Skip to content

Commit

Permalink
Merge pull request #71 from OlivierNicole/converge-jsoo-merge-07
Browse files Browse the repository at this point in the history
Integrate changes to Document.constant_equal
  • Loading branch information
vouillon authored Sep 20, 2024
2 parents 4174f52 + 26864d1 commit cfc3028
Show file tree
Hide file tree
Showing 15 changed files with 305 additions and 142 deletions.
142 changes: 73 additions & 69 deletions compiler/lib/code.ml
Original file line number Diff line number Diff line change
Expand Up @@ -290,75 +290,79 @@ type constant =
| NativeInt of nativeint
| Tuple of int * constant array * array_or_not

let rec constant_equal a b =
match a, b with
| String a, String b -> Some (String.equal a b)
| NativeString a, NativeString b -> Some (Native_string.equal a b)
| Tuple (ta, a, _), Tuple (tb, b, _) ->
if ta <> tb || Array.length a <> Array.length b
then Some false
else
let same = ref (Some true) in
for i = 0 to Array.length a - 1 do
match !same, constant_equal a.(i) b.(i) with
| None, _ -> ()
| _, None -> same := None
| Some s, Some c -> same := Some (s && c)
done;
!same
| Int a, Int b | Int32 a, Int32 b -> Some (Int32.equal a b)
| Int64 a, Int64 b -> Some (Int64.equal a b)
| NativeInt a, NativeInt b -> Some (Nativeint.equal a b)
| Float_array a, Float_array b -> Some (Array.equal Float.equal a b)
| Float a, Float b -> Some (Float.equal a b)
| String _, NativeString _ | NativeString _, String _ -> None
| Int _, Float _ | Float _, Int _ -> None
| Tuple ((0 | 254), _, _), Float_array _ -> None
| Float_array _, Tuple ((0 | 254), _, _) -> None
| ( Tuple _
, ( String _
| NativeString _
| Int64 _
| Int _
| Int32 _
| NativeInt _
| Float _
| Float_array _ ) ) -> Some false
| ( Float_array _
, ( String _
| NativeString _
| Int64 _
| Int _
| Int32 _
| NativeInt _
| Float _
| Tuple _ ) ) -> Some false
| ( String _
, (Int64 _ | Int _ | Int32 _ | NativeInt _ | Float _ | Tuple _ | Float_array _) ) ->
Some false
| ( NativeString _
, (Int64 _ | Int _ | Int32 _ | NativeInt _ | Float _ | Tuple _ | Float_array _) ) ->
Some false
| ( Int64 _
, ( String _
| NativeString _
| Int _
| Int32 _
| NativeInt _
| Float _
| Tuple _
| Float_array _ ) ) -> Some false
| Float _, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ->
Some false
| ( (Int _ | Int32 _ | NativeInt _)
, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ) ->
Some false
(* Note: the following cases should not occur when compiling to Javascript *)
| Int _, (Int32 _ | NativeInt _)
| Int32 _, (Int _ | NativeInt _)
| NativeInt _, (Int _ | Int32 _)
| (Int32 _ | NativeInt _), Float _
| Float _, (Int32 _ | NativeInt _) -> None
module Constant = struct
type t = constant

