zapashcanon
/
paper-wasocaml
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

clean code

main
zapashcanon 8 months ago
parent
1290936b3a
commit
b8a3b22838
Signed by: zapashcanon GPG Key ID: 8981C3C62D1D28F1
5 changed files with 72 additions and 84 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  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
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -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);

Write Preview
Loading…
Cancel
Save