Reference the true interface file (.resi, rei) when an implementation fails to implement its contract

.depend

@@ -579,16 +579,16 @@ bytecomp/lambda.cmi : typing/types.cmi typing/typedtree.cmi \
     typing/primitive.cmi typing/path.cmi parsing/location.cmi \
     typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
 bytecomp/matching.cmo : typing/types.cmi typing/typeopt.cmi \
-    typing/typedtree.cmi bytecomp/switch.cmi bytecomp/printlambda.cmi \
-    typing/primitive.cmi typing/predef.cmi typing/path.cmi \
-    typing/parmatch.cmi utils/misc.cmi parsing/longident.cmi \
+    typing/typedtree.cmi typing/typecore.cmi bytecomp/switch.cmi \
+    bytecomp/printlambda.cmi typing/primitive.cmi typing/predef.cmi \
+    typing/path.cmi typing/parmatch.cmi utils/misc.cmi parsing/longident.cmi \
     parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
     typing/datarepr.cmi utils/config.cmi utils/clflags.cmi typing/btype.cmi \
     parsing/asttypes.cmi bytecomp/matching.cmi
 bytecomp/matching.cmx : typing/types.cmx typing/typeopt.cmx \
-    typing/typedtree.cmx bytecomp/switch.cmx bytecomp/printlambda.cmx \
-    typing/primitive.cmx typing/predef.cmx typing/path.cmx \
-    typing/parmatch.cmx utils/misc.cmx parsing/longident.cmx \
+    typing/typedtree.cmx typing/typecore.cmx bytecomp/switch.cmx \
+    bytecomp/printlambda.cmx typing/primitive.cmx typing/predef.cmx \
+    typing/path.cmx typing/parmatch.cmx utils/misc.cmx parsing/longident.cmx \
     parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \
     typing/datarepr.cmx utils/config.cmx utils/clflags.cmx typing/btype.cmx \
     parsing/asttypes.cmi bytecomp/matching.cmi
@@ -659,15 +659,17 @@ bytecomp/translattribute.cmx : utils/warnings.cmx typing/typedtree.cmx \
 bytecomp/translattribute.cmi : typing/typedtree.cmi parsing/parsetree.cmi \
     parsing/location.cmi bytecomp/lambda.cmi
 bytecomp/translclass.cmo : typing/types.cmi typing/typeopt.cmi \
-    typing/typedtree.cmi bytecomp/translobj.cmi bytecomp/translcore.cmi \
-    typing/path.cmi bytecomp/matching.cmi parsing/location.cmi \
-    bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi utils/clflags.cmi \
-    typing/btype.cmi parsing/asttypes.cmi bytecomp/translclass.cmi
+    typing/typedtree.cmi typing/typecore.cmi bytecomp/translobj.cmi \
+    bytecomp/translcore.cmi typing/path.cmi bytecomp/matching.cmi \
+    parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
+    utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
+    bytecomp/translclass.cmi
 bytecomp/translclass.cmx : typing/types.cmx typing/typeopt.cmx \
-    typing/typedtree.cmx bytecomp/translobj.cmx bytecomp/translcore.cmx \
-    typing/path.cmx bytecomp/matching.cmx parsing/location.cmx \
-    bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx utils/clflags.cmx \
-    typing/btype.cmx parsing/asttypes.cmi bytecomp/translclass.cmi
+    typing/typedtree.cmx typing/typecore.cmx bytecomp/translobj.cmx \
+    bytecomp/translcore.cmx typing/path.cmx bytecomp/matching.cmx \
+    parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \
+    utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
+    bytecomp/translclass.cmi
 bytecomp/translclass.cmi : typing/typedtree.cmi parsing/location.cmi \
     bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi
 bytecomp/translcore.cmo : typing/types.cmi typing/typeopt.cmi \

asmcomp/closure.ml

