Skip to content

Handle complex types in assertion wrapper modules #152

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
tlively wants to merge 1 commit into
base: cont-new-tests
Choose a base branch
from
+140 −21
Open

Handle complex types in assertion wrapper modules #152

Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
161 changes: 140 additions & 21 deletions interpreter/script/js.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -289,7 +289,6 @@ let lookup_export (env : env) x_opt name at =
let subject_idx = 0l
let hostref_idx = 1l
let eq_ref_idx = 2l
let subject_type_idx = 3l

let eq_of = function
| I32T -> I32 I32Op.Eq
Expand Down Expand Up @@ -331,13 +330,12 @@ let value v =
]
| Ref _ -> assert false

let invoke ft vs at =
let dt = RecT [SubT (Final, [], DefFuncT ft)] in
[dt @@ at], FuncImport (subject_type_idx @@ at) @@ at,
let invoke dt vs at =
FuncImport (0l @@ at) @@ at,
List.concat (List.map value vs) @ [Call (subject_idx @@ at) @@ at]

let get t at =
[], GlobalImport t @@ at, [GlobalGet (subject_idx @@ at) @@ at]
let get gt at =
GlobalImport gt @@ at, [GlobalGet (subject_idx @@ at) @@ at]

let run ts at =
[], []
Expand Down Expand Up @@ -470,7 +468,7 @@ let assert_return ress ts at =
BrIf (0l @@ at) @@ at ]
| RefResult (RefPat _) ->
assert false
| RefResult (RefTypePat (ExnHT | ExternHT)) ->
| RefResult (RefTypePat (ExnHT | ExternHT | ContHT)) ->
[ BrOnNull (0l @@ at) @@ at ]
| RefResult (RefTypePat t) ->
[ RefTest (NoNull, t) @@ at;
Expand Down Expand Up @@ -503,21 +501,137 @@ let eqref = RefT (Null, EqHT)
let func_rec_type ts1 ts2 at =
RecT [SubT (Final, [], DefFuncT (FuncT (ts1, ts2)))] @@ at

let wrap item_name wrap_action wrap_assertion at =
let itypes, idesc, action = wrap_action at in


let collect_and_sort_groups root_type =
let direct_deps rt =
let deps = ref [] in
let rec visit_ht = function
| DefHT (DefT (rt', _)) ->
if rt' != rt && not (List.exists (fun r -> r == rt') !deps) then
deps := rt' :: !deps
| _ -> ()
and visit_sub (SubT (_, hts, st)) =
List.iter visit_ht hts; visit_str st
and visit_str = function
| DefFuncT (FuncT (ins, outs)) ->
List.iter visit_val ins; List.iter visit_val outs
| DefContT (ContT ht) -> visit_ht ht
| DefStructT (StructT fields) ->
List.iter (fun (FieldT (_, st)) -> visit_storage st) fields
| DefArrayT (ArrayT (FieldT (_, st))) -> visit_storage st
and visit_storage = function
| ValStorageT t -> visit_val t
| _ -> ()
and visit_val = function
| RefT (_, ht) -> visit_ht ht
| _ -> ()
in
let RecT sts = rt in
List.iter visit_sub sts;
List.rev !deps
in
let visited = ref [] in
let sorted = ref [] in
let rec visit rt =
if not (List.exists (fun r -> r == rt) !visited) then begin
visited := rt :: !visited;
List.iter visit (direct_deps rt);
sorted := rt :: !sorted
end
in
let visit_root_ht = function
| DefHT (DefT (rt, _)) -> visit rt
| _ -> ()
in
let visit_root_val = function
| RefT (_, ht) -> visit_root_ht ht
| _ -> ()
in
visit_root_val root_type;
List.rev !sorted

let wrap item_name root_type wrap_action wrap_assertion at =
let idesc, action = wrap_action at in
let locals, assertion = wrap_assertion at in
let sorted_groups = collect_and_sort_groups root_type in
let base_map, total_custom_size =
List.fold_left (fun (map, idx) rt ->
let RecT sts = rt in
((rt, idx) :: map, Int32.add idx (Int32.of_int (List.length sts)))
) ([], 0l) sorted_groups
in
let get_base rt =
List.assq rt base_map
in
let remap_ht current_group_rt_opt = function
| DefHT (DefT (rt, i)) -> VarHT (StatX (Int32.add (get_base rt) i))
| VarHT (RecX i) ->
(match current_group_rt_opt with
| Some rt -> VarHT (StatX (Int32.add (get_base rt) i))
| None -> failwith "remap_ht: RecX outside group")
| ht -> ht
in
let remap_ref current_group_rt_opt (nul, ht) =
(nul, remap_ht current_group_rt_opt ht)
in
let remap_val current_group_rt_opt = function
| RefT rt -> RefT (remap_ref current_group_rt_opt rt)
| t -> t
in
let remap_storage current_group_rt_opt = function
| ValStorageT t -> ValStorageT (remap_val current_group_rt_opt t)
| st -> st
in
let remap_field current_group_rt_opt (FieldT (m, st)) =
FieldT (m, remap_storage current_group_rt_opt st)
in
let remap_func current_group_rt_opt (FuncT (ins, outs)) =
FuncT (List.map (remap_val current_group_rt_opt) ins,
List.map (remap_val current_group_rt_opt) outs)
in
let remap_str current_group_rt_opt = function
| DefFuncT ft -> DefFuncT (remap_func current_group_rt_opt ft)
| DefContT (ContT ht) -> DefContT (ContT (remap_ht current_group_rt_opt ht))
| DefStructT (StructT fields) ->
DefStructT (StructT (List.map (remap_field current_group_rt_opt) fields))
| DefArrayT (ArrayT f) ->
DefArrayT (ArrayT (remap_field current_group_rt_opt f))
in
let remap_sub current_group_rt_opt (SubT (fin, hts, st)) =
SubT (fin, List.map (remap_ht current_group_rt_opt) hts,
remap_str current_group_rt_opt st)
in
let custom_types =
List.map (fun rt ->
let RecT sts = rt in
let sts' = List.map (remap_sub (Some rt)) sts in
{it = RecT sts'; at = Source.no_region}
) sorted_groups
in
let run_type_idx = total_custom_size in
let hostref_type_idx = Int32.add total_custom_size 1l in
let eqref_type_idx = Int32.add total_custom_size 2l in
let types =
func_rec_type [] [] at ::
func_rec_type [i32] [anyref] at ::
func_rec_type [eqref; eqref] [i32] at ::
itypes
custom_types @
[ func_rec_type [] [] at;
func_rec_type [i32] [anyref] at;
func_rec_type [eqref; eqref] [i32] at;
]
in
let idesc' = match idesc.it, root_type with
| FuncImport _, RefT (_, DefHT (DefT (rt, i))) ->
FuncImport (Int32.add (get_base rt) i @@ at)
| GlobalImport t, _ -> GlobalImport t
| _ -> idesc.it
in
let idesc = {idesc with it = idesc'} in
let imports =
[ {module_name = Utf8.decode "module"; item_name; idesc} @@ at;
{module_name = Utf8.decode "spectest"; item_name = Utf8.decode "hostref";
idesc = FuncImport (1l @@ at) @@ at} @@ at;
idesc = FuncImport (hostref_type_idx @@ at) @@ at} @@ at;
{module_name = Utf8.decode "spectest"; item_name = Utf8.decode "eq_ref";
idesc = FuncImport (2l @@ at) @@ at} @@ at;
idesc = FuncImport (eqref_type_idx @@ at) @@ at} @@ at;
]
in
let item =
Expand All @@ -532,7 +646,7 @@ let wrap item_name wrap_action wrap_assertion at =
[ Block (ValBlockType None, action @ assertion @ [Return @@ at]) @@ at;
Unreachable @@ at ]
in
let funcs = [{ftype = 0l @@ at; locals; body} @@ at] in
let funcs = [{ftype = run_type_idx @@ at; locals; body} @@ at] in
let m = {empty_module with types; funcs; imports; exports} @@ at in
(try
Valid.check_module m; (* sanity check *)
Expand All @@ -553,7 +667,11 @@ let is_js_vec_type = function
| _ -> false

let is_js_ref_type = function
| (_, ExnHT) -> false
| (_, (ExnHT | NoExnHT | ContHT | NoContHT)) -> false
| (_, DefHT dt) ->
(match expand_def_type dt with
| DefContT _ -> false
| _ -> true)
| _ -> true

let is_js_val_type = function
Expand Down Expand Up @@ -665,9 +783,9 @@ let rec of_definition def =
try of_definition (snd (Parse.Module.parse_string ~offset:s.at s.it))
with Parse.Syntax _ | Custom.Syntax _ -> of_bytes "<malformed quote>"

let of_wrapper env x_opt name wrap_action wrap_assertion at =
let of_wrapper env x_opt name root_type wrap_action wrap_assertion at =
let x = of_inst_opt env x_opt in
let bs = wrap name wrap_action wrap_assertion at in
let bs = wrap name root_type wrap_action wrap_assertion at in
"call(instance(module(" ^ of_bytes bs ^ "), " ^
"exports(" ^ x ^ ")), " ^ " \"run\", [])"

Expand All @@ -678,19 +796,20 @@ let of_action env act =
"[" ^ String.concat ", " (List.map of_value vs) ^ "])",
(match lookup_export env x_opt name act.at with
| ExternFuncT dt ->
let root_type = RefT (NoNull, DefHT dt) in
let FuncT (_, out) as ft = as_func_str_type (expand_def_type dt) in
if is_js_func_type ft then
None
else
Some (of_wrapper env x_opt name (invoke ft vs), out)
Some (of_wrapper env x_opt name root_type (invoke dt vs), out)
| _ -> None
)
| Get (x_opt, name) ->
"get(" ^ of_inst_opt env x_opt ^ ", " ^ of_name name ^ ")",
(match lookup_export env x_opt name act.at with
| ExternGlobalT gt when not (is_js_global_type gt) ->
let GlobalT (_, t) = gt in
Some (of_wrapper env x_opt name (get gt), [t])
Some (of_wrapper env x_opt name t (get gt), [t])
| _ -> None
)

Expand Down