Commits

camlspotter committed e7b464a

cleanup

Comments (0)

Files changed (3)

 typing/ctype.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi \
     typing/env.cmi parsing/asttypes.cmi
 typing/datarepr.cmi: typing/types.cmi typing/path.cmi parsing/asttypes.cmi
+typing/dispatch.cmi: typing/types.cmi typing/typedtree.cmi \
+    parsing/parsetree.cmi parsing/location.cmi typing/ident.cmi \
+    typing/env.cmi parsing/asttypes.cmi
 typing/env.cmi: typing/types.cmi typing/path.cmi parsing/longident.cmi \
     typing/ident.cmi utils/consistbl.cmi typing/annot.cmi
 typing/ident.cmi:
     parsing/asttypes.cmi typing/datarepr.cmi
 typing/datarepr.cmx: typing/types.cmx typing/predef.cmx utils/misc.cmx \
     parsing/asttypes.cmi typing/datarepr.cmi
+typing/dispatch.cmo: typing/types.cmi typing/typedtree.cmi \
+    typing/printtyp.cmi typing/path.cmi parsing/parsetree.cmi \
+    typing/mtype.cmi utils/misc.cmi parsing/longident.cmi \
+    parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
+    typing/btype.cmi parsing/asttypes.cmi typing/dispatch.cmi
+typing/dispatch.cmx: typing/types.cmx typing/typedtree.cmx \
+    typing/printtyp.cmx typing/path.cmx parsing/parsetree.cmi \
+    typing/mtype.cmx utils/misc.cmx parsing/longident.cmx \
+    parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
+    typing/btype.cmx parsing/asttypes.cmi typing/dispatch.cmi
 typing/env.cmo: typing/types.cmi utils/tbl.cmi typing/subst.cmi \
     typing/predef.cmi typing/path.cmi utils/misc.cmi parsing/longident.cmi \
     typing/ident.cmi typing/datarepr.cmi utils/consistbl.cmi utils/config.cmi \
     typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \
     typing/path.cmi parsing/parsetree.cmi typing/parmatch.cmi utils/misc.cmi \
     parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
-    typing/env.cmi typing/ctype.cmi utils/clflags.cmi typing/btype.cmi \
-    parsing/asttypes.cmi typing/annot.cmi typing/typecore.cmi
+    typing/env.cmi typing/dispatch.cmi typing/ctype.cmi utils/clflags.cmi \
+    typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi \
+    typing/typecore.cmi
 typing/typecore.cmx: utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \
     typing/typedtree.cmx typing/subst.cmx typing/stypes.cmx \
     typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \
     typing/path.cmx parsing/parsetree.cmi typing/parmatch.cmx utils/misc.cmx \
     parsing/longident.cmx parsing/location.cmx typing/ident.cmx \
-    typing/env.cmx typing/ctype.cmx utils/clflags.cmx typing/btype.cmx \
-    parsing/asttypes.cmi typing/annot.cmi typing/typecore.cmi
+    typing/env.cmx typing/dispatch.cmx typing/ctype.cmx utils/clflags.cmx \
+    typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi \
+    typing/typecore.cmi
 typing/typedecl.cmo: typing/typetexp.cmi typing/types.cmi \
     typing/typedtree.cmi typing/subst.cmi typing/printtyp.cmi \
     typing/primitive.cmi typing/predef.cmi typing/path.cmi \
 asmcomp/selection.cmi: asmcomp/mach.cmi asmcomp/cmm.cmi
 asmcomp/spill.cmi: asmcomp/mach.cmi
 asmcomp/split.cmi: asmcomp/mach.cmi
-asmcomp/arch.cmo: utils/misc.cmi utils/config.cmi
-asmcomp/arch.cmx: utils/misc.cmx utils/config.cmx
+asmcomp/arch.cmo:
+asmcomp/arch.cmx:
 asmcomp/asmgen.cmo: bytecomp/translmod.cmi asmcomp/split.cmi \
     asmcomp/spill.cmi asmcomp/selection.cmi asmcomp/scheduling.cmi \
     asmcomp/reload.cmi asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printmach.cmi \
 asmcomp/debuginfo.cmx: parsing/location.cmx bytecomp/lambda.cmx \
     asmcomp/debuginfo.cmi
 asmcomp/emit.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
