[compiler]continue enhancing pointer info/module_alias_info

Author: bobzhang

bytecomp/lambda.ml

@@ -78,7 +78,9 @@ type field_dbg_info =
   | Fld_record_inline of string   
   | Fld_record_extension of string 
   | Fld_tuple  
-
+  | Fld_poly_var_tag
+  | Fld_poly_var_content
+  
 let fld_record = ref (fun (lbl : Types.label_description) ->
   Fld_record {name = lbl.lbl_name; mutable_flag = Mutable})
 
@@ -366,6 +368,7 @@ let const_unit = Const_pointer(0, Pt_na)
 
 let lambda_assert_false = Lconst (Const_pointer(0, Pt_constructor {name = "assert false"; cstrs = (1,0)}))  
 
+let lambda_module_alias = Lconst (Const_pointer(0, Pt_module_alias)) 
 
 let lambda_unit = Lconst const_unit
 

bytecomp/lambda.mli

@@ -94,7 +94,9 @@ type field_dbg_info =
   | Fld_record_inline of string 
   | Fld_record_extension of string 
   | Fld_tuple
-
+  | Fld_poly_var_tag
+  | Fld_poly_var_content
+  
 val fld_record :
   (Types.label_description -> 
   field_dbg_info) ref
@@ -414,6 +416,7 @@ val make_key: lambda -> lambda option
 val const_unit: structured_constant
 val lambda_assert_false: lambda
 val lambda_unit: lambda
+val lambda_module_alias : lambda
 val name_lambda: let_kind -> lambda -> (Ident.t -> lambda) -> lambda
 val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda
 

bytecomp/matching.ml

@@ -1405,7 +1405,7 @@ let make_variant_matching_nonconst p lab def ctx = function
       let def = make_default (matcher_variant_nonconst lab) def
       and ctx = filter_ctx p ctx in
       {pm=
-        {cases = []; args = (Lprim(Pfield (1, Fld_na), [arg], p.pat_loc), Alias) :: argl;
+        {cases = []; args = (Lprim(Pfield (1, Fld_poly_var_content), [arg], p.pat_loc), Alias) :: argl;
           default=def} ;
         ctx=ctx ;
         pat = normalize_pat p}
@@ -1609,7 +1609,7 @@ let make_tuple_matching loc arity def = function
       let rec make_args pos =
         if pos >= arity
         then argl
-        else (Lprim(Pfield (pos, Fld_na (* TODO: tuple *)), [arg], loc), Alias) :: make_args (pos + 1) in
+        else (Lprim(Pfield (pos, Fld_tuple), [arg], loc), Alias) :: make_args (pos + 1) in
       {cases = []; args = make_args 0 ;
         default=make_default (matcher_tuple arity) def}
 
@@ -2445,7 +2445,7 @@ let call_switcher_variant_constant loc fail arg int_lambda_list names =
 
 let call_switcher_variant_constr loc fail arg int_lambda_list names =
   let v = Ident.create "variant" in
-  Llet(Alias, Pgenval, v, Lprim(Pfield (0, Fld_na), [arg], loc),
+  Llet(Alias, Pgenval, v, Lprim(Pfield (0, Fld_poly_var_tag), [arg], loc),
        call_switcher loc
          fail (Lvar v) min_int max_int int_lambda_list names)
 

bytecomp/translclass.ml

@@ -61,7 +61,7 @@ let lfield v i = Lprim(Pfield (i, Fld_na), [Lvar v], Location.none)
 let transl_label l = share (Const_immstring l)
 
 let transl_meth_list lst =
-  if lst = [] then Lconst (Const_pointer (0, Lambda.Pt_na)) else
+  if lst = [] then Lconst (Const_pointer (0, Pt_na)) else
   share (Const_block
             (0, Lambda.Blk_array, List.map (fun lab -> Const_immstring lab) lst))
 
@@ -272,8 +272,8 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
           let lpath = transl_class_path ~loc:cl.cl_loc cl.cl_env path in
           (inh_init,
            Llet (Strict, Pgenval, obj_init,
-                 mkappl(Lprim(Pfield (1, Fld_na), [lpath], Location.none), Lvar cla ::
-                        if top then [Lprim(Pfield (3, Fld_na), [lpath], Location.none)]
+                 mkappl(Lprim(Pfield (1, Fld_tuple), [lpath], Location.none), Lvar cla ::
+                        if top then [Lprim(Pfield (3, Fld_tuple), [lpath], Location.none)]
                         else []),
                  bind_super cla super cl_init))
       | _ ->
@@ -529,7 +529,7 @@ let rec builtin_meths self env env2 body =
     | 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, Lambda.Pt_na))]
+        "env", [Lvar env2; Lconst(Const_pointer (n, Pt_na))]
     | Lsend(Self, met, Lvar s, [], _) when List.mem s self ->
         "meth", [met]
     | _ -> raise Not_found
@@ -600,7 +600,7 @@ module M = struct
     | "send_env"   -> SendEnv
     | "send_meth"  -> SendMeth
     | _ -> assert false
-    in Lconst(Const_pointer(Obj.magic tag, Lambda.Pt_na)) :: args
+    in Lconst(Const_pointer(Obj.magic tag, Pt_na)) :: args
 end
 open M
 

bytecomp/translcore.ml

@@ -1135,7 +1135,7 @@ and transl_exp0 e =
   | Texp_new (cl, {Location.loc=loc}, _) ->
       Lapply{ap_should_be_tailcall=false;
              ap_loc=loc;
-             ap_func=Lprim(Pfield (0, Fld_na), [transl_class_path ~loc e.exp_env cl], loc);
+             ap_func=Lprim(Pfield (0, Fld_tuple), [transl_class_path ~loc e.exp_env cl], loc);
              ap_args=[lambda_unit];
              ap_inlined=Default_inline;
              ap_specialised=Default_specialise}

bytecomp/translmod.ml

@@ -464,7 +464,7 @@ and transl_module cc rootpath mexp =
     mexp.mod_attributes;
   let loc = mexp.mod_loc in
   match mexp.mod_type with
-    Mty_alias (Mta_absent, _) -> apply_coercion loc Alias cc lambda_unit
+    Mty_alias (Mta_absent, _) -> apply_coercion loc Alias cc lambda_module_alias
   | _ ->
       match mexp.mod_desc with
         Tmod_ident (path,_) ->