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

SCM Repository

[smlnj] Annotation of /sml/branches/idlbasis-devel/src/MLRISC/Tools/MDL/mdl-type-utils.sml
ViewVC logotype

Annotation of /sml/branches/idlbasis-devel/src/MLRISC/Tools/MDL/mdl-type-utils.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 848 - (view) (download)

1 : leunga 744 (*
2 :     * Utilities for manipulating types
3 :     *)
4 :     functor MDLTypeUtils(AstPP : MDL_AST_PRETTY_PRINTER) : MDL_TYPE_UTILS =
5 :     struct
6 :    
7 :     structure Error = MDLError
8 :     structure AstPP = AstPP
9 :     structure Ast = AstPP.Ast
10 :    
11 :     open Ast
12 :    
13 :     type level = int
14 :    
15 :     val counter = ref 0
16 :     fun genVar k level = (counter := !counter + 1;
17 :     VARty(k,!counter,ref level,ref NONE))
18 :     val newIVar = genVar INTkind
19 :     val newVar = genVar TYPEkind
20 :    
21 :     exception OccursCheck
22 :     exception Unify
23 :    
24 :     fun init() = counter := 0
25 :    
26 :     fun bug msg = MLRiscErrorMsg.error("MDTyping",msg)
27 :    
28 :     fun pr ty = PP.text(AstPP.ty ty)
29 :    
30 :     fun deref(VARty(_,_,_,ref(SOME t))) = deref t
31 :     | deref t = t
32 :    
33 :     fun tupleTy [t] = t
34 :     | tupleTy ts = TUPLEty ts
35 :    
36 :     fun copy(VARty(_,_,_,ref(SOME t))) = copy t
37 :     | copy(t as VARty _) = t
38 :     | copy(t as TYVARty _) = t
39 :     | copy(t as CELLty _) = t
40 :     | copy(t as IDty _) = t
41 :     | copy(t as INTVARty _) = t
42 :     | copy(POLYty _) = bug "copy:poly"
43 :     | copy(TUPLEty ts) = TUPLEty(map copy ts)
44 :     | copy(RECORDty ts) = RECORDty(map (fn (l,t) => (l,copy t)) ts)
45 :     | copy(FUNty(a,b)) = FUNty(copy a,copy b)
46 :     | copy(APPty(f,tys)) = APPty(f,map copy tys)
47 :     | copy(LAMBDAty _) = bug "copy:lambda"
48 :    
49 :     val iboundvars = List.filter (fn VARty(INTkind,_,_,_) => true | _ => false)
50 :    
51 :     fun inst lvl (e, POLYty(tvs,ty)) =
52 :     let val tvs' = map (fn VARty(k,_,_,x) =>
53 :     let val v = genVar k lvl
54 :     in x := SOME v; v end) tvs
55 :     val ty = copy ty
56 :     val _ = app (fn VARty(_,_,_,x) => x := NONE) tvs
57 :     val ivars = iboundvars tvs'
58 :     in case ivars of
59 :     [] => (e, ty)
60 :     | _ => (APPexp(e, TUPLEexp(map TYPEexp ivars)), ty)
61 :     end
62 :     | inst lvl (e, t) = (e, t)
63 :    
64 :     fun gen lvl (e, ty) =
65 :     let val mark = !counter
66 :     val bvs = ref []
67 :     val trail = ref []
68 :     fun f(VARty(_,_,_,ref(SOME t))) = f t
69 :     | f(t as VARty(k,i,ref l,r)) =
70 :     if i > mark orelse l < lvl then t
71 :     else let val v = genVar k 0
72 :     in r := SOME v;
73 :     bvs := (v,t) :: !bvs; trail := r :: !trail; v
74 :     end
75 :     | f(t as TYVARty _) = t
76 :     | f(t as CELLty _) = t
77 :     | f(t as IDty _) = t
78 :     | f(t as INTVARty _) = t
79 :     | f(FUNty(a,b)) = FUNty(f a,f b)
80 :     | f(TUPLEty ts) = TUPLEty(map f ts)
81 :     | f(RECORDty lts) = RECORDty(map (fn (l,t) => (l,f t)) lts)
82 :     | f(APPty(a,ts)) = APPty(a,map f ts)
83 :     | f(POLYty _) = bug "gen:poly"
84 :     | f(LAMBDAty _) = bug "gen:lambda"
85 :     val t = f ty
86 :     fun arityRaise(bvs, e) =
87 :     case iboundvars bvs of
88 :     [] => e
89 :     | bvs => let val xs =
90 :     map (fn VARty(_,n,_,_) => "T"^Int.toString n) bvs
91 :     val args = map IDpat xs
92 :     in case e of
93 :     LAMBDAexp cs =>
94 :     LAMBDAexp(map (fn CLAUSE(cs,g,e) =>
95 :     CLAUSE(TUPLEpat args::cs,g,e)) cs)
96 :     | _ => LAMBDAexp[CLAUSE([TUPLEpat args], NONE, e)]
97 :     end
98 :     in app (fn r => r := NONE) (!trail);
99 :     case !bvs of
100 :     [] => (e, ty)
101 :     | bvs => let val bvs = rev bvs (* boundvars are listed in reverse *)
102 :     in (arityRaise(map #2 bvs, e), POLYty(map #1 bvs,t)) end
103 :     end
104 :    
105 :     fun lambda level ty =
106 :     case gen level (LITexp(INTlit 0), ty) of
107 :     (_, POLYty(bvs,t)) => LAMBDAty(bvs,t)
108 :     | (_, t) => t
109 :    
110 :     fun unify(msg,x,y) =
111 :     let fun errorOccursCheck(t1,t2) =
112 :     Error.error("occurs check failed in unifying "^pr t1^" and "
113 :     ^pr t2^msg())
114 :     fun errorUnify(t1,t2) =
115 :     Error.error("can't unify "^pr t1^" and "^pr t2^msg())
116 :    
117 :     fun f(VARty(_,_,_,ref(SOME x)),y) = f(x,y)
118 :     | f(x,VARty(_,_,_,ref(SOME y))) = f(x,y)
119 :     | f(x as VARty(k1,_,m,u),y as VARty(k2,_,n,v)) =
120 :     if u = v then ()
121 :     else if k1 = INTkind then
122 :     (v := SOME x; m := Int.max(!m,!n))
123 :     else
124 :     (u := SOME y; n := Int.max(!m,!n))
125 :     | f(VARty x,e) = upd x e
126 :     | f(e,VARty x) = upd x e
127 :     | f(IDty x,IDty y) = if x = y then () else raise Unify
128 :     | f(TYVARty x,TYVARty y) = if x = y then () else raise Unify
129 :     | f(TUPLEty x,TUPLEty y) = g(x,y)
130 :     | f(TUPLEty[x],y) = f(x,y)
131 :     | f(x,TUPLEty[y]) = f(x,y)
132 :     | f(RECORDty x,RECORDty y) = h(x,y)
133 :     | f(CELLty x,CELLty y) = if x = y then () else raise Unify
134 :     | f(FUNty(a,b),FUNty(c,d)) = (f(a,c); f(b,d))
135 :     | f(APPty(a,b),APPty(c,d)) = if a = c then g(b,d) else raise Unify
136 :     | f(INTVARty i,INTVARty j) = if i = j then () else raise Unify
137 :     | f _ = raise Unify
138 :    
139 :     and g([],[]) = ()
140 :     | g(a::b,c::d) = (f(a,c); g(b,d))
141 :     | g _ = raise Unify
142 :    
143 :     and h(ltys1,ltys2) =
144 :     let val sort = ListMergeSort.sort (fn ((a,_),(b,_)) => a > b)
145 :     val ltys1 = sort ltys1
146 :     val ltys2 = sort ltys2
147 :     fun merge((x,t)::m,(y,u)::n) =
148 :     if x = y then (f(t,u); merge(m,n))
149 :     else raise Unify
150 :     | merge([],[]) = ()
151 :     | merge _ = raise Unify
152 :     in merge(ltys1,ltys2) end
153 :    
154 :     and upd (t1 as (k,name,lvl,v)) t2 =
155 :     let fun g(VARty(_,_,_,ref(SOME t))) = g t
156 :     | g(VARty(k',n,l,y)) =
157 :     if y = v then raise OccursCheck
158 :     else (l := Int.max(!lvl,!l))
159 :     | g(TUPLEty ts) = app g ts
160 :     | g(RECORDty lts) = app (fn (_,t) => g t) lts
161 :     | g(CELLty _) = ()
162 :     | g(TYVARty t) = ()
163 :     | g(FUNty(a,b)) = (g a; g b)
164 :     | g(IDty _) = ()
165 :     | g(INTVARty _) = ()
166 :     | g(APPty(_,b)) = app g b
167 :     | g(POLYty _) = bug "unify:poly"
168 :     | g(LAMBDAty _) = bug "unify:lambda"
169 :     in g t2 handle Unify => errorUnify(VARty t1,t2)
170 :     | OccursCheck => errorOccursCheck(VARty t1,t2);
171 :     v := SOME t2
172 :     end
173 :    
174 :     in f(x,y) handle Unify => errorUnify(x,y)
175 :     end
176 :    
177 :     fun apply (msg,VARty(_,_,_,ref(SOME t)),args) = apply (msg,t,args)
178 :     | apply (msg,f as LAMBDAty(tvs,body),args) =
179 :     let val arity1 = length tvs
180 :     val arity2 = length args
181 :     in if arity1 <> arity2 then
182 :     Error.error(
183 :     "arity mismatch between "^pr f^" and "^pr(TUPLEty args)^msg)
184 :     else ();
185 :     ListPair.app (fn (x,y) =>
186 :     case (deref x,deref y) of
187 :     (VARty(TYPEkind,_,_,x),y) => x := SOME y
188 :     | (x,VARty(TYPEkind,_,_,y)) => y := SOME x
189 :     | (VARty(INTkind,_,_,x),y as INTVARty _) => x := SOME y
190 :     | (VARty(INTkind,_,_,x),y as VARty(INTkind,_,_,_)) => x := SOME y
191 :     | (VARty(INTkind,_,_,x),y) =>
192 :     Error.error(
193 :     "kind mismatch in application between "^pr f^
194 :     " and "^pr(TUPLEty args)^msg)
195 :     ) (tvs,args);
196 :     copy body before app (fn VARty(_,_,_,x) => x := NONE) tvs
197 :     end
198 :     | apply (msg,t,args) =
199 :     (Error.error("type "^pr t^" is not a type constructor"^msg); newVar 0)
200 :    
201 :     fun poly([],t) = t
202 :     | poly(tvs,t) = POLYty(tvs,t)
203 :    
204 :     fun newType(DATATYPEbind{id,tyvars,...}) =
205 :     let val ty = IDty(IDENT([],id))
206 :     in case tyvars of
207 :     [] => ([],ty)
208 :     | tyvars => let val vs = map (fn _ => newVar 0) tyvars
209 :     in (vs,ty) end
210 :     end
211 :     end
212 :    
213 :    

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