diff --git a/CHANGES.md b/CHANGES.md index 3490684715..8e7e25a169 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -2,6 +2,7 @@ ## Features/Changes * Compiler: exit-loop-early in more cases (#2077) +* Compiler/wasm: omit code pointer from closures when not used (#2059) # 6.1.1 (2025-07-07) - Lille diff --git a/compiler/lib-wasm/call_graph_analysis.ml b/compiler/lib-wasm/call_graph_analysis.ml new file mode 100644 index 0000000000..f897a046e1 --- /dev/null +++ b/compiler/lib-wasm/call_graph_analysis.ml @@ -0,0 +1,63 @@ +open! Stdlib +open Code + +let debug = Debug.find "call-graph" + +let times = Debug.find "times" + +let block_deps ~info ~non_escaping ~ambiguous ~blocks pc = + let block = Addr.Map.find pc blocks in + List.iter block.body ~f:(fun i -> + match i with + | Let (_, Apply { f; _ }) -> ( + try + match Var.Tbl.get info.Global_flow.info_approximation f with + | Top -> () + | Values { known; others } -> + if others || Var.Set.cardinal known > 1 + then Var.Set.iter (fun x -> Var.Hashtbl.replace ambiguous x ()) known; + if debug () + then + Format.eprintf + "CALL others:%b known:%d@." + others + (Var.Set.cardinal known) + with Invalid_argument _ -> ()) + | Let (x, Closure _) -> ( + match Var.Tbl.get info.Global_flow.info_approximation x with + | Top -> () + | Values { known; others } -> + if Var.Set.cardinal known = 1 && (not others) && Var.Set.mem x known + then ( + let may_escape = Var.ISet.mem info.Global_flow.info_may_escape x in + if debug () then Format.eprintf "CLOSURE may-escape:%b@." may_escape; + if not may_escape then Var.Hashtbl.replace non_escaping x ())) + | Let (_, (Prim _ | Block _ | Constant _ | Field _ | Special _)) + | Event _ | Assign _ | Set_field _ | Offset_ref _ | Array_set _ -> ()) + +type t = { unambiguous_non_escaping : unit Var.Hashtbl.t } + +let direct_calls_only info f = + Config.Flag.optcall () && Var.Hashtbl.mem info.unambiguous_non_escaping f + +let f p info = + let t = Timer.make () in + let non_escaping = Var.Hashtbl.create 128 in + let ambiguous = Var.Hashtbl.create 128 in + fold_closures + p + (fun _ _ (pc, _) _ () -> + traverse + { fold = Code.fold_children } + (fun pc () -> block_deps ~info ~non_escaping ~ambiguous ~blocks:p.blocks pc) + pc + p.blocks + ()) + (); + if debug () + then Format.eprintf "SUMMARY non-escaping:%d" (Var.Hashtbl.length non_escaping); + Var.Hashtbl.iter (fun x () -> Var.Hashtbl.remove non_escaping x) ambiguous; + if debug () + then Format.eprintf " unambiguous-non-escaping:%d@." (Var.Hashtbl.length non_escaping); + if times () then Format.eprintf " call graph analysis: %a@." Timer.print t; + { unambiguous_non_escaping = non_escaping } diff --git a/compiler/lib-wasm/call_graph_analysis.mli b/compiler/lib-wasm/call_graph_analysis.mli new file mode 100644 index 0000000000..3188253a2a --- /dev/null +++ b/compiler/lib-wasm/call_graph_analysis.mli @@ -0,0 +1,5 @@ +type t + +val direct_calls_only : t -> Code.Var.t -> bool + +val f : Code.program -> Global_flow.info -> t diff --git a/compiler/lib-wasm/curry.ml b/compiler/lib-wasm/curry.ml index b6d5ab0cab..32b339e5be 100644 --- a/compiler/lib-wasm/curry.ml +++ b/compiler/lib-wasm/curry.ml @@ -293,14 +293,7 @@ module Make (Target : Target_sig.S) = struct (fun ~typ closure -> let* l = expression_list load l in call ?typ ~cps:true ~arity closure l) - (let* args = - (* We don't need the deadcode sentinal when the tag is 0 *) - Memory.allocate - ~tag:0 - ~deadcode_sentinal:(Code.Var.fresh ()) - ~load - (List.map ~f:(fun x -> `Var x) (List.tl l)) - in + (let* args = Memory.allocate ~tag:0 (expression_list load (List.tl l)) in let* make_iterator = register_import ~name:"caml_apply_continuation" (Fun (Type.primitive_type 1)) in diff --git a/compiler/lib-wasm/gc_target.ml b/compiler/lib-wasm/gc_target.ml index 36ca054e4c..9e51787ec8 100644 --- a/compiler/lib-wasm/gc_target.ml +++ b/compiler/lib-wasm/gc_target.ml @@ -22,8 +22,6 @@ open Code_generation type expression = Wasm_ast.expression Code_generation.t -let include_closure_arity = false - module Type = struct let value = W.Ref { nullable = false; typ = Eq } @@ -215,13 +213,7 @@ module Type = struct let closure_common_fields ~cps = let* fun_ty = function_type ~cps 1 in return - (let function_pointer = - [ { W.mut = false; typ = W.Value (Ref { nullable = false; typ = Type fun_ty }) } - ] - in - if include_closure_arity - then { W.mut = false; typ = W.Value I32 } :: function_pointer - else function_pointer) + [ { W.mut = false; typ = W.Value (Ref { nullable = false; typ = Type fun_ty }) } ] let closure_type_1 ~cps = register_type @@ -289,36 +281,41 @@ module Type = struct }) env_type - let env_type ~cps ~arity ~env_type_id ~env_type = + let env_type ~cps ~arity ~no_code_pointer ~env_type_id ~env_type = register_type (if cps then Printf.sprintf "cps_env_%d_%d" arity env_type_id else Printf.sprintf "env_%d_%d" arity env_type_id) (fun () -> - let* cl_typ = closure_type ~usage:`Alloc ~cps arity in - let* common = closure_common_fields ~cps in - let* fun_ty' = function_type ~cps arity in - return - { supertype = Some cl_typ - ; final = true - ; typ = - W.Struct - ((if arity = 1 - then common - else if arity = 0 - then - [ { mut = false - ; typ = Value (Ref { nullable = false; typ = Type fun_ty' }) - } - ] - else - common - @ [ { mut = false + if no_code_pointer + then + return + { supertype = None; final = true; typ = W.Struct (make_env_type env_type) } + else + let* cl_typ = closure_type ~usage:`Alloc ~cps arity in + let* common = closure_common_fields ~cps in + let* fun_ty' = function_type ~cps arity in + return + { supertype = Some cl_typ + ; final = true + ; typ = + W.Struct + ((if arity = 1 + then common + else if arity = 0 + then + [ { mut = false ; typ = Value (Ref { nullable = false; typ = Type fun_ty' }) } - ]) - @ make_env_type env_type) - }) + ] + else + common + @ [ { mut = false + ; typ = Value (Ref { nullable = false; typ = Type fun_ty' }) + } + ]) + @ make_env_type env_type) + }) let rec_env_type ~function_count ~env_type_id ~env_type = register_type (Printf.sprintf "rec_env_%d_%d" function_count env_type_id) (fun () -> @@ -336,34 +333,48 @@ module Type = struct @ make_env_type env_type) }) - let rec_closure_type ~cps ~arity ~function_count ~env_type_id ~env_type = + let rec_closure_type ~cps ~arity ~no_code_pointer ~function_count ~env_type_id ~env_type + = register_type (if cps then Printf.sprintf "cps_closure_rec_%d_%d_%d" arity function_count env_type_id else Printf.sprintf "closure_rec_%d_%d_%d" arity function_count env_type_id) (fun () -> - let* cl_typ = closure_type ~usage:`Alloc ~cps arity in - let* common = closure_common_fields ~cps in - let* fun_ty' = function_type ~cps arity in let* env_ty = rec_env_type ~function_count ~env_type_id ~env_type in - return - { supertype = Some cl_typ - ; final = true - ; typ = - W.Struct - ((if arity = 1 - then common - else - common - @ [ { mut = false - ; typ = Value (Ref { nullable = false; typ = Type fun_ty' }) - } - ]) - @ [ { W.mut = false + if no_code_pointer + then + return + { supertype = None + ; final = true + ; typ = + W.Struct + [ { W.mut = false ; typ = W.Value (Ref { nullable = false; typ = Type env_ty }) } - ]) - }) + ] + } + else + let* cl_typ = closure_type ~usage:`Alloc ~cps arity in + let* common = closure_common_fields ~cps in + let* fun_ty' = function_type ~cps arity in + return + { supertype = Some cl_typ + ; final = true + ; typ = + W.Struct + ((if arity = 1 + then common + else + common + @ [ { mut = false + ; typ = Value (Ref { nullable = false; typ = Type fun_ty' }) + } + ]) + @ [ { W.mut = false + ; typ = W.Value (Ref { nullable = false; typ = Type env_ty }) + } + ]) + }) let rec curry_type ~cps arity m = register_type @@ -655,33 +666,21 @@ module Memory = struct let* ty = Type.float_type in wasm_struct_get ty (wasm_cast ty e) 0 - let allocate ~tag ~deadcode_sentinal ~load l = - if tag = 254 - then - let* l = - expression_list - (fun v -> - match v with - | `Var y -> - if Code.Var.equal y deadcode_sentinal - then return (W.Const (F64 0.)) - else unbox_float (load y) - | `Expr e -> unbox_float (return e)) - l - in - let* ty = Type.float_array_type in - return (W.ArrayNewFixed (ty, l)) - else - let* l = - expression_list - (fun v -> - match v with - | `Var y -> load y - | `Expr e -> return e) - l - in - let* ty = Type.block_type in - return (W.ArrayNewFixed (ty, RefI31 (Const (I32 (Int32.of_int tag))) :: l)) + let allocate ~tag l = + assert (tag <> 254); + let* l = l in + let* ty = Type.block_type in + return (W.ArrayNewFixed (ty, RefI31 (Const (I32 (Int32.of_int tag))) :: l)) + + let allocate_float_array ~deadcode_sentinal ~load l = + let* l = + expression_list + (fun y -> + if Code.Var.equal y deadcode_sentinal then return (W.Const (F64 0.)) else load y) + l + in + let* ty = Type.float_array_type in + return (W.ArrayNewFixed (ty, l)) let tag e = wasm_array_get e (Arith.const 0l) @@ -730,10 +729,9 @@ module Memory = struct let array_set e e' e'' = wasm_array_set e Arith.(e' + const 1l) e'' - let float_array_get e e' = box_float (wasm_array_get ~ty:Type.float_array_type e e') + let float_array_get e e' = wasm_array_get ~ty:Type.float_array_type e e' - let float_array_set e e' e'' = - wasm_array_set ~ty:Type.float_array_type e e' (unbox_float e'') + let float_array_set e e' e'' = wasm_array_set ~ty:Type.float_array_type e e' e'' let gen_array_get e e' = let a = Code.Var.fresh_n "a" in @@ -806,17 +804,22 @@ module Memory = struct let set_field e idx e' = wasm_array_set e (Arith.const (Int32.of_int (idx + 1))) e' - let env_start arity = - if arity = 0 - then 1 - else (if include_closure_arity then 1 else 0) + if arity = 1 then 1 else 2 + let env_start ~no_code_pointer arity = + if no_code_pointer + then 0 + else + match arity with + | 0 | 1 -> 1 + | _ -> 2 let load_function_pointer ~cps ~arity ?(skip_cast = false) closure = let arity = if cps then arity - 1 else arity in let* ty = Type.closure_type ~usage:`Access ~cps arity in 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 + let* e = + wasm_struct_get ty casted_closure (env_start ~no_code_pointer:false arity - 1) + in return (fun_ty, e) let load_real_closure ~cps ~arity closure = @@ -824,7 +827,12 @@ module Memory = struct let* ty = Type.dummy_closure_type ~cps ~arity in let* cl_typ = Type.closure_type ~usage:`Access ~cps arity in let* e = - wasm_cast cl_typ (wasm_struct_get ty (wasm_cast ty closure) (env_start arity)) + wasm_cast + cl_typ + (wasm_struct_get + ty + (wasm_cast ty closure) + (env_start ~no_code_pointer:false arity)) in return (cl_typ, e) @@ -1026,9 +1034,12 @@ module Constant = struct let* e = Memory.make_int32 ~kind:`Nativeint (return (W.Const (I32 i))) in return (Const, e) - let translate c = + let translate ~unboxed c = match c with | Code.Int i -> return (W.Const (I32 (Targetint.to_int32 i))) + | Float f when unboxed -> return (W.Const (F64 (Int64.float_of_bits f))) + | Int64 i when unboxed -> return (W.Const (I64 i)) + | (Int32 i | NativeInt i) when unboxed -> return (W.Const (I32 i)) | _ -> ( let* const, c = translate_rec c in match const with @@ -1061,7 +1072,7 @@ module Closure = struct | [ (g, _) ] -> Code.Var.equal f g | _ :: r -> is_last_fun r f - let translate ~context ~closures ~cps f = + let translate ~context ~closures ~cps ~no_code_pointer f = let info = Code.Var.Map.find f closures in let free_variables = get_free_variables ~context info in assert ( @@ -1070,29 +1081,29 @@ module Closure = struct ~f:(fun x -> Code.Var.Set.mem x context.globalized_variables) free_variables)); let _, arity = List.find ~f:(fun (f', _) -> Code.Var.equal f f') info.functions in - let arity = if cps then arity - 1 else arity in + let arity = if no_code_pointer then 0 else if cps then arity - 1 else arity in let* curry_fun = if arity > 1 then need_curry_fun ~cps ~arity else return f in if List.is_empty free_variables then - let* typ = Type.closure_type ~usage:`Alloc ~cps arity in - let name = Code.Var.fork f in - let* () = - register_global - name - { mut = false; typ = Type.value } - (W.StructNew - ( typ - , if arity = 0 - then [ W.RefFunc f ] - else - let code_pointers = - if arity = 1 then [ W.RefFunc f ] else [ RefFunc curry_fun; RefFunc f ] - in - if include_closure_arity - then Const (I32 (Int32.of_int arity)) :: code_pointers - else code_pointers )) - in - return (W.GlobalGet name) + if no_code_pointer + then Value.unit + else + let* typ = Type.closure_type ~usage:`Alloc ~cps arity in + let name = Code.Var.fork f in + let* () = + register_global + name + { mut = false; typ = Type.value } + (W.StructNew + ( typ + , if no_code_pointer + then [] + else + match arity with + | 0 | 1 -> [ W.RefFunc f ] + | _ -> [ RefFunc curry_fun; RefFunc f ] )) + in + return (W.GlobalGet name) else let* env_type = expression_list variable_type free_variables in let env_type_id = @@ -1106,22 +1117,17 @@ module Closure = struct match info.Closure_conversion.functions with | [] -> assert false | [ _ ] -> - let* typ = Type.env_type ~cps ~arity ~env_type_id ~env_type in + let* typ = Type.env_type ~cps ~arity ~no_code_pointer ~env_type_id ~env_type in let* l = expression_list load free_variables in return (W.StructNew ( typ - , (if arity = 0 - then [ W.RefFunc f ] + , (if no_code_pointer + then [] else - let code_pointers = - if arity = 1 - then [ W.RefFunc f ] - else [ RefFunc curry_fun; RefFunc f ] - in - if include_closure_arity - then W.Const (I32 (Int32.of_int arity)) :: code_pointers - else code_pointers) + match arity with + | 0 | 1 -> [ W.RefFunc f ] + | _ -> [ RefFunc curry_fun; RefFunc f ]) @ l )) | (g, _) :: _ as functions -> let function_count = List.length functions in @@ -1147,21 +1153,25 @@ module Closure = struct load env in let* typ = - Type.rec_closure_type ~cps ~arity ~function_count ~env_type_id ~env_type + Type.rec_closure_type + ~cps + ~arity + ~no_code_pointer + ~function_count + ~env_type_id + ~env_type in let res = let* env = env in return (W.StructNew ( typ - , (let code_pointers = - if arity = 1 - then [ W.RefFunc f ] - else [ RefFunc curry_fun; RefFunc f ] - in - if include_closure_arity - then W.Const (I32 (Int32.of_int arity)) :: code_pointers - else code_pointers) + , (if no_code_pointer + then [] + else + match arity with + | 0 | 1 -> [ W.RefFunc f ] + | _ -> [ RefFunc curry_fun; RefFunc f ]) @ [ env ] )) in if is_last_fun functions f @@ -1182,11 +1192,10 @@ module Closure = struct (load f) else res - let bind_environment ~context ~closures ~cps f = + let bind_environment ~context ~closures ~cps ~no_code_pointer f = let info = Code.Var.Map.find f closures in let free_variables = get_free_variables ~context info in - let free_variable_count = List.length free_variables in - if free_variable_count = 0 + if List.is_empty free_variables then (* The closures are all constants and the environment is empty. *) let* _ = add_var (Code.Var.fresh ()) in @@ -1194,11 +1203,13 @@ module Closure = struct else let env_type_id = Option.value ~default:(-1) info.id in let _, arity = List.find ~f:(fun (f', _) -> Code.Var.equal f f') info.functions in - let arity = if cps then arity - 1 else arity in - let offset = Memory.env_start arity in + let arity = if no_code_pointer then 0 else if cps then arity - 1 else arity in + let offset = Memory.env_start ~no_code_pointer arity in match info.Closure_conversion.functions with | [ _ ] -> - let* typ = Type.env_type ~cps ~arity ~env_type_id ~env_type:[] in + let* typ = + Type.env_type ~cps ~arity ~no_code_pointer ~env_type_id ~env_type:[] + in let* _ = add_var f in let env = Code.Var.fresh_n "env" in let* () = @@ -1218,7 +1229,13 @@ module Closure = struct | functions -> let function_count = List.length functions in let* typ = - Type.rec_closure_type ~cps ~arity ~function_count ~env_type_id ~env_type:[] + Type.rec_closure_type + ~cps + ~arity + ~no_code_pointer + ~function_count + ~env_type_id + ~env_type:[] in let* _ = add_var f in let env = Code.Var.fresh_n "env" in @@ -1247,13 +1264,7 @@ module Closure = struct in let* closure = Memory.wasm_cast cl_ty (load closure) in let* arg = load arg in - let closure_contents = [ W.RefFunc f; closure; arg ] in - return - (W.StructNew - ( ty - , if include_closure_arity - then Const (I32 1l) :: closure_contents - else closure_contents )) + return (W.StructNew (ty, [ W.RefFunc f; closure; arg ])) let curry_load ~cps ~arity m closure = let m = m + 1 in @@ -1264,7 +1275,7 @@ module Closure = struct else Type.curry_type ~cps arity (m + 1) in let cast e = if m = 2 then Memory.wasm_cast ty e else e in - let offset = Memory.env_start 1 in + let offset = Memory.env_start ~no_code_pointer:false 1 in return ( Memory.wasm_struct_get ty (cast (load closure)) (offset + 1) , Memory.wasm_struct_get ty (cast (load closure)) offset @@ -1283,12 +1294,7 @@ module Closure = struct then [ W.RefFunc dummy_fun; RefNull (Type cl_typ) ] else [ RefFunc curry_fun; RefFunc dummy_fun; RefNull (Type cl_typ) ] in - return - (W.StructNew - ( ty - , if include_closure_arity - then Const (I32 1l) :: closure_contents - else closure_contents )) + return (W.StructNew (ty, closure_contents)) end module Math = struct diff --git a/compiler/lib-wasm/generate.ml b/compiler/lib-wasm/generate.ml index 6bbe9830c6..48791e0605 100644 --- a/compiler/lib-wasm/generate.ml +++ b/compiler/lib-wasm/generate.ml @@ -37,6 +37,7 @@ module Generate (Target : Target_sig.S) = struct ; in_cps : Effects.in_cps ; deadcode_sentinal : Var.t ; global_flow_info : Global_flow.info + ; fun_info : Call_graph_analysis.t ; types : Typing.typ Var.Tbl.t ; blocks : block Addr.Map.t ; closures : Closure_conversion.closure Var.Map.t @@ -83,22 +84,6 @@ module Generate (Target : Target_sig.S) = struct let specialized_primitive_type (_, params, result) = { W.params = List.map ~f:repr_type params; result = [ repr_type result ] } - let box_value r e = - match r with - | Value -> e - | Float -> Memory.box_float e - | Int32 -> Memory.box_int32 e - | Nativeint -> Memory.box_nativeint e - | Int64 -> Memory.box_int64 e - - let unbox_value r e = - match r with - | Value -> e - | Float -> Memory.unbox_float e - | Int32 -> Memory.unbox_int32 e - | Nativeint -> Memory.unbox_nativeint e - | Int64 -> Memory.unbox_int64 e - let specialized_primitives = let h = String.Hashtbl.create 18 in List.iter @@ -129,54 +114,34 @@ module Generate (Target : Target_sig.S) = struct ]; h - let float_bin_op' op f g = - Memory.box_float (op (Memory.unbox_float f) (Memory.unbox_float 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 (return (W.BinOp (F64 op, f, g))) - - let float_un_op' op f = Memory.box_float (op (Memory.unbox_float f)) + let* f = f in + let* g = g in + return (W.BinOp (F64 op, f, g)) let float_un_op op f = - let* f = Memory.unbox_float f in - 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 - return (W.BinOp (F64 op, f, g)) + let* f = f in + return (W.UnOp (F64 op, f)) let int32_bin_op op f g = - let* f = Memory.unbox_int32 f in - let* g = Memory.unbox_int32 g in - Memory.box_int32 (return (W.BinOp (I32 op, f, g))) - - let int32_shift_op op f g = - let* f = Memory.unbox_int32 f in + let* f = f in let* g = g in - Memory.box_int32 (return (W.BinOp (I32 op, f, g))) + return (W.BinOp (I32 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 (return (W.BinOp (I64 op, f, g))) + let* f = f in + let* g = g in + return (W.BinOp (I64 op, f, g)) let int64_shift_op op f g = - let* f = Memory.unbox_int64 f in + let* f = f in let* g = g in - Memory.box_int64 (return (W.BinOp (I64 op, f, I64ExtendI32 (S, g)))) + return (W.BinOp (I64 op, f, I64ExtendI32 (S, 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 (return (W.BinOp (I32 op, f, g))) - - let nativeint_shift_op op f g = - let* f = Memory.unbox_nativeint f in + let* f = f in let* g = g in - Memory.box_nativeint (return (W.BinOp (I32 op, f, g))) + return (W.BinOp (I32 op, f, g)) let get_var_type ctx x = Var.Tbl.get ctx.types x @@ -191,6 +156,15 @@ module Generate (Target : Target_sig.S) = struct | Int (Normalized | Unnormalized), Int (Normalized | Unnormalized) -> e | _, Int (Normalized | Unnormalized) -> Value.int_val e | Int (Unnormalized | Normalized), _ -> Value.val_int e + | Number (_, Unboxed), Number (_, Unboxed) -> e + | _, Number (Int32, Unboxed) -> Memory.unbox_int32 e + | _, Number (Int64, Unboxed) -> Memory.unbox_int64 e + | _, Number (Nativeint, Unboxed) -> Memory.unbox_nativeint e + | _, Number (Float, Unboxed) -> Memory.unbox_float e + | Number (Int32, Unboxed), _ -> Memory.box_int32 e + | Number (Int64, Unboxed), _ -> Memory.box_int64 e + | Number (Nativeint, Unboxed), _ -> Memory.box_nativeint e + | Number (Float, Unboxed), _ -> Memory.box_float e | _ -> e let load_and_box ctx x = convert ~from:(get_var_type ctx x) ~into:Top (load x) @@ -201,7 +175,7 @@ module Generate (Target : Target_sig.S) = struct ~into:typ (match x with | Pv x -> load x - | Pc c -> Constant.translate c) + | Pc c -> Constant.translate ~unboxed:false c) let translate_int_comparison ctx op x y = match get_type ctx x, get_type ctx y with @@ -301,11 +275,6 @@ module Generate (Target : Target_sig.S) = struct | _ -> invalid_arity name l ~expected:3) let () = - register_bin_prim - "caml_array_unsafe_get" - `Mutable - ~ty:(Int Normalized) - Memory.gen_array_get; register_bin_prim "caml_floatarray_unsafe_get" `Mutable @@ -315,8 +284,11 @@ module Generate (Target : Target_sig.S) = struct seq (Memory.gen_array_set x y z) Value.unit); register_tern_prim "caml_array_unsafe_set_addr" ~ty:(Int Normalized) (fun x y z -> seq (Memory.array_set x y z) Value.unit); - register_tern_prim "caml_floatarray_unsafe_set" ~ty:(Int Normalized) (fun x y z -> - seq (Memory.float_array_set x y z) Value.unit); + register_tern_prim + "caml_floatarray_unsafe_set" + ~ty:(Int Normalized) + ~tz:(Number (Float, Unboxed)) + (fun x y z -> seq (Memory.float_array_set x y z) Value.unit); register_bin_prim "caml_string_unsafe_get" `Pure ~ty:(Int Normalized) Memory.bytes_get; register_bin_prim "caml_bytes_unsafe_get" @@ -477,91 +449,252 @@ module Generate (Target : Target_sig.S) = struct let* cond = Arith.uge y (Memory.float_array_length (load a)) in instr (W.Br_if (label, cond))) x); - register_bin_prim "caml_add_float" `Pure (fun f g -> float_bin_op Add f g); - register_bin_prim "caml_sub_float" `Pure (fun f g -> float_bin_op Sub f g); - register_bin_prim "caml_mul_float" `Pure (fun f g -> float_bin_op Mul f g); - register_bin_prim "caml_div_float" `Pure (fun f g -> float_bin_op Div f g); - register_bin_prim "caml_copysign_float" `Pure (fun f g -> float_bin_op CopySign f g); - register_un_prim "caml_signbit_float" `Pure (fun f -> - let* f = Memory.unbox_float f in + register_bin_prim + "caml_add_float" + `Pure + ~tx:(Number (Float, Unboxed)) + ~ty:(Number (Float, Unboxed)) + (fun f g -> float_bin_op Add f g); + register_bin_prim + "caml_sub_float" + ~tx:(Number (Float, Unboxed)) + ~ty:(Number (Float, Unboxed)) + `Pure + (fun f g -> float_bin_op Sub f g); + register_bin_prim + "caml_mul_float" + ~tx:(Number (Float, Unboxed)) + ~ty:(Number (Float, Unboxed)) + `Pure + (fun f g -> float_bin_op Mul f g); + register_bin_prim + "caml_div_float" + ~tx:(Number (Float, Unboxed)) + ~ty:(Number (Float, Unboxed)) + `Pure + (fun f g -> float_bin_op Div f g); + register_bin_prim + "caml_copysign_float" + `Pure + ~tx:(Number (Float, Unboxed)) + ~ty:(Number (Float, Unboxed)) + (fun f g -> float_bin_op CopySign f g); + register_un_prim + "caml_signbit_float" + `Pure + ~typ:(Number (Float, Unboxed)) + (fun f -> + let* f = f in let sign = W.BinOp (F64 CopySign, Const (F64 1.), f) in return (W.BinOp (F64 Lt, sign, Const (F64 0.)))); - register_un_prim "caml_neg_float" `Pure (fun f -> float_un_op Neg f); - register_un_prim "caml_abs_float" `Pure (fun f -> float_un_op Abs f); - register_un_prim "caml_ceil_float" `Pure (fun f -> float_un_op Ceil f); - register_un_prim "caml_floor_float" `Pure (fun f -> float_un_op Floor f); - register_un_prim "caml_trunc_float" `Pure (fun f -> float_un_op Trunc f); - register_un_prim "caml_round_float" `Pure (fun f -> float_un_op' Math.round f); - register_un_prim "caml_sqrt_float" `Pure (fun f -> float_un_op Sqrt f); - register_bin_prim "caml_eq_float" `Pure (fun f g -> float_comparison Eq f g); - register_bin_prim "caml_neq_float" `Pure (fun f g -> float_comparison Ne f g); - register_bin_prim "caml_ge_float" `Pure (fun f g -> float_comparison Ge f g); - register_bin_prim "caml_le_float" `Pure (fun f g -> float_comparison Le f g); - register_bin_prim "caml_gt_float" `Pure (fun f g -> float_comparison Gt f g); - register_bin_prim "caml_lt_float" `Pure (fun f g -> float_comparison Lt f g); - register_un_prim "caml_int_of_float" `Pure (fun f -> - let* f = Memory.unbox_float f in + register_un_prim + "caml_neg_float" + `Pure + ~typ:(Number (Float, Unboxed)) + (fun f -> float_un_op Neg f); + register_un_prim + "caml_abs_float" + `Pure + ~typ:(Number (Float, Unboxed)) + (fun f -> float_un_op Abs f); + register_un_prim + "caml_ceil_float" + `Pure + ~typ:(Number (Float, Unboxed)) + (fun f -> float_un_op Ceil f); + register_un_prim + "caml_floor_float" + `Pure + ~typ:(Number (Float, Unboxed)) + (fun f -> float_un_op Floor f); + register_un_prim + "caml_trunc_float" + `Pure + ~typ:(Number (Float, Unboxed)) + (fun f -> float_un_op Trunc f); + register_un_prim "caml_round_float" `Pure ~typ:(Number (Float, Unboxed)) Math.round; + register_un_prim + "caml_sqrt_float" + `Pure + ~typ:(Number (Float, Unboxed)) + (fun f -> float_un_op Sqrt f); + register_bin_prim + "caml_eq_float" + `Pure + ~tx:(Number (Float, Unboxed)) + ~ty:(Number (Float, Unboxed)) + (fun f g -> float_bin_op Eq f g); + register_bin_prim + "caml_neq_float" + `Pure + ~tx:(Number (Float, Unboxed)) + ~ty:(Number (Float, Unboxed)) + (fun f g -> float_bin_op Ne f g); + register_bin_prim + "caml_ge_float" + `Pure + ~tx:(Number (Float, Unboxed)) + ~ty:(Number (Float, Unboxed)) + (fun f g -> float_bin_op Ge f g); + register_bin_prim + "caml_le_float" + `Pure + ~tx:(Number (Float, Unboxed)) + ~ty:(Number (Float, Unboxed)) + (fun f g -> float_bin_op Le f g); + register_bin_prim + "caml_gt_float" + `Pure + ~tx:(Number (Float, Unboxed)) + ~ty:(Number (Float, Unboxed)) + (fun f g -> float_bin_op Gt f g); + register_bin_prim + "caml_lt_float" + ~tx:(Number (Float, Unboxed)) + ~ty:(Number (Float, Unboxed)) + `Pure + (fun f g -> float_bin_op Lt f g); + register_un_prim + "caml_int_of_float" + `Pure + ~typ:(Number (Float, Unboxed)) + (fun f -> + let* f = f in return (W.UnOp (I32 (TruncSatF64 S), f))); register_un_prim "caml_float_of_int" `Pure ~typ:(Int Normalized) (fun n -> let* n = n in - Memory.box_float (return (W.UnOp (F64 (Convert (`I32, S)), n)))); - register_un_prim "caml_cos_float" `Pure (fun f -> float_un_op' Math.cos f); - register_un_prim "caml_sin_float" `Pure (fun f -> float_un_op' Math.sin f); - register_un_prim "caml_tan_float" `Pure (fun f -> float_un_op' Math.tan f); - register_un_prim "caml_acos_float" `Pure (fun f -> float_un_op' Math.acos f); - register_un_prim "caml_asin_float" `Pure (fun f -> float_un_op' Math.asin f); - register_un_prim "caml_atan_float" `Pure (fun f -> float_un_op' Math.atan f); - register_bin_prim "caml_atan2_float" `Pure (fun f g -> float_bin_op' Math.atan2 f g); - register_un_prim "caml_cosh_float" `Pure (fun f -> float_un_op' Math.cosh f); - register_un_prim "caml_sinh_float" `Pure (fun f -> float_un_op' Math.sinh f); - register_un_prim "caml_tanh_float" `Pure (fun f -> float_un_op' Math.tanh f); - register_un_prim "caml_acosh_float" `Pure (fun f -> float_un_op' Math.acosh f); - register_un_prim "caml_asinh_float" `Pure (fun f -> float_un_op' Math.asinh f); - register_un_prim "caml_atanh_float" `Pure (fun f -> float_un_op' Math.atanh f); - register_un_prim "caml_cbrt_float" `Pure (fun f -> float_un_op' Math.cbrt f); - register_un_prim "caml_exp_float" `Pure (fun f -> float_un_op' Math.exp f); - register_un_prim "caml_exp2_float" `Pure (fun f -> float_un_op' Math.exp2 f); - register_un_prim "caml_log_float" `Pure (fun f -> float_un_op' Math.log f); - register_un_prim "caml_expm1_float" `Pure (fun f -> float_un_op' Math.expm1 f); - register_un_prim "caml_log1p_float" `Pure (fun f -> float_un_op' Math.log1p f); - register_un_prim "caml_log2_float" `Pure (fun f -> float_un_op' Math.log2 f); - register_un_prim "caml_log10_float" `Pure (fun f -> float_un_op' Math.log10 f); - register_bin_prim "caml_power_float" `Pure (fun f g -> float_bin_op' Math.power f g); - register_bin_prim "caml_hypot_float" `Pure (fun f g -> float_bin_op' Math.hypot f g); - register_bin_prim "caml_fmod_float" `Pure (fun f g -> float_bin_op' Math.fmod f g); - register_un_prim "caml_int32_bits_of_float" `Pure (fun f -> - let* f = Memory.unbox_float f in - Memory.box_int32 (return (W.UnOp (I32 ReinterpretF, F32DemoteF64 f)))); - register_un_prim "caml_int32_float_of_bits" `Pure (fun i -> - let* i = Memory.unbox_int32 i in - Memory.box_float (return (W.F64PromoteF32 (UnOp (F32 ReinterpretI, i))))); - register_un_prim "caml_int32_of_float" `Pure (fun f -> - let* f = Memory.unbox_float f in - Memory.box_int32 (return (W.UnOp (I32 (TruncSatF64 S), f)))); - register_un_prim "caml_int32_to_float" `Pure (fun n -> - let* n = Memory.unbox_int32 n in - Memory.box_float (return (W.UnOp (F64 (Convert (`I32, S)), n)))); - register_un_prim "caml_int32_neg" `Pure (fun i -> - let* i = Memory.unbox_int32 i in - Memory.box_int32 (return (W.BinOp (I32 Sub, Const (I32 0l), i)))); - register_bin_prim "caml_int32_add" `Pure (fun i j -> int32_bin_op Add i j); - register_bin_prim "caml_int32_sub" `Pure (fun i j -> int32_bin_op Sub i j); - register_bin_prim "caml_int32_mul" `Pure (fun i j -> int32_bin_op Mul i j); - register_bin_prim "caml_int32_and" `Pure (fun i j -> int32_bin_op And i j); - register_bin_prim "caml_int32_or" `Pure (fun i j -> int32_bin_op Or i j); - register_bin_prim "caml_int32_xor" `Pure (fun i j -> int32_bin_op Xor i j); - register_bin_prim_ctx "caml_int32_div" (fun context i j -> + return (W.UnOp (F64 (Convert (`I32, S)), n))); + register_un_prim "caml_cos_float" `Pure ~typ:(Number (Float, Unboxed)) Math.cos; + register_un_prim "caml_sin_float" `Pure ~typ:(Number (Float, Unboxed)) Math.sin; + register_un_prim "caml_tan_float" `Pure ~typ:(Number (Float, Unboxed)) Math.tan; + register_un_prim "caml_acos_float" `Pure ~typ:(Number (Float, Unboxed)) Math.acos; + register_un_prim "caml_asin_float" `Pure ~typ:(Number (Float, Unboxed)) Math.asin; + register_un_prim "caml_atan_float" `Pure ~typ:(Number (Float, Unboxed)) Math.atan; + register_bin_prim + "caml_atan2_float" + `Pure + ~tx:(Number (Float, Unboxed)) + ~ty:(Number (Float, Unboxed)) + Math.atan2; + register_un_prim "caml_cosh_float" `Pure ~typ:(Number (Float, Unboxed)) Math.cosh; + register_un_prim "caml_sinh_float" `Pure ~typ:(Number (Float, Unboxed)) Math.sinh; + register_un_prim "caml_tanh_float" `Pure ~typ:(Number (Float, Unboxed)) Math.tanh; + register_un_prim "caml_acosh_float" `Pure ~typ:(Number (Float, Unboxed)) Math.acosh; + register_un_prim "caml_asinh_float" `Pure ~typ:(Number (Float, Unboxed)) Math.asinh; + register_un_prim "caml_atanh_float" `Pure ~typ:(Number (Float, Unboxed)) Math.atanh; + register_un_prim "caml_cbrt_float" `Pure ~typ:(Number (Float, Unboxed)) Math.cbrt; + register_un_prim "caml_exp_float" `Pure ~typ:(Number (Float, Unboxed)) Math.exp; + register_un_prim "caml_exp2_float" `Pure ~typ:(Number (Float, Unboxed)) Math.exp2; + register_un_prim "caml_log_float" `Pure ~typ:(Number (Float, Unboxed)) Math.log; + register_un_prim "caml_expm1_float" `Pure ~typ:(Number (Float, Unboxed)) Math.expm1; + register_un_prim "caml_log1p_float" `Pure ~typ:(Number (Float, Unboxed)) Math.log1p; + register_un_prim "caml_log2_float" `Pure ~typ:(Number (Float, Unboxed)) Math.log2; + register_un_prim "caml_log10_float" `Pure ~typ:(Number (Float, Unboxed)) Math.log10; + register_bin_prim + "caml_power_float" + `Pure + ~tx:(Number (Float, Unboxed)) + ~ty:(Number (Float, Unboxed)) + Math.power; + register_bin_prim + "caml_hypot_float" + `Pure + ~tx:(Number (Float, Unboxed)) + ~ty:(Number (Float, Unboxed)) + Math.hypot; + register_bin_prim + "caml_fmod_float" + `Pure + ~tx:(Number (Float, Unboxed)) + ~ty:(Number (Float, Unboxed)) + Math.fmod; + register_un_prim + "caml_int32_bits_of_float" + `Pure + ~typ:(Number (Float, Unboxed)) + (fun f -> + let* f = f in + return (W.UnOp (I32 ReinterpretF, F32DemoteF64 f))); + register_un_prim + "caml_int32_float_of_bits" + `Pure + ~typ:(Number (Int32, Unboxed)) + (fun i -> + let* i = i in + return (W.F64PromoteF32 (UnOp (F32 ReinterpretI, i)))); + register_un_prim + "caml_int32_of_float" + `Pure + ~typ:(Number (Float, Unboxed)) + (fun f -> + let* f = f in + return (W.UnOp (I32 (TruncSatF64 S), f))); + register_un_prim + "caml_int32_to_float" + `Pure + ~typ:(Number (Int32, Unboxed)) + (fun n -> + let* n = n in + return (W.UnOp (F64 (Convert (`I32, S)), n))); + register_un_prim + "caml_int32_neg" + `Pure + ~typ:(Number (Int32, Unboxed)) + (fun i -> + let* i = i in + return (W.BinOp (I32 Sub, Const (I32 0l), i))); + register_bin_prim + "caml_int32_add" + `Pure + ~tx:(Number (Int32, Unboxed)) + ~ty:(Number (Int32, Unboxed)) + (fun i j -> int32_bin_op Add i j); + register_bin_prim + "caml_int32_sub" + `Pure + ~tx:(Number (Int32, Unboxed)) + ~ty:(Number (Int32, Unboxed)) + (fun i j -> int32_bin_op Sub i j); + register_bin_prim + "caml_int32_mul" + `Pure + ~tx:(Number (Int32, Unboxed)) + ~ty:(Number (Int32, Unboxed)) + (fun i j -> int32_bin_op Mul i j); + register_bin_prim + "caml_int32_and" + `Pure + ~tx:(Number (Int32, Unboxed)) + ~ty:(Number (Int32, Unboxed)) + (fun i j -> int32_bin_op And i j); + register_bin_prim + "caml_int32_or" + `Pure + ~tx:(Number (Int32, Unboxed)) + ~ty:(Number (Int32, Unboxed)) + (fun i j -> int32_bin_op Or i j); + register_bin_prim + "caml_int32_xor" + `Pure + ~tx:(Number (Int32, Unboxed)) + ~ty:(Number (Int32, Unboxed)) + (fun i j -> int32_bin_op Xor i j); + register_bin_prim_ctx + "caml_int32_div" + ~tx:(Number (Int32, Unboxed)) + ~ty:(Number (Int32, Unboxed)) + (fun context i j -> let res = Var.fresh () in (*ZZZ Can we do better?*) let i' = Var.fresh () in let j' = Var.fresh () in seq - (let* () = store ~typ:I32 j' (Memory.unbox_int32 j) in + (let* () = store ~typ:I32 j' j in let* () = let* j = load j' in instr (W.Br_if (label_index context zero_divide_pc, W.UnOp (I32 Eqz, j))) in - let* () = store ~typ:I32 i' (Memory.unbox_int32 i) in + let* () = store ~typ:I32 i' i in if_ { params = []; result = [] } Arith.( @@ -577,65 +710,137 @@ module Generate (Target : 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 (load res))); - register_bin_prim_ctx "caml_int32_mod" (fun context i j -> + (load res)); + register_bin_prim_ctx + "caml_int32_mod" + ~tx:(Number (Int32, Unboxed)) + ~ty:(Number (Int32, Unboxed)) + (fun context i j -> let j' = Var.fresh () in seq - (let* () = store ~typ:I32 j' (Memory.unbox_int32 j) in + (let* () = store ~typ:I32 j' j in let* j = load j' in instr (W.Br_if (label_index context zero_divide_pc, W.UnOp (I32 Eqz, j)))) - (let* i = Memory.unbox_int32 i in + (let* i = i in let* j = load j' in - Memory.box_int32 (return (W.BinOp (I32 (Rem S), i, j))))); - register_bin_prim "caml_int32_shift_left" `Pure ~ty:(Int Unnormalized) (fun i j -> - int32_shift_op Shl i j); - register_bin_prim "caml_int32_shift_right" `Pure ~ty:(Int Unnormalized) (fun i j -> - int32_shift_op (Shr S) i j); + return (W.BinOp (I32 (Rem S), i, j)))); + register_bin_prim + "caml_int32_shift_left" + `Pure + ~tx:(Number (Int32, Unboxed)) + ~ty:(Int Unnormalized) + (fun i j -> int32_bin_op Shl i j); + register_bin_prim + "caml_int32_shift_right" + `Pure + ~tx:(Number (Int32, Unboxed)) + ~ty:(Int Unnormalized) + (fun i j -> int32_bin_op (Shr S) i j); register_bin_prim "caml_int32_shift_right_unsigned" `Pure + ~tx:(Number (Int32, Unboxed)) ~ty:(Int Unnormalized) - (fun i j -> int32_shift_op (Shr U) i j); - register_un_prim "caml_int32_to_int" `Pure (fun i -> Memory.unbox_int32 i); - register_un_prim "caml_int32_of_int" `Pure ~typ:(Int Normalized) (fun i -> - Memory.box_int32 i); - register_un_prim "caml_nativeint_of_int32" `Pure (fun i -> - Memory.box_nativeint (Memory.unbox_int32 i)); - register_un_prim "caml_nativeint_to_int32" `Pure (fun i -> - Memory.box_int32 (Memory.unbox_nativeint i)); - register_un_prim "caml_int64_bits_of_float" `Pure (fun f -> - let* f = Memory.unbox_float f in - Memory.box_int64 (return (W.UnOp (I64 ReinterpretF, f)))); - register_un_prim "caml_int64_float_of_bits" `Pure (fun i -> - let* i = Memory.unbox_int64 i in - Memory.box_float (return (W.UnOp (F64 ReinterpretI, i)))); - register_un_prim "caml_int64_of_float" `Pure (fun f -> - let* f = Memory.unbox_float f in - Memory.box_int64 (return (W.UnOp (I64 (TruncSatF64 S), f)))); - register_un_prim "caml_int64_to_float" `Pure (fun n -> - let* n = Memory.unbox_int64 n in - Memory.box_float (return (W.UnOp (F64 (Convert (`I64, S)), n)))); - register_un_prim "caml_int64_neg" `Pure (fun i -> - let* i = Memory.unbox_int64 i in - Memory.box_int64 (return (W.BinOp (I64 Sub, Const (I64 0L), i)))); - register_bin_prim "caml_int64_add" `Pure (fun i j -> int64_bin_op Add i j); - register_bin_prim "caml_int64_sub" `Pure (fun i j -> int64_bin_op Sub i j); - register_bin_prim "caml_int64_mul" `Pure (fun i j -> int64_bin_op Mul i j); - register_bin_prim "caml_int64_and" `Pure (fun i j -> int64_bin_op And i j); - register_bin_prim "caml_int64_or" `Pure (fun i j -> int64_bin_op Or i j); - register_bin_prim "caml_int64_xor" `Pure (fun i j -> int64_bin_op Xor i j); - register_bin_prim_ctx "caml_int64_div" (fun context i j -> + (fun i j -> int32_bin_op (Shr U) i j); + register_un_prim "caml_int32_to_int" `Pure ~typ:(Number (Int32, Unboxed)) (fun i -> i); + register_un_prim "caml_int32_of_int" `Pure ~typ:(Int Normalized) (fun i -> i); + register_un_prim + "caml_nativeint_of_int32" + `Pure + ~typ:(Number (Int32, Unboxed)) + (fun i -> i); + register_un_prim + "caml_nativeint_to_int32" + `Pure + ~typ:(Number (Nativeint, Unboxed)) + (fun i -> i); + register_un_prim + "caml_int64_bits_of_float" + `Pure + ~typ:(Number (Float, Unboxed)) + (fun f -> + let* f = f in + return (W.UnOp (I64 ReinterpretF, f))); + register_un_prim + "caml_int64_float_of_bits" + `Pure + ~typ:(Number (Int64, Unboxed)) + (fun i -> + let* i = i in + return (W.UnOp (F64 ReinterpretI, i))); + register_un_prim + "caml_int64_of_float" + `Pure + ~typ:(Number (Float, Unboxed)) + (fun f -> + let* f = f in + return (W.UnOp (I64 (TruncSatF64 S), f))); + register_un_prim + "caml_int64_to_float" + `Pure + ~typ:(Number (Int64, Unboxed)) + (fun n -> + let* n = n in + return (W.UnOp (F64 (Convert (`I64, S)), n))); + register_un_prim + "caml_int64_neg" + `Pure + ~typ:(Number (Int64, Unboxed)) + (fun i -> + let* i = i in + return (W.BinOp (I64 Sub, Const (I64 0L), i))); + register_bin_prim + "caml_int64_add" + `Pure + ~tx:(Number (Int64, Unboxed)) + ~ty:(Number (Int64, Unboxed)) + (fun i j -> int64_bin_op Add i j); + register_bin_prim + "caml_int64_sub" + `Pure + ~tx:(Number (Int64, Unboxed)) + ~ty:(Number (Int64, Unboxed)) + (fun i j -> int64_bin_op Sub i j); + register_bin_prim + "caml_int64_mul" + `Pure + ~tx:(Number (Int64, Unboxed)) + ~ty:(Number (Int64, Unboxed)) + (fun i j -> int64_bin_op Mul i j); + register_bin_prim + "caml_int64_and" + `Pure + ~tx:(Number (Int64, Unboxed)) + ~ty:(Number (Int64, Unboxed)) + (fun i j -> int64_bin_op And i j); + register_bin_prim + "caml_int64_or" + `Pure + ~tx:(Number (Int64, Unboxed)) + ~ty:(Number (Int64, Unboxed)) + (fun i j -> int64_bin_op Or i j); + register_bin_prim + "caml_int64_xor" + `Pure + ~tx:(Number (Int64, Unboxed)) + ~ty:(Number (Int64, Unboxed)) + (fun i j -> int64_bin_op Xor i j); + register_bin_prim_ctx + "caml_int64_div" + ~tx:(Number (Int64, Unboxed)) + ~ty:(Number (Int64, Unboxed)) + (fun context i j -> let res = Var.fresh () in (*ZZZ Can we do better?*) let i' = Var.fresh () in let j' = Var.fresh () in seq - (let* () = store ~typ:I64 j' (Memory.unbox_int64 j) in + (let* () = store ~typ:I64 j' j in let* () = let* j = load j' in instr (W.Br_if (label_index context zero_divide_pc, W.UnOp (I64 Eqz, j))) in - let* () = store ~typ:I64 i' (Memory.unbox_int64 i) in + let* () = store ~typ:I64 i' i in if_ { params = []; result = [] } Arith.( @@ -651,80 +856,166 @@ module Generate (Target : 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 (load res))); - register_bin_prim_ctx "caml_int64_mod" (fun context i j -> + (load res)); + register_bin_prim_ctx + "caml_int64_mod" + ~tx:(Number (Int64, Unboxed)) + ~ty:(Number (Int64, Unboxed)) + (fun context i j -> let j' = Var.fresh () in seq - (let* () = store ~typ:I64 j' (Memory.unbox_int64 j) in + (let* () = store ~typ:I64 j' j in let* j = load j' in instr (W.Br_if (label_index context zero_divide_pc, W.UnOp (I64 Eqz, j)))) - (let* i = Memory.unbox_int64 i in + (let* i = i in let* j = load j' in - Memory.box_int64 (return (W.BinOp (I64 (Rem S), i, j))))); - register_bin_prim "caml_int64_shift_left" `Pure ~ty:(Int Unnormalized) (fun i j -> - int64_shift_op Shl i j); - register_bin_prim "caml_int64_shift_right" `Pure ~ty:(Int Unnormalized) (fun i j -> - int64_shift_op (Shr S) i j); + return (W.BinOp (I64 (Rem S), i, j)))); + register_bin_prim + "caml_int64_shift_left" + `Pure + ~tx:(Number (Int64, Unboxed)) + ~ty:(Int Unnormalized) + (fun i j -> int64_shift_op Shl i j); + register_bin_prim + "caml_int64_shift_right" + `Pure + ~tx:(Number (Int64, Unboxed)) + ~ty:(Int Unnormalized) + (fun i j -> int64_shift_op (Shr S) i j); register_bin_prim "caml_int64_shift_right_unsigned" + ~tx:(Number (Int64, Unboxed)) ~ty:(Int Unnormalized) `Pure (fun i j -> int64_shift_op (Shr U) i j); - register_un_prim "caml_int64_to_int" `Pure (fun i -> - let* i = Memory.unbox_int64 i in + register_un_prim + "caml_int64_to_int" + `Pure + ~typ:(Number (Int64, Unboxed)) + (fun i -> + let* i = i in return (W.I32WrapI64 i)); register_un_prim "caml_int64_of_int" `Pure ~typ:(Int Normalized) (fun i -> let* i = i in - Memory.box_int64 - (return - (match i with - | Const (I32 i) -> W.Const (I64 (Int64.of_int32 i)) - | _ -> W.I64ExtendI32 (S, i)))); - register_un_prim "caml_int64_to_int32" `Pure (fun i -> - let* i = Memory.unbox_int64 i in - Memory.box_int32 (return (W.I32WrapI64 i))); - register_un_prim "caml_int64_of_int32" `Pure (fun i -> - let* i = Memory.unbox_int32 i in - Memory.box_int64 (return (W.I64ExtendI32 (S, i)))); - register_un_prim "caml_int64_to_nativeint" `Pure (fun i -> - let* i = Memory.unbox_int64 i in - Memory.box_nativeint (return (W.I32WrapI64 i))); - register_un_prim "caml_int64_of_nativeint" `Pure (fun i -> - let* i = Memory.unbox_nativeint i in - Memory.box_int64 (return (W.I64ExtendI32 (S, i)))); - register_un_prim "caml_nativeint_bits_of_float" `Pure (fun f -> - let* f = Memory.unbox_float f in - Memory.box_nativeint (return (W.UnOp (I32 ReinterpretF, F32DemoteF64 f)))); - register_un_prim "caml_nativeint_float_of_bits" `Pure (fun i -> - let* i = Memory.unbox_int64 i in - Memory.box_float (return (W.F64PromoteF32 (UnOp (I32 ReinterpretF, i))))); - register_un_prim "caml_nativeint_of_float" `Pure (fun f -> - let* f = Memory.unbox_float f in - Memory.box_nativeint (return (W.UnOp (I32 (TruncSatF64 S), f)))); - register_un_prim "caml_nativeint_to_float" `Pure (fun n -> - let* n = Memory.unbox_nativeint n in - Memory.box_float (return (W.UnOp (F64 (Convert (`I32, S)), n)))); - register_un_prim "caml_nativeint_neg" `Pure (fun i -> - let* i = Memory.unbox_nativeint i in - Memory.box_nativeint (return (W.BinOp (I32 Sub, Const (I32 0l), i)))); - register_bin_prim "caml_nativeint_add" `Pure (fun i j -> nativeint_bin_op Add i j); - register_bin_prim "caml_nativeint_sub" `Pure (fun i j -> nativeint_bin_op Sub i j); - register_bin_prim "caml_nativeint_mul" `Pure (fun i j -> nativeint_bin_op Mul i j); - register_bin_prim "caml_nativeint_and" `Pure (fun i j -> nativeint_bin_op And i j); - register_bin_prim "caml_nativeint_or" `Pure (fun i j -> nativeint_bin_op Or i j); - register_bin_prim "caml_nativeint_xor" `Pure (fun i j -> nativeint_bin_op Xor i j); - register_bin_prim_ctx "caml_nativeint_div" (fun context i j -> + return + (match i with + | Const (I32 i) -> W.Const (I64 (Int64.of_int32 i)) + | _ -> W.I64ExtendI32 (S, i))); + register_un_prim + "caml_int64_to_int32" + `Pure + ~typ:(Number (Int64, Unboxed)) + (fun i -> + let* i = i in + return (W.I32WrapI64 i)); + register_un_prim + "caml_int64_of_int32" + `Pure + ~typ:(Number (Int32, Unboxed)) + (fun i -> + let* i = i in + return (W.I64ExtendI32 (S, i))); + register_un_prim + "caml_int64_to_nativeint" + `Pure + ~typ:(Number (Int64, Unboxed)) + (fun i -> + let* i = i in + return (W.I32WrapI64 i)); + register_un_prim + "caml_int64_of_nativeint" + `Pure + ~typ:(Number (Nativeint, Unboxed)) + (fun i -> + let* i = i in + return (W.I64ExtendI32 (S, i))); + register_un_prim + "caml_nativeint_bits_of_float" + `Pure + ~typ:(Number (Float, Unboxed)) + (fun f -> + let* f = f in + return (W.UnOp (I32 ReinterpretF, F32DemoteF64 f))); + register_un_prim + "caml_nativeint_float_of_bits" + `Pure + ~typ:(Number (Nativeint, Unboxed)) + (fun i -> + let* i = i in + return (W.F64PromoteF32 (UnOp (I32 ReinterpretF, i)))); + register_un_prim + "caml_nativeint_of_float" + `Pure + ~typ:(Number (Float, Unboxed)) + (fun f -> + let* f = f in + return (W.UnOp (I32 (TruncSatF64 S), f))); + register_un_prim + "caml_nativeint_to_float" + `Pure + ~typ:(Number (Nativeint, Unboxed)) + (fun n -> + let* n = n in + return (W.UnOp (F64 (Convert (`I32, S)), n))); + register_un_prim + "caml_nativeint_neg" + `Pure + ~typ:(Number (Nativeint, Unboxed)) + (fun i -> + let* i = i in + return (W.BinOp (I32 Sub, Const (I32 0l), i))); + register_bin_prim + "caml_nativeint_add" + `Pure + ~tx:(Number (Nativeint, Unboxed)) + ~ty:(Number (Nativeint, Unboxed)) + (fun i j -> nativeint_bin_op Add i j); + register_bin_prim + "caml_nativeint_sub" + `Pure + ~tx:(Number (Nativeint, Unboxed)) + ~ty:(Number (Nativeint, Unboxed)) + (fun i j -> nativeint_bin_op Sub i j); + register_bin_prim + "caml_nativeint_mul" + `Pure + ~tx:(Number (Nativeint, Unboxed)) + ~ty:(Number (Nativeint, Unboxed)) + (fun i j -> nativeint_bin_op Mul i j); + register_bin_prim + "caml_nativeint_and" + `Pure + ~tx:(Number (Nativeint, Unboxed)) + ~ty:(Number (Nativeint, Unboxed)) + (fun i j -> nativeint_bin_op And i j); + register_bin_prim + "caml_nativeint_or" + `Pure + ~tx:(Number (Nativeint, Unboxed)) + ~ty:(Number (Nativeint, Unboxed)) + (fun i j -> nativeint_bin_op Or i j); + register_bin_prim + "caml_nativeint_xor" + `Pure + ~tx:(Number (Nativeint, Unboxed)) + ~ty:(Number (Nativeint, Unboxed)) + (fun i j -> nativeint_bin_op Xor i j); + register_bin_prim_ctx + "caml_nativeint_div" + ~tx:(Number (Nativeint, Unboxed)) + ~ty:(Number (Nativeint, Unboxed)) + (fun context i j -> let res = Var.fresh () in (*ZZZ Can we do better?*) let i' = Var.fresh () in let j' = Var.fresh () in seq - (let* () = store ~typ:I32 j' (Memory.unbox_nativeint j) in + (let* () = store ~typ:I32 j' j in let* () = let* j = load j' in instr (W.Br_if (label_index context zero_divide_pc, W.UnOp (I32 Eqz, j))) in - let* () = store ~typ:I32 i' (Memory.unbox_nativeint i) in + let* () = store ~typ:I32 i' i in if_ { params = []; result = [] } Arith.( @@ -740,31 +1031,44 @@ module Generate (Target : 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 (load res))); - register_bin_prim_ctx "caml_nativeint_mod" (fun context i j -> + (load res)); + register_bin_prim_ctx + "caml_nativeint_mod" + ~tx:(Number (Nativeint, Unboxed)) + ~ty:(Number (Nativeint, Unboxed)) + (fun context i j -> let j' = Var.fresh () in seq - (let* () = store ~typ:I32 j' (Memory.unbox_nativeint j) in + (let* () = store ~typ:I32 j' j in let* j = load j' in instr (W.Br_if (label_index context zero_divide_pc, W.UnOp (I32 Eqz, j)))) - (let* i = Memory.unbox_nativeint i in + (let* i = i in let* j = load j' in - Memory.box_nativeint (return (W.BinOp (I32 (Rem S), i, j))))); - register_bin_prim "caml_nativeint_shift_left" `Pure ~ty:(Int Unnormalized) (fun i j -> - nativeint_shift_op Shl i j); + return (W.BinOp (I32 (Rem S), i, j)))); + register_bin_prim + "caml_nativeint_shift_left" + `Pure + ~tx:(Number (Nativeint, Unboxed)) + ~ty:(Int Unnormalized) + (fun i j -> nativeint_bin_op Shl i j); register_bin_prim "caml_nativeint_shift_right" `Pure + ~tx:(Number (Nativeint, Unboxed)) ~ty:(Int Unnormalized) - (fun i j -> nativeint_shift_op (Shr S) i j); + (fun i j -> nativeint_bin_op (Shr S) i j); register_bin_prim "caml_nativeint_shift_right_unsigned" `Pure + ~tx:(Number (Nativeint, Unboxed)) ~ty:(Int Unnormalized) - (fun i j -> nativeint_shift_op (Shr U) i j); - register_un_prim "caml_nativeint_to_int" `Pure (fun i -> Memory.unbox_nativeint i); - register_un_prim "caml_nativeint_of_int" `Pure ~typ:(Int Normalized) (fun i -> - Memory.box_nativeint i); + (fun i j -> nativeint_bin_op (Shr U) i j); + register_un_prim + "caml_nativeint_to_int" + `Pure + ~typ:(Number (Nativeint, Unboxed)) + (fun i -> i); + register_un_prim "caml_nativeint_of_int" `Pure ~typ:(Int Normalized) (fun i -> i); register_bin_prim "caml_int_compare" `Pure @@ -772,84 +1076,90 @@ module Generate (Target : Target_sig.S) = struct ~ty:(Int Normalized) (fun i j -> Arith.((j < i) - (i < j))); register_prim "%js_array" `Pure (fun ctx _ l -> - let* l = - List.fold_right - ~f:(fun x acc -> - let* x = transl_prim_arg ctx x in - let* acc = acc in - return (`Expr x :: acc)) - l - ~init:(return []) - in - Memory.allocate ~tag:0 ~deadcode_sentinal:ctx.deadcode_sentinal ~load l) + Memory.allocate ~tag:0 (expression_list (fun x -> transl_prim_arg ctx x) l)) + + let unboxed_type ty : W.value_type option = + match ty with + | Typing.Int (Normalized | Unnormalized) | Number ((Int32 | Nativeint), Unboxed) -> + Some I32 + | Number (Int64, Unboxed) -> Some I64 + | Number (Float, Unboxed) -> Some F64 + | _ -> None + + let box_number_if_needed ctx x e = + match get_var_type ctx x with + | Number (n, Boxed) as into -> convert ~from:(Number (n, Unboxed)) ~into e + | _ -> e let rec translate_expr ctx context x e = match e with | Apply { f; args; exact; _ } -> + let* closure = load f in + let* args = expression_list (fun x -> load_and_box ctx x) args in if exact || List.length args = if Var.Set.mem x ctx.in_cps then 2 else 1 then - 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* ty, funct = - Memory.load_function_pointer - ~cps:(Var.Set.mem x ctx.in_cps) - ~arity - (load funct) - in - let* b = is_closure f in - if b - then return (W.Call (f, List.rev (closure :: acc))) - else - 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))) - | _ -> ( - match - if exact - then Global_flow.get_unique_closure ctx.global_flow_info f - else None - with - | Some g -> return (W.Call (g, List.rev (closure :: acc))) - | None -> return (W.Call_ref (ty, funct, List.rev (closure :: acc))) - )) - | x :: r -> - let* x = load_and_box ctx x in - loop (x :: acc) r - in - loop [] args + match + if exact then Global_flow.get_unique_closure ctx.global_flow_info f else None + with + | Some g -> + let* cl = + (* Functions with constant closures ignore their environment. *) + match closure with + | GlobalGet global -> + let* init = get_global global in + if Option.is_some init then Value.unit else return closure + | _ -> return closure + in + return (W.Call (g, args @ [ cl ])) + | None -> ( + let funct = Var.fresh () in + let* closure = tee funct (return closure) in + let* ty, funct = + Memory.load_function_pointer + ~cps:(Var.Set.mem x ctx.in_cps) + ~arity:(List.length args) + (load funct) + in + match funct with + | W.RefFunc g -> return (W.Call (g, args @ [ closure ])) + | _ -> return (W.Call_ref (ty, funct, args @ [ closure ]))) else let* apply = need_apply_fun ~cps:(Var.Set.mem x ctx.in_cps) ~arity:(List.length args) in - let* args = expression_list (fun x -> load_and_box ctx x) args in - let* closure = load f in return (W.Call (apply, args @ [ closure ])) | Block (tag, a, _, _) -> - Memory.allocate - ~deadcode_sentinal:ctx.deadcode_sentinal - ~tag - ~load:(fun x -> load_and_box ctx x) - (List.map ~f:(fun x -> `Var x) (Array.to_list a)) - | Field (x, n, Non_float) -> Memory.field (load_and_box ctx x) n - | Field (x, n, Float) -> + if tag = 254 + then + Memory.allocate_float_array + ~deadcode_sentinal:ctx.deadcode_sentinal + ~load:(fun x -> + convert ~from:(get_var_type ctx x) ~into:(Number (Float, Unboxed)) (load x)) + (Array.to_list a) + else + Memory.allocate + ~tag + (expression_list (fun x -> load_and_box ctx x) (Array.to_list a)) + | Field (y, n, Non_float) -> Memory.field (load_and_box ctx y) n + | Field (y, n, Float) -> Memory.float_array_get - (load_and_box ctx x) - (Constant.translate (Int (Targetint.of_int_warning_on_overflow n))) + (load_and_box ctx y) + (return (W.Const (I32 (Int32.of_int n)))) + |> box_number_if_needed ctx x | Closure _ -> Closure.translate ~context:ctx.global_context ~closures:ctx.closures ~cps:(Var.Set.mem x ctx.in_cps) + ~no_code_pointer:(Call_graph_analysis.direct_calls_only ctx.fun_info x) x - | Constant c -> Constant.translate c + | Constant c -> + Constant.translate + ~unboxed: + (match get_var_type ctx x with + | Number (_, Unboxed) -> true + | _ -> false) + c | Special (Alias_prim _) -> assert false | Prim (Extern "caml_alloc_dummy_function", [ _; Pc (Int arity) ]) -> (* Removed in OCaml 5.2 *) @@ -896,40 +1206,55 @@ module Generate (Target : Target_sig.S) = struct Memory.array_get (transl_prim_arg ctx x) (transl_prim_arg ctx ~typ:(Int Normalized) y) + | Prim (Extern "caml_array_unsafe_get", [ x; y ]) -> + Memory.gen_array_get + (transl_prim_arg ctx x) + (transl_prim_arg ctx ~typ:(Int Normalized) y) | Prim (p, l) -> ( match p with | Extern name when String.Hashtbl.mem internal_primitives name -> snd (String.Hashtbl.find internal_primitives name) ctx context l + |> box_number_if_needed ctx x + | Extern name when String.Hashtbl.mem specialized_primitives name -> + let ((_, arg_typ, _) as typ) = + String.Hashtbl.find specialized_primitives name + in + let* f = register_import ~name (Fun (specialized_primitive_type typ)) in + let rec loop acc arg_typ l = + match arg_typ, l with + | [], [] -> return (W.Call (f, List.rev acc)) + | repr :: rem, x :: r -> + let* x = + transl_prim_arg + ctx + ?typ: + (match repr with + | Value -> None + | Float -> Some (Number (Float, Unboxed)) + | Int32 -> Some (Number (Int32, Unboxed)) + | Nativeint -> Some (Number (Nativeint, Unboxed)) + | Int64 -> Some (Number (Int64, Unboxed))) + x + in + loop (x :: acc) rem r + | [], _ :: _ | _ :: _, [] -> assert false + in + loop [] arg_typ l |> box_number_if_needed ctx x | _ -> ( let l = List.map ~f:(fun x -> transl_prim_arg ctx x) l in match p, l with - | Extern name, l -> ( - try - let ((_, arg_typ, res_typ) as typ) = - String.Hashtbl.find specialized_primitives name - in - let* f = register_import ~name (Fun (specialized_primitive_type typ)) in - let rec loop acc arg_typ l = - match arg_typ, l with - | [], [] -> box_value res_typ (return (W.Call (f, List.rev acc))) - | repr :: rem, x :: r -> - let* x = unbox_value repr x in - loop (x :: acc) rem r - | [], _ :: _ | _ :: _, [] -> assert false - in - loop [] arg_typ l - with Not_found -> - let* f = - register_import ~name (Fun (Type.primitive_type (List.length l))) - in - let rec loop acc l = - match l with - | [] -> return (W.Call (f, List.rev acc)) - | x :: r -> - let* x = x in - loop (x :: acc) r - in - loop [] l) + | Extern name, l -> + let* f = + register_import ~name (Fun (Type.primitive_type (List.length l))) + in + let rec loop acc l = + match l with + | [] -> return (W.Call (f, List.rev acc)) + | x :: r -> + let* x = x in + loop (x :: acc) r + in + loop [] l | IsInt, [ x ] -> Value.is_int x | Vectlength, [ x ] -> Memory.gen_array_length x | (Not | Lt | Le | Eq | Neq | Ult | Array_get | IsInt | Vectlength), _ -> @@ -944,10 +1269,7 @@ module Generate (Target : Target_sig.S) = struct then drop (translate_expr ctx context x e) else store - ?typ: - (match get_var_type ctx x with - | Int (Normalized | Unnormalized) -> Some I32 - | _ -> None) + ?typ:(unboxed_type (get_var_type ctx x)) x (translate_expr ctx context x e) | Set_field (x, n, Non_float, y) -> @@ -955,8 +1277,8 @@ module Generate (Target : Target_sig.S) = struct | Set_field (x, n, Float, y) -> Memory.float_array_set (load_and_box ctx x) - (Constant.translate (Int (Targetint.of_int_warning_on_overflow n))) - (load y) + (return (W.Const (I32 (Int32.of_int n)))) + (convert ~from:(get_var_type ctx y) ~into:(Number (Float, Unboxed)) (load y)) | Offset_ref (x, n) -> Memory.set_field (load x) @@ -1020,14 +1342,7 @@ module Generate (Target : Target_sig.S) = struct l ~f:(fun continuation (y, ty, x, tx) -> let* () = continuation in - store - ~always:true - ?typ: - (match ty with - | Typing.Int (Normalized | Unnormalized) -> Some I32 - | _ -> None) - y - (convert ~from:tx ~into:ty (load x))) + store ~always:true ?typ:(unboxed_type ty) y (convert ~from:tx ~into:ty (load x))) ~init:(return ()) let exception_name = "ocaml_exception" @@ -1272,6 +1587,7 @@ module Generate (Target : Target_sig.S) = struct ~context:ctx.global_context ~closures:ctx.closures ~cps:(Var.Set.mem f ctx.in_cps) + ~no_code_pointer:(Call_graph_analysis.direct_calls_only ctx.fun_info f) f | None -> return () in @@ -1400,6 +1716,7 @@ module Generate (Target : Target_sig.S) = struct *) ~deadcode_sentinal ~global_flow_info + ~fun_info ~types = global_context.unit_name <- unit_name; let p, closures = Closure_conversion.f p in @@ -1411,6 +1728,7 @@ module Generate (Target : Target_sig.S) = struct ; in_cps ; deadcode_sentinal ; global_flow_info + ; fun_info ; types ; blocks = p.blocks ; closures @@ -1520,9 +1838,10 @@ let start () = make_context ~value_type:Gc_target.Type.value let f ~context ~unit_name p ~live_vars ~in_cps ~deadcode_sentinal ~global_flow_data = let state, info = global_flow_data in - let p = Structure.norm p in + let fun_info = Call_graph_analysis.f p info in let types = Typing.f ~state ~info ~deadcode_sentinal p in let t = Timer.make () in + let p = Structure.norm p in let p = fix_switch_branches p in let res = G.f @@ -1532,6 +1851,7 @@ let f ~context ~unit_name p ~live_vars ~in_cps ~deadcode_sentinal ~global_flow_d ~in_cps ~deadcode_sentinal ~global_flow_info:info + ~fun_info ~types p in diff --git a/compiler/lib-wasm/target_sig.ml b/compiler/lib-wasm/target_sig.ml index 053e3be066..197bf6e690 100644 --- a/compiler/lib-wasm/target_sig.ml +++ b/compiler/lib-wasm/target_sig.ml @@ -20,11 +20,12 @@ module type S = sig type expression = Code_generation.expression module Memory : sig - val allocate : - tag:int - -> deadcode_sentinal:Code.Var.t + val allocate : tag:int -> Wasm_ast.expression list Code_generation.t -> expression + + val allocate_float_array : + deadcode_sentinal:Code.Var.t -> load:(Code.Var.t -> expression) - -> [ `Expr of Wasm_ast.expression | `Var of Wasm_ast.var ] list + -> Wasm_ast.var list -> expression val load_function_pointer : @@ -166,7 +167,7 @@ module type S = sig end module Constant : sig - val translate : Code.constant -> expression + val translate : unboxed:bool -> Code.constant -> expression end module Closure : sig @@ -174,6 +175,7 @@ module type S = sig context:Code_generation.context -> closures:Closure_conversion.closure Code.Var.Map.t -> cps:bool + -> no_code_pointer:bool -> Code.Var.t -> expression @@ -181,6 +183,7 @@ module type S = sig context:Code_generation.context -> closures:Closure_conversion.closure Code.Var.Map.t -> cps:bool + -> no_code_pointer:bool -> Code.Var.t -> unit Code_generation.t diff --git a/compiler/lib-wasm/typing.ml b/compiler/lib-wasm/typing.ml index 3e4781fcc9..c8cd07a8e6 100644 --- a/compiler/lib-wasm/typing.ml +++ b/compiler/lib-wasm/typing.ml @@ -4,6 +4,8 @@ open Global_flow let debug = Debug.find "typing" +let times = Debug.find "times" + module Integer = struct type kind = | Ref @@ -23,10 +25,14 @@ type boxed_number = | Nativeint | Float +type boxed_status = + | Boxed + | Unboxed + type typ = | Top | Int of Integer.kind - | Number of boxed_number + | Number of boxed_number * boxed_status | Tuple of typ array (** This value is a block or an integer; if it's an integer, an overapproximation of the possible values of each of its @@ -40,7 +46,15 @@ module Domain = struct match t, t' with | Bot, t | t, Bot -> t | Int r, Int r' -> Int (Integer.join r r') - | Number n, Number n' -> if Poly.equal n n' then t else Top + | Number (n, b), Number (n', b') -> + if Poly.equal n n' + then + Number + ( n + , match b, b' with + | Unboxed, _ | _, Unboxed -> Unboxed + | Boxed, Boxed -> Boxed ) + else Top | Tuple t, Tuple t' -> let l = Array.length t in let l' = Array.length t' in @@ -62,7 +76,7 @@ module Domain = struct match t, t' with | Top, Top | Bot, Bot -> true | Int t, Int t' -> Poly.equal t t' - | Number t, Number t' -> Poly.equal t t' + | Number (t, b), Number (t', b') -> Poly.equal t t' && Poly.equal b b' | Tuple t, Tuple t' -> Array.length t = Array.length t' && Array.for_all2 ~f:equal t t' | (Top | Tuple _ | Int _ | Number _ | Bot), _ -> false @@ -89,6 +103,7 @@ module Domain = struct let box t = match t with | Int _ -> Int Ref + | Number (n, _) -> Number (n, Boxed) | _ -> t let rec print f t = @@ -103,10 +118,18 @@ module Domain = struct | Ref -> "ref" | Normalized -> "normalized" | Unnormalized -> "unnormalized") - | Number Int32 -> Format.fprintf f "int32" - | Number Int64 -> Format.fprintf f "int64" - | Number Nativeint -> Format.fprintf f "nativeint" - | Number Float -> Format.fprintf f "float" + | Number (n, b) -> + Format.fprintf + f + "%s{%s}" + (match n with + | Int32 -> "int32" + | Int64 -> "int64" + | Nativeint -> "nativeint" + | Float -> "float") + (match b with + | Boxed -> "boxed" + | Unboxed -> "unboxed") | Tuple t -> Format.fprintf f @@ -154,10 +177,10 @@ type st = let rec constant_type (c : constant) = match c with | Int _ -> Int Normalized - | Int32 _ -> Number Int32 - | Int64 _ -> Number Int64 - | NativeInt _ -> Number Nativeint - | Float _ -> Number Float + | Int32 _ -> Number (Int32, Unboxed) + | Int64 _ -> Number (Int64, Unboxed) + | NativeInt _ -> Number (Nativeint, Unboxed) + | Float _ -> Number (Float, Unboxed) | Tuple (_, a, _) -> Tuple (Array.map ~f:(fun c' -> Domain.box (constant_type c')) a) | _ -> Top @@ -192,22 +215,22 @@ let prim_type ~approx prim args = | "caml_lessequal" | "caml_equal" | "caml_compare" -> Int Ref - | "caml_int32_bswap" -> Number Int32 - | "caml_nativeint_bswap" -> Number Nativeint - | "caml_int64_bswap" -> Number Int64 + | "caml_int32_bswap" -> Number (Int32, Unboxed) + | "caml_nativeint_bswap" -> Number (Nativeint, Unboxed) + | "caml_int64_bswap" -> Number (Int64, Unboxed) | "caml_int32_compare" | "caml_nativeint_compare" | "caml_int64_compare" -> Int Ref - | "caml_string_get32" -> Number Int32 - | "caml_string_get64" -> Number Int64 - | "caml_bytes_get32" -> Number Int32 - | "caml_bytes_get64" -> Number Int64 - | "caml_lxm_next" -> Number Int64 - | "caml_ba_uint8_get32" -> Number Int32 - | "caml_ba_uint8_get64" -> Number Int64 - | "caml_nextafter_float" -> Number Float + | "caml_string_get32" -> Number (Int32, Unboxed) + | "caml_string_get64" -> Number (Int64, Unboxed) + | "caml_bytes_get32" -> Number (Int32, Unboxed) + | "caml_bytes_get64" -> Number (Int64, Unboxed) + | "caml_lxm_next" -> Number (Int64, Unboxed) + | "caml_ba_uint8_get32" -> Number (Int32, Unboxed) + | "caml_ba_uint8_get64" -> Number (Int64, Unboxed) + | "caml_nextafter_float" -> Number (Float, Unboxed) | "caml_classify_float" -> Int Ref - | "caml_ldexp_float" | "caml_erf_float" | "caml_erfc_float" -> Number Float + | "caml_ldexp_float" | "caml_erf_float" | "caml_erfc_float" -> Number (Float, Unboxed) | "caml_float_compare" -> Int Ref - | "caml_floatarray_unsafe_get" -> Number Float + | "caml_floatarray_unsafe_get" -> Number (Float, Unboxed) | "caml_bytes_unsafe_get" | "caml_string_unsafe_get" | "caml_bytes_get" @@ -219,7 +242,7 @@ let prim_type ~approx prim args = | "caml_sub_float" | "caml_mul_float" | "caml_div_float" - | "caml_copysign_float" -> Number Float + | "caml_copysign_float" -> Number (Float, Unboxed) | "caml_signbit_float" -> Int Normalized | "caml_neg_float" | "caml_abs_float" @@ -227,7 +250,7 @@ let prim_type ~approx prim args = | "caml_floor_float" | "caml_trunc_float" | "caml_round_float" - | "caml_sqrt_float" -> Number Float + | "caml_sqrt_float" -> Number (Float, Unboxed) | "caml_eq_float" | "caml_neq_float" | "caml_ge_float" @@ -259,11 +282,11 @@ let prim_type ~approx prim args = | "caml_log10_float" | "caml_power_float" | "caml_hypot_float" - | "caml_fmod_float" -> Number Float - | "caml_int32_bits_of_float" -> Number Int32 - | "caml_int32_float_of_bits" -> Number Float - | "caml_int32_of_float" -> Number Int32 - | "caml_int32_to_float" -> Number Float + | "caml_fmod_float" -> Number (Float, Unboxed) + | "caml_int32_bits_of_float" -> Number (Int32, Unboxed) + | "caml_int32_float_of_bits" -> Number (Float, Unboxed) + | "caml_int32_of_float" -> Number (Int32, Unboxed) + | "caml_int32_to_float" -> Number (Float, Unboxed) | "caml_int32_neg" | "caml_int32_add" | "caml_int32_sub" @@ -275,15 +298,15 @@ let prim_type ~approx prim args = | "caml_int32_mod" | "caml_int32_shift_left" | "caml_int32_shift_right" - | "caml_int32_shift_right_unsigned" -> Number Int32 + | "caml_int32_shift_right_unsigned" -> Number (Int32, Unboxed) | "caml_int32_to_int" -> Int Unnormalized - | "caml_int32_of_int" -> Number Int32 - | "caml_nativeint_of_int32" -> Number Nativeint - | "caml_nativeint_to_int32" -> Number Int32 - | "caml_int64_bits_of_float" -> Number Int64 - | "caml_int64_float_of_bits" -> Number Float - | "caml_int64_of_float" -> Number Int64 - | "caml_int64_to_float" -> Number Float + | "caml_int32_of_int" -> Number (Int32, Unboxed) + | "caml_nativeint_of_int32" -> Number (Nativeint, Unboxed) + | "caml_nativeint_to_int32" -> Number (Int32, Unboxed) + | "caml_int64_bits_of_float" -> Number (Int64, Unboxed) + | "caml_int64_float_of_bits" -> Number (Float, Unboxed) + | "caml_int64_of_float" -> Number (Int64, Unboxed) + | "caml_int64_to_float" -> Number (Float, Unboxed) | "caml_int64_neg" | "caml_int64_add" | "caml_int64_sub" @@ -295,17 +318,17 @@ let prim_type ~approx prim args = | "caml_int64_mod" | "caml_int64_shift_left" | "caml_int64_shift_right" - | "caml_int64_shift_right_unsigned" -> Number Int64 + | "caml_int64_shift_right_unsigned" -> Number (Int64, Unboxed) | "caml_int64_to_int" -> Int Unnormalized - | "caml_int64_of_int" -> Number Int64 - | "caml_int64_to_int32" -> Number Int32 - | "caml_int64_of_int32" -> Number Int64 - | "caml_int64_to_nativeint" -> Number Nativeint - | "caml_int64_of_nativeint" -> Number Int64 - | "caml_nativeint_bits_of_float" -> Number Nativeint - | "caml_nativeint_float_of_bits" -> Number Float - | "caml_nativeint_of_float" -> Number Nativeint - | "caml_nativeint_to_float" -> Number Float + | "caml_int64_of_int" -> Number (Int64, Unboxed) + | "caml_int64_to_int32" -> Number (Int32, Unboxed) + | "caml_int64_of_int32" -> Number (Int64, Unboxed) + | "caml_int64_to_nativeint" -> Number (Nativeint, Unboxed) + | "caml_int64_of_nativeint" -> Number (Int64, Unboxed) + | "caml_nativeint_bits_of_float" -> Number (Nativeint, Unboxed) + | "caml_nativeint_float_of_bits" -> Number (Float, Unboxed) + | "caml_nativeint_of_float" -> Number (Nativeint, Unboxed) + | "caml_nativeint_to_float" -> Number (Float, Unboxed) | "caml_nativeint_neg" | "caml_nativeint_add" | "caml_nativeint_sub" @@ -317,9 +340,9 @@ let prim_type ~approx prim args = | "caml_nativeint_mod" | "caml_nativeint_shift_left" | "caml_nativeint_shift_right" - | "caml_nativeint_shift_right_unsigned" -> Number Nativeint + | "caml_nativeint_shift_right_unsigned" -> Number (Nativeint, Unboxed) | "caml_nativeint_to_int" -> Int Unnormalized - | "caml_nativeint_of_int" -> Number Nativeint + | "caml_nativeint_of_int" -> Number (Nativeint, Unboxed) | "caml_int_compare" -> Int Normalized | _ -> Top @@ -343,7 +366,7 @@ let propagate st approx x : Domain.t = | Some_fields _ | No_field -> Domain.limit (Domain.box (Var.Tbl.get approx y))) lst) - | Field (_, _, Float) -> Number Float + | Field (_, _, Float) -> Number (Float, Unboxed) | Field (y, n, Non_float) -> ( match Var.Tbl.get approx y with | Tuple t -> if n < Array.length t then t.(n) else Bot @@ -419,11 +442,184 @@ let solver st = in Solver.f () g (propagate st) +(* These are primitives which are handled internally by the compiler, + plus the specialized primitives listed in Generate. *) +let primitives_with_unboxed_parameters = + let h = String.Hashtbl.create 256 in + List.iter + ~f:(fun s -> String.Hashtbl.add h s ()) + [ "caml_int32_bswap" + ; "caml_nativeint_bswap" + ; "caml_int64_bswap" + ; "caml_int32_compare" + ; "caml_nativeint_compare" + ; "caml_int64_compare" + ; "caml_nextafter_float" + ; "caml_classify_float" + ; "caml_ldexp_float" + ; "caml_erf_float" + ; "caml_erfc_float" + ; "caml_float_compare" + ; "caml_add_float" + ; "caml_sub_float" + ; "caml_mul_float" + ; "caml_div_float" + ; "caml_copysign_float" + ; "caml_signbit_float" + ; "caml_neg_float" + ; "caml_abs_float" + ; "caml_ceil_float" + ; "caml_floor_float" + ; "caml_trunc_float" + ; "caml_round_float" + ; "caml_sqrt_float" + ; "caml_eq_float" + ; "caml_neq_float" + ; "caml_ge_float" + ; "caml_le_float" + ; "caml_gt_float" + ; "caml_lt_float" + ; "caml_int_of_float" + ; "caml_cos_float" + ; "caml_sin_float" + ; "caml_tan_float" + ; "caml_acos_float" + ; "caml_asin_float" + ; "caml_atan_float" + ; "caml_atan2_float" + ; "caml_cosh_float" + ; "caml_sinh_float" + ; "caml_tanh_float" + ; "caml_acosh_float" + ; "caml_asinh_float" + ; "caml_atanh_float" + ; "caml_cbrt_float" + ; "caml_exp_float" + ; "caml_exp2_float" + ; "caml_log_float" + ; "caml_expm1_float" + ; "caml_log1p_float" + ; "caml_log2_float" + ; "caml_log10_float" + ; "caml_power_float" + ; "caml_hypot_float" + ; "caml_fmod_float" + ; "caml_int32_bits_of_float" + ; "caml_int32_float_of_bits" + ; "caml_int32_of_float" + ; "caml_int32_to_float" + ; "caml_int32_neg" + ; "caml_int32_add" + ; "caml_int32_sub" + ; "caml_int32_mul" + ; "caml_int32_and" + ; "caml_int32_or" + ; "caml_int32_xor" + ; "caml_int32_div" + ; "caml_int32_mod" + ; "caml_int32_shift_left" + ; "caml_int32_shift_right" + ; "caml_int32_shift_right_unsigned" + ; "caml_int32_to_int" + ; "caml_nativeint_of_int32" + ; "caml_nativeint_to_int32" + ; "caml_int64_bits_of_float" + ; "caml_int64_float_of_bits" + ; "caml_int64_of_float" + ; "caml_int64_to_float" + ; "caml_int64_neg" + ; "caml_int64_add" + ; "caml_int64_sub" + ; "caml_int64_mul" + ; "caml_int64_and" + ; "caml_int64_or" + ; "caml_int64_xor" + ; "caml_int64_div" + ; "caml_int64_mod" + ; "caml_int64_shift_left" + ; "caml_int64_shift_right" + ; "caml_int64_shift_right_unsigned" + ; "caml_int64_to_int" + ; "caml_int64_to_int32" + ; "caml_int64_of_int32" + ; "caml_int64_to_nativeint" + ; "caml_int64_of_nativeint" + ; "caml_nativeint_bits_of_float" + ; "caml_nativeint_float_of_bits" + ; "caml_nativeint_of_float" + ; "caml_nativeint_to_float" + ; "caml_nativeint_neg" + ; "caml_nativeint_add" + ; "caml_nativeint_sub" + ; "caml_nativeint_mul" + ; "caml_nativeint_and" + ; "caml_nativeint_or" + ; "caml_nativeint_xor" + ; "caml_nativeint_div" + ; "caml_nativeint_mod" + ; "caml_nativeint_shift_left" + ; "caml_nativeint_shift_right" + ; "caml_nativeint_shift_right_unsigned" + ; "caml_nativeint_to_int" + ; "caml_floatarray_unsafe_set" + ]; + h + +let box_numbers p st types = + (* We box numbers eagerly if the boxed value is ever used. *) + let should_box = Var.ISet.empty () in + let rec box y = + if not (Var.ISet.mem should_box y) + then ( + Var.ISet.add should_box y; + let typ = Var.Tbl.get types y in + (match typ with + | Number (n, Unboxed) -> Var.Tbl.set types y (Number (n, Boxed)) + | _ -> ()); + match typ with + | Number (_, Unboxed) | Top -> ( + match st.state.defs.(Var.idx y) with + | Expr _ -> () + | Phi { known; _ } -> Var.Set.iter box known) + | Number (_, Boxed) | Int _ | Tuple _ | Bot -> ()) + in + Addr.Map.iter + (fun _ b -> + List.iter + ~f:(fun i -> + match i with + | Let (_, e) -> ( + match e with + | Apply { args; _ } -> List.iter ~f:box args + | Block (tag, lst, _, _) -> if tag <> 254 then Array.iter ~f:box lst + | Prim (Extern s, args) -> + if not (String.Hashtbl.mem primitives_with_unboxed_parameters s) + then + List.iter + ~f:(fun a -> + match a with + | Pv y -> box y + | Pc _ -> ()) + args + | Prim ((Vectlength | Array_get | Not | IsInt | Eq | Neq | Lt | Le | Ult), _) + | Field _ | Closure _ | Constant _ | Special _ -> ()) + | Set_field (_, _, Non_float, y) | Array_set (_, _, y) -> box y + | Assign _ | Offset_ref _ | Set_field (_, _, Float, _) | Event _ -> ()) + b.body; + match b.branch with + | Return y -> box y + | Raise _ | Stop | Branch _ | Cond _ | Switch _ | Pushtrap _ | Poptrap _ -> ()) + p.blocks + let f ~state ~info ~deadcode_sentinal p = + let t = Timer.make () in update_deps state p; let function_parameters = mark_function_parameters p in - let typ = solver { state; info; function_parameters } in + let st = { state; info; function_parameters } in + let typ = solver st in Var.Tbl.set typ deadcode_sentinal (Int Normalized); + box_numbers p st typ; + if times () then Format.eprintf " type analysis: %a@." Timer.print t; if debug () then ( Var.ISet.iter diff --git a/compiler/lib-wasm/typing.mli b/compiler/lib-wasm/typing.mli index 1860b4ac7c..d962438bbe 100644 --- a/compiler/lib-wasm/typing.mli +++ b/compiler/lib-wasm/typing.mli @@ -11,10 +11,14 @@ type boxed_number = | Nativeint | Float +type boxed_status = + | Boxed + | Unboxed + type typ = | Top | Int of Integer.kind - | Number of boxed_number + | Number of boxed_number * boxed_status | Tuple of typ array | Bot diff --git a/compiler/lib-wasm/wasm_output.ml b/compiler/lib-wasm/wasm_output.ml index 0617b0878c..88595ca03a 100644 --- a/compiler/lib-wasm/wasm_output.ml +++ b/compiler/lib-wasm/wasm_output.ml @@ -550,7 +550,9 @@ end = struct List.iter ~f:(fun e' -> output_expression st ch e') l; output_byte ch 0x10; output_uint ch (Code.Var.Hashtbl.find st.func_names f) - | Seq _ -> assert false + | Seq (l, e') -> + List.iter ~f:(fun i' -> output_instruction st ch i') l; + output_expression st ch e' | Pop _ -> () | RefFunc f -> Feature.require reference_types; @@ -939,7 +941,9 @@ end = struct List.fold_left ~f:(fun set i -> instr_function_references i set) ~init:set l | Call (_, l) | ArrayNewFixed (_, l) | StructNew (_, l) -> List.fold_left ~f:(fun set i -> expr_function_references i set) ~init:set l - | Seq _ -> assert false + | Seq (l, e) -> + List.fold_left ~f:(fun set i -> instr_function_references i set) ~init:set l + |> expr_function_references e | RefFunc f -> Code.Var.Set.add f set | Call_ref (_, e', l) -> List.fold_left diff --git a/runtime/wasm/effect.wat b/runtime/wasm/effect.wat index 05bc0ad9c2..40aa1dc7c1 100644 --- a/runtime/wasm/effect.wat +++ b/runtime/wasm/effect.wat @@ -45,7 +45,7 @@ (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) (type $function_1 (func (param (ref eq) (ref eq)) (result (ref eq)))) - (type $closure (sub (struct (;(field i32);) (field (ref $function_1))))) + (type $closure (sub (struct (field (ref $function_1))))) (type $function_3 (func (param (ref eq) (ref eq) (ref eq) (ref eq)) (result (ref eq)))) (type $closure_3 diff --git a/runtime/wasm/obj.wat b/runtime/wasm/obj.wat index 5e6a96ea5f..4fc39ee904 100644 --- a/runtime/wasm/obj.wat +++ b/runtime/wasm/obj.wat @@ -34,11 +34,9 @@ (type $float (struct (field f64))) (type $float_array (array (mut f64))) (type $function_1 (func (param (ref eq) (ref eq)) (result (ref eq)))) - (type $closure (sub (struct (;(field i32);) (field (ref $function_1))))) - (type $closure_last_arg - (sub $closure (struct (;(field i32);) (field (ref $function_1))))) - (type $function_2 - (func (param (ref eq) (ref eq) (ref eq)) (result (ref eq)))) + (type $closure (sub (struct (field (ref $function_1))))) + (type $closure_last_arg (sub $closure (struct (field (ref $function_1))))) + (type $function_2 (func (param (ref eq) (ref eq) (ref eq)) (result (ref eq)))) (type $cps_closure (sub (struct (field (ref $function_2))))) (type $cps_closure_last_arg (sub $cps_closure (struct (field (ref $function_2)))))