diff --git a/CHANGES.md b/CHANGES.md index b3cf3aebff..5b075986f2 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,14 +1,15 @@ # dev (2021-??-??) - ?? ## Features/Changes -* Compiler: static evaluation of backend_type -* Compiler: speedup emitting js files. -* Compiler: simplify (a | 0) >>> 0 into (a >>> 0) -* Lib: add messageEvent to Dom_html -* Lib: add PerformanceObserver API -* Lib: add CSSStyleDeclaration.{setProperty, getPropertyValue, getPropertyPriority, removeProperty} +* Compiler: static evaluation of backend_type (#1166) +* Compiler: speedup emitting js files (#1174) +* Compiler: simplify (a | 0) >>> 0 into (a >>> 0) (#1177) +* Compiler: improve static evaluation of cond (#1178) +* Lib: add messageEvent to Dom_html (#1164) +* Lib: add PerformanceObserver API (#1164) +* Lib: add CSSStyleDeclaration.{setProperty, getPropertyValue, getPropertyPriority, removeProperty} (#1170) ## Bug fixes -* Compiler: fix sourcemap warning for empty cma +* Compiler: fix sourcemap warning for empty cma (#1169) # 3.11.0 (2021-10-06) - Lille diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index ec57aba7d3..5bd421eb0c 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -299,12 +299,39 @@ let the_case_of info x = | Pc (Tuple (j, _, _)) -> CTag j | _ -> Unknown +type cond_of = + | Zero + | Non_zero + | Unknown + +let the_cond_of info x = + get_approx + info + (fun x -> + match info.info_defs.(Var.idx x) with + | Expr (Constant (Int 0l)) -> Zero + | Expr + (Constant + (Int _ | Float _ | Tuple _ | String _ | IString _ | Float_array _ | Int64 _)) + -> + Non_zero + | Expr (Block (_, _, _)) -> Non_zero + | Expr (Field _ | Closure _ | Prim _ | Apply _) -> Unknown + | Param | Phi _ -> Unknown) + Unknown + (fun u v -> + match u, v with + | Zero, Zero -> Zero + | Non_zero, Non_zero -> Non_zero + | _ -> Unknown) + x + let eval_branch info = function | Cond (x, ftrue, ffalse) as b -> ( - match the_int info (Pv x) with - | Some 0l -> Branch ffalse - | Some _ -> Branch ftrue - | _ -> b) + match the_cond_of info x with + | Zero -> Branch ffalse + | Non_zero -> Branch ftrue + | Unknown -> b) | Switch (x, const, tags) as b -> ( (* [the_case_of info (Pv x)] might be meaningless when we're inside a dead code. The proper fix would be to remove the deadcode entirely. diff --git a/compiler/tests-compiler/static_eval.ml b/compiler/tests-compiler/static_eval.ml index 62fac31c4f..26e1c78894 100644 --- a/compiler/tests-compiler/static_eval.ml +++ b/compiler/tests-compiler/static_eval.ml @@ -96,3 +96,57 @@ let%expect_test "static eval of Sys.backend_type" = print_fun_decl program (Some "myfun"); [%expect {| function myfun(param){return 42} |}] + +let%expect_test "static eval of string get" = + let program = + compile_and_parse + {| + + type ('a, 'b) bucketlist = + | Empty + | Cons of { mutable key: 'a; + mutable data: 'b; + mutable next: ('a, 'b) bucketlist } + + let copy_bucketlist = function + | Empty -> Empty + | Cons {key; data; next} -> + let rec loop prec = function + | Empty -> () + | Cons {key; data; next} -> + let r = Cons {key; data; next} in + begin match prec with + | Empty -> assert false + | Cons prec -> prec.next <- r + end; + loop r next + in + let r = Cons {key; data; next} in + loop r next; + r + |} + in + print_fun_decl program (Some "copy_bucketlist"); + [%expect + {| + function copy_bucketlist(param) + {if(param) + {var + key=param[1], + data=param[2], + next=param[3], + prec$0=[0,key,data,next], + prec=prec$0, + param$0=next; + for(;;) + {if(param$0) + {var + key$0=param$0[1], + data$0=param$0[2], + next$0=param$0[3], + r=[0,key$0,data$0,next$0]; + prec[3] = r; + var prec=r,param$0=next$0; + continue} + return prec$0}} + return 0} |}]