Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/branches/primop-branch-3/compiler/Elaborator/types/unify.sml
ViewVC logotype

Diff of /sml/branches/primop-branch-3/compiler/Elaborator/types/unify.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 2528, Wed May 9 20:36:39 2007 UTC revision 2529, Wed May 9 23:22:59 2007 UTC
# Line 184  Line 184 
184                 * against which we are unifying/instantiating                 * against which we are unifying/instantiating
185                 * Because we may be instantiating to nonstrict                 * Because we may be instantiating to nonstrict
186                 * univariables, it is safer to do an occurrence                 * univariables, it is safer to do an occurrence
187                 * check on all the arguments.                 * check on all the arguments. (typing/tests/20.sml)
188                 * [GK 4/28/07] *)                 * [GK 4/28/07] *)
189            | iter eq (CONty(tycon,args)) =            | iter eq (CONty(tycon,args)) =
190                (case tyconEqprop tycon                (case tyconEqprop tycon
# Line 231  Line 231 
231          val type2 = TU.prune type2          val type2 = TU.prune type2
232          val _ = debugPPType(">>unifyTy: type1: ",type1)          val _ = debugPPType(">>unifyTy: type1: ",type1)
233          val _ = debugPPType(">>unifyTy: type2: ",type2)          val _ = debugPPType(">>unifyTy: type2: ",type2)
234          fun unifyRaw(type1, type2) = (* unify without reducing CONty(DEFtycs) *)          fun unifyRaw(type1, type2) =
235              case (type1, type2)              case (type1, type2)
236            of (VARty var1,VARty var2) =>            of (VARty var1,VARty var2) =>
237                 unifyTyvars(var1,var2)  (* used to take type1 and type2 as args *)                 unifyTyvars(var1,var2)  (* used to take type1 and type2 as args *)
238             | (VARty var1,etype2) => (* etype2 may be WILDCARDty *)             | (VARty var1, _) => (* type2 may be WILDCARDty *)
239                 instTyvar(var1,type2,etype2)                 instTyvar(var1,type2)
240             | (etype1,VARty var2) => (* etype1 may be WILDCARDty *)             | (_, VARty var2) => (* type1 may be WILDCARDty *)
241                 instTyvar(var2,type1,etype1)                 instTyvar(var2,type1)
242             | (CONty(tycon1,args1),CONty(tycon2,args2)) =>             | (CONty(tycon1,args1),CONty(tycon2,args2)) =>
243                 if TU.eqTycon(tycon1,tycon2) then                 if TU.eqTycon(tycon1,tycon2) then
244                     (* Because tycons are equal, they must have the                     (* Because tycons are equal, they must have the
# Line 269  Line 269 
269             | (WILDCARDty,_) => ()             | (WILDCARDty,_) => ()
270             | (_,WILDCARDty) => ()             | (_,WILDCARDty) => ()
271             | tys => raise Unify (TYP tys)             | tys => raise Unify (TYP tys)
272      in unifyRaw(type1, type2)      in (* first try unifying without reducing CONty(DEFtycs) *)
273         handle Unify _ => (* try reducing CONty(DEFtyc, _) to make types equal *)         unifyRaw(type1, type2)
274           handle Unify _ =>
275             (* try head reducing type1 *)
276                let val type1' = TU.headReduceType type1                let val type1' = TU.headReduceType type1
277                in unifyRaw(type1', type2)                in unifyRaw(type1', type2)
278                   handle Unify _ => (* try reducing type2 *)              handle Unify _ => (* try head reducing type2 *)
279                          unifyRaw(type1', TU.headReduceType type2)                          unifyRaw(type1', TU.headReduceType type2)
280                          (* if unification still fails, then type1 and type2                          (* if unification still fails, then type1 and type2
281                             really cannot be made to be equal *)                             really cannot be made to be equal *)
# Line 356  Line 358 
358          else unify(sortVars(var1,var2))          else unify(sortVars(var1,var2))
359      end      end
360    
361  and instTyvar (var as ref(OPEN{kind=META,depth,eq}),ty,ety) =  (* instTyvar: tyvar * ty -> unit
362        (case ety   * instTyvar(tv,ty) -- instantiate tyvar tv to type ty.
363     * ty is not necessarily head normal form.
364     * ASSERT: ty is not a VARty (otherwise unifyTyvars would have been
365     * used instead. *)
366    and instTyvar (var as ref(OPEN{kind=META,depth,eq}),ty) =
367          (case ty
368           of WILDCARDty => ()           of WILDCARDty => ()
369            | _ => adjustType(var,depth,eq,ety);            | _ => adjustType(var,depth,eq,ty);
370         debugPPType("instTyvar ", VARty var);         debugPPType("instTyvar ", VARty var);
371         debugPPType("instTyvar to ", ty);         debugPPType("instTyvar to ", ty);
372         (* Also need to check for circularity with ty here *)         (* Also need to check for circularity with ty here *)
373         var := INSTANTIATED ty)         var := INSTANTIATED ty)
374    
375    | instTyvar (var as ref(OPEN{kind=FLEX fields,depth,eq}),ty,ety) =    | instTyvar (var as ref(OPEN{kind=FLEX fields,depth,eq}),ty) =
376        (case ety        let val ty' = readReduceType ty (* try to reduce to a record type *)
377           in case ty'
378           of CONty(RECORDtyc field_names, field_types) =>           of CONty(RECORDtyc field_names, field_types) =>
379                let val record_fields = ListPair.zip (field_names,field_types)                let val record_fields = ListPair.zip (field_names,field_types)
380                 in app (fn t => adjustType(var,depth,eq,t)) field_types;                 in app (fn t => adjustType(var,depth,eq,t)) field_types;
# Line 375  Line 383 
383                end                end
384            | WILDCARDty => (* propagate WILDCARDty to the fields *)            | WILDCARDty => (* propagate WILDCARDty to the fields *)
385                (app (fn (lab,ty) => unifyTy(WILDCARDty,ty)) fields)                (app (fn (lab,ty) => unifyTy(WILDCARDty,ty)) fields)
386            | _ => raise Unify (TYP(VARty(var), ety)))              | _ => raise Unify (TYP(VARty(var), ty))
387          end
388    
389    | instTyvar (var as ref(i as SCHEME eq),ty,ety) =    | instTyvar (var as ref(i as SCHEME eq),ty) =
390        (adjustType(var,infinity,eq,ety);        let val ty' = readReduceType ty
391         var := INSTANTIATED ty)         in case ty'
392                of VARty var1 => unifyTyvars(var, var1)
393                 | _ => adjustType(var,infinity,eq,ty');
394              var := INSTANTIATED ty'
395          end
396    
397    | instTyvar (var as ref(i as LITERAL{kind,...}),ty,ety) =    | instTyvar (var as ref(i as LITERAL{kind,...}),ty) =
398        (case ety        (case headReduceType ty
399           of WILDCARDty => ()           of WILDCARDty => ()
400            | _ =>            | ty' =>
401               if OLL.isLiteralTy(kind,ety)               if OLL.isLiteralTy(kind,ty')
402               then var := INSTANTIATED ty               then var := INSTANTIATED ty
403               else raise Unify (LIT i))   (* could return the ty for error msg*)               else raise Unify (LIT i))   (* could return the ty for error msg*)
404    
405    | instTyvar (ref(i as UBOUND _),_,ety) =    | instTyvar (ref(i as UBOUND _),ty) =
406        (case ety        (case ty
407           of WILDCARDty => ()           of WILDCARDty => ()
408            | _ =>  raise Unify (UBV i))   (* could return the ty for error msg*)            | _ =>  raise Unify (UBV i))   (* could return the ty for error msg*)
409    

Legend:
Removed from v.2528  
changed lines
  Added in v.2529

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0