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

update to latest owi, fmt

Browse Source
This commit is contained in:
zapashcanon 2024-09-15 14:39:06 +02:00
parent 62d350f03d
commit 39869f551a
Signed by: zapashcanon
GPG Key ID: 8981C3C62D1D28F1
5 changed files with 107 additions and 117 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.ocamlformat
View File

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

4
src/flambda.ml
View File

@ -29,7 +29,7 @@ let () =
let modul = To_wasm.term ast
let () =
printf "%a@\n***@\n" Owi.Symbolic.Pp.modul modul;
printf "%a@\n***@\n" Owi.Text.pp_modul modul;
pp_print_flush std_formatter ()
let prefix = "flambda_generated_"
@ -43,7 +43,7 @@ let chan = open_out tmp_file
let fmt = formatter_of_out_channel chan
let () =
fprintf fmt "%a@\n" Owi.Symbolic.Pp.modul modul;
fprintf fmt "%a@\n" Owi.Text.pp_modul modul;
close_out chan
let n = Sys.command @@ sprintf "wasmgc %s -s" tmp_file

2
src/interpret.ml
View File

@ -280,7 +280,7 @@ let rec term envs store t =
end;
let t = Value v in
term envs store (Pop t)
(* other *)
(* other *)
| Static_raise (exn, ids) -> (envs, store, Exn (exn, ids))
let _ =

168
src/to_wasm.ml
View File