@@ -43,7 +43,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, Fld_na), [Uvar env_param], Debuginfo.none))
+      Tbl.add id (Uprim(Pfield (pos, Lambda.fld_na), [Uvar env_param], Debuginfo.none))
               (build_closure_env env_param (pos+1) rem)
 
 (* Auxiliary for accessing globals.  We change the name of the global
@@ -765,7 +765,7 @@ let check_constant_result lam ulam approx =
           let glb =
             Uprim(Pgetglobal (Ident.create_persistent id), [], Debuginfo.none)
           in
-          Uprim(Pfield (i,Fld_na), [glb], Debuginfo.none), approx
+          Uprim(Pfield (i,Lambda.fld_na), [glb], Debuginfo.none), approx
       end
   | _ -> (ulam, approx)
 

asmcomp/cmmgen.ml

@@ -1447,7 +1447,7 @@ struct
   let make_isout h arg = Cop (Ccmpa Clt, [h ; arg], Debuginfo.none)
   let make_isin h arg = Cop (Ccmpa Cge, [h ; arg], Debuginfo.none)
   let make_if cond ifso ifnot = Cifthenelse (cond, ifso, ifnot)
-  let make_switch loc arg cases actions _names =
+  let make_switch loc arg cases actions ~offset:_ _names =
     make_switch arg cases actions (Debuginfo.from_location loc)
   let bind arg body = bind "switcher" arg body
 

asmcomp/flambda_to_clambda.ml

@@ -365,7 +365,7 @@ and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda =
         Flambda.print_named named
     end
   | Read_symbol_field (symbol, field) ->
-    Uprim (Pfield (field, Fld_na), [to_clambda_symbol env symbol], Debuginfo.none)
+    Uprim (Pfield (field, Lambda.fld_na), [to_clambda_symbol env symbol], Debuginfo.none)
   | Set_of_closures set_of_closures ->
     to_clambda_set_of_closures t env set_of_closures
   | Project_closure { set_of_closures; closure_id } ->
@@ -390,11 +390,11 @@ and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda =
     let fun_offset = get_fun_offset t closure_id in
     let var_offset = get_fv_offset t var in
     let pos = var_offset - fun_offset in
-    Uprim (Pfield (pos, Fld_na),
+    Uprim (Pfield (pos, Lambda.fld_na),
       [check_field (check_closure ulam (Expr (Var closure))) pos (Some named)],
       Debuginfo.none)
   | Prim (Pfield (index,_), [block], dbg) ->
-    Uprim (Pfield (index, Fld_na), [check_field (subst_var env block) index None], dbg)
+    Uprim (Pfield (index, Lambda.fld_na), [check_field (subst_var env block) index None], dbg)
   | Prim (Psetfield (index, maybe_ptr, init, dbg_info), [block; new_value], dbg) ->
     Uprim (Psetfield (index, maybe_ptr, init, dbg_info), [
         check_field (subst_var env block) index None;
@@ -492,7 +492,7 @@ and to_clambda_set_of_closures t env
         in
         let pos = var_offset - fun_offset in
         Env.add_subst env id
-          (Uprim (Pfield (pos, Fld_na), [Clambda.Uvar env_var], Debuginfo.none))
+          (Uprim (Pfield (pos, Lambda.fld_na), [Clambda.Uvar env_var], Debuginfo.none))
       in
       let env = Variable.Map.fold add_env_free_variable free_vars env in
       (* Add the Clambda expressions for all functions defined in the current

bytecomp/lambda.ml

@@ -35,7 +35,7 @@ type loc_kind =
   | Loc_POS
 
 type tag_info = 
-  | Blk_constructor of string * int (* Number of non-const constructors*)
+  | Blk_constructor of {name : string ; num_nonconst : int}
   | Blk_tuple
   | Blk_array
   | Blk_poly_var of string 
@@ -47,10 +47,9 @@ type tag_info =
   | Blk_na of string
   | Blk_some
   | Blk_some_not_nested (* ['a option] where ['a] can not inhabit a non-like value *)
-  | Blk_record_inlined of string array * string * int 
+  | Blk_record_inlined of { name : string ; num_nonconst :  int; fields : string array} 
   | Blk_record_ext of string array
   | Blk_lazy_general
-  | Blk_lazy_forward
   | Blk_class (* Ocaml style class*) 
 
 let default_tag_info : tag_info = Blk_na ""
@@ -64,28 +63,33 @@ let blk_record_ext =  ref (fun fields ->
     Blk_record_ext all_labels_info
   )
 
-let blk_record_inlined = ref (fun fields name num_nonconsts -> 
-  let all_labels_info = fields |> Array.map (fun (x,_) -> x.Types.lbl_name) in    
-  Blk_record_inlined (all_labels_info, name, num_nonconsts)
+let blk_record_inlined = ref (fun fields name num_nonconst -> 
+  let fields = fields |> Array.map (fun (x,_) -> x.Types.lbl_name) in    
+  Blk_record_inlined {fields; name; num_nonconst}
 ) 
 
 let ref_tag_info : tag_info = Blk_record [| "contents" |]
 
 type field_dbg_info = 
-  | Fld_na
+  | Fld_na of string
   | Fld_record of {name : string; mutable_flag : Asttypes.mutable_flag}
   | Fld_module of {name : string }
   | Fld_record_inline of { name : string}   
   | Fld_record_extension of {name : string}
   | Fld_tuple  
   | Fld_poly_var_tag
   | Fld_poly_var_content
-  | Fld_extension_slot 
+  | Fld_extension
+  | Fld_variant
+  | Fld_cons 
+  | Fld_array
+
 let fld_record = ref (fun (lbl : Types.label_description) ->
   Fld_record {name = lbl.lbl_name; mutable_flag = Mutable})
 
 let ref_field_info : field_dbg_info = 
   Fld_record { name = "contents"; mutable_flag = Mutable}
+let fld_na = Fld_na ""
 
 type set_field_dbg_info = 
     | Fld_set_na
@@ -250,11 +254,12 @@ and raise_kind =
   | Raise_notrace
 
 type pointer_info = 
-  | Pt_constructor of {name : string; cstrs : int * int }
+  | Pt_constructor of {name : string; const : int ; non_const : int }
   | Pt_variant of {name : string}
   | Pt_module_alias 
   | Pt_builtin_boolean  
   | Pt_shape_none   
+  | Pt_assertfalse
   | Pt_na 
 
 
@@ -364,9 +369,9 @@ type program =
     not necessary "()", it can be used as a place holder for module 
     alias etc.
 *)
-let const_unit = Const_pointer(0, Pt_na)
+let const_unit = Const_pointer(0, Pt_constructor{name = "()"; const = 1; non_const = 0})
 
-let lambda_assert_false = Lconst (Const_pointer(0, Pt_constructor {name = "assert false"; cstrs = (1,0)}))  
+let lambda_assert_false = Lconst (Const_pointer(0, Pt_assertfalse))  
 
 let lambda_module_alias = Lconst (Const_pointer(0, Pt_module_alias)) 
 
@@ -398,7 +403,7 @@ let make_key e =
   (* make_key is used for normalizing let-bound variables *)
   let rec tr_rec env e =
     incr count ;
-    if !count > max_raw then raise Not_simple ; (* Too big ! *)
+    if !count > max_raw then raise_notrace Not_simple ; (* Too big ! *)
     match e with
     | Lvar id ->
       begin
@@ -407,7 +412,7 @@ let make_key e =
       end
     | Lconst  (Const_base (Const_string _)) ->
         (* Mutable constants are not shared *)
-        raise Not_simple
+        raise_notrace Not_simple
     | Lconst _ -> e
     | Lapply ap ->
         Lapply {ap with ap_func = tr_rec env ap.ap_func;
@@ -453,7 +458,7 @@ let make_key e =
 (* Beware: (PR#6412) the event argument to Levent
    may include cyclic structure of type Type.typexpr *)
     | Levent _  ->
-        raise Not_simple
+        raise_notrace Not_simple
 
   and tr_recs env es = List.map (tr_rec env) es
 

bytecomp/lambda.mli

@@ -35,7 +35,7 @@ type loc_kind =
   | Loc_POS
 
 type tag_info = 
-  | Blk_constructor of string * int (* Number of non-const constructors*)
+  | Blk_constructor of {name : string ; num_nonconst : int}
   | Blk_tuple
   | Blk_array
   | Blk_poly_var of string 
@@ -57,10 +57,9 @@ type tag_info =
   | Blk_na of string (* This string only for debugging*)
   | Blk_some
   | Blk_some_not_nested (* ['a option] where ['a] can not inhabit a non-like value *)
-  | Blk_record_inlined of string array * string  * int   
+  | Blk_record_inlined of { name : string ; num_nonconst :  int ; fields : string array}   
   | Blk_record_ext of string array
-  | Blk_lazy_general  
-  | Blk_lazy_forward
+  | Blk_lazy_general    
   | Blk_class (* ocaml style class *)
 
 val blk_record : 
@@ -88,21 +87,27 @@ val default_tag_info : tag_info
 val ref_tag_info : tag_info
 
 type field_dbg_info = 
-  | Fld_na
+  | Fld_na of string
   | Fld_record of {name : string; mutable_flag : Asttypes.mutable_flag}
   | Fld_module of {name : string}     
   | Fld_record_inline of {name : string}
   | Fld_record_extension of {name : string}
   | Fld_tuple
   | Fld_poly_var_tag
   | Fld_poly_var_content
-  | Fld_extension_slot  
+  | Fld_extension
+  | Fld_variant
+  | Fld_cons
+  | Fld_array
+
 val fld_record :
   (Types.label_description -> 
   field_dbg_info) ref
 
 val ref_field_info : field_dbg_info   
 
+val fld_na : field_dbg_info
+
 type set_field_dbg_info = 
   | Fld_set_na
   | Fld_record_set of string 
@@ -134,11 +139,12 @@ type is_safe =
   | Unsafe
 
 type pointer_info = 
-  | Pt_constructor of {name : string; cstrs : int * int} 
+  | Pt_constructor of {name : string; const : int ; non_const :  int} 
   | Pt_variant of {name : string}
   | Pt_module_alias 
   | Pt_builtin_boolean
   | Pt_shape_none   
+  | Pt_assertfalse
   | Pt_na