Skip to content

Instantly share code, notes, and snippets.

@samoht

samoht/loc-lambda.diff

Created November 12, 2012 13:38
Show Gist options
  • Save samoht/4059441 to your computer and use it in GitHub Desktop.
Save samoht/4059441 to your computer and use it in GitHub Desktop.
Download ZIP
Location in lambda IR
Raw
loc-lambda.diff
commit 7c0725871e7dddf8fa9b3000405199cfe96886c3
Author: Thomas Gazagnaire <thomas@gazagnaire.org>
Date: Sun Dec 4 22:53:34 2011 +0100
Add location in lambda code
This is a very preliminary patch as there is just enough change to make everything compile, but location are not propagated through the backend.
Also the Levent are still there.
diff --git a/Makefile b/Makefile
index 46291ac..42e82ab 100644
--- a/Makefile
+++ b/Makefile
@@ -17,7 +17,10 @@
include config/Makefile
include stdlib/StdlibModules
-CAMLC=boot/ocamlrun boot/ocamlc -nostdlib -I boot
+CAMLC=boot/ocamlrun boot/ocamlc -nostdlib -I boot -annot
+#CAMLC= ocp-wrapper -save-types -save-last-compiled \
+ boot/ocamlrun boot/ocamlc \
+ -nostdlib -I boot -annot
CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib -I otherlibs/dynlink
COMPFLAGS=-strict-sequence -warn-error A $(INCLUDES)
LINKFLAGS=
diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml
index 9bcb36f..f11202b 100644
--- a/asmcomp/clambda.ml
+++ b/asmcomp/clambda.ml
@@ -20,17 +20,22 @@ open Lambda
type function_label = string
-type ulambda =
+and ulambda = {
+ u_desc : ulambda_desc;
+ u_debug : Debuginfo.t;
+}
+
+type ulambda_desc =
Uvar of Ident.t
| Uconst of structured_constant * string option
- | Udirect_apply of function_label * ulambda list * Debuginfo.t
- | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t
+ | Udirect_apply of function_label * ulambda list
+ | Ugeneric_apply of ulambda * ulambda list
| Uclosure of (function_label * int * Ident.t list * ulambda) list
* ulambda list
| Uoffset of ulambda * int
| Ulet of Ident.t * ulambda * ulambda
| Uletrec of (Ident.t * ulambda) list * ulambda
- | Uprim of primitive * ulambda list * Debuginfo.t
+ | Uprim of primitive * ulambda list
| Uswitch of ulambda * ulambda_switch
| Ustaticfail of int * ulambda list
| Ucatch of int * Ident.t list * ulambda * ulambda
@@ -40,7 +45,7 @@ type ulambda =
| Uwhile of ulambda * ulambda
| Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda
| Uassign of Ident.t * ulambda
- | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t
+ | Usend of meth_kind * ulambda * ulambda * ulambda list
and ulambda_switch =
{ us_index_consts: int array;
diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli
index 72ab857..13d734d 100644
--- a/asmcomp/clambda.mli
+++ b/asmcomp/clambda.mli
@@ -20,17 +20,22 @@ open Lambda
type function_label = string
-type ulambda =
+type ulambda = {
+ u_desc : ulambda_desc;
+ u_debug : Debuginfo.t;
+}
+
+and ulambda_desc =
Uvar of Ident.t
| Uconst of structured_constant * string option
- | Udirect_apply of function_label * ulambda list * Debuginfo.t
- | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t
+ | Udirect_apply of function_label * ulambda list
+ | Ugeneric_apply of ulambda * ulambda list
| Uclosure of (function_label * int * Ident.t list * ulambda) list
* ulambda list
| Uoffset of ulambda * int
| Ulet of Ident.t * ulambda * ulambda
| Uletrec of (Ident.t * ulambda) list * ulambda
- | Uprim of primitive * ulambda list * Debuginfo.t
+ | Uprim of primitive * ulambda list
| Uswitch of ulambda * ulambda_switch
| Ustaticfail of int * ulambda list
| Ucatch of int * Ident.t list * ulambda * ulambda
@@ -40,7 +45,7 @@ type ulambda =
| Uwhile of ulambda * ulambda
| Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda
| Uassign of Ident.t * ulambda
- | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t
+ | Usend of meth_kind * ulambda * ulambda * ulambda list
and ulambda_switch =
{ us_index_consts: int array;
diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml
index f37908f..5bc7049 100644
--- a/asmcomp/closure.ml
+++ b/asmcomp/closure.ml
@@ -33,7 +33,7 @@ let rec split_list n l =
let rec build_closure_env env_param pos = function
[] -> Tbl.empty
| id :: rem ->
- Tbl.add id (Uprim(Pfield pos, [Uvar env_param], Debuginfo.none))
+ Tbl.add id (Uprim(Pfield pos, [Uvar env_param]))
(build_closure_env env_param (pos+1) rem)
(* Auxiliary for accessing globals. We change the name of the global
@@ -43,7 +43,7 @@ let rec build_closure_env env_param pos = function
let getglobal id =
Uprim(Pgetglobal (Ident.create_persistent (Compilenv.symbol_for_global id)),
- [], Debuginfo.none)
+ [])
(* Check if a variable occurs in a [clambda] term. *)
diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
index 9773f0b..8d33177 100644
--- a/bytecomp/bytegen.ml
+++ b/bytecomp/bytegen.ml
@@ -133,17 +133,17 @@ type rhs_kind =
;;
let rec check_recordwith_updates id e =
- match e with
- | Lsequence (Lprim ((Psetfield _ | Psetfloatfield _), [Lvar id2; _]), cont)
+ match e.l_desc with
+ | Lsequence ({l_desc=Lprim ((Psetfield _ | Psetfloatfield _), [{l_desc=Lvar id2}; _])}, cont)
-> id2 = id && check_recordwith_updates id cont
| Lvar id2 -> id2 = id
| _ -> false
;;
-let rec size_of_lambda = function
- | Lfunction(kind, params, body) as funct ->
- RHS_block (1 + IdentSet.cardinal(free_variables funct))
- | Llet (Strict, id, Lprim (Pduprecord (kind, size), _), body)
+let rec size_of_lambda lam = match lam.l_desc with
+ | Lfunction(kind, params, body) ->
+ RHS_block (1 + IdentSet.cardinal(free_variables lam))
+ | Llet (Strict, id, {l_desc=Lprim (Pduprecord (kind, size), _)}, body)
when check_recordwith_updates id body ->
begin match kind with
| Record_regular -> RHS_block size
@@ -247,7 +247,7 @@ let find_raise_label i =
("exit("^string_of_int i^") outside appropriated catch")
(* Will the translation of l lead to a jump to label ? *)
-let code_as_jump l sz = match l with
+let code_as_jump l sz = match l.l_desc with
| Lstaticraise (i,[]) ->
let label,size = find_raise_label i in
if sz = size then
@@ -391,7 +391,7 @@ let is_immed n = immed_min <= n && n <= immed_max
let rec comp_expr env exp sz cont =
if sz > !max_stack_used then max_stack_used := sz;
- match exp with
+ match exp.l_desc with
Lvar id ->
begin try
let pos = Ident.find_same id env.ce_stack in
@@ -410,7 +410,7 @@ let rec comp_expr env exp sz cont =
end
| Lconst cst ->
Kconst cst :: cont
- | Lapply(func, args, loc) ->
+ | Lapply(func, args) ->
let nargs = List.length args in
if is_tailcall cont then begin
comp_args env args sz
@@ -428,12 +428,12 @@ let rec comp_expr env exp sz cont =
(Kapply nargs :: cont1))
end
end
- | Lsend(kind, met, obj, args, _) ->
+ | Lsend(kind, met, obj, args) ->
let args = if kind = Cached then List.tl args else args in
let nargs = List.length args + 1 in
let getmethod, args' =
if kind = Self then (Kgetmethod, met::obj::args) else
- match met with
+ match met.l_desc with
Lconst(Const_base(Const_int n)) -> (Kgetpubmet n, obj::args)
| _ -> (Kgetdynmet, met::obj::args)
in
@@ -457,7 +457,7 @@ let rec comp_expr env exp sz cont =
{ params = params; body = body; label = lbl;
free_vars = fv; num_defs = 1; rec_vars = []; rec_pos = 0 } in
Stack.push to_compile functions_to_compile;
- comp_args env (List.map (fun n -> Lvar n) fv) sz
+ comp_args env (List.map (fun n -> mk_lam (Lvar n)) fv) sz
(Kclosure(lbl, List.length fv) :: cont)
| Llet(str, id, arg, body) ->
comp_expr env arg sz
@@ -465,15 +465,15 @@ let rec comp_expr env exp sz cont =
(add_pop 1 cont))
| Lletrec(decl, body) ->
let ndecl = List.length decl in
- if List.for_all (function (_, Lfunction(_,_,_)) -> true | _ -> false)
+ if List.for_all (function (_, {l_desc=Lfunction(_,_,_)}) -> true | _ -> false)
decl then begin
(* let rec of functions *)
let fv =
- IdentSet.elements (free_variables (Lletrec(decl, lambda_unit))) in
+ IdentSet.elements (free_variables (mk_loc_lam exp.l_loc (Lletrec(decl, lambda_unit)))) in
let rec_idents = List.map (fun (id, lam) -> id) decl in
let rec comp_fun pos = function
[] -> []
- | (id, Lfunction(kind, params, body)) :: rem ->
+ | (id, {l_desc=Lfunction(kind, params, body)}) :: rem ->
let lbl = new_label() in
let to_compile =
{ params = params; body = body; label = lbl; free_vars = fv;
@@ -482,7 +482,7 @@ let rec comp_expr env exp sz cont =
lbl :: comp_fun (pos + 1) rem
| _ -> assert false in
let lbls = comp_fun 0 decl in
- comp_args env (List.map (fun n -> Lvar n) fv) sz
+ comp_args env (List.map (fun n -> mk_lam (Lvar n)) fv) sz
(Kclosurerec(lbls, List.length fv) ::
(comp_expr (add_vars rec_idents (sz+1) env) body (sz + ndecl)
(add_pop ndecl cont)))
@@ -561,10 +561,10 @@ let rec comp_expr env exp sz cont =
end
| Lprim(Praise, [arg]) ->
comp_expr env arg sz (Kraise :: discard_dead_code cont)
- | Lprim(Paddint, [arg; Lconst(Const_base(Const_int n))])
+ | Lprim(Paddint, [arg; {l_desc=Lconst(Const_base(Const_int n))}])
when is_immed n ->
comp_expr env arg sz (Koffsetint n :: cont)
- | Lprim(Psubint, [arg; Lconst(Const_base(Const_int n))])
+ | Lprim(Psubint, [arg; {l_desc=Lconst(Const_base(Const_int n))}])
when is_immed (-n) ->
comp_expr env arg sz (Koffsetint (-n) :: cont)
| Lprim (Poffsetint n, [arg])
@@ -587,7 +587,7 @@ let rec comp_expr env exp sz cont =
Kccall("caml_make_array", 1) :: cont)
end
(* Integer first for enabling futher optimization (cf. emitcode.ml) *)
- | Lprim (Pintcomp c, [arg ; (Lconst _ as k)]) ->
+ | Lprim (Pintcomp c, [arg ; ({l_desc=Lconst _} as k)]) ->
let p = Pintcomp (commute_comparison c)
and args = [k ; arg] in
comp_args env args sz (comp_primitive p args :: cont)
@@ -743,10 +743,10 @@ let rec comp_expr env exp sz cont =
comp_expr env lam sz cont
| Lev_after ty ->
let info =
- match lam with
- Lapply(_, args, _) -> Event_return (List.length args)
- | Lsend(_, _, _, args, _) -> Event_return (List.length args + 1)
- | _ -> Event_other
+ match lam.l_desc with
+ Lapply(_, args) -> Event_return (List.length args)
+ | Lsend(_, _, _, args) -> Event_return (List.length args + 1)
+ | _ -> Event_other
in
let ev = event (Event_after ty) info in
let cont1 = add_event ev cont in
@@ -781,7 +781,7 @@ and comp_expr_list_assign env exprl sz pos cont = match exprl with
and comp_binary_test env cond ifso ifnot sz cont =
let cont_cond =
- if ifnot = Lconst const_unit then begin
+ if ifnot = mk_lam (Lconst const_unit) then begin
let (lbl_end, cont1) = label_code cont in
Kstrictbranchifnot lbl_end :: comp_expr env ifso sz cont1
end else
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index b1e6f16..edb058f 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -123,10 +123,15 @@ type meth_kind = Self | Public | Cached
type shared_code = (int * int) list
-type lambda =
- Lvar of Ident.t
+type lambda = {
+ l_desc : lambda_desc;
+ l_loc : Location.t;
+}
+
+and lambda_desc =
+ | Lvar of Ident.t
| Lconst of structured_constant
- | Lapply of lambda * lambda list * Location.t
+ | Lapply of lambda * lambda list
| Lfunction of function_kind * Ident.t list * lambda
| Llet of let_kind * Ident.t * lambda * lambda
| Lletrec of (Ident.t * lambda) list * lambda
@@ -140,7 +145,7 @@ type lambda =
| Lwhile of lambda * lambda
| Lfor of Ident.t * lambda * lambda * direction_flag * lambda
| Lassign of Ident.t * lambda
- | Lsend of meth_kind * lambda * lambda * lambda list * Location.t
+ | Lsend of meth_kind * lambda * lambda * lambda list
| Levent of lambda * lambda_event
| Lifused of Ident.t * lambda
@@ -151,28 +156,35 @@ and lambda_switch =
sw_blocks: (int * lambda) list;
sw_failaction : lambda option}
-and lambda_event =
- { lev_loc: Location.t;
- lev_kind: lambda_event_kind;
- lev_repr: int ref option;
- lev_env: Env.summary }
+and lambda_event = {
+ lev_loc: Location.t;
+ lev_kind: lambda_event_kind;
+ lev_repr: int ref option;
+ lev_env: Env.summary;
+}
and lambda_event_kind =
Lev_before
| Lev_after of Types.type_expr
| Lev_function
+let mk_lam l_desc =
+ { l_loc = Location.none; l_desc }
+
+let mk_loc_lam l_loc l_desc =
+ { l_loc; l_desc }
+
let const_unit = Const_pointer 0
-let lambda_unit = Lconst const_unit
+let lambda_unit = mk_lam (Lconst const_unit)
let rec same l1 l2 =
- match (l1, l2) with
+ match l1.l_desc, l2.l_desc with
| Lvar v1, Lvar v2 ->
Ident.same v1 v2
| Lconst c1, Lconst c2 ->
c1 = c2
- | Lapply(a1, bl1, _), Lapply(a2, bl2, _) ->
+ | Lapply(a1, bl1), Lapply(a2, bl2) ->
same a1 a2 && samelist same bl1 bl2
| Lfunction(k1, idl1, a1), Lfunction(k2, idl2, a2) ->
k1 = k2 && samelist Ident.same idl1 idl2 && same a1 a2
@@ -201,7 +213,7 @@ let rec same l1 l2 =
same b1 b2 && df1 = df2 && same c1 c2
| Lassign(id1, a1), Lassign(id2, a2) ->
Ident.same id1 id2 && same a1 a2
- | Lsend(k1, a1, b1, cl1, _), Lsend(k2, a2, b2, cl2, _) ->
+ | Lsend(k1, a1, b1, cl1), Lsend(k2, a2, b2, cl2) ->
k1 = k2 && same a1 a2 && same b1 b2 && samelist same cl1 cl2
| Levent(a1, ev1), Levent(a2, ev2) ->
same a1 a2 && ev1.lev_loc = ev2.lev_loc
@@ -224,25 +236,16 @@ and sameswitch sw1 sw2 =
| (Some a1, Some a2) -> same a1 a2
| _ -> false)
-let name_lambda arg fn =
- match arg with
- Lvar id -> fn id
- | _ -> let id = Ident.create "let" in Llet(Strict, id, arg, fn id)
-
-let name_lambda_list args fn =
- let rec name_list names = function
- [] -> fn (List.rev names)
- | (Lvar id as arg) :: rem ->
- name_list (arg :: names) rem
- | arg :: rem ->
- let id = Ident.create "let" in
- Llet(Strict, id, arg, name_list (Lvar id :: names) rem) in
- name_list [] args
-
-let rec iter f = function
- Lvar _
+let name_lambda arg fn = match arg.l_desc with
+ | Lvar id -> fn id
+ | _ ->
+ let id = Ident.create "let" in
+ mk_loc_lam arg.l_loc (Llet(Strict, id, arg, fn id))
+
+let rec iter f l = match l.l_desc with
+ | Lvar _
| Lconst _ -> ()
- | Lapply(fn, args, _) ->
+ | Lapply(fn, args) ->
f fn; List.iter f args
| Lfunction(kind, params, body) ->
f body
@@ -277,7 +280,7 @@ let rec iter f = function
f e1; f e2; f e3
| Lassign(id, e) ->
f e
- | Lsend (k, met, obj, args, _) ->
+ | Lsend (k, met, obj, args) ->
List.iter f (met::obj::args)
| Levent (lam, evt) ->
f lam
@@ -294,8 +297,8 @@ let free_ids get l =
let fv = ref IdentSet.empty in
let rec free l =
iter free l;
- fv := List.fold_right IdentSet.add (get l) !fv;
- match l with
+ fv := List.fold_right IdentSet.add (get l.l_desc) !fv;
+ match l.l_desc with
Lfunction(kind, params, body) ->
List.iter (fun param -> fv := IdentSet.remove param !fv) params
| Llet(str, id, arg, body) ->
@@ -320,7 +323,7 @@ let free_variables l =
free_ids (function Lvar id -> [id] | _ -> []) l
let free_methods l =
- free_ids (function Lsend(Self, Lvar meth, obj, _, _) -> [meth] | _ -> []) l
+ free_ids (function Lsend(Self, {l_desc=Lvar meth}, obj, _) -> [meth] | _ -> []) l
(* Check if an action has a "when" guard *)
let raise_count = ref 0
@@ -330,30 +333,34 @@ let next_raise_count () =
!raise_count
(* Anticipated staticraise, for guards *)
-let staticfail = Lstaticraise (0,[])
+let staticfail =
+ mk_lam (Lstaticraise (0,[]))
-let rec is_guarded = function
- | Lifthenelse( cond, body, Lstaticraise (0,[])) -> true
+let rec is_guarded l = match l.l_desc with
+ | Lifthenelse( cond, body, {l_desc=Lstaticraise (0,[])}) -> true
| Llet(str, id, lam, body) -> is_guarded body
| Levent(lam, ev) -> is_guarded lam
| _ -> false
-let rec patch_guarded patch = function
- | Lifthenelse (cond, body, Lstaticraise (0,[])) ->
- Lifthenelse (cond, body, patch)
+let rec patch_guarded patch l = match l.l_desc with
+ | Lifthenelse (cond, body, {l_desc=Lstaticraise (0,[])}) ->
+ mk_loc_lam l.l_loc (Lifthenelse (cond, body, patch))
| Llet(str, id, lam, body) ->
- Llet (str, id, lam, patch_guarded patch body)
+ mk_loc_lam l.l_loc (Llet (str, id, lam, patch_guarded patch body))
| Levent(lam, ev) ->
- Levent (patch_guarded patch lam, ev)
+ mk_loc_lam l.l_loc (Levent (patch_guarded patch lam, ev))
| _ -> fatal_error "Lambda.patch_guarded"
(* Translate an access path *)
let rec transl_path = function
Pident id ->
- if Ident.global id then Lprim(Pgetglobal id, []) else Lvar id
+ if Ident.global id then
+ mk_lam (Lprim(Pgetglobal id, []))
+ else
+ mk_lam (Lvar id)
| Pdot(p, s, pos) ->
- Lprim(Pfield pos, [transl_path p])
+ mk_lam (Lprim(Pfield pos, [transl_path p]))
| Papply(p1, p2) ->
fatal_error "Lambda.transl_path"
@@ -363,7 +370,8 @@ let rec make_sequence fn = function
[] -> lambda_unit
| [x] -> fn x
| x::rem ->
- let lam = fn x in Lsequence(lam, make_sequence fn rem)
+ let lam = fn x in
+ mk_loc_lam lam.l_loc (Lsequence(lam, make_sequence fn rem))
(* Apply a substitution to a lambda-term.
Assumes that the bound variables of the lambda-term do not
@@ -372,36 +380,40 @@ let rec make_sequence fn = function
of the bound variables of the lambda-term (no capture). *)
let subst_lambda s lam =
- let rec subst = function
- Lvar id as l ->
- begin try Ident.find_same id s with Not_found -> l end
- | Lconst sc as l -> l
- | Lapply(fn, args, loc) -> Lapply(subst fn, List.map subst args, loc)
- | Lfunction(kind, params, body) -> Lfunction(kind, params, subst body)
- | Llet(str, id, arg, body) -> Llet(str, id, subst arg, subst body)
- | Lletrec(decl, body) -> Lletrec(List.map subst_decl decl, subst body)
- | Lprim(p, args) -> Lprim(p, List.map subst args)
- | Lswitch(arg, sw) ->
- Lswitch(subst arg,
- {sw with sw_consts = List.map subst_case sw.sw_consts;
- sw_blocks = List.map subst_case sw.sw_blocks;
- sw_failaction =
- match sw.sw_failaction with
- | None -> None
- | Some l -> Some (subst l)})
-
- | Lstaticraise (i,args) -> Lstaticraise (i, List.map subst args)
- | Lstaticcatch(e1, io, e2) -> Lstaticcatch(subst e1, io, subst e2)
- | Ltrywith(e1, exn, e2) -> Ltrywith(subst e1, exn, subst e2)
- | Lifthenelse(e1, e2, e3) -> Lifthenelse(subst e1, subst e2, subst e3)
- | Lsequence(e1, e2) -> Lsequence(subst e1, subst e2)
- | Lwhile(e1, e2) -> Lwhile(subst e1, subst e2)
- | Lfor(v, e1, e2, dir, e3) -> Lfor(v, subst e1, subst e2, dir, subst e3)
- | Lassign(id, e) -> Lassign(id, subst e)
- | Lsend (k, met, obj, args, loc) ->
- Lsend (k, subst met, subst obj, List.map subst args, loc)
- | Levent (lam, evt) -> Levent (subst lam, evt)
- | Lifused (v, e) -> Lifused (v, subst e)
+ let rec subst l =
+ let make d = mk_loc_lam l.l_loc d in
+ match l.l_desc with
+ | Lvar id ->
+ begin try Ident.find_same id s with Not_found -> l end
+ | Lconst _ -> l
+ | Lapply(fn, args) -> make (Lapply(subst fn, List.map subst args))
+ | Lfunction(kind, params, body) ->
+ make (Lfunction(kind, params, subst body))
+ | Llet(str, id, arg, body) ->
+ make (Llet(str, id, subst arg, subst body))
+ | Lletrec(decl, body) ->
+ make (Lletrec(List.map subst_decl decl, subst body))
+ | Lprim(p, args) -> make (Lprim(p, List.map subst args))
+ | Lswitch(arg, sw) ->
+ make (Lswitch(subst arg,
+ {sw with sw_consts = List.map subst_case sw.sw_consts;
+ sw_blocks = List.map subst_case sw.sw_blocks;
+ sw_failaction =
+ match sw.sw_failaction with
+ | None -> None
+ | Some l -> Some (subst l)}))
+ | Lstaticraise (i,args) -> make (Lstaticraise (i, List.map subst args))
+ | Lstaticcatch(e1, io, e2) -> make (Lstaticcatch(subst e1, io, subst e2))
+ | Ltrywith(e1, exn, e2) -> make (Ltrywith(subst e1, exn, subst e2))
+ | Lifthenelse(e1, e2, e3) -> make (Lifthenelse(subst e1, subst e2, subst e3))
+ | Lsequence(e1, e2) -> make (Lsequence(subst e1, subst e2))
+ | Lwhile(e1, e2) -> make (Lwhile(subst e1, subst e2))
+ | Lfor(v, e1, e2, dir, e3) -> make (Lfor(v, subst e1, subst e2, dir, subst e3))
+ | Lassign(id, e) -> make (Lassign(id, subst e))
+ | Lsend (k, met, obj, args) ->
+ make (Lsend (k, subst met, subst obj, List.map subst args))
+ | Levent (lam, evt) -> make (Levent (subst lam, evt))
+ | Lifused (v, e) -> make (Lifused (v, subst e))
and subst_decl (id, exp) = (id, subst exp)
and subst_case (key, case) = (key, subst case)
in subst lam
@@ -410,9 +422,9 @@ let subst_lambda s lam =
(* To let-bind expressions to variables *)
let bind str var exp body =
- match exp with
+ match exp.l_desc with
Lvar var' when Ident.same var var' -> body
- | _ -> Llet(str, var, exp, body)
+ | _ -> mk_loc_lam exp.l_loc (Llet(str, var, exp, body))
and commute_comparison = function
| Ceq -> Ceq| Cneq -> Cneq
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
index d09a8c6..423bee3 100644
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -132,10 +132,15 @@ type meth_kind = Self | Public | Cached
type shared_code = (int * int) list (* stack size -> code label *)
-type lambda =
- Lvar of Ident.t
+type lambda = {
+ l_desc : lambda_desc;
+ l_loc : Location.t;
+}
+
+and lambda_desc =
+ | Lvar of Ident.t
| Lconst of structured_constant
- | Lapply of lambda * lambda list * Location.t
+ | Lapply of lambda * lambda list
| Lfunction of function_kind * Ident.t list * lambda
| Llet of let_kind * Ident.t * lambda * lambda
| Lletrec of (Ident.t * lambda) list * lambda
@@ -149,7 +154,7 @@ type lambda =
| Lwhile of lambda * lambda
| Lfor of Ident.t * lambda * lambda * direction_flag * lambda
| Lassign of Ident.t * lambda
- | Lsend of meth_kind * lambda * lambda * lambda list * Location.t
+ | Lsend of meth_kind * lambda * lambda * lambda list
| Levent of lambda * lambda_event
| Lifused of Ident.t * lambda
@@ -170,11 +175,13 @@ and lambda_event_kind =
| Lev_after of Types.type_expr
| Lev_function
+val mk_lam: lambda_desc -> lambda
+val mk_loc_lam: Location.t -> lambda_desc -> lambda
+
val same: lambda -> lambda -> bool
val const_unit: structured_constant
val lambda_unit: lambda
val name_lambda: lambda -> (Ident.t -> lambda) -> lambda
-val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda
val iter: (lambda -> unit) -> lambda -> unit
module IdentSet: Set.S with type elt = Ident.t
@@ -203,3 +210,4 @@ val staticfail : lambda (* Anticipated static failure *)
(* Check anticipated failure, substitute its final value *)
val is_guarded: lambda -> bool
val patch_guarded : lambda -> lambda -> lambda
+
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index a464590..a2209f0 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -433,17 +433,17 @@ let pretty_precompiled_res first nexts =
(* A slight attempt to identify semantically equivalent lambda-expressions *)
exception Not_simple
-let rec raw_rec env = function
+let rec raw_rec env l = match l.l_desc with
| Llet(Alias,x,ex, body) -> raw_rec ((x,raw_rec env ex)::env) body
- | Lvar id as l ->
+ | Lvar id ->
begin try List.assoc id env with
| Not_found -> l
end
| Lprim (Pfield i,args) ->
- Lprim (Pfield i, List.map (raw_rec env) args)
- | Lconst _ as l -> l
+ mk_loc_lam l.l_loc (Lprim (Pfield i, List.map (raw_rec env) args))
+ | Lconst _ -> l
| Lstaticraise (i,args) ->
- Lstaticraise (i, List.map (raw_rec env) args)
+ mk_loc_lam l.l_loc (Lstaticraise (i, List.map (raw_rec env) args))
| _ -> raise Not_simple
let raw_action l = try raw_rec [] l with Not_simple -> l
@@ -479,7 +479,7 @@ let up_ok_action act1 act2 =
try
let raw1 = raw_rec [] act1
and raw2 = raw_rec [] act2 in
- match raw1, raw2 with
+ match raw1.l_desc, raw2.l_desc with
| Lstaticraise (i1,[]), Lstaticraise (i2,[]) -> i1=i2
| _,_ -> raw1 = raw2
with
@@ -922,7 +922,7 @@ and split_constr cls args def k =
and precompile_var args cls def k = match args with
| [] -> assert false
-| _::((Lvar v as av,_) as arg)::rargs ->
+| _::(({l_desc=Lvar v} as av,_) as arg)::rargs ->
begin match cls with
| [ps,_] -> (* as splitted as it can *)
dont_precompile_var args cls def k
@@ -959,7 +959,7 @@ and dont_precompile_var args cls def k =
and precompile_or argo cls ors args def k = match ors with
| [] -> split_constr cls args def k
-| _ ->
+| (_,{l_loc}) :: _ ->
let rec do_cases = function
| ({pat_desc=Tpat_or _} as orp::patl, action)::rem ->
let others,rem = get_equiv orp rem in
@@ -981,9 +981,11 @@ and precompile_or argo cls ors args def k = match ors with
let or_num = next_raise_count () in
let new_patl = Parmatch.omega_list patl in
- let mk_new_action vs =
- Lstaticraise
- (or_num, List.map (fun v -> Lvar v) vs) in
+ let mk_new_action vs = {
+ l_loc;
+ l_desc = Lstaticraise
+ (or_num, List.map (fun v -> {l_loc; l_desc=Lvar v}) vs)
+ } in
let body,handlers = do_cases rem in
explode_or_pat
@@ -1125,7 +1127,12 @@ let make_field_args binding_kind arg first_pos last_pos argl =
let rec make_args pos =
if pos > last_pos
then argl
- else (Lprim(Pfield pos, [arg]), binding_kind) :: make_args (pos + 1)
+ else
+ let lam = {
+ l_loc = arg.l_loc;
+ l_desc = Lprim(Pfield pos, [arg]);
+ } in
+ (lam, binding_kind) :: make_args (pos + 1)
in make_args first_pos
let get_key_constr = function
@@ -1244,11 +1251,18 @@ let make_variant_matching_nonconst p lab def ctx = function
| ((arg, mut) :: argl) ->
let def = make_default (matcher_variant_nonconst lab) def
and ctx = filter_ctx p ctx in
- {pm=
- {cases = []; args = (Lprim(Pfield 1, [arg]), Alias) :: argl;
- default=def} ;
+ let lam = {
+ l_loc = arg.l_loc;
+ l_desc = Lprim(Pfield 1, [arg]);
+ } in {
+ pm = {
+ cases = [];
+ args = (lam, Alias) :: argl;
+ default=def
+ };
ctx=ctx ;
- pat = normalize_pat p}
+ pat = normalize_pat p
+ }
let get_key_variant p = match p.pat_desc with
| Tpat_variant(lab, Some _ , _) -> Cstr_block (Btype.hash_variant lab)
@@ -1327,11 +1341,15 @@ let get_mod_field modname field =
let env = Env.open_pers_signature modname Env.initial in
let p = try
match Env.lookup_value (Longident.Lident field) env with
- | (Path.Pdot(_,_,i), _) -> i
- | _ -> fatal_error ("Primitive "^modname^"."^field^" not found.")
- with Not_found -> fatal_error ("Primitive "^modname^"."^field^" not found.")
- in
- Lprim(Pfield p, [Lprim(Pgetglobal mod_ident, [])])
+ | (Path.Pdot(_,_,i), _) -> i
+ | _ -> fatal_error ("Primitive "^modname^"."^field^" not found.")
+ with Not_found -> fatal_error ("Primitive "^modname^"."^field^" not found.")
+ in {
+ l_loc = Location.none;
+ l_desc = Lprim(Pfield p, [{
+ l_loc = Location.none;
+ l_desc = Lprim(Pgetglobal mod_ident, [])
+ }])}
with Not_found -> fatal_error ("Module "^modname^" unavailable.")
)
@@ -1354,37 +1372,46 @@ let inline_lazy_force_cond arg loc =
let varg = Lvar idarg in
let tag = Ident.create "tag" in
let force_fun = Lazy.force code_force_lazy_block in
- Llet(Strict, idarg, arg,
- Llet(Alias, tag, Lprim(Pccall prim_obj_tag, [varg]),
- Lifthenelse(
- (* if (tag == Obj.forward_tag) then varg.(0) else ... *)
- Lprim(Pintcomp Ceq,
- [Lvar tag; Lconst(Const_base(Const_int Obj.forward_tag))]),
- Lprim(Pfield 0, [varg]),
- Lifthenelse(
- (* ... if (tag == Obj.lazy_tag) then Lazy.force varg else ... *)
- Lprim(Pintcomp Ceq,
- [Lvar tag; Lconst(Const_base(Const_int Obj.lazy_tag))]),
- Lapply(force_fun, [varg], loc),
- (* ... arg *)
- varg))))
+ let make = mk_loc_lam loc in
+ make
+ (Llet(Strict, idarg, arg,
+ make (
+ Llet(Alias, tag, make (Lprim(Pccall prim_obj_tag, [make varg])),
+ make (Lifthenelse(
+ (* if (tag == Obj.forward_tag) then varg.(0) else ... *)
+ make (Lprim(Pintcomp Ceq,
+ [make (Lvar tag);
+ make (Lconst(Const_base(Const_int Obj.forward_tag)))
+ ])),
+ make (Lprim(Pfield 0, [make varg])),
+ make (Lifthenelse(
+ (* ... if (tag == Obj.lazy_tag) then Lazy.force varg else ... *)
+ make (Lprim(Pintcomp Ceq,
+ [make (Lvar tag);
+ make (Lconst(Const_base(Const_int Obj.lazy_tag)))
+ ])),
+ make (Lapply(force_fun, [make varg])),
+ (* ... arg *)
+ make varg))))))))
let inline_lazy_force_switch arg loc =
let idarg = Ident.create "lzarg" in
let varg = Lvar idarg in
let force_fun = Lazy.force code_force_lazy_block in
- Llet(Strict, idarg, arg,
- Lifthenelse(
- Lprim(Pisint, [varg]), varg,
- (Lswitch
- (varg,
- { sw_numconsts = 0; sw_consts = [];
- sw_numblocks = (max Obj.lazy_tag Obj.forward_tag) + 1;
- sw_blocks =
- [ (Obj.forward_tag, Lprim(Pfield 0, [varg]));
- (Obj.lazy_tag,
- Lapply(force_fun, [varg], loc)) ];
- sw_failaction = Some varg } ))))
+ let make = mk_loc_lam loc in
+ make (Llet(Strict, idarg, arg,
+ make (Lifthenelse(
+ make (Lprim(Pisint, [make varg])),
+ make varg,
+ make (Lswitch
+ (make varg,
+ { sw_numconsts = 0; sw_consts = [];
+ sw_numblocks = (max Obj.lazy_tag Obj.forward_tag) + 1;
+ sw_blocks = [
+ (Obj.forward_tag, make (Lprim(Pfield 0, [make varg])));
+ (Obj.lazy_tag, make (Lapply(force_fun, [make varg])));
+ ];
+ sw_failaction = Some (make varg) }))))))
let inline_lazy_force =
if !Clflags.native_code then
@@ -1398,9 +1425,8 @@ let inline_lazy_force =
let make_lazy_matching def = function
[] -> fatal_error "Matching.make_lazy_matching"
| (arg,mut) :: argl ->
- { cases = [];
- args =
- (inline_lazy_force arg Location.none, Strict) :: argl;
+ { cases = [];
+ args = (inline_lazy_force arg arg.l_loc, Strict) :: argl;
default = make_default matcher_lazy def }
let divide_lazy p ctx pm =
@@ -1430,9 +1456,17 @@ let make_tuple_matching arity def = function
let rec make_args pos =
if pos >= arity
then argl
- else (Lprim(Pfield pos, [arg]), Alias) :: make_args (pos + 1) in
- {cases = []; args = make_args 0 ;
- default=make_default (matcher_tuple arity) def}
+ else
+ let lam = {
+ l_loc = arg.l_loc;
+ l_desc = Lprim(Pfield pos, [arg]);
+ } in
+ (lam, Alias) :: make_args (pos + 1)
+ in {
+ cases = [];
+ args = make_args 0 ;
+ default = make_default (matcher_tuple arity) def
+ }
let divide_tuple arity p ctx pm =
@@ -1475,7 +1509,11 @@ let make_record_matching all_labels def = function
match lbl.lbl_mut with
Immutable -> Alias
| Mutable -> StrictOpt in
- (Lprim(access, [arg]), str) :: make_args(pos + 1)
+ let lam = {
+ l_loc = arg.l_loc;
+ l_desc = Lprim(access, [arg]);
+ } in
+ (lam, str) :: make_args(pos + 1)
end in
let nfields = Array.length all_labels in
let def= make_default (matcher_record nfields) def in
@@ -1513,8 +1551,12 @@ let make_array_matching kind p def ctx = function
let rec make_args pos =
if pos >= len
then argl
- else (Lprim(Parrayrefu kind, [arg; Lconst(Const_base(Const_int pos))]),
- StrictOpt) :: make_args (pos + 1) in
+ else
+ let make = mk_loc_lam arg.l_loc in
+ let lam =
+ make (Lprim(Parrayrefu kind,
+ [arg; make (Lconst(Const_base(Const_int pos)))])) in
+ (lam, StrictOpt) :: make_args (pos + 1) in
let def = make_default (matcher_array len) def
and ctx = filter_ctx p ctx in
{pm={cases = []; args = make_args 0 ; default = def} ;
@@ -1548,19 +1590,23 @@ let rec cut n l =
let rec do_tests_fail fail tst arg = function
| [] -> fail
| (c, act)::rem ->
- Lifthenelse
- (Lprim (tst, [arg ; Lconst (Const_base c)]),
- do_tests_fail fail tst arg rem,
- act)
+ let make = mk_loc_lam arg.l_loc in
+ make
+ (Lifthenelse
+ (make (Lprim (tst, [arg ; make (Lconst (Const_base c))])),
+ do_tests_fail fail tst arg rem,
+ act))
let rec do_tests_nofail tst arg = function
| [] -> fatal_error "Matching.do_tests_nofail"
| [_,act] -> act
| (c,act)::rem ->
- Lifthenelse
- (Lprim (tst, [arg ; Lconst (Const_base c)]),
- do_tests_nofail tst arg rem,
- act)
+ let make = mk_loc_lam arg.l_loc in
+ make
+ (Lifthenelse
+ (make (Lprim (tst, [arg ; make (Lconst (Const_base c))])),
+ do_tests_nofail tst arg rem,
+ act))
let make_test_sequence fail tst lt_tst arg const_lambda_list =
let rec make_test_sequence const_lambda_list =
@@ -1573,12 +1619,22 @@ let make_test_sequence fail tst lt_tst arg const_lambda_list =
and split_sequence const_lambda_list =
let list1, list2 =
cut (List.length const_lambda_list / 2) const_lambda_list in
- Lifthenelse(Lprim(lt_tst,[arg; Lconst(Const_base (fst(List.hd list2)))]),
- make_test_sequence list1, make_test_sequence list2)
- in make_test_sequence (sort_lambda_list const_lambda_list)
+ let hd_const, hd_lam = List.hd list2 in
+ let make = mk_loc_lam hd_lam.l_loc in
+ make (Lifthenelse(
+ make (Lprim(lt_tst,[arg; make (Lconst(Const_base hd_const))])),
+ make_test_sequence list1,
+ make_test_sequence list2)) in
+ make_test_sequence (sort_lambda_list const_lambda_list)
-let make_offset x arg = if x=0 then arg else Lprim(Poffsetint(x), [arg])
+let make_offset x arg =
+ if x=0 then
+ arg
+ else {
+ l_loc = arg.l_loc;
+ l_desc = Lprim(Poffsetint(x), [arg]);
+ }
@@ -1652,13 +1708,13 @@ let full sw =
List.length sw.sw_blocks = sw.sw_numblocks
let make_switch (arg,sw) = match sw.sw_failaction with
-| None ->
+ | None ->
let t = Hashtbl.create 17 in
- let seen l = match l with
- | Lstaticraise (i,[]) ->
+ let seen l = match l.l_desc with
+ | Lstaticraise (i,[]) ->
let old = try Hashtbl.find t i with Not_found -> 0 in
Hashtbl.replace t i (old+1)
- | _ -> () in
+ | _ -> () in
List.iter (fun (_,lam) -> seen lam) sw.sw_consts ;
List.iter (fun (_,lam) -> seen lam) sw.sw_blocks ;
let i_max = ref (-1)
@@ -1669,22 +1725,23 @@ let make_switch (arg,sw) = match sw.sw_failaction with
i_max := i ;
max := c
end) t ;
+ let make = mk_loc_lam arg.l_loc in
if !i_max >= 0 then
let default = !i_max in
let rec remove = function
| [] -> []
- | (_,Lstaticraise (j,[]))::rem when j=default ->
- remove rem
+ | (_,{l_desc=Lstaticraise (j,[])})::rem when j=default ->
+ remove rem
| x::rem -> x::remove rem in
- Lswitch
- (arg,
- {sw with
-sw_consts = remove sw.sw_consts ;
-sw_blocks = remove sw.sw_blocks ;
-sw_failaction = Some (Lstaticraise (default,[]))})
+ make (Lswitch (arg,
+ { sw with
+ sw_consts = remove sw.sw_consts ;
+ sw_blocks = remove sw.sw_blocks ;
+ sw_failaction = Some (make (Lstaticraise (default,[])));
+ }))
else
- Lswitch (arg,sw)
-| _ -> Lswitch (arg,sw)
+ make (Lswitch (arg,sw))
+ | _ -> { l_loc = arg.l_loc; l_desc = Lswitch (arg,sw) }
module SArg = struct
type primitive = Lambda.primitive
@@ -1698,28 +1755,31 @@ module SArg = struct
type act = Lambda.lambda
- let make_prim p args = Lprim (p,args)
+ let make_prim p args = {l_loc = Location.none; l_desc = Lprim (p,args) }
let make_offset arg n = match n with
| 0 -> arg
- | _ -> Lprim (Poffsetint n,[arg])
+ | _ -> { l_loc = arg.l_loc; l_desc = Lprim (Poffsetint n,[arg]) }
let bind arg body =
- let newvar,newarg = match arg with
+ let newvar,newarg = match arg.l_desc with
| Lvar v -> v,arg
| _ ->
let newvar = Ident.create "switcher" in
- newvar,Lvar newvar in
+ newvar, mk_loc_lam arg.l_loc (Lvar newvar) in
bind Alias newvar arg (body newarg)
- let make_isout h arg = Lprim (Pisout, [h ; arg])
- let make_isin h arg = Lprim (Pnot,[make_isout h arg])
- let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot)
- let make_switch = make_switch_switcher
+ let make_isout h arg = mk_loc_lam arg.l_loc (Lprim (Pisout, [h ; arg]))
+ let make_isin h arg = mk_loc_lam arg.l_loc (Lprim (Pnot,[make_isout h arg]))
+ let make_if cond ifso ifnot = mk_loc_lam cond.l_loc (Lifthenelse (cond, ifso, ifnot))
+ let make_switch cond ia la = mk_loc_lam cond.l_loc (make_switch_switcher cond ia la)
end
module Switcher = Switch.Make(SArg)
open Switch
-let lambda_of_int i = Lconst (Const_base (Const_int i))
+let lambda_of_int loc i = {
+ l_loc = loc;
+ l_desc = Lconst (Const_base (Const_int i));
+}
let rec last def = function
| [] -> def
@@ -1910,17 +1970,20 @@ let mk_res get_key env last_choice idef cant_fail ctx =
*)
let mk_failaction_neg partial ctx def = match partial with
-| Partial ->
+ | Partial ->
begin match def with
- | (_,idef)::_ ->
- Some (Lstaticraise (idef,[])),[],jumps_singleton idef ctx
- | _ ->
- (* Act as Total, this means
- If no appropriate default matrix exists,
- then this switch cannot fail *)
+ | (_,idef)::_ ->
+ Some {
+ l_loc = Location.none;
+ l_desc = Lstaticraise (idef,[])
+ },[],jumps_singleton idef ctx
+ | _ ->
+ (* Act as Total, this means
+ If no appropriate default matrix exists,
+ then this switch cannot fail *)
None, [], jumps_empty
end
-| Total ->
+ | Total ->
None, [], jumps_empty
@@ -1928,25 +1991,28 @@ let mk_failaction_neg partial ctx def = match partial with
(* Conforme a l'article et plus simple qu'avant *)
and mk_failaction_pos partial seen ctx defs =
let rec scan_def env to_test defs = match to_test,defs with
- | ([],_)|(_,[]) ->
- List.fold_left
- (fun (klist,jumps) (pats,i)->
- let action = Lstaticraise (i,[]) in
- let klist =
- List.fold_right
- (fun pat r -> (get_key_constr pat,action)::r)
- pats klist
- and jumps =
- jumps_add i (ctx_lub (list_as_pat pats) ctx) jumps in
- klist,jumps)
- ([],jumps_empty) env
- | _,(pss,idef)::rem ->
+ | ([],_)|(_,[]) ->
+ List.fold_left
+ (fun (klist,jumps) (pats,i)->
+ let action = {
+ l_loc = Location.none;
+ l_desc = Lstaticraise (i,[]);
+ } in
+ let klist =
+ List.fold_right
+ (fun pat r -> (get_key_constr pat,action)::r)
+ pats klist
+ and jumps =
+ jumps_add i (ctx_lub (list_as_pat pats) ctx) jumps in
+ klist,jumps)
+ ([],jumps_empty) env
+ | _,(pss,idef)::rem ->
let now, later =
List.partition
(fun (p,p_ctx) -> ctx_match p_ctx pss) to_test in
match now with
- | [] -> scan_def env to_test rem
- | _ -> scan_def ((List.map fst now,idef)::env) later rem in
+ | [] -> scan_def env to_test rem
+ | _ -> scan_def ((List.map fst now,idef)::env) later rem in
scan_def
[]
@@ -1968,14 +2034,14 @@ let combine_constant arg cst partial ctx def
List.map (function Const_int n, l -> n,l | _ -> assert false)
const_lambda_list in
call_switcher
- lambda_of_int fail arg min_int max_int int_lambda_list
+ (lambda_of_int arg.l_loc) fail arg min_int max_int int_lambda_list
| Const_char _ ->
let int_lambda_list =
List.map (function Const_char c, l -> (Char.code c, l)
| _ -> assert false)
const_lambda_list in
call_switcher
- (fun i -> Lconst (Const_base (Const_int i)))
+ (fun i -> { l_loc = arg.l_loc; l_desc = Lconst (Const_base (Const_int i))})
fail arg 0 255 int_lambda_list
| Const_string _ ->
make_test_sequence
@@ -2038,9 +2104,12 @@ let combine_constructor arg ex_pat cstr partial ctx def
(fun (ex, act) rem ->
match ex with
| Cstr_exception path ->
- Lifthenelse(Lprim(Pintcomp Ceq,
- [Lprim(Pfield 0, [arg]); transl_path path]),
- act, rem)
+ let make = mk_loc_lam arg.l_loc in
+ make (Lifthenelse(
+ make (Lprim(
+ Pintcomp Ceq,
+ [make (Lprim(Pfield 0, [arg])); transl_path path])),
+ act, rem))
| _ -> assert false)
tests default in
lambda1, jumps_union local_jumps total1
@@ -2050,41 +2119,43 @@ let combine_constructor arg ex_pat cstr partial ctx def
and nconstrs = cstr.cstr_consts + cstr.cstr_nonconsts in
let sig_complete = ncases = nconstrs in
let fails,local_jumps =
- if sig_complete then [],jumps_empty
+ if sig_complete then
+ [],jumps_empty
else
mk_failaction_pos partial pats ctx def in
let tag_lambda_list = fails @ tag_lambda_list in
let (consts, nonconsts) = split_cases tag_lambda_list in
+ let make = mk_loc_lam arg.l_loc in
let lambda1 =
match same_actions tag_lambda_list with
- | Some act -> act
- | _ ->
+ | Some act -> act
+ | _ ->
match
(cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts)
with
- | (1, 1, [0, act1], [0, act2]) ->
- Lifthenelse(arg, act2, act1)
- | (n,_,_,[]) ->
+ | (1, 1, [0, act1], [0, act2]) ->
+ make (Lifthenelse(arg, act2, act1))
+ | (n,_,_,[]) ->
call_switcher
- (fun i -> Lconst (Const_base (Const_int i)))
+ (fun i -> make (Lconst (Const_base (Const_int i))))
None arg 0 (n-1) consts
- | (n, _, _, _) ->
+ | (n, _, _, _) ->
match same_actions nonconsts with
- | None ->
+ | None ->
make_switch(arg, {sw_numconsts = cstr.cstr_consts;
- sw_consts = consts;
- sw_numblocks = cstr.cstr_nonconsts;
- sw_blocks = nonconsts;
- sw_failaction = None})
- | Some act ->
- Lifthenelse
- (Lprim (Pisint, [arg]),
- call_switcher
- (fun i -> Lconst (Const_base (Const_int i)))
- None arg
- 0 (n-1) consts,
- act) in
+ sw_consts = consts;
+ sw_numblocks = cstr.cstr_nonconsts;
+ sw_blocks = nonconsts;
+ sw_failaction = None})
+ | Some act ->
+ make (Lifthenelse
+ (make (Lprim (Pisint, [arg])),
+ call_switcher
+ (fun i -> make (Lconst (Const_base (Const_int i))))
+ None arg
+ 0 (n-1) consts,
+ act)) in
lambda1, jumps_union local_jumps total1
end
@@ -2092,20 +2163,24 @@ let make_test_sequence_variant_constant fail arg int_lambda_list =
let _, (cases, actions) =
as_interval fail min_int max_int int_lambda_list in
Switcher.test_sequence
- (fun i -> Lconst (Const_base (Const_int i))) arg cases actions
+ (fun i -> { l_loc = arg.l_loc;
+ l_desc = Lconst (Const_base (Const_int i))})
+ arg cases actions
let call_switcher_variant_constant fail arg int_lambda_list =
call_switcher
- (fun i -> Lconst (Const_base (Const_int i)))
+ (fun i -> { l_loc = arg.l_loc;
+ l_desc = Lconst (Const_base (Const_int i))})
fail arg min_int max_int int_lambda_list
let call_switcher_variant_constr fail arg int_lambda_list =
let v = Ident.create "variant" in
- Llet(Alias, v, Lprim(Pfield 0, [arg]),
- call_switcher
- (fun i -> Lconst (Const_base (Const_int i)))
- fail (Lvar v) min_int max_int int_lambda_list)
+ let make = mk_loc_lam arg.l_loc in
+ make (Llet(Alias, v, make (Lprim(Pfield 0, [arg])),
+ call_switcher
+ (fun i -> make (Lconst (Const_base (Const_int i))))
+ fail (make (Lvar v)) min_int max_int int_lambda_list))
let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) =
let row = Btype.row_repr row in
@@ -2120,7 +2195,8 @@ let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) =
else
num_constr := max_int;
let test_int_or_block arg if_int if_block =
- Lifthenelse(Lprim (Pisint, [arg]), if_int, if_block) in
+ let make = mk_loc_lam arg.l_loc in
+ make (Lifthenelse(make (Lprim (Pisint, [arg])), if_int, if_block)) in
let sig_complete = List.length tag_lambda_list = !num_constr
and one_action = same_actions tag_lambda_list in
let fail, to_add, local_jumps =
@@ -2166,36 +2242,33 @@ let combine_array arg kind partial ctx def
let len_lambda_list = to_add @ len_lambda_list in
let lambda1 =
let newvar = Ident.create "len" in
+ let make = mk_loc_lam arg.l_loc in
let switch =
call_switcher
- lambda_of_int
- fail (Lvar newvar)
+ (lambda_of_int arg.l_loc)
+ fail (make (Lvar newvar))
0 max_int len_lambda_list in
- bind
- Alias newvar (Lprim(Parraylength kind, [arg])) switch in
+ bind Alias newvar (make (Lprim(Parraylength kind, [arg]))) switch in
lambda1, jumps_union local_jumps total1
(* Insertion of debugging events *)
-let rec event_branch repr lam =
- begin match lam, repr with
- (_, None) ->
- lam
+let rec event_branch repr lam = match lam.l_desc, repr with
+ | (_, None) -> lam
| (Levent(lam', ev), Some r) ->
- incr r;
- Levent(lam', {lev_loc = ev.lev_loc;
- lev_kind = ev.lev_kind;
- lev_repr = repr;
- lev_env = ev.lev_env})
+ incr r;
+ mk_loc_lam lam.l_loc
+ (Levent(lam', {lev_loc = ev.lev_loc;
+ lev_kind = ev.lev_kind;
+ lev_repr = repr;
+ lev_env = ev.lev_env}))
| (Llet(str, id, lam, body), _) ->
- Llet(str, id, lam, event_branch repr body)
+ mk_loc_lam lam.l_loc (Llet(str, id, lam, event_branch repr body))
| Lstaticraise _,_ -> lam
| (_, Some r) ->
- Printlambda.lambda Format.str_formatter lam ;
- fatal_error
- ("Matching.event_branch: "^Format.flush_str_formatter ())
- end
-
+ Printlambda.lambda Format.str_formatter lam ;
+ fatal_error
+ ("Matching.event_branch: "^Format.flush_str_formatter ())
(*
This exception is raised when the compiler cannot produce code
@@ -2237,27 +2310,29 @@ let compile_orhandlers compile_fun lambda1 total1 ctx to_catch =
let rec do_rec r total_r = function
| [] -> r,total_r
| (mat,i,vars,pm)::rem ->
- begin try
- let ctx = select_columns mat ctx in
- let handler_i, total_i = compile_fun ctx pm in
- match raw_action r with
+ let lam = raw_action r in
+ try
+ let ctx = select_columns mat ctx in
+ let handler_i, total_i = compile_fun ctx pm in
+ match lam.l_desc with
| Lstaticraise (j,args) ->
- if i=j then
- List.fold_right2 (bind Alias) vars args handler_i,
- jumps_map (ctx_rshift_num (ncols mat)) total_i
- else
- do_rec r total_r rem
+ if i=j then
+ List.fold_right2 (bind Alias) vars args handler_i,
+ jumps_map (ctx_rshift_num (ncols mat)) total_i
+ else
+ do_rec r total_r rem
| _ ->
- do_rec
- (Lstaticcatch (r,(i,vars), handler_i))
- (jumps_union
- (jumps_remove i total_r)
- (jumps_map (ctx_rshift_num (ncols mat)) total_i))
+ do_rec
+ (mk_loc_lam lam.l_loc (Lstaticcatch (r,(i,vars), handler_i)))
+ (jumps_union
+ (jumps_remove i total_r)
+ (jumps_map (ctx_rshift_num (ncols mat)) total_i))
rem
- with
+ with
| Unused ->
- do_rec (Lstaticcatch (r, (i,vars), lambda_unit)) total_r rem
- end in
+ do_rec
+ (mk_loc_lam lam.l_loc (Lstaticcatch (r, (i,vars), lambda_unit)))
+ total_r rem in
do_rec lambda1 total1 to_catch
@@ -2276,7 +2351,7 @@ let compile_test compile_fun partial divide combine ctx to_match =
(* Attempt to avoid some useless bindings by lowering them *)
(* Approximation of v present in lam *)
-let rec approx_present v = function
+let rec approx_present v l = match l.l_desc with
| Lconst _ -> false
| Lstaticraise (_,args) ->
List.exists (fun lam -> approx_present v lam) args
@@ -2291,76 +2366,81 @@ let string_of_lam lam =
Printlambda.lambda Format.str_formatter lam ;
Format.flush_str_formatter ()
-let rec lower_bind v arg lam = match lam with
-| Lifthenelse (cond, ifso, ifnot) ->
+let rec lower_bind v arg lam = match lam.l_desc with
+ | Lifthenelse (cond, ifso, ifnot) ->
let pcond = approx_present v cond
and pso = approx_present v ifso
and pnot = approx_present v ifnot in
begin match pcond, pso, pnot with
- | false, false, false -> lam
- | false, true, false ->
- Lifthenelse (cond, lower_bind v arg ifso, ifnot)
- | false, false, true ->
- Lifthenelse (cond, ifso, lower_bind v arg ifnot)
- | _,_,_ -> bind Alias v arg lam
+ | false, false, false -> lam
+ | false, true, false ->
+ (mk_loc_lam lam.l_loc (Lifthenelse (cond, lower_bind v arg ifso, ifnot)))
+ | false, false, true ->
+ (mk_loc_lam lam.l_loc (Lifthenelse (cond, ifso, lower_bind v arg ifnot)))
+ | _,_,_ -> bind Alias v arg lam
end
-| Lswitch (ls,({sw_consts=[i,act] ; sw_blocks = []} as sw))
- when not (approx_present v ls) ->
- Lswitch (ls, {sw with sw_consts = [i,lower_bind v arg act]})
-| Lswitch (ls,({sw_consts=[] ; sw_blocks = [i,act]} as sw))
- when not (approx_present v ls) ->
- Lswitch (ls, {sw with sw_blocks = [i,lower_bind v arg act]})
-| Llet (Alias, vv, lv, l) ->
+ | Lswitch (ls,({sw_consts=[i,act] ; sw_blocks = []} as sw))
+ when not (approx_present v ls) ->
+ {lam with
+ l_desc = Lswitch (ls, {sw with sw_consts = [i,lower_bind v arg act]})}
+ | Lswitch (ls,({sw_consts=[] ; sw_blocks = [i,act]} as sw))
+ when not (approx_present v ls) ->
+ {lam with
+ l_desc = Lswitch (ls, {sw with sw_blocks = [i,lower_bind v arg act]})}
+ | Llet (Alias, vv, lv, l) ->
if approx_present v lv then
bind Alias v arg lam
else
- Llet (Alias, vv, lv, lower_bind v arg l)
-| _ ->
+ (mk_loc_lam lam.l_loc (Llet (Alias, vv, lv, lower_bind v arg l)))
+ | _ ->
bind Alias v arg lam
-let bind_check str v arg lam = match str,arg with
-| _, Lvar _ ->bind str v arg lam
-| Alias,_ -> lower_bind v arg lam
-| _,_ -> bind str v arg lam
+let bind_check str v arg lam = match str,arg.l_desc with
+ | _, Lvar _ ->bind str v arg lam
+ | Alias,_ -> lower_bind v arg lam
+ | _,_ -> bind str v arg lam
let rec comp_exit ctx m = match m.default with
-| (_,i)::_ -> Lstaticraise (i,[]), jumps_singleton i ctx
-| _ -> fatal_error "Matching.comp_exit"
+ | (_,i)::_ ->
+ { l_loc = Location.none; l_desc = Lstaticraise (i,[])},
+ jumps_singleton i ctx
+ | _ -> fatal_error "Matching.comp_exit"
-let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs = match next_matchs with
+let rec comp_match_handlers comp_fun partial ctx arg first_match = function
| [] -> comp_fun partial ctx arg first_match
| rem ->
- let rec c_rec body total_body = function
- | [] -> body, total_body
- (* Hum, -1 meant never taken
- | (-1,pm)::rem -> c_rec body total_body rem *)
- | (i,pm)::rem ->
- let ctx_i,total_rem = jumps_extract i total_body in
- begin match ctx_i with
- | [] -> c_rec body total_body rem
- | _ ->
- try
- let li,total_i =
- comp_fun
- (match rem with [] -> partial | _ -> Partial)
- ctx_i arg pm in
- c_rec
- (Lstaticcatch (body,(i,[]),li))
- (jumps_union total_i total_rem)
- rem
- with
- | Unused ->
- c_rec (Lstaticcatch (body,(i,[]),lambda_unit))
- total_rem rem
- end in
- try
+ let make = mk_loc_lam arg.l_loc in
+ let rec c_rec body total_body = function
+ | [] -> body, total_body
+ (* Hum, -1 meant never taken
+ | (-1,pm)::rem -> c_rec body total_body rem *)
+ | (i,pm)::rem ->
+ let ctx_i,total_rem = jumps_extract i total_body in
+ begin match ctx_i with
+ | [] -> c_rec body total_body rem
+ | _ ->
+ try
+ let li,total_i =
+ comp_fun
+ (match rem with [] -> partial | _ -> Partial)
+ ctx_i arg pm in
+ c_rec
+ (make (Lstaticcatch (body,(i,[]),li)))
+ (jumps_union total_i total_rem)
+ rem
+ with
+ | Unused ->
+ c_rec (make (Lstaticcatch (body,(i,[]),lambda_unit)))
+ total_rem rem
+ end in
+ try
let first_lam,total = comp_fun Partial ctx arg first_match in
c_rec first_lam total rem
- with Unused -> match next_matchs with
- | [] -> raise Unused
- | (_,x)::xs -> comp_match_handlers comp_fun partial ctx arg x xs
+ with Unused -> match rem with
+ | [] -> raise Unused
+ | (_,x)::xs -> comp_match_handlers comp_fun partial ctx arg x xs
(* To find reasonable names for variables *)
@@ -2373,11 +2453,11 @@ let rec name_pattern default = function
end
| _ -> Ident.create default
-let arg_to_var arg cls = match arg with
+let arg_to_var arg cls = match arg.l_desc with
| Lvar v -> v,arg
| _ ->
let v = name_pattern "match" cls in
- v,Lvar v
+ v,{l_loc = arg.l_loc; l_desc = Lvar v}
(*
@@ -2393,15 +2473,15 @@ let arg_to_var arg cls = match arg with
let rec compile_match repr partial ctx m = match m with
-| { cases = [] } -> comp_exit ctx m
-| { cases = ([], action) :: rem } ->
+ | { cases = [] } -> comp_exit ctx m
+ | { cases = ([], action) :: rem } ->
if is_guarded action then begin
let (lambda, total) =
compile_match None partial ctx { m with cases = rem } in
event_branch repr (patch_guarded lambda action), total
end else
(event_branch repr action, jumps_empty)
-| { args = (arg, str)::argl } ->
+ | { args = (arg, str)::argl } ->
let v,newarg = arg_to_var arg m.cases in
let first_match,rem =
split_precompile (Some v)
@@ -2410,12 +2490,12 @@ let rec compile_match repr partial ctx m = match m with
comp_match_handlers
(do_compile_matching repr) partial ctx newarg first_match rem in
bind_check str v arg lam, total
-| _ -> assert false
+ | _ -> assert false
(* verbose version of do_compile_matching, for debug *)
(*
-and do_compile_matching_pr repr partial ctx arg x =
+ and do_compile_matching_pr repr partial ctx arg x =
prerr_string "COMPILE: " ;
prerr_endline (match partial with Partial -> "Partial" | Total -> "Total") ;
prerr_endline "MATCH" ;
@@ -2428,52 +2508,52 @@ and do_compile_matching_pr repr partial ctx arg x =
r
*)
and do_compile_matching repr partial ctx arg pmh = match pmh with
-| Pm pm ->
- let pat = what_is_cases pm.cases in
- begin match pat.pat_desc with
- | Tpat_any ->
- compile_no_test
- divide_var ctx_rshift repr partial ctx pm
- | Tpat_tuple patl ->
- compile_no_test
- (divide_tuple (List.length patl) (normalize_pat pat)) ctx_combine
- repr partial ctx pm
- | Tpat_record ((lbl,_)::_) ->
- compile_no_test
- (divide_record lbl.lbl_all (normalize_pat pat))
- ctx_combine repr partial ctx pm
- | Tpat_constant cst ->
- compile_test
- (compile_match repr partial) partial
- divide_constant
- (combine_constant arg cst partial)
- ctx pm
- | Tpat_construct (cstr, _) ->
- compile_test
- (compile_match repr partial) partial
- divide_constructor (combine_constructor arg pat cstr partial)
- ctx pm
- | Tpat_array _ ->
- let kind = Typeopt.array_pattern_kind pat in
- compile_test (compile_match repr partial) partial
- (divide_array kind) (combine_array arg kind partial)
- ctx pm
- | Tpat_lazy _ ->
- compile_no_test
- (divide_lazy (normalize_pat pat))
- ctx_combine repr partial ctx pm
- | Tpat_variant(lab, _, row) ->
- compile_test (compile_match repr partial) partial
- (divide_variant !row)
- (combine_variant !row arg partial)
- ctx pm
- | _ -> assert false
- end
-| PmVar {inside=pmh ; var_arg=arg} ->
+ | Pm pm ->
+ let pat = what_is_cases pm.cases in
+ begin match pat.pat_desc with
+ | Tpat_any ->
+ compile_no_test
+ divide_var ctx_rshift repr partial ctx pm
+ | Tpat_tuple patl ->
+ compile_no_test
+ (divide_tuple (List.length patl) (normalize_pat pat)) ctx_combine
+ repr partial ctx pm
+ | Tpat_record ((lbl,_)::_) ->
+ compile_no_test
+ (divide_record lbl.lbl_all (normalize_pat pat))
+ ctx_combine repr partial ctx pm
+ | Tpat_constant cst ->
+ compile_test
+ (compile_match repr partial) partial
+ divide_constant
+ (combine_constant arg cst partial)
+ ctx pm
+ | Tpat_construct (cstr, _) ->
+ compile_test
+ (compile_match repr partial) partial
+ divide_constructor (combine_constructor arg pat cstr partial)
+ ctx pm
+ | Tpat_array _ ->
+ let kind = Typeopt.array_pattern_kind pat in
+ compile_test (compile_match repr partial) partial
+ (divide_array kind) (combine_array arg kind partial)
+ ctx pm
+ | Tpat_lazy _ ->
+ compile_no_test
+ (divide_lazy (normalize_pat pat))
+ ctx_combine repr partial ctx pm
+ | Tpat_variant(lab, _, row) ->
+ compile_test (compile_match repr partial) partial
+ (divide_variant !row)
+ (combine_variant !row arg partial)
+ ctx pm
+ | _ -> assert false
+ end
+ | PmVar {inside=pmh ; var_arg=arg} ->
let lam, total =
do_compile_matching repr partial (ctx_lshift ctx) arg pmh in
lam, jumps_map ctx_rshift total
-| PmOr {body=body ; handlers=handlers} ->
+ | PmOr {body=body ; handlers=handlers} ->
let lam, total = compile_match repr partial ctx body in
compile_orhandlers (compile_match repr partial) lam total ctx handlers
@@ -2512,7 +2592,7 @@ let check_total total lambda i handler_fun =
if jumps_is_empty total then
lambda
else begin
- Lstaticcatch(lambda, (i,[]), handler_fun())
+ mk_loc_lam lambda.l_loc (Lstaticcatch(lambda, (i,[]), handler_fun()))
end
let compile_matching loc repr handler_fun arg pat_act_list partial =
@@ -2543,19 +2623,26 @@ let compile_matching loc repr handler_fun arg pat_act_list partial =
let partial_function loc () =
(* [Location.get_pos_info] is too expensive *)
let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in
- Lprim(Praise, [Lprim(Pmakeblock(0, Immutable),
- [transl_path Predef.path_match_failure;
- Lconst(Const_block(0,
- [Const_base(Const_string fname);
- Const_base(Const_int line);
- Const_base(Const_int char)]))])])
+ let make = mk_loc_lam loc in
+ make
+ (Lprim
+ (Praise,
+ [make (Lprim(Pmakeblock(0, Immutable),
+ [transl_path Predef.path_match_failure;
+ make (Lconst
+ (Const_block(0,
+ [Const_base(Const_string fname);
+ Const_base(Const_int line);
+ Const_base(Const_int char)])))])
+ )]))
let for_function loc repr param pat_act_list partial =
compile_matching loc repr (partial_function loc) param pat_act_list partial
(* In the following two cases, exhaustiveness info is not available! *)
let for_trywith param pat_act_list =
- compile_matching Location.none None (fun () -> Lprim(Praise, [param]))
+ compile_matching Location.none None
+ (fun () -> { l_loc = Location.none; l_desc = Lprim(Praise, [param])})
param pat_act_list Partial
let for_let loc param pat body =
@@ -2568,11 +2655,12 @@ let for_tupled_function loc paraml pats_act_list partial =
let partial = check_partial pats_act_list partial in
let raise_num = next_raise_count () in
let omegas = [List.map (fun _ -> omega) paraml] in
- let pm =
- { cases = pats_act_list;
- args = List.map (fun id -> (Lvar id, Strict)) paraml ;
- default = [omegas,raise_num]
- } in
+ let pm = {
+ cases = pats_act_list;
+ args = List.map
+ (fun id -> ({l_loc=loc; l_desc=Lvar id}, Strict)) paraml ;
+ default = [omegas,raise_num]
+ } in
try
let (lambda, total) = compile_match None partial
(start_ctx (List.length paraml)) pm in
@@ -2647,28 +2735,29 @@ let compile_flattened repr partial ctx _ pmh = match pmh with
let do_for_multiple_match loc paraml pat_act_list partial =
let repr = None in
let partial = check_partial pat_act_list partial in
+ let make = mk_loc_lam loc in
let raise_num,pm1 =
match partial with
- | Partial ->
+ | Partial ->
let raise_num = next_raise_count () in
raise_num,
{ cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
- args = [Lprim(Pmakeblock(0, Immutable), paraml), Strict] ;
+ args = [make (Lprim(Pmakeblock(0, Immutable), paraml)), Strict] ;
default = [[[omega]],raise_num] }
- | _ ->
+ | _ ->
-1,
{ cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
- args = [Lprim(Pmakeblock(0, Immutable), paraml), Strict] ;
+ args = [make (Lprim(Pmakeblock(0, Immutable), paraml)), Strict] ;
default = [] } in
try
try
-(* Once for checking that compilation is possible *)
+ (* Once for checking that compilation is possible *)
let next, nexts = split_precompile None pm1 in
let size = List.length paraml
and idl = List.map (fun _ -> Ident.create "match") paraml in
- let args = List.map (fun id -> Lvar id, Alias) idl in
+ let args = List.map (fun id -> {l_loc = loc; l_desc = Lvar id}, Alias) idl in
let flat_next = flatten_precompiled size args next
and flat_nexts =
@@ -2676,23 +2765,24 @@ let do_for_multiple_match loc paraml pat_act_list partial =
(fun (e,pm) -> e,flatten_precompiled size args pm)
nexts in
+ let dummy_arg = { l_loc = loc; l_desc = Lvar (Ident.create "dummy") } in
let lam, total =
comp_match_handlers
(compile_flattened repr)
- partial (start_ctx size) () flat_next flat_nexts in
+ partial (start_ctx size) dummy_arg flat_next flat_nexts in
List.fold_right2 (bind Strict) idl paraml
(match partial with
- | Partial ->
+ | Partial ->
check_total total lam raise_num (partial_function loc)
- | Total ->
+ | Total ->
assert (jumps_is_empty total) ;
lam)
with Cannot_flatten ->
let (lambda, total) = compile_match None partial (start_ctx 1) pm1 in
begin match partial with
- | Partial ->
+ | Partial ->
check_total total lambda raise_num (partial_function loc)
- | Total ->
+ | Total ->
assert (jumps_is_empty total) ;
lambda
end
@@ -2702,14 +2792,14 @@ let do_for_multiple_match loc paraml pat_act_list partial =
(* #PR4828: Believe it or not, the 'paraml' argument below
may not be side effect free. *)
-let arg_to_var arg cls = match arg with
-| Lvar v -> v,arg
-| _ ->
+let arg_to_var arg cls = match arg.l_desc with
+ | Lvar v -> v,arg
+ | _ ->
let v = name_pattern "match" cls in
- v,Lvar v
+ v, {l_loc = arg.l_loc; l_desc = Lvar v}
-let rec param_to_var param = match param with
+let rec param_to_var param = match param.l_desc with
| Lvar v -> v,None
| _ -> Ident.create "match",Some param
@@ -2719,6 +2809,6 @@ let bind_opt (v,eo) k = match eo with
let for_multiple_match loc paraml pat_act_list partial =
let v_paraml = List.map param_to_var paraml in
- let paraml = List.map (fun (v,_) -> Lvar v) v_paraml in
+ let paraml = List.map (fun (v,_) -> {l_loc = loc; l_desc = Lvar v}) v_paraml in
List.fold_right bind_opt v_paraml
(do_for_multiple_match loc paraml pat_act_list partial)
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index 38182db..a7465a0 100644
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -183,12 +183,15 @@ let primitive ppf = function
| Pbigarrayset(unsafe, n, kind, layout) ->
print_bigarray "set" unsafe kind ppf layout
-let rec lam ppf = function
+let rec lam ppf l =
+ lam_desc ppf l.l_desc
+
+and lam_desc ppf = function
| Lvar id ->
Ident.print ppf id
| Lconst cst ->
struct_const ppf cst
- | Lapply(lfun, largs, _) ->
+ | Lapply(lfun, largs) ->
let lams ppf largs =
List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs
@@ -211,11 +214,11 @@ let rec lam ppf = function
let rec letbody = function
| Llet(str, id, arg, body) ->
fprintf ppf "@ @[<2>%a@ %a@]" Ident.print id lam arg;
- letbody body
+ letbody body.l_desc
| expr -> expr in
fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a@ %a@]" Ident.print id lam arg;
- let expr = letbody body in
- fprintf ppf ")@]@ %a)@]" lam expr
+ let expr = letbody body.l_desc in
+ fprintf ppf ")@]@ %a)@]" lam_desc expr
| Lletrec(id_arg_list, body) ->
let bindings ppf id_arg_list =
let spc = ref false in
@@ -285,7 +288,7 @@ let rec lam ppf = function
lam hi lam body
| Lassign(id, expr) ->
fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr
- | Lsend (k, met, obj, largs, _) ->
+ | Lsend (k, met, obj, largs) ->
let args ppf largs =
List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
let kind =
@@ -304,11 +307,11 @@ let rec lam ppf = function
| Lifused(id, expr) ->
fprintf ppf "@[<2>(ifused@ %a@ %a)@]" Ident.print id lam expr
-and sequence ppf = function
+and sequence ppf l = match l.l_desc with
| Lsequence(l1, l2) ->
fprintf ppf "%a@ %a" sequence l1 sequence l2
| l ->
- lam ppf l
+ lam_desc ppf l
let structured_constant = struct_const
diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml
index e26524e..82b3388 100644
--- a/bytecomp/simplif.ml
+++ b/bytecomp/simplif.ml
@@ -22,31 +22,33 @@ open Lambda
exception Real_reference
-let rec eliminate_ref id = function
- Lvar v as lam ->
+let rec eliminate_ref id lam =
+ let mk = mk_loc_lam lam.l_loc in
+ match lam.l_desc with
+ Lvar v ->
if Ident.same v id then raise Real_reference else lam
- | Lconst cst as lam -> lam
- | Lapply(e1, el, loc) ->
- Lapply(eliminate_ref id e1, List.map (eliminate_ref id) el, loc)
- | Lfunction(kind, params, body) as lam ->
+ | Lconst cst -> lam
+ | Lapply(e1, el) ->
+ mk (Lapply(eliminate_ref id e1, List.map (eliminate_ref id) el))
+ | Lfunction(kind, params, body) ->
if IdentSet.mem id (free_variables lam)
then raise Real_reference
else lam
| Llet(str, v, e1, e2) ->
- Llet(str, v, eliminate_ref id e1, eliminate_ref id e2)
+ mk (Llet(str, v, eliminate_ref id e1, eliminate_ref id e2))
| Lletrec(idel, e2) ->
- Lletrec(List.map (fun (v, e) -> (v, eliminate_ref id e)) idel,
- eliminate_ref id e2)
- | Lprim(Pfield 0, [Lvar v]) when Ident.same v id ->
- Lvar id
- | Lprim(Psetfield(0, _), [Lvar v; e]) when Ident.same v id ->
- Lassign(id, eliminate_ref id e)
- | Lprim(Poffsetref delta, [Lvar v]) when Ident.same v id ->
- Lassign(id, Lprim(Poffsetint delta, [Lvar id]))
+ mk (Lletrec(List.map (fun (v, e) -> (v, eliminate_ref id e)) idel,
+ eliminate_ref id e2))
+ | Lprim(Pfield 0, [{l_desc=Lvar v}]) when Ident.same v id ->
+ mk (Lvar id)
+ | Lprim(Psetfield(0, _), [{l_desc=Lvar v}; e]) when Ident.same v id ->
+ mk (Lassign(id, eliminate_ref id e))
+ | Lprim(Poffsetref delta, [({l_desc=Lvar v} as lamv)]) when Ident.same v id ->
+ mk (Lassign(id, mk(Lprim(Poffsetint delta, [mk_loc_lam lamv.l_loc (Lvar id)]))))
| Lprim(p, el) ->
- Lprim(p, List.map (eliminate_ref id) el)
+ mk (Lprim(p, List.map (eliminate_ref id) el))
| Lswitch(e, sw) ->
- Lswitch(eliminate_ref id e,
+ mk (Lswitch(eliminate_ref id e,
{sw_numconsts = sw.sw_numconsts;
sw_consts =
List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_consts;
@@ -55,33 +57,33 @@ let rec eliminate_ref id = function
List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_blocks;
sw_failaction = match sw.sw_failaction with
| None -> None
- | Some l -> Some (eliminate_ref id l)})
+ | Some l -> Some (eliminate_ref id l)}))
| Lstaticraise (i,args) ->
- Lstaticraise (i,List.map (eliminate_ref id) args)
+ mk (Lstaticraise (i,List.map (eliminate_ref id) args))
| Lstaticcatch(e1, i, e2) ->
- Lstaticcatch(eliminate_ref id e1, i, eliminate_ref id e2)
+ mk (Lstaticcatch(eliminate_ref id e1, i, eliminate_ref id e2))
| Ltrywith(e1, v, e2) ->
- Ltrywith(eliminate_ref id e1, v, eliminate_ref id e2)
+ mk (Ltrywith(eliminate_ref id e1, v, eliminate_ref id e2))
| Lifthenelse(e1, e2, e3) ->
- Lifthenelse(eliminate_ref id e1,
- eliminate_ref id e2,
- eliminate_ref id e3)
+ mk (Lifthenelse(eliminate_ref id e1,
+ eliminate_ref id e2,
+ eliminate_ref id e3))
| Lsequence(e1, e2) ->
- Lsequence(eliminate_ref id e1, eliminate_ref id e2)
+ mk (Lsequence(eliminate_ref id e1, eliminate_ref id e2))
| Lwhile(e1, e2) ->
- Lwhile(eliminate_ref id e1, eliminate_ref id e2)
+ mk (Lwhile(eliminate_ref id e1, eliminate_ref id e2))
| Lfor(v, e1, e2, dir, e3) ->
- Lfor(v, eliminate_ref id e1, eliminate_ref id e2,
- dir, eliminate_ref id e3)
+ mk (Lfor(v, eliminate_ref id e1, eliminate_ref id e2,
+ dir, eliminate_ref id e3))
| Lassign(v, e) ->
- Lassign(v, eliminate_ref id e)
- | Lsend(k, m, o, el, loc) ->
- Lsend(k, eliminate_ref id m, eliminate_ref id o,
- List.map (eliminate_ref id) el, loc)
+ mk (Lassign(v, eliminate_ref id e))
+ | Lsend(k, m, o, el) ->
+ mk (Lsend(k, eliminate_ref id m, eliminate_ref id o,
+ List.map (eliminate_ref id) el))
| Levent(l, ev) ->
- Levent(eliminate_ref id l, ev)
+ mk (Levent(eliminate_ref id l, ev))
| Lifused(v, e) ->
- Lifused(v, eliminate_ref id e)
+ mk (Lifused(v, eliminate_ref id e))
(* Simplification of exits *)
@@ -102,9 +104,9 @@ let simplify_exits lam =
with
| Not_found -> Hashtbl.add exits i (ref 1) in
- let rec count = function
+ let rec count lam = match lam.l_desc with
| (Lvar _| Lconst _) -> ()
- | Lapply(l1, ll, _) -> count l1; List.iter count ll
+ | Lapply(l1, ll) -> count l1; List.iter count ll
| Lfunction(kind, params, l) -> count l
| Llet(str, v, l1, l2) ->
count l2; count l1
@@ -118,7 +120,7 @@ let simplify_exits lam =
List.iter (fun (_, l) -> count l) sw.sw_consts;
List.iter (fun (_, l) -> count l) sw.sw_blocks
| Lstaticraise (i,ls) -> incr_exit i ; List.iter count ls
- | Lstaticcatch (l1,(i,[]),Lstaticraise (j,[])) ->
+ | Lstaticcatch (l1,(i,[]),{l_desc=Lstaticraise (j,[])}) ->
(* i will be replaced by j in l1, so each occurence of i in l1
increases j's ref count *)
count l1 ;
@@ -144,7 +146,7 @@ let simplify_exits lam =
(* Lalias-bound variables are never assigned, so don't increase
v's refcount *)
count l
- | Lsend(k, m, o, ll, _) -> List.iter count (m::o::ll)
+ | Lsend(k, m, o, ll) -> List.iter count (m::o::ll)
| Levent(l, _) -> count l
| Lifused(v, l) -> count l
@@ -183,14 +185,16 @@ let simplify_exits lam =
let subst = Hashtbl.create 17 in
- let rec simplif = function
- | (Lvar _|Lconst _) as l -> l
- | Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc)
- | Lfunction(kind, params, l) -> Lfunction(kind, params, simplif l)
- | Llet(kind, v, l1, l2) -> Llet(kind, v, simplif l1, simplif l2)
+ let rec simplif lam =
+ let mk = mk_loc_lam lam.l_loc in
+ match lam.l_desc with
+ | (Lvar _|Lconst _) -> lam
+ | Lapply(l1, ll) -> mk (Lapply(simplif l1, List.map simplif ll))
+ | Lfunction(kind, params, l) -> mk (Lfunction(kind, params, simplif l))
+ | Llet(kind, v, l1, l2) -> mk (Llet(kind, v, simplif l1, simplif l2))
| Lletrec(bindings, body) ->
- Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body)
- | Lprim(p, ll) -> Lprim(p, List.map simplif ll)
+ mk (Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body))
+ | Lprim(p, ll) -> mk (Lprim(p, List.map simplif ll))
| Lswitch(l, sw) ->
let new_l = simplif l
and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts
@@ -198,16 +202,16 @@ let simplify_exits lam =
and new_fail = match sw.sw_failaction with
| None -> None
| Some l -> Some (simplif l) in
- Lswitch
+ mk (Lswitch
(new_l,
{sw with sw_consts = new_consts ; sw_blocks = new_blocks;
- sw_failaction = new_fail})
- | Lstaticraise (i,[]) as l ->
+ sw_failaction = new_fail}))
+ | Lstaticraise (i,[]) ->
begin try
let _,handler = Hashtbl.find subst i in
handler
with
- | Not_found -> l
+ | Not_found -> lam
end
| Lstaticraise (i,ls) ->
let ls = List.map simplif ls in
@@ -216,18 +220,18 @@ let simplify_exits lam =
let ys = List.map Ident.rename xs in
let env =
List.fold_right2
- (fun x y t -> Ident.add x (Lvar y) t)
+ (fun x y t -> Ident.add x (mk_lam (Lvar y)) t)
xs ys Ident.empty in
List.fold_right2
- (fun y l r -> Llet (Alias, y, l, r))
+ (fun y l r -> mk_lam (Llet (Alias, y, l, r)))
ys ls (Lambda.subst_lambda env handler)
with
- | Not_found -> Lstaticraise (i,ls)
+ | Not_found -> mk (Lstaticraise (i,ls))
end
- | Lstaticcatch (l1,(i,[]),(Lstaticraise (j,[]) as l2)) ->
+ | Lstaticcatch (l1,(i,[]),({l_desc=Lstaticraise (j,[])} as l2)) ->
Hashtbl.add subst i ([],simplif l2) ;
simplif l1
- | Lstaticcatch (l1,(i,xs), (Lvar _ as l2)) ->
+ | Lstaticcatch (l1,(i,xs), ({l_desc=Lvar _} as l2)) ->
begin match count_exit i with
| 0 -> simplif l1
| _ ->
@@ -241,18 +245,18 @@ let simplify_exits lam =
Hashtbl.add subst i (xs,simplif l2) ;
simplif l1
| _ ->
- Lstaticcatch (simplif l1, (i,xs), simplif l2)
+ mk (Lstaticcatch (simplif l1, (i,xs), simplif l2))
end
- | Ltrywith(l1, v, l2) -> Ltrywith(simplif l1, v, simplif l2)
- | Lifthenelse(l1, l2, l3) -> Lifthenelse(simplif l1, simplif l2, simplif l3)
- | Lsequence(l1, l2) -> Lsequence(simplif l1, simplif l2)
- | Lwhile(l1, l2) -> Lwhile(simplif l1, simplif l2)
+ | Ltrywith(l1, v, l2) -> mk (Ltrywith(simplif l1, v, simplif l2))
+ | Lifthenelse(l1, l2, l3) -> mk (Lifthenelse(simplif l1, simplif l2, simplif l3))
+ | Lsequence(l1, l2) -> mk (Lsequence(simplif l1, simplif l2))
+ | Lwhile(l1, l2) -> mk (Lwhile(simplif l1, simplif l2))
| Lfor(v, l1, l2, dir, l3) ->
- Lfor(v, simplif l1, simplif l2, dir, simplif l3)
- | Lassign(v, l) -> Lassign(v, simplif l)
- | Lsend(k, m, o, ll, loc) -> Lsend(k, simplif m, simplif o, List.map simplif ll, loc)
- | Levent(l, ev) -> Levent(simplif l, ev)
- | Lifused(v, l) -> Lifused (v,simplif l)
+ mk (Lfor(v, simplif l1, simplif l2, dir, simplif l3))
+ | Lassign(v, l) -> mk (Lassign(v, simplif l))
+ | Lsend(k, m, o, ll) -> mk (Lsend(k, simplif m, simplif o, List.map simplif ll))
+ | Levent(l, ev) -> mk (Levent(simplif l, ev))
+ | Lifused(v, l) -> mk (Lifused (v,simplif l))
in
simplif lam
@@ -299,15 +303,15 @@ let simplify_lets lam =
(* Not a let-bound variable, ignore *)
() in
- let rec count bv = function
+ let rec count bv lam = match lam.l_desc with
| Lconst cst -> ()
| Lvar v ->
use_var bv v 1
- | Lapply(l1, ll, _) ->
+ | Lapply(l1, ll) ->
count bv l1; List.iter (count bv) ll
| Lfunction(kind, params, l) ->
count Tbl.empty l
- | Llet(str, v, Lvar w, l2) when not !Clflags.debug ->
+ | Llet(str, v, {l_desc=Lvar w}, l2) when not !Clflags.debug ->
(* v will be replaced by w in l2, so each occurrence of v in l2
increases w's refcount *)
count (bind_var bv v) l2;
@@ -336,7 +340,7 @@ let simplify_lets lam =
(* Lalias-bound variables are never assigned, so don't increase
v's refcount *)
count bv l
- | Lsend(_, m, o, ll, _) -> List.iter (count bv) (m::o::ll)
+ | Lsend(_, m, o, ll) -> List.iter (count bv) (m::o::ll)
| Levent(l, _) -> count bv l
| Lifused(v, l) ->
if count_var v > 0 then count bv l
@@ -366,38 +370,40 @@ let simplify_lets lam =
(* This (small) optimisation is always legal, it may uncover some
tail call later on. *)
- let mklet (kind,v,e1,e2) = match e2 with
+ let mklet (kind,v,e1,e2) = match e2.l_desc with
| Lvar w when optimize && Ident.same v w -> e1
- | _ -> Llet (kind,v,e1,e2) in
+ | _ -> mk_lam (Llet (kind,v,e1,e2)) in
- let rec simplif = function
- Lvar v as l ->
+ let rec simplif lam =
+ let mk = mk_loc_lam lam.l_loc in
+ match lam.l_desc with
+ Lvar v ->
begin try
Hashtbl.find subst v
with Not_found ->
- l
+ lam
end
- | Lconst cst as l -> l
- | Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc)
- | Lfunction(kind, params, l) -> Lfunction(kind, params, simplif l)
- | Llet(str, v, Lvar w, l2) when optimize ->
- Hashtbl.add subst v (simplif (Lvar w));
+ | Lconst cst -> lam
+ | Lapply(l1, ll) -> mk (Lapply(simplif l1, List.map simplif ll))
+ | Lfunction(kind, params, l) -> mk (Lfunction(kind, params, simplif l))
+ | Llet(str, v, ({l_desc=Lvar w} as lamw), l2) when optimize ->
+ Hashtbl.add subst v (simplif lamw);
simplif l2
- | Llet(Strict, v, Lprim(Pmakeblock(0, Mutable), [linit]), lbody)
+ | Llet(Strict, v, ({l_desc=Lprim(Pmakeblock(0, Mutable), [linit])} as l), lbody)
when optimize ->
let slinit = simplif linit in
let slbody = simplif lbody in
begin try
mklet (Variable, v, slinit, eliminate_ref v slbody)
with Real_reference ->
- mklet(Strict, v, Lprim(Pmakeblock(0, Mutable), [slinit]), slbody)
+ mklet(Strict, v, mk_loc_lam l.l_loc (Lprim(Pmakeblock(0, Mutable), [slinit])), slbody)
end
| Llet(Alias, v, l1, l2) ->
begin match count_var v with
0 -> simplif l2
| 1 when optimize -> Hashtbl.add subst v (simplif l1); simplif l2
- | n -> Llet(Alias, v, simplif l1, simplif l2)
+ | n -> mk (Llet(Alias, v, simplif l1, simplif l2))
end
| Llet(StrictOpt, v, l1, l2) ->
begin match count_var v with
@@ -406,8 +412,8 @@ let simplify_lets lam =
end
| Llet(kind, v, l1, l2) -> mklet(kind, v, simplif l1, simplif l2)
| Lletrec(bindings, body) ->
- Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body)
- | Lprim(p, ll) -> Lprim(p, List.map simplif ll)
+ mk (Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body))
+ | Lprim(p, ll) -> mk (Lprim(p, List.map simplif ll))
| Lswitch(l, sw) ->
let new_l = simplif l
and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts
@@ -415,27 +421,27 @@ let simplify_lets lam =
and new_fail = match sw.sw_failaction with
| None -> None
| Some l -> Some (simplif l) in
- Lswitch
+ mk (Lswitch
(new_l,
{sw with sw_consts = new_consts ; sw_blocks = new_blocks;
- sw_failaction = new_fail})
+ sw_failaction = new_fail}))
| Lstaticraise (i,ls) ->
- Lstaticraise (i, List.map simplif ls)
+ mk (Lstaticraise (i, List.map simplif ls))
| Lstaticcatch(l1, (i,args), l2) ->
- Lstaticcatch (simplif l1, (i,args), simplif l2)
- | Ltrywith(l1, v, l2) -> Ltrywith(simplif l1, v, simplif l2)
- | Lifthenelse(l1, l2, l3) -> Lifthenelse(simplif l1, simplif l2, simplif l3)
- | Lsequence(Lifused(v, l1), l2) ->
+ mk (Lstaticcatch (simplif l1, (i,args), simplif l2))
+ | Ltrywith(l1, v, l2) -> mk (Ltrywith(simplif l1, v, simplif l2))
+ | Lifthenelse(l1, l2, l3) -> mk (Lifthenelse(simplif l1, simplif l2, simplif l3))
+ | Lsequence({l_desc=Lifused(v, l1)}, l2) ->
if count_var v > 0
- then Lsequence(simplif l1, simplif l2)
+ then mk (Lsequence(simplif l1, simplif l2))
else simplif l2
- | Lsequence(l1, l2) -> Lsequence(simplif l1, simplif l2)
- | Lwhile(l1, l2) -> Lwhile(simplif l1, simplif l2)
+ | Lsequence(l1, l2) -> mk (Lsequence(simplif l1, simplif l2))
+ | Lwhile(l1, l2) -> mk (Lwhile(simplif l1, simplif l2))
| Lfor(v, l1, l2, dir, l3) ->
- Lfor(v, simplif l1, simplif l2, dir, simplif l3)
- | Lassign(v, l) -> Lassign(v, simplif l)
- | Lsend(k, m, o, ll, loc) -> Lsend(k, simplif m, simplif o, List.map simplif ll, loc)
- | Levent(l, ev) -> Levent(simplif l, ev)
+ mk (Lfor(v, simplif l1, simplif l2, dir, simplif l3))
+ | Lassign(v, l) -> mk (Lassign(v, simplif l))
+ | Lsend(k, m, o, ll) -> mk (Lsend(k, simplif m, simplif o, List.map simplif ll))
+ | Levent(l, ev) -> mk (Levent(simplif l, ev))
| Lifused(v, l) ->
if count_var v > 0 then simplif l else lambda_unit
in
@@ -453,12 +459,12 @@ let rec emit_tail_infos is_tail lambda =
|| (!is_tail_native_heuristic (List.length args)))
then Annot.Tail
else Annot.Stack in
- match lambda with
+ match lambda.l_desc with
| Lvar _ -> ()
| Lconst _ -> ()
- | Lapply (func, l, loc) ->
+ | Lapply (func, l) ->
list_emit_tail_infos false l;
- Stypes.record (Stypes.An_call (loc, call_kind l))
+ Stypes.record (Stypes.An_call (lambda.l_loc, call_kind l))
| Lfunction (_, _, lam) ->
emit_tail_infos true lam
| Llet (_, _, lam, body) ->
@@ -503,11 +509,11 @@ let rec emit_tail_infos is_tail lambda =
emit_tail_infos false body
| Lassign (_, lam) ->
emit_tail_infos false lam
- | Lsend (_, meth, obj, args, loc) ->
+ | Lsend (_, meth, obj, args) ->
emit_tail_infos false meth;
emit_tail_infos false obj;
list_emit_tail_infos false args;
- Stypes.record (Stypes.An_call (loc, call_kind (obj :: args)))
+ Stypes.record (Stypes.An_call (lambda.l_loc, call_kind (obj :: args)))
| Levent (lam, _) ->
emit_tail_infos is_tail lam
| Lifused (_, lam) ->
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index f06e43b..2217a60 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -28,55 +28,67 @@ exception Error of Location.t * error
let lfunction params body =
if params = [] then body else
- match body with
- Lfunction (Curried, params', body') ->
- Lfunction (Curried, params @ params', body')
- | _ ->
- Lfunction (Curried, params, body)
+ mk_lam
+ begin match body.l_desc with
+ | Lfunction (Curried, params', body') ->
+ Lfunction (Curried, params @ params', body')
+ | _ ->
+ Lfunction (Curried, params, body)
+ end
let lapply func args loc =
- match func with
- Lapply(func', args', _) ->
- Lapply(func', args' @ args, loc)
- | _ ->
- Lapply(func, args, loc)
+ mk_loc_lam loc
+ begin match func.l_desc with
+ | Lapply(func', args') -> Lapply(func', args' @ args)
+ | _ -> Lapply(func, args)
+ end
-let mkappl (func, args) = Lapply (func, args, Location.none);;
+let mkappl (func, args) =
+ mk_lam (Lapply (func, args))
let lsequence l1 l2 =
- if l2 = lambda_unit then l1 else Lsequence(l1, l2)
+ if l2 = lambda_unit then
+ l1
+ else
+ mk_lam (Lsequence(l1, l2))
-let lfield v i = Lprim(Pfield i, [Lvar v])
+let lfield v i =
+ mk_lam (Lprim(Pfield i, [mk_lam (Lvar v)]))
let transl_label l = share (Const_immstring l)
-let rec transl_meth_list lst =
- if lst = [] then Lconst (Const_pointer 0) else
+let transl_meth_list lst =
+ if lst = [] then mk_lam (Lconst (Const_pointer 0)) else
share (Const_block
(0, List.map (fun lab -> Const_immstring lab) lst))
let set_inst_var obj id expr =
let kind = if Typeopt.maybe_pointer expr then Paddrarray else Pintarray in
- Lprim(Parraysetu kind, [Lvar obj; Lvar id; transl_exp expr])
+ mk_lam (Lprim(Parraysetu kind, [mk_lam (Lvar obj); mk_lam (Lvar id); transl_exp expr]))
let copy_inst_var obj id expr templ offset =
let kind = if Typeopt.maybe_pointer expr then Paddrarray else Pintarray in
let id' = Ident.create (Ident.name id) in
- Llet(Strict, id', Lprim (Pidentity, [Lvar id]),
- Lprim(Parraysetu kind,
- [Lvar obj; Lvar id';
- Lprim(Parrayrefu kind, [Lvar templ; Lprim(Paddint,
- [Lvar id';
- Lvar offset])])]))
+ mk_lam (Llet(Strict, id',
+ mk_lam (Lprim (Pidentity, [mk_lam (Lvar id)])),
+ mk_lam (Lprim(Parraysetu kind,
+ [mk_lam (Lvar obj);
+ mk_lam (Lvar id');
+ mk_lam (Lprim(Parrayrefu kind,
+ [mk_lam (Lvar templ);
+ mk_lam (Lprim(Paddint,
+ [mk_lam (Lvar id');
+ mk_lam (Lvar offset);
+ ]))]))]))))
let transl_val tbl create name =
mkappl (oo_prim (if create then "new_variable" else "get_variable"),
- [Lvar tbl; transl_label name])
+ [mk_lam (Lvar tbl); transl_label name])
let transl_vals tbl create strict vals rem =
List.fold_right
(fun (name, id) rem ->
- Llet(strict, id, transl_val tbl create name, rem))
+ mk_lam (Llet(strict, id, transl_val tbl create name, rem)))
vals rem
let meths_super tbl meths inh_meths =
@@ -84,14 +96,15 @@ let meths_super tbl meths inh_meths =
(fun (nm, id) rem ->
try
(nm, id,
- mkappl(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)]))
+ mkappl(oo_prim "get_method", [mk_lam (Lvar tbl);
+ mk_lam (Lvar (Meths.find nm meths))]))
:: rem
with Not_found -> rem)
inh_meths []
let bind_super tbl (vals, meths) cl_init =
transl_vals tbl false StrictOpt vals
- (List.fold_right (fun (nm, id, def) rem -> Llet(StrictOpt, id, def, rem))
+ (List.fold_right (fun (nm, id, def) rem -> mk_lam (Llet(StrictOpt, id, def, rem)))
meths cl_init)
let create_object cl obj init =
@@ -101,15 +114,19 @@ let create_object cl obj init =
(inh_init,
mkappl (oo_prim (if has_init then "create_object_and_run_initializers"
else"create_object_opt"),
- [obj; Lvar cl]))
+ [obj; mk_lam (Lvar cl)]))
else begin
(inh_init,
- Llet(Strict, obj',
- mkappl (oo_prim "create_object_opt", [obj; Lvar cl]),
- Lsequence(obj_init,
- if not has_init then Lvar obj' else
- mkappl (oo_prim "run_initializers_opt",
- [obj; Lvar obj'; Lvar cl]))))
+ mk_lam (Llet(Strict, obj',
+ mkappl (oo_prim "create_object_opt", [obj; mk_lam (Lvar cl)]),
+ mk_lam (Lsequence(obj_init,
+ if not has_init then
+ mk_lam (Lvar obj')
+ else
+ mkappl (oo_prim "run_initializers_opt",
+ [obj;
+ mk_lam (Lvar obj');
+ mk_lam (Lvar cl)]))))))
end
let rec build_object_init cl_table obj params inh_init obj_init cl =
@@ -119,10 +136,10 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
let envs, inh_init = inh_init in
let env =
match envs with None -> []
- | Some envs -> [Lprim(Pfield (List.length inh_init + 1), [Lvar envs])]
+ | Some envs -> [mk_lam (Lprim(Pfield (List.length inh_init + 1), [mk_lam (Lvar envs)]))]
in
((envs, (obj_init, path)::inh_init),
- mkappl(Lvar obj_init, env @ [obj]))
+ mkappl(mk_lam (Lvar obj_init), env @ [obj]))
| Tclass_structure str ->
create_object cl_table obj (fun obj ->
let (inh_init, obj_init, has_init) =
@@ -131,7 +148,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
match field with
Cf_inher (cl, _, _) ->
let (inh_init, obj_init') =
- build_object_init cl_table (Lvar obj) [] inh_init
+ build_object_init cl_table (mk_lam (Lvar obj)) [] inh_init
(fun _ -> lambda_unit) cl
in
(inh_init, lsequence obj_init' obj_init, true)
@@ -147,7 +164,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
Translcore.transl_let rec_flag defs
(List.fold_right
(fun (id, expr) rem ->
- lsequence (Lifused(id, set_inst_var obj id expr))
+ lsequence (mk_lam (Lifused(id, set_inst_var obj id expr)))
rem)
vals obj_init),
has_init))
@@ -157,7 +174,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
(inh_init,
List.fold_right
(fun (id, expr) rem ->
- lsequence (Lifused (id, set_inst_var obj id expr)) rem)
+ lsequence (mk_lam (Lifused (id, set_inst_var obj id expr))) rem)
params obj_init,
has_init))
| Tclass_fun (pat, vals, cl, partial) ->
@@ -167,13 +184,13 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
(inh_init,
let build params rem =
let param = name_pattern "param" [pat, ()] in
- Lfunction (Curried, param::params,
+ mk_lam (Lfunction (Curried, param::params,
Matching.for_function
- pat.pat_loc None (Lvar param) [pat, rem] partial)
+ pat.pat_loc None (mk_lam (Lvar param)) [pat, rem] partial))
in
- begin match obj_init with
+ begin match obj_init.l_desc with
Lfunction (Curried, params, rem) -> build params rem
- | rem -> build [] rem
+ | _ -> build [] obj_init
end)
| Tclass_apply (cl, oexprs) ->
let (inh_init, obj_init) =
@@ -195,7 +212,7 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env top ids =
| _ ->
let self = Ident.create "self" in
let env = Ident.create "env" in
- let obj = if ids = [] then lambda_unit else Lvar self in
+ let obj = if ids = [] then lambda_unit else mk_lam (Lvar self) in
let envs = if top then None else Some env in
let ((_,inh_init), obj_init) =
build_object_init cl_table obj params (envs,[]) (copy_env env) cl in
@@ -205,9 +222,9 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env top ids =
let bind_method tbl lab id cl_init =
- Llet(Strict, id, mkappl (oo_prim "get_method_label",
- [Lvar tbl; transl_label lab]),
- cl_init)
+ mk_lam (Llet(Strict, id, mkappl (oo_prim "get_method_label",
+ [mk_lam (Lvar tbl); transl_label lab]),
+ cl_init))
let bind_methods tbl meths vals cl_init =
let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in
@@ -220,21 +237,22 @@ let bind_methods tbl meths vals cl_init =
if nvals = 0 then "get_method_labels", [] else
"new_methods_variables", [transl_meth_list (List.map fst vals)]
in
- Llet(Strict, ids,
- mkappl (oo_prim getter,
- [Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
- List.fold_right
- (fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam))
- (methl @ vals) cl_init)
+ mk_lam (Llet(Strict, ids,
+ mkappl (oo_prim getter,
+ [mk_lam (Lvar tbl); transl_meth_list (List.map fst methl)] @ names),
+ List.fold_right
+ (fun (lab,id) lam -> decr i; mk_lam (Llet(StrictOpt, id, lfield ids !i, lam)))
+ (methl @ vals) cl_init))
let output_methods tbl methods lam =
match methods with
[] -> lam
| [lab; code] ->
- lsequence (mkappl(oo_prim "set_method", [Lvar tbl; lab; code])) lam
+ lsequence (mkappl(oo_prim "set_method", [mk_lam (Lvar tbl); lab; code])) lam
| _ ->
lsequence (mkappl(oo_prim "set_methods",
- [Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)]))
+ [mk_lam (Lvar tbl);
+ mk_lam (Lprim(Pmakeblock(0,Immutable), methods))]))
lam
let rec ignore_cstrs cl =
@@ -257,10 +275,15 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
(obj_init, path')::inh_init ->
let lpath = transl_path path in
(inh_init,
- Llet (Strict, obj_init,
- mkappl(Lprim(Pfield 1, [lpath]), Lvar cla ::
- if top then [Lprim(Pfield 3, [lpath])] else []),
- bind_super cla super cl_init))
+ mk_lam (Llet (Strict, obj_init,
+ mkappl(
+ mk_lam (Lprim(Pfield 1, [lpath])),
+ mk_lam (Lvar cla) ::
+ if top then
+ [mk_lam (Lprim(Pfield 3, [lpath]))]
+ else
+ []),
+ bind_super cla super cl_init)))
| _ ->
assert false
end
@@ -286,11 +309,11 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
if !Clflags.native_code && List.length met_code = 1 then
(* Force correct naming of method for profiles *)
let met = Ident.create ("method_" ^ name) in
- [Llet(Strict, met, List.hd met_code, Lvar met)]
+ [mk_lam (Llet(Strict, met, List.hd met_code, mk_lam (Lvar met)))]
else met_code
in
(inh_init, cl_init,
- Lvar (Meths.find name str.cl_meths) :: met_code @ methods,
+ mk_lam (Lvar (Meths.find name str.cl_meths)) :: met_code @ methods,
values)
| Cf_let (rec_flag, defs, vals) ->
let vals =
@@ -299,9 +322,10 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
(inh_init, cl_init, methods, vals @ values)
| Cf_init exp ->
(inh_init,
- Lsequence(mkappl (oo_prim "add_initializer",
- Lvar cla :: msubst false (transl_exp exp)),
- cl_init),
+ mk_lam (Lsequence(mkappl (oo_prim "add_initializer",
+ mk_lam (Lvar cla) ::
+ msubst false (transl_exp exp)),
+ cl_init)),
methods, values))
str.cl_field
(inh_init, cl_init, [], [])
@@ -327,7 +351,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in
let concr_meths = Concr.elements concr_meths in
let narrow_args =
- [Lvar cla;
+ [mk_lam (Lvar cla);
transl_meth_list vals;
transl_meth_list virt_meths;
transl_meth_list concr_meths] in
@@ -342,30 +366,31 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
let cl_init =
List.fold_left
(fun init (nm, id, _) ->
- Llet(StrictOpt, id, lfield inh (index nm concr_meths + ofs),
- init))
+ mk_lam (Llet(StrictOpt, id, lfield inh (index nm concr_meths + ofs),
+ init)))
cl_init methids in
let cl_init =
List.fold_left
(fun init (nm, id) ->
- Llet(StrictOpt, id, lfield inh (index nm vals + 1), init))
+ mk_lam (Llet(StrictOpt, id, lfield inh (index nm vals + 1), init)))
cl_init valids in
(inh_init,
- Llet (Strict, inh,
- mkappl(oo_prim "inherits", narrow_args @
- [lpath; Lconst(Const_pointer(if top then 1 else 0))]),
- Llet(StrictOpt, obj_init, lfield inh 0, cl_init)))
+ mk_lam (Llet (Strict, inh,
+ mkappl(oo_prim "inherits", narrow_args @
+ [lpath;
+ mk_lam (Lconst(Const_pointer(if top then 1 else 0)))]),
+ mk_lam (Llet(StrictOpt, obj_init, lfield inh 0, cl_init)))))
| _ ->
let core cl_init =
build_class_init cla true super inh_init cl_init msubst top cl
in
if cstr then core cl_init else
let (inh_init, cl_init) =
- core (Lsequence (mkappl (oo_prim "widen", [Lvar cla]), cl_init))
+ core (mk_lam (Lsequence (mkappl (oo_prim "widen", [mk_lam (Lvar cla)]), cl_init)))
in
(inh_init,
- Lsequence(mkappl (oo_prim "narrow", narrow_args),
- cl_init))
+ mk_lam (Lsequence(mkappl (oo_prim "narrow", narrow_args),
+ cl_init)))
end
let rec build_class_lets cl =
@@ -402,14 +427,14 @@ let rec transl_class_rebind obj_init cl vf =
let path, obj_init = transl_class_rebind obj_init cl vf in
let build params rem =
let param = name_pattern "param" [pat, ()] in
- Lfunction (Curried, param::params,
+ mk_lam (Lfunction (Curried, param::params,
Matching.for_function
- pat.pat_loc None (Lvar param) [pat, rem] partial)
+ pat.pat_loc None (mk_lam (Lvar param)) [pat, rem] partial))
in
(path,
- match obj_init with
+ match obj_init.l_desc with
Lfunction (Curried, params, rem) -> build params rem
- | rem -> build [] rem)
+ | _ -> build [] obj_init)
| Tclass_apply (cl, oexprs) ->
let path, obj_init = transl_class_rebind obj_init cl vf in
(path, transl_apply obj_init oexprs Location.none)
@@ -440,7 +465,7 @@ let transl_class_rebind ids cl vf =
try
let obj_init = Ident.create "obj_init"
and self = Ident.create "self" in
- let obj_init0 = lapply (Lvar obj_init) [Lvar self] Location.none in
+ let obj_init0 = lapply (mk_lam (Lvar obj_init)) [mk_lam (Lvar self)] Location.none in
let path, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in
if not (Translcore.check_recursive_lambda ids obj_init') then
raise(Error(cl.cl_loc, Illegal_class_expr));
@@ -452,81 +477,82 @@ let transl_class_rebind ids cl vf =
and env_init = Ident.create "env_init"
and table = Ident.create "table"
and envs = Ident.create "envs" in
- Llet(
+ mk_lam (Llet(
Strict, new_init, lfunction [obj_init] obj_init',
- Llet(
+ mk_lam (Llet(
Alias, cla, transl_path path,
- Lprim(Pmakeblock(0, Immutable),
- [mkappl(Lvar new_init, [lfield cla 0]);
+ mk_lam (Lprim(Pmakeblock(0, Immutable),
+ [mkappl(mk_lam (Lvar new_init), [lfield cla 0]);
lfunction [table]
- (Llet(Strict, env_init,
- mkappl(lfield cla 1, [Lvar table]),
+ (mk_lam (Llet(Strict, env_init,
+ mkappl(lfield cla 1, [mk_lam (Lvar table)]),
lfunction [envs]
- (mkappl(Lvar new_init,
- [mkappl(Lvar env_init, [Lvar envs])]))));
+ (mkappl(mk_lam (Lvar new_init),
+ [mkappl(mk_lam (Lvar env_init), [mk_lam (Lvar envs)])]
+ )))));
lfield cla 2;
- lfield cla 3])))
+ lfield cla 3]))))))
with Exit ->
lambda_unit
(* Rewrite a closure using builtins. Improves native code size. *)
-let rec module_path = function
+let rec module_path l = match l.l_desc with
Lvar id ->
let s = Ident.name id in s <> "" && s.[0] >= 'A' && s.[0] <= 'Z'
| Lprim(Pfield _, [p]) -> module_path p
| Lprim(Pgetglobal _, []) -> true
| _ -> false
-let const_path local = function
+let const_path local l = match l.l_desc with
Lvar id -> not (List.mem id local)
| Lconst _ -> true
| Lfunction (Curried, _, body) ->
let fv = free_variables body in
List.for_all (fun x -> not (IdentSet.mem x fv)) local
- | p -> module_path p
+ | _ -> module_path l
let rec builtin_meths self env env2 body =
let const_path = const_path (env::self) in
- let conv = function
+ let conv l = match l.l_desc with
(* Lvar s when List.mem s self -> "_self", [] *)
- | p when const_path p -> "const", [p]
- | Lprim(Parrayrefu _, [Lvar s; Lvar n]) when List.mem s self ->
- "var", [Lvar n]
- | Lprim(Pfield n, [Lvar e]) when Ident.same e env ->
- "env", [Lvar env2; Lconst(Const_pointer n)]
- | Lsend(Self, met, Lvar s, [], _) when List.mem s self ->
+ | _ when const_path l -> "const", [l]
+ | Lprim(Parrayrefu _, [{l_desc=Lvar s}; {l_desc=Lvar n}]) when List.mem s self ->
+ "var", [mk_lam (Lvar n)]
+ | Lprim(Pfield n, [{l_desc=Lvar e}]) when Ident.same e env ->
+ "env", [mk_lam (Lvar env2); mk_lam (Lconst(Const_pointer n))]
+ | Lsend(Self, met, {l_desc=Lvar s}, []) when List.mem s self ->
"meth", [met]
| _ -> raise Not_found
in
- match body with
- | Llet(_, s', Lvar s, body) when List.mem s self ->
+ match body.l_desc with
+ | Llet(_, s', {l_desc=Lvar s}, body) when List.mem s self ->
builtin_meths (s'::self) env env2 body
- | Lapply(f, [arg], _) when const_path f ->
+ | Lapply(f, [arg]) when const_path f ->
let s, args = conv arg in ("app_"^s, f :: args)
- | Lapply(f, [arg; p], _) when const_path f && const_path p ->
+ | Lapply(f, [arg; p]) when const_path f && const_path p ->
let s, args = conv arg in
("app_"^s^"_const", f :: args @ [p])
- | Lapply(f, [p; arg], _) when const_path f && const_path p ->
+ | Lapply(f, [p; arg]) when const_path f && const_path p ->
let s, args = conv arg in
("app_const_"^s, f :: p :: args)
- | Lsend(Self, Lvar n, Lvar s, [arg], _) when List.mem s self ->
+ | Lsend(Self, {l_desc=Lvar n}, {l_desc=Lvar s}, [arg]) when List.mem s self ->
let s, args = conv arg in
- ("meth_app_"^s, Lvar n :: args)
- | Lsend(Self, met, Lvar s, [], _) when List.mem s self ->
+ ("meth_app_"^s, mk_lam (Lvar n) :: args)
+ | Lsend(Self, met, {l_desc=Lvar s}, []) when List.mem s self ->
("get_meth", [met])
- | Lsend(Public, met, arg, [], _) ->
+ | Lsend(Public, met, arg, []) ->
let s, args = conv arg in
("send_"^s, met :: args)
- | Lsend(Cached, met, arg, [_;_], _) ->
+ | Lsend(Cached, met, arg, [_;_]) ->
let s, args = conv arg in
("send_"^s, met :: args)
| Lfunction (Curried, [x], body) ->
- let rec enter self = function
- | Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'])
+ let rec enter self l = match l.l_desc with
+ | Lprim(Parraysetu _, [{l_desc=Lvar s}; {l_desc=Lvar n}; {l_desc=Lvar x'}])
when Ident.same x x' && List.mem s self ->
- ("set_var", [Lvar n])
- | Llet(_, s', Lvar s, body) when List.mem s self ->
+ ("set_var", [mk_lam (Lvar n)])
+ | Llet(_, s', {l_desc=Lvar s}, body) when List.mem s self ->
enter (s'::self) body
| _ -> raise Not_found
in enter self body
@@ -565,7 +591,7 @@ module M = struct
| "send_env" -> SendEnv
| "send_meth" -> SendMeth
| _ -> assert false
- in Lconst(Const_pointer(Obj.magic tag)) :: args
+ in mk_lam (Lconst(Const_pointer(Obj.magic tag))) :: args
end
open M
@@ -628,7 +654,7 @@ let transl_class ids cl_id arity pub_meths cl vflag =
Ident.empty !new_ids'
in
let new_ids_meths = ref [] in
- let msubst arr = function
+ let msubst arr l = match l.l_desc with
Lfunction (Curried, self :: args, body) ->
let env = Ident.create "env" in
let body' =
@@ -642,9 +668,11 @@ let transl_class ids cl_id arity pub_meths cl vflag =
with Not_found ->
[lfunction (self :: args)
(if not (IdentSet.mem env (free_variables body')) then body' else
- Llet(Alias, env,
- Lprim(Parrayrefu Paddrarray,
- [Lvar self; Lvar env2]), body'))]
+ mk_lam (Llet(Alias, env,
+ mk_lam (Lprim(Parrayrefu Paddrarray,
+ [mk_lam (Lvar self);
+ mk_lam (Lvar env2)])),
+ body')))]
end
| _ -> assert false
in
@@ -652,16 +680,26 @@ let transl_class ids cl_id arity pub_meths cl vflag =
let env1 = Ident.create "env" and env1' = Ident.create "env'" in
let copy_env envs self =
if top then lambda_unit else
- Lifused(env2, Lprim(Parraysetu Paddrarray,
- [Lvar self; Lvar env2; Lvar env1']))
+ mk_lam (Lifused(env2,
+ mk_lam (Lprim(Parraysetu Paddrarray,
+ [mk_lam (Lvar self);
+ mk_lam (Lvar env2);
+ mk_lam (Lvar env1')]))))
and subst_env envs l lam =
if top then lam else
(* must be called only once! *)
let lam = subst_lambda (subst env1 lam 1 new_ids_init) lam in
- Llet(Alias, env1, (if l = [] then Lvar envs else lfield envs 0),
- Llet(Alias, env1',
- (if !new_ids_init = [] then Lvar env1 else lfield env1 0),
- lam))
+ mk_lam (Llet(Alias, env1,
+ (if l = [] then
+ mk_lam (Lvar envs)
+ else
+ lfield envs 0),
+ mk_lam(Llet(Alias, env1',
+ (if !new_ids_init = [] then
+ mk_lam (Lvar env1)
+ else
+ lfield env1 0),
+ lam))))
in
(* Now we start compiling the class *)
@@ -691,36 +729,39 @@ let transl_class ids cl_id arity pub_meths cl vflag =
if name' <> name then raise(Error(cl.cl_loc, Tags(name, name'))))
tags pub_meths;
let ltable table lam =
- Llet(Strict, table,
- mkappl (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
+ mk_lam (Llet(Strict, table,
+ mkappl (oo_prim "create_table", [transl_meth_list pub_meths]), lam))
and ldirect obj_init =
- Llet(Strict, obj_init, cl_init,
- Lsequence(mkappl (oo_prim "init_class", [Lvar cla]),
- mkappl (Lvar obj_init, [lambda_unit])))
+ mk_lam (Llet(Strict, obj_init, cl_init,
+ mk_lam (Lsequence(mkappl (oo_prim "init_class", [mk_lam (Lvar cla)]),
+ mkappl (mk_lam (Lvar obj_init), [lambda_unit])))))
in
(* Simplest case: an object defined at toplevel (ids=[]) *)
if top && ids = [] then llets (ltable cla (ldirect obj_init)) else
let concrete = (vflag = Concrete)
and lclass lam =
- let cl_init = llets (Lfunction(Curried, [cla], cl_init)) in
- Llet(Strict, class_init, cl_init, lam (free_variables cl_init))
+ let cl_init = llets (mk_lam (Lfunction(Curried, [cla], cl_init))) in
+ mk_lam (Llet(Strict, class_init, cl_init, lam (free_variables cl_init)))
and lbody fv =
if List.for_all (fun id -> not (IdentSet.mem id fv)) ids then
mkappl (oo_prim "make_class",[transl_meth_list pub_meths;
- Lvar class_init])
+ mk_lam (Lvar class_init)])
else
ltable table (
- Llet(
- Strict, env_init, mkappl (Lvar class_init, [Lvar table]),
- Lsequence(
- mkappl (oo_prim "init_class", [Lvar table]),
- Lprim(Pmakeblock(0, Immutable),
- [mkappl (Lvar env_init, [lambda_unit]);
- Lvar class_init; Lvar env_init; lambda_unit]))))
+ mk_lam (Llet(
+ Strict, env_init, mkappl (mk_lam (Lvar class_init), [mk_lam (Lvar table)]),
+ mk_lam (Lsequence(
+ mkappl (oo_prim "init_class", [mk_lam (Lvar table)]),
+ mk_lam (Lprim(Pmakeblock(0, Immutable),
+ [mkappl (mk_lam (Lvar env_init), [lambda_unit]);
+ mk_lam (Lvar class_init); mk_lam (Lvar env_init); lambda_unit]
+ )))))))
and lbody_virt lenvs =
- Lprim(Pmakeblock(0, Immutable),
- [lambda_unit; Lfunction(Curried,[cla], cl_init); lambda_unit; lenvs])
+ mk_lam (Lprim(Pmakeblock(0, Immutable),
+ [lambda_unit;
+ mk_lam (Lfunction(Curried,[cla], cl_init));
+ lambda_unit; lenvs]))
in
(* Still easy: a class defined at toplevel *)
if top && concrete then lclass lbody else
@@ -732,74 +773,80 @@ let transl_class ids cl_id arity pub_meths cl vflag =
let lenvs =
if !new_ids_meths = [] && !new_ids_init = [] && inh_init = []
then lambda_unit
- else Lvar envs in
+ else mk_lam (Lvar envs) in
let lenv =
let menv =
if !new_ids_meths = [] then lambda_unit else
- Lprim(Pmakeblock(0, Immutable),
- List.map (fun id -> Lvar id) !new_ids_meths) in
+ mk_lam (Lprim(Pmakeblock(0, Immutable),
+ List.map (fun id -> mk_lam (Lvar id)) !new_ids_meths)) in
if !new_ids_init = [] then menv else
- Lprim(Pmakeblock(0, Immutable),
- menv :: List.map (fun id -> Lvar id) !new_ids_init)
+ mk_lam (Lprim(Pmakeblock(0, Immutable),
+ menv :: List.map (fun id -> mk_lam (Lvar id)) !new_ids_init))
and linh_envs =
- List.map (fun (_, p) -> Lprim(Pfield 3, [transl_path p]))
+ List.map (fun (_, p) -> mk_lam (Lprim(Pfield 3, [transl_path p])))
(List.rev inh_init)
in
let make_envs lam =
- Llet(StrictOpt, envs,
- (if linh_envs = [] then lenv else
- Lprim(Pmakeblock(0, Immutable), lenv :: linh_envs)),
- lam)
+ mk_lam (Llet(StrictOpt, envs,
+ (if linh_envs = [] then
+ lenv
+ else
+ mk_lam (Lprim(Pmakeblock(0, Immutable), lenv :: linh_envs))),
+ lam))
and def_ids cla lam =
- Llet(StrictOpt, env2,
- mkappl (oo_prim "new_variable", [Lvar cla; transl_label ""]),
- lam)
+ mk_lam (Llet(StrictOpt, env2,
+ mkappl (oo_prim "new_variable", [mk_lam (Lvar cla); transl_label ""]),
+ lam))
in
let inh_paths =
List.filter
(fun (_,path) -> List.mem (Path.head path) new_ids) inh_init in
let inh_keys =
- List.map (fun (_,p) -> Lprim(Pfield 1, [transl_path p])) inh_paths in
+ List.map (fun (_,p) -> mk_lam (Lprim(Pfield 1, [transl_path p]))) inh_paths in
let lclass lam =
- Llet(Strict, class_init,
- Lfunction(Curried, [cla], def_ids cla cl_init), lam)
+ mk_lam (Llet(Strict, class_init,
+ mk_lam (Lfunction(Curried, [cla], def_ids cla cl_init)), lam))
and lcache lam =
- if inh_keys = [] then Llet(Alias, cached, Lvar tables, lam) else
- Llet(Strict, cached,
- mkappl (oo_prim "lookup_tables",
- [Lvar tables; Lprim(Pmakeblock(0, Immutable), inh_keys)]),
- lam)
+ if inh_keys = [] then
+ mk_lam (Llet(Alias, cached, mk_lam (Lvar tables), lam))
+ else
+ mk_lam (Llet(Strict, cached,
+ mkappl (oo_prim "lookup_tables",
+ [mk_lam (Lvar tables);
+ mk_lam (Lprim(Pmakeblock(0, Immutable), inh_keys))]),
+ lam))
and lset cached i lam =
- Lprim(Psetfield(i, true), [Lvar cached; lam])
+ mk_lam (Lprim(Psetfield(i, true), [mk_lam (Lvar cached); lam]))
in
let ldirect () =
ltable cla
- (Llet(Strict, env_init, def_ids cla cl_init,
- Lsequence(mkappl (oo_prim "init_class", [Lvar cla]),
- lset cached 0 (Lvar env_init))))
+ (mk_lam (Llet(Strict, env_init, def_ids cla cl_init,
+ mk_lam (Lsequence(mkappl (oo_prim "init_class", [mk_lam (Lvar cla)]),
+ lset cached 0 (mk_lam (Lvar env_init)))))))
and lclass_virt () =
- lset cached 0 (Lfunction(Curried, [cla], def_ids cla cl_init))
+ lset cached 0 (mk_lam (Lfunction(Curried, [cla], def_ids cla cl_init)))
in
llets (
lcache (
- Lsequence(
- Lifthenelse(lfield cached 0, lambda_unit,
+ mk_lam (Lsequence(
+ mk_lam (Lifthenelse(lfield cached 0, lambda_unit,
if ids = [] then ldirect () else
if not concrete then lclass_virt () else
lclass (
mkappl (oo_prim "make_class_store",
[transl_meth_list pub_meths;
- Lvar class_init; Lvar cached]))),
+ mk_lam (Lvar class_init);
+ mk_lam (Lvar cached)])))),
make_envs (
if ids = [] then mkappl (lfield cached 0, [lenvs]) else
- Lprim(Pmakeblock(0, Immutable),
+ mk_lam (Lprim(Pmakeblock(0, Immutable),
if concrete then
[mkappl (lfield cached 0, [lenvs]);
lfield cached 1;
lfield cached 0;
lenvs]
else [lambda_unit; lfield cached 0; lambda_unit; lenvs]
- )))))
+ )))))))
(* Wrapper for class compilation *)
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 9441fcc..088da1e 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -40,6 +40,11 @@ let transl_object =
ref (fun id s cl -> assert false :
Ident.t -> string list -> class_expr -> lambda)
+let lambda l_desc = {
+ l_loc = Location.none;
+ l_desc;
+}
+
(* Translation of primitives *)
let comparisons_table = create_hashtable 11 [
@@ -361,19 +366,19 @@ let transl_primitive p =
match prim with
Plazyforce ->
let parm = Ident.create "prim" in
- Lfunction(Curried, [parm], Matching.inline_lazy_force (Lvar parm) Location.none)
+ lambda (Lfunction(Curried, [parm], Matching.inline_lazy_force (lambda (Lvar parm)) Location.none))
| _ ->
let rec make_params n =
if n <= 0 then [] else Ident.create "prim" :: make_params (n-1) in
let params = make_params p.prim_arity in
- Lfunction(Curried, params, Lprim(prim, List.map (fun id -> Lvar id) params))
+ lambda (Lfunction(Curried, params, lambda (Lprim(prim, List.map (fun id -> lambda (Lvar id)) params))))
(* To check the well-formedness of r.h.s. of "let rec" definitions *)
let check_recursive_lambda idlist lam =
- let rec check_top idlist = function
+ let rec check_top idlist l = match l.l_desc with
| Lvar v -> not (List.mem v idlist)
- | Llet (_, _, _, _) as lam when check_recursive_recordwith idlist lam ->
+ | Llet _ when check_recursive_recordwith idlist l ->
true
| Llet(str, id, arg, body) ->
check idlist arg && check_top (add_let id arg idlist) body
@@ -384,12 +389,12 @@ let check_recursive_lambda idlist lam =
| Lprim (Pmakearray (Pgenarray), args) -> false
| Lsequence (lam1, lam2) -> check idlist lam1 && check_top idlist lam2
| Levent (lam, _) -> check_top idlist lam
- | lam -> check idlist lam
+ | _ -> check idlist l
- and check idlist = function
+ and check idlist l = match l.l_desc with
| Lvar _ -> true
| Lfunction(kind, params, body) -> true
- | Llet (_, _, _, _) as lam when check_recursive_recordwith idlist lam ->
+ | Llet _ when check_recursive_recordwith idlist l ->
true
| Llet(str, id, arg, body) ->
check idlist arg && check (add_let id arg idlist) body
@@ -403,8 +408,8 @@ let check_recursive_lambda idlist lam =
List.for_all (check idlist) args
| Lsequence (lam1, lam2) -> check idlist lam1 && check idlist lam2
| Levent (lam, _) -> check idlist lam
- | lam ->
- let fv = free_variables lam in
+ | _ ->
+ let fv = free_variables l in
not (List.exists (fun id -> IdentSet.mem id fv) idlist)
and add_let id arg idlist =
@@ -419,14 +424,14 @@ let check_recursive_lambda idlist lam =
(* reverse-engineering the code generated by transl_record case 2 *)
(* If you change this, you probably need to change Bytegen.size_of_lambda. *)
- and check_recursive_recordwith idlist = function
- | Llet (Strict, id1, Lprim (Pduprecord _, [e1]), body) ->
+ and check_recursive_recordwith idlist l = match l.l_desc with
+ | Llet (Strict, id1, {l_desc=Lprim (Pduprecord _, [e1])}, body) ->
check_top idlist e1
&& check_recordwith_updates idlist id1 body
| _ -> false
- and check_recordwith_updates idlist id1 = function
- | Lsequence (Lprim ((Psetfield _ | Psetfloatfield _), [Lvar id2; e1]), cont)
+ and check_recordwith_updates idlist id1 l = match l.l_desc with
+ | Lsequence ({l_desc=Lprim((Psetfield _ | Psetfloatfield _), [{l_desc=Lvar id2}; e1])}, cont)
-> id2 = id1 && check idlist e1
&& check_recordwith_updates idlist id1 cont
| Lvar id2 -> id2 = id1
@@ -438,7 +443,7 @@ let check_recursive_lambda idlist lam =
exception Not_constant
-let extract_constant = function
+let extract_constant l = match l.l_desc with
Lconst sc -> sc
| _ -> raise Not_constant
@@ -491,33 +496,38 @@ let rec push_defaults loc bindings pat_expr_list partial =
(* Insertion of debugging events *)
-let event_before exp lam = match lam with
-| Lstaticraise (_,_) -> lam
-| _ ->
- if !Clflags.debug
- then Levent(lam, {lev_loc = exp.exp_loc;
- lev_kind = Lev_before;
- lev_repr = None;
- lev_env = Env.summary exp.exp_env})
- else lam
+let event_before exp lam = match lam.l_desc with
+ | Lstaticraise (_,_) -> lam
+ | _ ->
+ if !Clflags.debug then
+ mk_loc_lam exp.exp_loc
+ (Levent(lam, {lev_loc = exp.exp_loc;
+ lev_kind = Lev_before;
+ lev_repr = None;
+ lev_env = Env.summary exp.exp_env}))
+ else
+ lam
let event_after exp lam =
- if !Clflags.debug
- then Levent(lam, {lev_loc = exp.exp_loc;
+ if !Clflags.debug then
+ mk_loc_lam exp.exp_loc
+ (Levent(lam, {lev_loc = exp.exp_loc;
lev_kind = Lev_after exp.exp_type;
lev_repr = None;
- lev_env = Env.summary exp.exp_env})
- else lam
+ lev_env = Env.summary exp.exp_env}))
+ else
+ lam
let event_function exp lam =
if !Clflags.debug then
let repr = Some (ref 0) in
let (info, body) = lam repr in
(info,
- Levent(body, {lev_loc = exp.exp_loc;
- lev_kind = Lev_function;
- lev_repr = repr;
- lev_env = Env.summary exp.exp_env}))
+ mk_loc_lam exp.exp_loc
+ (Levent(body, {lev_loc = exp.exp_loc;
+ lev_kind = Lev_function;
+ lev_repr = repr;
+ lev_env = Env.summary exp.exp_env})))
else
lam None
@@ -532,13 +542,15 @@ let primitive_is_ccall = function
let assert_failed loc =
let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in
- Lprim(Praise, [Lprim(Pmakeblock(0, Immutable),
- [transl_path Predef.path_assert_failure;
- Lconst(Const_block(0,
- [Const_base(Const_string fname);
- Const_base(Const_int line);
- Const_base(Const_int char)]))])])
-;;
+ let make = mk_loc_lam loc in
+ make
+ (Lprim(Praise,
+ [make (Lprim(Pmakeblock(0, Immutable),
+ [transl_path Predef.path_assert_failure;
+ make (Lconst(Const_block(0,
+ [Const_base(Const_string fname);
+ Const_base(Const_int line);
+ Const_base(Const_int char)])))]))]))
let rec cut n l =
if n = 0 then ([],l) else
@@ -561,15 +573,20 @@ and transl_exp0 e =
match e.exp_desc with
Texp_ident(path, {val_kind = Val_prim p}) ->
let public_send = p.prim_name = "%send" in
+ let make = mk_loc_lam e.exp_loc in
if public_send || p.prim_name = "%sendself" then
let kind = if public_send then Public else Self in
let obj = Ident.create "obj" and meth = Ident.create "meth" in
- Lfunction(Curried, [obj; meth], Lsend(kind, Lvar meth, Lvar obj, [], e.exp_loc))
+ make
+ (Lfunction(Curried, [obj; meth],
+ make (Lsend(kind, make (Lvar meth), make (Lvar obj), []))))
else if p.prim_name = "%sendcache" then
let obj = Ident.create "obj" and meth = Ident.create "meth" in
let cache = Ident.create "cache" and pos = Ident.create "pos" in
- Lfunction(Curried, [obj; meth; cache; pos],
- Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos], e.exp_loc))
+ make
+ (Lfunction(Curried, [obj; meth; cache; pos],
+ make (Lsend(Cached, make (Lvar meth), make (Lvar obj),
+ [make (Lvar cache); make (Lvar pos)]))))
else
transl_primitive p
| Texp_ident(path, {val_kind = Val_anc _}) ->
@@ -577,8 +594,7 @@ and transl_exp0 e =
| Texp_ident(path, {val_kind = Val_reg | Val_self _}) ->
transl_path path
| Texp_ident _ -> fatal_error "Translcore.transl_exp: bad Texp_ident"
- | Texp_constant cst ->
- Lconst(Const_base cst)
+ | Texp_constant cst -> mk_loc_lam e.exp_loc (Lconst(Const_base cst))
| Texp_let(rec_flag, pat_expr_list, body) ->
transl_let rec_flag pat_expr_list (event_before body (transl_exp body))
| Texp_function (pat_expr_list, partial) ->
@@ -588,7 +604,7 @@ and transl_exp0 e =
let pl = push_defaults e.exp_loc [] pat_expr_list partial in
transl_function e.exp_loc !Clflags.native_code repr partial pl)
in
- Lfunction(kind, params, body)
+ mk_loc_lam e.exp_loc (Lfunction(kind, params, body))
| Texp_apply({exp_desc = Texp_ident(path, {val_kind = Val_prim p})}, oargs)
when List.length oargs >= p.prim_arity
&& List.for_all (fun (arg,_) -> arg <> None) oargs ->
@@ -607,22 +623,22 @@ and transl_exp0 e =
if public_send || p.prim_name = "%sendself" then
let kind = if public_send then Public else Self in
let obj = List.hd argl in
- wrap (Lsend (kind, List.nth argl 1, obj, [], e.exp_loc))
+ wrap (mk_loc_lam e.exp_loc (Lsend (kind, List.nth argl 1, obj, [])))
else if p.prim_name = "%sendcache" then
match argl with [obj; meth; cache; pos] ->
- wrap (Lsend(Cached, meth, obj, [cache; pos], e.exp_loc))
+ wrap (mk_loc_lam e.exp_loc (Lsend(Cached, meth, obj, [cache; pos])))
| _ -> assert false
else begin
let prim = transl_prim p args in
match (prim, args) with
(Praise, [arg1]) ->
- wrap0 (Lprim(Praise, [event_after arg1 (List.hd argl)]))
+ wrap0 (mk_loc_lam e.exp_loc (Lprim(Praise, [event_after arg1 (List.hd argl)])))
| (_, _) ->
begin match (prim, argl) with
| (Plazyforce, [a]) ->
wrap (Matching.inline_lazy_force a e.exp_loc)
| (Plazyforce, _) -> assert false
- |_ -> let p = Lprim(prim, argl) in
+ |_ -> let p = mk_loc_lam e.exp_loc (Lprim(prim, argl)) in
if primitive_is_ccall prim then wrap p else wrap0 p
end
end
@@ -636,17 +652,21 @@ and transl_exp0 e =
(transl_exp arg) (transl_cases pat_expr_list) partial
| Texp_try(body, pat_expr_list) ->
let id = name_pattern "exn" pat_expr_list in
- Ltrywith(transl_exp body, id,
- Matching.for_trywith (Lvar id) (transl_cases pat_expr_list))
+ mk_loc_lam e.exp_loc
+ (Ltrywith(transl_exp body, id,
+ Matching.for_trywith
+ (mk_loc_lam e.exp_loc (Lvar id))
+ (transl_cases pat_expr_list)))
| Texp_tuple el ->
let ll = transl_list el in
begin try
- Lconst(Const_block(0, List.map extract_constant ll))
+ mk_loc_lam e.exp_loc (Lconst(Const_block(0, List.map extract_constant ll)))
with Not_constant ->
- Lprim(Pmakeblock(0, Immutable), ll)
+ mk_loc_lam e.exp_loc (Lprim(Pmakeblock(0, Immutable), ll))
end
| Texp_construct(cstr, args) ->
let ll = transl_list args in
+ mk_loc_lam e.exp_loc
begin match cstr.cstr_tag with
Cstr_constant n ->
Lconst(Const_pointer n)
@@ -661,6 +681,7 @@ and transl_exp0 e =
end
| Texp_variant(l, arg) ->
let tag = Btype.hash_variant l in
+ mk_loc_lam e.exp_loc
begin match arg with
None -> Lconst(Const_pointer tag)
| Some arg ->
@@ -670,7 +691,8 @@ and transl_exp0 e =
extract_constant lam]))
with Not_constant ->
Lprim(Pmakeblock(0, Immutable),
- [Lconst(Const_base(Const_int tag)); lam])
+ [mk_loc_lam e.exp_loc (Lconst(Const_base(Const_int tag)));
+ lam])
end
| Texp_record ((lbl1, _) :: _ as lbl_expr_list, opt_init_expr) ->
transl_record lbl1.lbl_all lbl1.lbl_repres lbl_expr_list opt_init_expr
@@ -681,86 +703,99 @@ and transl_exp0 e =
match lbl.lbl_repres with
Record_regular -> Pfield lbl.lbl_pos
| Record_float -> Pfloatfield lbl.lbl_pos in
- Lprim(access, [transl_exp arg])
+ mk_loc_lam e.exp_loc (Lprim(access, [transl_exp arg]))
| Texp_setfield(arg, lbl, newval) ->
let access =
match lbl.lbl_repres with
Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer newval)
| Record_float -> Psetfloatfield lbl.lbl_pos in
- Lprim(access, [transl_exp arg; transl_exp newval])
+ mk_loc_lam e.exp_loc (Lprim(access, [transl_exp arg; transl_exp newval]))
| Texp_array expr_list ->
let kind = array_kind e in
let ll = transl_list expr_list in
+ mk_loc_lam e.exp_loc
begin try
(* Deactivate constant optimization if array is small enough *)
if List.length ll <= 4 then raise Not_constant;
let cl = List.map extract_constant ll in
let master =
- match kind with
+ mk_loc_lam e.exp_loc
+ (match kind with
| Paddrarray | Pintarray ->
Lconst(Const_block(0, cl))
| Pfloatarray ->
Lconst(Const_float_array(List.map extract_float cl))
| Pgenarray ->
- raise Not_constant in (* can this really happen? *)
+ raise Not_constant) in (* can this really happen? *)
Lprim(Pccall prim_obj_dup, [master])
with Not_constant ->
Lprim(Pmakearray kind, ll)
end
| Texp_ifthenelse(cond, ifso, Some ifnot) ->
- Lifthenelse(transl_exp cond,
- event_before ifso (transl_exp ifso),
- event_before ifnot (transl_exp ifnot))
+ mk_loc_lam e.exp_loc
+ (Lifthenelse(transl_exp cond,
+ event_before ifso (transl_exp ifso),
+ event_before ifnot (transl_exp ifnot)))
| Texp_ifthenelse(cond, ifso, None) ->
- Lifthenelse(transl_exp cond,
- event_before ifso (transl_exp ifso),
- lambda_unit)
+ mk_loc_lam e.exp_loc
+ (Lifthenelse(transl_exp cond,
+ event_before ifso (transl_exp ifso),
+ lambda_unit))
| Texp_sequence(expr1, expr2) ->
- Lsequence(transl_exp expr1, event_before expr2 (transl_exp expr2))
+ mk_loc_lam e.exp_loc
+ (Lsequence(transl_exp expr1, event_before expr2 (transl_exp expr2)))
| Texp_while(cond, body) ->
- Lwhile(transl_exp cond, event_before body (transl_exp body))
+ mk_loc_lam e.exp_loc
+ (Lwhile(transl_exp cond, event_before body (transl_exp body)))
| Texp_for(param, low, high, dir, body) ->
- Lfor(param, transl_exp low, transl_exp high, dir,
- event_before body (transl_exp body))
+ mk_loc_lam e.exp_loc
+ (Lfor(param, transl_exp low, transl_exp high, dir,
+ event_before body (transl_exp body)))
| Texp_when(cond, body) ->
event_before cond
- (Lifthenelse(transl_exp cond, event_before body (transl_exp body),
- staticfail))
+ (mk_loc_lam e.exp_loc
+ (Lifthenelse(transl_exp cond, event_before body (transl_exp body),
+ staticfail)))
| Texp_send(expr, met) ->
let obj = transl_exp expr in
- let lam =
+ let lamd =
match met with
- Tmeth_val id -> Lsend (Self, Lvar id, obj, [], e.exp_loc)
+ Tmeth_val id -> Lsend (Self, mk_loc_lam e.exp_loc (Lvar id), obj, [])
| Tmeth_name nm ->
let (tag, cache) = Translobj.meth obj nm in
let kind = if cache = [] then Public else Cached in
- Lsend (kind, tag, obj, cache, e.exp_loc)
+ Lsend (kind, tag, obj, cache)
in
- event_after e lam
+ event_after e (mk_loc_lam e.exp_loc lamd)
| Texp_new (cl, _) ->
- Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit], Location.none)
+ mk_loc_lam e.exp_loc
+ (Lapply(mk_loc_lam e.exp_loc (Lprim(Pfield 0, [transl_path cl])), [lambda_unit]))
| Texp_instvar(path_self, path) ->
- Lprim(Parrayrefu Paddrarray, [transl_path path_self; transl_path path])
+ mk_loc_lam e.exp_loc (Lprim(Parrayrefu Paddrarray, [transl_path path_self; transl_path path]))
| Texp_setinstvar(path_self, path, expr) ->
transl_setinstvar (transl_path path_self) path expr
| Texp_override(path_self, modifs) ->
let cpy = Ident.create "copy" in
- Llet(Strict, cpy,
- Lapply(Translobj.oo_prim "copy", [transl_path path_self],
- Location.none),
+ mk_loc_lam e.exp_loc
+ (Llet(Strict, cpy,
+ mk_loc_lam e.exp_loc
+ (Lapply(Translobj.oo_prim "copy", [transl_path path_self])),
List.fold_right
(fun (path, expr) rem ->
- Lsequence(transl_setinstvar (Lvar cpy) path expr, rem))
+ mk_loc_lam e.exp_loc
+ (Lsequence(transl_setinstvar (mk_loc_lam e.exp_loc (Lvar cpy)) path expr, rem)))
modifs
- (Lvar cpy))
+ (mk_loc_lam e.exp_loc (Lvar cpy))))
| Texp_letmodule(id, modl, body) ->
- Llet(Strict, id, !transl_module Tcoerce_none None modl, transl_exp body)
+ mk_loc_lam e.exp_loc
+ (Llet(Strict, id, !transl_module Tcoerce_none None modl, transl_exp body))
| Texp_pack modl ->
!transl_module Tcoerce_none None modl
| Texp_assert (cond) ->
if !Clflags.noassert
then lambda_unit
- else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e.exp_loc)
+ else mk_loc_lam e.exp_loc
+ (Lifthenelse (transl_exp cond, lambda_unit, assert_failed e.exp_loc))
| Texp_assertfalse -> assert_failed e.exp_loc
| Texp_lazy e ->
(* when e needs no computation (constants, identifiers, ...), we
@@ -775,14 +810,15 @@ and transl_exp0 e =
| Texp_construct ({cstr_arity = 0}, _)
-> transl_exp e
| Texp_constant(Const_float _) ->
- Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e])
+ mk_loc_lam e.exp_loc
+ (Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e]))
| Texp_ident(_, _) -> (* according to the type *)
begin match e.exp_type.desc with
(* the following may represent a float/forward/lazy: need a
forward_tag *)
| Tvar _ | Tlink _ | Tsubst _ | Tunivar _
| Tpoly(_,_) | Tfield(_,_,_,_) ->
- Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e])
+ mk_loc_lam e.exp_loc (Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e]))
(* the following cannot be represented as float/forward/lazy:
optimize *)
| Tarrow(_,_,_,_) | Ttuple _ | Tpackage _ | Tobject(_,_) | Tnil
@@ -805,12 +841,14 @@ and transl_exp0 e =
|| has_base_type e Predef.path_int64
then transl_exp e
else
- Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e])
+ mk_loc_lam e.exp_loc (Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e]))
end
(* other cases compile to a lazy block holding a function *)
| _ ->
- let fn = Lfunction (Curried, [Ident.create "param"], transl_exp e) in
- Lprim(Pmakeblock(Config.lazy_tag, Immutable), [fn])
+ let fn = mk_loc_lam e.exp_loc
+ (Lfunction (Curried, [Ident.create "param"], transl_exp e)) in
+ mk_loc_lam e.exp_loc
+ (Lprim(Pmakeblock(Config.lazy_tag, Immutable), [fn]))
end
| Texp_object (cs, cty, meths) ->
let cl = Ident.create "class" in
@@ -833,26 +871,27 @@ and transl_tupled_cases patl_expr_list =
and transl_apply lam sargs loc =
let lapply funct args =
- match funct with
- Lsend(k, lmet, lobj, largs, loc) ->
- Lsend(k, lmet, lobj, largs @ args, loc)
- | Levent(Lsend(k, lmet, lobj, largs, loc), _) ->
- Lsend(k, lmet, lobj, largs @ args, loc)
- | Lapply(lexp, largs, _) ->
- Lapply(lexp, largs @ args, loc)
- | lexp ->
- Lapply(lexp, args, loc)
+ let make = mk_loc_lam funct.l_loc in
+ match funct.l_desc with
+ Lsend(k, lmet, lobj, largs) ->
+ make (Lsend(k, lmet, lobj, largs @ args))
+ | Levent({l_desc=Lsend(k, lmet, lobj, largs)},_) ->
+ make (Lsend(k, lmet, lobj, largs @ args))
+ | Lapply(lexp, largs) ->
+ make (Lapply(lexp, largs @ args))
+ | _ ->
+ make (Lapply(funct, args))
in
let rec build_apply lam args = function
(None, optional) :: l ->
let defs = ref [] in
let protect name lam =
- match lam with
+ match lam.l_desc with
Lvar _ | Lconst _ -> lam
| _ ->
let id = Ident.create name in
defs := (id, lam) :: !defs;
- Lvar id
+ mk_loc_lam lam.l_loc (Lvar id)
in
let args, args' =
if List.for_all (fun (_,opt) -> opt = Optional) args then [], args
@@ -863,16 +902,18 @@ and transl_apply lam sargs loc =
and l = List.map (fun (arg, opt) -> may_map (protect "arg") arg, opt) l
and id_arg = Ident.create "param" in
let body =
- match build_apply handle ((Lvar id_arg, optional)::args') l with
- Lfunction(Curried, ids, lam) ->
- Lfunction(Curried, id_arg::ids, lam)
- | Levent(Lfunction(Curried, ids, lam), _) ->
- Lfunction(Curried, id_arg::ids, lam)
- | lam ->
- Lfunction(Curried, [id_arg], lam)
- in
+ let app = build_apply handle ((lambda (Lvar id_arg), optional)::args') l in
+ mk_loc_lam app.l_loc
+ begin match app.l_desc with
+ | Lfunction(Curried, ids, lam) ->
+ Lfunction(Curried, id_arg::ids, lam)
+ | Levent({l_desc=Lfunction(Curried, ids, lam)}, _) ->
+ Lfunction(Curried, id_arg::ids, lam)
+ | _ ->
+ Lfunction(Curried, [id_arg], lam)
+ end in
List.fold_left
- (fun body (id, lam) -> Llet(Strict, id, lam, body))
+ (fun body (id, lam) -> lambda (Llet(Strict, id, lam, body)))
body !defs
| (Some arg, optional) :: l ->
build_apply lam ((arg, optional) :: args) l
@@ -889,7 +930,7 @@ and transl_function loc untuplify_fn repr partial pat_expr_list =
let ((_, params), body) =
transl_function exp.exp_loc false repr partial' pl in
((Curried, param :: params),
- Matching.for_function loc None (Lvar param) [pat, body] partial)
+ Matching.for_function loc None (mk_loc_lam loc (Lvar param)) [pat, body] partial)
| ({pat_desc = Tpat_tuple pl}, _) :: _ when untuplify_fn ->
begin try
let size = List.length pl in
@@ -904,13 +945,13 @@ and transl_function loc untuplify_fn repr partial pat_expr_list =
with Matching.Cannot_flatten ->
let param = name_pattern "param" pat_expr_list in
((Curried, [param]),
- Matching.for_function loc repr (Lvar param)
+ Matching.for_function loc repr (mk_loc_lam loc (Lvar param))
(transl_cases pat_expr_list) partial)
end
| _ ->
let param = name_pattern "param" pat_expr_list in
((Curried, [param]),
- Matching.for_function loc repr (Lvar param)
+ Matching.for_function loc repr (mk_loc_lam loc (Lvar param))
(transl_cases pat_expr_list) partial)
and transl_let rec_flag pat_expr_list body =
@@ -935,11 +976,12 @@ and transl_let rec_flag pat_expr_list body =
if not (check_recursive_lambda idlist lam) then
raise(Error(expr.exp_loc, Illegal_letrec_expr));
(id, lam) in
- Lletrec(List.map2 transl_case pat_expr_list idlist, body)
+ (mk_loc_lam body.l_loc (Lletrec(List.map2 transl_case pat_expr_list idlist, body)))
and transl_setinstvar self var expr =
- Lprim(Parraysetu (if maybe_pointer expr then Paddrarray else Pintarray),
- [self; transl_path var; transl_exp expr])
+ mk_loc_lam expr.exp_loc
+ (Lprim(Parraysetu (if maybe_pointer expr then Paddrarray else Pintarray),
+ [self; transl_path var; transl_exp expr]))
and transl_record all_labels repres lbl_expr_list opt_init_expr =
let size = Array.length all_labels in
@@ -958,7 +1000,7 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr =
match all_labels.(i).lbl_repres with
Record_regular -> Pfield i
| Record_float -> Pfloatfield i in
- lv.(i) <- Lprim(access, [Lvar init_id])
+ lv.(i) <- lambda (Lprim(access, [lambda (Lvar init_id)]))
done
end;
List.iter
@@ -970,20 +1012,20 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr =
then Mutable
else Immutable in
let lam =
- try
- if mut = Mutable then raise Not_constant;
- let cl = List.map extract_constant ll in
- match repres with
- Record_regular -> Lconst(Const_block(0, cl))
- | Record_float ->
- Lconst(Const_float_array(List.map extract_float cl))
- with Not_constant ->
- match repres with
- Record_regular -> Lprim(Pmakeblock(0, mut), ll)
- | Record_float -> Lprim(Pmakearray Pfloatarray, ll) in
+ lambda
+ begin try
+ if mut = Mutable then raise Not_constant;
+ let cl = List.map extract_constant ll in
+ match repres with
+ | Record_regular -> Lconst(Const_block(0, cl))
+ | Record_float -> Lconst(Const_float_array(List.map extract_float cl))
+ with Not_constant -> match repres with
+ | Record_regular -> Lprim(Pmakeblock(0, mut), ll)
+ | Record_float -> Lprim(Pmakearray Pfloatarray, ll)
+ end in
begin match opt_init_expr with
None -> lam
- | Some init_expr -> Llet(Strict, init_id, transl_exp init_expr, lam)
+ | Some init_expr -> lambda (Llet(Strict, init_id, transl_exp init_expr, lam))
end
end else begin
(* Take a shallow copy of the init record, then mutate the fields
@@ -996,13 +1038,15 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr =
match lbl.lbl_repres with
Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer expr)
| Record_float -> Psetfloatfield lbl.lbl_pos in
- Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr]), cont) in
+ lambda
+ (Lsequence(lambda (Lprim(upd, [lambda (Lvar copy_id); transl_exp expr])),
+ cont)) in
begin match opt_init_expr with
None -> assert false
| Some init_expr ->
- Llet(Strict, copy_id,
- Lprim(Pduprecord (repres, size), [transl_exp init_expr]),
- List.fold_right update_field lbl_expr_list (Lvar copy_id))
+ lambda (Llet(Strict, copy_id,
+ lambda (Lprim(Pduprecord (repres, size), [transl_exp init_expr])),
+ List.fold_right update_field lbl_expr_list (lambda (Lvar copy_id))))
end
end
@@ -1026,7 +1070,8 @@ let transl_exception id path decl =
match path with
None -> Ident.name id
| Some p -> Path.name p in
- Lprim(Pmakeblock(0, Immutable), [Lconst(Const_base(Const_string name))])
+ lambda (Lprim(Pmakeblock(0, Immutable),
+ [lambda (Lconst(Const_base(Const_string name)))]))
(* Error report *)
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index 38eab85..570eabf 100644
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -40,20 +40,21 @@ let rec apply_coercion restr arg =
arg
| Tcoerce_structure pos_cc_list ->
name_lambda arg (fun id ->
- Lprim(Pmakeblock(0, Immutable),
- List.map (apply_coercion_field id) pos_cc_list))
+ mk_lam (Lprim(Pmakeblock(0, Immutable),
+ List.map (apply_coercion_field id) pos_cc_list)))
| Tcoerce_functor(cc_arg, cc_res) ->
let param = Ident.create "funarg" in
name_lambda arg (fun id ->
- Lfunction(Curried, [param],
+ mk_lam (Lfunction(Curried, [param],
apply_coercion cc_res
- (Lapply(Lvar id, [apply_coercion cc_arg (Lvar param)],
- Location.none))))
+ (mk_lam (Lapply(mk_lam (Lvar id),
+ [apply_coercion cc_arg (mk_lam (Lvar param))]
+ ))))))
| Tcoerce_primitive p ->
transl_primitive p
and apply_coercion_field id (pos, cc) =
- apply_coercion cc (Lprim(Pfield pos, [Lvar id]))
+ apply_coercion cc (mk_lam (Lprim(Pfield pos, [mk_lam (Lvar id)])))
(* Compose two coercions
apply_coercion c1 (apply_coercion c2 e) behaves like
@@ -110,10 +111,10 @@ let mod_prim name =
let undefined_location loc =
let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in
- Lconst(Const_block(0,
+ mk_lam (Lconst(Const_block(0,
[Const_base(Const_string fname);
Const_base(Const_int line);
- Const_base(Const_int char)]))
+ Const_base(Const_int char)])))
let init_shape modl =
let rec init_shape_mod env mty =
@@ -153,7 +154,7 @@ let init_shape modl =
in
try
Some(undefined_location modl.mod_loc,
- Lconst(init_shape_mod modl.mod_env modl.mod_type))
+ mk_lam (Lconst(init_shape_mod modl.mod_env modl.mod_type)))
with Not_found ->
None
@@ -200,13 +201,13 @@ let eval_rec_bindings bindings cont =
| (id, None, rhs) :: rem ->
bind_inits rem
| (id, Some(loc, shape), rhs) :: rem ->
- Llet(Strict, id, Lapply(mod_prim "init_mod", [loc; shape], Location.none),
- bind_inits rem)
+ mk_lam (Llet(Strict, id, mk_lam (Lapply(mod_prim "init_mod", [loc; shape])),
+ bind_inits rem))
and bind_strict = function
[] ->
patch_forwards bindings
| (id, None, rhs) :: rem ->
- Llet(Strict, id, rhs, bind_strict rem)
+ mk_lam (Llet(Strict, id, rhs, bind_strict rem))
| (id, Some(loc, shape), rhs) :: rem ->
bind_strict rem
and patch_forwards = function
@@ -215,9 +216,9 @@ let eval_rec_bindings bindings cont =
| (id, None, rhs) :: rem ->
patch_forwards rem
| (id, Some(loc, shape), rhs) :: rem ->
- Lsequence(Lapply(mod_prim "update_mod", [shape; Lvar id; rhs],
- Location.none),
- patch_forwards rem)
+ mk_lam (Lsequence(mk_lam (Lapply(mod_prim "update_mod",
+ [shape; mk_lam (Lvar id); rhs])),
+ patch_forwards rem))
in
bind_inits bindings
@@ -243,21 +244,25 @@ let rec transl_module cc rootpath mexp =
oo_wrap mexp.mod_env true
(function
| Tcoerce_none ->
- Lfunction(Curried, [param],
- transl_module Tcoerce_none bodypath body)
+ mk_loc_lam mexp.mod_loc
+ (Lfunction(Curried, [param],
+ transl_module Tcoerce_none bodypath body))
| Tcoerce_functor(ccarg, ccres) ->
let param' = Ident.create "funarg" in
- Lfunction(Curried, [param'],
- Llet(Alias, param, apply_coercion ccarg (Lvar param'),
- transl_module ccres bodypath body))
+ mk_loc_lam mexp.mod_loc
+ (Lfunction(Curried, [param'],
+ mk_lam (Llet(Alias, param,
+ apply_coercion ccarg (mk_lam (Lvar param')),
+ transl_module ccres bodypath body))))
| _ ->
fatal_error "Translmod.transl_module")
cc
| Tmod_apply(funct, arg, ccarg) ->
oo_wrap mexp.mod_env true
(apply_coercion cc)
- (Lapply(transl_module Tcoerce_none None funct,
- [transl_module ccarg None arg], mexp.mod_loc))
+ (mk_loc_lam mexp.mod_loc
+ (Lapply(transl_module Tcoerce_none None funct,
+ [transl_module ccarg None arg])))
| Tmod_constraint(arg, mty, ccarg) ->
transl_module (compose_coercions cc ccarg) rootpath arg
| Tmod_unpack(arg, _) ->
@@ -267,22 +272,22 @@ and transl_structure fields cc rootpath = function
[] ->
begin match cc with
Tcoerce_none ->
- Lprim(Pmakeblock(0, Immutable),
- List.map (fun id -> Lvar id) (List.rev fields))
+ mk_lam (Lprim(Pmakeblock(0, Immutable),
+ List.map (fun id -> mk_lam (Lvar id)) (List.rev fields)))
| Tcoerce_structure pos_cc_list ->
let v = Array.of_list (List.rev fields) in
- Lprim(Pmakeblock(0, Immutable),
+ mk_lam (Lprim(Pmakeblock(0, Immutable),
List.map
(fun (pos, cc) ->
match cc with
Tcoerce_primitive p -> transl_primitive p
- | _ -> apply_coercion cc (Lvar v.(pos)))
- pos_cc_list)
+ | _ -> apply_coercion cc (mk_lam (Lvar v.(pos))))
+ pos_cc_list))
| _ ->
fatal_error "Translmod.transl_structure"
end
| Tstr_eval expr :: rem ->
- Lsequence(transl_exp expr, transl_structure fields cc rootpath rem)
+ mk_lam (Lsequence(transl_exp expr, transl_structure fields cc rootpath rem))
| Tstr_value(rec_flag, pat_expr_list) :: rem ->
let ext_fields = rev_let_bound_idents pat_expr_list @ fields in
transl_let rec_flag pat_expr_list
@@ -293,15 +298,15 @@ and transl_structure fields cc rootpath = function
| Tstr_type(decls) :: rem ->
transl_structure fields cc rootpath rem
| Tstr_exception(id, decl) :: rem ->
- Llet(Strict, id, transl_exception id (field_path rootpath id) decl,
- transl_structure (id :: fields) cc rootpath rem)
+ mk_lam (Llet(Strict, id, transl_exception id (field_path rootpath id) decl,
+ transl_structure (id :: fields) cc rootpath rem))
| Tstr_exn_rebind(id, path) :: rem ->
- Llet(Strict, id, transl_path path,
- transl_structure (id :: fields) cc rootpath rem)
+ mk_lam (Llet(Strict, id, transl_path path,
+ transl_structure (id :: fields) cc rootpath rem))
| Tstr_module(id, modl) :: rem ->
- Llet(Strict, id,
- transl_module Tcoerce_none (field_path rootpath id) modl,
- transl_structure (id :: fields) cc rootpath rem)
+ mk_lam (Llet(Strict, id,
+ transl_module Tcoerce_none (field_path rootpath id) modl,
+ transl_structure (id :: fields) cc rootpath rem))
| Tstr_recmodule bindings :: rem ->
let ext_fields = List.rev_append (List.map fst bindings) fields in
compile_recmodule
@@ -315,11 +320,11 @@ and transl_structure fields cc rootpath = function
transl_structure fields cc rootpath rem
| Tstr_class cl_list :: rem ->
let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in
- Lletrec(List.map
- (fun (id, arity, meths, cl, vf) ->
- (id, transl_class ids id arity meths cl vf))
- cl_list,
- transl_structure (List.rev ids @ fields) cc rootpath rem)
+ mk_lam (Lletrec(List.map
+ (fun (id, arity, meths, cl, vf) ->
+ (id, transl_class ids id arity meths cl vf))
+ cl_list,
+ transl_structure (List.rev ids @ fields) cc rootpath rem))
| Tstr_cltype cl_list :: rem ->
transl_structure fields cc rootpath rem
| Tstr_include(modl, ids) :: rem ->
@@ -328,10 +333,11 @@ and transl_structure fields cc rootpath = function
[] ->
transl_structure newfields cc rootpath rem
| id :: ids ->
- Llet(Alias, id, Lprim(Pfield pos, [Lvar mid]),
- rebind_idents (pos + 1) (id :: newfields) ids) in
- Llet(Strict, mid, transl_module Tcoerce_none None modl,
- rebind_idents 0 fields ids)
+ mk_lam (Llet(Alias, id,
+ mk_lam (Lprim(Pfield pos, [mk_lam (Lvar mid)])),
+ rebind_idents (pos + 1) (id :: newfields) ids)) in
+ mk_lam (Llet(Strict, mid, transl_module Tcoerce_none None modl,
+ rebind_idents 0 fields ids))
(* Update forward declaration in Translcore *)
let _ =
@@ -343,9 +349,9 @@ let transl_implementation module_name (str, cc) =
reset_labels ();
primitive_declarations := [];
let module_id = Ident.create_persistent module_name in
- Lprim(Psetglobal module_id,
- [transl_label_init
- (transl_structure [] cc (global_path module_id) str)])
+ mk_lam (Lprim(Psetglobal module_id,
+ [transl_label_init
+ (transl_structure [] cc (global_path module_id) str)]))
(* A variant of transl_structure used to compile toplevel structure definitions
for the native-code compiler. Store the defined values in the fields
@@ -361,8 +367,8 @@ let transl_store_subst = ref Ident.empty
calls of transl_store_structure *)
let nat_toplevel_name id =
- try match Ident.find_same id !transl_store_subst with
- | Lprim(Pfield pos, [Lprim(Pgetglobal glob, [])]) -> (glob,pos)
+ try match (Ident.find_same id !transl_store_subst).l_desc with
+ | Lprim(Pfield pos, [{l_desc=Lprim(Pgetglobal glob, [])}]) -> (glob,pos)
| _ -> raise Not_found
with Not_found ->
fatal_error("Translmod.nat_toplevel_name: " ^ Ident.unique_name id)
@@ -373,13 +379,13 @@ let transl_store_structure glob map prims str =
transl_store_subst := subst;
lambda_unit
| Tstr_eval expr :: rem ->
- Lsequence(subst_lambda subst (transl_exp expr),
- transl_store subst rem)
+ mk_lam (Lsequence(subst_lambda subst (transl_exp expr),
+ transl_store subst rem))
| Tstr_value(rec_flag, pat_expr_list) :: rem ->
let ids = let_bound_idents pat_expr_list in
let lam = transl_let rec_flag pat_expr_list (store_idents ids) in
- Lsequence(subst_lambda subst lam,
- transl_store (add_idents false ids subst) rem)
+ mk_lam (Lsequence(subst_lambda subst lam,
+ transl_store (add_idents false ids subst) rem))
| Tstr_primitive(id, descr) :: rem ->
record_primitive descr;
transl_store subst rem
@@ -387,12 +393,12 @@ let transl_store_structure glob map prims str =
transl_store subst rem
| Tstr_exception(id, decl) :: rem ->
let lam = transl_exception id (field_path (global_path glob) id) decl in
- Lsequence(Llet(Strict, id, lam, store_ident id),
- transl_store (add_ident false id subst) rem)
+ mk_lam (Lsequence(mk_lam (Llet(Strict, id, lam, store_ident id)),
+ transl_store (add_ident false id subst) rem))
| Tstr_exn_rebind(id, path) :: rem ->
let lam = subst_lambda subst (transl_path path) in
- Lsequence(Llet(Strict, id, lam, store_ident id),
- transl_store (add_ident false id subst) rem)
+ mk_lam (Lsequence(mk_lam (Llet(Strict, id, lam, store_ident id)),
+ transl_store (add_ident false id subst) rem))
| Tstr_module(id, modl) :: rem ->
let lam =
transl_module Tcoerce_none (field_path (global_path glob) id) modl in
@@ -402,8 +408,8 @@ let transl_store_structure glob map prims str =
the compilation unit (add_ident true returns subst unchanged).
If not, we can use the value from the global
(add_ident true adds id -> Pgetglobal... to subst). *)
- Llet(Strict, id, subst_lambda subst lam,
- Lsequence(store_ident id, transl_store(add_ident true id subst) rem))
+ mk_lam (Llet(Strict, id, subst_lambda subst lam,
+ mk_lam (Lsequence(store_ident id, transl_store(add_ident true id subst) rem))))
| Tstr_recmodule bindings :: rem ->
let ids = List.map fst bindings in
compile_recmodule
@@ -412,8 +418,8 @@ let transl_store_structure glob map prims str =
(transl_module Tcoerce_none
(field_path (global_path glob) id) modl))
bindings
- (Lsequence(store_idents ids,
- transl_store (add_idents true ids subst) rem))
+ (mk_lam (Lsequence(store_idents ids,
+ transl_store (add_idents true ids subst) rem)))
| Tstr_modtype(id, decl) :: rem ->
transl_store subst rem
| Tstr_open path :: rem ->
@@ -421,13 +427,13 @@ let transl_store_structure glob map prims str =
| Tstr_class cl_list :: rem ->
let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in
let lam =
- Lletrec(List.map
- (fun (id, arity, meths, cl, vf) ->
- (id, transl_class ids id arity meths cl vf))
- cl_list,
- store_idents ids) in
- Lsequence(subst_lambda subst lam,
- transl_store (add_idents false ids subst) rem)
+ mk_lam (Lletrec(List.map
+ (fun (id, arity, meths, cl, vf) ->
+ (id, transl_class ids id arity meths cl vf))
+ cl_list,
+ store_idents ids)) in
+ mk_lam (Lsequence(subst_lambda subst lam,
+ transl_store (add_idents false ids subst) rem))
| Tstr_cltype cl_list :: rem ->
transl_store subst rem
| Tstr_include(modl, ids) :: rem ->
@@ -435,17 +441,18 @@ let transl_store_structure glob map prims str =
let rec store_idents pos = function
[] -> transl_store (add_idents true ids subst) rem
| id :: idl ->
- Llet(Alias, id, Lprim(Pfield pos, [Lvar mid]),
- Lsequence(store_ident id, store_idents (pos + 1) idl)) in
- Llet(Strict, mid,
- subst_lambda subst (transl_module Tcoerce_none None modl),
- store_idents 0 ids)
+ mk_lam (Llet(Alias, id,
+ mk_lam (Lprim(Pfield pos, [mk_lam (Lvar mid)])),
+ mk_lam (Lsequence(store_ident id, store_idents (pos + 1) idl)))) in
+ mk_lam (Llet(Strict, mid,
+ subst_lambda subst (transl_module Tcoerce_none None modl),
+ store_idents 0 ids))
and store_ident id =
try
let (pos, cc) = Ident.find_same id map in
- let init_val = apply_coercion cc (Lvar id) in
- Lprim(Psetfield(pos, false), [Lprim(Pgetglobal glob, []); init_val])
+ let init_val = apply_coercion cc (mk_lam (Lvar id)) in
+ mk_lam (Lprim(Psetfield(pos, false), [mk_lam (Lprim(Pgetglobal glob, [])); init_val]))
with Not_found ->
fatal_error("Translmod.store_ident: " ^ Ident.unique_name id)
@@ -457,7 +464,7 @@ let transl_store_structure glob map prims str =
let (pos, cc) = Ident.find_same id map in
match cc with
Tcoerce_none ->
- Ident.add id (Lprim(Pfield pos, [Lprim(Pgetglobal glob, [])])) subst
+ Ident.add id (mk_lam (Lprim(Pfield pos, [mk_lam (Lprim(Pgetglobal glob, []))]))) subst
| _ ->
if may_coerce then subst else assert false
with Not_found ->
@@ -467,9 +474,10 @@ let transl_store_structure glob map prims str =
List.fold_right (add_ident may_coerce) idlist subst
and store_primitive (pos, prim) cont =
- Lsequence(Lprim(Psetfield(pos, false),
- [Lprim(Pgetglobal glob, []); transl_primitive prim]),
- cont)
+ mk_lam (Lsequence(mk_lam (Lprim(Psetfield(pos, false),
+ [mk_lam (Lprim(Pgetglobal glob, []));
+ transl_primitive prim])),
+ cont))
in List.fold_right store_primitive prims (transl_store !transl_store_subst str)
@@ -573,21 +581,19 @@ let toplevel_name id =
with Not_found -> Ident.name id
let toploop_getvalue id =
- Lapply(Lprim(Pfield toploop_getvalue_pos,
- [Lprim(Pgetglobal toploop_ident, [])]),
- [Lconst(Const_base(Const_string (toplevel_name id)))],
- Location.none)
+ mk_lam (Lapply(mk_lam(Lprim(Pfield toploop_getvalue_pos,
+ [mk_lam (Lprim(Pgetglobal toploop_ident, []))])),
+ [mk_lam (Lconst(Const_base(Const_string (toplevel_name id))))]))
let toploop_setvalue id lam =
- Lapply(Lprim(Pfield toploop_setvalue_pos,
- [Lprim(Pgetglobal toploop_ident, [])]),
- [Lconst(Const_base(Const_string (toplevel_name id))); lam],
- Location.none)
+ mk_lam (Lapply(mk_lam(Lprim(Pfield toploop_setvalue_pos,
+ [mk_lam (Lprim(Pgetglobal toploop_ident, []))])),
+ [mk_lam (Lconst(Const_base(Const_string (toplevel_name id)))); lam]))
-let toploop_setvalue_id id = toploop_setvalue id (Lvar id)
+let toploop_setvalue_id id = toploop_setvalue id (mk_lam (Lvar id))
let close_toplevel_term lam =
- IdentSet.fold (fun id l -> Llet(Strict, id, toploop_getvalue id, l))
+ IdentSet.fold (fun id l -> mk_lam (Llet(Strict, id, toploop_getvalue id, l)))
(free_variables lam) lam
let transl_toplevel_item = function
@@ -626,13 +632,13 @@ let transl_toplevel_item = function
be a value named identically *)
let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in
List.iter set_toplevel_unique_name ids;
- Lletrec(List.map
+ mk_lam (Lletrec(List.map
(fun (id, arity, meths, cl, vf) ->
(id, transl_class ids id arity meths cl vf))
cl_list,
make_sequence
(fun (id, _, _, _, _) -> toploop_setvalue_id id)
- cl_list)
+ cl_list))
| Tstr_cltype cl_list ->
lambda_unit
| Tstr_include(modl, ids) ->
@@ -641,9 +647,9 @@ let transl_toplevel_item = function
[] ->
lambda_unit
| id :: ids ->
- Lsequence(toploop_setvalue id (Lprim(Pfield pos, [Lvar mid])),
- set_idents (pos + 1) ids) in
- Llet(Strict, mid, transl_module Tcoerce_none None modl, set_idents 0 ids)
+ mk_lam (Lsequence(toploop_setvalue id (mk_lam (Lprim(Pfield pos, [mk_lam (Lvar mid)]))),
+ set_idents (pos + 1) ids)) in
+ mk_lam (Llet(Strict, mid, transl_module Tcoerce_none None modl, set_idents 0 ids))
let transl_toplevel_item_and_close itm =
close_toplevel_term (transl_label_init (transl_toplevel_item itm))
@@ -655,8 +661,8 @@ let transl_toplevel_definition str =
(* Compile the initialization code for a packed library *)
let get_component = function
- None -> Lconst const_unit
- | Some id -> Lprim(Pgetglobal id, [])
+ None -> mk_lam (Lconst const_unit)
+ | Some id -> mk_lam (Lprim(Pgetglobal id, []))
let transl_package component_names target_name coercion =
let components =
@@ -670,30 +676,31 @@ let transl_package component_names target_name coercion =
pos_cc_list
| _ ->
assert false in
- Lprim(Psetglobal target_name, [Lprim(Pmakeblock(0, Immutable), components)])
+ mk_lam (Lprim(Psetglobal target_name,
+ [mk_lam (Lprim(Pmakeblock(0, Immutable), components))]))
let transl_store_package component_names target_name coercion =
let rec make_sequence fn pos arg =
match arg with
[] -> lambda_unit
- | hd :: tl -> Lsequence(fn pos hd, make_sequence fn (pos + 1) tl) in
+ | hd :: tl -> mk_lam (Lsequence(fn pos hd, make_sequence fn (pos + 1) tl)) in
match coercion with
Tcoerce_none ->
(List.length component_names,
make_sequence
(fun pos id ->
- Lprim(Psetfield(pos, false),
- [Lprim(Pgetglobal target_name, []);
- get_component id]))
+ mk_lam (Lprim(Psetfield(pos, false),
+ [mk_lam (Lprim(Pgetglobal target_name, []));
+ get_component id])))
0 component_names)
| Tcoerce_structure pos_cc_list ->
let id = Array.of_list component_names in
(List.length pos_cc_list,
make_sequence
(fun dst (src, cc) ->
- Lprim(Psetfield(dst, false),
- [Lprim(Pgetglobal target_name, []);
- apply_coercion cc (get_component id.(src))]))
+ mk_lam (Lprim(Psetfield(dst, false),
+ [mk_lam (Lprim(Pgetglobal target_name, []));
+ apply_coercion cc (get_component id.(src))])))
0 pos_cc_list)
| _ -> assert false
diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml
index f72e34b..7ee894e 100644
--- a/bytecomp/translobj.ml
+++ b/bytecomp/translobj.ml
@@ -18,6 +18,12 @@ open Asttypes
open Longident
open Lambda
+(* Create a lambda term with a dummy location *)
+let lambda l_desc = {
+ l_loc = Location.none;
+ l_desc;
+}
+
(* Get oo primitives identifiers *)
let oo_prim name =
@@ -35,13 +41,13 @@ let share c =
match c with
Const_block (n, l) when l <> [] ->
begin try
- Lvar (Hashtbl.find consts c)
+ lambda (Lvar (Hashtbl.find consts c))
with Not_found ->
let id = Ident.create "shared" in
Hashtbl.add consts c id;
- Lvar id
+ lambda (Lvar id)
end
- | _ -> Lconst c
+ | _ -> lambda (Lconst c)
(* Collect labels *)
@@ -50,14 +56,14 @@ let method_cache = ref lambda_unit
let method_count = ref 0
let method_table = ref []
-let meth_tag s = Lconst(Const_base(Const_int(Btype.hash_variant s)))
+let meth_tag s = lambda (Lconst(Const_base(Const_int(Btype.hash_variant s))))
let next_cache tag =
let n = !method_count in
incr method_count;
- (tag, [!method_cache; Lconst(Const_base(Const_int n))])
+ (tag, [!method_cache; lambda (Lconst(Const_base(Const_int n)))])
-let rec is_path = function
+let rec is_path l = match l.l_desc with
Lvar _ | Lprim (Pgetglobal _, []) | Lconst _ -> true
| Lprim (Pfield _, [lam]) -> is_path lam
| Lprim ((Parrayrefu _ | Parrayrefs _), [lam1; lam2]) ->
@@ -88,8 +94,8 @@ let reset_labels () =
(* Insert labels *)
-let string s = Lconst (Const_base (Const_string s))
-let int n = Lconst (Const_base (Const_int n))
+let string s = lambda (Lconst (Const_base (Const_string s)))
+let int n = lambda (Lconst (Const_base (Const_int n)))
let prim_makearray =
{ prim_name = "caml_make_vect"; prim_arity = 2; prim_alloc = true;
@@ -98,23 +104,23 @@ let prim_makearray =
let transl_label_init expr =
let expr =
Hashtbl.fold
- (fun c id expr -> Llet(Alias, id, Lconst c, expr))
+ (fun c id expr -> lambda (Llet(Alias, id, lambda (Lconst c), expr)))
consts expr
in
reset_labels ();
expr
let transl_store_label_init glob size f arg =
- method_cache := Lprim(Pfield size, [Lprim(Pgetglobal glob, [])]);
+ method_cache := lambda (Lprim(Pfield size, [lambda (Lprim(Pgetglobal glob, []))]));
let expr = f arg in
let (size, expr) =
if !method_count = 0 then (size, expr) else
- (size+1,
- Lsequence(
- Lprim(Psetfield(size, false),
- [Lprim(Pgetglobal glob, []);
- Lprim (Pccall prim_makearray, [int !method_count; int 0])]),
- expr))
+ (size+1,
+ lambda (Lsequence(
+ lambda (Lprim(Psetfield(size, false),
+ [lambda (Lprim(Pgetglobal glob, []));
+ lambda (Lprim (Pccall prim_makearray, [int !method_count; int 0]))])),
+ expr)))
in
(size, transl_label_init expr)
@@ -132,28 +138,28 @@ let oo_add_class id =
let oo_wrap env req f x =
if !wrapping then
if !cache_required then f x else
- try cache_required := true; let lam = f x in cache_required := false; lam
- with exn -> cache_required := false; raise exn
+ try cache_required := true; let lam = f x in cache_required := false; lam
+ with exn -> cache_required := false; raise exn
else try
- wrapping := true;
- cache_required := req;
- top_env := env;
- classes := [];
- method_ids := IdentSet.empty;
- let lambda = f x in
- let lambda =
- List.fold_left
- (fun lambda id ->
- Llet(StrictOpt, id,
- Lprim(Pmakeblock(0, Mutable),
- [lambda_unit; lambda_unit; lambda_unit]),
- lambda))
- lambda !classes
- in
- wrapping := false;
- top_env := Env.empty;
- lambda
- with exn ->
- wrapping := false;
- top_env := Env.empty;
- raise exn
+ wrapping := true;
+ cache_required := req;
+ top_env := env;
+ classes := [];
+ method_ids := IdentSet.empty;
+ let l = f x in
+ let lambda =
+ List.fold_left
+ (fun expr id ->
+ lambda (Llet(StrictOpt, id,
+ lambda (Lprim(Pmakeblock(0, Mutable),
+ [lambda_unit; lambda_unit; lambda_unit])),
+ expr)))
+ l !classes
+ in
+ wrapping := false;
+ top_env := Env.empty;
+ lambda
+ with exn ->
+ wrapping := false;
+ top_env := Env.empty;
+ raise exn
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment