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

29
middle_end/closure_conversion.ml
View File

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