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

Annotation of /sml/branches/SMLNJ/src/compiler/FLINT/trans/pequal.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 16 - (view) (download)
Original Path: sml/trunk/src/compiler/FLINT/trans/pequal.sml

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

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