merge with trunk at rev 14512ephemeron

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/ephemeron@14514 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

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