-    asmcomp/mach.cmi parsing/location.cmi asmcomp/linearize.cmi \
-    asmcomp/emitaux.cmi asmcomp/debuginfo.cmi utils/config.cmi \
-    asmcomp/compilenv.cmi asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo \
-    asmcomp/emit.cmi
+    asmcomp/mach.cmi asmcomp/linearize.cmi asmcomp/emitaux.cmi \
+    asmcomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \
+    asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emit.cmi
 asmcomp/emit.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
-    asmcomp/mach.cmx parsing/location.cmx asmcomp/linearize.cmx \
-    asmcomp/emitaux.cmx asmcomp/debuginfo.cmx utils/config.cmx \
-    asmcomp/compilenv.cmx asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx \
-    asmcomp/emit.cmi
+    asmcomp/mach.cmx asmcomp/linearize.cmx asmcomp/emitaux.cmx \
+    asmcomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \
+    asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emit.cmi
 asmcomp/emitaux.cmo: asmcomp/reg.cmi asmcomp/linearize.cmi \
     asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
     asmcomp/emitaux.cmi
     asmcomp/mach.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
     asmcomp/printmach.cmi
 asmcomp/proc.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
-    utils/config.cmi asmcomp/cmm.cmi utils/clflags.cmi utils/ccomp.cmi \
-    asmcomp/arch.cmo asmcomp/proc.cmi
+    utils/config.cmi asmcomp/cmm.cmi utils/ccomp.cmi asmcomp/arch.cmo \
+    asmcomp/proc.cmi
 asmcomp/proc.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
-    utils/config.cmx asmcomp/cmm.cmx utils/clflags.cmx utils/ccomp.cmx \
-    asmcomp/arch.cmx asmcomp/proc.cmi
+    utils/config.cmx asmcomp/cmm.cmx utils/ccomp.cmx asmcomp/arch.cmx \
+    asmcomp/proc.cmi
 asmcomp/reg.cmo: asmcomp/cmm.cmi asmcomp/reg.cmi
 asmcomp/reg.cmx: asmcomp/cmm.cmx asmcomp/reg.cmi
 asmcomp/reload.cmo: asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
-    asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/reload.cmi
+    asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/reload.cmi
 asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \
-    asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/reload.cmi
+    asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/reload.cmi
 asmcomp/reloadgen.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
     asmcomp/reloadgen.cmi
 asmcomp/reloadgen.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
     asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/selectgen.cmi
 asmcomp/selection.cmo: asmcomp/selectgen.cmi asmcomp/reg.cmi asmcomp/proc.cmi \
     utils/misc.cmi asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \
-    asmcomp/arch.cmo asmcomp/selection.cmi
+    utils/clflags.cmi asmcomp/arch.cmo asmcomp/selection.cmi
 asmcomp/selection.cmx: asmcomp/selectgen.cmx asmcomp/reg.cmx asmcomp/proc.cmx \
     utils/misc.cmx asmcomp/mach.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \
-    asmcomp/arch.cmx asmcomp/selection.cmi
+    utils/clflags.cmx asmcomp/arch.cmx asmcomp/selection.cmi
 asmcomp/spill.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
     asmcomp/mach.cmi asmcomp/spill.cmi
 asmcomp/spill.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \

typing/dispatch.ml

   try ignore (Sys.getenv "DCAML_DISPATCH_DEBUG"); true 
   with _ -> false
 
-let x = Format.eprintf "%s%a"
-
 let debugf (fmt : (_, Format.formatter, unit) format) =
   if debug then Format.eprintf fmt 
   else Format.ifprintf Format.err_formatter fmt
       List.fold_right (fun (l,t) st ->
         newty (Tarrow (l, t, st, Cok))) implicit_dabsts typ 
     in
+prerr_endline "unifier";
     unifier typ;
+prerr_endline "unifier done";
     implicit_dabsts, if implicit_dabsts = [] then None else Some typ
 
   let unify_type_with_dispatch env dty typ =
     unify_with_dispatch env dty typ (unify env dty)
       
+(*
   let unify_subtype_with_dispatch env dty typ =
     unify_with_dispatch env dty typ (fun ty -> subtype env ty dty ())
+*)
       
   let unify_exp_with_dispatch env exp typ =
-    unify_with_dispatch env exp.exp_type typ (unify_exp env exp)
+    let typ = repr typ in
+    match typ.desc with
+    | Tpoly (ty, tl) -> 
+        prerr_endline "Tpoly inst";
+        begin_def ();
+        let typ = snd (instance_poly false tl ty) in
+        prerr_endline "Tpoly unify done";
+        end_def ();
+        let unify = unify_exp env exp in
+Format.eprintf "Tpoly unify %a  %a@."
+  Printtyp.type_scheme exp.exp_type 
+  Printtyp.type_scheme typ;
+        let res = unify_with_dispatch env exp.exp_type typ unify in
+        prerr_endline "Tpoly unify_with_dispatch done";
+        res
+    | _ -> 
+        unify_with_dispatch env exp.exp_type typ (unify_exp env exp)
 
   module Recursives : sig
 

