SCM Repository
Annotation of /sml/branches/SMLNJ/src/compiler/FLINT/reps/equal.sml
Parent Directory
| 
Revision Log
Revision 69 - (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 | 69 | val fkfun = FK_FUN{isrec=NONE, known=false, fixed=LT.ffc_rrflint, inline=true} |
| 138 : | |||
| 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 : |
| root@smlnj-gforge.cs.uchicago.edu | ViewVC Help |
| Powered by ViewVC 1.0.0 |
