summaryrefslogtreecommitdiff
path: root/bytecomp
diff options
context:
space:
mode:
Diffstat (limited to 'bytecomp')
-rw-r--r--bytecomp/bytegen.ml13
-rw-r--r--bytecomp/bytepackager.ml2
-rw-r--r--bytecomp/lambda.ml27
-rw-r--r--bytecomp/lambda.mli8
-rw-r--r--bytecomp/matching.ml139
-rw-r--r--bytecomp/matching.mli8
-rw-r--r--bytecomp/printlambda.ml20
-rw-r--r--bytecomp/simplif.ml25
-rw-r--r--bytecomp/translclass.ml22
-rw-r--r--bytecomp/translcore.ml22
-rw-r--r--bytecomp/translmod.ml146
-rw-r--r--bytecomp/translobj.ml9
12 files changed, 353 insertions, 88 deletions
diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
index 6ecd41dde1..3b25c3db3b 100644
--- a/bytecomp/bytegen.ml
+++ b/bytecomp/bytegen.ml
@@ -275,6 +275,10 @@ let compunit_name = ref ""
let max_stack_used = ref 0
+
+(* Sequence of string tests *)
+
+
(* Translate a primitive to a bytecode instruction (possibly a call to a C
function) *)
@@ -618,7 +622,7 @@ let rec comp_expr env exp sz cont =
comp_args env args sz (comp_primitive p args :: cont)
| Lprim(p, args) ->
comp_args env args sz (comp_primitive p args :: cont)
- | Lstaticcatch (body, (i, vars) , handler) ->
+ | Lstaticcatch (body, (i, vars) , handler) ->
let nvars = List.length vars in
let branch1, cont1 = make_branch cont in
let r =
@@ -703,7 +707,6 @@ let rec comp_expr env exp sz cont =
(fun (n, act) -> act_consts.(n) <- store.act_store act) sw.sw_consts;
List.iter
(fun (n, act) -> act_blocks.(n) <- store.act_store act) sw.sw_blocks;
-
(* Compile and label actions *)
let acts = store.act_get () in
let lbls = Array.create (Array.length acts) 0 in
@@ -723,6 +726,8 @@ let rec comp_expr env exp sz cont =
lbl_consts.(i) <- lbls.(act_consts.(i))
done;
comp_expr env arg sz (Kswitch(lbl_consts, lbl_blocks) :: !c)
+ | Lstringswitch (arg,sw,d) ->
+ comp_expr env (Matching.expand_stringswitch arg sw d) sz cont
| Lassign(id, expr) ->
begin try
let pos = Ident.find_same id env.ce_stack in
@@ -827,6 +832,10 @@ and comp_binary_test env cond ifso ifnot sz cont =
comp_expr env cond sz cont_cond
+(* Compile string switch *)
+
+and comp_string_switch env arg cases default sz cont = ()
+
(**** Compilation of a code block (with tracking of stack usage) ****)
let comp_block env exp sz cont =
diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml
index 8ba2f5321f..9c9c1b842f 100644
--- a/bytecomp/bytepackager.ml
+++ b/bytecomp/bytepackager.ml
@@ -182,6 +182,8 @@ let build_global_target oc target_name members mapping pos coercion =
let lam =
Translmod.transl_package
components (Ident.create_persistent target_name) coercion in
+ if !Clflags.dump_lambda then
+ Format.printf "%a@." Printlambda.lambda lam;
let instrs =
Bytegen.compile_implementation target_name lam in
let rel =
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index b64dee2acd..83c00a32da 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -166,6 +166,7 @@ type lambda =
| Lletrec of (Ident.t * lambda) list * lambda
| Lprim of primitive * lambda list
| Lswitch of lambda * lambda_switch
+ | Lstringswitch of lambda * (string * lambda) list * lambda
| Lstaticraise of int * lambda list
| Lstaticcatch of lambda * (int * Ident.t list) * lambda
| Ltrywith of lambda * Ident.t * lambda
@@ -204,6 +205,8 @@ let rec same l1 l2 =
match (l1, l2) with
| Lvar v1, Lvar v2 ->
Ident.same v1 v2
+ | Lconst (Const_base (Const_string _)), _ ->
+ false (* do not share strings *)
| Lconst c1, Lconst c2 ->
c1 = c2
| Lapply(a1, bl1, _), Lapply(a2, bl2, _) ->
@@ -258,10 +261,10 @@ and sameswitch sw1 sw2 =
| (Some a1, Some a2) -> same a1 a2
| _ -> false)
-let name_lambda arg fn =
+let name_lambda strict arg fn =
match arg with
Lvar id -> fn id
- | _ -> let id = Ident.create "let" in Llet(Strict, id, arg, 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
@@ -295,6 +298,10 @@ let iter f = function
| None -> ()
| Some l -> f l
end
+ | Lstringswitch (arg,cases,default) ->
+ f arg ;
+ List.iter (fun (_,act) -> f act) cases ;
+ f default
| Lstaticraise (_,args) ->
List.iter f args
| Lstaticcatch(e1, (_,vars), e2) ->
@@ -345,7 +352,7 @@ let free_ids get l =
| Lassign(id, e) ->
fv := IdentSet.add id !fv
| Lvar _ | Lconst _ | Lapply _
- | Lprim _ | Lswitch _ | Lstaticraise _
+ | Lprim _ | Lswitch _ | Lstringswitch _ | Lstaticraise _
| Lifthenelse _ | Lsequence _ | Lwhile _
| Lsend _ | Levent _ | Lifused _ -> ()
in free l; !fv
@@ -383,14 +390,19 @@ let rec patch_guarded patch = function
(* Translate an access path *)
-let rec transl_path = function
+let rec transl_normal_path = function
Pident id ->
if Ident.global id then Lprim(Pgetglobal id, []) else Lvar id
| Pdot(p, s, pos) ->
- Lprim(Pfield pos, [transl_path p])
+ Lprim(Pfield pos, [transl_normal_path p])
| Papply(p1, p2) ->
fatal_error "Lambda.transl_path"
+(* Translation of value identifiers *)
+
+let transl_path ?(loc=Location.none) env path =
+ transl_normal_path (Env.normalize_path (Some loc) env path)
+
(* Compile a sequence of expressions *)
let rec make_sequence fn = function
@@ -423,7 +435,9 @@ let subst_lambda s lam =
match sw.sw_failaction with
| None -> None
| Some l -> Some (subst l)})
-
+ | Lstringswitch (arg,cases,default) ->
+ Lstringswitch
+ (subst arg,List.map subst_strcase cases,subst default)
| 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)
@@ -438,6 +452,7 @@ let subst_lambda s lam =
| Lifused (v, e) -> Lifused (v, subst e)
and subst_decl (id, exp) = (id, subst exp)
and subst_case (key, case) = (key, subst case)
+ and subst_strcase (key, case) = (key, subst case)
in subst lam
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
index ccc5fc640f..6748fefe1a 100644
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -175,6 +175,9 @@ type lambda =
| Lletrec of (Ident.t * lambda) list * lambda
| Lprim of primitive * lambda list
| Lswitch of lambda * lambda_switch
+(* switch on strings, clauses are sorted by string order,
+ strings are pairwise distinct *)
+ | Lstringswitch of lambda * (string * lambda) list * lambda
| Lstaticraise of int * lambda list
| Lstaticcatch of lambda * (int * Ident.t list) * lambda
| Ltrywith of lambda * Ident.t * lambda
@@ -207,7 +210,7 @@ and lambda_event_kind =
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: let_kind -> lambda -> (Ident.t -> lambda) -> lambda
val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda
val iter: (lambda -> unit) -> lambda -> unit
@@ -215,7 +218,8 @@ module IdentSet: Set.S with type elt = Ident.t
val free_variables: lambda -> IdentSet.t
val free_methods: lambda -> IdentSet.t
-val transl_path: Path.t -> lambda
+val transl_normal_path: Path.t -> lambda (* Path.t is already normal *)
+val transl_path: ?loc:Location.t -> Env.t -> Path.t -> lambda
val make_sequence: ('a -> lambda) -> 'a list -> lambda
val subst_lambda: lambda Ident.tbl -> lambda -> lambda
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index 7387ea64ae..e981483195 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -443,7 +443,9 @@ let pretty_precompiled_res first nexts =
-(* A slight attempt to identify semantically equivalent lambda-expressions *)
+(* A slight attempt to identify semantically equivalent lambda-expressions,
+ We could have used Lambda.same, but our goal here is also to
+ find alpha-equivalent (simple) terms *)
exception Not_simple
let rec raw_rec env : lambda -> lambda = function
@@ -454,6 +456,8 @@ let rec raw_rec env : lambda -> lambda = function
end
| Lprim (Pfield i,args) ->
Lprim (Pfield i, List.map (raw_rec env) args)
+ | Lconst (Const_base (Const_string _)) ->
+ raise Not_simple (* do not share strings *)
| Lconst _ as l -> l
| Lstaticraise (i,args) ->
Lstaticraise (i, List.map (raw_rec env) args)
@@ -1648,10 +1652,110 @@ let divide_array kind ctx pm =
(make_array_matching kind)
(=) get_key_array get_args_array ctx pm
+(*
+ Specific string test sequence
+ Will be called by the bytecode compiler, from bytegen.ml.
+ The strategy is first dichotomic search (we perform 3-way tests
+ with compare_string), then sequence of equality tests
+ when there are less then T=strings_test_threshold static strings to match.
+
+ Increasing T entails (slightly) less code, decreasing T
+ (slightly) favors runtime speed.
+ T=8 looks a decent tradeoff.
+*)
+
+(* Utlities *)
+
+let strings_test_threshold = 8
+
+let prim_string_notequal =
+ Pccall{prim_name = "caml_string_notequal";
+ prim_arity = 2; prim_alloc = false;
+ prim_native_name = ""; prim_native_float = false}
+
+let prim_string_compare =
+ Pccall{prim_name = "caml_string_compare";
+ prim_arity = 2; prim_alloc = false;
+ prim_native_name = ""; prim_native_float = false}
+
+let bind_sw arg k = match arg with
+| Lvar _ -> k arg
+| _ ->
+ let id = Ident.create "switch" in
+ Llet (Strict,id,arg,k (Lvar id))
+
+
+(* Sequential equality tests *)
+
+let make_test_sequence arg sw d =
+ bind_sw arg
+ (fun arg ->
+ List.fold_right
+ (fun (s,lam) k ->
+ Lifthenelse
+ (Lprim
+ (prim_string_notequal,
+ [arg; Lconst (Const_immstring s)]),
+ k,lam))
+ sw d)
+
+let catch_sw d k = match d with
+| Lstaticraise (_,[]) -> k d
+| _ ->
+ let e = next_raise_count () in
+ Lstaticcatch (k (Lstaticraise (e,[])),(e,[]),d)
+
+let rec split k xs = match xs with
+| [] -> assert false
+| x0::xs ->
+ if k <= 1 then [],x0,xs
+ else
+ let xs,y0,ys = split (k-2) xs in
+ x0::xs,y0,ys
+
+let zero_lam = Lconst (Const_base (Const_int 0))
+
+let tree_way_test arg lt eq gt =
+ Lifthenelse
+ (Lprim (Pintcomp Clt,[arg;zero_lam]),lt,
+ Lifthenelse(Lprim (Pintcomp Clt,[zero_lam;arg]),gt,eq))
+
+(* Dichotomic tree *)
+
+let rec do_make_tree arg sw d =
+ let len = List.length sw in
+ if len <= strings_test_threshold then make_test_sequence arg sw d
+ else
+ let lt,(s,act),gt = split len sw in
+ bind_sw
+ (Lprim
+ (prim_string_compare,
+ [arg; Lconst (Const_immstring s)];))
+ (fun r ->
+ tree_way_test r
+ (do_make_tree arg lt d)
+ act
+ (do_make_tree arg gt d))
+
+(* Entry point *)
+let expand_stringswitch arg sw d =
+ bind_sw arg (fun arg -> catch_sw d (fun d -> do_make_tree arg sw d))
+
+(*************************************)
(* To combine sub-matchings together *)
+(*************************************)
+
+(* Note: dichotomic search requires sorted input with no duplicates *)
+let rec uniq_lambda_list sw = match sw with
+ | []|[_] -> sw
+ | (c1,_ as p1)::((c2,_)::sw2 as sw1) ->
+ if const_compare c1 c2 = 0 then uniq_lambda_list (p1::sw2)
+ else p1::uniq_lambda_list sw1
let sort_lambda_list l =
- List.sort (fun (x,_) (y,_) -> const_compare x y) l
+ let l =
+ List.stable_sort (fun (x,_) (y,_) -> const_compare x y) l in
+ uniq_lambda_list l
let rec cut n l =
if n = 0 then [],l
@@ -1694,13 +1798,6 @@ let make_test_sequence fail tst lt_tst arg const_lambda_list =
let make_offset x arg = if x=0 then arg else Lprim(Poffsetint(x), [arg])
-
-
-let prim_string_notequal =
- Pccall{prim_name = "caml_string_notequal";
- prim_arity = 2; prim_alloc = false;
- prim_native_name = ""; prim_native_float = false}
-
let rec explode_inter offset i j act k =
if i <= j then
explode_inter offset i (j-1) act ((j-offset,act)::k)
@@ -2097,8 +2194,22 @@ let combine_constant arg cst partial ctx def
(fun i -> Lconst (Const_base (Const_int i)))
fail arg 0 255 int_lambda_list
| Const_string _ ->
- make_test_sequence
- fail prim_string_notequal Pignore arg const_lambda_list
+(* Note as the bytecode compiler may resort to dichotmic search,
+ the clauses of strinswitch are sorted with duplicate removed.
+ This partly applies to the native code compiler, which requires
+ no duplicates *)
+ let fail,const_lambda_list = match fail with
+ | Some fail -> fail,sort_lambda_list const_lambda_list
+ | None ->
+ let cls,(_,lst) = Misc.split_last const_lambda_list in
+ lst,sort_lambda_list cls in
+ let sw =
+ List.map
+ (fun (c,act) -> match c with
+ | Const_string (s,_) -> s,act
+ | _ -> assert false)
+ const_lambda_list in
+ Lstringswitch (arg,sw,fail)
| Const_float _ ->
make_test_sequence
fail
@@ -2163,7 +2274,9 @@ let combine_constructor arg ex_pat cstr partial ctx def
else Lprim(Pfield 0, [arg])
in
Lifthenelse(Lprim(Pintcomp Ceq,
- [slot; transl_path path]),
+ [slot;
+ transl_path ~loc:ex_pat.pat_loc
+ ex_pat.pat_env path]),
act, rem)
| _ -> assert false)
tests default in
@@ -2734,7 +2847,7 @@ 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 Raise_regular, [Lprim(Pmakeblock(0, Immutable),
- [transl_path Predef.path_match_failure;
+ [transl_normal_path Predef.path_match_failure;
Lconst(Const_block(0,
[Const_base(Const_string (fname, None));
Const_base(Const_int line);
diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli
index 5c8577b26b..398143778b 100644
--- a/bytecomp/matching.mli
+++ b/bytecomp/matching.mli
@@ -15,6 +15,8 @@
open Typedtree
open Lambda
+
+(* Entry points to match compiler *)
val for_function:
Location.t -> int ref option -> lambda -> (pattern * lambda) list ->
partial -> lambda
@@ -34,8 +36,14 @@ exception Cannot_flatten
val flatten_pattern: int -> pattern -> pattern list
+(* Expand stringswitch to string test tree *)
+
+val expand_stringswitch: lambda -> (string * lambda) list -> lambda -> lambda
+
+(*
val make_test_sequence:
lambda option -> primitive -> primitive -> lambda ->
(Asttypes.constant * lambda) list -> lambda
+*)
val inline_lazy_force : lambda -> Location.t -> lambda
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index 3ef160fe21..e02196f9b9 100644
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -255,12 +255,15 @@ let rec lam ppf = function
fprintf ppf ")" in
fprintf ppf "@[<2>(function%a@ %a)@]" pr_params params lam body
| Llet(str, id, arg, body) ->
+ let kind = function
+ Alias -> "a" | Strict -> "" | StrictOpt -> "o" | Variable -> "v" in
let rec letbody = function
| Llet(str, id, arg, body) ->
- fprintf ppf "@ @[<2>%a@ %a@]" Ident.print id lam arg;
+ fprintf ppf "@ @[<2>%a =%s@ %a@]" Ident.print id (kind str) lam arg;
letbody body
| expr -> expr in
- fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a@ %a@]" Ident.print id lam arg;
+ fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a =%s@ %a@]"
+ Ident.print id (kind str) lam arg;
let expr = letbody body in
fprintf ppf ")@]@ %a)@]" lam expr
| Lletrec(id_arg_list, body) ->
@@ -296,11 +299,22 @@ let rec lam ppf = function
if !spc then fprintf ppf "@ " else spc := true;
fprintf ppf "@[<hv 1>default:@ %a@]" lam l
end in
-
fprintf ppf
"@[<1>(%s %a@ @[<v 0>%a@])@]"
(match sw.sw_failaction with None -> "switch*" | _ -> "switch")
lam larg switch sw
+ | Lstringswitch(arg, cases, default) ->
+ let switch ppf cases =
+ let spc = ref false in
+ List.iter
+ (fun (s, l) ->
+ if !spc then fprintf ppf "@ " else spc := true;
+ fprintf ppf "@[<hv 1>case \"%s\":@ %a@]" (String.escaped s) lam l)
+ cases;
+ if !spc then fprintf ppf "@ " else spc := true;
+ fprintf ppf "@[<hv 1>default:@ %a@]" lam default in
+ fprintf ppf
+ "@[<1>(stringswitch %a@ @[<v 0>%a@])@]" lam arg switch cases
| Lstaticraise (i, ls) ->
let lams ppf largs =
List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml
index e60bb6d168..c03cd857e7 100644
--- a/bytecomp/simplif.ml
+++ b/bytecomp/simplif.ml
@@ -54,6 +54,11 @@ let rec eliminate_ref id = function
sw_failaction = match sw.sw_failaction with
| None -> None
| Some l -> Some (eliminate_ref id l)})
+ | Lstringswitch(e, sw, default) ->
+ Lstringswitch
+ (eliminate_ref id e,
+ List.map (fun (s, e) -> (s, eliminate_ref id e)) sw,
+ eliminate_ref id default)
| Lstaticraise (i,args) ->
Lstaticraise (i,List.map (eliminate_ref id) args)
| Lstaticcatch(e1, i, e2) ->
@@ -115,6 +120,10 @@ let simplify_exits lam =
count l;
List.iter (fun (_, l) -> count l) sw.sw_consts;
List.iter (fun (_, l) -> count l) sw.sw_blocks
+ | Lstringswitch(l, sw, d) ->
+ count l;
+ List.iter (fun (_, l) -> count l) sw;
+ count d
| Lstaticraise (i,ls) -> incr_exit i ; List.iter count ls
| Lstaticcatch (l1,(i,[]),Lstaticraise (j,[])) ->
(* i will be replaced by j in l1, so each occurence of i in l1
@@ -216,6 +225,9 @@ let simplify_exits lam =
(new_l,
{sw with sw_consts = new_consts ; sw_blocks = new_blocks;
sw_failaction = new_fail})
+ | Lstringswitch(l,sw,d) ->
+ Lstringswitch
+ (simplif l,List.map (fun (s,l) -> s,simplif l) sw,simplif d)
| Lstaticraise (i,[]) as l ->
begin try
let _,handler = Hashtbl.find subst i in
@@ -361,6 +373,10 @@ let simplify_lets lam =
count bv l;
List.iter (fun (_, l) -> count bv l) sw.sw_consts;
List.iter (fun (_, l) -> count bv l) sw.sw_blocks
+ | Lstringswitch(l, sw, d) ->
+ count bv l ;
+ List.iter (fun (_, l) -> count bv l) sw ;
+ count bv d
| Lstaticraise (i,ls) -> List.iter (count bv) ls
| Lstaticcatch(l1, (i,_), l2) -> count bv l1; count bv l2
| Ltrywith(l1, v, l2) -> count bv l1; count bv l2
@@ -460,6 +476,9 @@ let simplify_lets lam =
(new_l,
{sw with sw_consts = new_consts ; sw_blocks = new_blocks;
sw_failaction = new_fail})
+ | Lstringswitch (l,sw,d) ->
+ Lstringswitch
+ (simplif l,List.map (fun (s,l) -> s,simplif l) sw,simplif d)
| Lstaticraise (i,ls) ->
Lstaticraise (i, List.map simplif ls)
| Lstaticcatch(l1, (i,args), l2) ->
@@ -521,6 +540,12 @@ let rec emit_tail_infos is_tail lambda =
emit_tail_infos false lam;
list_emit_tail_infos_fun snd is_tail sw.sw_consts;
list_emit_tail_infos_fun snd is_tail sw.sw_blocks
+ | Lstringswitch (lam, sw, d) ->
+ emit_tail_infos false lam;
+ List.iter
+ (fun (_,lam) -> emit_tail_infos is_tail lam)
+ sw ;
+ emit_tail_infos is_tail d
| Lstaticraise (_, l) ->
list_emit_tail_infos false l
| Lstaticcatch (body, _, handler) ->
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index b22c0adafb..55ddab3bc8 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -115,6 +115,9 @@ let name_pattern default p =
| Tpat_alias(p, id, _) -> id
| _ -> Ident.create default
+let normalize_cl_path cl path =
+ Env.normalize_path (Some cl.cl_loc) cl.cl_env path
+
let rec build_object_init cl_table obj params inh_init obj_init cl =
match cl.cl_desc with
Tcl_ident ( path, _, _) ->
@@ -124,7 +127,8 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
match envs with None -> []
| Some envs -> [Lprim(Pfield (List.length inh_init + 1), [Lvar envs])]
in
- ((envs, (obj_init, path)::inh_init),
+ ((envs, (obj_init, normalize_cl_path cl path)
+ ::inh_init),
mkappl(Lvar obj_init, env @ [obj]))
| Tcl_structure str ->
create_object cl_table obj (fun obj ->
@@ -253,7 +257,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
Tcl_ident ( path, _, _) ->
begin match inh_init with
(obj_init, path')::inh_init ->
- let lpath = transl_path path in
+ let lpath = transl_path ~loc:cl.cl_loc cl.cl_env path in
(inh_init,
Llet (Strict, obj_init,
mkappl(Lprim(Pfield 1, [lpath]), Lvar cla ::
@@ -331,8 +335,8 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
let cl = ignore_cstrs cl in
begin match cl.cl_desc, inh_init with
Tcl_ident (path, _, _), (obj_init, path')::inh_init ->
- assert (Path.same path path');
- let lpath = transl_path path in
+ assert (Path.same (normalize_cl_path cl path) path');
+ let lpath = transl_normal_path path' in
let inh = Ident.create "inh"
and ofs = List.length vals + 1
and valids, methids = super in
@@ -398,7 +402,7 @@ let rec transl_class_rebind obj_init cl vf =
try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit
with Not_found -> raise Exit
end;
- (path, obj_init)
+ (normalize_cl_path cl path, obj_init)
| Tcl_fun (_, pat, _, cl, partial) ->
let path, obj_init = transl_class_rebind obj_init cl vf in
let build params rem =
@@ -446,7 +450,7 @@ let transl_class_rebind ids cl vf =
if not (Translcore.check_recursive_lambda ids obj_init') then
raise(Error(cl.cl_loc, Illegal_class_expr));
let id = (obj_init' = lfunction [self] obj_init0) in
- if id then transl_path path else
+ if id then transl_normal_path path else
let cla = Ident.create "class"
and new_init = Ident.create "new_init"
@@ -456,7 +460,7 @@ let transl_class_rebind ids cl vf =
Llet(
Strict, new_init, lfunction [obj_init] obj_init',
Llet(
- Alias, cla, transl_path path,
+ Alias, cla, transl_normal_path path,
Lprim(Pmakeblock(0, Immutable),
[mkappl(Lvar new_init, [lfield cla 0]);
lfunction [table]
@@ -741,7 +745,7 @@ let transl_class ids cl_id pub_meths cl vflag =
Lprim(Pmakeblock(0, Immutable),
menv :: List.map (fun id -> Lvar id) !new_ids_init)
and linh_envs =
- List.map (fun (_, p) -> Lprim(Pfield 3, [transl_path p]))
+ List.map (fun (_, p) -> Lprim(Pfield 3, [transl_normal_path p]))
(List.rev inh_init)
in
let make_envs lam =
@@ -758,7 +762,7 @@ let transl_class ids cl_id pub_meths cl vflag =
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) -> Lprim(Pfield 1, [transl_normal_path p])) inh_paths in
let lclass lam =
Llet(Strict, class_init,
Lfunction(Curried, [cla], def_ids cla cl_init), lam)
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index d63381631c..526c0f576f 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -589,7 +589,7 @@ let assert_failed exp =
Location.get_pos_info exp.exp_loc.Location.loc_start in
Lprim(Praise Raise_regular, [event_after exp
(Lprim(Pmakeblock(0, Immutable),
- [transl_path Predef.path_assert_failure;
+ [transl_normal_path Predef.path_assert_failure;
Lconst(Const_block(0,
[Const_base(Const_string (fname, None));
Const_base(Const_int line);
@@ -635,7 +635,7 @@ and transl_exp0 e =
| Texp_ident(path, _, {val_kind = Val_anc _}) ->
raise(Error(e.exp_loc, Free_super_var))
| Texp_ident(path, _, {val_kind = Val_reg | Val_self _}) ->
- transl_path path
+ transl_path ~loc:e.exp_loc e.exp_env path
| Texp_ident _ -> fatal_error "Translcore.transl_exp: bad Texp_ident"
| Texp_constant cst ->
Lconst(Const_base cst)
@@ -734,7 +734,7 @@ and transl_exp0 e =
Lprim(Pmakeblock(n, Immutable), ll)
end
| Cstr_exception (path, _) ->
- let slot = transl_path path in
+ let slot = transl_path ~loc:e.exp_loc e.exp_env path in
if cstr.cstr_arity = 0 then slot
else Lprim(Pmakeblock(0, Immutable), slot :: ll)
end
@@ -813,16 +813,18 @@ and transl_exp0 e =
Lsend (kind, tag, obj, cache, e.exp_loc)
in
event_after e lam
- | Texp_new (cl, _, _) ->
- Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit], Location.none)
+ | Texp_new (cl, {Location.loc=loc}, _) ->
+ Lapply(Lprim(Pfield 0, [transl_path ~loc e.exp_env cl]),
+ [lambda_unit], Location.none)
| Texp_instvar(path_self, path, _) ->
- Lprim(Parrayrefu Paddrarray, [transl_path path_self; transl_path path])
+ Lprim(Parrayrefu Paddrarray,
+ [transl_normal_path path_self; transl_normal_path path])
| Texp_setinstvar(path_self, path, _, expr) ->
- transl_setinstvar (transl_path path_self) path expr
+ transl_setinstvar (transl_normal_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],
+ Lapply(Translobj.oo_prim "copy", [transl_normal_path path_self],
Location.none),
List.fold_right
(fun (path, _, expr) rem ->
@@ -887,7 +889,7 @@ and transl_exp0 e =
(* 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])
+ Lprim(Pmakeblock(Config.lazy_tag, Mutable), [fn])
end
| Texp_object (cs, meths) ->
let cty = cs.cstr_type in
@@ -1044,7 +1046,7 @@ and transl_let rec_flag pat_expr_list body =
and transl_setinstvar self var expr =
Lprim(Parraysetu (if maybe_pointer expr then Paddrarray else Pintarray),
- [self; transl_path var; transl_exp expr])
+ [self; transl_normal_path var; transl_exp expr])
and transl_record all_labels repres lbl_expr_list opt_init_expr =
let size = Array.length all_labels in
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index 10915d8533..4b3141ad90 100644
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -44,32 +44,48 @@ let transl_exception path decl =
| Some p -> Path.name p
in
Lprim(prim_set_oo_id,
- [Lprim(Pmakeblock(Obj.object_tag, Immutable),
+ [Lprim(Pmakeblock(Obj.object_tag, Mutable),
[Lconst(Const_base(Const_string (name,None)));
Lconst(Const_base(Const_int 0))])])
(* Compile a coercion *)
-let rec apply_coercion restr arg =
+let rec apply_coercion strict restr arg =
match restr with
Tcoerce_none ->
arg
- | Tcoerce_structure pos_cc_list ->
- name_lambda arg (fun id ->
- Lprim(Pmakeblock(0, Immutable),
- List.map (apply_coercion_field id) pos_cc_list))
+ | Tcoerce_structure(pos_cc_list, id_pos_list) ->
+ name_lambda strict arg (fun id ->
+ let lam =
+ Lprim(Pmakeblock(0, Immutable),
+ List.map (apply_coercion_field id) pos_cc_list) in
+ let fv = free_variables lam in
+ let (lam,s) =
+ List.fold_left (fun (lam,s) (id',pos,c) ->
+ if IdentSet.mem id' fv then
+ let id'' = Ident.create (Ident.name id') in
+ (Llet(Alias,id'',
+ apply_coercion Alias c (Lprim(Pfield pos,[Lvar id])),lam),
+ Ident.add id' (Lvar id'') s)
+ else (lam,s))
+ (lam, Ident.empty) id_pos_list
+ in
+ if s == Ident.empty then lam else subst_lambda s lam)
| Tcoerce_functor(cc_arg, cc_res) ->
let param = Ident.create "funarg" in
- name_lambda arg (fun id ->
+ name_lambda strict arg (fun id ->
Lfunction(Curried, [param],
- apply_coercion cc_res
- (Lapply(Lvar id, [apply_coercion cc_arg (Lvar param)],
+ apply_coercion Strict cc_res
+ (Lapply(Lvar id, [apply_coercion Alias cc_arg (Lvar param)],
Location.none))))
| Tcoerce_primitive p ->
transl_primitive Location.none p
+ | Tcoerce_alias (path, cc) ->
+ name_lambda strict arg
+ (fun id -> apply_coercion Alias cc (transl_normal_path path))
and apply_coercion_field id (pos, cc) =
- apply_coercion cc (Lprim(Pfield pos, [Lvar id]))
+ apply_coercion Alias cc (Lprim(Pfield pos, [Lvar id]))
(* Compose two coercions
apply_coercion c1 (apply_coercion c2 e) behaves like
@@ -79,18 +95,26 @@ let rec compose_coercions c1 c2 =
match (c1, c2) with
(Tcoerce_none, c2) -> c2
| (c1, Tcoerce_none) -> c1
- | (Tcoerce_structure pc1, Tcoerce_structure pc2) ->
+ | (Tcoerce_structure (pc1, ids1), Tcoerce_structure (pc2, ids2)) ->
let v2 = Array.of_list pc2 in
+ let ids1 =
+ List.map (fun (id,pos1,c1) ->
+ let (pos2,c2) = v2.(pos1) in (id, pos2, compose_coercions c1 c2))
+ ids1
+ in
Tcoerce_structure
(List.map
(function (p1, Tcoerce_primitive p) ->
(p1, Tcoerce_primitive p)
| (p1, c1) ->
let (p2, c2) = v2.(p1) in (p2, compose_coercions c1 c2))
- pc1)
+ pc1,
+ ids1 @ ids2)
| (Tcoerce_functor(arg1, res1), Tcoerce_functor(arg2, res2)) ->
Tcoerce_functor(compose_coercions arg2 arg1,
compose_coercions res1 res2)
+ | (c1, Tcoerce_alias (path, c2)) ->
+ Tcoerce_alias (path, compose_coercions c1 c2)
| (_, _) ->
fatal_error "Translmod.compose_coercions"
@@ -119,7 +143,7 @@ let field_path path field =
let mod_prim name =
try
- transl_path
+ transl_normal_path
(fst (Env.lookup_value (Ldot (Lident "CamlinternalMod", name))
Env.empty))
with Not_found ->
@@ -137,6 +161,8 @@ let init_shape modl =
match Mtype.scrape env mty with
Mty_ident _ ->
raise Not_found
+ | Mty_alias _ ->
+ Const_block (1, [Const_pointer 0])
| Mty_signature sg ->
Const_block(0, [Const_block(0, init_shape_struct env sg)])
| Mty_functor(id, arg, res) ->
@@ -264,9 +290,13 @@ let rec bound_value_identifiers = function
(* Compile a module expression *)
let rec transl_module cc rootpath mexp =
+ match mexp.mod_type with
+ Mty_alias _ -> apply_coercion Alias cc lambda_unit
+ | _ ->
match mexp.mod_desc with
Tmod_ident (path,_) ->
- apply_coercion cc (transl_path path)
+ apply_coercion StrictOpt cc
+ (transl_path ~loc:mexp.mod_loc mexp.mod_env path)
| Tmod_structure str ->
transl_struct [] cc rootpath str
| Tmod_functor( param, _, mty, body) ->
@@ -279,20 +309,21 @@ let rec transl_module cc rootpath mexp =
| Tcoerce_functor(ccarg, ccres) ->
let param' = Ident.create "funarg" in
Lfunction(Curried, [param'],
- Llet(Alias, param, apply_coercion ccarg (Lvar param'),
+ Llet(Alias, param,
+ apply_coercion Alias ccarg (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)
+ (apply_coercion Strict cc)
(Lapply(transl_module Tcoerce_none None funct,
[transl_module ccarg None arg], mexp.mod_loc))
| Tmod_constraint(arg, mty, _, ccarg) ->
transl_module (compose_coercions cc ccarg) rootpath arg
| Tmod_unpack(arg, _) ->
- apply_coercion cc (Translcore.transl_exp arg)
+ apply_coercion Strict cc (Translcore.transl_exp arg)
and transl_struct fields cc rootpath str =
transl_structure fields cc rootpath str.str_items
@@ -303,15 +334,19 @@ and transl_structure fields cc rootpath = function
Tcoerce_none ->
Lprim(Pmakeblock(0, Immutable),
List.map (fun id -> Lvar id) (List.rev fields))
- | Tcoerce_structure pos_cc_list ->
+ | Tcoerce_structure(pos_cc_list, id_pos_list) ->
+ (* ignore id_pos_list as the ids are already bound *)
let v = Array.of_list (List.rev fields) in
- Lprim(Pmakeblock(0, Immutable),
+ (*List.fold_left
+ (fun lam (id, pos) -> Llet(Alias, id, Lvar v.(pos), lam))*)
+ (Lprim(Pmakeblock(0, Immutable),
List.map
(fun (pos, cc) ->
match cc with
Tcoerce_primitive p -> transl_primitive Location.none p
- | _ -> apply_coercion cc (Lvar v.(pos)))
- pos_cc_list)
+ | _ -> apply_coercion Strict cc (Lvar v.(pos)))
+ pos_cc_list))
+ (*id_pos_list*)
| _ ->
fatal_error "Translmod.transl_structure"
end
@@ -332,12 +367,12 @@ and transl_structure fields cc rootpath = function
let id = decl.cd_id in
Llet(Strict, id, transl_exception (field_path rootpath id) decl,
transl_structure (id :: fields) cc rootpath rem)
- | Tstr_exn_rebind( id, _, path, _, _) ->
- Llet(Strict, id, transl_path path,
+ | Tstr_exn_rebind( id, _, path, {Location.loc=loc}, _) ->
+ Llet(Strict, id, transl_path ~loc item.str_env path,
transl_structure (id :: fields) cc rootpath rem)
| Tstr_module mb ->
let id = mb.mb_id in
- Llet(Strict, id,
+ Llet(pure_module mb.mb_expr, id,
transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr,
transl_structure (id :: fields) cc rootpath rem)
| Tstr_recmodule bindings ->
@@ -367,7 +402,7 @@ and transl_structure fields cc rootpath = function
| 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,
+ Llet(pure_module modl, mid, transl_module Tcoerce_none None modl,
rebind_idents 0 fields ids)
| Tstr_modtype _
@@ -376,6 +411,12 @@ and transl_structure fields cc rootpath = function
| Tstr_attribute _ ->
transl_structure fields cc rootpath rem
+and pure_module m =
+ match m.mod_desc with
+ Tmod_ident _ -> Alias
+ | Tmod_constraint (m,_,_,_) -> pure_module m
+ | _ -> Strict
+
(* Update forward declaration in Translcore *)
let _ =
Translcore.transl_module := transl_module
@@ -414,7 +455,7 @@ let rec defined_idents = function
List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ defined_idents rem
| Tstr_class_type cl_list -> defined_idents rem
| Tstr_include(modl, sg, _) -> bound_value_identifiers sg @ defined_idents rem
- | Tstr_attribute _ -> []
+ | Tstr_attribute _ -> defined_idents rem
(* second level idents (module M = struct ... let id = ... end),
and all sub-levels idents *)
@@ -437,7 +478,7 @@ let rec more_idents = function
| Tstr_module {mb_expr={mod_desc = Tmod_structure str}} ->
all_idents str.str_items @ more_idents rem
| Tstr_module _ -> more_idents rem
- | Tstr_attribute _ -> []
+ | Tstr_attribute _ -> more_idents rem
and all_idents = function
[] -> []
@@ -461,7 +502,7 @@ and all_idents = function
| Tstr_module {mb_id;mb_expr={mod_desc = Tmod_structure str}} ->
mb_id :: all_idents str.str_items @ all_idents rem
| Tstr_module mb -> mb.mb_id :: all_idents rem
- | Tstr_attribute _ -> []
+ | Tstr_attribute _ -> all_idents rem
(* A variant of transl_structure used to compile toplevel structure definitions
@@ -509,8 +550,8 @@ let transl_store_structure glob map prims str =
let lam = transl_exception (field_path rootpath id) decl in
Lsequence(Llet(Strict, id, lam, store_ident id),
transl_store rootpath (add_ident false id subst) rem)
- | Tstr_exn_rebind( id, _, path, _, _) ->
- let lam = subst_lambda subst (transl_path path) in
+ | Tstr_exn_rebind( id, _, path, {Location.loc=loc}, _) ->
+ let lam = subst_lambda subst (transl_path ~loc item.str_env path) in
Lsequence(Llet(Strict, id, lam, store_ident id),
transl_store rootpath (add_ident false id subst) rem)
| Tstr_module{mb_id=id; mb_expr={mod_desc = Tmod_structure str}} ->
@@ -527,8 +568,7 @@ let transl_store_structure glob map prims str =
transl_store rootpath (add_ident true id subst)
rem)))
| Tstr_module{mb_id=id; mb_expr=modl} ->
- let lam =
- transl_module Tcoerce_none (field_path rootpath id) modl in
+ let lam = transl_module Tcoerce_none (field_path rootpath id) modl in
(* Careful: the module value stored in the global may be different
from the local module value, in case a coercion is applied.
If so, keep using the local module value (id) in the remainder of
@@ -580,7 +620,7 @@ let transl_store_structure glob map prims str =
and store_ident id =
try
let (pos, cc) = Ident.find_same id map in
- let init_val = apply_coercion cc (Lvar id) in
+ let init_val = apply_coercion Alias cc (Lvar id) in
Lprim(Psetfield(pos, false), [Lprim(Pgetglobal glob, []); init_val])
with Not_found ->
fatal_error("Translmod.store_ident: " ^ Ident.unique_name id)
@@ -633,7 +673,8 @@ let build_ident_map restr idlist more_ids =
match restr with
Tcoerce_none ->
natural_map 0 Ident.empty [] idlist
- | Tcoerce_structure pos_cc_list ->
+ | Tcoerce_structure (pos_cc_list, _id_pos_list) ->
+ (* ignore _id_pos_list as the ids are already bound *)
let idarray = Array.of_list idlist in
let rec export_map pos map prims undef = function
[] ->
@@ -721,14 +762,14 @@ let transl_toplevel_item item =
(make_sequence toploop_setvalue_id idents)
| Tstr_exception decl ->
toploop_setvalue decl.cd_id (transl_exception None decl)
- | Tstr_exn_rebind(id, _, path, _, _) ->
- toploop_setvalue id (transl_path path)
+ | Tstr_exn_rebind(id, _, path, {Location.loc=loc}, _) ->
+ toploop_setvalue id (transl_path ~loc item.str_env path)
| Tstr_module {mb_id=id; mb_expr=modl} ->
(* we need to use the unique name for the module because of issues
with "open" (PR#1672) *)
set_toplevel_unique_name id;
- toploop_setvalue id
- (transl_module Tcoerce_none (Some(Pident id)) modl)
+ let lam = transl_module Tcoerce_none (Some(Pident id)) modl in
+ toploop_setvalue id lam
| Tstr_recmodule bindings ->
let idents = List.map (fun mb -> mb.mb_id) bindings in
compile_recmodule
@@ -782,17 +823,23 @@ let get_component = function
let transl_package component_names target_name coercion =
let components =
+ Lprim(Pmakeblock(0, Immutable), List.map get_component component_names) in
+ Lprim(Psetglobal target_name, [apply_coercion Strict coercion components])
+ (*
+ let components =
match coercion with
Tcoerce_none ->
List.map get_component component_names
- | Tcoerce_structure pos_cc_list ->
+ | Tcoerce_structure (pos_cc_list, id_pos_list) ->
+ (* ignore id_pos_list as the ids are already bound *)
let g = Array.of_list component_names in
List.map
- (fun (pos, cc) -> apply_coercion cc (get_component g.(pos)))
+ (fun (pos, cc) -> apply_coercion Strict cc (get_component g.(pos)))
pos_cc_list
| _ ->
assert false in
Lprim(Psetglobal target_name, [Lprim(Pmakeblock(0, Immutable), components)])
+ *)
let transl_store_package component_names target_name coercion =
let rec make_sequence fn pos arg =
@@ -808,15 +855,30 @@ let transl_store_package component_names target_name coercion =
[Lprim(Pgetglobal target_name, []);
get_component id]))
0 component_names)
- | Tcoerce_structure pos_cc_list ->
+ | Tcoerce_structure (pos_cc_list, id_pos_list) ->
+ let components =
+ Lprim(Pmakeblock(0, Immutable), List.map get_component component_names)
+ in
+ let blk = Ident.create "block" in
+ (List.length pos_cc_list,
+ Llet (Strict, blk, apply_coercion Strict coercion components,
+ make_sequence
+ (fun pos id ->
+ Lprim(Psetfield(pos, false),
+ [Lprim(Pgetglobal target_name, []);
+ Lprim(Pfield pos, [Lvar blk])]))
+ 0 pos_cc_list))
+ (*
+ (* ignore id_pos_list as the ids are already bound *)
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))]))
+ apply_coercion Strict cc (get_component id.(src))]))
0 pos_cc_list)
+ *)
| _ -> assert false
(* Error report *)
diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml
index 437c3d71e3..7f0d8577eb 100644
--- a/bytecomp/translobj.ml
+++ b/bytecomp/translobj.ml
@@ -20,7 +20,7 @@ open Lambda
let oo_prim name =
try
- transl_path
+ transl_normal_path
(fst (Env.lookup_value (Ldot (Lident "CamlinternalOO", name)) Env.empty))
with Not_found ->
fatal_error ("Primitive " ^ name ^ " not found.")
@@ -93,12 +93,19 @@ let prim_makearray =
{ prim_name = "caml_make_vect"; prim_arity = 2; prim_alloc = true;
prim_native_name = ""; prim_native_float = false }
+(* Also use it for required globals *)
let transl_label_init expr =
let expr =
Hashtbl.fold
(fun c id expr -> Llet(Alias, id, Lconst c, expr))
consts expr
in
+ let expr =
+ List.fold_right
+ (fun id expr -> Lsequence(Lprim(Pgetglobal id, []), expr))
+ (Env.get_required_globals ()) expr
+ in
+ Env.reset_required_globals ();
reset_labels ();
expr
View Lorry Controller Status