typing/typecore.ml

           {pat with pat_type = instance pat.pat_type})
         pat_list
     end else pat_list in
+
   (* Polymoprhic variant processing *)
   List.iter
     (fun pat ->
   let exp_env =
     match rec_flag with Nonrecursive | Default -> env | Recursive -> new_env in
 
-  let spat_exp_dispatch_list =
+  let pat0_list = pat_list in (* we need this for fix_calls *)
+
+  let pat_exp_abstracts_list =
     let defined_idents = 
       List.map fst
         (List.flatten (List.map pat_bound_idents_and_types pat_list))
     in
      List.map2
       (fun (spat, sexp) pat ->
-        spat,
-        (* reset dispatch info and enter the definition of pat *)
-        Dispatch.Let.enter (Some pat) defined_idents (fun () ->
-          match pat.pat_type.desc with
-          | Tpoly (ty, tl) ->
-              begin_def ();
-              let vars, ty' = instance_poly true tl ty in
-              let exp = type_expect exp_env sexp ty' in
-              end_def ();
-              check_univars env true "definition" exp pat.pat_type vars;
-              {exp with exp_type = instance exp.exp_type}
-          | _ ->
-              let d_abstable = Dispatch.pattern_may_have_implicit_dabst spat in
-              if d_abstable then 
-	        (* We here temporarily apply dispatch args 
-	           for the all $-absts. *)
-	        (* CR: We must perform the same thing like type_expect later *)
-	        type_exp exp_env sexp
-              else 
-	        (* We cannot have implicit $-absts, therefore we can use
-	           type_expect. *)
-                type_expect exp_env sexp pat.pat_type) )
-	  spat_sexp_list pat_list
-  in
-
-  let pat0_list = pat_list in (* we need this for fix_calls *)
-  
-  (* CR jfuruse : abstracts_list is no longer used *)
-  let exp_list, pat_list, abstracts_list =
-    List.fold_right2 (fun 
-      (spat, (exp, dispatches)) pat 
-      (exp_list, pat_list, abstracts_list) ->
+        let exp, dispatches = 
+          (* reset dispatch info and enter the definition of pat *)
+          Dispatch.Let.enter (Some pat) defined_idents (fun () ->
+            match pat.pat_type.desc with
+            | Tpoly (ty, tl) ->
+                begin_def ();
+                let vars, ty' = instance_poly true tl ty in
+                let exp = type_expect exp_env sexp ty' in
+                end_def ();
+                check_univars env true "definition" exp pat.pat_type vars;
+                {exp with exp_type = instance exp.exp_type}
+            | _ ->
+                let d_abstable = Dispatch.pattern_may_have_implicit_dabst spat in
+                if d_abstable then 
+	          (* We here temporarily apply dispatch args 
+	             for the all $-absts. *)
+	          (* CR: We must perform the same thing like type_expect later *)
+	          type_exp exp_env sexp
+                else
+	          (* We cannot have implicit $-absts, therefore we can use
+	             type_expect. *)
+                  type_expect exp_env sexp pat.pat_type)
+        in
         let pattern_may_have_implicit_dabst =
           Dispatch.pattern_may_have_implicit_dabst spat
         in
         let pat =
           if pattern_may_have_implicit_dabst then begin
 	    match
+prerr_endline "Tpoly2.5";
+let res = 
               Dispatch.unify_exp_with_dispatch exp_env exp pat.pat_type
+in
+prerr_endline "Tpoly2.6";
+res
 	    with
 	    | [], None -> pat
             | _, None -> assert false
             pat
           end
         in
-        exp :: exp_list,
-        pat :: pat_list,
-        abstracts :: abstracts_list) spat_exp_dispatch_list pat_list ([],[],[]) 
+        pat, exp, abstracts
+       )
+       spat_sexp_list pat_list
+  in
+
+  let pat_list, exp_list, abstracts_list =
+    List.fold_right (fun (pat, exp, abstracts) (pats, exps, abstracts_list) ->
+      pat :: pats,
+      exp :: exps,
+      abstracts :: abstracts_list) pat_exp_abstracts_list ([],[],[])
   in
 
   (* We have added all the $-arrows to pats. Now fix rec calls and apply