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 903 - (view) (download)
Original Path: sml/trunk/src/compiler/ElabData/types/typesutil.sml

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 :     let val name = SS.triml 1 (SS.all name) (* remove leading "'" *)
52 :     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 :     fun mkMETAtyBounded depth : ty = VARty(mkTyvar (mkMETA depth))
80 :    
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 :     let val arity = tyconArity tyc
336 :     in
337 :     case arity of
338 :     0 => (case domain of
339 :     NONE => CONty(tyc,[])
340 :     | SOME dom => dom --> CONty(tyc,[]))
341 :     | _ =>
342 :     POLYty{sign=mkPolySign arity,
343 :     tyfun=TYFUN{arity=arity,
344 :     body = case domain of
345 :     NONE => CONty(tyc,boundargs(arity))
346 :     | SOME dom =>
347 :     dom --> CONty(tyc,boundargs(arity))}}
348 :     end
349 :    
350 :     (* matching a scheme against a target type -- used declaring overloadings *)
351 :     fun matchScheme (TYFUN{arity,body}: tyfun, target: ty) : ty =
352 :     let val tyenv = array(arity,UNDEFty)
353 :     fun matchTyvar(i:int, ty: ty) : unit =
354 :     case tyenv sub i
355 :     of UNDEFty => update(tyenv,i,ty)
356 :     | ty' => if equalType(ty,ty')
357 :     then ()
358 :     else bug("this compiler was inadvertantly \
359 :     \distributed to a user who insists on \
360 :     \playing with 'overload' declarations.")
361 :     fun match(scheme:ty, target:ty) =
362 :     case (prune scheme,prune(target))
363 :     of (WILDCARDty, _) => () (* Wildcards match any type *)
364 :     | (_, WILDCARDty) => () (* Wildcards match any type *)
365 :     | ((IBOUND i),ty) => matchTyvar(i,ty)
366 :     | (CONty(tycon1,args1), pt as CONty(tycon2,args2)) =>
367 :     if eqTycon(tycon1,tycon2)
368 :     then ListPair.app match (args1, args2)
369 :     else (match(reduceType scheme, target)
370 :     handle ReduceType =>
371 :     (match(scheme, reduceType pt)
372 :     handle ReduceType =>
373 :     bug "matchScheme, match -- tycons "))
374 :     | _ => bug "matchScheme, match"
375 :     in case prune target
376 :     of POLYty{sign,tyfun=TYFUN{arity=arity',body=body'}} =>
377 :     (match(body,body');
378 :     POLYty{sign = sign,
379 :     tyfun = TYFUN{arity = arity',
380 :     body = if arity>1
381 :     then BT.tupleTy(Array.foldr (op ::)
382 :     nil tyenv)
383 :     else tyenv sub 0}})
384 :     | ty =>
385 :     (match(body,ty);
386 :     if arity>1
387 :     then BT.tupleTy(Array.foldr (op ::) nil tyenv)
388 :     else tyenv sub 0)
389 :     end
390 :    
391 :     val rec compressTy =
392 :     fn t as VARty(x as ref(INSTANTIATED(VARty(ref v)))) =>
393 :     (x := v; compressTy t)
394 :     | VARty(ref(OPEN{kind=FLEX fields,...})) =>
395 :     app (compressTy o #2) fields
396 :     | CONty(tyc,tyl) => app compressTy tyl
397 :     | POLYty{tyfun=TYFUN{body,...},...} => compressTy body
398 :     | _ => ()
399 :    
400 :     (*
401 :     * 8/18/92: cleaned up occ "state machine" some and fixed bug #612.
402 :     *
403 :     * Known behaviour of the attributes about the context that are kept:
404 :     *
405 :     * lamd = # of Abstr's seen so far. Starts at 0 with Root.
406 :     *
407 :     * top = true iff haven't seen a LetDef yet.
408 :     *)
409 :    
410 :     abstype occ = OCC of {lamd: int, top: bool}
411 :     with
412 :    
413 :     val Root = OCC{lamd=0, top=true}
414 :    
415 :     fun LetDef(OCC{lamd,...}) = OCC{lamd=lamd, top=false}
416 :    
417 :     fun Abstr(OCC{lamd,top}) = OCC{lamd=lamd+1, top=top}
418 :    
419 :     fun lamdepth (OCC{lamd,...}) = lamd
420 :    
421 :     fun toplevel (OCC{top,...}) = top
422 :    
423 :     end (* abstype occ *)
424 :    
425 :     (* instantiatePoly: ty -> ty * ty list
426 :     if argument is a POLYty, instantiates body of POLYty with new META typa
427 :     variables, returning the instantiatied body and the list of META tyvars.
428 :     if argument is not a POLYty, does nothing, returning argument type *)
429 :     fun instantiatePoly(POLYty{sign,tyfun}) : ty * ty list =
430 :     let val args =
431 :     map (fn eq =>
432 :     VARty(ref(OPEN{kind = META, depth = infinity, eq = eq})))
433 :     sign
434 :     in (applyTyfun(tyfun, args), args)
435 :     end
436 :     | instantiatePoly ty = (ty,[])
437 :    
438 :     local
439 :     exception CHECKEQ
440 :     in
441 :     fun checkEqTySig(ty, sign: polysign) =
442 :     let fun eqty(VARty(ref(INSTANTIATED ty))) = eqty ty
443 :     | eqty(CONty(DEFtyc{tyfun,...}, args)) =
444 :     eqty(applyTyfun(tyfun,args))
445 :     | eqty(CONty(GENtyc { eq, ... }, args)) =
446 :     (case !eq
447 :     of OBJ => ()
448 :     | YES => app eqty args
449 :     | (NO | ABS | IND) => raise CHECKEQ
450 :     | p => bug ("checkEqTySig: "^eqpropToString p))
451 :     | eqty(CONty(RECORDtyc _, args)) = app eqty args
452 :     | eqty(IBOUND n) = if List.nth(sign,n) then () else raise CHECKEQ
453 :     | eqty _ = ()
454 :     in eqty ty;
455 :     true
456 :     end
457 :     handle CHECKEQ => false
458 :     end
459 :    
460 :     exception CompareTypes
461 :     fun compType(specty, specsign:polysign, actty,
462 :     actsign:polysign, actarity): unit =
463 :     let val env = array(actarity,UNDEFty)
464 :     fun comp'(WILDCARDty, _) = ()
465 :     | comp'(_, WILDCARDty) = ()
466 :     | comp'(ty1, IBOUND i) =
467 :     (case env sub i
468 :     of UNDEFty =>
469 :     (let val eq = List.nth(actsign,i)
470 :     in if eq andalso not(checkEqTySig(ty1,specsign))
471 :     then raise CompareTypes
472 :     else ();
473 :     update(env,i,ty1)
474 :     end handle Subscript => ())
475 :     | ty => if equalType(ty1,ty)
476 :     then ()
477 :     else raise CompareTypes)
478 :     | comp'(CONty(tycon1, args1), CONty(tycon2, args2)) =
479 :     if eqTycon(tycon1,tycon2)
480 :     then ListPair.app comp (args1,args2)
481 :     else raise CompareTypes
482 :     | comp' _ = raise CompareTypes
483 :     and comp(ty1,ty2) = comp'(headReduceType ty1, headReduceType ty2)
484 :     in comp(specty,actty)
485 :     end
486 :    
487 :     (* returns true if actual type > spec type *)
488 :     fun compareTypes (spec : ty, actual: ty): bool =
489 :     let val actual = prune actual
490 :     in case spec
491 :     of POLYty{sign,tyfun=TYFUN{body,...}} =>
492 :     (case actual
493 :     of POLYty{sign=sign',tyfun=TYFUN{arity,body=body'}} =>
494 :     (compType(body,sign,body',sign',arity); true)
495 :     | WILDCARDty => true
496 :     | _ => false)
497 :     | WILDCARDty => true
498 :     | _ =>
499 :     (case actual
500 :     of POLYty{sign,tyfun=TYFUN{arity,body}} =>
501 :     (compType(spec,[],body,sign,arity); true)
502 :     | WILDCARDty => true
503 :     | _ => equalType(spec,actual))
504 :     end handle CompareTypes => false
505 :    
506 :     (* given a single-type-variable type, extract out the tyvar *)
507 :     fun tyvarType (VARty (tv as ref(OPEN _))) = tv
508 :     | tyvarType (VARty (tv as ref(INSTANTIATED t))) = tyvarType t
509 :     | tyvarType WILDCARDty = ref(mkMETA infinity) (* fake a tyvar *)
510 :     | tyvarType (IBOUND i) = bug "tyvarType: IBOUND"
511 :     | tyvarType (CONty(_,_)) = bug "tyvarType: CONty"
512 :     | tyvarType (POLYty _) = bug "tyvarType: POLYty"
513 :     | tyvarType UNDEFty = bug "tyvarType: UNDEFty"
514 :     | tyvarType _ = bug "tyvarType 124"
515 :    
516 :     (*
517 :     * getRecTyvarMap : int * ty -> (int -> bool)
518 :     * see if a bound tyvar has occurred in some datatypes, e.g. 'a list.
519 :     * this is useful for representation analysis. This function probably
520 :     * will soon be obsolete.
521 :     *)
522 :     fun getRecTyvarMap (n,ty) =
523 :     let val s = Array.array(n,false)
524 :     fun notArrow tyc = not (eqTycon (tyc, BT.arrowTycon))
525 :     (* orelse eqTycon(tyc,contTycon) *)
526 :     fun special (tyc as GENtyc { arity, ... }) =
527 :     arity <> 0 andalso notArrow tyc
528 :     | special(RECORDtyc _) = false
529 :     | special tyc = notArrow tyc
530 :    
531 :     fun scan(b,(IBOUND n)) = if b then (update(s,n,true)) else ()
532 :     | scan(b,CONty(tyc,args)) =
533 :     let val nb = (special tyc) orelse b
534 :     in app (fn t => scan(nb,t)) args
535 :     end
536 :     | scan(b,VARty(ref(INSTANTIATED ty))) = scan(b,ty)
537 :     | scan _ = ()
538 :    
539 :     val _ = scan(false,ty)
540 :    
541 :     in fn i => (Array.sub(s,i) handle General.Subscript =>
542 :     bug "Strange things in TypesUtil.getRecTyvarMap")
543 :     end
544 :    
545 :     fun gtLabel(a,b) =
546 :     let val a' = Symbol.name a and b' = Symbol.name b
547 :     val a0 = String.sub(a',0) and b0 = String.sub(b',0)
548 :     in if Char.isDigit a0
549 :     then if Char.isDigit b0
550 :     then (size a' > size b' orelse size a' = size b' andalso a' > b')
551 :     else false
552 :     else if Char.isDigit b0
553 :     then true
554 :     else (a' > b')
555 :     end
556 :    
557 :     (* Tests used to implement the value restriction *)
558 :     (* Based on Ken Cline's version; allows refutable patterns *)
559 :     (* Modified to support CAST, and special binding CASEexp. (ZHONG) *)
560 :     (* Modified to allow applications of lazy val rec Y combinators to
561 :     be nonexpansive. (Taha, DBM) *)
562 :     local open Absyn in
563 :    
564 :     fun isValue { ii_ispure } = let
565 :     fun isval (VARexp _) = true
566 :     | isval (CONexp _) = true
567 :     | isval (INTexp _) = true
568 :     | isval (WORDexp _) = true
569 :     | isval (REALexp _) = true
570 :     | isval (STRINGexp _) = true
571 :     | isval (CHARexp _) = true
572 :     | isval (FNexp _) = true
573 :     | isval (RECORDexp fields) =
574 :     foldr (fn ((_,exp),x) => x andalso (isval exp)) true fields
575 :     | isval (SELECTexp(_, e)) = isval e
576 :     | isval (VECTORexp (exps, _)) =
577 :     foldr (fn (exp,x) => x andalso (isval exp)) true exps
578 :     | isval (SEQexp nil) = true
579 :     | isval (SEQexp [e]) = isval e
580 :     | isval (SEQexp _) = false
581 :     | isval (APPexp(rator, rand)) =
582 :     let fun isrefdcon(DATACON{rep=A.REF,...}) = true
583 :     | isrefdcon _ = false
584 :     fun iscast (VALvar { info, ... }) = ii_ispure info
585 :     | iscast _ = false
586 :     (*
587 :     fun iscast(VALvar{info,...}) = II.pureInfo (II.fromExn info)
588 :     | iscast _ = false
589 :     *)
590 :    
591 :     (* LAZY: The following function allows applications of the
592 :     * fixed-point combinators generated for lazy val recs to
593 :     * be non-expansive. *)
594 :     fun issafe(VALvar{path=(SymPath.SPATH [s]),...}) =
595 :     (case String.explode (Symbol.name s)
596 :     of (#"Y" :: #"$" :: _) => true
597 :     | _ => false)
598 :     | issafe _ = false
599 :    
600 :     fun iscon (CONexp(dcon,_)) = not (isrefdcon dcon)
601 :     | iscon (MARKexp(e,_)) = iscon e
602 :     | iscon (VARexp(ref v, _)) = (iscast v) orelse (issafe v)
603 :     | iscon _ = false
604 :     in if iscon rator then isval rand
605 :     else false
606 :     end
607 :     | isval (CONSTRAINTexp(e,_)) = isval e
608 :     | isval (CASEexp(e, (RULE(p,_))::_, false)) =
609 :     (isval e) andalso (irref p) (* special bind CASEexps *)
610 :     | isval (LETexp(VALRECdec _, e)) = (isval e) (* special RVB hacks *)
611 :     | isval (MARKexp(e,_)) = isval e
612 :     | isval _ = false
613 :     in
614 :     isval
615 :     end
616 :    
617 :     (* testing if a binding pattern is irrefutable --- complete *)
618 :     and irref pp =
619 :     let fun udcon(DATACON{sign=A.CSIG(x,y),...}) = ((x+y) = 1)
620 :     | udcon _ = false
621 :    
622 :     fun g (CONpat(dc,_)) = udcon dc
623 :     | g (APPpat(dc,_,p)) = (udcon dc) andalso (g p)
624 :     | g (RECORDpat{fields=ps,...}) =
625 :     let fun h((_, p)::r) = if g p then h r else false
626 :     | h _ = true
627 :     in h ps
628 :     end
629 :     | g (CONSTRAINTpat(p, _)) = g p
630 :     | g (LAYEREDpat(p1,p2)) = (g p1) andalso (g p2)
631 :     | g (ORpat(p1,p2)) = (g p1) andalso (g p2)
632 :     | g (VECTORpat(ps,_)) =
633 :     let fun h (p::r) = if g p then h r else false
634 :     | h _ = true
635 :     in h ps
636 :     end
637 :     | g _ = true
638 :     in g pp
639 :     end
640 :     end (* local *)
641 :    
642 :     fun isVarTy(VARty(ref(INSTANTIATED ty))) = isVarTy ty
643 :     | isVarTy(VARty _) = true
644 :     | isVarTy(_) = false
645 :    
646 :    
647 :     (* sortFields, mapUnZip: two utility functions used in type checking
648 :     (typecheck.sml, mtderiv.sml, reconstruct.sml) *)
649 :    
650 :     fun sortFields fields =
651 :     ListMergeSort.sort (fn ((Absyn.LABEL{number=n1,...},_),
652 :     (Absyn.LABEL{number=n2,...},_)) => n1>n2)
653 :     fields
654 :    
655 :     fun mapUnZip f nil = (nil,nil)
656 :     | mapUnZip f (hd::tl) =
657 :     let val (x,y) = f(hd)
658 :     val (xl,yl) = mapUnZip f tl
659 :     in (x::xl,y::yl)
660 :     end
661 :    
662 :     fun foldTypeEntire f =
663 :     let fun foldTc (tyc, b0) =
664 :     case tyc
665 :     of GENtyc { kind, ... } =>
666 :     (case kind of
667 :     DATATYPE{family={members=ms,...},...} => b0
668 :     (* foldl (fn ({dcons, ...},b) => foldl foldDcons b dcons) b0 ms *)
669 :     | ABSTRACT tc => foldTc (tc, b0)
670 :     | _ => b0)
671 :     | DEFtyc{tyfun=TYFUN{arity,body}, ...} => foldTy(body, b0)
672 :     | _ => b0
673 :    
674 :     and foldDcons({name, rep, domain=NONE}, b0) = b0
675 :     | foldDcons({domain=SOME ty, ...}, b0) = foldTy(ty, b0)
676 :    
677 :     and foldTy (ty, b0) =
678 :     case ty
679 :     of CONty (tc, tl) =>
680 :     let val b1 = f(tc, b0)
681 :     val b2 = foldTc(tc, b1)
682 :     in foldl foldTy b2 tl
683 :     end
684 :     | POLYty {sign, tyfun=TYFUN{arity, body}} => foldTy(body, b0)
685 :     | VARty(ref(INSTANTIATED ty)) => foldTy(ty, b0)
686 :     | _ => b0
687 :     in foldTy
688 :     end
689 :    
690 :     fun mapTypeEntire f =
691 :     let fun mapTy ty =
692 :     case ty
693 :     of CONty (tc, tl) =>
694 :     mkCONty(f(mapTc, tc), map mapTy tl)
695 :     | POLYty {sign, tyfun=TYFUN{arity, body}} =>
696 :     POLYty{sign=sign, tyfun=TYFUN{arity=arity,body=mapTy body}}
697 :     | VARty(ref(INSTANTIATED ty)) => mapTy ty
698 :     | _ => ty
699 :    
700 :     and mapTc tyc =
701 :     case tyc
702 :     of GENtyc { stamp, arity, eq, path, kind, stub = _ } =>
703 :     (case kind of
704 :     DATATYPE{index,family={members,...},...} => tyc
705 :     (*
706 :     * The following code needs to be rewritten !!! (ZHONG)
707 :    
708 :     GENtyc{stamp=stamp, arity=arity, eq=eq, path=path,
709 :     kind=DATATYPE {index=index, members=map mapMb members,
710 :     lambdatyc = ref NONE}}
711 :     *)
712 :     | ABSTRACT tc =>
713 :     GENtyc {stamp=stamp, arity=arity, eq=eq, path=path,
714 :     kind= ABSTRACT (mapTc tc),
715 :     stub = NONE}
716 :     | _ => tyc)
717 :     | DEFtyc{stamp, strict, tyfun, path} =>
718 :     DEFtyc{stamp=stamp, strict=strict, tyfun=mapTf tyfun,
719 :     path=path}
720 :     | _ => tyc
721 :    
722 :     and mapMb {tycname, stamp, arity, dcons, lambdatyc} =
723 :     {tycname=tycname, stamp=stamp, arity=arity,
724 :     dcons=(map mapDcons dcons), lambdatyc=ref NONE}
725 :    
726 :     and mapDcons (x as {name, rep, domain=NONE}) = x
727 :     | mapDcons (x as {name, rep, domain=SOME ty}) =
728 :     {name=name, rep=rep, domain=SOME(mapTy ty)}
729 :    
730 :     and mapTf (TYFUN{arity, body}) =
731 :     TYFUN{arity=arity, body=mapTy body}
732 :    
733 :     in mapTy
734 :     end
735 :    
736 :    
737 :     (*
738 :     * Here, using a set implementation should suffice, however,
739 :     * I am using a binary dictionary instead. (ZHONG)
740 :     *)
741 :     local
742 :     structure TycSet = StampMap
743 :     in
744 :     type tycset = tycon TycSet.map
745 :    
746 :     val mkTycSet = fn () => TycSet.empty
747 :    
748 :     fun addTycSet(tyc as GENtyc { stamp, ... }, tycset) =
749 :     TycSet.insert (tycset, stamp, tyc)
750 :     | addTycSet _ = bug "unexpected tycons in addTycSet"
751 :    
752 :     fun inTycSet(tyc as GENtyc { stamp, ... }, tycset) =
753 :     isSome (TycSet.find(tycset, stamp))
754 :     | inTycSet _ = false
755 :    
756 :     fun filterSet(ty, tycs) =
757 :     let fun inList (a::r, tc) = if eqTycon(a, tc) then true else inList(r, tc)
758 :     | inList ([], tc) = false
759 :    
760 :     fun pass1 (tc, tset) =
761 :     if inTycSet(tc, tycs) then
762 :     (if inList(tset, tc) then tset else tc::tset)
763 :     else tset
764 :     in foldTypeEntire pass1 (ty, [])
765 :     end
766 :     (*
767 :     val filterSet = fn x =>
768 :     Stats.doPhase(Stats.makePhase "Compiler 034 filterSet") filterSet x
769 :     *)
770 :    
771 :     end (* local TycSet *)
772 :    
773 :     (*
774 :     (* The reformat function is called inside translate.sml to reformat
775 :     * a type abstraction packing inside PACKexp absyn. It is a hack. (ZHONG)
776 :     *)
777 :     fun reformat { tp_var, tp_tyc } (ty, tycs, depth) =
778 :     let fun h ([], i, ks, ps, nts) = (rev ks, rev ps, rev nts)
779 :     | h (tc :: rest, i, ks, ps, nts) = let
780 :     fun noabs () = bug "non-abstract tycons seen in TU.reformat"
781 :     in
782 :     case tc
783 :     of GENtyc { stamp, arity, eq, path, kind, stub } =>
784 :     (case kind of
785 :     ABSTRACT itc => let
786 :     val tk = LT.tkc_int arity
787 :     (*
788 :     val tps = TP_VAR (TVI.toExn
789 :     {depth=depth, num=i, kind=tk})
790 :     *)
791 :     val tps = tp_var { depth=depth, num=i, kind=tk}
792 :     val nkind = FLEXTYC tps
793 :     val ntc =
794 :     GENtyc { stamp = stamp, arity = arity,
795 :     eq = eq, kind = nkind, path = path,
796 :     stub = NONE}
797 :     in
798 :     h (rest, i+1, tk::ks, (tp_tyc itc)::ps, ntc::nts)
799 :     end
800 :     | _ => noabs ())
801 :     | _ => noabs ()
802 :     end
803 :    
804 :     val (tks, tps, ntycs) = h(tycs, 0, [], [], [])
805 :    
806 :     fun getTyc (foo, tc) =
807 :     let fun h(a::r, tc) = if eqTycon(a, tc) then a else h(r, tc)
808 :     | h([], tc) = foo tc
809 :     in h(ntycs, tc)
810 :     end
811 :    
812 :     val nty = mapTypeEntire getTyc ty
813 :    
814 :     in (nty, tks, tps)
815 :     end
816 :    
817 :     val reformat = Stats.doPhase(Stats.makePhase "Compiler 047 reformat") reformat
818 :     *)
819 :    
820 :     fun dtSibling(n,tyc as GENtyc { kind = DATATYPE dt, ... }) =
821 :     let val {index,stamps,freetycs,root, family as {members,...} } = dt
822 :     in
823 :     if n = index then tyc
824 :     else let val {tycname,arity,dcons,eq,lazyp,sign} =
825 :     Vector.sub(members,n)
826 :     val stamp= Vector.sub(stamps,n)
827 :     in
828 :     GENtyc {stamp=stamp,
829 :     arity=arity,eq=eq,path=IP.IPATH[tycname],
830 :     kind=DATATYPE{index=n,stamps=stamps,
831 :     freetycs=freetycs,
832 :     root=NONE (*!*),
833 :     family=family},
834 :     stub = NONE}
835 :     end
836 :     end
837 :     | dtSibling _ = bug "dtSibling"
838 :    
839 :     (* NOTE: this only works (perhaps) for datatype declarations, but not
840 :     specifications. The reason: the root field is used to connect mutually
841 :     recursive datatype specifications together, its information cannot be
842 :     fully recovered in dtSibling. (ZHONG)
843 :     *)
844 :     fun extractDcons (tyc as GENtyc { kind = DATATYPE dt, ... }) =
845 :     let val {index,stamps,freetycs,root,family as {members,...}} = dt
846 :     val {dcons,sign,lazyp,...} = Vector.sub(members,index)
847 :     fun expandTyc(PATHtyc _) =
848 :     bug "expandTyc:PATHtyc" (* use expandTycon? *)
849 :     | expandTyc(RECtyc n) = dtSibling(n,tyc)
850 :     | expandTyc(FREEtyc n) =
851 :     ((List.nth(freetycs,n))
852 :     handle _ => bug "unexpected freetycs in extractDcons")
853 :     | expandTyc tyc = tyc
854 :    
855 :     fun expand ty = mapTypeFull expandTyc ty
856 :    
857 :     fun mkDcon({name,rep,domain}) =
858 :     DATACON{name = name, rep = rep, sign = sign, lazyp = lazyp,
859 :     typ = dconType (tyc, Option.map expand domain),
860 :     const = case domain of NONE => true | _ => false}
861 :    
862 :     in map mkDcon dcons
863 :     end
864 :     | extractDcons _ = bug "extractDcons"
865 :    
866 :     fun mkStrict 0 = []
867 :     | mkStrict n = true :: mkStrict(n-1)
868 :    
869 :     (* used in ElabSig for datatype replication specs, where the tyc arg
870 :     * is expected to be either a GENtyc/DATATYPE or a PATHtyc. *)
871 :     fun wrapDef(tyc as DEFtyc _,_) = tyc
872 :     | wrapDef(tyc,s) =
873 :     let val arity = tyconArity tyc
874 :     val name = tycName tyc
875 :     val args = boundargs arity
876 :     in DEFtyc{stamp=s,strict=mkStrict arity,path=IP.IPATH[name],
877 :     tyfun=TYFUN{arity=arity,body=CONty(tyc,args)}}
878 :     end
879 :    
880 :     (* eta-reduce a type function: \args.tc args => tc *)
881 :     fun unWrapDef1(tyc as DEFtyc{tyfun=TYFUN{body=CONty(tyc',args),arity},...}) =
882 :     let fun formals((IBOUND i)::rest,j) = if i=j then formals(rest,j+1) else false
883 :     | formals(nil,_) = true
884 :     | formals _ = false
885 :     in if formals(args,0) then SOME tyc' else NONE
886 :     end
887 :     | unWrapDef1 tyc = NONE
888 :    
889 :     (* closure under iterated eta-reduction *)
890 :     fun unWrapDefStar tyc =
891 :     (case unWrapDef1 tyc
892 :     of SOME tyc' => unWrapDefStar tyc'
893 :     | NONE => tyc)
894 :    
895 :     fun dummyTyGen () : unit -> Types.ty =
896 :     let val count = ref 0
897 :     fun next () = (count := !count + 1; !count)
898 :     fun nextTy () =
899 :     let val name = "X"^Int.toString(next())
900 :     in CONty(GENtyc{stamp = ST.special name,
901 :     path = IP.IPATH[S.tycSymbol name],
902 :     arity = 0, eq = ref NO,
903 :     kind = ABSTRACT BT.boolTycon,
904 :     stub = NONE},
905 :     [])
906 :     end
907 :     in nextTy
908 :     end
909 :    
910 :     end (* local *)
911 :     end (* structure TypesUtil *)

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