diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index 2954158960..b688d46101 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -17,6 +17,16 @@ * 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) +*) + open! Stdlib open Code open Flow @@ -139,6 +149,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 = @@ -351,6 +371,14 @@ 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_obj_dup", [ x ] -> ( + match x with + | NativeString _ | Float _ | Int _ | Int32 _ | Int64 _ | NativeInt _ -> 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 @@ -511,7 +539,180 @@ let constant_equal a b = | (String _ | NativeString _), _ -> false | (Float_array _ | Tuple _), _ -> false -let eval_instr update_count inline_constant ~target info i = +let rec eval_block ~info ~blocks ~target ~env pc args = + 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 ~info ~blocks ~target ~env block.body with + | None -> None + | Some env -> ( + 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 ~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 ~info ~blocks ~target ~env pc2 args2 + | Some (Int _ | Tuple _) -> eval_block ~info ~blocks ~target ~env pc1 args1 + | Some _ -> assert false + | None -> 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 ~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 ~info ~blocks ~target ~env instrs = + (match instrs with + | i :: _ -> Format.eprintf "instr %a@." Code.Print.instr i + | [] -> ()); + match instrs with + | [] -> Some env + | Event _ :: rem -> eval_block_body ~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 ~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 ~info ~blocks ~target ~env:(Var.Map.add x (bool' b) env) rem) + | (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:(function + | Some _ -> false + | None -> true) + then ( + List.iter prim_args' ~f:(fun x -> + Format.eprintf + "%s" + (match x with + | Some _ -> "x" + | None -> "?")); + 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 -> + Format.eprintf "INSTR %a@." Code.Print.instr i; + None + | Some c -> eval_block_body ~info ~blocks ~target ~env:(Var.Map.add x c env) rem) + | Let (x, Constant c) :: rem -> ( + match c with + | Float _ | Int _ | Int32 _ | Int64 _ | NativeInt _ | NativeString _ | Float_array _ + -> eval_block_body ~info ~blocks ~target ~env:(Var.Map.add x c env) rem + | String _ (*ZZZ*) | 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:(fun x -> + match x with + | Some _ -> true + | None -> false) + then + let env = + List.fold_left2 + ~f:(fun s x v -> Var.Map.add x (Option.get v) s) + params + args + ~init:env + in + let res = eval_block ~info ~blocks ~target ~env pc args' in + match res with + | Some c -> + eval_block_body ~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:(function + | Some _ -> false + | None -> true) + then None + else + let fields = + Array.map fields ~f:(function + | Some c -> c + | None -> assert false) + in + eval_block_body + ~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 ~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 = @@ -699,6 +900,48 @@ 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 -> + match Flow.Info.def info g with + | Some e -> Some (g, e) + | _ -> None) + None + (fun _ _ -> None) + f + with + | Some (f, 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:(fun x -> + match x with + | Some _ -> true + | None -> false) + 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 res = eval_block ~info ~blocks ~target ~env pc args' in + match res with + | Some c -> + 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 = @@ -829,7 +1072,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/compiler/lib/flow.ml b/compiler/lib/flow.ml index 13de7ffb74..2e11629ceb 100644 --- a/compiler/lib/flow.ml +++ b/compiler/lib/flow.ml @@ -338,14 +338,17 @@ let get_approx top join x = - let s = Var.Tbl.get info_known_origins x in - if Var.Tbl.get info_maybe_unknown x + if Var.Tbl.length info_known_origins <= Var.idx x then top else - match Var.Set.cardinal s with - | 0 -> top - | 1 -> f (Var.Set.choose s) - | _ -> Var.Set.fold (fun x u -> join (f x) u) s (f (Var.Set.choose s)) + let s = Var.Tbl.get info_known_origins x in + if Var.Tbl.get info_maybe_unknown x + then top + else + match Var.Set.cardinal s with + | 0 -> top + | 1 -> f (Var.Set.choose s) + | _ -> Var.Set.fold (fun x u -> join (f x) u) s (f (Var.Set.choose s)) let the_def_of info x = match x with