let rec ocaml_equal a b =
match a, b with
| String a, String b -> Some (String.equal a b)
| NativeString a, NativeString b -> Some (Native_string.equal a b)
| Tuple (ta, a, _), Tuple (tb, b, _) ->
if ta <> tb || Array.length a <> Array.length b
then Some false
else
let same = ref (Some true) in
for i = 0 to Array.length a - 1 do
match !same, ocaml_equal a.(i) b.(i) with
| None, _ -> ()
| _, None -> same := None
| Some s, Some c -> same := Some (s && c)
done;
!same
| Int a, Int b | Int32 a, Int32 b -> Some (Int32.equal a b)
| Int64 a, Int64 b -> Some (Int64.equal a b)
| NativeInt a, NativeInt b -> Some (Nativeint.equal a b)
| Float_array a, Float_array b -> Some (Array.equal Float.ieee_equal a b)
| Float a, Float b -> Some (Float.ieee_equal a b)
| String _, NativeString _ | NativeString _, String _ -> None
| Int _, Float _ | Float _, Int _ -> None
| Tuple ((0 | 254), _, _), Float_array _ -> None
| Float_array _, Tuple ((0 | 254), _, _) -> None
| ( Tuple _
, ( String _
| NativeString _
| Int64 _
| Int _
| Int32 _
| NativeInt _
| Float _
| Float_array _ ) ) -> Some false
| ( Float_array _
, ( String _
| NativeString _
| Int64 _
| Int _
| Int32 _
| NativeInt _
| Float _
| Tuple _ ) ) -> Some false
| ( String _
, (Int64 _ | Int _ | Int32 _ | NativeInt _ | Float _ | Tuple _ | Float_array _) ) ->
Some false
| ( NativeString _
, (Int64 _ | Int _ | Int32 _ | NativeInt _ | Float _ | Tuple _ | Float_array _) ) ->
Some false
| ( Int64 _
, ( String _
| NativeString _
| Int _
| Int32 _
| NativeInt _
| Float _
| Tuple _
| Float_array _ ) ) -> Some false
| Float _, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ->
Some false
| ( (Int _ | Int32 _ | NativeInt _)
, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ) ->
Some false
(* Note: the following cases should not occur when compiling to Javascript *)
| Int _, (Int32 _ | NativeInt _)
| Int32 _, (Int _ | NativeInt _)
| NativeInt _, (Int _ | Int32 _)
| (Int32 _ | NativeInt _), Float _
| Float _, (Int32 _ | NativeInt _) -> None
end

type loc =
| No
Expand Down
10 changes: 9 additions & 1 deletion compiler/lib/code.mli
Original file line number Diff line number Diff line change
Expand Up @@ -150,6 +150,8 @@ module Native_string : sig
val of_string : string -> t

val of_bytestring : string -> t

val equal : t -> t -> bool
end

type int_kind =
Expand All @@ -168,7 +170,13 @@ type constant =
| NativeInt of nativeint (** Only produced when compiling to WebAssembly. *)
| Tuple of int * constant array * array_or_not

val constant_equal : constant -> constant -> bool option
module Constant : sig
type t = constant

val ocaml_equal : t -> t -> bool option
(** Guaranteed equality in terms of OCaml [(=)]: if [constant_equal a b =
Some v], then [Poly.(=) a b = v]. This is used for optimization purposes. *)
end

