Browse Source

clean code

main
zapashcanon 1 year ago
parent
commit
b8a3b22838
Signed by: zapashcanon GPG Key ID: 8981C3C62D1D28F1
  1. 2
      .ocamlformat
  2. 35
      src/dune
  3. 6
      src/flambda_core_ast.ml
  4. 108
      src/interpret.ml
  5. 5
      src/menhir_parser.mly

2
.ocamlformat

@ -1,4 +1,4 @@
version=0.24.1
version=0.25.1
assignment-operator=end-line
break-cases=fit
break-fun-decl=wrap

35
src/dune

@ -1,11 +1,6 @@
(rule
(targets main.pdf)
(deps
article.tex
main.bbl
main.tex
packages.tex
)
(deps article.tex main.bbl main.tex packages.tex)
(action
(pipe-outputs
(run texfot xelatex -halt-on-error -shell-escape main.tex)
@ -29,24 +24,22 @@
(rule
(targets main.bcf)
(deps
article.tex
main.tex
packages.tex
)
(deps article.tex main.tex packages.tex)
(action
(run texfot xelatex -halt-on-error -shell-escape main.tex)))
(run texfot xelatex -halt-on-error -shell-escape main.tex)))
(executable
(name main)
(modules main)
(libraries wasocaml_core))
(name main)
(modules main)
(libraries wasocaml_core))
(library
(name wasocaml_core)
(modules flambda_core_ast interpret menhir_parser parse lexer)
(private_modules menhir_parser lexer)
(libraries menhirLib sedlex)
(preprocess (pps sedlex.ppx)))
(name wasocaml_core)
(modules flambda_core_ast interpret menhir_parser parse lexer)
(private_modules menhir_parser lexer)
(libraries menhirLib sedlex)
(preprocess
(pps sedlex.ppx)))
(menhir (modules menhir_parser))
(menhir
(modules menhir_parser))

6
src/flambda_core_ast.ml

