Skip to content

More precise function type #1908

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

Draft
wants to merge 2 commits into
base: master
Choose a base branch
from
Draft

More precise function type #1908

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
03f41d2
Clean-up regarding function and primitive types
vouillon Mar 31, 2025
622f1a1
More precise environment type
vouillon Mar 28, 2025
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
25 changes: 25 additions & 0 deletions compiler/lib-wasm/code_generation.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -511,6 +511,31 @@ let tee ?typ x e =

let should_make_global x st = Var.Set.mem x st.context.globalized_variables, st

let get_constant x st = Hashtbl.find_opt st.context.constants x, st

let placeholder_value typ f =
let* c = get_constant typ in
match c with
| None ->
let x = Var.fresh () in
let* () = register_constant typ (W.GlobalGet x) in
let* () =
register_global
~constant:true
x
{ mut = false; typ = Ref { nullable = false; typ = Type typ } }
(f typ)
in
return (W.GlobalGet x)
| Some c -> return c

let empty_struct =
let* typ =
register_type "empty_struct" (fun () ->
return { supertype = None; final = true; typ = W.Struct [] })
in
placeholder_value typ (fun typ -> W.StructNew (typ, []))

let value_type st = st.context.value_type, st

let rec store ?(always = false) ?typ x e =
Expand Down
2 changes: 2 additions & 0 deletions compiler/lib-wasm/code_generation.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -203,3 +203,5 @@ val function_body :
-> param_names:Code.Var.t list
-> body:unit t
-> (Wasm_ast.var * Wasm_ast.value_type) list * Wasm_ast.instruction list

val empty_struct : expression
38 changes: 19 additions & 19 deletions compiler/lib-wasm/curry.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -24,11 +24,6 @@ open Code_generation
module Make (Target : Target_sig.S) = struct
open Target

let func_type n =
{ W.params = List.init ~len:(n + 1) ~f:(fun _ -> Value.value)
; result = [ Value.value ]
}