type loc =
| No
Expand Down
30 changes: 17 additions & 13 deletions compiler/lib/driver.ml
Original file line number Diff line number Diff line change
Expand Up @@ -241,9 +241,9 @@ let gen_missing js missing =
, ( ECond
( EBin
( NotEqEq
, dot (EVar (ident Constant.global_object_)) prim
, dot (EVar (ident Global_constant.global_object_)) prim
, EVar (ident_s "undefined") )
, dot (EVar (ident Constant.global_object_)) prim
, dot (EVar (ident Global_constant.global_object_)) prim
, EFun
( None
, fun_
Expand Down Expand Up @@ -364,7 +364,7 @@ let link' ~export_runtime ~standalone ~link (js : Javascript.statement_list) :
(EBin
( Eq
, dot
(EVar (ident Constant.global_object_))
(EVar (ident Global_constant.global_object_))
(Utf8_string.of_string_exn "jsoo_runtime")
, EObj all ))
, N )
Expand All @@ -375,7 +375,7 @@ let link' ~export_runtime ~standalone ~link (js : Javascript.statement_list) :
(EVar (ident (Utf8_string.of_string_exn "Object")))
(Utf8_string.of_string_exn "assign"))
[ dot
(EVar (ident Constant.global_object_))
(EVar (ident Global_constant.global_object_))
(Utf8_string.of_string_exn "jsoo_runtime")
; EObj all
]
Expand Down Expand Up @@ -404,7 +404,7 @@ let link' ~export_runtime ~standalone ~link (js : Javascript.statement_list) :
; rest = None
}
, ( dot
(EVar (ident Constant.global_object_))
(EVar (ident Global_constant.global_object_))
(Utf8_string.of_string_exn "jsoo_runtime")
, N ) )
] )
Expand Down Expand Up @@ -510,27 +510,30 @@ let pack ~wrap_with_fun ~standalone { Linker.runtime_code = js; always_required_
o#get_free
in
let export_shim js =
if J.IdentSet.mem (J.ident Constant.exports_) freenames
if J.IdentSet.mem (J.ident Global_constant.exports_) freenames
then
if should_export wrap_with_fun
then var Constant.exports_ (J.EObj []) :: js
then var Global_constant.exports_ (J.EObj []) :: js
else
let export_node =
let s =
Printf.sprintf
{|((typeof module === 'object' && module.exports) || %s)|}
Constant.global_object
Global_constant.global_object
in
let lex = Parse_js.Lexer.of_string s in
Parse_js.parse_expr lex
in
var Constant.exports_ export_node :: js
var Global_constant.exports_ export_node :: js
else js
in
let old_global_object_shim js =
if J.IdentSet.mem (J.ident Constant.old_global_object_) freenames
if J.IdentSet.mem (J.ident Global_constant.old_global_object_) freenames
then
var Constant.old_global_object_ (J.EVar (J.ident Constant.global_object_)) :: js
var
Global_constant.old_global_object_
(J.EVar (J.ident Global_constant.global_object_))
:: js
else js
in

Expand All @@ -544,14 +547,15 @@ let pack ~wrap_with_fun ~standalone { Linker.runtime_code = js; always_required_
then expr (J.EStr (Utf8_string.of_string_exn "use strict")) :: js
else js
in
f [ J.ident Constant.global_object_ ] js
f [ J.ident Global_constant.global_object_ ] js
in
match wrap_with_fun with
| `Anonymous -> expr (mk efun)
| `Named name ->
let name = Utf8_string.of_string_exn name in
mk (sfun (J.ident name))
| `Iife -> expr (J.call (mk efun) [ J.EVar (J.ident Constant.global_object_) ] J.N)
| `Iife ->
expr (J.call (mk efun) [ J.EVar (J.ident Global_constant.global_object_) ] J.N)
in
let always_required_js =
(* consider adding a comments in the generated file with original
Expand Down
69 changes: 54 additions & 15 deletions compiler/lib/eval.ml
Original file line number Diff line number Diff line change
Expand Up @@ -65,14 +65,15 @@ let float_unop (l : constant list) (f : float -> float) : constant option =
| [ Int i ] -> Some (Float (f (Int32.to_float i)))
| _ -> None

let bool' b = Int (if b then 1l else 0l)

let bool b = Some (bool' b)

let float_binop_bool l f =
match float_binop_aux l f with
| Some true -> Some (Int 1l)
| Some false -> Some (Int 0l)
| Some b -> bool b
| None -> None

let bool b = Some (Int (if b then 1l else 0l))

let eval_prim ~target x =
match x with
| Not, [ Int i ] -> bool Int32.(i = 0l)
Expand Down Expand Up @@ -165,14 +166,14 @@ let eval_prim ~target x =
| _ -> None)
| _ -> None

let the_length_of info x =
let the_length_of ~target info x =
get_approx
info
(fun x ->
match info.info_defs.(Var.idx x) with
| Expr (Constant (String s)) -> Some (Int32.of_int (String.length s))
| Expr (Prim (Extern "caml_create_string", [ arg ]))
| Expr (Prim (Extern "caml_create_bytes", [ arg ])) -> the_int info arg
| Expr (Prim (Extern "caml_create_bytes", [ arg ])) -> the_int ~target info arg
| _ -> None)
None
(fun u v ->
Expand Down Expand Up @@ -254,24 +255,63 @@ let the_cont_of info x (a : cont array) =
| _ -> None)
x

(* If [constant_js_equal a b = Some v], then [caml_js_equals a b = v]). *)
let constant_js_equal a b =
match a, b with
| Int i, Int j -> Some (Int32.equal i j)
| Float a, Float b -> Some (Float.ieee_equal a b)
| NativeString a, NativeString b -> Some (Native_string.equal a b)
| String a, String b when Config.Flag.use_js_string () -> Some (String.equal a b)
| Int _, Float _ | Float _, Int _ -> None
(* All other values may be distinct objects and thus different by [caml_js_equals]. *)
| String _, _
| _, String _
| NativeString _, _
| _, NativeString _
| Float_array _, _
| _, Float_array _
| Int64 _, _
| _, Int64 _
| Int32 _, _
| _, Int32 _
| NativeInt _, _
| _, NativeInt _
| Tuple _, _
| _, Tuple _ -> None

let eval_instr ~target info ((x, loc) as i) =
match x with
| Let (x, Prim (Extern ("caml_js_equals" | "caml_equal"), [ y; z ])) -> (
match the_const_of info y, the_const_of info z with
| Let (x, Prim (Extern (("caml_equal" | "caml_notequal") as prim), [ y; z ])) -> (
match the_const_of ~target info y, the_const_of ~target info z with
| Some e1, Some e2 -> (
match Code.Constant.ocaml_equal e1 e2 with
| None -> [ i ]
| Some c ->
let c =
match prim with
| "caml_equal" -> c
| "caml_notequal" -> not c
| _ -> assert false
in
let c = Constant (bool' c) in
Flow.update_def info x c;
[ Let (x, c), loc ])
| _ -> [ i ])
| Let (x, Prim (Extern ("caml_js_equals" | "caml_js_strict_equals"), [ y; z ])) -> (
match the_const_of ~target info y, the_const_of ~target info z with
| Some e1, Some e2 -> (
match constant_equal e1 e2 with
match constant_js_equal e1 e2 with
| None -> [ i ]
| Some c ->
let c = if c then 1l else 0l in
let c = Constant (Int c) in
let c = Constant (bool' c) in
Flow.update_def info x c;
[ Let (x, c), loc ])
| _ -> [ i ])
| Let (x, Prim (Extern "caml_ml_string_length", [ s ])) -> (
let c =
match s with
| Pc (String s) -> Some (Int32.of_int (String.length s))
| Pv v -> the_length_of info v
| Pv v -> the_length_of ~target info v
| _ -> None
in
match c with
Expand Down Expand Up @@ -299,8 +339,7 @@ let eval_instr ~target info ((x, loc) as i) =
match is_int ~target info y with
| Unknown -> [ i ]
| (Y | N) as b ->
let b = if Poly.(b = N) then 0l else 1l in
let c = Constant (Int b) in
let c = Constant (bool' Poly.(b = Y)) in
Flow.update_def info x c;
[ Let (x, c), loc ])
| Let (x, Prim (Extern "%direct_obj_tag", [ y ])) -> (
Expand All @@ -325,7 +364,7 @@ let eval_instr ~target info ((x, loc) as i) =
| Let (_, Prim (Extern ("%resume" | "%perform" | "%reperform"), _)) ->
[ i ] (* We need that the arguments to this primitives remain variables *)
| Let (x, Prim (prim, prim_args)) -> (
let prim_args' = List.map prim_args ~f:(fun x -> the_const_of info x) in
let prim_args' = List.map prim_args ~f:(fun x -> the_const_of ~target info x) in
let res =
if List.for_all prim_args' ~f:(function
| Some _ -> true
Expand Down
Loading

0 comments on commit cfc3028

Please sign in to comment.