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 184 - (view) (download)

1 : monnier 69 (* COPYRIGHT (c) 1998 YALE FLINT PROJECT *)
2 : monnier 16 (* 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 : monnier 69 val equal_branch : FLINT.primop * FLINT.value list * FLINT.lexp * FLINT.lexp
12 :     -> FLINT.lexp
13 : monnier 16 val debugging : bool ref
14 :    
15 :     end (* signature EQUAL *)
16 :    
17 :    
18 :     structure Equal : EQUAL =
19 :     struct
20 :    
21 : monnier 69 local structure BT = BasicTypes
22 : monnier 16 structure LT = LtyExtern
23 :     structure PT = PrimTyc
24 :     structure PO = PrimOp
25 :     structure PP = PrettyPrint
26 : monnier 69 structure FU = FlintUtil
27 :     open FLINT
28 : monnier 16 in
29 :    
30 :     val debugging = ref false
31 :     fun bug msg = ErrorMsg.impossible("Equal: "^msg)
32 :     val say = Control.Print.say
33 : monnier 69 val mkv = LambdaVar.mkLvar
34 :     val ident = fn x => x
35 : monnier 16
36 : monnier 69
37 : monnier 16 val (trueDcon', falseDcon') =
38 : monnier 69 let val lt = LT.ltc_arrow(LT.ffc_rrflint, [LT.ltc_unit], [LT.ltc_bool])
39 : monnier 16 fun h (Types.DATACON{name, rep, ...}) = (name, rep, lt)
40 :     in (h BT.trueDcon, h BT.falseDcon)
41 :     end
42 :    
43 :     val tcEqv = LT.tc_eqv
44 :    
45 :    
46 : monnier 69 fun boolLexp b =
47 :     let val v = mkv() and w = mkv()
48 :     val dc = if b then trueDcon' else falseDcon'
49 :     in RECORD(FU.rk_tuple, [], v, CON(dc, [], VAR v, w, RET[VAR w]))
50 : monnier 16 end
51 :    
52 : monnier 69 fun trueLexp () = boolLexp true
53 :     fun falseLexp () = boolLexp false
54 : monnier 16
55 :     exception Poly
56 :    
57 :     (****************************************************************************
58 :     * Commonly-used Lambda Types *
59 :     ****************************************************************************)
60 :    
61 : monnier 69 (** assumptions: typed created here will be reprocessed in wrapping.sml *)
62 :     fun eqLty lt = LT.ltc_arrow(LT.ffc_rrflint, [lt, lt], [LT.ltc_bool])
63 :     fun eqTy tc = eqLty(LT.ltc_tyc tc)
64 :    
65 :     val inteqty = eqLty (LT.ltc_int)
66 : monnier 16 val int32eqty = eqLty (LT.ltc_int32)
67 : monnier 69 val booleqty = eqLty (LT.ltc_bool)
68 :     val realeqty = eqLty (LT.ltc_real)
69 : monnier 16
70 : monnier 69 datatype resKind
71 :     = VBIND of value
72 :     | PBIND of primop
73 :     | EBIND of lexp
74 : monnier 16
75 : monnier 69 fun ptrEq(p, tc) = PBIND (NONE, p, eqTy tc, [])
76 :     fun prim(p, lt) = PBIND (NONE, p, lt, [])
77 :    
78 : monnier 16 fun isRef tc =
79 :     if LT.tcp_app tc then
80 :     (let val (x, _) = LT.tcd_app tc
81 :     in if LT.tcp_prim x
82 :     then (let val pt = LT.tcd_prim x
83 :     in (pt = PT.ptc_ref) orelse (pt = PT.ptc_array)
84 :     end)
85 :     else false
86 :     end)
87 :     else false
88 :    
89 : monnier 69 fun branch(PBIND p, vs, e1, e2) = BRANCH(p, vs, e1, e2)
90 :     | branch(VBIND v, vs, e1, e2) =
91 :     let val x = mkv()
92 :     in LET([x], APP(v, vs),
93 :     SWITCH(VAR x, BT.boolsign,
94 :     [(DATAcon(trueDcon', [], mkv()), e1),
95 :     (DATAcon(falseDcon', [], mkv()), e2)], NONE))
96 :     end
97 :     | branch(EBIND e, vs, e1, e2) =
98 :     let val x = mkv()
99 :     in LET([x], e, branch(VBIND (VAR x), vs, e1, e2))
100 :     end
101 : monnier 16
102 :     (****************************************************************************
103 :     * equal --- the equality function generator *
104 :     ****************************************************************************)
105 : monnier 69 exception Notfound
106 :    
107 : monnier 16 fun equal (peqv, seqv, tc) =
108 : monnier 69 let
109 : monnier 16
110 : monnier 69 val cache : (tyc * lvar * (fundec option ref)) list ref = ref nil
111 :     (* lexp ref is used for recursions ? *)
112 :    
113 : monnier 16 fun enter tc =
114 :     let val v = mkv()
115 : monnier 69 val r = ref NONE
116 :     in cache := (tc, v, r) :: !cache; (v, r)
117 : monnier 16 end
118 : monnier 69 (* the order of cache is relevant; the hdr may use the tail *)
119 : monnier 16
120 :     fun find tc =
121 : monnier 69 let fun f ((t,v,e)::r) = if tcEqv(tc,t) then VBIND(VAR v) else f r
122 : monnier 16 | f [] = (if !debugging
123 :     then say "equal.sml-find-notfound\n" else ();
124 :     raise Notfound)
125 :     in f (!cache)
126 :     end
127 :    
128 :     fun atomeq tc =
129 :     if tcEqv(tc,LT.tcc_int) then prim(PO.IEQL,inteqty)
130 :     else if tcEqv(tc,LT.tcc_int32) then prim(PO.IEQL,int32eqty)
131 :     else if tcEqv(tc,LT.tcc_bool) then prim(PO.IEQL,booleqty)
132 :     else if tcEqv(tc,LT.tcc_real) then prim(PO.FEQLd,realeqty)
133 : monnier 69 else if tcEqv(tc,LT.tcc_string) then VBIND (VAR seqv)
134 : monnier 16 else if isRef(tc) then ptrEq(PO.PTREQL, tc)
135 :     else raise Poly
136 :    
137 : monnier 184 val fkfun = {isrec=NONE, known=false, cconv=CC_FUN LT.ffc_rrflint, inline=IH_ALWAYS}
138 : monnier 69
139 : monnier 16 fun test(tc, 0) = raise Poly
140 :     | test(tc, depth) =
141 :     if LT.tcp_tuple tc then
142 :     (let val ts = LT.tcd_tuple tc
143 :     in (find tc handle Notfound =>
144 : monnier 69 let val x=mkv() and y=mkv()
145 :     val (v, patch) = enter tc
146 : monnier 16
147 : monnier 69 fun loop(n, tx::r) =
148 :     let val a = mkv() and b = mkv()
149 :     in SELECT(VAR x, n, a,
150 :     SELECT(VAR y, n, b,
151 :     branch(test(tx, depth), [VAR a, VAR b],
152 :     loop(n+1, r), falseLexp())))
153 :     end
154 :     | loop(_, []) = trueLexp()
155 : monnier 16
156 : monnier 69 val lt = LT.ltc_tyc tc
157 :     in patch := SOME (fkfun, v, [(x, lt), (y, lt)], loop(0, ts));
158 :     VBIND(VAR v)
159 :     end)
160 :     end)
161 :     else atomeq tc
162 : monnier 16
163 : monnier 69 val body = test(tc, 10)
164 : monnier 16 val fl = !cache
165 :    
166 :     in
167 :     (case fl
168 :     of [] => body
169 : monnier 69 | _ => let fun g ((tc, f, store), e) =
170 :     (case !store
171 :     of NONE => e
172 :     | SOME fd => FIX([fd], e))
173 :     in case body
174 :     of PBIND _ => bug "unexpected PBIND in equal"
175 :     | VBIND u => EBIND(foldr g (RET[u]) fl)
176 :     | EBIND e => EBIND(foldr g e fl)
177 : monnier 16 end)
178 :    
179 : monnier 69 end handle Poly => EBIND(TAPP(VAR peqv, [tc]))
180 :    
181 :    
182 :     fun equal_branch ((d, p, lt, ts), vs, e1, e2) =
183 :     (case (d, p, ts)
184 :     of (SOME{default=pv, table=[(_,sv)]}, PO.POLYEQL, [tc]) =>
185 :     branch(equal(pv, sv, tc), vs, e1, e2)
186 :     | _ => bug "unexpected case in equal_branch")
187 :    
188 : monnier 16 end (* toplevel local *)
189 :     end (* structure Equal *)
190 :    
191 : monnier 93
192 :     (*
193 : monnier 113 * $Log$
194 : monnier 93 *)

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