let bind_parameters l =
List.fold_left
~f:(fun l x ->
Expand All @@ -40,7 +35,12 @@ module Make (Target : Target_sig.S) = struct

let call ?typ ~cps ~arity closure args =
let funct = Var.fresh () in
let* closure = tee ?typ funct closure in
let closure = tee ?typ funct closure in
let* closure =
match typ with
| None -> Memory.cast_closure ~cps ~arity closure
| Some _ -> closure
in
let args = args @ [ closure ] in
let* ty, funct =
Memory.load_function_pointer
Expand Down Expand Up @@ -73,7 +73,7 @@ module Make (Target : Target_sig.S) = struct
let body =
let* () = no_event in
let* () = bind_parameters args in
let* _ = add_var f in
let* _ = add_var ~typ:Type.closure f in
let* args' = expression_list load args in
let* _f = load f in
let rec loop m args closure closure_typ =
Expand Down Expand Up @@ -105,7 +105,7 @@ module Make (Target : Target_sig.S) = struct
{ name
; exported_name = None
; typ = None
; signature = func_type 1
; signature = Type.func_type 1
; param_names
; locals
; body
Expand All @@ -131,7 +131,7 @@ module Make (Target : Target_sig.S) = struct
let body =
let* () = no_event in
let* _ = add_var x in
let* _ = add_var f in
let* _ = add_var ~typ:Type.closure f in
push (Closure.curry_allocate ~cps:false ~arity m ~f:name' ~closure:f ~arg:x)
in
let param_names = [ x; f ] in
Expand All @@ -140,7 +140,7 @@ module Make (Target : Target_sig.S) = struct
{ name
; exported_name = None
; typ = None
; signature = func_type 1
; signature = Type.func_type 1
; param_names
; locals
; body
Expand All @@ -159,7 +159,7 @@ module Make (Target : Target_sig.S) = struct
let body =
let* () = no_event in
let* () = bind_parameters args in
let* _ = add_var f in
let* _ = add_var ~typ:Type.closure f in
let* args' = expression_list load args in
let* _f = load f in
let rec loop m args closure closure_typ =
Expand Down Expand Up @@ -191,7 +191,7 @@ module Make (Target : Target_sig.S) = struct
{ name
; exported_name = None
; typ = None
; signature = func_type 2
; signature = Type.func_type 2
; param_names
; locals
; body
Expand Down Expand Up @@ -219,7 +219,7 @@ module Make (Target : Target_sig.S) = struct
let* () = no_event in
let* _ = add_var x in
let* _ = add_var cont in
let* _ = add_var f in
let* _ = add_var ~typ:Type.closure f in
let* e = Closure.curry_allocate ~cps:true ~arity m ~f:name' ~closure:f ~arg:x in
let* c = call ~cps:false ~arity:1 (load cont) [ e ] in
instr (W.Return (Some c))
Expand All @@ -230,7 +230,7 @@ module Make (Target : Target_sig.S) = struct
{ name
; exported_name = None
; typ = None
; signature = func_type 2
; signature = Type.func_type 2
; param_names
; locals
; body
Expand Down Expand Up @@ -274,7 +274,7 @@ module Make (Target : Target_sig.S) = struct
{ name
; exported_name = None
; typ = None
; signature = func_type arity
; signature = Type.primitive_type (arity + 1)
; param_names
; locals
; body
Expand Down Expand Up @@ -306,7 +306,7 @@ module Make (Target : Target_sig.S) = struct
(List.map ~f:(fun x -> `Var x) (List.tl l))
in
let* make_iterator =
register_import ~name:"caml_apply_continuation" (Fun (func_type 0))
register_import ~name:"caml_apply_continuation" (Fun (Type.primitive_type 1))
in
let iterate = Var.fresh_n "iterate" in
let* () = store iterate (return (W.Call (make_iterator, [ args ]))) in
Expand All @@ -321,7 +321,7 @@ module Make (Target : Target_sig.S) = struct
{ name
; exported_name = None
; typ = None
; signature = func_type arity
; signature = Type.primitive_type (arity + 1)
; param_names
; locals
; body
Expand All @@ -337,7 +337,7 @@ module Make (Target : Target_sig.S) = struct
let body =
let* () = no_event in
let* () = bind_parameters l in
let* _ = add_var f in
let* _ = add_var ~typ:Type.closure f in
let* typ, closure = Memory.load_real_closure ~cps ~arity (load f) in
let* l = expression_list load l in
let* e =
Expand All @@ -356,7 +356,7 @@ module Make (Target : Target_sig.S) = struct
{ name
; exported_name = None
; typ = None
; signature = func_type arity
; signature = Type.func_type arity
; param_names
; locals
; body
Expand Down
40 changes: 25 additions & 15 deletions compiler/lib-wasm/gc_target.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -27,6 +27,8 @@ let include_closure_arity = false
module Type = struct
let value = W.Ref { nullable = false; typ = Eq }

let closure = W.Ref { nullable = false; typ = Struct }

let block_type =
register_type "block" (fun () ->
return
Expand Down Expand Up @@ -202,8 +204,11 @@ module Type = struct
]
})

let primitive_type n =
{ W.params = List.init ~len:n ~f:(fun _ -> value); result = [ value ] }

let func_type n =
{ W.params = List.init ~len:(n + 1) ~f:(fun _ -> value); result = [ value ] }
{ W.params = List.init ~len:n ~f:(fun _ -> value) @ [ closure ]; result = [ value ] }

let function_type ~cps n =
let n = if cps then n + 1 else n in
Expand Down Expand Up @@ -423,8 +428,6 @@ module Type = struct
end

module Value = struct
let value = Type.value

let block_type =
let* t = Type.block_type in
return (W.Ref { nullable = false; typ = Type t })
Expand All @@ -433,6 +436,8 @@ module Value = struct
let* t = Type.block_type in
return (W.ArrayNewFixed (t, []))

let dummy_closure = empty_struct

let as_block e =
let* t = Type.block_type in
let* e = e in
Expand Down Expand Up @@ -743,13 +748,13 @@ module Memory = struct
let a = Code.Var.fresh_n "a" in
let i = Code.Var.fresh_n "i" in
block_expr
{ params = []; result = [ Value.value ] }
{ params = []; result = [ Type.value ] }
(let* () = store a e in
let* () = store ~typ:I32 i (Value.int_val e') in
let* () =
drop
(block_expr
{ params = []; result = [ Value.value ] }
{ params = []; result = [ Type.value ] }
(let* block = Type.block_type in
let* a = load a in
let* e =
Expand Down Expand Up @@ -779,7 +784,7 @@ module Memory = struct
(let* () =
drop
(block_expr
{ params = []; result = [ Value.value ] }
{ params = []; result = [ Type.value ] }
(let* block = Type.block_type in
let* a = load a in
let* () =
Expand Down Expand Up @@ -817,6 +822,11 @@ module Memory = struct
then 1
else (if include_closure_arity then 1 else 0) + if arity = 1 then 1 else 2

let cast_closure ~cps ~arity closure =
let arity = if cps then arity - 1 else arity in
let* ty = Type.closure_type ~usage:`Access ~cps arity in
wasm_cast ty closure

let load_function_pointer ~cps ~arity ?(skip_cast = false) closure =
let arity = if cps then arity - 1 else arity in
let* ty = Type.closure_type ~usage:`Access ~cps arity in
Expand All @@ -840,7 +850,7 @@ module Memory = struct
let* () =
drop
(block_expr
{ params = []; result = [ Value.value ] }
{ params = []; result = [ Type.value ] }
(let* e =
if_match
~typ:(Some (W.Ref { nullable = false; typ = Type fun_ty }))
Expand Down Expand Up @@ -1196,7 +1206,7 @@ module Closure = struct
if free_variable_count = 0
then
(* The closures are all constants and the environment is empty. *)
let* _ = add_var (Code.Var.fresh ()) in
let* _ = add_var ~typ:Type.closure (Code.Var.fresh ()) in
return ()
else
let arity = List.assoc f info.functions in
Expand All @@ -1205,7 +1215,7 @@ module Closure = struct
match info.Closure_conversion.functions with
| [ _ ] ->
let* typ = Type.env_type ~cps ~arity free_variable_count in
let* _ = add_var f in
let* _ = add_var ~typ:Type.closure f in
let env = Code.Var.fresh_n "env" in
let* () =
store
Expand All @@ -1226,7 +1236,7 @@ module Closure = struct
let* typ =
Type.rec_closure_type ~cps ~arity ~function_count ~free_variable_count
in
let* _ = add_var f in
let* _ = add_var ~typ:Type.closure f in
let env = Code.Var.fresh_n "env" in
let* env_typ = Type.rec_env_type ~function_count ~free_variable_count in
let* () =
Expand Down Expand Up @@ -1406,7 +1416,7 @@ let internal_primitives =
let arity = List.length args in
(* [Type.func_type] counts one additional argument for the closure environment (absent
here) *)
let* f = register_import ~name (Fun (Type.func_type (arity - 1))) in
let* f = register_import ~name (Fun (Type.primitive_type arity)) in
let args = List.map ~f:transl_prim_arg args in
let* args = expression_list Fun.id args in
return (W.Call (f, args))
Expand Down Expand Up @@ -1675,19 +1685,19 @@ let externref = W.Ref { nullable = true; typ = Extern }

let handle_exceptions ~result_typ ~fall_through ~context body x exn_handler =
let* js_tag = register_import ~name:"javascript_exception" (Tag externref) in
let* ocaml_tag = register_import ~name:"ocaml_exception" (Tag Value.value) in
let* ocaml_tag = register_import ~name:"ocaml_exception" (Tag Type.value) in
let* f =
register_import
~name:"caml_wrap_exception"
(Fun { params = [ externref ]; result = [ Value.value ] })
(Fun { params = [ externref ]; result = [ Type.value ] })
in
block
{ params = []; result = result_typ }
(let* () =
store
x
(block_expr
{ params = []; result = [ Value.value ] }
{ params = []; result = [ Type.value ] }
(let* exn =
block_expr
{ params = []; result = [ externref ] }
Expand All @@ -1698,7 +1708,7 @@ let handle_exceptions ~result_typ ~fall_through ~context body x exn_handler =
~result_typ:[ externref ]
~fall_through:`Skip
~context:(`Skip :: `Skip :: `Catch :: context))
[ ocaml_tag, 1, Value.value; js_tag, 0, externref ]
[ ocaml_tag, 1, Type.value; js_tag, 0, externref ]
in
instr (W.Push e))
in
Expand Down
Loading
Loading