Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Flambda produces the same stack traces as closure

master
Pierre Chambart 2016-01-28 17:33:15 +01:00
parent fd8cdc9d20
commit cdd75a23e6
1 changed files with 23 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
middle_end/closure_conversion.ml
View File

@ -118,6 +118,11 @@ let rec eliminate_const_block (const : Lambda.structured_constant)
| Const_immstring _
| Const_float_array _ -> Lconst const
let default_debuginfo ?(inner_debuginfo = Debuginfo.none) env_debuginfo =
match env_debuginfo with
| None -> inner_debuginfo
| Some debuginfo -> debuginfo
let rec close_const t env (const : Lambda.structured_constant)
: Flambda.named * string =
match const with
@ -138,7 +143,7 @@ let rec close_const t env (const : Lambda.structured_constant)
| Const_block _ ->
Expr (close t env (eliminate_const_block const)), "const_block"
and close t ?(debuginfo=Debuginfo.none) env (lam : Lambda.lambda) : Flambda.t =
and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
match lam with
| Lvar id ->
begin match Env.find_var_exn env id with
@ -208,7 +213,10 @@ and close t ?(debuginfo=Debuginfo.none) env (lam : Lambda.lambda) : Flambda.t =
func = func_var;
args;
kind = Indirect;
dbg = Debuginfo.from_location Dinfo_call ap_loc;
dbg =
default_debuginfo
~inner_debuginfo:(Debuginfo.from_location Dinfo_call ap_loc)
debuginfo;
inline = ap_inlined;
})))
| Lletrec (defs, body) ->
@ -322,7 +330,7 @@ and close t ?(debuginfo=Debuginfo.none) env (lam : Lambda.lambda) : Flambda.t =
(Prim (Pintcomp Ceq, [zero; denominator], Debuginfo.none))
(If_then_else (is_zero,
name_expr (Prim (Praise Raise_regular, [exn],
debuginfo))
default_debuginfo debuginfo))
~name:"dummy",
(* CR-someday pchambart: find the right event.
mshinwell: I briefly looked at this, and couldn't
@ -369,12 +377,14 @@ and close t ?(debuginfo=Debuginfo.none) env (lam : Lambda.lambda) : Flambda.t =
ap_inlined = Default_inline;
}
in
close t env ~debuginfo (Lambda.Lapply apply)
close t env ?debuginfo (Lambda.Lapply apply)
| Lprim (Praise kind, [Levent (arg, event)]) ->
let arg_var = Variable.create "raise_arg" in
Flambda.create_let arg_var (Expr (close t env arg))
(name_expr
(Prim (Praise kind, [arg_var], Debuginfo.from_raise event))
(Prim (Praise kind, [arg_var],
default_debuginfo ~inner_debuginfo:(Debuginfo.from_raise event)
debuginfo))
~name:"raise")
| Lprim (Pfield _, [Lprim (Pgetglobal id, [])])
when Ident.same id t.current_unit_id ->
@ -404,7 +414,7 @@ and close t ?(debuginfo=Debuginfo.none) env (lam : Lambda.lambda) : Flambda.t =
~evaluation_order:`Right_to_left
~name:(name ^ "_arg")
~create_body:(fun args ->
name_expr (Prim (p, args, debuginfo)) ~name)
name_expr (Prim (p, args, default_debuginfo debuginfo)) ~name)
| Lswitch (arg, sw) ->
let scrutinee = Variable.create "switch" in
let aux (i, lam) = i, close t env lam in
@ -470,8 +480,13 @@ and close t ?(debuginfo=Debuginfo.none) env (lam : Lambda.lambda) : Flambda.t =
let new_value_var = Variable.create "new_value" in
Flambda.create_let new_value_var (Expr (close t env new_value))
(Assign { being_assigned; new_value = new_value_var; })
| Levent (lam, ev) ->
close t env ~debuginfo:(Debuginfo.from_call ev) lam
| Levent (lam, ev) -> begin
match ev.lev_kind with
| Lev_after _ ->
close t env ~debuginfo:(Debuginfo.from_call ev) lam
| _ ->
close t env lam
end
| Lifused _ ->
(* [Lifused] is used to mark that this expression should be alive only if
an identifier is. Every use should have been removed by