Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Integrate changes to Document.constant_equal #71

Merged
merged 4 commits into from
Sep 20, 2024
+305 −142
Merged

Integrate changes to Document.constant_equal #71

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
a40f9a0
Compiler: Document non-trivial function Code.constant_equal, and fix …
OlivierNicole Aug 27, 2024
48b465f
WSOO side of ocsigen/js_of_ocaml#1659
OlivierNicole Sep 3, 2024
68bf91e
Fixes
vouillon Sep 20, 2024
26864d1
Fix constant_identical for Wasm target
OlivierNicole Sep 20, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
142 changes: 73 additions & 69 deletions compiler/lib/code.ml
View file
Open in desktop
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
View file
Open in desktop
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
View file
Open in desktop
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
View file
Open in desktop
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