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 1939 - (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 :     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 : macqueen 1938 (* compType, compareTypes used to compare specification type with type of
461 :     * corresponding actual element. Check that spec type is an instance of
462 :     * the actual type *)
463 : blume 903 exception CompareTypes
464 :     fun compType(specty, specsign:polysign, actty,
465 :     actsign:polysign, actarity): unit =
466 : macqueen 1938 let val env = array(actarity,UNDEFty) (* instantiations of IBOUNDs in actual body *)
467 : blume 903 fun comp'(WILDCARDty, _) = ()
468 :     | comp'(_, WILDCARDty) = ()
469 :     | comp'(ty1, IBOUND i) =
470 :     (case env sub i
471 :     of UNDEFty =>
472 :     (let val eq = List.nth(actsign,i)
473 :     in if eq andalso not(checkEqTySig(ty1,specsign))
474 :     then raise CompareTypes
475 :     else ();
476 :     update(env,i,ty1)
477 :     end handle Subscript => ())
478 :     | ty => if equalType(ty1,ty)
479 :     then ()
480 :     else raise CompareTypes)
481 :     | comp'(CONty(tycon1, args1), CONty(tycon2, args2)) =
482 :     if eqTycon(tycon1,tycon2)
483 :     then ListPair.app comp (args1,args2)
484 :     else raise CompareTypes
485 :     | comp' _ = raise CompareTypes
486 :     and comp(ty1,ty2) = comp'(headReduceType ty1, headReduceType ty2)
487 :     in comp(specty,actty)
488 :     end
489 :    
490 : macqueen 1938 (* returns true if actual type > spec type, i.e. if spec is an instance of actual *)
491 : blume 903 fun compareTypes (spec : ty, actual: ty): bool =
492 :     let val actual = prune actual
493 :     in case spec
494 :     of POLYty{sign,tyfun=TYFUN{body,...}} =>
495 :     (case actual
496 :     of POLYty{sign=sign',tyfun=TYFUN{arity,body=body'}} =>
497 :     (compType(body,sign,body',sign',arity); true)
498 :     | WILDCARDty => true
499 :     | _ => false)
500 :     | WILDCARDty => true
501 :     | _ =>
502 :     (case actual
503 :     of POLYty{sign,tyfun=TYFUN{arity,body}} =>
504 :     (compType(spec,[],body,sign,arity); true)
505 :     | WILDCARDty => true
506 :     | _ => equalType(spec,actual))
507 :     end handle CompareTypes => false
508 :    
509 :     (* given a single-type-variable type, extract out the tyvar *)
510 :     fun tyvarType (VARty (tv as ref(OPEN _))) = tv
511 :     | tyvarType (VARty (tv as ref(INSTANTIATED t))) = tyvarType t
512 :     | tyvarType WILDCARDty = ref(mkMETA infinity) (* fake a tyvar *)
513 :     | tyvarType (IBOUND i) = bug "tyvarType: IBOUND"
514 :     | tyvarType (CONty(_,_)) = bug "tyvarType: CONty"
515 :     | tyvarType (POLYty _) = bug "tyvarType: POLYty"
516 :     | tyvarType UNDEFty = bug "tyvarType: UNDEFty"
517 : macqueen 1938 | tyvarType _ = bug "tyvarType - unexpected argument"
518 : blume 903
519 :     (*
520 :     * getRecTyvarMap : int * ty -> (int -> bool)
521 :     * see if a bound tyvar has occurred in some datatypes, e.g. 'a list.
522 :     * this is useful for representation analysis. This function probably
523 :     * will soon be obsolete.
524 :     *)
525 :     fun getRecTyvarMap (n,ty) =
526 :     let val s = Array.array(n,false)
527 :     fun notArrow tyc = not (eqTycon (tyc, BT.arrowTycon))
528 :     (* orelse eqTycon(tyc,contTycon) *)
529 :     fun special (tyc as GENtyc { arity, ... }) =
530 :     arity <> 0 andalso notArrow tyc
531 :     | special(RECORDtyc _) = false
532 :     | special tyc = notArrow tyc
533 :    
534 :     fun scan(b,(IBOUND n)) = if b then (update(s,n,true)) else ()
535 :     | scan(b,CONty(tyc,args)) =
536 :     let val nb = (special tyc) orelse b
537 :     in app (fn t => scan(nb,t)) args
538 :     end
539 :     | scan(b,VARty(ref(INSTANTIATED ty))) = scan(b,ty)
540 :     | scan _ = ()
541 :    
542 :     val _ = scan(false,ty)
543 :    
544 :     in fn i => (Array.sub(s,i) handle General.Subscript =>
545 :     bug "Strange things in TypesUtil.getRecTyvarMap")
546 :     end
547 :    
548 :     fun gtLabel(a,b) =
549 :     let val a' = Symbol.name a and b' = Symbol.name b
550 :     val a0 = String.sub(a',0) and b0 = String.sub(b',0)
551 :     in if Char.isDigit a0
552 :     then if Char.isDigit b0
553 :     then (size a' > size b' orelse size a' = size b' andalso a' > b')
554 :     else false
555 :     else if Char.isDigit b0
556 :     then true
557 :     else (a' > b')
558 :     end
559 :    
560 :     (* Tests used to implement the value restriction *)
561 :     (* Based on Ken Cline's version; allows refutable patterns *)
562 :     (* Modified to support CAST, and special binding CASEexp. (ZHONG) *)
563 :     (* Modified to allow applications of lazy val rec Y combinators to
564 :     be nonexpansive. (Taha, DBM) *)
565 :     local open Absyn in
566 :    
567 : macqueen 1938 fun isValue (VARexp _) = true
568 :     | isValue (CONexp _) = true
569 :     | isValue (INTexp _) = true
570 :     | isValue (WORDexp _) = true
571 :     | isValue (REALexp _) = true
572 :     | isValue (STRINGexp _) = true
573 :     | isValue (CHARexp _) = true
574 :     | isValue (FNexp _) = true
575 :     | isValue (RECORDexp fields) =
576 :     foldr (fn ((_,exp),x) => x andalso (isValue exp)) true fields
577 :     | isValue (SELECTexp(_, e)) = isValue e
578 :     | isValue (VECTORexp (exps, _)) =
579 :     foldr (fn (exp,x) => x andalso (isValue exp)) true exps
580 :     | isValue (SEQexp nil) = true
581 :     | isValue (SEQexp [e]) = isValue e
582 :     | isValue (SEQexp _) = false
583 :     | isValue (APPexp(rator, rand)) =
584 :     let fun isrefdcon(DATACON{rep=A.REF,...}) = true
585 :     | isrefdcon _ = false
586 : macqueen 1939
587 :     fun iscast (VALvar { info, ... }) = InlInfo.isPrimCast info
588 : macqueen 1938 | iscast _ = false
589 : blume 903
590 : macqueen 1938 (* LAZY: The following function allows applications of the
591 :     * fixed-point combinators generated for lazy val recs to
592 :     * be non-expansive. *)
593 :     fun issafe(VALvar{path=(SymPath.SPATH [s]),...}) =
594 :     (case String.explode (Symbol.name s)
595 :     of (#"Y" :: #"$" :: _) => true
596 :     | _ => false)
597 :     | issafe _ = false
598 : blume 903
599 : macqueen 1938 fun iscon (CONexp(dcon,_)) = not (isrefdcon dcon)
600 :     | iscon (MARKexp(e,_)) = iscon e
601 :     | iscon (VARexp(ref v, _)) = (iscast v) orelse (issafe v)
602 :     | iscon _ = false
603 :     in if iscon rator then isValue rand
604 :     else false
605 :     end
606 :     | isValue (CONSTRAINTexp(e,_)) = isValue e
607 :     | isValue (CASEexp(e, (RULE(p,_))::_, false)) =
608 :     (isValue e) andalso (irref p) (* special bind CASEexps *)
609 :     | isValue (LETexp(VALRECdec _, e)) = (isValue e) (* special RVB hacks *)
610 :     | isValue (MARKexp(e,_)) = isValue e
611 :     | isValue _ = false
612 : blume 903
613 :     (* testing if a binding pattern is irrefutable --- complete *)
614 :     and irref pp =
615 :     let fun udcon(DATACON{sign=A.CSIG(x,y),...}) = ((x+y) = 1)
616 :     | udcon _ = false
617 :    
618 :     fun g (CONpat(dc,_)) = udcon dc
619 :     | g (APPpat(dc,_,p)) = (udcon dc) andalso (g p)
620 :     | g (RECORDpat{fields=ps,...}) =
621 :     let fun h((_, p)::r) = if g p then h r else false
622 :     | h _ = true
623 :     in h ps
624 :     end
625 :     | g (CONSTRAINTpat(p, _)) = g p
626 :     | g (LAYEREDpat(p1,p2)) = (g p1) andalso (g p2)
627 :     | g (ORpat(p1,p2)) = (g p1) andalso (g p2)
628 :     | g (VECTORpat(ps,_)) =
629 :     let fun h (p::r) = if g p then h r else false
630 :     | h _ = true
631 :     in h ps
632 :     end
633 :     | g _ = true
634 :     in g pp
635 :     end
636 :     end (* local *)
637 :    
638 :     fun isVarTy(VARty(ref(INSTANTIATED ty))) = isVarTy ty
639 :     | isVarTy(VARty _) = true
640 :     | isVarTy(_) = false
641 :    
642 :    
643 :     (* sortFields, mapUnZip: two utility functions used in type checking
644 :     (typecheck.sml, mtderiv.sml, reconstruct.sml) *)
645 :    
646 :     fun sortFields fields =
647 :     ListMergeSort.sort (fn ((Absyn.LABEL{number=n1,...},_),
648 :     (Absyn.LABEL{number=n2,...},_)) => n1>n2)
649 :     fields
650 :    
651 :     fun mapUnZip f nil = (nil,nil)
652 :     | mapUnZip f (hd::tl) =
653 :     let val (x,y) = f(hd)
654 :     val (xl,yl) = mapUnZip f tl
655 :     in (x::xl,y::yl)
656 :     end
657 :    
658 :     fun foldTypeEntire f =
659 :     let fun foldTc (tyc, b0) =
660 :     case tyc
661 :     of GENtyc { kind, ... } =>
662 :     (case kind of
663 :     DATATYPE{family={members=ms,...},...} => b0
664 :     (* foldl (fn ({dcons, ...},b) => foldl foldDcons b dcons) b0 ms *)
665 :     | ABSTRACT tc => foldTc (tc, b0)
666 :     | _ => b0)
667 :     | DEFtyc{tyfun=TYFUN{arity,body}, ...} => foldTy(body, b0)
668 :     | _ => b0
669 :    
670 :     and foldDcons({name, rep, domain=NONE}, b0) = b0
671 :     | foldDcons({domain=SOME ty, ...}, b0) = foldTy(ty, b0)
672 :    
673 :     and foldTy (ty, b0) =
674 :     case ty
675 :     of CONty (tc, tl) =>
676 :     let val b1 = f(tc, b0)
677 :     val b2 = foldTc(tc, b1)
678 :     in foldl foldTy b2 tl
679 :     end
680 :     | POLYty {sign, tyfun=TYFUN{arity, body}} => foldTy(body, b0)
681 :     | VARty(ref(INSTANTIATED ty)) => foldTy(ty, b0)
682 :     | _ => b0
683 :     in foldTy
684 :     end
685 :    
686 :     fun mapTypeEntire f =
687 :     let fun mapTy ty =
688 :     case ty
689 :     of CONty (tc, tl) =>
690 :     mkCONty(f(mapTc, tc), map mapTy tl)
691 :     | POLYty {sign, tyfun=TYFUN{arity, body}} =>
692 :     POLYty{sign=sign, tyfun=TYFUN{arity=arity,body=mapTy body}}
693 :     | VARty(ref(INSTANTIATED ty)) => mapTy ty
694 :     | _ => ty
695 :    
696 :     and mapTc tyc =
697 :     case tyc
698 :     of GENtyc { stamp, arity, eq, path, kind, stub = _ } =>
699 :     (case kind of
700 :     DATATYPE{index,family={members,...},...} => tyc
701 :     (*
702 :     * The following code needs to be rewritten !!! (ZHONG)
703 :    
704 :     GENtyc{stamp=stamp, arity=arity, eq=eq, path=path,
705 :     kind=DATATYPE {index=index, members=map mapMb members,
706 :     lambdatyc = ref NONE}}
707 :     *)
708 :     | ABSTRACT tc =>
709 :     GENtyc {stamp=stamp, arity=arity, eq=eq, path=path,
710 :     kind= ABSTRACT (mapTc tc),
711 :     stub = NONE}
712 :     | _ => tyc)
713 :     | DEFtyc{stamp, strict, tyfun, path} =>
714 :     DEFtyc{stamp=stamp, strict=strict, tyfun=mapTf tyfun,
715 :     path=path}
716 :     | _ => tyc
717 :    
718 :     and mapMb {tycname, stamp, arity, dcons, lambdatyc} =
719 :     {tycname=tycname, stamp=stamp, arity=arity,
720 :     dcons=(map mapDcons dcons), lambdatyc=ref NONE}
721 :    
722 :     and mapDcons (x as {name, rep, domain=NONE}) = x
723 :     | mapDcons (x as {name, rep, domain=SOME ty}) =
724 :     {name=name, rep=rep, domain=SOME(mapTy ty)}
725 :    
726 :     and mapTf (TYFUN{arity, body}) =
727 :     TYFUN{arity=arity, body=mapTy body}
728 :    
729 :     in mapTy
730 :     end
731 :    
732 :    
733 :     (*
734 :     * Here, using a set implementation should suffice, however,
735 :     * I am using a binary dictionary instead. (ZHONG)
736 :     *)
737 :     local
738 :     structure TycSet = StampMap
739 :     in
740 :     type tycset = tycon TycSet.map
741 :    
742 :     val mkTycSet = fn () => TycSet.empty
743 :    
744 :     fun addTycSet(tyc as GENtyc { stamp, ... }, tycset) =
745 :     TycSet.insert (tycset, stamp, tyc)
746 :     | addTycSet _ = bug "unexpected tycons in addTycSet"
747 :    
748 :     fun inTycSet(tyc as GENtyc { stamp, ... }, tycset) =
749 :     isSome (TycSet.find(tycset, stamp))
750 :     | inTycSet _ = false
751 :    
752 :     fun filterSet(ty, tycs) =
753 :     let fun inList (a::r, tc) = if eqTycon(a, tc) then true else inList(r, tc)
754 :     | inList ([], tc) = false
755 :    
756 :     fun pass1 (tc, tset) =
757 :     if inTycSet(tc, tycs) then
758 :     (if inList(tset, tc) then tset else tc::tset)
759 :     else tset
760 :     in foldTypeEntire pass1 (ty, [])
761 :     end
762 :     (*
763 :     val filterSet = fn x =>
764 :     Stats.doPhase(Stats.makePhase "Compiler 034 filterSet") filterSet x
765 :     *)
766 :    
767 :     end (* local TycSet *)
768 :    
769 :     (*
770 :     (* The reformat function is called inside translate.sml to reformat
771 :     * a type abstraction packing inside PACKexp absyn. It is a hack. (ZHONG)
772 :     *)
773 :     fun reformat { tp_var, tp_tyc } (ty, tycs, depth) =
774 :     let fun h ([], i, ks, ps, nts) = (rev ks, rev ps, rev nts)
775 :     | h (tc :: rest, i, ks, ps, nts) = let
776 :     fun noabs () = bug "non-abstract tycons seen in TU.reformat"
777 :     in
778 :     case tc
779 :     of GENtyc { stamp, arity, eq, path, kind, stub } =>
780 :     (case kind of
781 :     ABSTRACT itc => let
782 :     val tk = LT.tkc_int arity
783 :     (*
784 :     val tps = TP_VAR (TVI.toExn
785 :     {depth=depth, num=i, kind=tk})
786 :     *)
787 :     val tps = tp_var { depth=depth, num=i, kind=tk}
788 :     val nkind = FLEXTYC tps
789 :     val ntc =
790 :     GENtyc { stamp = stamp, arity = arity,
791 :     eq = eq, kind = nkind, path = path,
792 :     stub = NONE}
793 :     in
794 :     h (rest, i+1, tk::ks, (tp_tyc itc)::ps, ntc::nts)
795 :     end
796 :     | _ => noabs ())
797 :     | _ => noabs ()
798 :     end
799 :    
800 :     val (tks, tps, ntycs) = h(tycs, 0, [], [], [])
801 :    
802 :     fun getTyc (foo, tc) =
803 :     let fun h(a::r, tc) = if eqTycon(a, tc) then a else h(r, tc)
804 :     | h([], tc) = foo tc
805 :     in h(ntycs, tc)
806 :     end
807 :    
808 :     val nty = mapTypeEntire getTyc ty
809 :    
810 :     in (nty, tks, tps)
811 :     end
812 :    
813 :     val reformat = Stats.doPhase(Stats.makePhase "Compiler 047 reformat") reformat
814 :     *)
815 :    
816 :     fun dtSibling(n,tyc as GENtyc { kind = DATATYPE dt, ... }) =
817 :     let val {index,stamps,freetycs,root, family as {members,...} } = dt
818 :     in
819 :     if n = index then tyc
820 :     else let val {tycname,arity,dcons,eq,lazyp,sign} =
821 :     Vector.sub(members,n)
822 :     val stamp= Vector.sub(stamps,n)
823 :     in
824 :     GENtyc {stamp=stamp,
825 :     arity=arity,eq=eq,path=IP.IPATH[tycname],
826 :     kind=DATATYPE{index=n,stamps=stamps,
827 :     freetycs=freetycs,
828 :     root=NONE (*!*),
829 :     family=family},
830 :     stub = NONE}
831 :     end
832 :     end
833 :     | dtSibling _ = bug "dtSibling"
834 :    
835 :     (* NOTE: this only works (perhaps) for datatype declarations, but not
836 :     specifications. The reason: the root field is used to connect mutually
837 :     recursive datatype specifications together, its information cannot be
838 :     fully recovered in dtSibling. (ZHONG)
839 :     *)
840 :     fun extractDcons (tyc as GENtyc { kind = DATATYPE dt, ... }) =
841 :     let val {index,stamps,freetycs,root,family as {members,...}} = dt
842 :     val {dcons,sign,lazyp,...} = Vector.sub(members,index)
843 :     fun expandTyc(PATHtyc _) =
844 :     bug "expandTyc:PATHtyc" (* use expandTycon? *)
845 :     | expandTyc(RECtyc n) = dtSibling(n,tyc)
846 :     | expandTyc(FREEtyc n) =
847 :     ((List.nth(freetycs,n))
848 :     handle _ => bug "unexpected freetycs in extractDcons")
849 :     | expandTyc tyc = tyc
850 :    
851 :     fun expand ty = mapTypeFull expandTyc ty
852 :    
853 :     fun mkDcon({name,rep,domain}) =
854 :     DATACON{name = name, rep = rep, sign = sign, lazyp = lazyp,
855 :     typ = dconType (tyc, Option.map expand domain),
856 :     const = case domain of NONE => true | _ => false}
857 :    
858 :     in map mkDcon dcons
859 :     end
860 :     | extractDcons _ = bug "extractDcons"
861 :    
862 :     fun mkStrict 0 = []
863 :     | mkStrict n = true :: mkStrict(n-1)
864 :    
865 :     (* used in ElabSig for datatype replication specs, where the tyc arg
866 :     * is expected to be either a GENtyc/DATATYPE or a PATHtyc. *)
867 :     fun wrapDef(tyc as DEFtyc _,_) = tyc
868 :     | wrapDef(tyc,s) =
869 :     let val arity = tyconArity tyc
870 :     val name = tycName tyc
871 :     val args = boundargs arity
872 :     in DEFtyc{stamp=s,strict=mkStrict arity,path=IP.IPATH[name],
873 :     tyfun=TYFUN{arity=arity,body=CONty(tyc,args)}}
874 :     end
875 :    
876 :     (* eta-reduce a type function: \args.tc args => tc *)
877 :     fun unWrapDef1(tyc as DEFtyc{tyfun=TYFUN{body=CONty(tyc',args),arity},...}) =
878 :     let fun formals((IBOUND i)::rest,j) = if i=j then formals(rest,j+1) else false
879 :     | formals(nil,_) = true
880 :     | formals _ = false
881 :     in if formals(args,0) then SOME tyc' else NONE
882 :     end
883 :     | unWrapDef1 tyc = NONE
884 :    
885 :     (* closure under iterated eta-reduction *)
886 :     fun unWrapDefStar tyc =
887 :     (case unWrapDef1 tyc
888 :     of SOME tyc' => unWrapDefStar tyc'
889 :     | NONE => tyc)
890 :    
891 :     fun dummyTyGen () : unit -> Types.ty =
892 :     let val count = ref 0
893 :     fun next () = (count := !count + 1; !count)
894 :     fun nextTy () =
895 :     let val name = "X"^Int.toString(next())
896 :     in CONty(GENtyc{stamp = ST.special name,
897 :     path = IP.IPATH[S.tycSymbol name],
898 :     arity = 0, eq = ref NO,
899 :     kind = ABSTRACT BT.boolTycon,
900 :     stub = NONE},
901 :     [])
902 :     end
903 :     in nextTy
904 :     end
905 :    
906 :     end (* local *)
907 :     end (* structure TypesUtil *)

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