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/reps/equal.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/FLINT/reps/equal.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 17 - (view) (download)
Original Path: sml/branches/SMLNJ/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