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 2458, Fri Apr 27 22:48:38 2007 UTC revision 2459, Sat Apr 28 19:17:33 2007 UTC
# Line 132  Line 132 
132    
133  (* propagate depth and eq while checking for circularities in the  (* propagate depth and eq while checking for circularities in the
134   * type ty that is going to unify with tyvar var *)   * type ty that is going to unify with tyvar var *)
135    
136    (* ASSERT: VARty var <> ty *)
137  fun adjustType (var,depth,eq,ty) =  fun adjustType (var,depth,eq,ty) =
138      let val _ = debugPPType(">>adjustType: ",ty)      let val _ = debugPPType(">>adjustType: ",ty)
139          fun iter _ WILDCARDty = ()          fun iter _ WILDCARDty = ()
140            | iter eq (VARty(var' as ref(info))) =            | iter eq (VARty(var' as ref(info))) =
141                (case info                (case info
142                   of INSTANTIATED ty => iter eq ty                   of INSTANTIATED ty =>
143                          (debugmsg "adjustType INSTANTIATED";
144                           iter eq ty)
145                    | OPEN{kind=k,depth=d,eq=e} =>                    | OPEN{kind=k,depth=d,eq=e} =>
146                        (* check for circularity, propagage eq and depth *)                        (* check for circularity, propagage eq and depth *)
147                        if TU.eqTyvar(var,var')                        if TU.eqTyvar(var,var')
# Line 169  Line 173 
173                        then raise Unify EQ                        then raise Unify EQ
174                        else ()                        else ()
175                    | LBOUND _ => bug "unify:adjustType:LBOUND")                    | LBOUND _ => bug "unify:adjustType:LBOUND")
176            | iter eq (ty as CONty(DEFtyc _, args)) =            | iter eq (ty as CONty(DEFtyc{tyfun=TYFUN{body,...},...}, args)) =
177                iter eq (TU.headReduceType ty)                (app (iter eq) args; iter eq (TU.headReduceType ty))
178                  (* A headReduceType here may cause instTyvar to
179                   * infinite loop if this CONty has a nonstrict arg
180                   * against which we are unifying/instantiating
181                   * [GK 4/28/07] *)
182            | iter eq (CONty(tycon,args)) =            | iter eq (CONty(tycon,args)) =
183                (case tyconEqprop tycon                (case tyconEqprop tycon
184                   of OBJ => app (iter false) args                   of OBJ => app (iter false) args
# Line 183  Line 191 
191            | iter _ (POLYty _) = bug "adjustType 1"            | iter _ (POLYty _) = bug "adjustType 1"
192            | iter _ (IBOUND _) = bug "adjustType 2"            | iter _ (IBOUND _) = bug "adjustType 2"
193            | iter _ _ = bug "adjustType 3"            | iter _ _ = bug "adjustType 3"
194       in iter eq ty       in iter eq ty; debugmsg "<<adjustType"
195      end      end
196    
197  (*************** unify functions *****************************************)  (*************** unify functions *****************************************)
# Line 209  Line 217 
217         | (_, OPEN{kind=FLEX _,...})=> (v2,v1)         | (_, OPEN{kind=FLEX _,...})=> (v2,v1)
218         | _ => (v1,v2) (* both OPEN/META *)         | _ => (v1,v2) (* both OPEN/META *)
219    
220    (* unifyTy expects that there are no POLYtys with 0-arity
221       CONty(DEFtyc, _) are reduced only if absolutely necessary. *)
222  fun unifyTy(type1,type2) =  fun unifyTy(type1,type2) =
223      let val type1 = TU.prune type1      let val type1 = TU.prune type1
224          val type2 = TU.prune type2          val type2 = TU.prune type2
225          val _ = debugPPType(">>unifyTy: type1: ",type1)          val _ = debugPPType(">>unifyTy: type1: ",type1)
226          val _ = debugPPType(">>unifyTy: type2: ",type2)          val _ = debugPPType(">>unifyTy: type2: ",type2)
227       in case (TU.headReduceType type1, TU.headReduceType type2)          fun unifyRaw(type1, type2) = (* unify without reducing CONty(DEFtycs) *)
228                case (type1, type2)
229            of (VARty var1,VARty var2) =>            of (VARty var1,VARty var2) =>
230                 unifyTyvars(var1,var2)  (* used to take type1 and type2 as args *)                 unifyTyvars(var1,var2)  (* used to take type1 and type2 as args *)
231             | (VARty var1,etype2) => (* etype2 may be WILDCARDty *)             | (VARty var1,etype2) => (* etype2 may be WILDCARDty *)
# Line 223  Line 234 
234                 instTyvar(var2,type1,etype1)                 instTyvar(var2,type1,etype1)
235             | (CONty(tycon1,args1),CONty(tycon2,args2)) =>             | (CONty(tycon1,args1),CONty(tycon2,args2)) =>
236                 if TU.eqTycon(tycon1,tycon2) then                 if TU.eqTycon(tycon1,tycon2) then
237                     ListPair.app unifyTy (args1,args2)                     (* Because tycons are equal, they must have the
238                          same arity. Assume that lengths of args1 and
239                          args2 are the same. Type abbrev. strictness
240                          optimization. If tycons equal, then only check
241                          strict arguments. [GK 4/28/07] *)
242                       (case tycon1
243                         of DEFtyc{strict, ...} =>
244                            let fun unifyArgs([],[],[]) = ()
245                                  | unifyArgs(true::ss, ty1::tys1, ty2::tys2) =
246                                    (unifyTy(ty1,ty2); unifyArgs(ss,tys1,tys2))
247                                  | unifyArgs(false::ss, _::tys1, _::tys2) =
248                                    unifyArgs(ss,tys1,tys2)
249                            in unifyArgs(strict,args1,args2)
250                            end
251                          | _ => ListPair.app unifyTy (args1,args2))
252                 else raise Unify (TYC(tycon1,tycon2))                 else raise Unify (TYC(tycon1,tycon2))
253            (* if one of the types is WILDCARDty, propagate it down into the            (* if one of the types is WILDCARDty, propagate it down into the
254             * other type to eliminate tyvars that might otherwise cause             * other type to eliminate tyvars that might otherwise cause
# Line 235  Line 260 
260             | (WILDCARDty,_) => ()             | (WILDCARDty,_) => ()
261             | (_,WILDCARDty) => ()             | (_,WILDCARDty) => ()
262             | tys => raise Unify (TYP tys)             | tys => raise Unify (TYP tys)
263        in unifyRaw(type1, type2)
264           handle Unify _ => (* try reducing CONty(DEFtyc, _) to make types equal *)
265                  let val type1' = TU.headReduceType type1
266                  in unifyRaw(type1', type2)
267                     handle Unify _ => (* try reducing type2 *)
268                            unifyRaw(type1', TU.headReduceType type2)
269                            (* if unification still fails, then type1 and type2
270                               really cannot be made to be equal *)
271                  end
272      end      end
273    
274  and unifyTyvars (var1, var2) =  and unifyTyvars (var1, var2) =
# Line 317  Line 351 
351        (case ety        (case ety
352           of WILDCARDty => ()           of WILDCARDty => ()
353            | _ => adjustType(var,depth,eq,ety);            | _ => adjustType(var,depth,eq,ety);
354           debugPPType("instTyvar ", VARty var);
355           debugPPType("instTyvar to ", ty);
356           (* Also need to check for circularity with ty here *)
357         var := INSTANTIATED ty)         var := INSTANTIATED ty)
358    
359    | instTyvar (var as ref(OPEN{kind=FLEX fields,depth,eq}),ty,ety) =    | instTyvar (var as ref(OPEN{kind=FLEX fields,depth,eq}),ty,ety) =

Legend:
Removed from v.2458  
changed lines
  Added in v.2459

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