Skip to content

Commit

Permalink
remove tuples
Browse files Browse the repository at this point in the history
  • Loading branch information
@zapashcanon
zapashcanon committed Oct 11, 2024
1 parent 24d0e16 commit 4d446c5
Show file tree
Hide file tree
Showing 5 changed files with 41 additions and 321 deletions.
91 changes: 28 additions & 63 deletions wasm/emit_wat.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -84,18 +84,22 @@ module Conv = struct
let function_call_handling handler ~tail call : Expr.t =
if tail then call
else
let var = Local.fresh "call_result" in
let var1 = Local.fresh "call_result1" in
let var2 = Local.fresh "call_result2" in

let body : Expr.t =
If_then_else
{ cond = Unop (Tuple_extract { arity = 2; field = 0 }, Var (V var))
{ cond = Var (V var1)
; if_expr =
NR (raise handler (Unop (Tuple_extract { arity = 2; field = 1 }, Var (V var))))
; else_expr = Unop (Tuple_extract { arity = 2; field = 1 }, Var (V var))
NR (raise handler (Var (V var2)))
; else_expr = Var (V var2)
}
in
Let
{ var
; typ = Type.Tuple [ I32; ref_eq ]
Let2
{ var1
; var2
; typ1 = I32
; typ2 = ref_eq
; defining_expr = call
; body
}
Expand Down Expand Up @@ -2087,8 +2091,6 @@ module ToWasm = struct
Cst.node name [ arg ]
| Abs_float -> Cst.node "f64.abs" [ arg ]
| Neg_float -> Cst.node "f64.neg" [ arg ]
| Tuple_extract { arity; field } ->
C.tuple_extract ~arity ~field arg

let irelop_name nn (op : Expr.irelop) =
match op with
Expand Down Expand Up @@ -2127,6 +2129,11 @@ module ToWasm = struct
| Let { var; typ = _; defining_expr; body } ->
C.local_set (Expr.Local.V var) (conv_expr_group defining_expr)
:: conv_expr body
| Let2 { var1; typ1 = _; var2; typ2 = _; defining_expr; body } ->
C.local_set (Expr.Local.V var1)
(C.local_set (Expr.Local.V var2)
(conv_expr_group defining_expr))
:: conv_expr body
| I32 i -> [ C.i32 i ]
| I64 i -> [ C.i64 i ]
| F64 f -> [ C.f64 f ]
Expand All @@ -2141,18 +2148,11 @@ module ToWasm = struct
| Call_ref { typ; args; func; tail } ->
let args = List.map conv_expr_group args @ [ conv_expr_group func ] in
if tail then [ C.return_call_ref typ args ] else [ C.call_ref typ args ]
| Call { typ; args; func; tail } ->
| Call { typ = _; args; func; tail } ->
let args = List.map conv_expr_group args in
if tail then
(* This should be
{[ [ C.return_call func args ] ]}
But return call is not handled by the gc branch so we play a trick
with return_call_ref
*)
let _ = typ in
(* TODO do something about C calls that does not return exceptions ? *)
[ C.return_call func args ]
(* [ C.return_call_ref typ (args @ [ C.ref_func func ]) ] *)
else [ C.call func args ]
| Ref_cast { typ; r } -> [ C.ref_cast typ [ conv_expr_group r ] ]
| Global_get g -> [ C.global_get g ]
Expand All @@ -2171,45 +2171,16 @@ module ToWasm = struct
C.block cont result_types [ C.br fallthrough [ conv_expr_group body ] ]
in
let handler_expr = conv_expr handler in
(*
match mode with
| Reference ->
let handler =
List.map
(fun (var, _typ) ->
match var with
| Some var -> C.local_set' (Expr.Local.V var)
| None -> C.drop' )
params
@ handler_expr
in
[ C.block fallthrough [ ref_eq ] (body :: handler) ]
| Binarien ->
*)
let set_locals =
match params with
| [] -> [ body ]
| [ (None, _typ) ] -> [ C.drop body ]
| [ (Some var, _typ) ] -> [ C.local_set (Expr.Local.V var) body ]
| _ ->
let arity = List.length params in
let local_tuple = Expr.Local.Block_result cont in
let _i, assigns =
List.fold_left
(fun (i, assigns) (var, _typ) ->
match var with
| Some var ->
let project =
C.tuple_extract ~arity ~field:i (C.local_get (Expr.Local.V local_tuple))
in
let expr = C.local_set (Expr.Local.V var) project in
(i + 1, expr :: assigns)
| None -> (i + 1, assigns) )
(0, []) params
in
[ C.local_set (Expr.Local.V local_tuple) body ] @ assigns
let handler =
List.map
(fun (var, _typ) ->
match var with
| Some var -> C.local_set' (Expr.Local.V var)
| None -> C.drop' )
params
@ handler_expr
in
[ C.block fallthrough [ ref_eq ] (set_locals @ handler_expr) ]
[ C.block fallthrough [ ref_eq ] (body :: handler) ]
end
| Br_on_cast { value; typ; if_cast; if_else } ->
[ C.drop (C.br_on_cast if_cast typ (conv_expr_group value)) ]
Expand Down Expand Up @@ -2406,11 +2377,8 @@ let output_file ~output_prefix ~module_ =
output_wat ppf module_;
Format.fprintf ppf "@\n")

let run ~output_prefix (flambda : Flambda.program) =
let run (flambda : Flambda.program) =
State.reset ();
let print_everything =
match Sys.getenv_opt "WASMPRINT" with None -> false | Some _ -> true
in
let offsets = Wasm_closure_offsets.compute flambda in
let top_env = Conv.{ offsets } in
let m = Conv.conv_body top_env flambda.program_body [] in
Expand All @@ -2425,10 +2393,7 @@ let run ~output_prefix (flambda : Flambda.program) =
in
let functions = Conv.conv_functions ~top_env flambda in
let m = closure_types @ m @ functions in
if print_everything then
Format.printf "WASM %s@.%a@." output_prefix Module.print m;
let common = Conv.make_common () in
if print_everything then Format.printf "COMMON@.%a@." Module.print common;
let wasm =
Profile.record_call "ToWasm" (fun () -> ToWasm.conv_module (common @ m))
in
Expand All @@ -2438,7 +2403,7 @@ let run ~output_prefix (flambda : Flambda.program) =
Wat.{ module_ = wasm }

let emit ~to_file ~output_prefix (flambda : Flambda.program) =
let r = run ~output_prefix flambda in
let r = run flambda in
if to_file then
Profile.record_call "output_wasm" (fun () ->
output_file ~output_prefix ~module_:r.module_ );
Expand Down
2 changes: 0 additions & 2 deletions wasm/wat.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -360,8 +360,6 @@ module C = struct
let opt_tuple fields =
[ tuple_make fields ]

let tuple_extract ~arity ~field tuple = node "tuple.extract" [ int arity; int field; tuple ]

let rec_ l = node "rec" l

let import module_ name e = node "import" [ String (module_name module_); String (Wident.acceptable_string name); e ]
Expand Down
173 changes: 13 additions & 160 deletions wasm/wexpr.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -102,7 +102,6 @@ type unop =
}
| Abs_float
| Neg_float
| Tuple_extract of { field : int; arity : int }

(* Every expression returns exactly one value *)
type t =
Expand All @@ -117,6 +116,14 @@ type t =
; defining_expr : t
; body : t
}
| Let2 of
{ var1 : Local.var
; typ1 : Type.atom
; var2 : Local.var
; typ2 : Type.atom
; defining_expr : t
; body : t
}
| If_then_else of
{ cond : t
; if_expr : t
Expand Down Expand Up @@ -318,165 +325,6 @@ let print_sign ppf = function
| S -> Format.fprintf ppf "s"
| U -> Format.fprintf ppf "u"

let print_unop ppf = function
| I31_get_s -> Format.fprintf ppf "I31_get_s"
| I31_new -> Format.fprintf ppf "I31_new"
| Struct_get { typ; field } ->
Format.fprintf ppf "@[<hov 2>Struct_get(%a).(%i)@]" Type.Var.print typ field
| Struct_get_packed { typ; field; extend } ->
let str = match extend with S -> "_s" | U -> "_u" in
Format.fprintf ppf "@[<hov 2>Struct_get%s(%a).(%i)@]" str Type.Var.print typ
field
| Ref_cast_i31 -> Format.fprintf ppf "Ref_cast_i31"
| Is_i31 -> Format.fprintf ppf "Is_i31"
| Array_len typ ->
Format.fprintf ppf "@[<hov 2>Array_len(%a)@]" Type.Var.print typ
| Reinterpret { from_type; to_type } ->
Format.fprintf ppf "%a.reinterpret_%a" print_num_type to_type print_num_type
from_type
| I32_wrap_i64 -> Format.fprintf ppf "I32_wrap_i64"
| I64_extend_i32 sign ->
Format.fprintf ppf "I64_extend_i32_%a" print_sign sign
| Convert { from_type; to_type; sign } ->
Format.fprintf ppf "f%a.convert_i%a_%a" print_nn to_type print_nn from_type
print_sign sign
| Trunc { from_type; to_type; sign } ->
Format.fprintf ppf "i%a.trunc_i%a_%a" print_nn to_type print_nn from_type
print_sign sign
| Abs_float -> Format.fprintf ppf "Abs_float"
| Neg_float -> Format.fprintf ppf "Neg_float"
| Tuple_extract { arity = _; field = i } ->
Format.fprintf ppf "Tuple_extract.%i" i

let rec print ppf = function
| Var l -> Local.print ppf l
| I32 i -> Format.fprintf ppf "%li" i
| I64 i -> Format.fprintf ppf "%Li" i
| F64 f -> Format.fprintf ppf "%g" f
| Ref_func f -> Format.fprintf ppf "Ref_func %a" Func_id.print f
| Let { var; defining_expr; body } ->
Format.fprintf ppf "@[<hov 2>Let %a =@ %a@]@ in@ %a" Local.print_var var
print defining_expr print body
| I_relop (nn, op, (arg1, arg2)) ->
Format.fprintf ppf "@[<hov 2>I_relop(%a_%a:@ %a,@ %a)@]" print_irelop op
print_nn nn print arg1 print arg2
| F_relop (nn, op, (arg1, arg2)) ->
Format.fprintf ppf "@[<hov 2>F_relop(%a_%a:@ %a,@ %a)@]" print_frelop op
print_nn nn print arg1 print arg2
| Binop (binop, (arg1, arg2)) ->
Format.fprintf ppf "@[<hov 2>Binop(%a:@ %a,@ %a)@]" print_binop binop print
arg1 print arg2
| Unop (unop, arg) ->
Format.fprintf ppf "@[<hov 2>Unop(%a:@ %a)@]" print_unop unop print arg
| Struct_new (typ, args) ->
Format.fprintf ppf "@[<hov 2>Struct_new(%a:@ %a)@]" Type.Var.print typ
(print_list print ",") args
| Array_new_fixed { typ; fields } ->
Format.fprintf ppf "@[<hov 2>Array_new_fixed(%a:@ %a)@]" Type.Var.print typ
(print_list print ",") fields
| Call_ref { typ; args; func } ->
Format.fprintf ppf "@[<hov 2>Call_ref(%a:@ %a(%a))@]" Type.Var.print typ
print func (print_list print ",") args
| Call { args; func } ->
Format.fprintf ppf "@[<hov 2>Call(%a(%a))@]" Func_id.print func
(print_list print ",") args
| Ref_cast { typ; r } ->
Format.fprintf ppf "@[<hov 2>Ref_cast(%a:@ %a)@]" Type.Var.print typ print r
| Global_get g ->
Format.fprintf ppf "@[<hov 2>Global_get(%a)@]" Global.print g
| Seq (effects, last) ->
Format.fprintf ppf "@[<v 2>Seq(%a;%a)@]"
(print_list print_no_value ";")
effects print last
| If_then_else { cond; if_expr; else_expr } ->
Format.fprintf ppf "@[<hov 2>If(%a)@ Then(%a)@ Else(%a)@]" print cond print
if_expr print else_expr
| Let_cont { cont; params; handler; body } ->
Format.fprintf ppf "@[<hov 2>Let_cont %a(%a) =@ %a@]@ in@ %a" Block_id.print
cont
(print_list
(fun ppf (local, typ) ->
Format.fprintf ppf "%a : %a"
(Format.pp_print_option Local.print_var)
local Type.print_atom typ )
", " )
params print handler print body
| Br_on_cast { value; typ; if_cast; if_else } ->
Format.fprintf ppf "@[<hov 2>Br_on_cast(%a %a -> (%a) else %a)@]" print
value Type.Var.print typ Block_id.print if_cast print if_else
| Br_if { cond; if_true; if_else } ->
Format.fprintf ppf "@[<hov 2>Br_if(%a -> (%a) else %a)@]" print cond
Block_id.print if_true print if_else
| Br_table { cond; cases; default } ->
Format.fprintf ppf "@[<hov 2>Br_table(%a -> (%a) %a@]" print cond
(print_list Block_id.print " ")
cases Block_id.print default
| Try { body; param = var, typ; result_typ; handler } ->
Format.fprintf ppf
"@[<v>@[<hov 2>Try -> %a {@ @[<hov 2>%a@ @]}@]@ @[<hov 2>With@ @[<hov \
2>%a : %a@ ->@ @[<hov>%a@]@]@]@]"
Type.print_atom result_typ print body Local.print_var var Type.print_atom
typ print handler
| Unit nv -> Format.fprintf ppf "@[<hov 2>Unit (@ %a@ )@]" print_no_value nv
| NR nr -> print_no_return ppf nr

and print_no_value ppf no_value =
match no_value with
| NV_seq effects ->
Format.fprintf ppf "@[<v 2>Seq(%a)@]"
(print_list print_no_value ";")
effects
| NV_drop e -> Format.fprintf ppf "@[<hov 2>Drop (@ %a@ )@]" print e
| NV_binop (binop, (arg1, arg2)) ->
Format.fprintf ppf "@[<hov 2>Binop(%a:@ %a,@ %a)@]" print_nv_binop binop
print arg1 print arg2
| Assign { being_assigned; new_value } ->
Format.fprintf ppf "@[<v 2>Assign(%a <- %a)@]" Local.print_var
being_assigned print new_value
| Array_set { typ; array; field; value } ->
Format.fprintf ppf "@[<hov 2>Array_set(%a:@ %a.(%a) <- %a)@]" Type.Var.print
typ print array print field print value
| Loop { cont; body } ->
Format.fprintf ppf "@[<hov 2>Loop %a@ %a@]" Block_id.print cont
print_no_value body
| NV -> Format.fprintf ppf "Nil"
| NV_if_then_else { cond; if_expr; else_expr } ->
Format.fprintf ppf "@[<hov 2>If(%a)Then(%a)Else(%a)@]" print cond
print_no_value if_expr print_no_value else_expr
| NV_br_if { cond; if_true } ->
Format.fprintf ppf "@[<hov 2>Br_if(%a -> (%a))@]" print cond Block_id.print
if_true
| NV_call { args; func } ->
Format.fprintf ppf "@[<hov 2>Call(%a(%a))@]" Func_id.print func
(print_list print ",") args

and print_no_return ppf no_return =
match no_return with
| NR_if_then_else { cond; if_expr; else_expr } ->
Format.fprintf ppf "@[<hov 2>If(%a)Then(%a)Else(%a)@]" print cond
print_no_return if_expr print_no_return else_expr
| NR_br_table { cond; cases; default } ->
Format.fprintf ppf "@[<hov 2>Br_table(%a -> (%a) %a@]" print cond
(print_list Block_id.print " ")
cases Block_id.print default
| NR_let_cont { cont; params; handler; body } ->
Format.fprintf ppf "@[<hov 2>Let_cont %a(%a) =@ %a@]@ in@ %a" Block_id.print
cont
(print_list
(fun ppf (local, typ) ->
Format.fprintf ppf "%a : %a"
(Format.pp_print_option Local.print_var)
local Type.print_atom typ )
", " )
params print_no_return handler print_no_return body
| NR_br { cont; args } ->
Format.fprintf ppf "@[<hov 2>Br(%a(%a))@]" Block_id.print cont
(print_list print ",") args
| NR_return args ->
Format.fprintf ppf "@[<hov 2>Return(%a)@]" (print_list print ",") args
| Throw e -> Format.fprintf ppf "@[<hov 2>Throw (@ %a@ )@]" print e
| Unreachable -> Format.fprintf ppf "Unreachable"

let let_ var typ defining_expr body = Let { var; typ; defining_expr; body }

type function_body =
Expand Down Expand Up @@ -513,6 +361,11 @@ let required_locals body =
let acc = add var typ acc in
let acc = loop acc defining_expr in
loop acc body
| Let2 { var1; var2; typ1; typ2; defining_expr; body } ->
let acc = add var1 typ1 acc in
let acc = add var2 typ2 acc in
let acc = loop acc defining_expr in
loop acc body
| I_relop (_, _, (arg1, arg2))
| F_relop (_, _, (arg1, arg2))
| Binop (_, (arg1, arg2)) ->
Expand Down
Loading

0 comments on commit 4d446c5

Please sign in to comment.