@ -17,7 +17,7 @@ and named =
| Print_int of id
| Apply of id * id
| Get_field of int * id
| Make_block of int * id list
| Make_block of int * id array
| Make_closures of closure list * (id * id) list
| Project_closure of id * id
| Project_var of id * id
@ -34,6 +34,8 @@ let pp_ids fmt ids =
~pp_sep:(fun fmt () -> Format.fprintf fmt " ")
pp_id fmt ids
let pp_ids_array fmt ids = pp_ids fmt (Array.to_list ids)
let rec pp_term fmt = function
| Variable id -> pp_id fmt id
| Let (id, named, t) ->
@ -73,7 +75,7 @@ and pp_named fmt = function
| Print_int id -> pp fmt "print_int %a" pp_id id
| Apply (id, id') -> pp fmt "%a %a" pp_id id pp_id id'
| Get_field (n, id) -> pp fmt "get_field %d %a" n pp_id id
| Make_block (n, ids) -> pp fmt "make_block %d %a" n pp_ids ids
| Make_block (n, ids) -> pp fmt "make_block %d %a" n pp_ids_array ids
| Make_closures (closures, env) ->
let pp_closure fmt closure = Format.fprintf fmt "| %a" pp_closure closure in
let pp_closures fmt closures =

108
src/interpret.ml

@ -1,5 +1,11 @@
open Flambda_core_ast
let log =
let debug = false in
if debug then Format.fprintf else Format.ifprintf
let fmt = Format.err_formatter
module Value = struct
type closure =
{ parent : set_of_closures
@ -8,9 +14,11 @@ module Value = struct
; env_name : id
}
and set_of_closures = var_set * (string, closure) Hashtbl.t
and var_set = (string * t) list
and set_of_closures =
{ var_set : (string, t) Hashtbl.t
; (* closure_set needs to be mutable as it needs a reference to itself to be constructed *)
closure_set : (string, closure) Hashtbl.t
}
and block =
{ tag : int
@ -23,13 +31,8 @@ module Value = struct
| Closure of closure
| Set_of_closure of set_of_closures
let unit = Scalar 0
let bool b = if b then Scalar 1 else Scalar 0
let closure parent code ~env_name ~var_name =
Closure { parent; code; env_name; var_name }
let to_bool = function Scalar n -> n <> 0 | _ -> assert false
let to_closure = function Closure closure -> closure | _ -> assert false
@ -42,34 +45,23 @@ module Value = struct
| Set_of_closure set -> set
| _ -> assert false
let get_closure (_var_set, clos_set) name =
let code = Hashtbl.find clos_set name in
Closure code
let rec pp fmt = function
| Block b -> Format.fprintf fmt "block %a" pp_block b
| Scalar n -> Format.fprintf fmt "scalar %d" n
| Set_of_closure _ -> Format.fprintf fmt "set_of_closures"
| Closure _ -> Format.fprintf fmt "closure"
| Block b -> log fmt "block %a" pp_block b
| Scalar n -> log fmt "scalar %d" n
| Set_of_closure _ -> log fmt "set_of_closures"
| Closure _ -> log fmt "closure"
and pp_block fmt b =
Format.fprintf fmt "{ tag = %d ; [ %a ]}" b.tag
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt " ; ") pp)
log fmt "{ tag = %d ; [ %a ]}" b.tag
(Format.pp_print_list ~pp_sep:(fun fmt () -> log fmt " ; ") pp)
(Array.to_list b.data)
let pp_var_set fmt var_set =
Format.fprintf fmt "{ %a }"
log fmt "{ %a }"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt " ; ")
(fun fmt (k, v) -> Format.fprintf fmt "%s = %a" k pp v) )
~pp_sep:(fun fmt () -> log fmt " ; ")
(fun fmt (k, v) -> log fmt "%s = %a" k pp v) )
var_set
let project_var (var_set, _clos_set) name =
Format.eprintf "looking for %s in %a@\n" name pp_var_set var_set;
let _name, value =
List.find (fun (name', _value) -> name = name') var_set
in
value
end
module Id_map = struct
@ -102,19 +94,19 @@ module Env = struct
{ id_map }
let pp fmt env =
Format.fprintf fmt "{@\n";
log fmt "{@\n";
Id_map.iter
(fun k v -> Format.fprintf fmt " %a = %a@\n" pp_id k Value.pp v)
(fun k v -> log fmt " %a = %a@\n" pp_id k Value.pp v)
env.id_map;
Format.fprintf fmt "}"
log fmt "}"
end
exception Static_raise of id * id list
let rec eval_term env term =
Format.eprintf "***** env is %a@\n" Env.pp env;
Format.eprintf "***** EVAL TERM@\n";
Format.eprintf " %a@\n" pp_term term;
log fmt "***** env is %a@\n" Env.pp env;
log fmt "***** EVAL TERM@\n";
log fmt " %a@\n" pp_term term;
match term with
| Variable id -> (env, Env.find_id env id)
| Let (id, named, term) ->
@ -124,7 +116,7 @@ let rec eval_term env term =
| Mutate (id, id') ->
let v = Env.find_id env id' in
let env = Env.add_id env id v in
(env, Value.unit)
(env, Value.Scalar 0)
| If_then_else (cond, t1, t2) ->
let cond = Env.find_bool env cond in
let term = if cond then t1 else t2 in
@ -134,7 +126,7 @@ let rec eval_term env term =
if Value.to_bool v then
let env, _v = eval_term env t in
eval_term env (While (cond, t))
else (env, Value.unit)
else (env, Value.Scalar 0)
| Raise (id, ids) -> raise (Static_raise (id, ids))
| Try_catch (t, id, _ids, t') -> begin
(* TODO: _ids ? *)
@ -155,9 +147,9 @@ let rec eval_term env term =
eval_term env term
and eval_named env i =
Format.eprintf "***** env is %a@\n" Env.pp env;
Format.eprintf "***** EVAL NAMED@\n";
Format.eprintf " %a@\n" pp_named i;
log fmt "***** env is %a@\n" Env.pp env;
log fmt "***** EVAL NAMED@\n";
log fmt " %a@\n" pp_named i;
match i with
| Const n ->
let v = Value.Scalar n in
@ -171,53 +163,51 @@ and eval_named env i =
let v = Env.find_scalar env id in
let v' = Env.find_scalar env id' in
(* TODO: ? *)
let eq = Value.bool @@ (v = v') in
let eq = if v = v' then Value.Scalar 1 else Scalar 0 in
(env, eq)
| Print_int id ->
let n = Env.find_scalar env id in
Format.printf "%d@\n" n;
(env, Value.unit)
(env, Value.Scalar 0)
| Apply (f, v) ->
let closure = Env.find_closure env f in
let closure_env = Env.find_id env f in
let env' = Env.add_id env closure.env_name closure_env in
let v = Env.find_id env v in
let env' = Env.add_id env' closure.var_name v in
eval_term env' closure.code
let _env, term = eval_term env' closure.code in
(env, term)
| Get_field (n, id) ->
let block = Env.find_block env id in
let field = block.data.(n) in
(env, field)
| Make_block (tag, ids) ->
let data = Array.of_list @@ List.map (Env.find_id env) ids in
let data = Array.map (Env.find_id env) ids in
let block = Value.Block { tag; data } in
(env, block)
| Make_closures (closures, var_set) ->
let var_set = List.map (fun (k, v) -> (k, Env.find_id env v)) var_set in
| Make_closures (closures, vars) ->
let var_set = Hashtbl.create 512 in
List.iter (fun (k, v) -> Hashtbl.add var_set k (Env.find_id env v)) vars;
let closure_set = Hashtbl.create 512 in
let set_unwrap = (var_set, closure_set) in
let set = { Value.var_set; closure_set } in
List.iter
(fun (name, var_name, env_name, term) ->
let closure = Value.closure set_unwrap term ~var_name ~env_name in
let closure_unboxed = Value.to_closure closure in
Hashtbl.add closure_set name closure_unboxed )
(fun (name, var_name, env_name, code) ->
let closure = { Value.code; env_name; var_name; parent = set } in
Hashtbl.add closure_set name closure )
closures;
let set = Value.Set_of_closure set_unwrap in
let set = Value.Set_of_closure set in
(env, set)
| Project_closure (closure_name, set) ->
let set = Env.find_set_of_closures env set in
let term = Value.get_closure set closure_name in
let term = Value.Closure (Hashtbl.find set.closure_set closure_name) in
(env, term)
| Move_within_closure (closure_env, closure_name) ->
let closure = Env.find_closure env closure_env in
let term = Value.get_closure closure.parent closure_name in
let term =
Value.Closure (Hashtbl.find closure.parent.closure_set closure_name)
in
(env, term)
| Project_var (var_name, set) ->
let closure = Env.find_closure env set in
let term = Value.project_var closure.parent var_name in
let term = Hashtbl.find closure.parent.var_set var_name in
(env, term)

5
src/menhir_parser.mly

@ -49,7 +49,10 @@ let named ==
| i1 = id; DOUBLE_EQUAL; i2 = id; <Physical_eq>
| i1 = id; i2 = id; <Apply>
| GET_FIELD; ~ = num; ~ = id; <Get_field>
| MAKE_BLOCK; ~ = num; ~ = list(id); <Make_block>
| MAKE_BLOCK; ~ = num; ids = list(id); {
let ids = Array.of_list ids in
Make_block (num, ids)
}
| MAKE_CLOSURES;
(* TODO: can this be empty ? *)
~ = list(closures);

Loading…
Cancel
Save