@ -1,7 +1,7 @@
open Types
module Wasopp = Pp
open Owi.Types
open Owi.Symbolic
open Owi.Text
let rec collect_closures = function
| Value _ | Identifier _ | Application _ | Mutate _ | Static_raise _
@ -97,12 +97,12 @@ and collect_var_offset_within_set_from_branch b =
(fun _i t offsets -> collect_var_offset_within_set t @ offsets)
b []
let get x = Local_get (Symbolic x)
let get x = Local_get (Text x)
let bt_ret_eq = Arg.Bt_raw (None, ([], [ Ref_type (Null, Eq_ht) ]))
let bt_ret_eq = Bt_raw (None, ([], [ Ref_type (Null, Eq_ht) ]))
let rec gen_expr = function
| Value (Scalar n) -> [ I32_const (Int32.of_int n); I31_new ]
| Value (Scalar n) -> [ I32_const (Int32.of_int n); Ref_i31 ]
| Identifier x -> [ get x ]
| Unary_op (op, x) -> begin
match op with
@ -110,10 +110,10 @@ let rec gen_expr = function
[ get x
; Ref_cast (No_null, I31_ht)
; I31_get_u
; Call (Symbolic "print_i32")
; Call (Text "print_i32")
; (* return unit ! *)
I32_const 0l
; I31_new
; Ref_i31
]
end
| Binary_op (x1, op, x2) -> begin
@ -126,7 +126,7 @@ let rec gen_expr = function
; Ref_cast (No_null, I31_ht)
; I31_get_u
; I_binop (S32, Add)
; I31_new
; Ref_i31
]
| Sub ->
[ get x1
@ -136,7 +136,7 @@ let rec gen_expr = function
; Ref_cast (No_null, I31_ht)
; I31_get_u
; I_binop (S32, Sub)
; I31_new
; Ref_i31
]
| Eq ->
[ get x1
@ -146,26 +146,26 @@ let rec gen_expr = function
; Ref_cast (No_null, I31_ht)
; I31_get_u
; I_relop (S32, Eq)
; I31_new
; Ref_i31
]
end
| Application (f, x) ->
[ get f
; Ref_cast (No_null, Def_ht (Symbolic "closure"))
; Ref_cast (No_null, Def_ht (Text "closure"))
; get x
; Ref_as_non_null
; get f
; Ref_cast (No_null, Def_ht (Symbolic "closure"))
; Struct_get (Symbolic "closure", Raw 0)
; Call_ref (Symbolic "mlfun")
; Ref_cast (No_null, Def_ht (Text "closure"))
; Struct_get (Text "closure", Raw 0)
; Call_ref (Text "mlfun")
]
| Let (x, t1, t2) -> gen_expr t1 @ [ Local_set (Symbolic x) ] @ gen_expr t2
| Let (x, t1, t2) -> gen_expr t1 @ [ Local_set (Text x) ] @ gen_expr t2
| Project_closure (x1, x2) ->
[ get x2
; Ref_cast (No_null, Def_ht (Symbolic "set_of_closures"))
; Struct_get (Symbolic "set_of_closures", Raw 0)
; Global_get (Symbolic (Format.sprintf "closure_offset_within_set_%s" x1))
; Array_get (Symbolic "closures")
; Ref_cast (No_null, Def_ht (Text "set_of_closures"))
; Struct_get (Text "set_of_closures", Raw 0)
; Global_get (Text (Format.sprintf "closure_offset_within_set_%s" x1))
; Array_get (Text "closures")
]
| Make_set_of_closures (clos, vars) ->
(* TODO: check what happens when len clos = 0 || len vars = 0 *)
@ -173,12 +173,12 @@ let rec gen_expr = function
List.fold_left
(fun expr (_x1, x2) -> expr @ [ get x2; Ref_as_non_null ])
[] vars
@ [ Array_new_fixed (Symbolic "vars", List.length vars) ]
@ [ Array_new_fixed (Text "vars", List.length vars) ]
in
let gen_set_with_null_closures =
(Ref_null (Def_ht (Symbolic "closures")) :: gen_vars)
@ [ Struct_new (Symbolic "set_of_closures")
; Global_set (Symbolic "tmp_set_of_closures")
(Ref_null (Def_ht (Text "closures")) :: gen_vars)
@ [ Struct_new (Text "set_of_closures")
; Global_set (Text "tmp_set_of_closures")
]
in
let gen_closures =
@ -187,19 +187,19 @@ let rec gen_expr = function
(fun (i, expr) (name, _env, _x, _t) ->
( succ i
, expr
@ [ Ref_func (Symbolic name)
; Global_get (Symbolic "tmp_set_of_closures")
; Struct_new (Symbolic "closure")
@ [ Ref_func (Text name)
; Global_get (Text "tmp_set_of_closures")
; Struct_new (Text "closure")
] ) )
(0, []) clos )
@ [ Array_new_fixed (Symbolic "closures", List.length clos) ]
@ [ Array_new_fixed (Text "closures", List.length clos) ]
in
gen_set_with_null_closures
@ [ Global_get (Symbolic "tmp_set_of_closures") ]
@ [ Global_get (Text "tmp_set_of_closures") ]
@ gen_closures
@ [ Struct_set (Symbolic "set_of_closures", Raw 0)
; Global_get (Symbolic "tmp_set_of_closures")
@ [ Struct_set (Text "set_of_closures", Raw 0)
; Global_get (Text "tmp_set_of_closures")
]
| Ite (x, t1, t2) ->
[ get x
@ -210,21 +210,21 @@ let rec gen_expr = function
]
| Project_var (x, env) ->
[ get env
; Ref_cast (No_null, Def_ht (Symbolic "closure"))
; Struct_get (Symbolic "closure", Raw 1)
; Ref_cast (No_null, Def_ht (Text "closure"))
; Struct_get (Text "closure", Raw 1)
; Ref_as_non_null
; Struct_get (Symbolic "set_of_closures", Raw 1)
; Global_get (Symbolic (Format.sprintf "var_offset_within_set_%s" x))
; Array_get (Symbolic "vars")
; Struct_get (Text "set_of_closures", Raw 1)
; Global_get (Text (Format.sprintf "var_offset_within_set_%s" x))
; Array_get (Text "vars")
]
| Move_within_closure (env, cl) ->
[ get env
; Ref_cast (No_null, Def_ht (Symbolic "closure"))
; Struct_get (Symbolic "closure", Raw 1)
; Ref_cast (No_null, Def_ht (Text "closure"))
; Struct_get (Text "closure", Raw 1)
; Ref_as_non_null
; Struct_get (Symbolic "set_of_closures", Raw 0)
; Global_get (Symbolic (Format.sprintf "closure_offset_within_set_%s" cl))
; Array_get (Symbolic "closures")
; Struct_get (Text "set_of_closures", Raw 0)
; Global_get (Text (Format.sprintf "closure_offset_within_set_%s" cl))
; Array_get (Text "closures")
]
| Static_catch (t1, exn, ids, t2) ->
[ Block
@ -233,50 +233,45 @@ let rec gen_expr = function
, [ Block
( Some (Format.sprintf "exn_%s" exn)
, Some
(Arg.Bt_raw
(Bt_raw
( None
, ( []
, Array.map (fun _ -> Ref_type (Null, Eq_ht)) ids
|> Array.to_list ) ) )
, gen_expr t1 @ [ Br (Symbolic "after_try_catch") ] )
, gen_expr t1 @ [ Br (Text "after_try_catch") ] )
]
@ (Array.map (fun id -> Local_set (Symbolic id)) ids |> Array.to_list)
@ (Array.map (fun id -> Local_set (Text id)) ids |> Array.to_list)
@ gen_expr t2 )
]
| Static_raise (exn, ids) ->
List.rev_map get (Array.to_list ids)
@ [ Br (Symbolic (Format.sprintf "exn_%s" exn)) ]
@ [ Br (Text (Format.sprintf "exn_%s" exn)) ]
| Mutate (x1, x2) ->
[ get x2
; Local_set (Symbolic x1)
; (* return unit ! *)
I32_const 0l
; I31_new
]
[ get x2; Local_set (Text x1); (* return unit ! *) I32_const 0l; Ref_i31 ]
| Make_block (tag, ids) ->
(I32_const (Int32.of_int tag) :: List.map get (Array.to_list ids))
@ [ Array_new_fixed (Symbolic "data", Array.length ids)
; Struct_new (Symbolic "block")
@ [ Array_new_fixed (Text "data", Array.length ids)
; Struct_new (Text "block")
]
| Get_field (i, b) ->
[ get b
; Ref_cast (No_null, Def_ht (Symbolic "block"))
; Struct_get (Symbolic "block", Raw 1)
; Ref_cast (No_null, Def_ht (Text "block"))
; Struct_get (Text "block", Raw 1)
; Ref_as_non_null
; I32_const (Int32.of_int i)
; Array_get (Symbolic "data")
; Array_get (Text "data")
]
| Set_field (i, b, x) ->
[ get b
; Ref_cast (No_null, Def_ht (Symbolic "block"))
; Struct_get (Symbolic "block", Raw 1)
; Ref_cast (No_null, Def_ht (Symbolic "data"))
; Ref_cast (No_null, Def_ht (Text "block"))
; Struct_get (Text "block", Raw 1)
; Ref_cast (No_null, Def_ht (Text "data"))
; I32_const (Int32.of_int i)
; get x
; Array_set (Symbolic "data")
; Array_set (Text "data")
; (* return unit ! *)
I32_const 0l
; I31_new
; Ref_i31
]
| While (_t_orig, t1, t2) ->
let t1 = gen_expr t1 in
@ -290,18 +285,18 @@ let rec gen_expr = function
, t1
@ [ I31_get_u
; I_testop (S32, Owi.Types.Eqz)
; Br_if (Symbolic "exit_while_loop")
; Br_if (Text "exit_while_loop")
]
@ t2 @ [ Drop; Br (Raw 0) ] )
] )
; I32_const 0l
; I31_new
; Ref_i31
]
| Switch (id, scalar_map, tag_map) ->
let gen_cases map =
Int_map.fold
(fun i t acc ->
[ Global_get (Symbolic "tmp_switch_value")
[ Global_get (Text "tmp_switch_value")
; I32_const (Int32.of_int i)
; I_relop (S32, Eq)
; If_else (None, Some bt_ret_eq, gen_expr t, acc)
@ -317,21 +312,20 @@ let rec gen_expr = function
( Some "switch_b"
, Some bt_ret_eq
, [ get id
; Br_on_cast
(Symbolic "switch_b", (Null, Eq_ht), (No_null, I31_ht))
; Br_on_cast (Text "switch_b", (Null, Eq_ht), (No_null, I31_ht))
(* handle tag case *)
; Ref_cast (No_null, Def_ht (Symbolic "block"))
; Struct_get (Symbolic "block", Raw 0)
; Global_set (Symbolic "tmp_switch_value")
; Ref_cast (No_null, Def_ht (Text "block"))
; Struct_get (Text "block", Raw 0)
; Global_set (Text "tmp_switch_value")
]
@ tag_case_test
@ [ (* br on switch a to skip the int case *)
Br (Symbolic "switch_a")
Br (Text "switch_a")
] )
(* handle int case *)
; Ref_cast (No_null, I31_ht)
; I31_get_s
; Global_set (Symbolic "tmp_switch_value")
; Global_set (Text "tmp_switch_value")
]
@ scalar_case_test )
]
@ -344,7 +338,7 @@ let mk_func (name, env, x, t) =
List.map (fun id -> (Some id, Ref_type (No_null, Eq_ht))) (collect_locals t)
in
let type_f =
Arg.Bt_raw
Bt_raw
( None
, ( [ (Some x, Ref_type (No_null, Eq_ht))
; (Some env, Ref_type (No_null, Eq_ht))
@ -379,8 +373,7 @@ let term t =
[ (None, [ (Const, Val_storage_t (Num_type I32)) ])
; ( None
, [ ( Const
, Val_storage_t (Ref_type (Null, Def_ht (Symbolic "data")))
)
, Val_storage_t (Ref_type (Null, Def_ht (Text "data"))) )
] )
] ) )
]
@ -395,36 +388,33 @@ let term t =
, Def_struct_t
[ ( None
, [ ( Var
, Val_storage_t
(Ref_type (Null, Def_ht (Symbolic "closures"))) )
, Val_storage_t (Ref_type (Null, Def_ht (Text "closures")))
)
] )
; ( None
, [ ( Const
, Val_storage_t (Ref_type (Null, Def_ht (Symbolic "vars")))
)
, Val_storage_t (Ref_type (Null, Def_ht (Text "vars"))) )
] )
] ) )
; ( Some "closures"
, ( Owi.Types.Final
, []
, Def_array_t
( Var
, Val_storage_t (Ref_type (No_null, Def_ht (Symbolic "closure")))
) ) )
(Var, Val_storage_t (Ref_type (No_null, Def_ht (Text "closure"))))
) )
; ( Some "closure"
, ( Owi.Types.Final
, []
, Def_struct_t
[ ( None
, [ ( Const
, Val_storage_t
(Ref_type (No_null, Def_ht (Symbolic "mlfun"))) )
, Val_storage_t (Ref_type (No_null, Def_ht (Text "mlfun")))
)
] )
; ( None
, [ ( Var
, Val_storage_t
(Ref_type (Null, Def_ht (Symbolic "set_of_closures")))
)
(Ref_type (Null, Def_ht (Text "set_of_closures"))) )
] )
] ) )
]
@ -445,10 +435,10 @@ let term t =
let elems =
[ (let id = None in
let typ = (Owi.Types.No_null, Def_ht (Symbolic "mlfun")) in
let typ = (Owi.Types.No_null, Def_ht (Text "mlfun")) in
let mode = Elem_declarative in
let init =
List.map (fun (name, _, _, _) -> [ Ref_func (Symbolic name) ]) closures
List.map (fun (name, _, _, _) -> [ Ref_func (Text name) ]) closures
in
{ id; typ; mode; init } )
]
@ -457,8 +447,8 @@ let term t =
(* globals *)
let globals =
{ id = Some "tmp_set_of_closures"
; init = [ Ref_null (Def_ht (Symbolic "set_of_closures")) ]
; typ = (Owi.Types.Var, Ref_type (Null, Def_ht (Symbolic "set_of_closures")))
; init = [ Ref_null (Def_ht (Text "set_of_closures")) ]
; typ = (Owi.Types.Var, Ref_type (Null, Def_ht (Text "set_of_closures")))
}
:: { id = Some "tmp_switch_value"
; init = [ I32_const 0l ]
@ -496,7 +486,7 @@ let term t =
(* exports *)
let exports =
[ { name = {|"start"|}; desc = Export_func (Some (Symbolic "start")) } ]
[ { name = {|"start"|}; desc = Export_func (Some (Text "start")) } ]
in
(* module *)
@ -507,7 +497,7 @@ let term t =
@ List.map (fun e -> MElem e) elems
@ List.map (fun f -> MFunc f) funcs
@ List.map (fun e -> MExport e) exports
@ [ MStart (Symbolic "start") ]
@ [ MStart (Text "start") ]
in
let id = Some "wasocaml_generated_modul" in
let modul = { id; fields } in

48
test/fuzz/gen.ml
View File

@ -71,9 +71,9 @@ let is_keyword =
let id =
fix (fun id ->
let* chars = list1 id_char in
let id_s = List.to_seq chars |> String.of_seq in
if is_keyword id_s then id else const id_s )
let* chars = list1 id_char in
let id_s = List.to_seq chars |> String.of_seq in
if is_keyword id_s then id else const id_s )
let scalar =
let+ int in
@ -197,24 +197,24 @@ let unary_op =
let term =
fix (fun term ->
choose
[ value
; identifier
; letbind term
; apply
; mutate
; ite term
; switch term
; static_raise
; static_catch term
; whil term
; get_field
; set_field
; make_block
; project_closure
; project_var
; move_within_closures
; make_set_of_closures term
; binary_op
; unary_op
] )
choose
[ value
; identifier
; letbind term
; apply
; mutate
; ite term
; switch term
; static_raise
; static_catch term
; whil term
; get_field
; set_field
; make_block
; project_closure
; project_var
; move_within_closures
; make_set_of_closures term
; binary_op
; unary_op
] )