diff --git a/compiler/lib-wasm/generate.ml b/compiler/lib-wasm/generate.ml index 9a049ab9aa..a79d273255 100644 --- a/compiler/lib-wasm/generate.ml +++ b/compiler/lib-wasm/generate.ml @@ -2474,6 +2474,16 @@ module Generate (Target : Target_sig.S) = struct Typing.reset (); Primitive.register "caml_make_array" `Mutable None None; Primitive.register "caml_array_of_uniform_array" `Mutable None None; + Primitive.register "caml_array_unsafe_get" `Mutable None None; + Primitive.register "caml_alloc_dummy" `Pure None None; + Primitive.register "caml_alloc_dummy_float" `Pure None None; + Primitive.register "caml_alloc_dummy_mixed" `Pure None None; + Primitive.register "caml_js_to_int32" `Pure None None; + Primitive.register "caml_js_to_nativeint" `Pure None None; + Primitive.register "caml_js_from_bool" `Pure None None; + Primitive.register "caml_js_to_bool" `Pure None None; + Primitive.register "caml_js_equals" `Mutable None None; + Primitive.register "caml_js_strict_equals" `Mutable None None; (* These primitives are rewritten by [Specialize_js] before code generation, but need to be registered so that [Primitive.get_external] reports them as available for the diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index e02da32415..a6f6c0f3b2 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -17,6 +17,23 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +(* +Static evaluation +================= +- Limited amount of fuel +- Cannot return a static boxed constant + (`return x` where x is a constant global variable (not in env), + or a parameter from the initial call) +- Deal with constant tuples (see one_ulp / lower_bound_for_int) + +We need to keep track of whether we have a global constant, +a small constant, a tuple built during evaluation. +==> beware of sharing when building a tuple (maybe do not allow tuple of anything but small constants and global constants? at least after evaluation) +==> should keep referring to global constants and not duplicate them + +Add tests +*) + open! Stdlib open Code open Flow @@ -27,6 +44,8 @@ let stats = Debug.find "stats" let debug_stats = Debug.find "stats-debug" +let debug_static_eval = Debug.find "static-eval" + let static_env = String.Hashtbl.create 17 let clear_static_env () = String.Hashtbl.clear static_env @@ -138,6 +157,16 @@ let nativeint_shiftop (l : constant list) (f : int32 -> int -> int32) : constant | [ NativeInt i; Int j ] -> Some (NativeInt (f i (Targetint.to_int_exn j))) | _ -> None +let eval_comparison op args = + match args with + | [ Int i; Int j ] -> bool (op (Targetint.compare i j) 0) + | [ Int32 i; Int32 j ] -> bool (op (Int32.compare i j) 0) + | [ Int64 i; Int64 j ] -> bool (op (Int64.compare i j) 0) + | [ NativeInt i; NativeInt j ] -> bool (op (Int32.compare i j) 0) + | [ Float f; Float g ] -> + bool (op (Float.compare (Int64.float_of_bits f) (Int64.float_of_bits g)) 0) + | _ -> None + let quiet_nan n = Int64.logor n 0x00_08_00_00_00_00_00_00L let eval_prim ~target x = @@ -362,6 +391,22 @@ let eval_prim ~target x = Some (Int (Targetint.of_int_exn (Targetint.num_bits ()))) | "caml_sys_const_big_endian", [ _ ] -> Some (Int Targetint.zero) | "caml_sys_const_naked_pointers_checked", [ _ ] -> Some (Int Targetint.zero) + | "caml_sys_const_runtime5", [ _ ] -> Some (Int Targetint.one) + | "caml_obj_dup", [ x ] -> ( + match x with + | NativeString _ + | Float _ + | Float32 _ + | Int _ + | Int32 _ + | Int64 _ + | NativeInt _ + | Null_ -> Some x + | String _ | Float_array _ | Tuple _ -> None) + | "caml_greaterthan", args -> eval_comparison ( > ) args + | "caml_greaterequal", args -> eval_comparison ( >= ) args + | "caml_lessthan", args -> eval_comparison ( < ) args + | "caml_lessequal", args -> eval_comparison ( <= ) args | _ -> None) | _ -> None @@ -530,7 +575,214 @@ let constant_equal a b = | (String _ | NativeString _), _ -> false | (Float_array _ | Tuple _), _ -> false -let eval_instr update_count inline_constant ~target info i = +let static_eval_fuel = 1000 + +let rec eval_block ~fuel ~info ~blocks ~target ~env pc args = + if !fuel <= 0 + then None + else ( + decr fuel; + let block = Addr.Map.find pc blocks in + let env = + List.fold_left2 + ~f:(fun env x x' -> + match resolve ~info ~env (Pv x') with + | None -> Var.Map.remove x env + | Some c -> Var.Map.add x c env) + block.params + args + ~init:env + in + match eval_block_body ~fuel ~info ~blocks ~target ~env block.body with + | None -> None + | Some env -> ( + if debug_static_eval () + then Format.eprintf "instr %a@." Code.Print.last block.branch; + match block.branch with + | Return x -> resolve ~info ~env (Pv x) + | Branch (pc', args') -> eval_block ~fuel ~info ~blocks ~target ~env pc' args' + | Cond (x, (pc1, args1), (pc2, args2)) -> ( + match resolve ~info ~env (Pv x) with + | Some (Int i) when Targetint.is_zero i -> + eval_block ~fuel ~info ~blocks ~target ~env pc2 args2 + | Some (Int _ | Tuple _) -> + eval_block ~fuel ~info ~blocks ~target ~env pc1 args1 + | _ -> None) + | Switch (x, conts) -> ( + match resolve ~info ~env (Pv x) with + | Some (Int i) -> + let pc', args' = conts.(Targetint.to_int_exn i) in + eval_block ~fuel ~info ~blocks ~target ~env pc' args' + | _ -> None) + | Raise _ | Stop | Pushtrap _ | Poptrap _ -> None)) + +and resolve ~info ~env ?(eq = constant_equal) a = + match + match a with + | Pv x -> Var.Map.find_opt x env + | _ -> None + with + | Some _ as c -> c + | None -> the_const_of ~eq info a + +and eval_block_body ~fuel ~info ~blocks ~target ~env instrs = + (if debug_static_eval () + then + match instrs with + | i :: _ -> Format.eprintf "instr %a@." Code.Print.instr i + | [] -> ()); + match instrs with + | [] -> Some env + | Event _ :: rem -> eval_block_body ~fuel ~info ~blocks ~target ~env rem + | Let (x, Prim (Extern (("caml_equal" | "caml_notequal") as prim), [ y; z ])) :: rem + -> ( + let eq e1 e2 = + match Code.Constant.ocaml_equal e1 e2 with + | None -> false + | Some e -> e + in + match resolve ~info ~env ~eq y, resolve ~info ~env ~eq z with + | Some e1, Some e2 -> ( + match Code.Constant.ocaml_equal e1 e2 with + | None -> None + | Some c -> + let c = + match prim with + | "caml_equal" -> c + | "caml_notequal" -> not c + | _ -> assert false + in + eval_block_body + ~fuel + ~info + ~blocks + ~target + ~env:(Var.Map.add x (bool' c) env) + rem) + | _ -> None) + | Let (x, Prim (IsInt, [ y ])) :: rem -> ( + let res = + match is_int info y with + | Y -> Some true + | N -> Some false + | Unknown -> ( + match resolve ~info ~env y with + | Some (Int _) -> Some true + | Some _ -> Some false + | None -> None) + in + match res with + | None -> None + | Some b -> + eval_block_body + ~fuel + ~info + ~blocks + ~target + ~env:(Var.Map.add x (bool' b) env) + rem) + | Let (x, Prim (Extern "caml_obj_tag", [ y ])) :: rem -> ( + match resolve ~info ~env y with + | Some (Tuple (tag, _, _)) -> + eval_block_body + ~fuel + ~info + ~blocks + ~target + ~env:(Var.Map.add x (Int (Targetint.of_int_exn tag)) env) + rem + | _ -> None) + | (Let (x, Prim (prim, prim_args)) as i) :: rem -> ( + let prim_args' = List.map prim_args ~f:(fun a -> resolve ~info ~env a) in + if List.exists prim_args' ~f:Option.is_none + then ( + if debug_static_eval () + then ( + List.iter prim_args' ~f:(fun a -> + Format.eprintf "%s" (if Option.is_some a then "x" else "?")); + Format.eprintf "@."); + None) + else + let res = + eval_prim + ~target + ( prim + , List.map prim_args' ~f:(function + | Some c -> c + | None -> assert false) ) + in + match res with + | None -> + if debug_static_eval () then Format.eprintf "INSTR %a@." Code.Print.instr i; + None + | Some c -> + eval_block_body ~fuel ~info ~blocks ~target ~env:(Var.Map.add x c env) rem) + | Let (x, Constant c) :: rem -> ( + match c with + | Float _ + | Float32 _ + | Int _ + | Int32 _ + | Int64 _ + | NativeInt _ + | NativeString _ + | Float_array _ + | Null_ -> + eval_block_body ~fuel ~info ~blocks ~target ~env:(Var.Map.add x c env) rem + | String _ | Tuple _ -> None) + | Let (x, Apply { f; args; _ }) :: rem -> ( + match get_approx info (fun g -> Flow.Info.def info g) None (fun _ _ -> None) f with + | Some (Closure (params, (pc, args'), _)) when List.compare_lengths args params = 0 + -> + let args = List.map args ~f:(fun x -> resolve ~info ~env (Pv x)) in + if List.for_all args ~f:Option.is_some + then + let callee_env = + List.fold_left2 + ~f:(fun s x v -> Var.Map.add x (Option.get v) s) + params + args + ~init:Var.Map.empty + in + match eval_block ~fuel ~info ~blocks ~target ~env:callee_env pc args' with + | Some c -> + eval_block_body ~fuel ~info ~blocks ~target ~env:(Var.Map.add x c env) rem + | None -> None + else None + | _ -> None) + | Let (x, Block (tag, fields, _, _)) :: rem -> + let fields = Array.map fields ~f:(fun x -> resolve ~info ~env (Pv x)) in + if Array.exists fields ~f:Option.is_none + then None + else + let fields = + Array.map fields ~f:(function + | Some c -> c + | None -> assert false) + in + eval_block_body + ~fuel + ~info + ~blocks + ~target + ~env:(Var.Map.add x (Tuple (tag, fields, Unknown)) env) + rem + | Let (x, Field (y, i, _)) :: rem -> ( + match resolve ~info ~env (Pv y) with + | Some (Tuple (_, fields, _)) when i < Array.length fields -> + eval_block_body + ~fuel + ~info + ~blocks + ~target + ~env:(Var.Map.add x fields.(i) env) + rem + | _ -> None) + | ( Let (_, (Closure _ | Special _)) + | Assign _ | Set_field _ | Offset_ref _ | Array_set _ ) + :: _ -> None + +let eval_instr update_count inline_constant ~target info ~blocks i = match i with | Let (x, Prim (Extern (("caml_equal" | "caml_notequal") as prim), [ y; z ])) -> ( let eq e1 e2 = @@ -721,6 +973,39 @@ let eval_instr update_count inline_constant ~target info i = they're not represented with constant in javascript. *) | None, _ -> arg)) ) ) ]) + | Let (x, Apply { f; args; _ }) -> ( + match get_approx info (fun g -> Flow.Info.def info g) None (fun _ _ -> None) f with + | Some (Closure (params, (pc, args'), _)) when List.compare_lengths args params = 0 + -> + let args = + List.map args ~f:(fun x -> the_const_of ~eq:constant_equal info (Pv x)) + in + if List.for_all args ~f:Option.is_some + then ( + if debug_static_eval () then Format.eprintf "ZZZ %a@." Code.Var.print f; + let env = + List.fold_left2 + ~f:(fun s x v -> Var.Map.add x (Option.get v) s) + params + args + ~init:Var.Map.empty + in + let fuel = ref static_eval_fuel in + match eval_block ~fuel ~info ~blocks ~target ~env pc args' with + | Some (Tuple _ | Float_array _) -> + (* The outcome is not supposed to be a block; emitting one as + a constant loses the array_or_not / field-type information + the back-end needs (e.g. for float records). *) + [ i ] + | Some c -> + if debug_static_eval () then Format.eprintf "===> STATIC@."; + let c = Constant c in + Flow.Info.update_def info x c; + incr update_count; + [ Let (x, c) ] + | None -> [ i ]) + else [ i ] + | _ -> [ i ]) | _ -> [ i ] type cond_of = @@ -853,7 +1138,7 @@ let eval update_count update_branch inline_constant ~target info blocks = let body = List.concat_map block.body - ~f:(eval_instr update_count inline_constant ~target info) + ~f:(eval_instr update_count inline_constant ~blocks ~target info) in let branch = eval_branch update_branch info block.branch in { block with Code.body; Code.branch }) diff --git a/runtime/js/obj.js b/runtime/js/obj.js index 2384e87e0f..210ada322f 100644 --- a/runtime/js/obj.js +++ b/runtime/js/obj.js @@ -30,7 +30,7 @@ function caml_update_dummy(x, y) { return 0; } -//Provides: caml_alloc_dummy_infix +//Provides: caml_alloc_dummy_infix pure //Requires: caml_call_gen //Version: < 5.4 function caml_alloc_dummy_infix() { @@ -39,7 +39,7 @@ function caml_alloc_dummy_infix() { }; } -//Provides: caml_alloc_dummy_lazy +//Provides: caml_alloc_dummy_lazy pure //Version: >= 5.4 function caml_alloc_dummy_lazy(_unit) { return [0, 0]; diff --git a/runtime/js/sys.js b/runtime/js/sys.js index 00093077ca..7d87ea5b69 100644 --- a/runtime/js/sys.js +++ b/runtime/js/sys.js @@ -161,7 +161,7 @@ function caml_sys_unsafe_getenv(name) { return caml_sys_getenv(name); } -//Provides: caml_argv +//Provides: caml_argv mutable //Requires: caml_string_of_jsstring var caml_argv = (function () { var process = globalThis.process;