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/primop-branch-2/src/compiler/ElabData/types/typesutil.sml
ViewVC logotype

Annotation of /sml/branches/primop-branch-2/src/compiler/ElabData/types/typesutil.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1962 - (view) (download)

1 : blume 903 (* Copyright 1996 by Bell Laboratories *)
2 :     (* typesutil.sml *)
3 :    
4 :     structure TypesUtil : TYPESUTIL = struct
5 :    
6 :     local
7 :     structure EM = ErrorMsg
8 :     structure SS = Substring
9 :     structure EP = EntPath
10 :     structure BT = CoreBasicTypes
11 :     structure SP = SymPath
12 :     structure IP = InvPath
13 :     structure S = Symbol
14 :     structure ST = Stamps
15 :     structure A = Access
16 :     open Types VarCon
17 :     in
18 :    
19 :     val array = Array.array
20 :     val sub = Array.sub
21 :     val update = Array.update
22 :     infix 9 sub
23 :    
24 :     val --> = CoreBasicTypes.-->
25 :     infix -->
26 :    
27 :     val say = Control_Print.say
28 :     val debugging = ref false
29 :     fun bug msg = EM.impossible("TypesUtil: "^msg)
30 :    
31 :     fun eqpropToString p =
32 :     case p
33 :     of NO => "NO"
34 :     | YES => "YES"
35 :     | IND => "IND"
36 :     | OBJ => "OBJ"
37 :     | DATA => "DATA"
38 :     | UNDEF => "UNDEF"
39 :     | ABS => "ABS"
40 :    
41 :    
42 :     (*************** operations to build tyvars, VARtys ***************)
43 :    
44 :     fun mkMETA depth =
45 :     OPEN{kind=META, depth=depth, eq=false}
46 :    
47 :     fun mkFLEX(fields, depth) =
48 :     OPEN{kind=FLEX fields, depth=depth, eq=false}
49 :    
50 :     fun extract_varname_info name =
51 : jhr 1861 let val name = SS.triml 1 (SS.full name) (* remove leading "'" *)
52 : blume 903 val (name, eq) =
53 :     if SS.sub(name,0) = #"'" (* initial "'" signifies equality *)
54 :     then (SS.triml 1 name,true)
55 :     else (name,false)
56 :     in (SS.string name, eq)
57 :     end
58 :    
59 :     fun mkUBOUND(id : Symbol.symbol) : tvKind =
60 :     let val (name, eq) = extract_varname_info (Symbol.name id)
61 :     in UBOUND{name=Symbol.tyvSymbol name, depth=infinity, eq=eq}
62 :     end
63 :    
64 :     fun mkLITERALty (k: litKind, r: SourceMap.region) : ty =
65 :     VARty(mkTyvar(LITERAL{kind=k,region=r}))
66 :    
67 :     fun mkSCHEMEty () : ty = VARty(mkTyvar(SCHEME false))
68 :    
69 :     (*
70 :     * mkMETAty:
71 :     *
72 :     * This function returns a type that represents a new meta variable
73 :     * which does NOT appear in the "context" anywhere. To do the same
74 :     * thing for a meta variable which will appear in the context (because,
75 :     * for example, we are going to assign the resulting type to a program
76 :     * variable), use mkMETAtyBounded with the appropriate depth.
77 :     *)
78 :    
79 : macqueen 1961 fun mkMETAtyBounded (depth: int) : ty = VARty(mkTyvar (mkMETA depth))
80 : blume 903
81 :     fun mkMETAty() = mkMETAtyBounded infinity
82 :    
83 :    
84 :    
85 :     (*************** primitive operations on tycons ***************)
86 :     fun bugTyc (s: string, tyc) =
87 :     case tyc
88 :     of GENtyc { path, ... } => bug (s ^ " GENtyc " ^ S.name (IP.last path))
89 :     | DEFtyc {path,...} => bug (s ^ " DEFtyc " ^ S.name(IP.last path))
90 :     | RECORDtyc _ => bug (s ^ " RECORDtyc")
91 :     | PATHtyc{path,...} => bug (s ^ " PATHtyc " ^ S.name(IP.last path))
92 :     | RECtyc _ => bug (s ^ " RECtyc")
93 :     | FREEtyc _ => bug (s ^ " FREEtyc")
94 :     | ERRORtyc => bug (s ^ " ERRORtyc")
95 :    
96 :     (* short (single symbol) name of tycon *)
97 :     fun tycName (GENtyc { path, ... } | DEFtyc{path,...} | PATHtyc{path,...}) =
98 :     IP.last path
99 :     | tycName (RECORDtyc _) = S.tycSymbol "<RECORDtyc>"
100 :     | tycName (RECtyc _) = S.tycSymbol "<RECtyc>"
101 :     | tycName (FREEtyc _) = S.tycSymbol "<FREEtyc>"
102 :     | tycName ERRORtyc = S.tycSymbol "<ERRORtyc>"
103 :    
104 :     (* get the stamp of a tycon *)
105 :     fun tycStamp (GENtyc { stamp, ... } | DEFtyc { stamp, ... }) = stamp
106 :     | tycStamp tycon = bugTyc("tycStamp",tycon)
107 :    
108 :     (* full path name of tycon, an InvPath.path *)
109 :     fun tycPath (GENtyc{path,...} | DEFtyc{path,...} | PATHtyc{path,...}) = path
110 :     | tycPath ERRORtyc = IP.IPATH[S.tycSymbol "error"]
111 :     | tycPath tycon = bugTyc("tycPath",tycon)
112 :    
113 :     fun tycEntPath(PATHtyc{entPath,...}) = entPath
114 :     | tycEntPath tycon = bugTyc("tycEntPath",tycon)
115 :    
116 :     fun tyconArity(GENtyc { arity, ... } | PATHtyc{arity,...}) = arity
117 :     | tyconArity(DEFtyc{tyfun=TYFUN{arity,...},...}) = arity
118 :     | tyconArity(RECORDtyc l) = length l
119 :     | tyconArity(ERRORtyc) = 0
120 :     | tyconArity tycon = bugTyc("tyconArity",tycon)
121 :    
122 :     fun setTycPath(tycon,path) =
123 :     case tycon
124 :     of GENtyc { stamp, arity, eq, kind, path = _, stub = _ } =>
125 :     GENtyc { stamp = stamp, arity = arity, eq = eq, kind = kind,
126 :     path = path, stub = NONE }
127 :     | DEFtyc{tyfun,strict,stamp,path=_} =>
128 :     DEFtyc{tyfun=tyfun,path=path,strict=strict,stamp=stamp}
129 :     | _ => bugTyc("setTycName",tycon)
130 :    
131 :     fun eqRecordLabels(nil,nil) = true
132 :     | eqRecordLabels(x::xs,y::ys) = Symbol.eq(x,y) andalso eqRecordLabels(xs,ys)
133 :     | eqRecordLabels _ = false
134 :    
135 :     fun eqTycon (GENtyc g, GENtyc g') = Stamps.eq (#stamp g, #stamp g')
136 :     | eqTycon (ERRORtyc,_) = true
137 :     | eqTycon (_,ERRORtyc) = true
138 :     (* this rule for PATHtycs is conservatively correct, but is only an
139 :     approximation *)
140 :     | eqTycon(PATHtyc{entPath=ep,...},PATHtyc{entPath=ep',...}) =
141 :     EP.eqEntPath(ep,ep')
142 :     (*
143 :     * This last case used for comparing DEFtyc's, RECORDtyc's.
144 :     * Also used in PPBasics to check data constructors of
145 :     * a datatype. Used elsewhere?
146 :     *)
147 :     | eqTycon(RECORDtyc l1, RECORDtyc l2) = eqRecordLabels(l1,l2)
148 :     | eqTycon _ = false
149 :    
150 :     (* for now... *)
151 :     fun mkCONty(ERRORtyc, _) = WILDCARDty
152 :     | mkCONty(tycon as DEFtyc{tyfun,strict,...}, args) =
153 :     CONty(tycon, ListPair.map
154 :     (fn (ty,strict) => if strict then ty else WILDCARDty)
155 :     (args,strict))
156 :     | mkCONty(tycon, args) = CONty(tycon, args);
157 :    
158 :     fun prune(VARty(tv as ref(INSTANTIATED ty))) : ty =
159 :     let val pruned = prune ty
160 :     in tv := INSTANTIATED pruned; pruned
161 :     end
162 :     | prune ty = ty
163 :    
164 :     fun eqTyvar(tv1: tyvar, tv2: tyvar) = (tv1 = tv2)
165 :    
166 :     fun bindTyvars(tyvars: tyvar list) : unit =
167 :     let fun loop([],_) = ()
168 :     | loop(tv::rest,n) =
169 :     (tv := INSTANTIATED (IBOUND n);
170 :     loop(rest,n+1))
171 :     in loop(tyvars,0)
172 :     end
173 :    
174 :     fun bindTyvars1(tyvars: tyvar list) : Types.polysign =
175 :     let fun loop([],_) = []
176 :     | loop((tv as ref(UBOUND{eq,...}))::rest,n) =
177 :     (tv := INSTANTIATED (IBOUND n);
178 :     eq :: loop(rest,n+1))
179 :     | loop _ = bug "bindTyvars1:UBOUND"
180 :     in loop(tyvars,0)
181 :     end
182 :    
183 :     exception SHARE
184 :    
185 :     (* assume that f fails on identity, i.e. f x raises SHARE instead of
186 :     returning x *)
187 :     fun shareMap f nil = raise SHARE
188 :     | shareMap f (x::l) =
189 :     (f x) :: ((shareMap f l) handle SHARE => l)
190 :     handle SHARE => x :: (shareMap f l)
191 :    
192 :     (*** This function should be merged with instantiatePoly soon --zsh ***)
193 :     fun applyTyfun(TYFUN{arity,body},args) =
194 :     let fun subst(IBOUND n) = List.nth(args,n)
195 :     | subst(CONty(tyc,args)) = CONty(tyc, shareMap subst args)
196 :     | subst(VARty(ref(INSTANTIATED ty))) = subst ty
197 :     | subst _ = raise SHARE
198 :     in if arity > 0
199 :     then subst body
200 :     handle SHARE => body
201 :     | Subscript => bug "applyTyfun - not enough arguments"
202 :     else body
203 :     end
204 :    
205 :     fun mapTypeFull f =
206 :     let fun mapTy ty =
207 :     case ty
208 :     of CONty (tc, tl) =>
209 :     mkCONty(f tc, map mapTy tl)
210 :     | POLYty {sign, tyfun=TYFUN{arity, body}} =>
211 :     POLYty{sign=sign, tyfun=TYFUN{arity=arity,body=mapTy body}}
212 :     | VARty(ref(INSTANTIATED ty)) => mapTy ty
213 :     | _ => ty
214 :     in mapTy
215 :     end
216 :    
217 :     fun appTypeFull f =
218 :     let fun appTy ty =
219 :     case ty
220 :     of CONty (tc, tl) => (f tc; app appTy tl)
221 :     | POLYty {sign, tyfun=TYFUN{arity, body}} => appTy body
222 :     | VARty(ref(INSTANTIATED ty)) => appTy ty
223 :     | _ => ()
224 :     in appTy
225 :     end
226 :    
227 :    
228 :     exception ReduceType
229 :    
230 :     fun reduceType(CONty(DEFtyc{tyfun,...}, args)) = applyTyfun(tyfun,args)
231 :     | reduceType(POLYty{sign=[],tyfun=TYFUN{arity=0,body}}) = body
232 :     | reduceType(VARty(ref(INSTANTIATED ty))) = ty
233 :     | reduceType _ = raise ReduceType
234 :    
235 :     fun headReduceType ty = headReduceType(reduceType ty) handle ReduceType => ty
236 :    
237 :     fun equalType(ty,ty') =
238 :     let fun eq(IBOUND i1, IBOUND i2) = i1 = i2
239 :     | eq(VARty(tv),VARty(tv')) = eqTyvar(tv,tv')
240 :     | eq(ty as CONty(tycon, args), ty' as CONty(tycon', args')) =
241 :     if eqTycon(tycon, tycon') then ListPair.all equalType(args,args')
242 :     else (eq(reduceType ty, ty')
243 :     handle ReduceType =>
244 :     (eq(ty,reduceType ty') handle ReduceType => false))
245 :     | eq(ty1 as (VARty _ | IBOUND _), ty2 as CONty _) =
246 :     (eq(ty1,reduceType ty2)
247 :     handle ReduceType => false)
248 :     | eq(ty1 as CONty _, ty2 as (VARty _ | IBOUND _)) =
249 :     (eq(reduceType ty1, ty2)
250 :     handle ReduceType => false)
251 :     | eq(WILDCARDty,_) = true
252 :     | eq(_,WILDCARDty) = true
253 :     | eq _ = false
254 :     in eq(prune ty, prune ty')
255 :     end
256 :    
257 :     local
258 :     (* making dummy argument lists to be used in equalTycon *)
259 :     val generator = Stamps.newGenerator()
260 :     fun makeDummyType() =
261 :     CONty(GENtyc{stamp = Stamps.fresh generator,
262 :     path = IP.IPATH[Symbol.tycSymbol "dummy"],
263 :     arity = 0, eq = ref YES, stub = NONE,
264 :     kind = PRIMITIVE CorePrimTycNum.ptn_void},[])
265 :     (*
266 :     * Making dummy type is a temporary hack ! pt_void is not used
267 :     * anywhere in the source language ... Requires major clean up
268 :     * in the future. (ZHONG)
269 :     * DBM: shouldn't cause any problem here. Only thing relevant
270 :     * property of the dummy types is that they have different stamps
271 :     * and their stamps should not agree with those of any "real" tycons.
272 :     *)
273 :     (* precomputing dummy argument lists
274 :     * -- perhaps a bit of over-optimization here. [dbm] *)
275 :     fun makeargs (0,args) = args
276 :     | makeargs (i,args) = makeargs(i-1, makeDummyType()::args)
277 :     val args10 = makeargs(10,[]) (* 10 dummys *)
278 :     val args1 = [hd args10]
279 :     val args2 = List.take (args10,2)
280 :     val args3 = List.take (args10,3) (* rarely need more than 3 args *)
281 :     in fun dummyargs 0 = []
282 :     | dummyargs 1 = args1
283 :     | dummyargs 2 = args2
284 :     | dummyargs 3 = args3
285 :     | dummyargs n =
286 :     if n <= 10 then List.take (args10,n) (* should be plenty *)
287 :     else makeargs(n-10,args10) (* but make new dummys if needed *)
288 :     end
289 :    
290 :     (* equalTycon. This definition deals only partially with types that
291 :     contain PATHtycs. There is no interpretation of the PATHtycs, but
292 :     PATHtycs with the same entPath will be seen as equal because of the
293 :     definition on eqTycon. *)
294 :     fun equalTycon(ERRORtyc,_) = true
295 :     | equalTycon(_,ERRORtyc) = true
296 :     | equalTycon(t1,t2) =
297 :     let val a1 = tyconArity t1 and a2 = tyconArity t2
298 :     in if a1<>a2 then false
299 :     else let val args = dummyargs a1
300 :     in equalType(mkCONty(t1,args),mkCONty(t2,args))
301 :     end
302 :     end
303 :    
304 :     (* instantiating polytypes *)
305 :    
306 :     fun typeArgs n =
307 :     if n>0
308 :     then mkMETAty() :: typeArgs(n-1)
309 :     else []
310 :    
311 :     val default_tvprop = false
312 :    
313 :     fun mkPolySign 0 = []
314 :     | mkPolySign n = default_tvprop :: mkPolySign(n-1)
315 :    
316 :     fun dconTyc(DATACON{typ,const,name,...}) =
317 :     let (* val _ = say "*** the screwed datacon ***"
318 :     val _ = say (S.name(name))
319 :     val _ = say " \n" *)
320 :     fun f (POLYty{tyfun=TYFUN{body,...},...},b) = f (body,b)
321 :     | f (CONty(tyc,_),true) = tyc
322 :     | f (CONty(_,[_,CONty(tyc,_)]),false) = tyc
323 :     | f _ = bug "dconTyc"
324 :     in f (typ,const)
325 :     end
326 :    
327 :     fun boundargs n =
328 :     let fun loop(i) =
329 :     if i>=n then nil
330 :     else IBOUND i :: loop(i+1)
331 :     in loop 0
332 :     end
333 :    
334 :     fun dconType (tyc,domain) =
335 : macqueen 1961 (case tyconArity tyc
336 :     of 0 => (case domain
337 :     of NONE => CONty(tyc,[])
338 :     | SOME dom => dom --> CONty(tyc,[]))
339 :     | arity =>
340 :     POLYty{sign=mkPolySign arity,
341 :     tyfun=TYFUN{arity=arity,
342 :     body = case domain
343 :     of NONE => CONty(tyc,boundargs(arity))
344 :     | SOME dom =>
345 :     dom --> CONty(tyc,boundargs(arity))}})
346 : blume 903
347 :     (* matching a scheme against a target type -- used declaring overloadings *)
348 :     fun matchScheme (TYFUN{arity,body}: tyfun, target: ty) : ty =
349 :     let val tyenv = array(arity,UNDEFty)
350 :     fun matchTyvar(i:int, ty: ty) : unit =
351 :     case tyenv sub i
352 :     of UNDEFty => update(tyenv,i,ty)
353 :     | ty' => if equalType(ty,ty')
354 :     then ()
355 :     else bug("this compiler was inadvertantly \
356 :     \distributed to a user who insists on \
357 :     \playing with 'overload' declarations.")
358 :     fun match(scheme:ty, target:ty) =
359 :     case (prune scheme,prune(target))
360 :     of (WILDCARDty, _) => () (* Wildcards match any type *)
361 :     | (_, WILDCARDty) => () (* Wildcards match any type *)
362 :     | ((IBOUND i),ty) => matchTyvar(i,ty)
363 :     | (CONty(tycon1,args1), pt as CONty(tycon2,args2)) =>
364 :     if eqTycon(tycon1,tycon2)
365 :     then ListPair.app match (args1, args2)
366 :     else (match(reduceType scheme, target)
367 :     handle ReduceType =>
368 :     (match(scheme, reduceType pt)
369 :     handle ReduceType =>
370 :     bug "matchScheme, match -- tycons "))
371 :     | _ => bug "matchScheme, match"
372 :     in case prune target
373 :     of POLYty{sign,tyfun=TYFUN{arity=arity',body=body'}} =>
374 :     (match(body,body');
375 :     POLYty{sign = sign,
376 :     tyfun = TYFUN{arity = arity',
377 :     body = if arity>1
378 :     then BT.tupleTy(Array.foldr (op ::)
379 :     nil tyenv)
380 :     else tyenv sub 0}})
381 :     | ty =>
382 :     (match(body,ty);
383 :     if arity>1
384 :     then BT.tupleTy(Array.foldr (op ::) nil tyenv)
385 :     else tyenv sub 0)
386 :     end
387 :    
388 :     val rec compressTy =
389 :     fn t as VARty(x as ref(INSTANTIATED(VARty(ref v)))) =>
390 :     (x := v; compressTy t)
391 :     | VARty(ref(OPEN{kind=FLEX fields,...})) =>
392 :     app (compressTy o #2) fields
393 :     | CONty(tyc,tyl) => app compressTy tyl
394 :     | POLYty{tyfun=TYFUN{body,...},...} => compressTy body
395 :     | _ => ()
396 :    
397 :     (*
398 :     * 8/18/92: cleaned up occ "state machine" some and fixed bug #612.
399 :     *
400 :     * Known behaviour of the attributes about the context that are kept:
401 :     *
402 :     * lamd = # of Abstr's seen so far. Starts at 0 with Root.
403 :     *
404 :     * top = true iff haven't seen a LetDef yet.
405 :     *)
406 :    
407 :     abstype occ = OCC of {lamd: int, top: bool}
408 :     with
409 :    
410 :     val Root = OCC{lamd=0, top=true}
411 :    
412 :     fun LetDef(OCC{lamd,...}) = OCC{lamd=lamd, top=false}
413 :    
414 :     fun Abstr(OCC{lamd,top}) = OCC{lamd=lamd+1, top=top}
415 :    
416 :     fun lamdepth (OCC{lamd,...}) = lamd
417 :    
418 :     fun toplevel (OCC{top,...}) = top
419 :    
420 :     end (* abstype occ *)
421 :    
422 :     (* instantiatePoly: ty -> ty * ty list
423 :     if argument is a POLYty, instantiates body of POLYty with new META typa
424 :     variables, returning the instantiatied body and the list of META tyvars.
425 :     if argument is not a POLYty, does nothing, returning argument type *)
426 :     fun instantiatePoly(POLYty{sign,tyfun}) : ty * ty list =
427 :     let val args =
428 :     map (fn eq =>
429 :     VARty(ref(OPEN{kind = META, depth = infinity, eq = eq})))
430 :     sign
431 :     in (applyTyfun(tyfun, args), args)
432 :     end
433 :     | instantiatePoly ty = (ty,[])
434 :    
435 :     local
436 :     exception CHECKEQ
437 :     in
438 :     fun checkEqTySig(ty, sign: polysign) =
439 :     let fun eqty(VARty(ref(INSTANTIATED ty))) = eqty ty
440 :     | eqty(CONty(DEFtyc{tyfun,...}, args)) =
441 :     eqty(applyTyfun(tyfun,args))
442 :     | eqty(CONty(GENtyc { eq, ... }, args)) =
443 :     (case !eq
444 :     of OBJ => ()
445 :     | YES => app eqty args
446 :     | (NO | ABS | IND) => raise CHECKEQ
447 :     | p => bug ("checkEqTySig: "^eqpropToString p))
448 :     | eqty(CONty(RECORDtyc _, args)) = app eqty args
449 :     | eqty(IBOUND n) = if List.nth(sign,n) then () else raise CHECKEQ
450 :     | eqty _ = ()
451 :     in eqty ty;
452 :     true
453 :     end
454 :     handle CHECKEQ => false
455 : macqueen 1961
456 :     fun checkEqTyInst(ty) =
457 :     let fun eqty(VARty(ref(INSTANTIATED ty))) = eqty ty
458 :     | eqty(VARty(ref(OPEN{eq,...}))) = if eq then () else raise CHECKEQ
459 :     | eqty(CONty(DEFtyc{tyfun,...}, args)) =
460 :     eqty(applyTyfun(tyfun,args))
461 :     | eqty(CONty(GENtyc { eq, ... }, args)) =
462 :     (case !eq
463 :     of OBJ => ()
464 :     | YES => app eqty args
465 :     | (NO | ABS | IND) => raise CHECKEQ
466 :     | p => bug ("checkEqTyInst: "^eqpropToString p))
467 :     | eqty(CONty(RECORDtyc _, args)) = app eqty args
468 :     | eqty(IBOUND n) = bug "checkEqTyInst: IBOUND in instantiated polytype"
469 :     | eqty _ = () (* what other cases? dbm *)
470 :     in eqty ty;
471 :     true
472 :     end
473 :     handle CHECKEQ => false
474 : blume 903 end
475 :    
476 : macqueen 1938 (* compType, compareTypes used to compare specification type with type of
477 :     * corresponding actual element. Check that spec type is an instance of
478 :     * the actual type *)
479 : blume 903 exception CompareTypes
480 :     fun compType(specty, specsign:polysign, actty,
481 :     actsign:polysign, actarity): unit =
482 : macqueen 1938 let val env = array(actarity,UNDEFty) (* instantiations of IBOUNDs in actual body *)
483 : blume 903 fun comp'(WILDCARDty, _) = ()
484 :     | comp'(_, WILDCARDty) = ()
485 :     | comp'(ty1, IBOUND i) =
486 :     (case env sub i
487 :     of UNDEFty =>
488 :     (let val eq = List.nth(actsign,i)
489 :     in if eq andalso not(checkEqTySig(ty1,specsign))
490 :     then raise CompareTypes
491 : macqueen 1961 else update(env,i,ty1)
492 : blume 903 end handle Subscript => ())
493 :     | ty => if equalType(ty1,ty)
494 :     then ()
495 :     else raise CompareTypes)
496 :     | comp'(CONty(tycon1, args1), CONty(tycon2, args2)) =
497 :     if eqTycon(tycon1,tycon2)
498 :     then ListPair.app comp (args1,args2)
499 :     else raise CompareTypes
500 :     | comp' _ = raise CompareTypes
501 :     and comp(ty1,ty2) = comp'(headReduceType ty1, headReduceType ty2)
502 :     in comp(specty,actty)
503 :     end
504 :    
505 : macqueen 1938 (* returns true if actual type > spec type, i.e. if spec is an instance of actual *)
506 : blume 903 fun compareTypes (spec : ty, actual: ty): bool =
507 :     let val actual = prune actual
508 :     in case spec
509 :     of POLYty{sign,tyfun=TYFUN{body,...}} =>
510 :     (case actual
511 :     of POLYty{sign=sign',tyfun=TYFUN{arity,body=body'}} =>
512 :     (compType(body,sign,body',sign',arity); true)
513 :     | WILDCARDty => true
514 : macqueen 1961 | _ => false) (* if spec is poly, then actual must be poly *)
515 : blume 903 | WILDCARDty => true
516 : macqueen 1961 | _ => (* spec is a monotype *)
517 : blume 903 (case actual
518 :     of POLYty{sign,tyfun=TYFUN{arity,body}} =>
519 :     (compType(spec,[],body,sign,arity); true)
520 :     | WILDCARDty => true
521 :     | _ => equalType(spec,actual))
522 :     end handle CompareTypes => false
523 :    
524 : georgekuan 1952 (* matchTypes -- one-way matching of actual to spec type; yields
525 :     list of instantiation metavariables
526 :     Parameters:
527 :     spec -- specification type
528 :     actual -- actual type
529 :     Returns:
530 :     (specGenericTvs, -- spec metavariables that are generalized
531 :     in the match
532 :     actParamTvs) -- metavariables in actual type that are instantiations
533 :     of spec metavariables in match
534 :     Invariant: specGenericTvs are always instantiated but
535 :     actInstTvs are never generalized (because they are only
536 :     meaningful in this function and are immediately generalized
537 :     away.
538 :     Comments: compareTypes does pruning so there is no need to prune in
539 :     this function or anywhere else that uses compareTypes or
540 :     matchTypes.
541 : georgekuan 1953
542 :     matchTypes is used in SigMatch for matching structures (matchStr1) only
543 : macqueen 1961
544 :     dbm:This doesn't work. After instantiating spec and actual, have to do
545 :     a one-way match of spec (specinst) against (more general) actual (actinst),
546 :     and this match should instantiate the tyvars in actParamTvs to capture
547 :     the parameters that instantiate actual to produce specinst.
548 : georgekuan 1952 *)
549 : macqueen 1961 (*
550 : georgekuan 1952 fun matchTypes (specTy, actualTy) =
551 : georgekuan 1953 (* If specTy is an instance of actualTy,
552 :     then match, otherwise give up. *)
553 : georgekuan 1952 if compareTypes(specTy, actualTy) then
554 : georgekuan 1953 (* compareTypes should have already determined that the
555 :     two types match. *)
556 : georgekuan 1952 let
557 : georgekuan 1953 val (actinst, actParamTvs) = instantiatePoly actualTy
558 :     val (specinst, specGenericTvs) = instantiatePoly specTy
559 : georgekuan 1952 in
560 : georgekuan 1953 (* These metavariable lists may be empty if either actualTy
561 :     or specTy are monomorphic *)
562 : georgekuan 1952 (specGenericTvs, actParamTvs)
563 :     end
564 :     else ([], [])
565 : macqueen 1961 *)
566 :     (* matchInstTypes: ty * ty -> (tyvar list * tyvar list) option
567 :     * The first argument is a spec type (e.g. from a signature spec),
568 :     * while the second is a potentially more general actual type. The
569 :     * two types are instantiated (if they are polymorphic), and a one-way
570 :     * match is performed on their generic instantiations.
571 :     * [Note that the match cannot succeed if spec is polymorphic while
572 :     * actualTy is monomorphic.]
573 :     * This function is also used more generally to obtain instantiation
574 :     * parameters for a polytype (actualTy) to obtain one of its instantiations
575 :     * (specTy). This usage occurs in translate.sml where we match an occurrence
576 :     * type of a primop variable with the intrinsic type of the primop to obtain
577 :     * the parameters of instantiation of the primop.
578 :     *)
579 :     fun matchInstTypes(specTy,actualTy) =
580 :     let fun match'(WILDCARDty, _) = () (* possible? how? *)
581 :     | match'(_, WILDCARDty) = () (* possible? how? *)
582 : georgekuan 1962 | match'(ty1, VARty(tv as ref(OPEN{kind=META,eq,...}))) =
583 : macqueen 1961 if eq andalso not(checkEqTyInst(ty1))
584 :     then raise CompareTypes
585 :     else tv := INSTANTIATED ty1
586 : georgekuan 1962 | match'(ty1, VARty(tv as ref(INSTANTIATED ty2))) =
587 : macqueen 1961 if equalType(ty1,ty2) then () else raise CompareTypes
588 :     | match'(CONty(tycon1, args1), CONty(tycon2, args2)) =
589 :     if eqTycon(tycon1,tycon2)
590 :     then ListPair.app match (args1,args2)
591 :     else raise CompareTypes
592 :     | match' _ = raise CompareTypes
593 :     and match(ty1,ty2) = match'(headReduceType ty1, headReduceType ty2)
594 :     val (actinst, actParamTvs) = instantiatePoly actualTy
595 :     val (specinst, specGenericTvs) = instantiatePoly specTy
596 :     in match(specinst,actinst);
597 :     SOME(specGenericTvs, actParamTvs)
598 :     end handle CompareTypes => NONE
599 : georgekuan 1952
600 : blume 903 (* given a single-type-variable type, extract out the tyvar *)
601 :     fun tyvarType (VARty (tv as ref(OPEN _))) = tv
602 :     | tyvarType (VARty (tv as ref(INSTANTIATED t))) = tyvarType t
603 :     | tyvarType WILDCARDty = ref(mkMETA infinity) (* fake a tyvar *)
604 :     | tyvarType (IBOUND i) = bug "tyvarType: IBOUND"
605 :     | tyvarType (CONty(_,_)) = bug "tyvarType: CONty"
606 :     | tyvarType (POLYty _) = bug "tyvarType: POLYty"
607 :     | tyvarType UNDEFty = bug "tyvarType: UNDEFty"
608 : macqueen 1938 | tyvarType _ = bug "tyvarType - unexpected argument"
609 : blume 903
610 :     (*
611 :     * getRecTyvarMap : int * ty -> (int -> bool)
612 :     * see if a bound tyvar has occurred in some datatypes, e.g. 'a list.
613 :     * this is useful for representation analysis. This function probably
614 : macqueen 1961 * will soon be obsolete (dbm: Why?).
615 : blume 903 *)
616 :     fun getRecTyvarMap (n,ty) =
617 :     let val s = Array.array(n,false)
618 :     fun notArrow tyc = not (eqTycon (tyc, BT.arrowTycon))
619 :     (* orelse eqTycon(tyc,contTycon) *)
620 :     fun special (tyc as GENtyc { arity, ... }) =
621 :     arity <> 0 andalso notArrow tyc
622 :     | special(RECORDtyc _) = false
623 :     | special tyc = notArrow tyc
624 :    
625 :     fun scan(b,(IBOUND n)) = if b then (update(s,n,true)) else ()
626 :     | scan(b,CONty(tyc,args)) =
627 :     let val nb = (special tyc) orelse b
628 :     in app (fn t => scan(nb,t)) args
629 :     end
630 :     | scan(b,VARty(ref(INSTANTIATED ty))) = scan(b,ty)
631 :     | scan _ = ()
632 :    
633 :     val _ = scan(false,ty)
634 :    
635 :     in fn i => (Array.sub(s,i) handle General.Subscript =>
636 :     bug "Strange things in TypesUtil.getRecTyvarMap")
637 :     end
638 :    
639 :     fun gtLabel(a,b) =
640 :     let val a' = Symbol.name a and b' = Symbol.name b
641 :     val a0 = String.sub(a',0) and b0 = String.sub(b',0)
642 :     in if Char.isDigit a0
643 :     then if Char.isDigit b0
644 :     then (size a' > size b' orelse size a' = size b' andalso a' > b')
645 :     else false
646 :     else if Char.isDigit b0
647 :     then true
648 :     else (a' > b')
649 :     end
650 :    
651 :     (* Tests used to implement the value restriction *)
652 :     (* Based on Ken Cline's version; allows refutable patterns *)
653 :     (* Modified to support CAST, and special binding CASEexp. (ZHONG) *)
654 :     (* Modified to allow applications of lazy val rec Y combinators to
655 :     be nonexpansive. (Taha, DBM) *)
656 : georgekuan 1941 (** Either InlInfo must be moved closer to here or this function needs
657 :     to move to where InlInfo is. -GK *)
658 :     (**
659 : blume 903 local open Absyn in
660 :    
661 : macqueen 1938 fun isValue (VARexp _) = true
662 :     | isValue (CONexp _) = true
663 :     | isValue (INTexp _) = true
664 :     | isValue (WORDexp _) = true
665 :     | isValue (REALexp _) = true
666 :     | isValue (STRINGexp _) = true
667 :     | isValue (CHARexp _) = true
668 :     | isValue (FNexp _) = true
669 :     | isValue (RECORDexp fields) =
670 :     foldr (fn ((_,exp),x) => x andalso (isValue exp)) true fields
671 :     | isValue (SELECTexp(_, e)) = isValue e
672 :     | isValue (VECTORexp (exps, _)) =
673 :     foldr (fn (exp,x) => x andalso (isValue exp)) true exps
674 :     | isValue (SEQexp nil) = true
675 :     | isValue (SEQexp [e]) = isValue e
676 :     | isValue (SEQexp _) = false
677 :     | isValue (APPexp(rator, rand)) =
678 :     let fun isrefdcon(DATACON{rep=A.REF,...}) = true
679 :     | isrefdcon _ = false
680 : macqueen 1961 fun iscast (VALvar {prim, ...}) = PrimOpId.isPrimCast prim
681 : macqueen 1938 | iscast _ = false
682 : blume 903
683 : macqueen 1938 (* LAZY: The following function allows applications of the
684 :     * fixed-point combinators generated for lazy val recs to
685 :     * be non-expansive. *)
686 :     fun issafe(VALvar{path=(SymPath.SPATH [s]),...}) =
687 :     (case String.explode (Symbol.name s)
688 :     of (#"Y" :: #"$" :: _) => true
689 :     | _ => false)
690 :     | issafe _ = false
691 : blume 903
692 : macqueen 1938 fun iscon (CONexp(dcon,_)) = not (isrefdcon dcon)
693 :     | iscon (MARKexp(e,_)) = iscon e
694 :     | iscon (VARexp(ref v, _)) = (iscast v) orelse (issafe v)
695 :     | iscon _ = false
696 :     in if iscon rator then isValue rand
697 :     else false
698 :     end
699 :     | isValue (CONSTRAINTexp(e,_)) = isValue e
700 :     | isValue (CASEexp(e, (RULE(p,_))::_, false)) =
701 :     (isValue e) andalso (irref p) (* special bind CASEexps *)
702 :     | isValue (LETexp(VALRECdec _, e)) = (isValue e) (* special RVB hacks *)
703 :     | isValue (MARKexp(e,_)) = isValue e
704 :     | isValue _ = false
705 : georgekuan 1941
706 : blume 903
707 : georgekuan 1941
708 : blume 903 (* testing if a binding pattern is irrefutable --- complete *)
709 :     and irref pp =
710 :     let fun udcon(DATACON{sign=A.CSIG(x,y),...}) = ((x+y) = 1)
711 :     | udcon _ = false
712 :    
713 :     fun g (CONpat(dc,_)) = udcon dc
714 :     | g (APPpat(dc,_,p)) = (udcon dc) andalso (g p)
715 :     | g (RECORDpat{fields=ps,...}) =
716 :     let fun h((_, p)::r) = if g p then h r else false
717 :     | h _ = true
718 :     in h ps
719 :     end
720 :     | g (CONSTRAINTpat(p, _)) = g p
721 :     | g (LAYEREDpat(p1,p2)) = (g p1) andalso (g p2)
722 :     | g (ORpat(p1,p2)) = (g p1) andalso (g p2)
723 :     | g (VECTORpat(ps,_)) =
724 :     let fun h (p::r) = if g p then h r else false
725 :     | h _ = true
726 :     in h ps
727 :     end
728 :     | g _ = true
729 :     in g pp
730 :     end
731 :     end (* local *)
732 : georgekuan 1942 *)
733 : blume 903
734 : georgekuan 1941
735 : blume 903 fun isVarTy(VARty(ref(INSTANTIATED ty))) = isVarTy ty
736 :     | isVarTy(VARty _) = true
737 :     | isVarTy(_) = false
738 :    
739 :    
740 :     (* sortFields, mapUnZip: two utility functions used in type checking
741 :     (typecheck.sml, mtderiv.sml, reconstruct.sml) *)
742 :    
743 :     fun sortFields fields =
744 :     ListMergeSort.sort (fn ((Absyn.LABEL{number=n1,...},_),
745 :     (Absyn.LABEL{number=n2,...},_)) => n1>n2)
746 :     fields
747 :    
748 :     fun mapUnZip f nil = (nil,nil)
749 :     | mapUnZip f (hd::tl) =
750 :     let val (x,y) = f(hd)
751 :     val (xl,yl) = mapUnZip f tl
752 :     in (x::xl,y::yl)
753 :     end
754 :    
755 :     fun foldTypeEntire f =
756 :     let fun foldTc (tyc, b0) =
757 :     case tyc
758 :     of GENtyc { kind, ... } =>
759 :     (case kind of
760 :     DATATYPE{family={members=ms,...},...} => b0
761 :     (* foldl (fn ({dcons, ...},b) => foldl foldDcons b dcons) b0 ms *)
762 :     | ABSTRACT tc => foldTc (tc, b0)
763 :     | _ => b0)
764 :     | DEFtyc{tyfun=TYFUN{arity,body}, ...} => foldTy(body, b0)
765 :     | _ => b0
766 :    
767 :     and foldDcons({name, rep, domain=NONE}, b0) = b0
768 :     | foldDcons({domain=SOME ty, ...}, b0) = foldTy(ty, b0)
769 :    
770 :     and foldTy (ty, b0) =
771 :     case ty
772 :     of CONty (tc, tl) =>
773 :     let val b1 = f(tc, b0)
774 :     val b2 = foldTc(tc, b1)
775 :     in foldl foldTy b2 tl
776 :     end
777 :     | POLYty {sign, tyfun=TYFUN{arity, body}} => foldTy(body, b0)
778 :     | VARty(ref(INSTANTIATED ty)) => foldTy(ty, b0)
779 :     | _ => b0
780 :     in foldTy
781 :     end
782 :    
783 :     fun mapTypeEntire f =
784 :     let fun mapTy ty =
785 :     case ty
786 :     of CONty (tc, tl) =>
787 :     mkCONty(f(mapTc, tc), map mapTy tl)
788 :     | POLYty {sign, tyfun=TYFUN{arity, body}} =>
789 :     POLYty{sign=sign, tyfun=TYFUN{arity=arity,body=mapTy body}}
790 :     | VARty(ref(INSTANTIATED ty)) => mapTy ty
791 :     | _ => ty
792 :    
793 :     and mapTc tyc =
794 :     case tyc
795 :     of GENtyc { stamp, arity, eq, path, kind, stub = _ } =>
796 :     (case kind of
797 :     DATATYPE{index,family={members,...},...} => tyc
798 :     (*
799 :     * The following code needs to be rewritten !!! (ZHONG)
800 :    
801 :     GENtyc{stamp=stamp, arity=arity, eq=eq, path=path,
802 :     kind=DATATYPE {index=index, members=map mapMb members,
803 :     lambdatyc = ref NONE}}
804 :     *)
805 :     | ABSTRACT tc =>
806 :     GENtyc {stamp=stamp, arity=arity, eq=eq, path=path,
807 :     kind= ABSTRACT (mapTc tc),
808 :     stub = NONE}
809 :     | _ => tyc)
810 :     | DEFtyc{stamp, strict, tyfun, path} =>
811 :     DEFtyc{stamp=stamp, strict=strict, tyfun=mapTf tyfun,
812 :     path=path}
813 :     | _ => tyc
814 :    
815 :     and mapMb {tycname, stamp, arity, dcons, lambdatyc} =
816 :     {tycname=tycname, stamp=stamp, arity=arity,
817 :     dcons=(map mapDcons dcons), lambdatyc=ref NONE}
818 :    
819 :     and mapDcons (x as {name, rep, domain=NONE}) = x
820 :     | mapDcons (x as {name, rep, domain=SOME ty}) =
821 :     {name=name, rep=rep, domain=SOME(mapTy ty)}
822 :    
823 :     and mapTf (TYFUN{arity, body}) =
824 :     TYFUN{arity=arity, body=mapTy body}
825 :    
826 :     in mapTy
827 :     end
828 :    
829 :    
830 :     (*
831 :     * Here, using a set implementation should suffice, however,
832 :     * I am using a binary dictionary instead. (ZHONG)
833 :     *)
834 :     local
835 :     structure TycSet = StampMap
836 :     in
837 :     type tycset = tycon TycSet.map
838 :    
839 :     val mkTycSet = fn () => TycSet.empty
840 :    
841 :     fun addTycSet(tyc as GENtyc { stamp, ... }, tycset) =
842 :     TycSet.insert (tycset, stamp, tyc)
843 :     | addTycSet _ = bug "unexpected tycons in addTycSet"
844 :    
845 :     fun inTycSet(tyc as GENtyc { stamp, ... }, tycset) =
846 :     isSome (TycSet.find(tycset, stamp))
847 :     | inTycSet _ = false
848 :    
849 :     fun filterSet(ty, tycs) =
850 :     let fun inList (a::r, tc) = if eqTycon(a, tc) then true else inList(r, tc)
851 :     | inList ([], tc) = false
852 :    
853 :     fun pass1 (tc, tset) =
854 :     if inTycSet(tc, tycs) then
855 :     (if inList(tset, tc) then tset else tc::tset)
856 :     else tset
857 :     in foldTypeEntire pass1 (ty, [])
858 :     end
859 :     (*
860 :     val filterSet = fn x =>
861 :     Stats.doPhase(Stats.makePhase "Compiler 034 filterSet") filterSet x
862 :     *)
863 :    
864 :     end (* local TycSet *)
865 :    
866 :     (*
867 :     (* The reformat function is called inside translate.sml to reformat
868 :     * a type abstraction packing inside PACKexp absyn. It is a hack. (ZHONG)
869 :     *)
870 :     fun reformat { tp_var, tp_tyc } (ty, tycs, depth) =
871 :     let fun h ([], i, ks, ps, nts) = (rev ks, rev ps, rev nts)
872 :     | h (tc :: rest, i, ks, ps, nts) = let
873 :     fun noabs () = bug "non-abstract tycons seen in TU.reformat"
874 :     in
875 :     case tc
876 :     of GENtyc { stamp, arity, eq, path, kind, stub } =>
877 :     (case kind of
878 :     ABSTRACT itc => let
879 :     val tk = LT.tkc_int arity
880 :     (*
881 :     val tps = TP_VAR (TVI.toExn
882 :     {depth=depth, num=i, kind=tk})
883 :     *)
884 :     val tps = tp_var { depth=depth, num=i, kind=tk}
885 :     val nkind = FLEXTYC tps
886 :     val ntc =
887 :     GENtyc { stamp = stamp, arity = arity,
888 :     eq = eq, kind = nkind, path = path,
889 :     stub = NONE}
890 :     in
891 :     h (rest, i+1, tk::ks, (tp_tyc itc)::ps, ntc::nts)
892 :     end
893 :     | _ => noabs ())
894 :     | _ => noabs ()
895 :     end
896 :    
897 :     val (tks, tps, ntycs) = h(tycs, 0, [], [], [])
898 :    
899 :     fun getTyc (foo, tc) =
900 :     let fun h(a::r, tc) = if eqTycon(a, tc) then a else h(r, tc)
901 :     | h([], tc) = foo tc
902 :     in h(ntycs, tc)
903 :     end
904 :    
905 :     val nty = mapTypeEntire getTyc ty
906 :    
907 :     in (nty, tks, tps)
908 :     end
909 :    
910 :     val reformat = Stats.doPhase(Stats.makePhase "Compiler 047 reformat") reformat
911 :     *)
912 :    
913 :     fun dtSibling(n,tyc as GENtyc { kind = DATATYPE dt, ... }) =
914 :     let val {index,stamps,freetycs,root, family as {members,...} } = dt
915 :     in
916 :     if n = index then tyc
917 :     else let val {tycname,arity,dcons,eq,lazyp,sign} =
918 :     Vector.sub(members,n)
919 :     val stamp= Vector.sub(stamps,n)
920 :     in
921 :     GENtyc {stamp=stamp,
922 :     arity=arity,eq=eq,path=IP.IPATH[tycname],
923 :     kind=DATATYPE{index=n,stamps=stamps,
924 :     freetycs=freetycs,
925 :     root=NONE (*!*),
926 :     family=family},
927 :     stub = NONE}
928 :     end
929 :     end
930 :     | dtSibling _ = bug "dtSibling"
931 :    
932 :     (* NOTE: this only works (perhaps) for datatype declarations, but not
933 :     specifications. The reason: the root field is used to connect mutually
934 :     recursive datatype specifications together, its information cannot be
935 :     fully recovered in dtSibling. (ZHONG)
936 :     *)
937 :     fun extractDcons (tyc as GENtyc { kind = DATATYPE dt, ... }) =
938 :     let val {index,stamps,freetycs,root,family as {members,...}} = dt
939 :     val {dcons,sign,lazyp,...} = Vector.sub(members,index)
940 :     fun expandTyc(PATHtyc _) =
941 :     bug "expandTyc:PATHtyc" (* use expandTycon? *)
942 :     | expandTyc(RECtyc n) = dtSibling(n,tyc)
943 :     | expandTyc(FREEtyc n) =
944 :     ((List.nth(freetycs,n))
945 :     handle _ => bug "unexpected freetycs in extractDcons")
946 :     | expandTyc tyc = tyc
947 :    
948 :     fun expand ty = mapTypeFull expandTyc ty
949 :    
950 :     fun mkDcon({name,rep,domain}) =
951 :     DATACON{name = name, rep = rep, sign = sign, lazyp = lazyp,
952 :     typ = dconType (tyc, Option.map expand domain),
953 :     const = case domain of NONE => true | _ => false}
954 :    
955 :     in map mkDcon dcons
956 :     end
957 :     | extractDcons _ = bug "extractDcons"
958 :    
959 :     fun mkStrict 0 = []
960 :     | mkStrict n = true :: mkStrict(n-1)
961 :    
962 :     (* used in ElabSig for datatype replication specs, where the tyc arg
963 :     * is expected to be either a GENtyc/DATATYPE or a PATHtyc. *)
964 :     fun wrapDef(tyc as DEFtyc _,_) = tyc
965 :     | wrapDef(tyc,s) =
966 :     let val arity = tyconArity tyc
967 :     val name = tycName tyc
968 :     val args = boundargs arity
969 :     in DEFtyc{stamp=s,strict=mkStrict arity,path=IP.IPATH[name],
970 :     tyfun=TYFUN{arity=arity,body=CONty(tyc,args)}}
971 :     end
972 :    
973 :     (* eta-reduce a type function: \args.tc args => tc *)
974 :     fun unWrapDef1(tyc as DEFtyc{tyfun=TYFUN{body=CONty(tyc',args),arity},...}) =
975 :     let fun formals((IBOUND i)::rest,j) = if i=j then formals(rest,j+1) else false
976 :     | formals(nil,_) = true
977 :     | formals _ = false
978 :     in if formals(args,0) then SOME tyc' else NONE
979 :     end
980 :     | unWrapDef1 tyc = NONE
981 :    
982 :     (* closure under iterated eta-reduction *)
983 :     fun unWrapDefStar tyc =
984 :     (case unWrapDef1 tyc
985 :     of SOME tyc' => unWrapDefStar tyc'
986 :     | NONE => tyc)
987 :    
988 : macqueen 1961 (* dummyTyGen produces a generator of dummy types with names X0, X1, etc.
989 :     * These are used to to instantiate type metavariables in top-level val
990 :     * decls that are not generalized because of the value restriction. *)
991 : blume 903 fun dummyTyGen () : unit -> Types.ty =
992 :     let val count = ref 0
993 :     fun next () = (count := !count + 1; !count)
994 :     fun nextTy () =
995 :     let val name = "X"^Int.toString(next())
996 :     in CONty(GENtyc{stamp = ST.special name,
997 :     path = IP.IPATH[S.tycSymbol name],
998 :     arity = 0, eq = ref NO,
999 :     kind = ABSTRACT BT.boolTycon,
1000 :     stub = NONE},
1001 :     [])
1002 :     end
1003 :     in nextTy
1004 :     end
1005 :    
1006 :     end (* local *)
1007 :     end (* structure TypesUtil *)

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