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/trunk/src/compiler/Semant/types/typesutil.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/Semant/types/typesutil.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 126 - (view) (download)

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

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