From 364c37c2705176e6227b6407063a9af5f05568f5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Tue, 8 Oct 2024 15:36:32 +0200 Subject: [PATCH 1/3] WAT output: no longer emit 'pop' instructions This instruction is not standard and the Binaryen parser no longer needs it. --- compiler/lib/wasm/wa_wat_output.ml | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/compiler/lib/wasm/wa_wat_output.ml b/compiler/lib/wasm/wa_wat_output.ml index a01874b4e..1d66b078d 100644 --- a/compiler/lib/wasm/wa_wat_output.ml +++ b/compiler/lib/wasm/wa_wat_output.ml @@ -19,8 +19,6 @@ open! Stdlib open Wa_ast -let target = `Binaryen (*`Reference*) - let assign_names ?(reversed = true) f names = let used = ref StringSet.empty in let counts = Hashtbl.create 101 in @@ -394,10 +392,7 @@ let expression_or_instructions ctx st in_function = ] | MemoryGrow (_, e) -> [ List (Atom "memory.grow" :: expression e) ] | Seq (l, e) -> instructions l @ expression e - | Pop ty -> ( - match target with - | `Binaryen -> [ List [ Atom "pop"; value_type st ty ] ] - | `Reference -> []) + | Pop _ -> [] | RefFunc symb -> if in_function then reference_function ctx symb; [ List [ Atom "ref.func"; index st.func_names symb ] ] From 5f736b1d10590ae2457f3630bd02aa5bddeeb9cf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Tue, 8 Oct 2024 15:42:35 +0200 Subject: [PATCH 2/3] Use Js_of_ocaml_compiler.Structure instead of Wa_structure Module Structure was basically copied from Wa_structure. --- compiler/lib/generate.ml | 2 +- compiler/lib/structure.ml | 4 +- compiler/lib/structure.mli | 2 + compiler/lib/wasm/wa_generate.ml | 18 +-- compiler/lib/wasm/wa_globalize.ml | 2 +- compiler/lib/wasm/wa_globalize.mli | 2 +- compiler/lib/wasm/wa_structure.ml | 251 ----------------------------- compiler/lib/wasm/wa_structure.mli | 37 ----- 8 files changed, 17 insertions(+), 301 deletions(-) delete mode 100644 compiler/lib/wasm/wa_structure.ml delete mode 100644 compiler/lib/wasm/wa_structure.mli diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml index 3d1a0a6ee..8ce83db0b 100644 --- a/compiler/lib/generate.ml +++ b/compiler/lib/generate.ml @@ -1642,7 +1642,7 @@ and compile_block_no_loop st queue (pc : Addr.t) ~fall_through scope_stack = | true -> never, [ J.Labelled_statement (l, (J.Block inner, J.N)), J.N ] @ code | false -> never, inner @ code) in - let never_after, after = loop ~scope_stack ~fall_through (List.rev new_scopes) in + let never_after, after = loop ~scope_stack ~fall_through new_scopes in never_after, seq @ after and compile_decision_tree kind st scope_stack loc cx dtree ~fall_through = diff --git a/compiler/lib/structure.ml b/compiler/lib/structure.ml index 503b6021e..3fe927bbb 100644 --- a/compiler/lib/structure.ml +++ b/compiler/lib/structure.ml @@ -147,7 +147,9 @@ let is_loop_header g pc = Addr.Set.exists (fun pc' -> Hashtbl.find g.block_order pc' >= o) s let sort_in_post_order t l = - List.sort ~cmp:(fun a b -> compare (block_order t a) (block_order t b)) l + List.sort ~cmp:(fun a b -> compare (block_order t b) (block_order t a)) l + +let blocks_in_reverse_post_order g = g.reverse_post_order (* diff --git a/compiler/lib/structure.mli b/compiler/lib/structure.mli index 6278174c6..1aa1a1094 100644 --- a/compiler/lib/structure.mli +++ b/compiler/lib/structure.mli @@ -21,4 +21,6 @@ val is_loop_header : t -> Addr.t -> bool val sort_in_post_order : t -> Addr.t list -> Addr.t list +val blocks_in_reverse_post_order : t -> Code.Addr.t list + val get_nodes : t -> Addr.Set.t diff --git a/compiler/lib/wasm/wa_generate.ml b/compiler/lib/wasm/wa_generate.ml index 15e99e3fa..49f413fef 100644 --- a/compiler/lib/wasm/wa_generate.ml +++ b/compiler/lib/wasm/wa_generate.ml @@ -856,15 +856,15 @@ module Generate (Target : Wa_target_sig.S) = struct ~pc ~params in - let g = Wa_structure.build_graph ctx.blocks pc in - let dom = Wa_structure.dominator_tree g in + let g = Structure.build_graph ctx.blocks pc in + let dom = Structure.dominator_tree g in let rec translate_tree result_typ fall_through pc context = let block = Addr.Map.find pc ctx.blocks in let keep_ouside pc' = match fst block.branch with | Switch _ -> true | Cond (_, (pc1, _), (pc2, _)) when pc' = pc1 && pc' = pc2 -> true - | _ -> Wa_structure.is_merge_node g pc' + | _ -> Structure.is_merge_node g pc' in let code ~context = translate_node_within @@ -873,13 +873,13 @@ module Generate (Target : Wa_target_sig.S) = struct ~pc ~l: (pc - |> Wa_structure.get_edges dom + |> Structure.get_edges dom |> Addr.Set.elements |> List.filter ~f:keep_ouside - |> Wa_structure.sort_in_post_order g) + |> Structure.sort_in_post_order g) ~context in - if Wa_structure.is_loop_header g pc + if Structure.is_loop_header g pc then loop { params = []; result = result_typ } (code ~context:(`Block pc :: context)) else code ~context @@ -943,7 +943,7 @@ module Generate (Target : Wa_target_sig.S) = struct List.filter ~f:(fun pc' -> Stack.stack_adjustment_needed stack_ctx ~src:pc ~dst:pc') - (List.rev (Addr.Set.elements (Wa_structure.get_edges dom pc))) + (List.rev (Addr.Set.elements (Structure.get_edges dom pc))) in let br_table e a context = let len = Array.length a in @@ -999,8 +999,8 @@ module Generate (Target : Wa_target_sig.S) = struct match fall_through with | `Block dst' when dst = dst' -> return () | _ -> - if (src >= 0 && Wa_structure.is_backward g src dst) - || Wa_structure.is_merge_node g dst + if (src >= 0 && Structure.is_backward g src dst) + || Structure.is_merge_node g dst then instr (Br (label_index context dst, None)) else translate_tree result_typ fall_through dst context in diff --git a/compiler/lib/wasm/wa_globalize.ml b/compiler/lib/wasm/wa_globalize.ml index 5c2cc2d47..5a255b767 100644 --- a/compiler/lib/wasm/wa_globalize.ml +++ b/compiler/lib/wasm/wa_globalize.ml @@ -104,7 +104,7 @@ let traverse_block p st pc = List.fold_left ~f:(fun st i -> traverse_instruction st i) ~init:st b.Code.body let f p g closures = - let l = Wa_structure.blocks_in_reverse_post_order g in + let l = Structure.blocks_in_reverse_post_order g in let in_loop = Freevars.find_loops_in_closure p p.Code.start in let st = List.fold_left diff --git a/compiler/lib/wasm/wa_globalize.mli b/compiler/lib/wasm/wa_globalize.mli index 9819b18f4..efbc79aa7 100644 --- a/compiler/lib/wasm/wa_globalize.mli +++ b/compiler/lib/wasm/wa_globalize.mli @@ -18,6 +18,6 @@ val f : Code.program - -> Wa_structure.control_flow_graph + -> Structure.t -> Wa_closure_conversion.closure Code.Var.Map.t -> Code.Var.Set.t diff --git a/compiler/lib/wasm/wa_structure.ml b/compiler/lib/wasm/wa_structure.ml deleted file mode 100644 index 520465a56..000000000 --- a/compiler/lib/wasm/wa_structure.ml +++ /dev/null @@ -1,251 +0,0 @@ -(* Wasm_of_ocaml compiler - * http://www.ocsigen.org/js_of_ocaml/ - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) - -open Stdlib -open Code - -type graph = (Addr.t, Addr.Set.t) Hashtbl.t - -let get_edges g src = try Hashtbl.find g src with Not_found -> Addr.Set.empty - -let add_edge g src dst = Hashtbl.replace g src (Addr.Set.add dst (get_edges g src)) - -let reverse_graph g = - let g' = Hashtbl.create 16 in - Hashtbl.iter - (fun child parents -> Addr.Set.iter (fun parent -> add_edge g' parent child) parents) - g; - g' - -let reverse_tree t = - let g = Hashtbl.create 16 in - Hashtbl.iter (fun child parent -> add_edge g parent child) t; - g - -type control_flow_graph = - { succs : (Addr.t, Addr.Set.t) Hashtbl.t - ; preds : (Addr.t, Addr.Set.t) Hashtbl.t - ; reverse_post_order : Addr.t list - ; block_order : (Addr.t, int) Hashtbl.t - } - -let is_backward g pc pc' = Hashtbl.find g.block_order pc >= Hashtbl.find g.block_order pc' - -let is_forward g pc pc' = Hashtbl.find g.block_order pc < Hashtbl.find g.block_order pc' - -(* pc has at least two forward edges moving into it *) -let is_merge_node' block_order preds pc = - let s = try Hashtbl.find preds pc with Not_found -> Addr.Set.empty in - let o = Hashtbl.find block_order pc in - let n = - Addr.Set.fold (fun pc' n -> if Hashtbl.find block_order pc' < o then n + 1 else n) s 0 - in - n > 1 - -let rec leave_try_body block_order preds blocks pc = - if is_merge_node' block_order preds pc - then false - else - match Addr.Map.find pc blocks with - | { body = []; branch = (Return _ | Stop), _; _ } -> false - | { body = []; branch = Branch (pc', _), _; _ } -> - leave_try_body block_order preds blocks pc' - | _ -> true - -let build_graph blocks pc = - let succs = Hashtbl.create 16 in - let l = ref [] in - let visited = Hashtbl.create 16 in - let poptraps = ref [] in - let rec traverse ~englobing_exn_handlers pc = - if not (Hashtbl.mem visited pc) - then ( - Hashtbl.add visited pc (); - let successors = Code.fold_children blocks pc Addr.Set.add Addr.Set.empty in - Hashtbl.add succs pc successors; - let block = Addr.Map.find pc blocks in - Addr.Set.iter - (fun pc' -> - let englobing_exn_handlers = - match fst block.branch with - | Pushtrap ((body_pc, _), _, _) when pc' = body_pc -> - pc :: englobing_exn_handlers - | Poptrap (leave_pc, _) -> ( - match englobing_exn_handlers with - | [] -> assert false - | enter_pc :: rem -> - poptraps := (enter_pc, leave_pc) :: !poptraps; - rem) - | _ -> englobing_exn_handlers - in - traverse ~englobing_exn_handlers pc') - successors; - l := pc :: !l) - in - traverse ~englobing_exn_handlers:[] pc; - let block_order = Hashtbl.create 16 in - List.iteri !l ~f:(fun i pc -> Hashtbl.add block_order pc i); - let preds = reverse_graph succs in - List.iter !poptraps ~f:(fun (enter_pc, leave_pc) -> - if leave_try_body block_order preds blocks leave_pc - then ( - (* Add an edge to limit the [try] body *) - Hashtbl.replace - succs - enter_pc - (Addr.Set.add leave_pc (Hashtbl.find succs enter_pc)); - Hashtbl.replace - preds - leave_pc - (Addr.Set.add enter_pc (Hashtbl.find preds leave_pc)))); - { succs; preds; reverse_post_order = !l; block_order } - -let reversed_dominator_tree g = - (* A Simple, Fast Dominance Algorithm - Keith D. Cooper, Timothy J. Harvey, and Ken Kennedy *) - let dom = Hashtbl.create 16 in - let rec inter pc pc' = - (* Compute closest common ancestor *) - if pc = pc' - then pc - else if is_forward g pc pc' - then inter pc (Hashtbl.find dom pc') - else inter (Hashtbl.find dom pc) pc' - in - List.iter g.reverse_post_order ~f:(fun pc -> - let l = Hashtbl.find g.succs pc in - Addr.Set.iter - (fun pc' -> - if is_forward g pc pc' - then - let d = try inter pc (Hashtbl.find dom pc') with Not_found -> pc in - Hashtbl.replace dom pc' d) - l); - (* Check we have reached a fixed point (reducible graph) *) - List.iter g.reverse_post_order ~f:(fun pc -> - let l = Hashtbl.find g.succs pc in - Addr.Set.iter - (fun pc' -> - if is_forward g pc pc' - then - let d = Hashtbl.find dom pc' in - assert (inter pc d = d)) - l); - dom - -let dominator_tree g = reverse_tree (reversed_dominator_tree g) - -(* pc has at least two forward edges moving into it *) -let is_merge_node g pc = is_merge_node' g.block_order g.preds pc - -let is_loop_header g pc = - let s = try Hashtbl.find g.preds pc with Not_found -> Addr.Set.empty in - let o = Hashtbl.find g.block_order pc in - Addr.Set.exists (fun pc' -> Hashtbl.find g.block_order pc' >= o) s - -let sort_in_post_order g l = - List.sort - ~cmp:(fun b b' -> - compare (Hashtbl.find g.block_order b') (Hashtbl.find g.block_order b)) - l - -let blocks_in_reverse_post_order g = g.reverse_post_order - -(* Compute a map from each block to the set of loops it belongs to *) -let mark_loops g = - let in_loop = Hashtbl.create 16 in - Hashtbl.iter - (fun pc preds -> - let rec mark_loop pc' = - if not (Addr.Set.mem pc (get_edges in_loop pc')) - then ( - add_edge in_loop pc' pc; - if pc' <> pc then Addr.Set.iter mark_loop (Hashtbl.find g.preds pc')) - in - Addr.Set.iter (fun pc' -> if is_backward g pc' pc then mark_loop pc') preds) - g.preds; - in_loop - -let rec measure blocks g pc limit = - let b = Addr.Map.find pc blocks in - let limit = limit - List.length b.body in - if limit < 0 - then limit - else - Addr.Set.fold - (fun pc limit -> if limit < 0 then limit else measure blocks g pc limit) - (get_edges g.succs pc) - limit - -let is_small blocks g pc = measure blocks g pc 20 >= 0 - -(* V8 uses the distance between the position of a backward jump and - the loop header as an estimation of the cost of executing the loop, - to decide whether to optimize a function containing a loop. So, for - a large function when the loop includes all the remaining code, the - estimation can be widely off. In particular, it may decide to - optimize the toplevel code, which is especially costly since it is - very large, and uncessary since it is executed only once. *) -let shrink_loops blocks ({ succs; preds; reverse_post_order; _ } as g) = - let add_edge pred succ = - Hashtbl.replace succs pred (Addr.Set.add succ (Hashtbl.find succs pred)); - Hashtbl.replace preds succ (Addr.Set.add pred (Hashtbl.find preds succ)) - in - let in_loop = mark_loops g in - let dom = dominator_tree g in - let root = List.hd reverse_post_order in - let rec traverse ignored pc = - let succs = get_edges dom pc in - let loops = get_edges in_loop pc in - let block = Addr.Map.find pc blocks in - Addr.Set.iter - (fun pc' -> - (* Whatever is in the scope of an exception handler should not be - moved outside *) - let ignored = - match fst block.branch with - | Pushtrap ((body_pc, _), _, _) when pc' = body_pc -> - Addr.Set.union ignored loops - | _ -> ignored - in - let loops' = get_edges in_loop pc' in - let left_loops = Addr.Set.diff (Addr.Set.diff loops loops') ignored in - (* If we leave a loop, we add an edge from a predecessor of - the loop header to the current block, so that it is - considered outside of the loop. *) - if not (Addr.Set.is_empty left_loops || is_small blocks g pc') - then - Addr.Set.iter - (fun pc0 -> - match - Addr.Set.find_first - (fun pc -> is_forward g pc pc0) - (get_edges g.preds pc0) - with - | pc -> add_edge pc pc' - | exception Not_found -> ()) - left_loops; - traverse ignored pc') - succs - in - traverse Addr.Set.empty root - -let build_graph blocks pc = - let g = build_graph blocks pc in - shrink_loops blocks g; - g diff --git a/compiler/lib/wasm/wa_structure.mli b/compiler/lib/wasm/wa_structure.mli deleted file mode 100644 index 53be40e9d..000000000 --- a/compiler/lib/wasm/wa_structure.mli +++ /dev/null @@ -1,37 +0,0 @@ -(* Wasm_of_ocaml compiler - * http://www.ocsigen.org/js_of_ocaml/ - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) - -type graph - -val get_edges : graph -> Code.Addr.t -> Code.Addr.Set.t - -type control_flow_graph - -val build_graph : Code.block Code.Addr.Map.t -> Code.Addr.t -> control_flow_graph - -val dominator_tree : control_flow_graph -> graph - -val is_loop_header : control_flow_graph -> Code.Addr.t -> bool - -val is_merge_node : control_flow_graph -> Code.Addr.t -> bool - -val is_backward : control_flow_graph -> Code.Addr.t -> Code.Addr.t -> bool - -val sort_in_post_order : control_flow_graph -> Code.Addr.t list -> Code.Addr.t list - -val blocks_in_reverse_post_order : control_flow_graph -> Code.Addr.t list From f4f188a63551caf94685e257f0daad99c1f43eee Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Tue, 8 Oct 2024 16:27:00 +0200 Subject: [PATCH 3/3] Remove code corresponding to an hypothetical core Wasm support --- compiler/lib/wasm/wa_asm_output.ml | 679 ------------------ compiler/lib/wasm/wa_asm_output.mli | 19 - compiler/lib/wasm/wa_ast.ml | 30 +- compiler/lib/wasm/wa_code_generation.ml | 42 +- compiler/lib/wasm/wa_code_generation.mli | 8 +- compiler/lib/wasm/wa_core_target.ml | 684 ------------------ compiler/lib/wasm/wa_core_target.mli | 19 - compiler/lib/wasm/wa_curry.ml | 140 +--- compiler/lib/wasm/wa_gc_target.ml | 84 +-- compiler/lib/wasm/wa_generate.ml | 461 +++++-------- compiler/lib/wasm/wa_initialize_locals.ml | 11 +- compiler/lib/wasm/wa_liveness.ml | 246 ------- compiler/lib/wasm/wa_liveness.mli | 38 - compiler/lib/wasm/wa_spilling.ml | 805 ---------------------- compiler/lib/wasm/wa_spilling.mli | 89 --- compiler/lib/wasm/wa_tail_call.ml | 7 - compiler/lib/wasm/wa_target_sig.ml | 71 +- compiler/lib/wasm/wa_wasm_output.ml | 36 +- compiler/lib/wasm/wa_wat_output.ml | 189 +---- 19 files changed, 247 insertions(+), 3411 deletions(-) delete mode 100644 compiler/lib/wasm/wa_asm_output.ml delete mode 100644 compiler/lib/wasm/wa_asm_output.mli delete mode 100644 compiler/lib/wasm/wa_core_target.ml delete mode 100644 compiler/lib/wasm/wa_core_target.mli delete mode 100644 compiler/lib/wasm/wa_liveness.ml delete mode 100644 compiler/lib/wasm/wa_liveness.mli delete mode 100644 compiler/lib/wasm/wa_spilling.ml delete mode 100644 compiler/lib/wasm/wa_spilling.mli diff --git a/compiler/lib/wasm/wa_asm_output.ml b/compiler/lib/wasm/wa_asm_output.ml deleted file mode 100644 index 3726fd8ba..000000000 --- a/compiler/lib/wasm/wa_asm_output.ml +++ /dev/null @@ -1,679 +0,0 @@ -(* Wasm_of_ocaml compiler - * http://www.ocsigen.org/js_of_ocaml/ - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) - -open! Stdlib - -module PP : sig - type t - - val empty : t - - val ( ^^ ) : t -> t -> t - - val string : string -> t - - val line : t -> t - - val indent : t -> t - - val concat_map : ('a -> t) -> 'a list -> t - - val separate_map : t -> ('a -> t) -> 'a list -> t - - val delayed : (unit -> t) -> t - - val to_channel : out_channel -> t -> unit - - (* val to_buffer : Buffer.t -> t -> unit *) -end = struct - let spaces = "\t" ^ String.make 80 ' ' - - type st = - { mutable indent : int - ; output : string -> int -> int -> unit - } - - type t = st -> unit - - let empty _ = () - - let string s st = st.output s 0 (String.length s) - - let ( ^^ ) s s' st = - s st; - s' st - - let line l st = - st.output spaces 0 (min (String.length spaces) st.indent); - l st; - st.output "\n" 0 1 - - let indent x st = - st.indent <- st.indent + 1; - x st; - st.indent <- st.indent - 1 - - let concat_map f l st = List.iter ~f:(fun x -> f x st) l - - let separate_map sep f l st = - List.iteri - ~f:(fun i x -> - if i > 0 then sep st; - f x st) - l - - let delayed f st = f () st - - let to_channel ch doc = doc { indent = 0; output = output_substring ch } - - (* - let to_buffer b doc = - doc { indent = 0; output = (fun s i l -> Buffer.add_substring b s i l) } - *) -end - -module Feature : sig - type set - - val make : unit -> set - - val get : set -> string list - - type t - - val register : set -> string -> t - - val require : t -> unit -end = struct - type t = string * bool ref - - type set = t list ref - - let make () = ref [] - - let get l = !l |> List.filter ~f:(fun (_, b) -> !b) |> List.map ~f:fst - - let register l name = - let f = name, ref false in - l := f :: !l; - f - - let require (_, b) = b := true -end - -module Output () = struct - open PP - open Wa_ast - - let features = Feature.make () - - let mutable_globals = Feature.register features "mutable-globals" - - let nontrapping_fptoint = Feature.register features "nontrapping-fptoint" - - let exception_handling = Feature.register features "exception-handling" - - let tail_call = Feature.register features "tail-call" - - let value_type (t : value_type) = - string - (match t with - | I32 -> "i32" - | I64 -> "i64" - | F32 -> "f32" - | F64 -> "f64" - | Ref _ -> assert false (* Not supported *)) - - let func_type { params; result } = - assert (List.length result <= 1); - string "(" - ^^ separate_map (string ", ") value_type params - ^^ string ") -> (" - ^^ separate_map (string ", ") value_type result - ^^ string ")" - - let block_type ty = - match ty with - | { params = []; result = [] } -> empty - | { params = []; result = [ res ] } -> string " " ^^ value_type res - | _ -> assert false - - let type_prefix op = - match op with - | I32 _ -> string "i32." - | I64 _ -> string "i64." - | F32 _ -> string "f32." - | F64 _ -> string "f64." - - let signage op (s : Wa_ast.signage) = - op - ^ - match s with - | S -> "_s" - | U -> "_u" - - let int_un_op sz op = - match op with - | Clz -> "clz" - | Ctz -> "ctz" - | Popcnt -> "popcnt" - | Eqz -> "eqz" - | TruncSatF64 s -> - Feature.require nontrapping_fptoint; - signage "trunc_sat_f64" s - | ReinterpretF -> "reinterpret_f" ^ sz - - let int_bin_op _ (op : int_bin_op) = - match op with - | Add -> "add" - | Sub -> "sub" - | Mul -> "mul" - | Div s -> signage "div" s - | Rem s -> signage "rem" s - | And -> "and" - | Or -> "or" - | Xor -> "xor" - | Shl -> "shl" - | Shr s -> signage "shr" s - | Rotl -> "rotl" - | Rotr -> "rotr" - | Eq -> "eq" - | Ne -> "ne" - | Lt s -> signage "lt" s - | Gt s -> signage "gt" s - | Le s -> signage "le" s - | Ge s -> signage "ge" s - - let float_un_op sz op = - match op with - | Neg -> "neg" - | Abs -> "abs" - | Ceil -> "ceil" - | Floor -> "floor" - | Trunc -> "trunc" - | Nearest -> "nearest" - | Sqrt -> "sqrt" - | Convert (`I32, s) -> signage "convert_i32" s - | Convert (`I64, s) -> signage "convert_i64" s - | ReinterpretI -> "reinterpret_i" ^ sz - - let float_bin_op _ op = - match op with - | Add -> "add" - | Sub -> "sub" - | Mul -> "mul" - | Div -> "div" - | Min -> "min" - | Max -> "max" - | CopySign -> "copysign" - | Eq -> "eq" - | Ne -> "ne" - | Lt -> "lt" - | Gt -> "gt" - | Le -> "le" - | Ge -> "ge" - - let select i32 i64 f32 f64 op = - match op with - | I32 x -> i32 "32" x - | I64 x -> i64 "64" x - | F32 x -> f32 "32" x - | F64 x -> f64 "64" x - - let integer i = string (string_of_int i) - - let integer32 _ i = - string - (if Poly.(i > -10000l && i < 10000l) - then Int32.to_string i - else Printf.sprintf "0x%lx" i) - - let integer64 _ i = - string - (if Poly.(i > -10000L && i < 10000L) - then Int64.to_string i - else Printf.sprintf "0x%Lx" i) - - let float32 _ f = string (Printf.sprintf "%h" f) (*ZZZ nan with payload*) - - let float64 _ f = string (Printf.sprintf "%h" f) (*ZZZ nan with payload*) - - let index name = string (Code.Var.to_string name) - - let symbol name offset = - string - (match name with - | V name -> Code.Var.to_string name - | S name -> name) - ^^ - if offset = 0 - then empty - else (if offset < 0 then empty else string "+") ^^ integer offset - - let offs _ i = Int32.to_string i - - let rec expression m e = - match e with - | Const op -> - line - (type_prefix op - ^^ string "const " - ^^ select integer32 integer64 float32 float64 op) - | ConstSym (name, offset) -> - line (type_prefix (I32 ()) ^^ string "const " ^^ symbol name offset) - | UnOp (op, e') -> - expression m e' - ^^ line - (type_prefix op - ^^ string (select int_un_op int_un_op float_un_op float_un_op op)) - | BinOp (op, e1, e2) -> - expression m e1 - ^^ expression m e2 - ^^ line - (type_prefix op - ^^ string (select int_bin_op int_bin_op float_bin_op float_bin_op op)) - | I32WrapI64 e -> expression m e ^^ line (string "i32.wrap_i64") - | I64ExtendI32 (s, e) -> expression m e ^^ line (string (signage "i64.extend_i32" s)) - | F32DemoteF64 e -> expression m e ^^ line (string "f32.demote_f64") - | F64PromoteF32 e -> expression m e ^^ line (string "f64.promote_f32") - | Load (offset, e') -> - expression m e' - ^^ line - (type_prefix offset - ^^ string "load " - ^^ string (select offs offs offs offs offset)) - | Load8 (s, offset, e') -> - expression m e' - ^^ line - (type_prefix offset - ^^ string (signage "load8" s) - ^^ string " " - ^^ string (select offs offs offs offs offset)) - | LocalGet i -> line (string "local.get " ^^ integer (Hashtbl.find m i)) - | LocalTee (i, e') -> - expression m e' ^^ line (string "local.tee " ^^ integer (Hashtbl.find m i)) - | GlobalGet nm -> line (string "global.get " ^^ symbol nm 0) - | BlockExpr (ty, l) -> - line (string "block" ^^ block_type ty) - ^^ indent (concat_map (instruction m) l) - ^^ line (string "end_block") - | Call_indirect (typ, f, l) -> - concat_map (expression m) l - ^^ expression m f - ^^ line (string "call_indirect " ^^ func_type typ) - | Call (x, l) -> concat_map (expression m) l ^^ line (string "call " ^^ index x) - | MemoryGrow (mem, e) -> expression m e ^^ line (string "memory.grow " ^^ integer mem) - | Seq (l, e') -> concat_map (instruction m) l ^^ expression m e' - | Pop _ -> empty - | IfExpr (ty, e, e1, e2) -> - expression m e - ^^ line (string "if" ^^ block_type { params = []; result = [ ty ] }) - ^^ indent (expression m e1) - ^^ line (string "else") - ^^ indent (expression m e2) - ^^ line (string "end_if") - | RefFunc _ - | Call_ref _ - | RefI31 _ - | I31Get _ - | ArrayNew _ - | ArrayNewFixed _ - | ArrayNewData _ - | ArrayGet _ - | ArrayLen _ - | StructNew _ - | StructGet _ - | RefCast _ - | RefTest _ - | RefEq _ - | RefNull _ - | Br_on_cast _ - | Br_on_cast_fail _ -> assert false (* Not supported *) - - and instruction m i = - match i with - | Drop e -> expression m e ^^ line (string "drop") - | Store (offset, e, e') -> - expression m e - ^^ expression m e' - ^^ line - (type_prefix offset - ^^ string "store " - ^^ string (select offs offs offs offs offset)) - | Store8 (offset, e, e') -> - expression m e - ^^ expression m e' - ^^ line - (type_prefix offset - ^^ string "store8 " - ^^ string (select offs offs offs offs offset)) - | LocalSet (i, e) -> - expression m e ^^ line (string "local.set " ^^ integer (Hashtbl.find m i)) - | GlobalSet (nm, e) -> expression m e ^^ line (string "global.set " ^^ symbol nm 0) - | Loop (ty, l) -> - line (string "loop" ^^ block_type ty) - ^^ indent (concat_map (instruction m) l) - ^^ line (string "end_loop") - | Block (ty, l) -> - line (string "block" ^^ block_type ty) - ^^ indent (concat_map (instruction m) l) - ^^ line (string "end_block") - | If (ty, e, l1, l2) -> - expression m e - ^^ line (string "if" ^^ block_type ty) - ^^ indent (concat_map (instruction m) l1) - ^^ line (string "else") - ^^ indent (concat_map (instruction m) l2) - ^^ line (string "end_if") - | Br_table (e, l, i) -> - expression m e - ^^ line - (string "br_table {" - ^^ separate_map (string ", ") integer (l @ [ i ]) - ^^ string "}") - | Br (i, Some e) -> expression m e ^^ instruction m (Br (i, None)) - | Br (i, None) -> line (string "br " ^^ integer i) - | Br_if (i, e) -> expression m e ^^ line (string "br_if " ^^ integer i) - | Return (Some e) -> expression m e ^^ instruction m (Return None) - | Return None -> line (string "return") - | CallInstr (x, l) -> concat_map (expression m) l ^^ line (string "call " ^^ index x) - | Nop -> empty - | Push e -> expression m e - | Try (ty, body, catches, catch_all) -> - Feature.require exception_handling; - line (string "try" ^^ block_type ty) - ^^ indent (concat_map (instruction m) body) - ^^ concat_map - (fun (tag, l) -> - line (string "catch " ^^ index tag) - ^^ indent (concat_map (instruction m) l)) - catches - ^^ (match catch_all with - | None -> empty - | Some l -> line (string "catch_all") ^^ indent (concat_map (instruction m) l)) - ^^ line (string "end_try") - | Throw (i, e) -> - Feature.require exception_handling; - expression m e ^^ line (string "throw " ^^ index i) - | Rethrow i -> - Feature.require exception_handling; - line (string "rethrow " ^^ integer i) - | Return_call_indirect (typ, f, l) -> - Feature.require tail_call; - concat_map (expression m) l - ^^ expression m f - ^^ line (string "return_call_indirect " ^^ func_type typ) - | Return_call (x, l) -> - Feature.require tail_call; - concat_map (expression m) l ^^ line (string "return_call " ^^ index x) - | Location (_, i) -> - (* Source maps not supported for the non-GC target *) - instruction m i - | ArraySet _ | StructSet _ | Return_call_ref _ -> assert false (* Not supported *) - - let escape_string s = - let b = Buffer.create (String.length s + 2) in - for i = 0 to String.length s - 1 do - let c = s.[i] in - if Poly.(c >= ' ' && c <= '~' && c <> '"' && c <> '\\') - then Buffer.add_char b c - else Printf.bprintf b "\\x%02x" (Char.code c) - done; - Buffer.contents b - - let section_header kind name = - line - (string ".section ." - ^^ string kind - ^^ string "." - ^^ symbol name 0 - ^^ string ",\"\",@") - - let vector l = - line (string ".int8 " ^^ integer (List.length l)) ^^ concat_map (fun x -> x) l - - let len_string s = - line (string ".int8 " ^^ integer (String.length s)) - ^^ line (string ".ascii \"" ^^ string (escape_string s) ^^ string "\"") - - let producer_section = - delayed - @@ fun () -> - indent - (section_header "custom_section" (S "producers") - ^^ vector - [ len_string "language" - ^^ vector [ len_string "OCaml" ^^ len_string Sys.ocaml_version ] - ; len_string "processed-by" - ^^ vector - [ len_string "wasm_of_ocaml" - ^^ len_string - (match Compiler_version.git_version with - | "" -> Compiler_version.s - | v -> Printf.sprintf "%s+git-%s" Compiler_version.s v) - ] - ]) - - let target_features = - delayed - @@ fun () -> - indent - (section_header "custom_section" (S "target_features") - ^^ vector - (List.map - ~f:(fun f -> line (string ".ascii \"+\"") ^^ len_string f) - (Feature.get features))) - - let export name exported_name = - match exported_name with - | None -> empty - | Some exported_name -> - line - (string ".export_name " ^^ symbol name 0 ^^ string "," ^^ string exported_name) - - let f ch fields = - List.iter - ~f:(fun f -> - match f with - | Global { name = S name; _ } -> Var_printer.add_reserved name - | Import _ | Function _ | Data _ | Global { name = V _; _ } | Tag _ | Type _ -> ()) - fields; - to_channel ch - @@ - let types = - List.filter_map - ~f:(fun f -> - match f with - | Function { name; typ; _ } -> Some (name, typ, None) - | Import { import_module; import_name; name; desc = Fun typ } -> - Some (name, typ, Some (import_module, import_name)) - | Import { desc = Global _ | Tag _; _ } | Data _ | Global _ | Tag _ | Type _ -> - None) - fields - in - let globals = - List.filter_map - ~f:(fun f -> - match f with - | Function _ | Import { desc = Fun _ | Tag _; _ } | Data _ | Tag _ | Type _ -> - None - | Import { import_module; import_name; name; desc = Global typ } -> - if typ.mut then Feature.require mutable_globals; - Some (V name, typ, Some (import_module, import_name)) - | Global { name; typ; init; _ } -> - assert (Poly.equal init (Const (I32 0l))); - Some (name, typ, None)) - fields - in - let tags = - List.filter_map - ~f:(fun f -> - match f with - | Function _ - | Import { desc = Fun _ | Global _; _ } - | Data _ | Global _ | Type _ -> None - | Import { import_module; import_name; name; desc = Tag typ } -> - Some (name, typ, Some (import_module, import_name)) - | Tag { name; typ } -> - Feature.require exception_handling; - Some (name, typ, None)) - fields - in - let define_symbol name = - line (string ".hidden " ^^ symbol name 0) ^^ line (string ".globl " ^^ symbol name 0) - in - let name_import name import = - (match import with - | None | Some ("env", _) -> empty - | Some (m, _) -> - line (string ".import_module " ^^ symbol name 0 ^^ string ", " ^^ string m)) - ^^ - match import with - | None -> empty - | Some (_, nm) -> - line (string ".import_name " ^^ symbol name 0 ^^ string ", " ^^ string nm) - in - let declare_global name { mut; typ } import = - line - (string ".globaltype " - ^^ symbol name 0 - ^^ string ", " - ^^ value_type typ - ^^ if mut then empty else string ", immutable") - ^^ name_import name import - in - let declare_tag name typ import = - line (string ".tagtype " ^^ index name ^^ string " " ^^ value_type typ) - ^^ name_import (V name) import - in - let declare_func_type name typ import = - line (string ".functype " ^^ index name ^^ string " " ^^ func_type typ) - ^^ name_import (V name) import - in - let data_sections = - concat_map - (fun f -> - match f with - | Function _ | Import _ | Type _ -> empty - | Data { name; read_only; active; contents } -> - assert active; - (* Not supported *) - let size = - List.fold_left - ~init:0 - ~f:(fun s d -> - s - + - match d with - | DataI8 _ -> 1 - | DataI32 _ | DataSym _ -> 4 - | DataI64 _ -> 8 - | DataBytes b -> String.length b - | DataSpace n -> n) - contents - in - indent - (section_header (if read_only then "rodata" else "data") (V name) - ^^ define_symbol (V name) - ^^ line (string ".p2align 2") - ^^ line (string ".size " ^^ index name ^^ string ", " ^^ integer size)) - ^^ line (index name ^^ string ":") - ^^ indent - (concat_map - (fun d -> - line - (match d with - | DataI8 i -> string ".int8 " ^^ integer i - | DataI32 i -> string ".int32 " ^^ integer32 "32" i - | DataI64 i -> string ".int64 " ^^ integer64 "64" i - | DataBytes b -> - string ".ascii \"" - ^^ string (escape_string b) - ^^ string "\"" - | DataSym (name, offset) -> - string ".int32 " ^^ symbol name offset - | DataSpace n -> string ".space " ^^ integer n)) - contents) - | Global { name; exported_name; typ; _ } -> - if typ.mut && Option.is_some exported_name - then Feature.require mutable_globals; - indent - (section_header "data" name - ^^ define_symbol name - ^^ export name exported_name) - | Tag { name; _ } -> - indent (section_header "data" (V name) ^^ define_symbol (V name)) - ^^ line (index name ^^ string ":")) - fields - in - let function_section = - concat_map - (fun f -> - match f with - | Function { name; exported_name; typ; param_names; locals; body } -> - let local_names = Hashtbl.create 8 in - let idx = - List.fold_left - ~f:(fun idx x -> - Hashtbl.add local_names x idx; - idx + 1) - ~init:0 - param_names - in - let _ = - List.fold_left - ~f:(fun idx (x, _) -> - Hashtbl.add local_names x idx; - idx + 1) - ~init:idx - locals - in - indent - (section_header "text" (V name) - ^^ define_symbol (V name) - ^^ export (V name) exported_name) - ^^ line (index name ^^ string ":") - ^^ indent - (declare_func_type name typ None - ^^ (if List.is_empty locals - then empty - else - line - (string ".local " - ^^ separate_map - (string ", ") - (fun (_, ty) -> value_type ty) - locals)) - ^^ concat_map (instruction local_names) body - ^^ line (string "end_function")) - | Import _ | Data _ | Global _ | Tag _ | Type _ -> empty) - fields - in - indent - (concat_map (fun (name, typ, import) -> declare_global name typ import) globals - ^^ concat_map (fun (name, typ, import) -> declare_func_type name typ import) types - ^^ concat_map (fun (name, typ, import) -> declare_tag name typ import) tags) - ^^ function_section - ^^ data_sections - ^^ producer_section - ^^ target_features -end - -let f ch fields = - let module O = Output () in - O.f ch fields diff --git a/compiler/lib/wasm/wa_asm_output.mli b/compiler/lib/wasm/wa_asm_output.mli deleted file mode 100644 index 3a2fc50a1..000000000 --- a/compiler/lib/wasm/wa_asm_output.mli +++ /dev/null @@ -1,19 +0,0 @@ -(* Wasm_of_ocaml compiler - * http://www.ocsigen.org/js_of_ocaml/ - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) - -val f : out_channel -> Wa_ast.module_field list -> unit diff --git a/compiler/lib/wasm/wa_ast.ml b/compiler/lib/wasm/wa_ast.ml index 6de691b26..0d3af3a0c 100644 --- a/compiler/lib/wasm/wa_ast.ml +++ b/compiler/lib/wasm/wa_ast.ml @@ -18,10 +18,6 @@ type var = Code.Var.t -type symbol = - | V of var - | S of string - type packed_type = | I8 | I16 @@ -137,7 +133,6 @@ type memarg = int32 type expression = | Const of (int32, int64, float, float) op - | ConstSym of symbol * int | UnOp of (int_un_op, int_un_op, float_un_op, float_un_op) op * expression | BinOp of (int_bin_op, int_bin_op, float_bin_op, float_bin_op) op * expression * expression @@ -145,15 +140,11 @@ type expression = | I64ExtendI32 of signage * expression | F32DemoteF64 of expression | F64PromoteF32 of expression - | Load of (memarg, memarg, memarg, memarg) op * expression - | Load8 of signage * (memarg, memarg, memarg, memarg) op * expression | LocalGet of var | LocalTee of var * expression - | GlobalGet of symbol + | GlobalGet of var | BlockExpr of func_type * instruction list - | Call_indirect of func_type * expression * expression list | Call of var * expression list - | MemoryGrow of int * expression | Seq of instruction list * expression | Pop of value_type | RefFunc of var @@ -177,10 +168,8 @@ type expression = and instruction = | Drop of expression - | Store of (memarg, memarg, memarg, memarg) op * expression * expression - | Store8 of (memarg, memarg, memarg, memarg) op * expression * expression | LocalSet of var * expression - | GlobalSet of symbol * expression + | GlobalSet of var * expression | Loop of func_type * instruction list | Block of func_type * instruction list | If of func_type * expression * instruction list * instruction list @@ -200,7 +189,6 @@ and instruction = | Rethrow of int | ArraySet of var * expression * expression * expression | StructSet of var * int * expression * expression - | Return_call_indirect of func_type * expression * expression list | Return_call of var * expression list | Return_call_ref of var * expression * expression list | Location of Code.loc * instruction @@ -211,14 +199,6 @@ type import_desc = | Global of global_type | Tag of value_type -type data = - | DataI8 of int - | DataI32 of int32 - | DataI64 of int64 - | DataBytes of string - | DataSym of symbol * int - | DataSpace of int - type type_field = { name : var ; typ : str_type @@ -237,12 +217,10 @@ type module_field = } | Data of { name : var - ; active : bool - ; read_only : bool - ; contents : data list + ; contents : string } | Global of - { name : symbol + { name : var ; exported_name : string option ; typ : global_type ; init : expression diff --git a/compiler/lib/wasm/wa_code_generation.ml b/compiler/lib/wasm/wa_code_generation.ml index 5c195668c..d4ca6b355 100644 --- a/compiler/lib/wasm/wa_code_generation.ml +++ b/compiler/lib/wasm/wa_code_generation.ml @@ -38,7 +38,7 @@ type constant_global = type context = { constants : (Var.t, W.expression) Hashtbl.t - ; mutable data_segments : (bool * W.data list) Var.Map.t + ; mutable data_segments : string Var.Map.t ; mutable constant_globals : constant_global Var.Map.t ; mutable other_fields : W.module_field list ; mutable imports : (Var.t * Wa_ast.import_desc) StringMap.t StringMap.t @@ -119,12 +119,10 @@ let expression_list f l = in loop [] l -let register_data_segment x ~active v st = - st.context.data_segments <- Var.Map.add x (active, v) st.context.data_segments; +let register_data_segment x v st = + st.context.data_segments <- Var.Map.add x v st.context.data_segments; (), st -let get_data_segment x st = Var.Map.find x st.context.data_segments, st - let get_context st = st.context, st let register_constant x e st = @@ -180,16 +178,13 @@ let heap_type_sub (ty : W.heap_type) (ty' : W.heap_type) st = let register_global name ?exported_name ?(constant = false) typ init st = st.context.other_fields <- W.Global { name; exported_name; typ; init } :: st.context.other_fields; - (match name with - | S _ -> () - | V name -> - st.context.constant_globals <- - Var.Map.add - name - { init = (if not typ.mut then Some init else None) - ; constant = (not typ.mut) || constant - } - st.context.constant_globals); + st.context.constant_globals <- + Var.Map.add + name + { init = (if not typ.mut then Some init else None) + ; constant = (not typ.mut) || constant + } + st.context.constant_globals; (), st let global_is_registered name = @@ -331,8 +326,6 @@ module Arith = struct | W.Const (I32 n), W.Const (I32 n') -> W.Const (I32 (Int32.add n n')) | W.Const (I32 0l), _ -> e' | _, W.Const (I32 0l) -> e - | W.ConstSym (sym, offset), W.Const (I32 n) -> - W.ConstSym (sym, offset + Int32.to_int n) | W.Const _, _ -> W.BinOp (I32 Add, e', e) | _ -> W.BinOp (I32 Add, e, e')) @@ -407,8 +400,8 @@ end let is_small_constant e = match e with - | W.ConstSym _ | W.Const _ | W.RefI31 (W.Const _) | W.RefFunc _ -> return true - | W.GlobalGet (V name) -> global_is_constant name + | W.Const _ | W.RefI31 (W.Const _) | W.RefFunc _ -> return true + | W.GlobalGet name -> global_is_constant name | _ -> return false let un_op_is_smi op = @@ -430,21 +423,16 @@ let rec is_smi e = | I31Get (S, _) -> true | I31Get (U, _) | Const (I64 _ | F32 _ | F64 _) - | ConstSym _ | UnOp ((F32 _ | F64 _), _) | I32WrapI64 _ | I64ExtendI32 _ | F32DemoteF64 _ | F64PromoteF32 _ - | Load _ - | Load8 _ | LocalGet _ | LocalTee _ | GlobalGet _ | BlockExpr _ - | Call_indirect _ | Call _ - | MemoryGrow _ | Seq _ | Pop _ | RefFunc _ @@ -526,12 +514,12 @@ let rec store ?(always = false) ?typ x e = else register_global ~constant:true - (V x) + x { mut = true; typ } (W.RefI31 (Const (I32 0l))) in - let* () = register_constant x (W.GlobalGet (V x)) in - instr (GlobalSet (V x, e)) + let* () = register_constant x (W.GlobalGet x) in + instr (GlobalSet (x, e)) else let* i = add_var ?typ x in instr (LocalSet (i, e)) diff --git a/compiler/lib/wasm/wa_code_generation.mli b/compiler/lib/wasm/wa_code_generation.mli index d83649c81..93f4f22f3 100644 --- a/compiler/lib/wasm/wa_code_generation.mli +++ b/compiler/lib/wasm/wa_code_generation.mli @@ -22,7 +22,7 @@ type constant_global type context = { constants : (Code.Var.t, Wa_ast.expression) Hashtbl.t - ; mutable data_segments : (bool * Wa_ast.data list) Code.Var.Map.t + ; mutable data_segments : string Code.Var.Map.t ; mutable constant_globals : constant_global Code.Var.Map.t ; mutable other_fields : Wa_ast.module_field list ; mutable imports : (Code.Var.t * Wa_ast.import_desc) StringMap.t StringMap.t @@ -154,7 +154,7 @@ val register_import : ?import_module:string -> name:string -> Wa_ast.import_desc -> Wa_ast.var t val register_global : - Wa_ast.symbol + Wa_ast.var -> ?exported_name:string -> ?constant:bool -> Wa_ast.global_type @@ -163,9 +163,7 @@ val register_global : val get_global : Code.Var.t -> Wa_ast.expression option t -val register_data_segment : Code.Var.t -> active:bool -> Wa_ast.data list -> unit t - -val get_data_segment : Code.Var.t -> (bool * Wa_ast.data list) t +val register_data_segment : Code.Var.t -> string -> unit t val register_init_code : unit t -> unit t diff --git a/compiler/lib/wasm/wa_core_target.ml b/compiler/lib/wasm/wa_core_target.ml deleted file mode 100644 index 09f12d2df..000000000 --- a/compiler/lib/wasm/wa_core_target.ml +++ /dev/null @@ -1,684 +0,0 @@ -(* Wasm_of_ocaml compiler - * http://www.ocsigen.org/js_of_ocaml/ - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) - -open! Stdlib -module W = Wa_ast -open Wa_code_generation - -type expression = Wa_ast.expression Wa_code_generation.t - -module Stack = Wa_spilling - -module Memory = struct - let mem_load ?(offset = 0) e = - assert (offset >= 0); - let* e = e in - match e with - | W.ConstSym (V x, offset') -> - let rec get_data offset l = - match l with - | [] -> assert false - | W.DataI32 i :: _ when offset = 0 -> W.Const (I32 i) - | W.DataSym (sym, ofs) :: _ when offset = 0 -> W.ConstSym (sym, ofs) - | (W.DataI32 _ | DataSym _) :: r -> get_data (offset - 4) r - | (DataI8 _ | DataBytes _ | DataSpace _ | DataI64 _) :: _ -> assert false - in - let* _, l = get_data_segment x in - let data = get_data (offset + offset') l in - return data - | _ -> return (W.Load (I32 (Int32.of_int offset), e)) - - let mem_init ?(offset = 0) e e' = - assert (offset >= 0); - let* e = e in - let* e' = e' in - instr (Store (I32 (Int32.of_int offset), e, e')) - - let mem_store ?(offset = 0) e e' = - assert (offset >= 0); - let* e = Arith.(e + const (Int32.of_int offset)) in - let* e' = e' in - let* f = - register_import ~name:"caml_modify" (Fun { W.params = [ I32; I32 ]; result = [] }) - in - instr (CallInstr (f, [ e; e' ])) - - (*ZZZ - p = young_ptr - size; - if (p < young_limit) {caml_call_gc(); p = young_ptr - size} - ... - return p + 4 - *) - let header ?(const = false) ~tag ~len () = - Int32.(add (shift_left (of_int len) 10) (of_int (tag + if const then 3 * 256 else 0))) - - let allocate stack_ctx x ~tag l = - let len = List.length l in - let p = Code.Var.fresh_n "p" in - let size = (len + 1) * 4 in - seq - (let* () = Stack.perform_spilling stack_ctx (`Instr x) in - let* v = - tee p Arith.(return (W.GlobalGet (S "young_ptr")) - const (Int32.of_int size)) - in - let* () = instr (W.GlobalSet (S "young_ptr", v)) in - let* () = mem_init (load p) (Arith.const (header ~tag ~len ())) in - Stack.kill_variables stack_ctx; - let* () = - Stack.perform_reloads - stack_ctx - (`Vars - (List.fold_left - ~f:(fun s v -> - match v with - | `Expr _ -> s - | `Var x -> Code.Var.Set.add x s) - ~init:Code.Var.Set.empty - l)) - in - snd - (List.fold_right - ~init:(len, return ()) - ~f:(fun v (i, cont) -> - ( i - 1 - , let* () = - mem_init - ~offset:(4 * i) - (load p) - (match v with - | `Var y -> load y - | `Expr e -> return e) - in - cont )) - l)) - Arith.(load p + const 4l) - (*ZZZ Float array?*) - - let tag e = - let val_int i = Arith.((i lsl const 1l) + const 1l) in - val_int Arith.(mem_load (e - const 4l) land const 0xffl) - - let block_length e = Arith.(mem_load (e - const 4l) lsr const 10l) - - let array_get e e' = mem_load Arith.(e + ((e' - const 1l) lsl const 1l)) - - let array_set e e' e'' = mem_store Arith.(e + ((e' - const 1l) lsl const 1l)) e'' - - let float_array_get = array_get - - let float_array_set = array_set - - let gen_array_get = array_get - - let gen_array_set = array_set - - let array_length = block_length - - let float_array_length = array_length - - let gen_array_length = array_length - - let bytes_length e = - let l = Code.Var.fresh () in - Arith.( - tee l ((block_length e lsl const 2l) - const 1l) - - let* tail = e + load l in - return (W.Load8 (U, I32 0l, tail))) - - let bytes_get e e' = - let* addr = Arith.(e + e' - const 1l) in - return (W.Load8 (U, I32 (Int32.of_int 0), addr)) - - let bytes_set e e' e'' = - let* addr = Arith.(e + e' - const 1l) in - let* e'' = e'' in - instr (W.Store8 (I32 (Int32.of_int 0), addr, e'')) - - let field e idx = mem_load ~offset:(4 * idx) e - - let set_field e idx e' = mem_store ~offset:(4 * idx) e e' - - let load_function_pointer ~cps:_ ~arity ?skip_cast:_ closure = - let* e = field closure (if arity = 1 then 0 else 2) in - return (`Index, e) - - let load_function_arity closure = Arith.(field closure 1 lsr const 24l) - - let load_real_closure ~cps:_ ~arity:_ _ = assert false - - let check_function_arity f ~cps:_ ~arity if_match if_mismatch = - let func_arity = load_function_arity (load f) in - if_ - { params = []; result = [ I32 ] } - Arith.(func_arity = const (Int32.of_int arity)) - (let* res = if_match ~typ:None (load f) in - instr (Push res)) - if_mismatch - - let box_float stack_ctx x e = - let p = Code.Var.fresh_n "p" in - let size = 12 in - seq - (let* () = Stack.perform_spilling stack_ctx (`Instr x) in - let* v = - tee p Arith.(return (W.GlobalGet (S "young_ptr")) - const (Int32.of_int size)) - in - let* () = instr (W.GlobalSet (S "young_ptr", v)) in - let* () = mem_init (load p) (Arith.const (header ~tag:Obj.double_tag ~len:2 ())) in - Stack.kill_variables stack_ctx; - let* () = Stack.perform_reloads stack_ctx (`Vars Code.Var.Set.empty) in - let* p = load p in - let* e = e in - instr (Store (F64 (Int32.of_int 4), p, e))) - Arith.(load p + const 4l) - - let unbox_float e = - let* e = e in - match e with - | W.ConstSym (V x, 4) -> - let get_data l = - match l with - | [ W.DataI32 _; W.DataI64 f ] -> W.Const (F64 (Int64.float_of_bits f)) - | _ -> assert false - in - let* _, l = get_data_segment x in - return (get_data l) - | _ -> - (*ZZZ aligned?*) - return (W.Load (F64 0l, e)) - - let box_int32 stack_ctx x e = - let p = Code.Var.fresh_n "p" in - let size = 16 in - seq - (let* () = Stack.perform_spilling stack_ctx (`Instr x) in - let* v = - tee p Arith.(return (W.GlobalGet (S "young_ptr")) - const (Int32.of_int size)) - in - let* () = instr (W.GlobalSet (S "young_ptr", v)) in - let* () = mem_init (load p) (Arith.const (header ~tag:Obj.double_tag ~len:2 ())) in - Stack.kill_variables stack_ctx; - let* () = Stack.perform_reloads stack_ctx (`Vars Code.Var.Set.empty) in - let* p = load p in - (* ZZZ int32_ops *) - let* () = instr (Store (I32 4l, p, Const (I32 0l))) in - let* e = e in - instr (Store (I32 8l, p, e))) - Arith.(load p + const 4l) - - let unbox_int32 e = - let* e = e in - match e with - | W.ConstSym (V x, 4) -> - let get_data l = - match l with - | [ W.DataI32 _; (W.DataI32 _ | W.DataSym _); W.DataI32 f ] -> W.Const (I32 f) - | _ -> assert false - in - let* _, l = get_data_segment x in - return (get_data l) - | _ -> return (W.Load (I32 4l, e)) - - let box_int64 stack_ctx x e = - let p = Code.Var.fresh_n "p" in - let size = 16 in - seq - (let* () = Stack.perform_spilling stack_ctx (`Instr x) in - let* v = - tee p Arith.(return (W.GlobalGet (S "young_ptr")) - const (Int32.of_int size)) - in - let* () = instr (W.GlobalSet (S "young_ptr", v)) in - let* () = mem_init (load p) (Arith.const (header ~tag:Obj.double_tag ~len:2 ())) in - Stack.kill_variables stack_ctx; - let* () = Stack.perform_reloads stack_ctx (`Vars Code.Var.Set.empty) in - let* p = load p in - let* () = instr (Store (I32 4l, p, ConstSym (S "int64_ops", 0))) in - let* e = e in - instr (Store (I64 8l, p, e))) - Arith.(load p + const 4l) - - let unbox_int64 e = - let* e = e in - match e with - | W.ConstSym (V x, 4) -> - let get_data l = - match l with - | [ W.DataI32 _; W.DataSym _; W.DataI64 f ] -> W.Const (I64 f) - | _ -> assert false - in - let* _, l = get_data_segment x in - return (get_data l) - | _ -> return (W.Load (F64 4l, e)) - - let box_nativeint stack_ctx x e = - let p = Code.Var.fresh_n "p" in - let size = 16 in - seq - (let* () = Stack.perform_spilling stack_ctx (`Instr x) in - let* v = - tee p Arith.(return (W.GlobalGet (S "young_ptr")) - const (Int32.of_int size)) - in - let* () = instr (W.GlobalSet (S "young_ptr", v)) in - let* () = mem_init (load p) (Arith.const (header ~tag:Obj.double_tag ~len:2 ())) in - Stack.kill_variables stack_ctx; - let* () = Stack.perform_reloads stack_ctx (`Vars Code.Var.Set.empty) in - let* p = load p in - (* ZZZ nativeint_ops *) - let* () = instr (Store (I32 4l, p, Const (I32 0l))) in - let* e = e in - instr (Store (I32 8l, p, e))) - Arith.(load p + const 4l) - - let unbox_nativeint = unbox_int32 -end - -module Value = struct - let value : W.value_type = I32 - - let block_type = return value - - let unit = Arith.const 1l - - let dummy_block = unit - - let as_block e = e - - let val_int i = Arith.((i lsl const 1l) + const 1l) - - let int_val i = Arith.(i asr const 1l) - - let check_is_not_zero i = Arith.(i <> const 1l) - - let check_is_int i = Arith.(i land const 1l) - - let not b = Arith.(const 4l - b) - - let lt i i' = val_int Arith.(i < i') - - let le i i' = val_int Arith.(i <= i') - - let eq i i' = val_int Arith.(i = i') - - let neq i i' = val_int Arith.(i <> i') - - let ult i i' = val_int Arith.(ult i i') - - let is_int i = val_int Arith.(i land const 1l) - - let int_add i i' = Arith.(i + i' - const 1l) - - let int_sub i i' = Arith.(i - i' + const 1l) - - let int_mul i i' = val_int Arith.(int_val i * int_val i') - - let int_div i i' = val_int Arith.(int_val i / int_val i') - - let int_mod i i' = val_int Arith.(int_val i mod int_val i') - - let int_neg i = Arith.(const 2l - i) - - let int_or i i' = Arith.(i lor i') - - let int_and i i' = Arith.(i land i') - - let int_xor i i' = Arith.(i lxor i' lor const 1l) - - let int_lsl i i' = Arith.(((i - const 1l) lsl int_val i') + const 1l) - - let int_lsr i i' = Arith.((i lsr int_val i') lor const 1l) - - let int_asr i i' = Arith.((i asr int_val i') lor const 1l) -end - -module Constant = struct - let rec translate_rec context c = - match c with - | Code.Int i -> - let i = Targetint.to_int32 i in - W.DataI32 Int32.(add (add i i) 1l) - | Tuple (tag, a, _) -> - let h = Memory.header ~const:true ~tag ~len:(Array.length a) () in - let name = Code.Var.fresh_n "block" in - let block = - W.DataI32 h :: List.map ~f:(fun c -> translate_rec context c) (Array.to_list a) - in - context.data_segments <- Code.Var.Map.add name (true, block) context.data_segments; - W.DataSym (V name, 4) - | NativeString (Byte s | Utf (Utf8 s)) | String s -> - let l = String.length s in - let len = (l + 4) / 4 in - let h = Memory.header ~const:true ~tag:Obj.string_tag ~len () in - let name = Code.Var.fresh_n "str" in - let extra = (4 * len) - l - 1 in - let string = - W.DataI32 h - :: DataBytes s - :: (if extra = 0 then [ DataI8 0 ] else [ DataSpace extra; DataI8 extra ]) - in - context.data_segments <- - Code.Var.Map.add name (true, string) context.data_segments; - W.DataSym (V name, 4) - | Float f -> - let h = Memory.header ~const:true ~tag:Obj.double_tag ~len:2 () in - let name = Code.Var.fresh_n "float" in - let block = [ W.DataI32 h; DataI64 (Int64.bits_of_float f) ] in - context.data_segments <- Code.Var.Map.add name (true, block) context.data_segments; - W.DataSym (V name, 4) - | Float_array l -> - (*ZZZ Boxed array? *) - let l = Array.to_list l in - let h = - Memory.header ~const:true ~tag:Obj.double_array_tag ~len:(List.length l) () - in - let name = Code.Var.fresh_n "float_array" in - let block = - W.DataI32 h :: List.map ~f:(fun f -> translate_rec context (Float f)) l - in - context.data_segments <- Code.Var.Map.add name (true, block) context.data_segments; - W.DataSym (V name, 4) - | Int64 i -> - let h = Memory.header ~const:true ~tag:Obj.custom_tag ~len:3 () in - let name = Code.Var.fresh_n "int64" in - let block = - [ W.DataI32 h; DataI32 0l (*ZZZ DataSym (S "caml_int64_ops", 0)*); DataI64 i ] - in - context.data_segments <- Code.Var.Map.add name (true, block) context.data_segments; - W.DataSym (V name, 4) - | Int32 i -> - let h = Memory.header ~const:true ~tag:Obj.custom_tag ~len:2 () in - let name = Code.Var.fresh_n "int32" in - let block = - [ W.DataI32 h; DataI32 0l (*ZZZ DataSym (S "caml_int32_ops", 0)*); DataI32 i ] - in - context.data_segments <- Code.Var.Map.add name (true, block) context.data_segments; - W.DataSym (V name, 4) - | NativeInt i -> - let h = Memory.header ~const:true ~tag:Obj.custom_tag ~len:2 () in - let name = Code.Var.fresh_n "nativeint" in - let block = - [ W.DataI32 h - ; DataI32 0l (*ZZZ DataSym (S "caml_nativeint_ops", 0)*) - ; DataI32 i - ] - in - context.data_segments <- Code.Var.Map.add name (true, block) context.data_segments; - W.DataSym (V name, 4) - - let translate c = - let* context = get_context in - return - (match translate_rec context c with - | W.DataSym (name, offset) -> W.ConstSym (name, offset) - | W.DataI32 i -> W.Const (I32 i) - | _ -> assert false) -end - -module Closure = struct - let get_free_variables ~context info = - List.filter - ~f:(fun x -> not (Hashtbl.mem context.constants x)) - info.Wa_closure_conversion.free_variables - - let closure_stats = - let s = ref 0 in - let n = ref 0 in - fun context info -> - let free_variables = get_free_variables ~context info in - if false && not (List.is_empty free_variables) - then - (incr n; - s := !s + List.length free_variables; - Format.eprintf - "OOO %d %f %s@." - (List.length free_variables) - (float !s /. float !n)) - (Code.Var.to_string (fst (List.hd info.functions))) - - let closure_env_start info = - List.fold_left - ~f:(fun i (_, arity) -> i + if arity > 1 then 4 else 3) - ~init:(-1) - info.Wa_closure_conversion.functions - - let function_offset_in_closure info f = - let rec index i l = - match l with - | [] -> assert false - | (g, arity) :: r -> - if Code.Var.equal f g then i else index (i + if arity > 1 then 4 else 3) r - in - index 0 info.Wa_closure_conversion.functions - - let closure_info ~arity ~sz = - W.Const (I32 Int32.(add (shift_left (of_int arity) 24) (of_int ((sz lsl 1) + 1)))) - - let translate ~context ~closures ~stack_ctx ~cps x = - let info = Code.Var.Map.find x closures in - let f, _ = List.hd info.Wa_closure_conversion.functions in - let* () = set_closure_env x x in - if Code.Var.equal x f - then ( - let start_env = closure_env_start info in - let* _, start = - List.fold_left - ~f:(fun accu (f, arity) -> - let* i, start = accu in - let* curry_fun = if arity > 1 then need_curry_fun ~cps ~arity else return f in - let start = - if i = 0 - then start - else W.Const (I32 (Memory.header ~tag:Obj.infix_tag ~len:i ())) :: start - in - let clos_info = closure_info ~arity ~sz:(start_env - i) in - let start = clos_info :: W.ConstSym (V curry_fun, 0) :: start in - return - (if arity > 1 then i + 4, W.ConstSym (V f, 0) :: start else i + 3, start)) - ~init:(return (0, [])) - info.functions - in - closure_stats context info; - let free_variables = get_free_variables ~context info in - if List.is_empty free_variables - then - let l = - List.rev_map - ~f:(fun e -> - match e with - | W.Const (I32 i) -> W.DataI32 i - | ConstSym (sym, offset) -> DataSym (sym, offset) - | _ -> assert false) - start - in - let h = Memory.header ~const:true ~tag:Obj.closure_tag ~len:(List.length l) () in - let name = Code.Var.fresh_n "closure" in - let* () = register_data_segment name ~active:true (W.DataI32 h :: l) in - let* () = - (* In case we did not detect that this closure was constant - during the spilling analysis *) - Stack.perform_spilling stack_ctx (`Instr x) - in - return (W.ConstSym (V name, 4)) - else - Memory.allocate - stack_ctx - x - ~tag:Obj.closure_tag - (List.rev_map ~f:(fun e -> `Expr e) start - @ List.map ~f:(fun x -> `Var x) free_variables)) - else - let offset = Int32.of_int (4 * function_offset_in_closure info x) in - Arith.(load f + const offset) - - let bind_environment ~context ~closures ~cps:_ f = - if Hashtbl.mem context.constants f - then - (* The closures are all constants and the environment is empty. *) - let* _ = add_var (Code.Var.fresh ()) in - return () - else - let info = Code.Var.Map.find f closures in - let funct_index = function_offset_in_closure info f in - let* _ = add_var f in - let* () = - snd - (List.fold_left - ~f:(fun (i, prev) (x, arity) -> - ( (i + if arity > 1 then 4 else 3) - , let* () = prev in - if i = 0 - then return () - else - define_var - x - (let offset = 4 * i in - Arith.(load f + const (Int32.of_int offset))) )) - ~init:(-funct_index, return ()) - info.functions) - in - let start_env = closure_env_start info in - let offset = start_env - funct_index in - let free_variables = get_free_variables ~context info in - snd - (List.fold_left - ~f:(fun (i, prev) x -> - ( i + 1 - , let* () = prev in - define_var - x - (let* f = load f in - return (W.Load (I32 (Int32.of_int (4 * i)), f))) )) - ~init:(offset, return ()) - free_variables) - - let curry_allocate ~stack_ctx ~x ~cps:_ ~arity _ ~f ~closure ~arg = - Memory.allocate - stack_ctx - x - ~tag:Obj.closure_tag - [ `Expr (W.ConstSym (V f, 0)) - ; `Expr (closure_info ~arity ~sz:2) - ; `Var closure - ; `Var arg - ] - - let curry_load ~cps:_ ~arity:_ _ closure = - return (Memory.field (load closure) 3, Memory.field (load closure) 4, None) - - let dummy ~cps:_ ~arity:_ = assert false -end - -module Math = struct - let float_func_type n = - { W.params = List.init ~len:n ~f:(fun _ : W.value_type -> F64); result = [ F64 ] } - - let unary name x = - let* f = register_import ~name (Fun (float_func_type 1)) in - let* x = x in - return (W.Call (f, [ x ])) - - let cos f = unary "cos" f - - let sin f = unary "sin" f - - let tan f = unary "tan" f - - let acos f = unary "acos" f - - let asin f = unary "asin" f - - let atan f = unary "atan" f - - let cosh f = unary "cosh" f - - let sinh f = unary "sinh" f - - let tanh f = unary "tanh" f - - let acosh f = unary "acosh" f - - let asinh f = unary "asinh" f - - let atanh f = unary "atanh" f - - let cbrt f = unary "cbrt" f - - let exp f = unary "exp" f - - let exp2 f = unary "exp2" f - - let expm1 f = unary "expm1" f - - let log f = unary "log" f - - let log1p f = unary "log1p" f - - let log2 f = unary "log2" f - - let log10 f = unary "log10" f - - let round f = unary "round" f - - let binary name x y = - let* f = register_import ~name (Fun (float_func_type 2)) in - let* x = x in - let* y = y in - return (W.Call (f, [ x; y ])) - - let atan2 f g = binary "atan2" f g - - let hypot f g = binary "hypot" f g - - let power f g = binary "pow" f g - - let fmod f g = binary "fmod" f g -end - -let internal_primitives = Hashtbl.create 0 - -let handle_exceptions ~result_typ ~fall_through ~context body x exn_handler = - let* ocaml_tag = register_import ~name:"ocaml_exception" (Tag Value.value) in - try_ - { params = []; result = result_typ } - (body ~result_typ ~fall_through:(`Block (-1)) ~context) - [ ( ocaml_tag - , let* () = store ~always:true x (return (W.Pop Value.value)) in - exn_handler ~result_typ ~fall_through ~context ) - ] - -let post_process_function_body ~param_names:_ ~locals:_ instrs = instrs - -let entry_point ~toplevel_fun = - let code = - let declare_global name = - register_global (S name) { mut = true; typ = I32 } (Const (I32 0l)) - in - let* () = declare_global "sp" in - let* () = declare_global "young_ptr" in - let* () = declare_global "young_limit" in - let* call_ctors = - register_import ~name:"__wasm_call_ctors" (Fun { W.params = []; result = [] }) - in - let* () = instr (W.CallInstr (call_ctors, [])) in - let* sz = Arith.const 3l in - let* high = Arith.((return (W.MemoryGrow (0, sz)) + const 3l) lsl const 16l) in - let* () = instr (W.GlobalSet (S "young_ptr", high)) in - let low = W.ConstSym (S "__heap_base", 0) in - let* () = instr (W.GlobalSet (S "young_limit", low)) in - drop (return (W.Call (toplevel_fun, []))) - in - { W.params = []; result = [] }, [], code diff --git a/compiler/lib/wasm/wa_core_target.mli b/compiler/lib/wasm/wa_core_target.mli deleted file mode 100644 index e44faa1a1..000000000 --- a/compiler/lib/wasm/wa_core_target.mli +++ /dev/null @@ -1,19 +0,0 @@ -(* Wasm_of_ocaml compiler - * http://www.ocsigen.org/js_of_ocaml/ - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) - -include Wa_target_sig.S diff --git a/compiler/lib/wasm/wa_curry.ml b/compiler/lib/wasm/wa_curry.ml index f3640b3b4..e689ca6b6 100644 --- a/compiler/lib/wasm/wa_curry.ml +++ b/compiler/lib/wasm/wa_curry.ml @@ -42,16 +42,14 @@ module Make (Target : Wa_target_sig.S) = struct let funct = Var.fresh () in let* closure = tee ?typ funct closure in let args = args @ [ closure ] in - let* kind, funct = + let* ty, funct = Memory.load_function_pointer ~cps ~arity ~skip_cast:(Option.is_some typ) (load funct) in - match kind with - | `Index -> return (W.Call_indirect (func_type (List.length args), funct, args)) - | `Ref ty -> return (W.Call_ref (ty, funct, args)) + return (W.Call_ref (ty, funct, args)) let curry_app_name n m = Printf.sprintf "curry_app %d_%d" n m @@ -125,40 +123,7 @@ module Make (Target : Wa_target_sig.S) = struct let body = let* _ = add_var x in let* _ = add_var f in - let res = Code.Var.fresh_n "res" in - let stack_info, stack = - Stack.make_info () - |> fun info -> - Stack.add_spilling - info - ~location:res - ~stack:[] - ~live_vars:Var.Set.empty - ~spilled_vars:(Var.Set.of_list [ x; f ]) - in - let ret = Code.Var.fresh_n "ret" in - let stack_info, _ = - Stack.add_spilling - stack_info - ~location:ret - ~stack - ~live_vars:Var.Set.empty - ~spilled_vars:Var.Set.empty - in - let stack_ctx = Stack.start_function ~context stack_info in - let* () = - push - (Closure.curry_allocate - ~stack_ctx - ~x:res - ~cps:false - ~arity - m - ~f:name' - ~closure:f - ~arg:x) - in - Stack.perform_spilling stack_ctx (`Instr ret) + push (Closure.curry_allocate ~cps:false ~arity m ~f:name' ~closure:f ~arg:x) in let param_names = [ x; f ] in let locals, body = function_body ~context ~param_names ~body in @@ -230,39 +195,7 @@ module Make (Target : Wa_target_sig.S) = struct let* _ = add_var x in let* _ = add_var cont in let* _ = add_var f in - let res = Code.Var.fresh_n "res" in - let stack_info, stack = - Stack.make_info () - |> fun info -> - Stack.add_spilling - info - ~location:res - ~stack:[] - ~live_vars:Var.Set.empty - ~spilled_vars:(Var.Set.of_list [ x; f ]) - in - let ret = Code.Var.fresh_n "ret" in - let stack_info, _ = - Stack.add_spilling - stack_info - ~location:ret - ~stack - ~live_vars:Var.Set.empty - ~spilled_vars:Var.Set.empty - in - let stack_ctx = Stack.start_function ~context stack_info in - let* e = - Closure.curry_allocate - ~stack_ctx - ~x:res - ~cps:true - ~arity - m - ~f:name' - ~closure:f - ~arg:x - in - let* () = Stack.perform_spilling stack_ctx (`Instr ret) in + let* e = Closure.curry_allocate ~cps:true ~arity m ~f:name' ~closure:f ~arg:x in let* c = call ~cps:false ~arity:1 (load cont) [ e ] in instr (W.Return (Some c)) in @@ -291,39 +224,14 @@ module Make (Target : Wa_target_sig.S) = struct (fun ~typ closure -> let* l = expression_list load l in call ?typ ~cps:false ~arity closure l) - (let rec build_spilling_info stack_info stack live_vars acc l = - match l with - | [] -> stack_info, List.rev acc - | x :: rem -> - let live_vars = Var.Set.remove x live_vars in - let y = Var.fresh () in - let stack_info, stack = - Stack.add_spilling - stack_info - ~location:y - ~stack - ~live_vars - ~spilled_vars: - (if List.is_empty stack then live_vars else Var.Set.empty) - in - build_spilling_info stack_info stack live_vars ((x, y) :: acc) rem - in - let stack_info, l = - build_spilling_info (Stack.make_info ()) [] (Var.Set.of_list l) [] l - in - let stack_ctx = Stack.start_function ~context stack_info in - let rec build_applies y l = + (let rec build_applies y l = match l with | [] -> let* y = y in instr (Push y) - | (x, y') :: rem -> - let* () = Stack.perform_reloads stack_ctx (`Vars (Var.Set.singleton x)) in - let* () = Stack.perform_spilling stack_ctx (`Instr y') in + | x :: rem -> let* x = load x in - Stack.kill_variables stack_ctx; - let* () = store y' (call ~cps:false ~arity:1 y [ x ]) in - build_applies (load y') rem + build_applies (call ~cps:false ~arity:1 y [ x ]) rem in build_applies (load f) l) in @@ -349,46 +257,16 @@ module Make (Target : Wa_target_sig.S) = struct (fun ~typ closure -> let* l = expression_list load l in call ?typ ~cps:true ~arity closure l) - (let args = Code.Var.fresh_n "args" in - let stack_info, stack = - Stack.make_info () - |> fun info -> - Stack.add_spilling - info - ~location:args - ~stack:[] - ~live_vars:(Var.Set.of_list (f :: l)) - ~spilled_vars:(Var.Set.of_list (f :: l)) - in - let ret = Code.Var.fresh_n "ret" in - let stack_info, _ = - Stack.add_spilling - stack_info - ~location:ret - ~stack - ~live_vars:Var.Set.empty - ~spilled_vars:Var.Set.empty - in - let stack_ctx = Stack.start_function ~context stack_info in - let* args = - Memory.allocate - stack_ctx - args - ~tag:0 - (List.map ~f:(fun x -> `Var x) (List.tl l)) - in + (let* args = Memory.allocate ~tag:0 (List.map ~f:(fun x -> `Var x) (List.tl l)) in let* make_iterator = register_import ~name:"caml_apply_continuation" (Fun (func_type 0)) in - Stack.kill_variables stack_ctx; let iterate = Var.fresh_n "iterate" in let* () = store iterate (return (W.Call (make_iterator, [ args ]))) in let x = List.hd l in - let* () = Stack.perform_reloads stack_ctx (`Vars (Var.Set.of_list [ x; f ])) in let* x = load x in let* iterate = load iterate in - let* () = push (call ~cps:true ~arity:2 (load f) [ x; iterate ]) in - Stack.perform_spilling stack_ctx (`Instr ret)) + push (call ~cps:true ~arity:2 (load f) [ x; iterate ])) in let param_names = l @ [ f ] in let locals, body = function_body ~context ~param_names ~body in diff --git a/compiler/lib/wasm/wa_gc_target.ml b/compiler/lib/wasm/wa_gc_target.ml index 1ebf6943c..262d14d4b 100644 --- a/compiler/lib/wasm/wa_gc_target.ml +++ b/compiler/lib/wasm/wa_gc_target.ml @@ -480,7 +480,7 @@ module Value = struct match typ.typ with | W.I31 | Eq | Any -> return (W.Const (I32 1l)) | Type _ | Func | Extern -> return (W.Const (I32 0l))) - | GlobalGet (V nm) -> ( + | GlobalGet nm -> ( let* init = get_global nm in match init with | Some (W.ArrayNewFixed (t, _) | W.StructNew (t, _)) -> @@ -502,14 +502,12 @@ module Value = struct let rec effect_free e = match e with - | W.Const _ | ConstSym _ | LocalGet _ | GlobalGet _ | RefFunc _ | RefNull _ -> true + | W.Const _ | LocalGet _ | GlobalGet _ | RefFunc _ | RefNull _ -> true | UnOp (_, e') | I32WrapI64 e' | I64ExtendI32 (_, e') | F32DemoteF64 e' | F64PromoteF32 e' - | Load (_, e') - | Load8 (_, _, e') | RefI31 e' | I31Get (_, e') | ArrayLen e' @@ -523,9 +521,7 @@ module Value = struct | RefEq (e1, e2) -> effect_free e1 && effect_free e2 | LocalTee _ | BlockExpr _ - | Call_indirect _ | Call _ - | MemoryGrow _ | Seq _ | Pop _ | Call_ref _ @@ -619,7 +615,7 @@ module Memory = struct let wasm_struct_get ty e i = let* e = e in match e with - | W.RefCast ({ typ; _ }, GlobalGet (V nm)) -> ( + | W.RefCast ({ typ; _ }, GlobalGet nm) -> ( let* init = get_global nm in match init with | Some (W.StructNew (ty', l)) -> @@ -651,7 +647,7 @@ module Memory = struct let* e'' = e'' in instr (W.ArraySet (ty, e, e', e'')) - let box_float _ _ e = + let box_float e = let* ty = Type.float_type in let* e = e in return (W.StructNew (ty, [ e ])) @@ -660,7 +656,7 @@ module Memory = struct let* ty = Type.float_type in wasm_struct_get ty (wasm_cast ty e) 0 - let allocate _ _ ~tag l = + let allocate ~tag l = if tag = 254 then let* l = @@ -730,7 +726,7 @@ module Memory = struct let array_set e e' e'' = wasm_array_set e Arith.(Value.int_val e' + const 1l) e'' let float_array_get e e' = - box_float () () (wasm_array_get ~ty:Type.float_array_type e (Value.int_val e')) + box_float (wasm_array_get ~ty:Type.float_array_type e (Value.int_val e')) let float_array_set e e' e'' = wasm_array_set ~ty:Type.float_array_type e (Value.int_val e') (unbox_float e'') @@ -760,9 +756,7 @@ module Memory = struct in instr (Br (1, Some e)))) in - let* e = - box_float () () (wasm_array_get ~ty:Type.float_array_type (load a) (load i)) - in + let* e = box_float (wasm_array_get ~ty:Type.float_array_type (load a) (load i)) in instr (W.Push e)) let gen_array_set e e' e'' = @@ -821,7 +815,7 @@ module Memory = struct let* fun_ty = Type.function_type ~cps arity in let casted_closure = if skip_cast then closure else wasm_cast ty closure in let* e = wasm_struct_get ty casted_closure (env_start arity - 1) in - return (`Ref fun_ty, e) + return (fun_ty, e) let load_real_closure ~cps ~arity closure = let arity = if cps then arity - 1 else arity in @@ -866,9 +860,9 @@ module Memory = struct in let* ty = Type.int32_type in let* e = e in - return (W.StructNew (ty, [ GlobalGet (V int32_ops); e ])) + return (W.StructNew (ty, [ GlobalGet int32_ops; e ])) - let box_int32 _ _ e = make_int32 ~kind:`Int32 e + let box_int32 e = make_int32 ~kind:`Int32 e let unbox_int32 e = let* ty = Type.int32_type in @@ -884,15 +878,15 @@ module Memory = struct in let* ty = Type.int64_type in let* e = e in - return (W.StructNew (ty, [ GlobalGet (V int64_ops); e ])) + return (W.StructNew (ty, [ GlobalGet int64_ops; e ])) - let box_int64 _ _ e = make_int64 e + let box_int64 e = make_int64 e let unbox_int64 e = let* ty = Type.int64_type in wasm_struct_get ty (wasm_cast ty e) 1 - let box_nativeint _ _ e = make_int32 ~kind:`Nativeint e + let box_nativeint e = make_int32 ~kind:`Nativeint e let unbox_nativeint e = let* ty = Type.int32_type in @@ -906,8 +900,8 @@ module Constant = struct let store_in_global ?(name = "const") c = let name = Code.Var.fresh_n name in - let* () = register_global (V name) { mut = false; typ = Type.value } c in - return (W.GlobalGet (V name)) + let* () = register_global name { mut = false; typ = Type.value } c in + return (W.GlobalGet name) let str_js_utf8 s = let b = Buffer.create (String.length s) in @@ -1000,13 +994,13 @@ module Constant = struct (Global { mut = false; typ = Ref { nullable = false; typ = Any } }) in let* ty = Type.js_type in - return (Const_named ("str_" ^ s), W.StructNew (ty, [ GlobalGet (V x) ])) + return (Const_named ("str_" ^ s), W.StructNew (ty, [ GlobalGet x ])) | String s -> let* ty = Type.string_type in if String.length s >= string_length_threshold then let name = Code.Var.fresh_n "string" in - let* () = register_data_segment name ~active:false [ DataBytes s ] in + let* () = register_data_segment name s in return ( Mutated , W.ArrayNewData @@ -1050,12 +1044,12 @@ module Constant = struct let* () = register_global ~constant:true - (V name) + name { mut = true; typ = Type.value } (W.RefI31 (Const (I32 0l))) in - let* () = register_init_code (instr (W.GlobalSet (V name, c))) in - return (W.GlobalGet (V name)) + let* () = register_init_code (instr (W.GlobalSet (name, c))) in + return (W.GlobalGet name) end module Closure = struct @@ -1070,7 +1064,7 @@ module Closure = struct | [ (g, _) ] -> Code.Var.equal f g | _ :: r -> is_last_fun r f - let translate ~context ~closures ~stack_ctx:_ ~cps f = + let translate ~context ~closures ~cps f = let info = Code.Var.Map.find f closures in let free_variables = get_free_variables ~context info in assert ( @@ -1087,7 +1081,7 @@ module Closure = struct let name = Code.Var.fork f in let* () = register_global - (V name) + name { mut = false; typ = Type.value } (W.StructNew ( typ @@ -1101,7 +1095,7 @@ module Closure = struct then Const (I32 (Int32.of_int arity)) :: code_pointers else code_pointers )) in - return (W.GlobalGet (V name)) + return (W.GlobalGet name) else let free_variable_count = List.length free_variables in match info.Wa_closure_conversion.functions with @@ -1238,7 +1232,7 @@ module Closure = struct ~init:(0, return ()) (List.map ~f:fst functions @ free_variables)) - let curry_allocate ~stack_ctx:_ ~x:_ ~cps ~arity m ~f ~closure ~arg = + let curry_allocate ~cps ~arity m ~f ~closure ~arg = let* ty = Type.curry_type ~cps arity m in let* cl_ty = if m = arity @@ -1291,36 +1285,6 @@ module Closure = struct else closure_contents )) end -module Stack = struct - type stack = Code.Var.t option list - - type info = unit - - let generate_spilling_information _ ~context:_ ~closures:_ ~pc:_ ~env:_ ~params:_ = () - - let add_spilling _ ~location:_ ~stack:_ ~live_vars:_ ~spilled_vars:_ = (), [] - - type ctx = unit - - let start_function ~context:_ _ = () - - let start_block ~context:_ _ _ = () - - let perform_reloads _ _ = return () - - let perform_spilling _ _ = return () - - let kill_variables _ = () - - let assign _ _ = return () - - let make_info () = () - - let adjust_stack _ ~src:_ ~dst:_ = return () - - let stack_adjustment_needed _ ~src:_ ~dst:_ = false -end - module Math = struct let float_func_type n = { W.params = List.init ~len:n ~f:(fun _ : W.value_type -> F64); result = [ F64 ] } diff --git a/compiler/lib/wasm/wa_generate.ml b/compiler/lib/wasm/wa_generate.ml index 49f413fef..6b3c0d807 100644 --- a/compiler/lib/wasm/wa_generate.ml +++ b/compiler/lib/wasm/wa_generate.ml @@ -21,8 +21,6 @@ open Code module W = Wa_ast open Wa_code_generation -let target = `GC (*`Core*) - module Generate (Target : Wa_target_sig.S) = struct open Target @@ -43,55 +41,54 @@ module Generate (Target : Wa_target_sig.S) = struct let func_type n = { W.params = List.init ~len:n ~f:(fun _ -> Value.value); result = [ Value.value ] } - let float_bin_op' stack_ctx x op f g = - Memory.box_float stack_ctx x (op (Memory.unbox_float f) (Memory.unbox_float g)) + let float_bin_op' op f g = + Memory.box_float (op (Memory.unbox_float f) (Memory.unbox_float g)) - let float_bin_op stack_ctx x op f g = + let float_bin_op op f g = let* f = Memory.unbox_float f in let* g = Memory.unbox_float g in - Memory.box_float stack_ctx x (return (W.BinOp (F64 op, f, g))) + Memory.box_float (return (W.BinOp (F64 op, f, g))) - let float_un_op' stack_ctx x op f = - Memory.box_float stack_ctx x (op (Memory.unbox_float f)) + let float_un_op' op f = Memory.box_float (op (Memory.unbox_float f)) - let float_un_op stack_ctx x op f = + let float_un_op op f = let* f = Memory.unbox_float f in - Memory.box_float stack_ctx x (return (W.UnOp (F64 op, f))) + Memory.box_float (return (W.UnOp (F64 op, f))) let float_comparison op f g = let* f = Memory.unbox_float f in let* g = Memory.unbox_float g in Value.val_int (return (W.BinOp (F64 op, f, g))) - let int32_bin_op stack_ctx x op f g = + let int32_bin_op op f g = let* f = Memory.unbox_int32 f in let* g = Memory.unbox_int32 g in - Memory.box_int32 stack_ctx x (return (W.BinOp (I32 op, f, g))) + Memory.box_int32 (return (W.BinOp (I32 op, f, g))) - let int32_shift_op stack_ctx x op f g = + let int32_shift_op op f g = let* f = Memory.unbox_int32 f in let* g = Value.int_val g in - Memory.box_int32 stack_ctx x (return (W.BinOp (I32 op, f, g))) + Memory.box_int32 (return (W.BinOp (I32 op, f, g))) - let int64_bin_op stack_ctx x op f g = + let int64_bin_op op f g = let* f = Memory.unbox_int64 f in let* g = Memory.unbox_int64 g in - Memory.box_int64 stack_ctx x (return (W.BinOp (I64 op, f, g))) + Memory.box_int64 (return (W.BinOp (I64 op, f, g))) - let int64_shift_op stack_ctx x op f g = + let int64_shift_op op f g = let* f = Memory.unbox_int64 f in let* g = Value.int_val g in - Memory.box_int64 stack_ctx x (return (W.BinOp (I64 op, f, I64ExtendI32 (S, g)))) + Memory.box_int64 (return (W.BinOp (I64 op, f, I64ExtendI32 (S, g)))) - let nativeint_bin_op stack_ctx x op f g = + let nativeint_bin_op op f g = let* f = Memory.unbox_nativeint f in let* g = Memory.unbox_nativeint g in - Memory.box_nativeint stack_ctx x (return (W.BinOp (I32 op, f, g))) + Memory.box_nativeint (return (W.BinOp (I32 op, f, g))) - let nativeint_shift_op stack_ctx x op f g = + let nativeint_shift_op op f g = let* f = Memory.unbox_nativeint f in let* g = Value.int_val g in - Memory.box_nativeint stack_ctx x (return (W.BinOp (I32 op, f, g))) + Memory.box_nativeint (return (W.BinOp (I32 op, f, g))) let label_index context pc = let rec index_rec context pc i = @@ -106,57 +103,48 @@ module Generate (Target : Wa_target_sig.S) = struct let zero_divide_pc = -2 - let rec translate_expr ctx stack_ctx context x e = + let rec translate_expr ctx context x e = match e with | Apply { f; args; exact } when exact || List.length args = if Var.Set.mem x ctx.in_cps then 2 else 1 -> - let* () = Stack.perform_spilling stack_ctx (`Instr x) in let rec loop acc l = match l with | [] -> ( let arity = List.length args in let funct = Var.fresh () in let* closure = tee funct (load f) in - let* kind, funct = + let* ty, funct = Memory.load_function_pointer ~cps:(Var.Set.mem x ctx.in_cps) ~arity (load funct) in - Stack.kill_variables stack_ctx; let* b = is_closure f in if b then return (W.Call (f, List.rev (closure :: acc))) else - match kind, funct with - | `Index, W.ConstSym (V g, 0) | `Ref _, W.RefFunc g -> + match funct with + | W.RefFunc g -> (* Functions with constant closures ignore their environment. In case of partial application, we still need the closure. *) let* cl = if exact then Value.unit else return closure in return (W.Call (g, List.rev (cl :: acc))) - | `Index, _ -> - return - (W.Call_indirect - (func_type (arity + 1), funct, List.rev (closure :: acc))) - | `Ref ty, _ -> return (W.Call_ref (ty, funct, List.rev (closure :: acc))) - ) + | _ -> return (W.Call_ref (ty, funct, List.rev (closure :: acc)))) | x :: r -> let* x = load x in loop (x :: acc) r in loop [] args | Apply { f; args; _ } -> - let* () = Stack.perform_spilling stack_ctx (`Instr x) in let* apply = need_apply_fun ~cps:(Var.Set.mem x ctx.in_cps) ~arity:(List.length args) in let* args = expression_list load args in let* closure = load f in - Stack.kill_variables stack_ctx; return (W.Call (apply, args @ [ closure ])) | Block (tag, a, _, _) -> - Memory.allocate stack_ctx x ~tag (List.map ~f:(fun x -> `Var x) (Array.to_list a)) + Memory.allocate ~tag (List.map ~f:(fun x -> `Var x) (Array.to_list a)) | Field (x, n, Non_float) -> Memory.field (load x) n | Field (x, n, Float) -> Memory.float_array_get @@ -166,15 +154,13 @@ module Generate (Target : Wa_target_sig.S) = struct Closure.translate ~context:ctx.global_context ~closures:ctx.closures - ~stack_ctx ~cps:(Var.Set.mem x ctx.in_cps) x | Constant c -> Constant.translate c | Special (Alias_prim _) -> assert false - | Prim (Extern "caml_alloc_dummy_function", [ _; Pc (Int arity) ]) - when Poly.(target = `GC) -> + | Prim (Extern "caml_alloc_dummy_function", [ _; Pc (Int arity) ]) -> Closure.dummy ~cps:(Config.Flag.effects ()) ~arity:(Targetint.to_int_exn arity) - | Prim (Extern "caml_alloc_dummy_infix", _) when Poly.(target = `GC) -> + | Prim (Extern "caml_alloc_dummy_infix", _) -> Closure.dummy ~cps:(Config.Flag.effects ()) ~arity:1 | Prim (Extern "caml_get_global", [ Pc (String name) ]) -> let* x = @@ -183,7 +169,7 @@ module Generate (Target : Wa_target_sig.S) = struct List.find_map ~f:(fun f -> match f with - | W.Global { name = V name'; exported_name = Some exported_name; _ } + | W.Global { name = name'; exported_name = Some exported_name; _ } when String.equal exported_name name -> Some name' | _ -> None) context.other_fields @@ -193,18 +179,18 @@ module Generate (Target : Wa_target_sig.S) = struct let* typ = Value.block_type in register_import ~import_module:"OCaml" ~name (Global { mut = true; typ }) in - return (W.GlobalGet (V x)) + return (W.GlobalGet x) | Prim (Extern "caml_set_global", [ Pc (String name); v ]) -> let v = transl_prim_arg v in let x = Var.fresh_n name in let* () = let* typ = Value.block_type in let* dummy = Value.dummy_block in - register_global (V x) ~exported_name:name { mut = true; typ } dummy + register_global x ~exported_name:name { mut = true; typ } dummy in seq (let* v = Value.as_block v in - instr (W.GlobalSet (V x, v))) + instr (W.GlobalSet (x, v))) Value.unit | Prim (p, l) -> ( match p with @@ -278,23 +264,22 @@ module Generate (Target : Wa_target_sig.S) = struct in instr (W.Br_if (label_index context bound_error_pc, cond))) x - | Extern "caml_add_float", [ f; g ] -> float_bin_op stack_ctx x Add f g - | Extern "caml_sub_float", [ f; g ] -> float_bin_op stack_ctx x Sub f g - | Extern "caml_mul_float", [ f; g ] -> float_bin_op stack_ctx x Mul f g - | Extern "caml_div_float", [ f; g ] -> float_bin_op stack_ctx x Div f g - | Extern "caml_copysign_float", [ f; g ] -> - float_bin_op stack_ctx x CopySign f g + | Extern "caml_add_float", [ f; g ] -> float_bin_op Add f g + | Extern "caml_sub_float", [ f; g ] -> float_bin_op Sub f g + | Extern "caml_mul_float", [ f; g ] -> float_bin_op Mul f g + | Extern "caml_div_float", [ f; g ] -> float_bin_op Div f g + | Extern "caml_copysign_float", [ f; g ] -> float_bin_op CopySign f g | Extern "caml_signbit_float", [ f ] -> let* f = Memory.unbox_float f in let sign = W.BinOp (F64 CopySign, Const (F64 1.), f) in Value.val_int (return (W.BinOp (F64 Lt, sign, Const (F64 0.)))) - | Extern "caml_neg_float", [ f ] -> float_un_op stack_ctx x Neg f - | Extern "caml_abs_float", [ f ] -> float_un_op stack_ctx x Abs f - | Extern "caml_ceil_float", [ f ] -> float_un_op stack_ctx x Ceil f - | Extern "caml_floor_float", [ f ] -> float_un_op stack_ctx x Floor f - | Extern "caml_trunc_float", [ f ] -> float_un_op stack_ctx x Trunc f - | Extern "caml_round_float", [ f ] -> float_un_op' stack_ctx x Math.round f - | Extern "caml_sqrt_float", [ f ] -> float_un_op stack_ctx x Sqrt f + | Extern "caml_neg_float", [ f ] -> float_un_op Neg f + | Extern "caml_abs_float", [ f ] -> float_un_op Abs f + | Extern "caml_ceil_float", [ f ] -> float_un_op Ceil f + | Extern "caml_floor_float", [ f ] -> float_un_op Floor f + | Extern "caml_trunc_float", [ f ] -> float_un_op Trunc f + | Extern "caml_round_float", [ f ] -> float_un_op' Math.round f + | Extern "caml_sqrt_float", [ f ] -> float_un_op Sqrt f | Extern "caml_eq_float", [ f; g ] -> float_comparison Eq f g | Extern "caml_neq_float", [ f; g ] -> float_comparison Ne f g | Extern "caml_ge_float", [ f; g ] -> float_comparison Ge f g @@ -306,71 +291,52 @@ module Generate (Target : Wa_target_sig.S) = struct Value.val_int (return (W.UnOp (I32 (TruncSatF64 S), f))) | Extern "caml_float_of_int", [ n ] -> let* n = Value.int_val n in - Memory.box_float - stack_ctx - x - (return (W.UnOp (F64 (Convert (`I32, S)), n))) - | Extern "caml_cos_float", [ f ] -> float_un_op' stack_ctx x Math.cos f - | Extern "caml_sin_float", [ f ] -> float_un_op' stack_ctx x Math.sin f - | Extern "caml_tan_float", [ f ] -> float_un_op' stack_ctx x Math.tan f - | Extern "caml_acos_float", [ f ] -> float_un_op' stack_ctx x Math.acos f - | Extern "caml_asin_float", [ f ] -> float_un_op' stack_ctx x Math.asin f - | Extern "caml_atan_float", [ f ] -> float_un_op' stack_ctx x Math.atan f - | Extern "caml_atan2_float", [ f; g ] -> - float_bin_op' stack_ctx x Math.atan2 f g - | Extern "caml_cosh_float", [ f ] -> float_un_op' stack_ctx x Math.cosh f - | Extern "caml_sinh_float", [ f ] -> float_un_op' stack_ctx x Math.sinh f - | Extern "caml_tanh_float", [ f ] -> float_un_op' stack_ctx x Math.tanh f - | Extern "caml_acosh_float", [ f ] -> float_un_op' stack_ctx x Math.acosh f - | Extern "caml_asinh_float", [ f ] -> float_un_op' stack_ctx x Math.asinh f - | Extern "caml_atanh_float", [ f ] -> float_un_op' stack_ctx x Math.atanh f - | Extern "caml_cbrt_float", [ f ] -> float_un_op' stack_ctx x Math.cbrt f - | Extern "caml_exp_float", [ f ] -> float_un_op' stack_ctx x Math.exp f - | Extern "caml_exp2_float", [ f ] -> float_un_op' stack_ctx x Math.exp2 f - | Extern "caml_log_float", [ f ] -> float_un_op' stack_ctx x Math.log f - | Extern "caml_expm1_float", [ f ] -> float_un_op' stack_ctx x Math.expm1 f - | Extern "caml_log1p_float", [ f ] -> float_un_op' stack_ctx x Math.log1p f - | Extern "caml_log2_float", [ f ] -> float_un_op' stack_ctx x Math.log2 f - | Extern "caml_log10_float", [ f ] -> float_un_op' stack_ctx x Math.log10 f - | Extern "caml_power_float", [ f; g ] -> - float_bin_op' stack_ctx x Math.power f g - | Extern "caml_hypot_float", [ f; g ] -> - float_bin_op' stack_ctx x Math.hypot f g - | Extern "caml_fmod_float", [ f; g ] -> - float_bin_op' stack_ctx x Math.fmod f g + Memory.box_float (return (W.UnOp (F64 (Convert (`I32, S)), n))) + | Extern "caml_cos_float", [ f ] -> float_un_op' Math.cos f + | Extern "caml_sin_float", [ f ] -> float_un_op' Math.sin f + | Extern "caml_tan_float", [ f ] -> float_un_op' Math.tan f + | Extern "caml_acos_float", [ f ] -> float_un_op' Math.acos f + | Extern "caml_asin_float", [ f ] -> float_un_op' Math.asin f + | Extern "caml_atan_float", [ f ] -> float_un_op' Math.atan f + | Extern "caml_atan2_float", [ f; g ] -> float_bin_op' Math.atan2 f g + | Extern "caml_cosh_float", [ f ] -> float_un_op' Math.cosh f + | Extern "caml_sinh_float", [ f ] -> float_un_op' Math.sinh f + | Extern "caml_tanh_float", [ f ] -> float_un_op' Math.tanh f + | Extern "caml_acosh_float", [ f ] -> float_un_op' Math.acosh f + | Extern "caml_asinh_float", [ f ] -> float_un_op' Math.asinh f + | Extern "caml_atanh_float", [ f ] -> float_un_op' Math.atanh f + | Extern "caml_cbrt_float", [ f ] -> float_un_op' Math.cbrt f + | Extern "caml_exp_float", [ f ] -> float_un_op' Math.exp f + | Extern "caml_exp2_float", [ f ] -> float_un_op' Math.exp2 f + | Extern "caml_log_float", [ f ] -> float_un_op' Math.log f + | Extern "caml_expm1_float", [ f ] -> float_un_op' Math.expm1 f + | Extern "caml_log1p_float", [ f ] -> float_un_op' Math.log1p f + | Extern "caml_log2_float", [ f ] -> float_un_op' Math.log2 f + | Extern "caml_log10_float", [ f ] -> float_un_op' Math.log10 f + | Extern "caml_power_float", [ f; g ] -> float_bin_op' Math.power f g + | Extern "caml_hypot_float", [ f; g ] -> float_bin_op' Math.hypot f g + | Extern "caml_fmod_float", [ f; g ] -> float_bin_op' Math.fmod f g | Extern "caml_int32_bits_of_float", [ f ] -> let* f = Memory.unbox_float f in - Memory.box_int32 - stack_ctx - x - (return (W.UnOp (I32 ReinterpretF, F32DemoteF64 f))) + Memory.box_int32 (return (W.UnOp (I32 ReinterpretF, F32DemoteF64 f))) | Extern "caml_int32_float_of_bits", [ i ] -> let* i = Memory.unbox_int32 i in - Memory.box_float - stack_ctx - x - (return (W.F64PromoteF32 (UnOp (F32 ReinterpretI, i)))) + Memory.box_float (return (W.F64PromoteF32 (UnOp (F32 ReinterpretI, i)))) | Extern "caml_int32_of_float", [ f ] -> let* f = Memory.unbox_float f in - Memory.box_int32 stack_ctx x (return (W.UnOp (I32 (TruncSatF64 S), f))) + Memory.box_int32 (return (W.UnOp (I32 (TruncSatF64 S), f))) | Extern "caml_int32_to_float", [ n ] -> let* n = Memory.unbox_int32 n in - Memory.box_float - stack_ctx - x - (return (W.UnOp (F64 (Convert (`I32, S)), n))) + Memory.box_float (return (W.UnOp (F64 (Convert (`I32, S)), n))) | Extern "caml_int32_neg", [ i ] -> let* i = Memory.unbox_int32 i in - Memory.box_int32 - stack_ctx - x - (return (W.BinOp (I32 Sub, Const (I32 0l), i))) - | Extern "caml_int32_add", [ i; j ] -> int32_bin_op stack_ctx x Add i j - | Extern "caml_int32_sub", [ i; j ] -> int32_bin_op stack_ctx x Sub i j - | Extern "caml_int32_mul", [ i; j ] -> int32_bin_op stack_ctx x Mul i j - | Extern "caml_int32_and", [ i; j ] -> int32_bin_op stack_ctx x And i j - | Extern "caml_int32_or", [ i; j ] -> int32_bin_op stack_ctx x Or i j - | Extern "caml_int32_xor", [ i; j ] -> int32_bin_op stack_ctx x Xor i j + Memory.box_int32 (return (W.BinOp (I32 Sub, Const (I32 0l), i))) + | Extern "caml_int32_add", [ i; j ] -> int32_bin_op Add i j + | Extern "caml_int32_sub", [ i; j ] -> int32_bin_op Sub i j + | Extern "caml_int32_mul", [ i; j ] -> int32_bin_op Mul i j + | Extern "caml_int32_and", [ i; j ] -> int32_bin_op And i j + | Extern "caml_int32_or", [ i; j ] -> int32_bin_op Or i j + | Extern "caml_int32_xor", [ i; j ] -> int32_bin_op Xor i j | Extern "caml_int32_div", [ i; j ] -> let res = Var.fresh () in (*ZZZ Can we do better?*) @@ -403,7 +369,7 @@ module Generate (Target : Wa_target_sig.S) = struct (let* i = load i' in let* j = load j' in return (W.BinOp (I32 (Div S), i, j))))) - (Memory.box_int32 stack_ctx x (load res)) + (Memory.box_int32 (load res)) | Extern "caml_int32_mod", [ i; j ] -> let j' = Var.fresh () in seq @@ -413,43 +379,34 @@ module Generate (Target : Wa_target_sig.S) = struct (W.Br_if (label_index context zero_divide_pc, W.UnOp (I32 Eqz, j)))) (let* i = Memory.unbox_int32 i in let* j = load j' in - Memory.box_int32 stack_ctx x (return (W.BinOp (I32 (Rem S), i, j)))) - | Extern "caml_int32_shift_left", [ i; j ] -> - int32_shift_op stack_ctx x Shl i j - | Extern "caml_int32_shift_right", [ i; j ] -> - int32_shift_op stack_ctx x (Shr S) i j + Memory.box_int32 (return (W.BinOp (I32 (Rem S), i, j)))) + | Extern "caml_int32_shift_left", [ i; j ] -> int32_shift_op Shl i j + | Extern "caml_int32_shift_right", [ i; j ] -> int32_shift_op (Shr S) i j | Extern "caml_int32_shift_right_unsigned", [ i; j ] -> - int32_shift_op stack_ctx x (Shr U) i j + int32_shift_op (Shr U) i j | Extern "caml_int32_to_int", [ i ] -> Value.val_int (Memory.unbox_int32 i) - | Extern "caml_int32_of_int", [ i ] -> - Memory.box_int32 stack_ctx x (Value.int_val i) + | Extern "caml_int32_of_int", [ i ] -> Memory.box_int32 (Value.int_val i) | Extern "caml_int64_bits_of_float", [ f ] -> let* f = Memory.unbox_float f in - Memory.box_int64 stack_ctx x (return (W.UnOp (I64 ReinterpretF, f))) + Memory.box_int64 (return (W.UnOp (I64 ReinterpretF, f))) | Extern "caml_int64_float_of_bits", [ i ] -> let* i = Memory.unbox_int64 i in - Memory.box_float stack_ctx x (return (W.UnOp (F64 ReinterpretI, i))) + Memory.box_float (return (W.UnOp (F64 ReinterpretI, i))) | Extern "caml_int64_of_float", [ f ] -> let* f = Memory.unbox_float f in - Memory.box_int64 stack_ctx x (return (W.UnOp (I64 (TruncSatF64 S), f))) + Memory.box_int64 (return (W.UnOp (I64 (TruncSatF64 S), f))) | Extern "caml_int64_to_float", [ n ] -> let* n = Memory.unbox_int64 n in - Memory.box_float - stack_ctx - x - (return (W.UnOp (F64 (Convert (`I64, S)), n))) + Memory.box_float (return (W.UnOp (F64 (Convert (`I64, S)), n))) | Extern "caml_int64_neg", [ i ] -> let* i = Memory.unbox_int64 i in - Memory.box_int64 - stack_ctx - x - (return (W.BinOp (I64 Sub, Const (I64 0L), i))) - | Extern "caml_int64_add", [ i; j ] -> int64_bin_op stack_ctx x Add i j - | Extern "caml_int64_sub", [ i; j ] -> int64_bin_op stack_ctx x Sub i j - | Extern "caml_int64_mul", [ i; j ] -> int64_bin_op stack_ctx x Mul i j - | Extern "caml_int64_and", [ i; j ] -> int64_bin_op stack_ctx x And i j - | Extern "caml_int64_or", [ i; j ] -> int64_bin_op stack_ctx x Or i j - | Extern "caml_int64_xor", [ i; j ] -> int64_bin_op stack_ctx x Xor i j + Memory.box_int64 (return (W.BinOp (I64 Sub, Const (I64 0L), i))) + | Extern "caml_int64_add", [ i; j ] -> int64_bin_op Add i j + | Extern "caml_int64_sub", [ i; j ] -> int64_bin_op Sub i j + | Extern "caml_int64_mul", [ i; j ] -> int64_bin_op Mul i j + | Extern "caml_int64_and", [ i; j ] -> int64_bin_op And i j + | Extern "caml_int64_or", [ i; j ] -> int64_bin_op Or i j + | Extern "caml_int64_xor", [ i; j ] -> int64_bin_op Xor i j | Extern "caml_int64_div", [ i; j ] -> let res = Var.fresh () in (*ZZZ Can we do better?*) @@ -482,7 +439,7 @@ module Generate (Target : Wa_target_sig.S) = struct (let* i = load i' in let* j = load j' in return (W.BinOp (I64 (Div S), i, j))))) - (Memory.box_int64 stack_ctx x (load res)) + (Memory.box_int64 (load res)) | Extern "caml_int64_mod", [ i; j ] -> let j' = Var.fresh () in seq @@ -492,78 +449,54 @@ module Generate (Target : Wa_target_sig.S) = struct (W.Br_if (label_index context zero_divide_pc, W.UnOp (I64 Eqz, j)))) (let* i = Memory.unbox_int64 i in let* j = load j' in - Memory.box_int64 stack_ctx x (return (W.BinOp (I64 (Rem S), i, j)))) - | Extern "caml_int64_shift_left", [ i; j ] -> - int64_shift_op stack_ctx x Shl i j - | Extern "caml_int64_shift_right", [ i; j ] -> - int64_shift_op stack_ctx x (Shr S) i j + Memory.box_int64 (return (W.BinOp (I64 (Rem S), i, j)))) + | Extern "caml_int64_shift_left", [ i; j ] -> int64_shift_op Shl i j + | Extern "caml_int64_shift_right", [ i; j ] -> int64_shift_op (Shr S) i j | Extern "caml_int64_shift_right_unsigned", [ i; j ] -> - int64_shift_op stack_ctx x (Shr U) i j + int64_shift_op (Shr U) i j | Extern "caml_int64_to_int", [ i ] -> let* i = Memory.unbox_int64 i in Value.val_int (return (W.I32WrapI64 i)) | Extern "caml_int64_of_int", [ i ] -> let* i = Value.int_val i in Memory.box_int64 - stack_ctx - x (return (match i with | Const (I32 i) -> W.Const (I64 (Int64.of_int32 i)) | _ -> W.I64ExtendI32 (S, i))) | Extern "caml_int64_to_int32", [ i ] -> let* i = Memory.unbox_int64 i in - Memory.box_int32 stack_ctx x (return (W.I32WrapI64 i)) + Memory.box_int32 (return (W.I32WrapI64 i)) | Extern "caml_int64_of_int32", [ i ] -> let* i = Memory.unbox_int32 i in - Memory.box_int64 stack_ctx x (return (W.I64ExtendI32 (S, i))) + Memory.box_int64 (return (W.I64ExtendI32 (S, i))) | Extern "caml_int64_to_nativeint", [ i ] -> let* i = Memory.unbox_int64 i in - Memory.box_nativeint stack_ctx x (return (W.I32WrapI64 i)) + Memory.box_nativeint (return (W.I32WrapI64 i)) | Extern "caml_int64_of_nativeint", [ i ] -> let* i = Memory.unbox_nativeint i in - Memory.box_int64 stack_ctx x (return (W.I64ExtendI32 (S, i))) + Memory.box_int64 (return (W.I64ExtendI32 (S, i))) | Extern "caml_nativeint_bits_of_float", [ f ] -> let* f = Memory.unbox_float f in - Memory.box_nativeint - stack_ctx - x - (return (W.UnOp (I32 ReinterpretF, F32DemoteF64 f))) + Memory.box_nativeint (return (W.UnOp (I32 ReinterpretF, F32DemoteF64 f))) | Extern "caml_nativeint_float_of_bits", [ i ] -> let* i = Memory.unbox_int64 i in - Memory.box_float - stack_ctx - x - (return (W.F64PromoteF32 (UnOp (I32 ReinterpretF, i)))) + Memory.box_float (return (W.F64PromoteF32 (UnOp (I32 ReinterpretF, i)))) | Extern "caml_nativeint_of_float", [ f ] -> let* f = Memory.unbox_float f in - Memory.box_nativeint - stack_ctx - x - (return (W.UnOp (I32 (TruncSatF64 S), f))) + Memory.box_nativeint (return (W.UnOp (I32 (TruncSatF64 S), f))) | Extern "caml_nativeint_to_float", [ n ] -> let* n = Memory.unbox_nativeint n in - Memory.box_float - stack_ctx - x - (return (W.UnOp (F64 (Convert (`I32, S)), n))) + Memory.box_float (return (W.UnOp (F64 (Convert (`I32, S)), n))) | Extern "caml_nativeint_neg", [ i ] -> let* i = Memory.unbox_nativeint i in - Memory.box_nativeint - stack_ctx - x - (return (W.BinOp (I32 Sub, Const (I32 0l), i))) - | Extern "caml_nativeint_add", [ i; j ] -> - nativeint_bin_op stack_ctx x Add i j - | Extern "caml_nativeint_sub", [ i; j ] -> - nativeint_bin_op stack_ctx x Sub i j - | Extern "caml_nativeint_mul", [ i; j ] -> - nativeint_bin_op stack_ctx x Mul i j - | Extern "caml_nativeint_and", [ i; j ] -> - nativeint_bin_op stack_ctx x And i j - | Extern "caml_nativeint_or", [ i; j ] -> nativeint_bin_op stack_ctx x Or i j - | Extern "caml_nativeint_xor", [ i; j ] -> - nativeint_bin_op stack_ctx x Xor i j + Memory.box_nativeint (return (W.BinOp (I32 Sub, Const (I32 0l), i))) + | Extern "caml_nativeint_add", [ i; j ] -> nativeint_bin_op Add i j + | Extern "caml_nativeint_sub", [ i; j ] -> nativeint_bin_op Sub i j + | Extern "caml_nativeint_mul", [ i; j ] -> nativeint_bin_op Mul i j + | Extern "caml_nativeint_and", [ i; j ] -> nativeint_bin_op And i j + | Extern "caml_nativeint_or", [ i; j ] -> nativeint_bin_op Or i j + | Extern "caml_nativeint_xor", [ i; j ] -> nativeint_bin_op Xor i j | Extern "caml_nativeint_div", [ i; j ] -> let res = Var.fresh () in (*ZZZ Can we do better?*) @@ -596,7 +529,7 @@ module Generate (Target : Wa_target_sig.S) = struct (let* i = load i' in let* j = load j' in return (W.BinOp (I32 (Div S), i, j))))) - (Memory.box_nativeint stack_ctx x (load res)) + (Memory.box_nativeint (load res)) | Extern "caml_nativeint_mod", [ i; j ] -> let j' = Var.fresh () in seq @@ -606,17 +539,16 @@ module Generate (Target : Wa_target_sig.S) = struct (W.Br_if (label_index context zero_divide_pc, W.UnOp (I32 Eqz, j)))) (let* i = Memory.unbox_nativeint i in let* j = load j' in - Memory.box_nativeint stack_ctx x (return (W.BinOp (I32 (Rem S), i, j)))) - | Extern "caml_nativeint_shift_left", [ i; j ] -> - nativeint_shift_op stack_ctx x Shl i j + Memory.box_nativeint (return (W.BinOp (I32 (Rem S), i, j)))) + | Extern "caml_nativeint_shift_left", [ i; j ] -> nativeint_shift_op Shl i j | Extern "caml_nativeint_shift_right", [ i; j ] -> - nativeint_shift_op stack_ctx x (Shr S) i j + nativeint_shift_op (Shr S) i j | Extern "caml_nativeint_shift_right_unsigned", [ i; j ] -> - nativeint_shift_op stack_ctx x (Shr U) i j + nativeint_shift_op (Shr U) i j | Extern "caml_nativeint_to_int", [ i ] -> Value.val_int (Memory.unbox_nativeint i) | Extern "caml_nativeint_of_int", [ i ] -> - Memory.box_nativeint stack_ctx x (Value.int_val i) + Memory.box_nativeint (Value.int_val i) | Extern "caml_int_compare", [ i; j ] -> Value.val_int Arith.( @@ -632,17 +564,14 @@ module Generate (Target : Wa_target_sig.S) = struct l ~init:(return []) in - Memory.allocate stack_ctx x ~tag:0 l + Memory.allocate ~tag:0 l | Extern name, l -> let name = Primitive.resolve name in (*ZZZ Different calling convention when large number of parameters *) let* f = register_import ~name (Fun (func_type (List.length l))) in - let* () = Stack.perform_spilling stack_ctx (`Instr x) in let rec loop acc l = match l with - | [] -> - Stack.kill_variables stack_ctx; - return (W.Call (f, List.rev acc)) + | [] -> return (W.Call (f, List.rev acc)) | x :: r -> let* x = x in loop (x :: acc) r @@ -660,17 +589,15 @@ module Generate (Target : Wa_target_sig.S) = struct | (Not | Lt | Le | Eq | Neq | Ult | Array_get | IsInt | Vectlength), _ -> assert false)) - and translate_instr ctx stack_ctx context (i, loc) = + and translate_instr ctx context (i, loc) = with_location loc (match i with - | Assign (x, y) -> - let* () = assign x (load y) in - Stack.assign stack_ctx x + | Assign (x, y) -> assign x (load y) | Let (x, e) -> if ctx.live.(Var.idx x) = 0 - then drop (translate_expr ctx stack_ctx context x e) - else store x (translate_expr ctx stack_ctx context x e) + then drop (translate_expr ctx context x e) + else store x (translate_expr ctx context x e) | Set_field (x, n, Non_float, y) -> Memory.set_field (load x) n (load y) | Set_field (x, n, Float, y) -> Memory.float_array_set @@ -685,13 +612,12 @@ module Generate (Target : Wa_target_sig.S) = struct Arith.(Value.int_val (Memory.field (load x) 0) + const (Int32.of_int n))) | Array_set (x, y, z) -> Memory.array_set (load x) (load y) (load z)) - and translate_instrs ctx stack_ctx context l = + and translate_instrs ctx context l = match l with | [] -> return () | i :: rem -> - let* () = Stack.perform_reloads stack_ctx (`Instr (fst i)) in - let* () = translate_instr ctx stack_ctx context i in - translate_instrs ctx stack_ctx context rem + let* () = translate_instr ctx context i in + translate_instrs ctx context rem let parallel_renaming params args = let rec visit visited prev s m x l = @@ -844,18 +770,6 @@ module Generate (Target : Wa_target_sig.S) = struct { ctx with blocks } | None -> ctx in - let stack_info = - Stack.generate_spilling_information - p - ~context:ctx.global_context - ~closures:ctx.closures - ~env: - (match name_opt with - | Some name -> name - | None -> Var.fresh ()) - ~pc - ~params - in let g = Structure.build_graph ctx.blocks pc in let dom = Structure.dominator_tree g in let rec translate_tree result_typ fall_through pc context = @@ -910,17 +824,12 @@ module Generate (Target : Wa_target_sig.S) = struct translate_tree result_typ fall_through pc' context | [] -> let block = Addr.Map.find pc ctx.blocks in - let* global_context = get_context in - let stack_ctx = Stack.start_block ~context:global_context stack_info pc in - let* () = translate_instrs ctx stack_ctx context block.body in - let* () = Stack.perform_reloads stack_ctx (`Branch (fst block.branch)) in - let* () = Stack.perform_spilling stack_ctx (`Block pc) in + let* () = translate_instrs ctx context block.body in let branch, loc = block.branch in with_location loc (match branch with - | Branch cont -> - translate_branch result_typ fall_through pc cont context stack_ctx + | Branch cont -> translate_branch result_typ fall_through pc cont context | Return x -> ( let* e = load x in match fall_through with @@ -931,43 +840,22 @@ module Generate (Target : Wa_target_sig.S) = struct if_ { params = []; result = result_typ } (Value.check_is_not_zero (load x)) - (translate_branch result_typ fall_through pc cont1 context' stack_ctx) - (translate_branch result_typ fall_through pc cont2 context' stack_ctx) + (translate_branch result_typ fall_through pc cont1 context') + (translate_branch result_typ fall_through pc cont2 context') | Stop -> ( let* e = Value.unit in match fall_through with | `Return -> instr (Push e) | `Block _ -> instr (Return (Some e))) - | Switch (x, a1) -> - let l = - List.filter - ~f:(fun pc' -> - Stack.stack_adjustment_needed stack_ctx ~src:pc ~dst:pc') - (List.rev (Addr.Set.elements (Structure.get_edges dom pc))) - in - let br_table e a context = - let len = Array.length a in - let l = Array.to_list (Array.sub a ~pos:0 ~len:(len - 1)) in - let dest (pc, args) = - assert (List.is_empty args); - label_index context pc - in - let* e = e in - instr (Br_table (e, List.map ~f:dest l, dest a.(len - 1))) + | Switch (x, a) -> + let len = Array.length a in + let l = Array.to_list (Array.sub a ~pos:0 ~len:(len - 1)) in + let dest (pc, args) = + assert (List.is_empty args); + label_index context pc in - let rec nest l context = - match l with - | pc' :: rem -> - let* () = - Wa_code_generation.block - { params = []; result = [] } - (nest rem (`Block pc' :: context)) - in - let* () = Stack.adjust_stack stack_ctx ~src:pc ~dst:pc' in - instr (Br (label_index context pc', None)) - | [] -> br_table (Value.int_val (load x)) a1 context - in - nest l context + let* e = Value.int_val (load x) in + instr (Br_table (e, List.map ~f:dest l, dest a.(len - 1))) | Raise (x, _) -> let* e = load x in let* tag = register_import ~name:exception_name (Tag Value.value) in @@ -981,13 +869,12 @@ module Generate (Target : Wa_target_sig.S) = struct p (fst cont) (fun ~result_typ ~fall_through ~context -> - translate_branch result_typ fall_through pc cont context stack_ctx)) + translate_branch result_typ fall_through pc cont context)) x (fun ~result_typ ~fall_through ~context -> - translate_branch result_typ fall_through pc cont' context stack_ctx) - | Poptrap cont -> - translate_branch result_typ fall_through pc cont context stack_ctx) - and translate_branch result_typ fall_through src (dst, args) context stack_ctx = + translate_branch result_typ fall_through pc cont' context) + | Poptrap cont -> translate_branch result_typ fall_through pc cont context) + and translate_branch result_typ fall_through src (dst, args) context = let* () = if List.is_empty args then return () @@ -995,7 +882,6 @@ module Generate (Target : Wa_target_sig.S) = struct let block = Addr.Map.find dst ctx.blocks in parallel_renaming block.params args in - let* () = Stack.adjust_stack stack_ctx ~src ~dst in match fall_through with | `Block dst' when dst = dst' -> return () | _ -> @@ -1042,8 +928,6 @@ module Generate (Target : Wa_target_sig.S) = struct ~param_names ~body: (let* () = build_initial_env in - let stack_ctx = Stack.start_function ~context:ctx.global_context stack_info in - let* () = Stack.perform_spilling stack_ctx `Function in wrap_with_handlers p pc @@ -1051,7 +935,7 @@ module Generate (Target : Wa_target_sig.S) = struct ~fall_through:`Return ~context:[] (fun ~result_typ ~fall_through ~context -> - translate_branch result_typ fall_through (-1) cont context stack_ctx)) + translate_branch result_typ fall_through (-1) cont context)) in let body = post_process_function_body ~param_names ~locals body in W.Function @@ -1174,8 +1058,7 @@ module Generate (Target : Wa_target_sig.S) = struct in let constant_data = List.map - ~f:(fun (name, (active, contents)) -> - W.Data { name; read_only = true; active; contents }) + ~f:(fun (name, contents) -> W.Data { name; contents }) (Var.Map.bindings context.data_segments) in List.rev_append context.other_fields (imports @ constant_data) @@ -1232,51 +1115,25 @@ let fix_switch_branches p = p.blocks; !p' -let start () = - make_context - ~value_type: - (match target with - | `Core -> Wa_core_target.Value.value - | `GC -> Wa_gc_target.Value.value) +let start () = make_context ~value_type:Wa_gc_target.Value.value let f ~context ~unit_name p ~live_vars ~in_cps ~debug = let p = if Config.Flag.effects () then fix_switch_branches p else p in - match target with - | `Core -> - let module G = Generate (Wa_core_target) in - G.f ~context ~unit_name ~live_vars ~in_cps ~debug p - | `GC -> - let module G = Generate (Wa_gc_target) in - G.f ~context ~unit_name ~live_vars ~in_cps ~debug p + let module G = Generate (Wa_gc_target) in + G.f ~context ~unit_name ~live_vars ~in_cps ~debug p let add_start_function = - match target with - | `Core -> - let module G = Generate (Wa_core_target) in - G.add_start_function - | `GC -> - let module G = Generate (Wa_gc_target) in - G.add_start_function + let module G = Generate (Wa_gc_target) in + G.add_start_function let add_init_function = - match target with - | `Core -> - let module G = Generate (Wa_core_target) in - G.add_init_function - | `GC -> - let module G = Generate (Wa_gc_target) in - G.add_init_function + let module G = Generate (Wa_gc_target) in + G.add_init_function let output ch ~context ~debug = - match target with - | `Core -> - let module G = Generate (Wa_core_target) in - let fields = G.output ~context in - Wa_asm_output.f ch fields - | `GC -> - let module G = Generate (Wa_gc_target) in - let fields = G.output ~context in - Wa_wat_output.f ~debug ch fields + let module G = Generate (Wa_gc_target) in + let fields = G.output ~context in + Wa_wat_output.f ~debug ch fields let wasm_output ch ~context = let module G = Generate (Wa_gc_target) in diff --git a/compiler/lib/wasm/wa_initialize_locals.ml b/compiler/lib/wasm/wa_initialize_locals.ml index 3d7ea6a81..acbec8649 100644 --- a/compiler/lib/wasm/wa_initialize_locals.ml +++ b/compiler/lib/wasm/wa_initialize_locals.ml @@ -33,15 +33,12 @@ let check_initialized ctx i = let rec scan_expression ctx e = match e with - | Wa_ast.Const _ | ConstSym _ | GlobalGet _ | Pop _ | RefFunc _ | RefNull _ -> () + | Wa_ast.Const _ | GlobalGet _ | Pop _ | RefFunc _ | RefNull _ -> () | UnOp (_, e') | I32WrapI64 e' | I64ExtendI32 (_, e') | F32DemoteF64 e' | F64PromoteF32 e' - | Load (_, e') - | Load8 (_, _, e') - | MemoryGrow (_, e') | RefI31 e' | I31Get (_, e') | ArrayLen e' @@ -61,7 +58,7 @@ let rec scan_expression ctx e = | LocalTee (i, e') -> scan_expression ctx e'; mark_initialized ctx i - | Call_indirect (_, e', l) | Call_ref (_, e', l) -> + | Call_ref (_, e', l) -> scan_expressions ctx l; scan_expression ctx e' | Call (_, l) | ArrayNewFixed (_, l) | StructNew (_, l) -> scan_expressions ctx l @@ -84,7 +81,7 @@ and scan_instruction ctx i = | Throw (_, e) | Return (Some e) | Push e -> scan_expression ctx e - | Store (_, e, e') | Store8 (_, e, e') | StructSet (_, _, e, e') -> + | StructSet (_, _, e, e') -> scan_expression ctx e; scan_expression ctx e' | LocalSet (i, e) -> @@ -105,7 +102,7 @@ and scan_instruction ctx i = scan_expression ctx e; scan_expression ctx e'; scan_expression ctx e'' - | Return_call_indirect (_, e', l) | Return_call_ref (_, e', l) -> + | Return_call_ref (_, e', l) -> scan_expressions ctx l; scan_expression ctx e' | Location (_, i) -> scan_instruction ctx i diff --git a/compiler/lib/wasm/wa_liveness.ml b/compiler/lib/wasm/wa_liveness.ml deleted file mode 100644 index 59c528411..000000000 --- a/compiler/lib/wasm/wa_liveness.ml +++ /dev/null @@ -1,246 +0,0 @@ -(* Wasm_of_ocaml compiler - * http://www.ocsigen.org/js_of_ocaml/ - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) - -(* -ZZZ If live in exception handler, live any place we may raise in the body -*) - -open! Stdlib -open Code - -module Domain = struct - type t = - { input : Var.Set.t - ; output : Var.Set.t - } - - let bot = { input = Var.Set.empty; output = Var.Set.empty } - - let equal v v' = Var.Set.equal v.input v'.input -end - -(*ZZZ from wa_generate *) -let get_free_variables ~context info = - List.filter - ~f:(fun x -> not (Hashtbl.mem context.Wa_code_generation.constants x)) - info.Wa_closure_conversion.free_variables - -let function_free_variables ~context ~closures x = - let info = Var.Map.find x closures in - let f, _ = List.hd info.Wa_closure_conversion.functions in - if Var.equal x f then get_free_variables ~context info else [] - -let get_set h x = try Hashtbl.find h x with Not_found -> Addr.Set.empty - -let cont_deps (deps, rev_deps) pc (pc', _) = - Hashtbl.replace deps pc' (Addr.Set.add pc (get_set deps pc')); - Hashtbl.replace rev_deps pc (Addr.Set.add pc' (get_set rev_deps pc)) - -let block_deps deps block pc = - match fst block.branch with - | Return _ | Raise _ | Stop -> () - | Branch cont | Poptrap cont -> cont_deps deps pc cont - | Cond (_, cont1, cont2) -> - cont_deps deps pc cont1; - cont_deps deps pc cont2 - | Switch (_, a1) -> Array.iter a1 ~f:(fun cont -> cont_deps deps pc cont) - | Pushtrap (cont, _, cont_h) -> - cont_deps deps pc cont; - cont_deps deps pc cont_h - -let function_deps blocks pc = - let deps = Hashtbl.create 16, Hashtbl.create 16 in - Code.traverse - { fold = fold_children } - (fun pc () -> - let block = Addr.Map.find pc blocks in - block_deps deps block pc) - pc - blocks - (); - deps - -type ctx = - { env : Var.t - ; bound_vars : Var.Set.t - ; spilled_vars : Var.Set.t - ; context : Wa_code_generation.context - } - -let add_var ~ctx s x = - if Hashtbl.mem ctx.context.Wa_code_generation.constants x - then s - else - let x = if Var.Set.mem x ctx.bound_vars then x else ctx.env in - if Var.Set.mem x ctx.spilled_vars then Var.Set.add x s else s - -let add_list ~ctx s l = List.fold_left ~f:(fun s x -> add_var ~ctx s x) ~init:s l - -let add_prim_args ~ctx s l = - List.fold_left - ~f:(fun s x -> - match x with - | Pc _ -> s - | Pv x -> add_var ~ctx s x) - ~init:s - l - -let add_array ~ctx s a = Array.fold_left ~f:(fun s x -> add_var ~ctx s x) ~init:s a - -let expr_used ~context ~closures ~ctx x e s = - match e with - | Apply { f; args; _ } -> add_list ~ctx s (f :: args) - | Block (_, a, _, _) -> add_array ~ctx s a - | Prim (_, l) -> add_prim_args ~ctx s l - | Closure _ -> add_list ~ctx s (function_free_variables ~context ~closures x) - | Constant _ | Special _ -> s - | Field (x, _, _) -> add_var ~ctx s x - -let propagate_through_instr ~context ~closures ~ctx (i, _) s = - match i with - | Let (x, e) -> expr_used ~context ~closures ~ctx x e (Var.Set.remove x s) - | Set_field (x, _, _, y) -> add_var ~ctx (add_var ~ctx s x) y - | Assign (_, x) | Offset_ref (x, _) -> add_var ~ctx s x - | Array_set (x, y, z) -> add_var ~ctx (add_var ~ctx (add_var ~ctx s x) y) z - -let cont_used ~ctx (_, args) s = add_list ~ctx s args - -let propagate_through_branch ~ctx (b, _) s = - match b with - | Return x | Raise (x, _) -> add_var ~ctx s x - | Stop -> s - | Branch cont | Poptrap cont -> cont_used ~ctx cont s - | Cond (_, cont1, cont2) -> s |> cont_used ~ctx cont1 |> cont_used ~ctx cont2 - | Switch (_, a1) -> Array.fold_right a1 ~f:(fun cont s -> cont_used ~ctx cont s) ~init:s - | Pushtrap (cont, x, cont_h) -> - s |> cont_used ~ctx cont |> cont_used ~ctx cont_h |> Var.Set.remove x - -let propagate blocks ~context ~closures ~ctx rev_deps st pc = - let input = - pc - |> get_set rev_deps - |> Addr.Set.elements - |> List.map ~f:(fun pc' -> (Addr.Map.find pc' st).Domain.output) - |> List.fold_left ~f:Var.Set.union ~init:Var.Set.empty - in - let b = Addr.Map.find pc blocks in - let s = propagate_through_branch ~ctx b.branch input in - let output = - List.fold_right - ~f:(fun i s -> propagate_through_instr ~context ~closures ~ctx i s) - ~init:s - b.body - in - let output = Var.Set.diff output (Var.Set.of_list b.params) in - { Domain.input; output } - -module G = Dgraph.Make (Int) (Addr.Set) (Addr.Map) -module Solver = G.Solver (Domain) - -type block_info = - { initially_live : Var.Set.t (* Live at start of block *) - ; live_before_branch : Var.Set.t - } - -type info = - { instr : Var.Set.t Var.Map.t (* Live variables at spilling point *) - ; block : block_info Addr.Map.t - } - -let compute_instr_info ~blocks ~context ~closures ~domain ~ctx st = - Addr.Set.fold - (fun pc live_info -> - let live_vars = (Addr.Map.find pc st).Domain.input in - let block = Addr.Map.find pc blocks in - let live_vars = propagate_through_branch ~ctx block.Code.branch live_vars in - let _, live_info = - List.fold_right - ~f:(fun i (live_vars, live_info) -> - let live_vars' = - propagate_through_instr ~context ~closures ~ctx i live_vars - in - let live_info = - match fst i with - | Let (x, e) -> ( - match e with - | Apply _ | Prim _ -> - Var.Map.add x (Var.Set.remove x live_vars) live_info - | Block _ | Closure _ -> Var.Map.add x live_vars' live_info - | Constant _ | Field _ | Special _ -> live_info) - | Assign _ | Offset_ref _ | Set_field _ | Array_set _ -> live_info - in - live_vars', live_info) - ~init:(live_vars, live_info) - block.body - in - live_info) - domain - Var.Map.empty - -let compute_block_info ~blocks ~ctx st = - Addr.Map.mapi - (fun pc { Domain.input; output } -> - let block = Addr.Map.find pc blocks in - let live_before_branch = propagate_through_branch ~ctx block.Code.branch input in - { initially_live = output; live_before_branch }) - st - -let f ~blocks ~context ~closures ~domain ~env ~bound_vars ~spilled_vars ~pc = - let ctx = { env; bound_vars; spilled_vars; context } in - let deps, rev_deps = function_deps blocks pc in - let fold_children f pc acc = Addr.Set.fold f (get_set deps pc) acc in - let g = { G.domain; fold_children } in - let st = - Solver.f g (fun st pc -> propagate blocks ~context ~closures ~ctx rev_deps st pc) - in - let instr = compute_instr_info ~blocks ~context ~closures ~domain ~ctx st in - let block = compute_block_info ~blocks ~ctx st in - (* - Addr.Set.iter - (fun pc -> - let { Domain.input; output } = Addr.Map.find pc st in - Format.eprintf "input:"; - Var.Set.iter (fun x -> Format.eprintf " %a" Var.print x) input; - Format.eprintf "@."; - Format.eprintf "output:"; - Var.Set.iter (fun x -> Format.eprintf " %a" Var.print x) output; - Format.eprintf "@."; - let b = Addr.Map.find pc blocks in - let print_vars s = - Format.asprintf - "{%a}" - (fun f l -> - Format.pp_print_list ~pp_sep:(fun f () -> Format.fprintf f " ") Var.print f l) - (Var.Set.elements s) - in - Code.Print.block - (fun _pc loc -> - match loc with - | Instr (Let (x, _), _) -> ( - match Var.Map.find_opt x instr with - | Some s -> print_vars s - | None -> "") - | Instr _ -> "" - | Last _ -> - let s = Addr.Map.find pc block in - print_vars s.live_before_branch) - pc - b) - domain; - *) - { block; instr } diff --git a/compiler/lib/wasm/wa_liveness.mli b/compiler/lib/wasm/wa_liveness.mli deleted file mode 100644 index e6f7e3d2f..000000000 --- a/compiler/lib/wasm/wa_liveness.mli +++ /dev/null @@ -1,38 +0,0 @@ -(* Wasm_of_ocaml compiler - * http://www.ocsigen.org/js_of_ocaml/ - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) - -type block_info = - { initially_live : Code.Var.Set.t (* Live at start of block *) - ; live_before_branch : Code.Var.Set.t - } - -type info = - { instr : Code.Var.Set.t Code.Var.Map.t (* Live variables at spilling point *) - ; block : block_info Code.Addr.Map.t - } - -val f : - blocks:Code.block Code.Addr.Map.t - -> context:Wa_code_generation.context - -> closures:Wa_closure_conversion.closure Code.Var.Map.t - -> domain:Code.Addr.Set.t - -> env:Code.Var.t - -> bound_vars:Code.Var.Set.t - -> spilled_vars:Code.Var.Set.t - -> pc:int - -> info diff --git a/compiler/lib/wasm/wa_spilling.ml b/compiler/lib/wasm/wa_spilling.ml deleted file mode 100644 index f1eaa1b80..000000000 --- a/compiler/lib/wasm/wa_spilling.ml +++ /dev/null @@ -1,805 +0,0 @@ -(* Wasm_of_ocaml compiler - * http://www.ocsigen.org/js_of_ocaml/ - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) - -(* -We add spilling points at the end of each block and before each -possible GC: function calls and allocations. Local variables are -spilled at most once, at the first following spilling points. - -We first compute which local variables contain valid values at the -beginning of each block: either there has been no GC since their -definition or they have been accessed since the last GC point (so they -must have been reloaded). -Then, we compute which variables neeeds to be spilled at some point -(we access the local variable while it does not contain any valid -value). -From this, we can compute what need to be spilled at each spilling -point, and the stack contents at any point in the program. - -When allocating, we currently always spill everything. We should -probably spill everything only when a GC takes place. To keep the code -short, we should always spill variables that are still live after the -allocation, but variables that are no longer live after the allocation -only need to be spilled when a GC takes place. - -We should find a way to reuse local variables while they are spilled, -to minimize the number of local variables used. -*) - -let debug = Debug.find "spilling" - -open! Stdlib -open Code - -module Domain = struct - type t = - | Bot - | Set of - { input : Var.Set.t - ; output : Var.Set.t - } - - let bot = Bot - - let equal v v' = - match v, v' with - | Bot, Bot -> true - | Bot, Set _ | Set _, Bot -> false - | Set { input; _ }, Set { input = input'; _ } -> Var.Set.equal input input' -end - -let make_table l = - let h = Hashtbl.create 16 in - List.iter ~f:(fun s -> Hashtbl.add h s ()) l; - h - -(*ZZZ See lambda/translprim.ml + stdlib *) -let no_alloc_tbl = - make_table - [ "caml_array_unsafe_set" - ; "caml_string_unsafe_get" - ; "caml_string_unsafe_set" - ; "caml_bytes_unsafe_get" - ; "caml_bytes_unsafe_set" - ; "%int_add" - ; "%int_sub" - ; "%int_mul" - ; "%int_neg" - ; "%int_or" - ; "%int_and" - ; "%int_xor" - ; "%int_lsl" - ; "%int_lsr" - ; "%int_asr" - ] - -let no_pointer_tbl = - make_table - [ "caml_string_unsafe_get" - ; "caml_string_unsafe_set" - ; "caml_bytes_unsafe_get" - ; "caml_bytes_unsafe_set" - ; "%int_add" - ; "%int_sub" - ; "%int_mul" - ; "%int_neg" - ; "%int_or" - ; "%int_and" - ; "%int_xor" - ; "%int_lsl" - ; "%int_lsr" - ; "%int_asr" - ] - -let no_alloc p = - match p with - | Vectlength | Array_get | Not | IsInt | Eq | Neq | Lt | Le | Ult -> true - | Extern nm -> Hashtbl.mem no_alloc_tbl nm (* ZZZ Refine *) - -let no_pointer p = - match p with - | Vectlength | Not | IsInt | Eq | Neq | Lt | Le | Ult -> true - | Extern nm -> Hashtbl.mem no_pointer_tbl nm (* ZZZ Refine *) - | Array_get -> false - -(*ZZZ from wa_generate *) -let get_free_variables ~context info = - List.filter - ~f:(fun x -> not (Hashtbl.mem context.Wa_code_generation.constants x)) - info.Wa_closure_conversion.free_variables - -let function_free_variables ~context ~closures x = - let info = Code.Var.Map.find x closures in - let f, _ = List.hd info.Wa_closure_conversion.functions in - if Code.Var.equal x f then get_free_variables ~context info else [] - -let get_set h x = try Hashtbl.find h x with Not_found -> Addr.Set.empty - -let get_list h x = try Hashtbl.find h x with Not_found -> [] - -let cont_deps (deps, rev_deps) pc ?exn (pc', _) = - Hashtbl.replace deps pc (Addr.Set.add pc' (get_set deps pc)); - Hashtbl.replace rev_deps pc' ((pc, exn) :: get_list rev_deps pc') - -let block_deps bound_vars deps block pc = - match fst block.branch with - | Return _ | Raise _ | Stop -> () - | Branch cont | Poptrap cont -> cont_deps deps pc cont - | Cond (_, cont1, cont2) -> - cont_deps deps pc cont1; - cont_deps deps pc cont2 - | Switch (_, a1) -> Array.iter a1 ~f:(fun cont -> cont_deps deps pc cont) - | Pushtrap (cont, exn, cont_h) -> - cont_deps deps pc cont; - bound_vars := Var.Set.add exn !bound_vars; - cont_deps deps pc ~exn cont_h - -let function_deps blocks ~context ~closures pc params = - let bound_vars = ref params in - let non_spillable_vars = ref Var.Set.empty in - let domain = ref Addr.Set.empty in - let deps = Hashtbl.create 16, Hashtbl.create 16 in - let mark_non_spillable x = non_spillable_vars := Var.Set.add x !non_spillable_vars in - Code.traverse - { fold = fold_children } - (fun pc () -> - domain := Addr.Set.add pc !domain; - let block = Addr.Map.find pc blocks in - List.iter - ~f:(fun (i, _) -> - match i with - | Let (x, e) -> ( - match e with - | Constant _ | Special _ -> mark_non_spillable x - | Prim (p, _) when no_pointer p -> mark_non_spillable x - | Closure _ - when List.is_empty (function_free_variables ~context ~closures x) -> - mark_non_spillable x - | Prim _ | Closure _ | Apply _ | Block _ | Field _ -> ()) - | Assign _ | Set_field _ | Offset_ref _ | Array_set _ -> ()) - block.body; - bound_vars := - List.fold_left - ~f:(fun vars (i, _) -> - match i with - | Let (x, _) -> Var.Set.add x vars - | Assign _ | Set_field _ | Offset_ref _ | Array_set _ -> vars) - ~init:!bound_vars - block.body; - bound_vars := Var.Set.union !bound_vars (Var.Set.of_list block.params); - block_deps bound_vars deps block pc) - pc - blocks - (); - !domain, deps, !bound_vars, Var.Set.diff !bound_vars !non_spillable_vars - -let inter s s' = - match s, s' with - | None, None -> None - | _, None -> s - | None, _ -> s' - | Some s, Some s' -> Some (Var.Set.inter s s') - -let propagate_through_expr ~context ~closures s x e = - match e with - | Apply _ | Block _ -> Var.Set.empty - | Prim (p, _) -> if no_alloc p then s else Var.Set.empty - | Closure _ -> - if List.is_empty (function_free_variables ~context ~closures x) - then s - else Var.Set.empty - | Constant _ | Field _ | Special _ -> s - -let propagate_through_instr ~context ~closures s (i, _) = - match i with - | Let (x, e) -> Var.Set.add x (propagate_through_expr ~context ~closures s x e) - | Assign _ | Set_field _ | Offset_ref _ | Array_set _ -> s - -let propagate blocks ~context ~closures rev_deps pc0 params st pc = - let input = - pc - |> get_list rev_deps - |> List.map ~f:(fun (pc', exn_opt) -> - match Addr.Map.find pc' st with - | Domain.Bot -> None - | Set { output; _ } -> - Some - (match exn_opt with - | None -> output - | Some x -> Var.Set.add x output)) - |> List.fold_left ~f:inter ~init:None - in - let input = if pc = pc0 then inter input (Some params) else input in - match input with - | None -> Domain.Bot - | Some input -> - let b = Addr.Map.find pc blocks in - let input = Var.Set.union input (Var.Set.of_list b.params) in - let output = - List.fold_left - ~f:(fun s i -> propagate_through_instr ~context ~closures s i) - ~init:input - b.body - in - Set { input; output } - -module G = Dgraph.Make (Int) (Addr.Set) (Addr.Map) -module Solver = G.Solver (Domain) - -type spill_ctx = - { env : Var.t - ; bound_vars : Var.Set.t - ; spillable_vars : Var.Set.t - ; context : Wa_code_generation.context - } - -let check_spilled ~ctx loaded x spilled = - if Hashtbl.mem ctx.context.Wa_code_generation.constants x - then spilled - else - let x = if Var.Set.mem x ctx.bound_vars then x else ctx.env in - if Var.Set.mem x loaded || not (Var.Set.mem x ctx.spillable_vars) - then spilled - else Var.Set.add x spilled - -let spilled_variables - ~blocks - ~context - ~closures - ~domain - ~env - ~bound_vars - ~spillable_vars - st = - let spilled = Var.Set.empty in - let ctx = { env; bound_vars; spillable_vars; context } in - Addr.Set.fold - (fun pc spilled -> - let loaded = - match Addr.Map.find pc st with - | Domain.Bot -> assert false - | Domain.Set { input; _ } -> input - in - let block = Addr.Map.find pc blocks in - let loaded, spilled = - List.fold_left - ~f:(fun (loaded, spilled) i -> - let loaded' = propagate_through_instr ~context ~closures loaded i in - let reloaded = - match fst i with - | Let (x, e) -> ( - match e with - | Apply { f; args; _ } -> - List.fold_left - ~f:(fun reloaded x -> check_spilled ~ctx loaded x reloaded) - (f :: args) - ~init:Var.Set.empty - | Block (_, l, _, _) -> - Array.fold_left - ~f:(fun reloaded x -> check_spilled ~ctx loaded' x reloaded) - l - ~init:Var.Set.empty - | Prim (_, args) -> - List.fold_left - ~f:(fun reloaded x -> - match x with - | Pv x -> check_spilled ~ctx loaded x reloaded - | Pc _ -> reloaded) - args - ~init:Var.Set.empty - | Closure _ -> - let fv = function_free_variables ~context ~closures x in - List.fold_left - ~f:(fun reloaded x -> check_spilled ~ctx loaded' x reloaded) - fv - ~init:Var.Set.empty - | Constant _ | Special _ -> Var.Set.empty - | Field (x, _, _) -> check_spilled ~ctx loaded x Var.Set.empty) - | Assign (_, x) | Offset_ref (x, _) -> - check_spilled ~ctx loaded x Var.Set.empty - | Set_field (x, _, _, y) -> - Var.Set.empty - |> check_spilled ~ctx loaded x - |> check_spilled ~ctx loaded y - | Array_set (x, y, z) -> - Var.Set.empty - |> check_spilled ~ctx loaded x - |> check_spilled ~ctx loaded y - |> check_spilled ~ctx loaded z - in - Var.Set.union loaded' reloaded, Var.Set.union spilled reloaded) - ~init:(loaded, spilled) - block.body - in - let handle_cont (_, args) spilled = - List.fold_left - ~f:(fun spilled x -> check_spilled ~ctx loaded x spilled) - args - ~init:spilled - in - match fst block.branch with - | Return x | Raise (x, _) -> check_spilled ~ctx loaded x spilled - | Stop -> spilled - | Branch cont | Poptrap cont -> handle_cont cont spilled - | Cond (_, cont1, cont2) -> spilled |> handle_cont cont1 |> handle_cont cont2 - | Switch (_, a1) -> Array.fold_right a1 ~f:handle_cont ~init:spilled - | Pushtrap (cont, _, cont_h) -> spilled |> handle_cont cont |> handle_cont cont_h) - domain - spilled - -let traverse ~f pc blocks input = - let rec traverse_rec f pc visited blocks inp = - if not (Addr.Set.mem pc visited) - then - let visited = Addr.Set.add pc visited in - let out = f pc inp in - Code.fold_children - blocks - pc - (fun pc visited -> traverse_rec f pc visited blocks out) - visited - else visited - in - ignore (traverse_rec f pc Addr.Set.empty blocks input) - -let filter_stack live stack = - List.fold_right - ~f:(fun v rem -> - match v, rem with - | Some x, _ when Var.Set.mem x live -> v :: rem - | _, [] -> [] - | _ -> None :: rem) - stack - ~init:[] - -let rec spill i x stack = - match stack with - | None :: rem -> i, Some x :: rem - | [] -> i, [ Some x ] - | v :: rem -> - let i, rem = spill (i + 1) x rem in - i, v :: rem - -let spill_vars live vars stack = - let stack = filter_stack live stack in - let stack, spills = - Var.Set.fold - (fun x (stack, spills) -> - let i, stack = spill 0 x stack in - stack, (x, i) :: spills) - vars - (stack, []) - in - let last = List.length stack - 1 in - stack, List.map ~f:(fun (x, i) -> x, last - i) spills - -let print_stack s = - if List.is_empty s - then "" - else - Format.asprintf - "{%a}" - (fun f l -> - Format.pp_print_list - ~pp_sep:(fun f () -> Format.fprintf f " ") - (fun f v -> - match v with - | None -> Format.fprintf f "*" - | Some x -> Var.print f x) - f - l) - s - -type stack = Var.t option list - -type spilling_info = - { depth_change : int - ; spills : (Var.t * int) list - ; stack : stack - } - -let print_spilling { depth_change; spills; stack; _ } = - let print_actions f l = - Format.pp_print_list - ~pp_sep:(fun f () -> Format.fprintf f " ") - (fun f (x, i) -> Format.fprintf f "%d:%a" i Var.print x) - f - l - in - if false - then print_stack stack - else Format.asprintf "%d %s {%a}" depth_change (print_stack stack) print_actions spills - -type block_info = - { initial_stack : stack (* Stack at beginning of block *) - ; loaded_variables : Var.Set.t (* Values in local variables at beginning of block *) - ; spilling : spilling_info (* Spilling at end of block *) - } - -type info = - { max_depth : int - ; subcalls : bool - ; env : Var.t - ; bound_vars : Var.Set.t - ; initial_spilling : spilling_info - ; block : block_info Addr.Map.t - ; instr : spilling_info Var.Map.t - } - -let update_stack ~max_depth live_vars vars stack = - let stack', spills = spill_vars live_vars vars stack in - max_depth := max !max_depth (List.length stack); - { depth_change = List.length stack' - List.length stack; stack = stack'; spills } - -let spilling blocks st env bound_vars spilled_vars live_info pc params = - let stack = [] in - let max_depth = ref 0 in - let subcalls = ref false in - let vars = Var.Set.inter params spilled_vars in - let stack, spills = spill_vars Var.Set.empty vars stack in - let initial_spilling = { depth_change = List.length stack; stack; spills } in - let instr_info = ref Var.Map.empty in - let block_info = ref Addr.Map.empty in - traverse pc blocks stack ~f:(fun pc stack -> - let block = Addr.Map.find pc blocks in - let block_live_vars = Addr.Map.find pc live_info.Wa_liveness.block in - let initial_stack, _ = - spill_vars block_live_vars.initially_live Var.Set.empty stack - in - let vars = Var.Set.inter (Var.Set.of_list block.params) spilled_vars in - let stack, vars = - List.fold_left - ~f:(fun (stack, vars) (i, _) -> - let stack, vars = - match i with - | Let (x, e) -> ( - match e with - | Apply _ | Block _ | Closure _ -> - let live_vars = Var.Map.find x live_info.instr in - let ({ stack; _ } as sp) = - update_stack ~max_depth live_vars vars stack - in - instr_info := Var.Map.add x sp !instr_info; - (match e with - | Apply _ when not (List.is_empty stack) -> subcalls := true - | _ -> ()); - stack, Var.Set.empty - | Prim (p, _) when not (no_alloc p) -> - let live_vars = Var.Map.find x live_info.instr in - let ({ stack; _ } as sp) = - update_stack ~max_depth live_vars vars stack - in - instr_info := Var.Map.add x sp !instr_info; - stack, Var.Set.empty - | Prim _ | Constant _ | Field _ | Special _ -> stack, vars) - | Assign _ | Offset_ref _ | Set_field _ | Array_set _ -> stack, vars - in - let vars = - match i with - | Let (x, _) when Var.Set.mem x spilled_vars -> Var.Set.add x vars - | _ -> vars - in - stack, vars) - ~init:(initial_stack, vars) - block.body - in - (* ZZZ Spilling at end of block *) - let ({ stack; _ } as sp) = - update_stack ~max_depth block_live_vars.live_before_branch vars stack - in - let loaded_variables = - match Addr.Map.find pc st with - | Domain.Bot -> assert false - | Domain.Set { input; _ } -> input - in - block_info := - Addr.Map.add pc { initial_stack; loaded_variables; spilling = sp } !block_info; - stack); - { max_depth = !max_depth - ; subcalls = !subcalls - ; env - ; bound_vars - ; initial_spilling - ; block = !block_info - ; instr = !instr_info - } - -let generate_spilling_information { blocks; _ } ~context ~closures ~pc:pc0 ~env ~params = - let params = Var.Set.add env (Var.Set.of_list params) in - let domain, (deps, rev_deps), bound_vars, spillable_vars = - function_deps blocks ~context ~closures pc0 params - in - let fold_children f pc acc = Addr.Set.fold f (get_set deps pc) acc in - let g = { G.domain; fold_children } in - let st = - Solver.f g (fun st pc -> - propagate blocks ~context ~closures rev_deps pc0 params st pc) - in - let spilled_vars = - spilled_variables - ~blocks - ~context - ~closures - ~domain - ~env - ~bound_vars - ~spillable_vars - st - in - if debug () - then ( - Format.eprintf "PARAMS: (%a)" Var.print env; - Var.Set.iter (fun x -> Format.eprintf " %a" Var.print x) params; - Format.eprintf "@."; - Format.eprintf "SPILLED:"; - Var.Set.iter (fun x -> Format.eprintf " %a" Var.print x) spilled_vars; - Format.eprintf "@."); - (* - Addr.Set.iter - (fun pc -> - let s = Addr.Map.find pc st in - (match s with - | Domain.Bot -> () - | Domain.Set { input; output } -> - Format.eprintf "INPUT:"; - Var.Set.iter (fun x -> Format.eprintf " %a" Var.print x) input; - Format.eprintf "@."; - Format.eprintf "OUTPUT:"; - Var.Set.iter (fun x -> Format.eprintf " %a" Var.print x) output; - Format.eprintf "@."); - let block = Addr.Map.find pc blocks in - Code.Print.block (fun _ _ -> "") pc block) - domain; - *) - let live_info = - Wa_liveness.f - ~blocks - ~context - ~closures - ~domain - ~env - ~bound_vars - ~spilled_vars - ~pc:pc0 - in - let info = spilling blocks st env bound_vars spilled_vars live_info pc0 params in - if debug () - then ( - Format.eprintf "== %d == depth %d calls %b@." pc0 info.max_depth info.subcalls; - Format.eprintf "%s@." (print_spilling info.initial_spilling); - Addr.Set.iter - (fun pc -> - let block = Addr.Map.find pc blocks in - let _print_vars s = - if Var.Set.is_empty s - then "" - else - Format.asprintf - "{%a}" - (fun f l -> - Format.pp_print_list - ~pp_sep:(fun f () -> Format.fprintf f " ") - Var.print - f - l) - (Var.Set.elements s) - in - Code.Print.block - (fun _pc loc -> - match loc with - | Instr (Let (x, _), _) -> ( - match Var.Map.find_opt x info.instr with - | Some s -> print_spilling s - | None -> "") - | Instr _ -> "" - | Last _ -> - let s = Addr.Map.find pc info.block in - print_spilling s.spilling) - pc - block) - domain); - info - -type context = - { loaded_variables : Var.Set.t - ; loaded_sp : Code.Var.t option - ; stack : stack - ; info : info - ; context : Wa_code_generation.context - } - -type ctx = context ref - -open Wa_code_generation -module W = Wa_ast - -let rec find_in_stack x stack = - match stack with - | [] -> raise Not_found - | Some y :: rem when Var.equal x y -> List.length rem - | _ :: rem -> find_in_stack x rem - -let load_sp ctx = - match !ctx.loaded_sp with - | Some sp -> return sp - | None -> - let sp = Var.fresh_n "sp" in - ctx := { !ctx with loaded_sp = Some sp }; - let* () = store sp (return (W.GlobalGet (S "sp"))) in - return sp - -let perform_reloads ctx l = - let vars = ref Var.Map.empty in - let add_var x = - if not (Hashtbl.mem !ctx.context.Wa_code_generation.constants x) - then - let x = if Var.Set.mem x !ctx.info.bound_vars then x else !ctx.info.env in - if not (Var.Set.mem x !ctx.loaded_variables) - then - try - let i = find_in_stack x !ctx.stack in - vars := Var.Map.add x i !vars - with Not_found -> () - in - (match l with - | `Instr i -> Freevars.iter_instr_free_vars add_var i - | `Branch l -> Freevars.iter_last_free_var add_var l - | `Vars s -> Var.Set.iter add_var s); - if Var.Map.is_empty !vars - then return () - else - let* sp = load_sp ctx in - let* () = - List.fold_left - ~f:(fun before (x, i) -> - let* () = before in - let* sp = load sp in - let offset = 4 * i in - store x (return (W.Load (I32 (Int32.of_int offset), sp)))) - (List.sort ~cmp:(fun (_, i) (_, j) -> compare i j) (Var.Map.bindings !vars)) - ~init:(return ()) - in - ctx := - { !ctx with - loaded_variables = - Var.Set.union - !ctx.loaded_variables - (Var.Map.fold (fun x _ s -> Var.Set.add x s) !vars Var.Set.empty) - }; - return () - -let assign ctx x = - match find_in_stack x !ctx.stack with - | exception Not_found -> return () - | i -> - let* sp = load_sp ctx in - let* sp = load sp in - let* x = load x in - let offset = 4 * i in - instr (W.Store (I32 (Int32.of_int offset), sp, x)) - -let perform_spilling ctx loc = - match - match loc with - | `Function -> !ctx.info.initial_spilling - | `Instr x -> Var.Map.find x !ctx.info.instr - | `Block pc -> (Addr.Map.find pc !ctx.info.block).spilling - with - | exception Not_found -> return () - | spilling -> - if spilling.depth_change = 0 && List.is_empty spilling.spills - then return () - else - let* sp = load_sp ctx in - let* sp = - if spilling.depth_change = 0 - then return sp - else - let sp' = Var.fresh_n "sp" in - let delta = -4 * spilling.depth_change in - let* sp = tee sp' Arith.(load sp + const (Int32.of_int delta)) in - ctx := { !ctx with loaded_sp = Some sp' }; - let* () = instr (W.GlobalSet (S "sp", sp)) in - return sp' - in - let* () = - List.fold_left - ~f:(fun before (x, i) -> - let* () = before in - let* sp = load sp in - let* x = load x in - let offset = 4 * i in - instr (W.Store (I32 (Int32.of_int offset), sp, x))) - spilling.spills - ~init:(return ()) - in - ctx := { !ctx with stack = spilling.stack }; - return () - -let adjust_stack ctx ~src ~dst = - let src_stack = - if src = -1 then !ctx.stack else (Addr.Map.find src !ctx.info.block).spilling.stack - in - let dst_info = Addr.Map.find dst !ctx.info.block in - let delta = List.length dst_info.initial_stack - List.length src_stack in - if delta = 0 - then return () - else - let* sp = load_sp ctx in - let delta = -4 * delta in - let* sp = Arith.(load sp + const (Int32.of_int delta)) in - instr (W.GlobalSet (S "sp", sp)) - -let stack_adjustment_needed ctx ~src ~dst = - let src_stack = - if src = -1 then !ctx.stack else (Addr.Map.find src !ctx.info.block).spilling.stack - in - let dst_info = Addr.Map.find dst !ctx.info.block in - let delta = List.length dst_info.initial_stack - List.length src_stack in - delta <> 0 - -let start_block ~context spilling_info pc = - let info = Addr.Map.find pc spilling_info.block in - ref - { loaded_variables = info.loaded_variables - ; loaded_sp = None - ; stack = info.initial_stack - ; info = spilling_info - ; context - } - -let start_function ~context (spilling_info : info) = - (*ZZZ Check stack depth *) - ref - { loaded_variables = Var.Set.empty - ; loaded_sp = None - ; stack = [] - ; info = spilling_info - ; context - } - -let kill_variables ctx = - ctx := { !ctx with loaded_variables = Var.Set.empty; loaded_sp = None } - -let make_info () = - { max_depth = 0 - ; subcalls = false - ; env = Var.fresh () - ; bound_vars = Var.Set.empty - ; initial_spilling = { depth_change = 0; spills = []; stack = [] } - ; block = Addr.Map.empty - ; instr = Var.Map.empty - } - -let add_spilling info ~location:x ~stack ~live_vars ~spilled_vars = - let max_depth = ref info.max_depth in - let spilling = update_stack ~max_depth live_vars spilled_vars stack in - ( { info with - max_depth = !max_depth - ; instr = Var.Map.add x spilling info.instr - ; bound_vars = Var.Set.union info.bound_vars spilled_vars - } - , spilling.stack ) - -(* -ZZZ TODO -- We could improve the code generated for stack adjustment after a switch -- We need to deal with exceptions... -- Check available stack depth at beginning of function (also for curry/apply) -- We could zero-out no longer used stack slots to avoid memory leaks -*) diff --git a/compiler/lib/wasm/wa_spilling.mli b/compiler/lib/wasm/wa_spilling.mli deleted file mode 100644 index 5c4ac9db8..000000000 --- a/compiler/lib/wasm/wa_spilling.mli +++ /dev/null @@ -1,89 +0,0 @@ -(* Wasm_of_ocaml compiler - * http://www.ocsigen.org/js_of_ocaml/ - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) - -(* -type stack = Code.Var.t option list - -type spilling_info = - { reloads : (Code.Var.t * int) list - ; depth_change : int - ; spills : (Code.Var.t * int) list - ; stack : stack - } - -type block_info = - { initial_depth : int - ; loaded_variables : Code.Var.Set.t - ; spilling : spilling_info - } - -type info = - { max_depth : int - ; subcalls : bool - ; initial_spilling : spilling_info - ; block : block_info Code.Addr.Map.t - ; instr : spilling_info Code.Var.Map.t - } -*) - -type stack = Code.Var.t option list - -type info - -val generate_spilling_information : - Code.program - -> context:Wa_code_generation.context - -> closures:Wa_closure_conversion.closure Code.Var.Map.t - -> pc:Code.Addr.t - -> env:Code.Var.t - -> params:Code.Var.t list - -> info - -val make_info : unit -> info - -val add_spilling : - info - -> location:Code.Var.t - -> stack:stack - -> live_vars:Code.Var.Set.t - -> spilled_vars:Code.Var.Set.t - -> info * stack - -type ctx - -val start_function : context:Wa_code_generation.context -> info -> ctx - -val start_block : context:Wa_code_generation.context -> info -> Code.Addr.t -> ctx - -val perform_reloads : - ctx - -> [ `Branch of Code.last | `Instr of Code.instr | `Vars of Code.Var.Set.t ] - -> unit Wa_code_generation.t - -val perform_spilling : - ctx - -> [ `Function | `Instr of Code.Var.t | `Block of Code.Addr.t ] - -> unit Wa_code_generation.t - -val kill_variables : ctx -> unit - -val assign : ctx -> Code.Var.t -> unit Wa_code_generation.t - -val adjust_stack : ctx -> src:Code.Addr.t -> dst:Code.Addr.t -> unit Wa_code_generation.t - -val stack_adjustment_needed : ctx -> src:Code.Addr.t -> dst:Code.Addr.t -> bool diff --git a/compiler/lib/wasm/wa_tail_call.ml b/compiler/lib/wasm/wa_tail_call.ml index b0c1a40c8..8b71358fe 100644 --- a/compiler/lib/wasm/wa_tail_call.ml +++ b/compiler/lib/wasm/wa_tail_call.ml @@ -30,8 +30,6 @@ let rec rewrite_tail_call ~y i = | Wa_ast.Location (loc, i') -> Option.map ~f:(fun i -> Wa_ast.Location (loc, i)) (rewrite_tail_call ~y i') | LocalSet (x, Call (symb, l)) when Code.Var.equal x y -> Some (Return_call (symb, l)) - | LocalSet (x, Call_indirect (ty, e, l)) when Code.Var.equal x y -> - Some (Return_call_indirect (ty, e, l)) | LocalSet (x, Call_ref (ty, e, l)) when Code.Var.equal x y -> Some (Return_call_ref (ty, e, l)) | _ -> None @@ -48,17 +46,13 @@ let rec instruction ~tail i = , List.map ~f:(fun (tag, l) -> tag, instructions ~tail l) catches , Option.map ~f:(fun l -> instructions ~tail l) catch_all ) | Return (Some (Call (symb, l))) -> Return_call (symb, l) - | Return (Some (Call_indirect (ty, e, l))) -> Return_call_indirect (ty, e, l) | Return (Some (Call_ref (ty, e, l))) -> Return_call_ref (ty, e, l) | Push (Call (symb, l)) when tail -> Return_call (symb, l) - | Push (Call_indirect (ty, e, l)) when tail -> Return_call_indirect (ty, e, l) | Push (Call_ref (ty, e, l)) when tail -> Return_call_ref (ty, e, l) | Location (loc, i) -> Location (loc, instruction ~tail i) | Push (Call_ref _) -> i | Drop (BlockExpr (typ, l)) -> Drop (BlockExpr (typ, instructions ~tail:false l)) | Drop _ - | Store _ - | Store8 _ | LocalSet _ | GlobalSet _ | Br_table _ @@ -72,7 +66,6 @@ let rec instruction ~tail i = | Push _ | ArraySet _ | StructSet _ - | Return_call_indirect _ | Return_call _ | Return_call_ref _ -> i diff --git a/compiler/lib/wasm/wa_target_sig.ml b/compiler/lib/wasm/wa_target_sig.ml index e5f221e88..422720ed0 100644 --- a/compiler/lib/wasm/wa_target_sig.ml +++ b/compiler/lib/wasm/wa_target_sig.ml @@ -19,70 +19,16 @@ module type S = sig type expression = Wa_code_generation.expression - module Stack : sig - type stack = Code.Var.t option list - - type info - - val generate_spilling_information : - Code.program - -> context:Wa_code_generation.context - -> closures:Wa_closure_conversion.closure Code.Var.Map.t - -> pc:Code.Addr.t - -> env:Code.Var.t - -> params:Code.Var.t list - -> info - - val make_info : unit -> info - - val add_spilling : - info - -> location:Code.Var.t - -> stack:stack - -> live_vars:Code.Var.Set.t - -> spilled_vars:Code.Var.Set.t - -> info * stack - - type ctx - - val start_function : context:Wa_code_generation.context -> info -> ctx - - val start_block : context:Wa_code_generation.context -> info -> Code.Addr.t -> ctx - - val perform_reloads : - ctx - -> [ `Branch of Code.last | `Instr of Code.instr | `Vars of Code.Var.Set.t ] - -> unit Wa_code_generation.t - - val perform_spilling : - ctx - -> [ `Function | `Instr of Code.Var.t | `Block of Code.Addr.t ] - -> unit Wa_code_generation.t - - val kill_variables : ctx -> unit - - val assign : ctx -> Code.Var.t -> unit Wa_code_generation.t - - val adjust_stack : - ctx -> src:Code.Addr.t -> dst:Code.Addr.t -> unit Wa_code_generation.t - - val stack_adjustment_needed : ctx -> src:Code.Addr.t -> dst:Code.Addr.t -> bool - end - module Memory : sig val allocate : - Stack.ctx - -> Code.Var.t - -> tag:int - -> [ `Expr of Wa_ast.expression | `Var of Wa_ast.var ] list - -> expression + tag:int -> [ `Expr of Wa_ast.expression | `Var of Wa_ast.var ] list -> expression val load_function_pointer : cps:bool -> arity:int -> ?skip_cast:bool -> expression - -> ([ `Index | `Ref of Wa_ast.var ] * Wa_ast.expression) Wa_code_generation.t + -> (Wa_ast.var * Wa_ast.expression) Wa_code_generation.t val load_real_closure : cps:bool @@ -130,19 +76,19 @@ module type S = sig val bytes_set : expression -> expression -> expression -> unit Wa_code_generation.t - val box_float : Stack.ctx -> Code.Var.t -> expression -> expression + val box_float : expression -> expression val unbox_float : expression -> expression - val box_int32 : Stack.ctx -> Code.Var.t -> expression -> expression + val box_int32 : expression -> expression val unbox_int32 : expression -> expression - val box_int64 : Stack.ctx -> Code.Var.t -> expression -> expression + val box_int64 : expression -> expression val unbox_int64 : expression -> expression - val box_nativeint : Stack.ctx -> Code.Var.t -> expression -> expression + val box_nativeint : expression -> expression val unbox_nativeint : expression -> expression end @@ -215,7 +161,6 @@ module type S = sig val translate : context:Wa_code_generation.context -> closures:Wa_closure_conversion.closure Code.Var.Map.t - -> stack_ctx:Stack.ctx -> cps:bool -> Code.Var.t -> expression @@ -228,9 +173,7 @@ module type S = sig -> unit Wa_code_generation.t val curry_allocate : - stack_ctx:Stack.ctx - -> x:Code.Var.t - -> cps:bool + cps:bool -> arity:int -> int -> f:Code.Var.t diff --git a/compiler/lib/wasm/wa_wasm_output.ml b/compiler/lib/wasm/wa_wasm_output.ml index 114ce0edc..68c6018c9 100644 --- a/compiler/lib/wasm/wa_wasm_output.ml +++ b/compiler/lib/wasm/wa_wasm_output.ml @@ -299,7 +299,7 @@ end = struct if typ.mut then Feature.require mutable_globals; output_byte ch 0x03; output_globaltype type_names ch typ; - Hashtbl.add global_names (V name) !global_idx; + Hashtbl.add global_names name !global_idx; incr global_idx | Tag typ -> Feature.require exception_handling; @@ -428,7 +428,7 @@ end = struct type st = { type_names : (var, int) Hashtbl.t ; func_names : (var, int) Hashtbl.t - ; global_names : (symbol, int) Hashtbl.t + ; global_names : (var, int) Hashtbl.t ; data_names : (var, int) Hashtbl.t ; tag_names : (var, int) Hashtbl.t ; local_names : (var, (var, int) Hashtbl.t) Hashtbl.t @@ -481,7 +481,6 @@ end = struct | F64PromoteF32 e' -> output_expression st ch e'; output_byte ch 0xBB - | Call_indirect _ | ConstSym _ | Load _ | Load8 _ | MemoryGrow _ -> assert false | LocalGet i -> output_byte ch 0x20; output_uint ch (Hashtbl.find st.current_local_names i) @@ -635,7 +634,6 @@ end = struct | Drop e -> output_expression st ch e; output_byte ch 0x1A - | Store _ | Store8 _ -> assert false | LocalSet (i, e) -> output_expression st ch e; output_byte ch 0x21; @@ -732,7 +730,6 @@ end = struct output_byte ch 0x05; output_uint ch (Hashtbl.find st.type_names typ); output_uint ch idx - | Return_call_indirect _ -> assert false | Return_call (f, l) -> Feature.require tail_call; List.iter ~f:(fun e -> output_expression st ch e) l; @@ -829,20 +826,6 @@ end = struct in data_count, data_names - let data_contents contents = - let b = Buffer.create 16 in - List.iter - ~f:(fun d -> - match d with - | DataI8 c -> Buffer.add_uint8 b c - | DataI32 i -> Buffer.add_int32_le b i - | DataI64 i -> Buffer.add_int64_le b i - | DataBytes s -> Buffer.add_string b s - | DataSym _ -> assert false - | DataSpace n -> Buffer.add_string b (String.make n '\000')) - contents; - Buffer.contents b - let output_data_count ch data_count = output_uint ch data_count let output_data ch (data_count, fields) = @@ -851,10 +834,9 @@ end = struct (List.fold_left ~f:(fun idx field -> match field with - | Data { active; contents; _ } -> - assert (not active); + | Data { contents; _ } -> output_byte ch 1; - output_name ch (data_contents contents); + output_name ch contents; idx + 1 | Function _ | Type _ | Import _ | Global _ | Tag _ -> idx) ~init:0 @@ -883,7 +865,6 @@ end = struct | ArrayGet (_, _, e', e'') | RefEq (e', e'') -> set |> expr_function_references e' |> expr_function_references e'' - | Call_indirect _ | ConstSym _ | Load _ | Load8 _ | MemoryGrow _ -> assert false | IfExpr (_, e1, e2, e3) -> set |> expr_function_references e1 @@ -912,7 +893,6 @@ end = struct | Return (Some e) | Push e | Throw (_, e) -> expr_function_references e set - | Store _ | Store8 _ -> assert false | Loop (_, l) | Block (_, l) -> List.fold_left ~f:(fun set i -> instr_function_references i set) ~init:set l | If (_, e, l1, l2) -> @@ -950,7 +930,6 @@ end = struct |> expr_function_references e3 | StructSet (_, _, e1, e2) -> set |> expr_function_references e1 |> expr_function_references e2 - | Return_call_indirect _ -> assert false | Return_call (_, l) -> List.fold_left ~f:(fun set i -> expr_function_references i set) ~init:set l | Return_call_ref (_, e', l) -> @@ -1090,11 +1069,6 @@ end = struct let output_names ch st = output_name ch "name"; let index = Code.Var.get_name in - let symbol name = - match name with - | V name -> Code.Var.get_name name - | S name -> Some name - in let out id f tbl = let names = assign_names f tbl in if not (List.is_empty names) @@ -1129,7 +1103,7 @@ end = struct ch locals; out 4 index st.type_names; - out 7 symbol st.global_names; + out 7 index st.global_names; out 9 index st.data_names; out 11 index st.tag_names diff --git a/compiler/lib/wasm/wa_wat_output.ml b/compiler/lib/wasm/wa_wat_output.ml index 1d66b078d..ef157c69e 100644 --- a/compiler/lib/wasm/wa_wat_output.ml +++ b/compiler/lib/wasm/wa_wat_output.ml @@ -70,7 +70,7 @@ let assign_names ?(reversed = true) f names = type st = { type_names : (var, string) Hashtbl.t ; func_names : (var, string) Hashtbl.t - ; global_names : (symbol, string) Hashtbl.t + ; global_names : (var, string) Hashtbl.t ; data_names : (var, string) Hashtbl.t ; tag_names : (var, string) Hashtbl.t ; local_names : (var, string) Hashtbl.t @@ -94,18 +94,13 @@ let build_name_tables fields = | Import { name; desc; _ } -> ( match desc with | Fun _ -> push func_names name - | Global _ -> push global_names (V name) + | Global _ -> push global_names name | Tag _ -> push tag_names name)) fields; let index = Code.Var.get_name in - let symbol name = - match name with - | V name -> Code.Var.get_name name - | S name -> Some name - in { type_names = assign_names index !type_names ; func_names = assign_names index !func_names - ; global_names = assign_names symbol !global_names + ; global_names = assign_names index !global_names ; data_names = assign_names index !data_names ; tag_names = assign_names index !tag_names ; local_names = Hashtbl.create 1 @@ -134,8 +129,6 @@ let rec format_sexp f s = let index tbl x = Atom ("$" ^ Hashtbl.find tbl x) -let symbol tbl name = index tbl.global_names name - let heap_type st (ty : heap_type) = match ty with | Func -> Atom "func" @@ -288,28 +281,12 @@ let select i32 i64 f32 f64 op = | F64 x -> f64 "64" x type ctx = - { addresses : int Code.Var.Map.t - ; mutable functions : int Code.Var.Map.t - ; mutable function_refs : Code.Var.Set.t - ; mutable function_count : int + { mutable function_refs : Code.Var.Set.t ; debug : Parse_bytecode.Debug.t } let reference_function ctx f = ctx.function_refs <- Code.Var.Set.add f ctx.function_refs -let lookup_symbol ctx (x : symbol) = - match x with - | S _ -> assert false - | V x -> ( - try Code.Var.Map.find x ctx.addresses - with Not_found -> ( - try Code.Var.Map.find x ctx.functions - with Not_found -> - let i = ctx.function_count in - ctx.functions <- Code.Var.Map.add x i ctx.functions; - ctx.function_count <- ctx.function_count + 1; - i)) - let remove_nops l = List.filter ~f:(fun i -> not (Poly.equal i Nop)) l let float64 _ f = @@ -337,9 +314,6 @@ let expression_or_instructions ctx st in_function = op) ] ] - | ConstSym (symb, ofs) -> - let i = lookup_symbol ctx symb in - [ List [ Atom "i32.const"; Atom (string_of_int (i + ofs)) ] ] | UnOp (op, e') -> [ List (Atom (type_prefix op (select int_un_op int_un_op float_un_op float_un_op op)) @@ -357,40 +331,17 @@ let expression_or_instructions ctx st in_function = | I64ExtendI32 (s, e) -> [ List (Atom (signage "i64.extend_i32" s) :: expression e) ] | F32DemoteF64 e -> [ List (Atom "f32.demote_f64" :: expression e) ] | F64PromoteF32 e -> [ List (Atom "f64.promote_f32" :: expression e) ] - | Load (offset, e') -> - let offs _ i = - if Int32.equal i 0l then [] else [ Atom (Printf.sprintf "offset=%ld" i) ] - in - [ List - ((Atom (type_prefix offset "load") :: select offs offs offs offs offset) - @ expression e') - ] - | Load8 (s, offset, e') -> - let offs _ i = - if Int32.equal i 0l then [] else [ Atom (Printf.sprintf "offset=%ld" i) ] - in - [ List - (Atom (type_prefix offset (signage "load" s)) - :: select offs offs offs offs offset - @ expression e') - ] | LocalGet i -> [ List [ Atom "local.get"; index st.local_names i ] ] | LocalTee (i, e') -> [ List (Atom "local.tee" :: index st.local_names i :: expression e') ] - | GlobalGet nm -> [ List [ Atom "global.get"; symbol st nm ] ] + | GlobalGet nm -> [ List [ Atom "global.get"; index st.global_names nm ] ] | BlockExpr (ty, l) -> [ List (Atom "block" :: (block_type st ty @ instructions l)) ] - | Call_indirect (typ, e, l) -> - [ List - ((Atom "call_indirect" :: func_type st typ) - @ List.concat (List.map ~f:expression (l @ [ e ]))) - ] | Call (f, l) -> [ List (Atom "call" :: index st.func_names f :: List.concat (List.map ~f:expression l)) ] - | MemoryGrow (_, e) -> [ List (Atom "memory.grow" :: expression e) ] | Seq (l, e) -> instructions l @ expression e | Pop _ -> [] | RefFunc symb -> @@ -483,26 +434,11 @@ let expression_or_instructions ctx st in_function = and instruction i = match i with | Drop e -> [ List (Atom "drop" :: expression e) ] - | Store (offset, e1, e2) -> - let offs _ i = - if Int32.equal i 0l then [] else [ Atom (Printf.sprintf "offset=%ld" i) ] - in - [ List - (Atom (type_prefix offset "store") - :: (select offs offs offs offs offset @ expression e1 @ expression e2)) - ] - | Store8 (offset, e1, e2) -> - let offs _ i = - if Int32.equal i 0l then [] else [ Atom (Printf.sprintf "offset=%ld" i) ] - in - [ List - (Atom (type_prefix offset "store8") - :: (select offs offs offs offs offset @ expression e1 @ expression e2)) - ] | LocalSet (i, Seq (l, e)) -> instructions (l @ [ LocalSet (i, e) ]) | LocalSet (i, e) -> [ List (Atom "local.set" :: index st.local_names i :: expression e) ] - | GlobalSet (nm, e) -> [ List (Atom "global.set" :: symbol st nm :: expression e) ] + | GlobalSet (nm, e) -> + [ List (Atom "global.set" :: index st.global_names nm :: expression e) ] | Loop (ty, l) -> [ List (Atom "loop" :: (block_type st ty @ instructions l)) ] | Block (ty, l) -> [ List (Atom "block" :: (block_type st ty @ instructions l)) ] | If (ty, e, l1, l2) -> @@ -574,11 +510,6 @@ let expression_or_instructions ctx st in_function = :: Atom (string_of_int i) :: (expression e @ expression e')) ] - | Return_call_indirect (typ, e, l) -> - [ List - ((Atom "return_call_indirect" :: func_type st typ) - @ List.concat (List.map ~f:expression (l @ [ e ]))) - ] | Return_call (f, l) -> [ List (Atom "return_call" @@ -635,7 +566,8 @@ let import st f = ; List (match desc with | Fun typ -> Atom "func" :: index st.func_names name :: func_type st typ - | Global ty -> [ Atom "global"; symbol st (V name); global_type st ty ] + | Global ty -> + [ Atom "global"; index st.global_names name; global_type st ty ] | Tag ty -> [ Atom "tag" ; index st.tag_names name @@ -654,21 +586,6 @@ let escape_string s = done; Buffer.contents b -let data_contents ctx contents = - let b = Buffer.create 16 in - List.iter - ~f:(fun d -> - match d with - | DataI8 c -> Buffer.add_uint8 b c - | DataI32 i -> Buffer.add_int32_le b i - | DataI64 i -> Buffer.add_int64_le b i - | DataBytes s -> Buffer.add_string b s - | DataSym (symb, ofs) -> - Buffer.add_int32_le b (Int32.of_int (lookup_symbol ctx symb + ofs)) - | DataSpace n -> Buffer.add_string b (String.make n '\000')) - contents; - escape_string (Buffer.contents b) - let type_field st { name; typ; supertype; final } = if final && Option.is_none supertype then List [ Atom "type"; index st.type_names name; str_type st typ ] @@ -692,7 +609,7 @@ let field ctx st f = | Global { name; exported_name; typ; init } -> [ List (Atom "global" - :: symbol st name + :: index st.global_names name :: (export exported_name @ (global_type st typ :: expression ctx st init))) ] | Tag { name; typ } -> @@ -703,85 +620,22 @@ let field ctx st f = ] ] | Import _ -> [] - | Data { name; active; contents; _ } -> + | Data { name; contents } -> [ List - (Atom "data" - :: index st.data_names name - :: ((if active - then - expression - ctx - st - (Const (I32 (Int32.of_int (lookup_symbol ctx (V name))))) - else []) - @ [ Atom ("\"" ^ data_contents ctx contents ^ "\"") ])) + [ Atom "data" + ; index st.data_names name + ; Atom ("\"" ^ escape_string contents ^ "\"") + ] ] | Type [ t ] -> [ type_field st t ] | Type l -> [ List (Atom "rec" :: List.map ~f:(type_field st) l) ] -let data_size contents = - List.fold_left - ~f:(fun sz d -> - sz - + - match d with - | DataI8 _ -> 1 - | DataI32 _ -> 4 - | DataI64 _ -> 8 - | DataBytes s -> String.length s - | DataSym _ -> 4 - | DataSpace n -> n) - ~init:0 - contents - -let data_offsets fields = - List.fold_left - ~f:(fun (i, addresses) f -> - match f with - | Data { name; contents; active = true; _ } -> - i + data_size contents, Code.Var.Map.add name i addresses - | Function _ | Global _ | Tag _ | Import _ | Data { active = false; _ } | Type _ -> - i, addresses) - ~init:(0, Code.Var.Map.empty) - fields - let f ~debug ch fields = let st = build_name_tables fields in - let heap_base, addresses = data_offsets fields in - let ctx = - { addresses - ; functions = Code.Var.Map.empty - ; function_refs = Code.Var.Set.empty - ; function_count = 0 - ; debug - } - in + let ctx = { function_refs = Code.Var.Set.empty; debug } in let other_fields = List.concat (List.map ~f:(fun f -> field ctx st f) fields) in - let funct_table = - let functions = - List.map - ~f:fst - (List.sort - ~cmp:(fun (_, i) (_, j) -> compare i j) - (Code.Var.Map.bindings ctx.functions)) - in - if List.is_empty functions - then [] - else - [ List - [ Atom "table" - ; Atom "funcref" - ; List (Atom "elem" :: List.map ~f:(index st.func_names) functions) - ] - ] - in let funct_decl = - let functions = - Code.Var.Set.elements - (Code.Var.Set.filter - (fun f -> not (Code.Var.Map.mem f ctx.functions)) - ctx.function_refs) - in + let functions = Code.Var.Set.elements ctx.function_refs in if List.is_empty functions then [] else @@ -799,14 +653,5 @@ let f ~debug ch fields = (List (Atom "module" :: (List.concat (List.map ~f:(fun i -> import st i) fields) - @ (if Code.Var.Map.is_empty addresses - then [] - else - [ List - [ Atom "memory" - ; Atom (string_of_int ((heap_base + 0xffff) / 0x10000)) - ] - ]) - @ funct_table @ funct_decl @ other_fields)))