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/FLINT/trans/pequal.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/FLINT/trans/pequal.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 93 - (view) (download)
Original Path: sml/branches/SMLNJ/src/compiler/FLINT/trans/pequal.sml

1 : monnier 16 (* COPYRIGHT (c) 1996 Bell Laboratories *)
2 :     (* pequal.sml *)
3 :    
4 :     signature PEQUAL =
5 :     sig
6 : monnier 45 type toTcLt = (Types.ty -> PLambdaType.tyc) * (Types.ty -> PLambdaType.lty)
7 : monnier 16 (*
8 :     * Constructing generic equality functions; the current version will
9 :     * use runtime polyequal function to deal with abstract types. (ZHONG)
10 :     *)
11 :     val equal : {getStrEq : unit -> PLambda.lexp,
12 :     getPolyEq : unit -> PLambda.lexp} * StaticEnv.staticEnv
13 : monnier 45 -> (Types.ty * Types.ty * toTcLt) -> PLambda.lexp
14 : monnier 16
15 :     val debugging : bool ref
16 :    
17 :     end (* signature PEQUAL *)
18 :    
19 :    
20 :     structure PEqual : PEQUAL =
21 :     struct
22 :    
23 :     local structure DA = Access
24 :     structure EM = ErrorMsg
25 :     structure T = Types
26 :     structure BT = BasicTypes
27 :     structure LT = PLambdaType
28 :     structure TU = TypesUtil
29 :     structure SE = StaticEnv
30 :     structure PO = PrimOp
31 :     structure PP = PrettyPrint
32 :     open Types PLambda
33 :    
34 :     in
35 :    
36 :     val debugging = ref false
37 :     fun bug msg = ErrorMsg.impossible("Equal: "^msg)
38 :     val say = Control.Print.say
39 :    
40 : monnier 45 type toTcLt = (ty -> LT.tyc) * (ty -> LT.lty)
41 :    
42 : monnier 16 val --> = BT.-->
43 :     infix -->
44 :    
45 :     (*
46 :     * MAJOR CLEANUP REQUIRED ! The function mkv is currently directly taken
47 :     * from the LambdaVar module; I think it should be taken from the
48 :     * "compInfo". Similarly, should we replace all mkLvar in the backend
49 :     * with the mkv in "compInfo" ? (ZHONG)
50 :     *)
51 :     val mkv = LambdaVar.mkLvar
52 :    
53 :     (** translating the typ field in DATACON into lty; constant datacons
54 :     will take ltc_unit as the argument *)
55 : monnier 45 fun toDconLty (toTyc, toLty) ty =
56 : monnier 16 (case ty
57 :     of POLYty{sign, tyfun=TYFUN{arity, body}} =>
58 : monnier 45 if BT.isArrowType body then toLty ty
59 :     else toLty (POLYty{sign=sign,
60 :     tyfun=TYFUN{arity=arity,
61 :     body=BT.-->(BT.unitTy, body)}})
62 :     | _ => if BT.isArrowType ty then toLty ty
63 :     else toLty (BT.-->(BT.unitTy, ty)))
64 : monnier 16
65 :     (*
66 :     * Is TU.dconType necessary, or could a variant of transTyLty that
67 :     * just takes tyc and domain be used in transDcon???
68 :     *)
69 : monnier 45 fun transDcon(tyc, {name,rep,domain}, toTcLt) =
70 :     (name, rep, toDconLty toTcLt (TU.dconType(tyc,domain)))
71 : monnier 16
72 :     val (trueDcon', falseDcon') =
73 :     let val lt = LT.ltc_parrow(LT.ltc_unit, LT.ltc_bool)
74 :     fun h (DATACON{name, rep, ...}) = (name, rep, lt)
75 :     in (h BT.trueDcon, h BT.falseDcon)
76 :     end
77 :    
78 :     fun COND(a,b,c) =
79 :     SWITCH(a, BT.boolsign, [(DATAcon(trueDcon', [], mkv()),b),
80 :     (DATAcon(falseDcon', [], mkv()),c)], NONE)
81 :    
82 :     val (trueLexp, falseLexp) =
83 :     let val unitLexp = RECORD []
84 :     in (CON (trueDcon', [], unitLexp), CON (falseDcon', [], unitLexp))
85 :     end
86 :    
87 :     fun argType(domain, []) = domain
88 :     | argType(domain, args) =
89 :     TU.applyTyfun(TYFUN{arity=length args,body=domain},args)
90 :    
91 :     fun reduceTy ty =
92 :     (case TU.headReduceType ty
93 :     of POLYty{tyfun=TYFUN{body,...},...} => reduceTy body
94 :     | ty => ty)
95 :    
96 :     fun expandREC (family as {members: T.dtmember vector, ...}, stamps, freetycs) =
97 :     let fun g (RECtyc i) =
98 :     let val {tycname,dcons,arity,eq,sign} =
99 :     Vector.sub(members,i)
100 :     val s = Vector.sub(stamps, i)
101 :     in GENtyc{stamp=s,arity=arity,eq=ref(YES),
102 :     kind=DATATYPE{index=i, family=family,root=NONE,
103 :     stamps=stamps, freetycs=freetycs},
104 :     path=InvPath.IPATH[tycname]}
105 :     end
106 :     | g (FREEtyc i) = List.nth(freetycs, i)
107 :     | g x = x
108 :     fun f(CONty(tyc,tyl)) = CONty(g tyc, map f tyl)
109 :     | f(x as IBOUND _) = x
110 :     | f _ = bug "unexpected type in expandREC"
111 :     in f
112 :     end
113 :    
114 :     exception Poly
115 :    
116 :     fun equivType(ty,ty') =
117 :     let fun eq(ty as CONty(tycon, args), ty' as CONty(tycon', args')) =
118 :     (if TU.eqTycon(tycon, tycon')
119 :     then ListPair.all equivType (args,args')
120 :     else (equivType(TU.reduceType ty, ty')
121 :     handle ReduceType =>
122 :     (equivType(ty,TU.reduceType ty')
123 :     handle ReduceType => false)))
124 :     | eq(VARty _, _) = raise Poly
125 :     | eq(_, VARty _) = raise Poly
126 :     | eq(POLYty _, _) = raise Poly
127 :     | eq(_, POLYty _) = raise Poly
128 :     | eq _ = false
129 :     in eq(TU.prune ty, TU.prune ty')
130 :     end
131 :    
132 :     (****************************************************************************
133 :     * Commonly-used Lambda Types *
134 :     ****************************************************************************)
135 :    
136 :     val boolty = LT.ltc_bool
137 :     fun eqLty lt = LT.ltc_parrow(LT.ltc_tuple [lt, lt], boolty)
138 :     val inteqty = eqLty (LT.ltc_int)
139 :     val int32eqty = eqLty (LT.ltc_int32)
140 :     val booleqty = eqLty (LT.ltc_bool)
141 :     val realeqty = eqLty (LT.ltc_real)
142 :    
143 :     exception Notfound
144 :    
145 :     (****************************************************************************
146 :     * equal --- the equality function generator *
147 :     ****************************************************************************)
148 :     fun equal ({getStrEq, getPolyEq}, env)
149 : monnier 45 (polyEqTy : ty, concreteType : ty, toTcLc as (toTyc, toLty)) =
150 : monnier 16 let
151 :    
152 :     val cache : (ty * lexp * lexp ref) list ref = ref nil
153 :    
154 :     fun enter ty =
155 :     let val v = VAR(mkv())
156 :     val r = ref v
157 :     in if !debugging
158 :     then PP.with_pp (EM.defaultConsumer())
159 :     (fn ppstrm => (PP.add_string ppstrm "enter: ";
160 :     PPType.resetPPType(); PPType.ppType env ppstrm ty))
161 :     else ();
162 :     cache := (ty, v, r) :: !cache; (v,r)
163 :     end
164 :    
165 :     fun find ty =
166 :     let fun f ((t,v,e)::r) = if equivType(ty,t) then v else f r
167 :     | f [] = (if !debugging
168 :     then say "equal.sml-find-notfound\n" else ();
169 :     raise Notfound)
170 :     in if !debugging
171 :     then PP.with_pp (EM.defaultConsumer())
172 :     (fn ppstrm => (PP.add_string ppstrm "find: ";
173 :     PPType.resetPPType();
174 :     PPType.ppType env ppstrm ty))
175 :     else ();
176 :     f (!cache)
177 :     end
178 :    
179 : monnier 45 fun eqTy ty = eqLty(toLty ty)
180 : monnier 16 fun ptrEq(p, ty) = PRIM(p, eqTy ty, [])
181 :     fun prim(p, lt) = PRIM(p, lt, [])
182 :    
183 :     fun atomeq (tyc, ty) =
184 :     if TU.equalTycon(tyc,BT.intTycon) then prim(PO.IEQL,inteqty)
185 :     else if TU.equalTycon(tyc,BT.int32Tycon) then prim(PO.IEQL,int32eqty)
186 :     else if TU.equalTycon(tyc,BT.wordTycon) then prim(PO.IEQL,inteqty)
187 :     else if TU.equalTycon(tyc,BT.word8Tycon) then prim(PO.IEQL,inteqty)
188 :     else if TU.equalTycon(tyc,BT.charTycon) then prim(PO.IEQL,inteqty)
189 :     else if TU.equalTycon(tyc,BT.word32Tycon) then prim(PO.IEQL,int32eqty)
190 :     else if TU.equalTycon(tyc,BT.boolTycon) then prim(PO.IEQL,booleqty)
191 :     else if TU.equalTycon(tyc,BT.realTycon) then prim(PO.FEQLd,realeqty)
192 :     else if TU.equalTycon(tyc,BT.stringTycon) then getStrEq()
193 :     else if TU.equalTycon(tyc,BT.refTycon) then ptrEq(PO.PTREQL, ty)
194 :     else if TU.equalTycon(tyc,BT.arrayTycon) then ptrEq(PO.PTREQL, ty)
195 :     else if TU.equalTycon(tyc,BT.word8arrayTycon) then ptrEq(PO.PTREQL, ty)
196 :     else if TU.equalTycon(tyc,BT.real64arrayTycon) then ptrEq(PO.PTREQL, ty)
197 :     else raise Poly
198 :    
199 :     fun test(ty, 0) = raise Poly
200 :     | test(ty, depth) =
201 :     (if !debugging
202 :     then PP.with_pp (EM.defaultConsumer())
203 :     (fn ppstrm => (PP.add_string ppstrm "test: ";
204 :     PPType.resetPPType();
205 :     PPType.ppType env ppstrm ty))
206 :     else ();
207 :    
208 :     case ty
209 :     of VARty(ref(INSTANTIATED t)) => test(t,depth)
210 :     | CONty(DEFtyc _, _) => test(TU.reduceType ty,depth)
211 :     | CONty(RECORDtyc _, tyl) =>
212 :     (find ty handle Notfound =>
213 :     let val v = mkv() and x=mkv() and y=mkv()
214 :     val (eqv, patch) = enter ty
215 :     fun loop(n, [ty]) =
216 :     APP(test(ty,depth), RECORD[SELECT(n, VAR x),
217 :     SELECT(n, VAR y)])
218 :     | loop(n, ty::r) =
219 :     COND(loop(n,[ty]), loop(n+1,r), falseLexp)
220 :     | loop(_,nil) = trueLexp
221 :    
222 : monnier 45 val lt = toLty ty
223 : monnier 16 in patch := FN(v, LT.ltc_tuple [lt,lt],
224 :     LET(x, SELECT(0, VAR v),
225 :     LET(y, SELECT(1, VAR v),
226 :     loop(0, tyl))));
227 :     eqv
228 :     end)
229 :    
230 :     | CONty(tyc as GENtyc{kind=PRIMITIVE _,eq=ref YES,...}, tyl) =>
231 :     atomeq (tyc, ty)
232 :    
233 :     | CONty(GENtyc{eq=ref ABS,stamp,arity,kind,path}, tyl) =>
234 :     test(TU.mkCONty(GENtyc{eq=ref YES,stamp=stamp,arity=arity,
235 :     kind=kind,path=path}, tyl), depth)
236 :     (* assume that an equality datatype has been converted
237 :     to an abstract type in an abstype declaration *)
238 :    
239 :     | CONty(tyc as GENtyc{kind=DATATYPE{index,family as {members,...},
240 :     freetycs,stamps,...},
241 :     ...}, tyl) =>
242 :     let val {dcons=dcons0,...} = Vector.sub(members,index)
243 :     fun expandRECdcon{domain=SOME x, rep, name} =
244 :     {domain=SOME(expandREC (family, stamps, freetycs) x),
245 :     rep=rep,name=name}
246 :     | expandRECdcon z = z
247 :    
248 :     in case map expandRECdcon dcons0
249 :     of [{rep=REF,...}] => atomeq(tyc, ty)
250 :     | dcons =>
251 :     (find ty handle Notfound =>
252 :     let val v = mkv() and x=mkv() and y=mkv()
253 :     val (eqv, patch) = enter ty
254 :     fun inside ({name,rep,domain}, ww, uu) =
255 :     (case domain
256 :     of NONE => trueLexp
257 :     | SOME dom =>
258 :     (case reduceTy dom
259 :     of (CONty(RECORDtyc [], _)) => trueLexp
260 :     | _ =>
261 :     (let val argt = argType(dom, tyl)
262 :     in APP(test(argt, depth-1),
263 :     RECORD[VAR ww, VAR uu])
264 :     end)))
265 : monnier 45 val lt = toLty ty
266 : monnier 16 val argty = LT.ltc_tuple [lt,lt]
267 :     val pty = LT.ltc_parrow(argty, boolty)
268 :    
269 :     val body =
270 :     case dcons
271 :     of [] => bug "empty data types"
272 :     (* | [dcon] => inside dcon *)
273 :     | _ =>
274 :     let (** this is somewhat a hack !!!! *)
275 :     (* val sign = map #rep dcons *)
276 :     fun isConst(DA.CONSTANT _) = true
277 :     | isConst(DA.LISTNIL) = true
278 :     | isConst _ = false
279 :    
280 :     fun getCsig({rep=a,domain,name}::r,c,v)=
281 :     if isConst a then getCsig(r, c+1, v)
282 :     else getCsig(r, c, v+1)
283 :     | getCsig([], c, v) = DA.CSIG(v,c)
284 :    
285 :     val sign = getCsig(dcons,0,0)
286 :    
287 :     fun concase dcon =
288 : monnier 45 let val tcs = map toTyc tyl
289 : monnier 16 val ww = mkv() and uu = mkv()
290 : monnier 45 val dc = transDcon(tyc,dcon,toTcLc)
291 : monnier 16 val dconx = DATAcon(dc, tcs, ww)
292 :     val dcony = DATAcon(dc, tcs, uu)
293 :     in (dconx,
294 :     SWITCH(VAR y, sign,
295 :     [(dcony, inside(dcon,ww,uu))],
296 :     SOME(falseLexp)))
297 :     end
298 :     in SWITCH(VAR x, sign,
299 :     map concase dcons, NONE)
300 :     end
301 :    
302 :     val root = APP(PRIM(PO.PTREQL, pty, []),
303 :     RECORD[VAR x, VAR y])
304 :     val nbody = COND(root, trueLexp, body)
305 :     in patch := FN(v, argty,
306 :     LET(x, SELECT(0, VAR v),
307 :     LET(y, SELECT(1, VAR v), nbody)));
308 :     eqv
309 :     end)
310 :     end
311 :    
312 :     | _ => raise Poly)
313 :    
314 :     val body = test(concreteType, 10)
315 :     val fl = !cache
316 :    
317 :     in
318 :    
319 :     (case fl
320 :     of [] => body
321 :     | _ => let fun g ((ty, VAR v, e), (vs, ts, es)) =
322 :     (v::vs, (eqTy ty)::ts, (!e)::es)
323 :     | g _ = bug "unexpected equality cache value"
324 :    
325 :     val (vs, ts, es) = foldr g ([], [], []) fl
326 :     in FIX(vs, ts, es, body)
327 :     end)
328 :    
329 :     end handle Poly =>
330 :     (GENOP({default=getPolyEq(),
331 :     table=[([LT.tcc_string], getStrEq())]},
332 : monnier 45 PO.POLYEQL, toLty polyEqTy,
333 :     [toTyc concreteType]))
334 : monnier 16
335 :    
336 :     end (* toplevel local *)
337 :     end (* structure Equal *)
338 :    
339 :     (*
340 :     * $Log: pequal.sml,v $
341 : monnier 93 * Revision 1.1.1.1 1998/04/08 18:39:42 george
342 :     * Version 110.5
343 : monnier 16 *
344 :     *)

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