Annotation of /sml/branches/SMLNJ/src/compiler/FLINT/reps/equal.sml

Parent Directory | Revision Log

---

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

1 :	monnier	16	(* COPYRIGHT (c) 1996 Bell Laboratories *)
2 :			(* equal.sml *)
3 :
4 :			signature EQUAL =
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 : LambdaVar.lvar * LambdaVar.lvar * LtyDef.tyc -> Lambda.lexp
12 :			val debugging : bool ref
13 :
14 :			end (* signature EQUAL *)
15 :
16 :
17 :			structure Equal : EQUAL =
18 :			struct
19 :
20 :			local structure DA = Access
21 :			structure BT = BasicTypes
22 :			structure LT = LtyExtern
23 :			structure PT = PrimTyc
24 :			structure PO = PrimOp
25 :			structure PP = PrettyPrint
26 :			open Lambda
27 :			in
28 :
29 :			val debugging = ref false
30 :			fun bug msg = ErrorMsg.impossible("Equal: "^msg)
31 :			val say = Control.Print.say
32 :
33 :			val (trueDcon', falseDcon') =
34 :			let val lt = LT.ltc_parrow(LT.ltc_unit, LT.ltc_bool)
35 :			fun h (Types.DATACON{name, rep, ...}) = (name, rep, lt)
36 :			in (h BT.trueDcon, h BT.falseDcon)
37 :			end
38 :
39 :			val tcEqv = LT.tc_eqv
40 :
41 :			(*
42 :			* MAJOR CLEANUP REQUIRED ! The function mkv is currently directly taken
43 :			* from the LambdaVar module; I think it should be taken from the
44 :			* "compInfo". Similarly, should we replace all mkLvar in the backend
45 :			* with the mkv in "compInfo" ? (ZHONG)
46 :			*)
47 :			val mkv = LambdaVar.mkLvar
48 :
49 :			val ident = fn x => x
50 :			fun split(SVAL v) = (v, ident)
51 :			| split x = let val v = mkv()
52 :			in (VAR v, fn z => LET(v, x, z))
53 :			end
54 :
55 :			fun APPg(e1, e2) =
56 :			let val (v1, h1) = split e1
57 :			val (v2, h2) = split e2
58 :			in h1(h2(APP(v1, v2)))
59 :			end
60 :
61 :			fun RECORDg es =
62 :			let fun f ([], vs, hdr) = hdr(RECORD (rev vs))
63 :			| f (e::r, vs, hdr) =
64 :			let val (v, h) = split e
65 :			in f(r, v::vs, hdr o h)
66 :			end
67 :			in f(es, [], ident)
68 :			end
69 :
70 :			fun SWITCHg(e, csig, ces, oe) =
71 :			let val (v, h) = split e
72 :			in h(SWITCH(v, csig, ces, oe))
73 :			end
74 :
75 :			fun CONg(dc, ts, e) =
76 :			let val (v, h) = split e
77 :			in h(CON(dc, ts, v))
78 :			end
79 :
80 :			val (trueLexp, falseLexp) =
81 :			let val unitLexp = RECORD []
82 :			in (CONg (trueDcon', [], unitLexp), CONg (falseDcon', [], unitLexp))
83 :			end
84 :
85 :			exception Poly
86 :
87 :			(****************************************************************************
88 :			* Commonly-used Lambda Types *
89 :			****************************************************************************)
90 :
91 :			val boolty = LT.ltc_bool
92 :			fun eqLty lt = LT.ltc_arw(LT.ltc_tuple [lt, lt], boolty)
93 :			val inteqty = eqLty (LT.ltc_int)
94 :			val int32eqty = eqLty (LT.ltc_int32)
95 :			val booleqty = eqLty (LT.ltc_bool)
96 :			val realeqty = eqLty (LT.ltc_real)
97 :
98 :			fun eqTy tc = eqLty(LT.ltc_tyc tc)
99 :			fun ptrEq(p, tc) = PRIM(p, eqTy tc, [])
100 :			fun prim(p, lt) = PRIM(p, lt, [])
101 :
102 :			fun isRef tc =
103 :			if LT.tcp_app tc then
104 :			(let val (x, _) = LT.tcd_app tc
105 :			in if LT.tcp_prim x
106 :			then (let val pt = LT.tcd_prim x
107 :			in (pt = PT.ptc_ref) orelse (pt = PT.ptc_array)
108 :			end)
109 :			else false
110 :			end)
111 :			else false
112 :
113 :			exception Notfound
114 :
115 :			(****************************************************************************
116 :			* equal --- the equality function generator *
117 :			****************************************************************************)
118 :			fun equal (peqv, seqv, tc) =
119 :			let val cache : (tyc * lvar * lexp ref) list ref = ref nil
120 :
121 :			fun enter tc =
122 :			let val v = mkv()
123 :			val r = ref (SVAL(VAR v))
124 :			in cache := (tc, v, r) :: !cache; (VAR v, r)
125 :			end
126 :
127 :			fun find tc =
128 :			let fun f ((t,v,e)::r) = if tcEqv(tc,t) then VAR v else f r
129 :			| f [] = (if !debugging
130 :			then say "equal.sml-find-notfound\n" else ();
131 :			raise Notfound)
132 :			in f (!cache)
133 :			end
134 :
135 :			fun atomeq tc =
136 :			if tcEqv(tc,LT.tcc_int) then prim(PO.IEQL,inteqty)
137 :			else if tcEqv(tc,LT.tcc_int32) then prim(PO.IEQL,int32eqty)
138 :			else if tcEqv(tc,LT.tcc_bool) then prim(PO.IEQL,booleqty)
139 :			else if tcEqv(tc,LT.tcc_real) then prim(PO.FEQLd,realeqty)
140 :			else if tcEqv(tc,LT.tcc_string) then (VAR seqv)
141 :			else if isRef(tc) then ptrEq(PO.PTREQL, tc)
142 :			else raise Poly
143 :
144 :			fun test(tc, 0) = raise Poly
145 :			| test(tc, depth) =
146 :			if LT.tcp_tuple tc then
147 :			(let val ts = LT.tcd_tuple tc
148 :			in (find tc handle Notfound =>
149 :			let val v = mkv() and x=mkv() and y=mkv()
150 :			val (eqv, patch) = enter tc
151 :			fun loop(n, [tx]) =
152 :			APPg(SVAL (test(tx, depth)),
153 :			RECORDg[SELECT(n, VAR x),
154 :			SELECT(n, VAR y)])
155 :
156 :			| loop(n, tx::r) =
157 :			SWITCHg(loop(n,[tx]), BT.boolsign,
158 :			[(DATAcon(trueDcon'), loop(n+1,r)),
159 :			(DATAcon(falseDcon'), falseLexp)],
160 :			NONE)
161 :
162 :			| loop(_,nil) = trueLexp
163 :
164 :			val lt = LT.ltc_tyc tc
165 :			in patch := FN(v, LT.ltc_tuple [lt,lt],
166 :			LET(x, SELECT(0, VAR v),
167 :			LET(y, SELECT(1, VAR v),
168 :			loop(0, ts))));
169 :			eqv
170 :			end)
171 :			end)
172 :			else atomeq tc
173 :
174 :			val body = SVAL(test(tc, 10))
175 :			val fl = !cache
176 :
177 :			in
178 :			(case fl
179 :			of [] => body
180 :			| _ => let fun g ((tc, v, e), (vs, ts, es)) =
181 :			(v::vs, (eqTy tc)::ts, (!e)::es)
182 :			val (vs, ts, es) = foldr g ([], [], []) fl
183 :			in FIX(vs, ts, es, body)
184 :			end)
185 :			end handle Poly => (TAPP(VAR peqv, [tc]))
186 :
187 :			end (* toplevel local *)
188 :			end (* structure Equal *)
189 :

---

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