Home My Page Projects Code Snippets Project Openings SML/NJ
 Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

# SCM Repository

[smlnj] Diff of /sml/trunk/src/compiler/FLINT/reps/equal.sml
 [smlnj] / sml / trunk / src / compiler / FLINT / reps / equal.sml

# Diff of /sml/trunk/src/compiler/FLINT/reps/equal.sml

revision 603, Thu Apr 6 19:59:57 2000 UTC revision 604, Fri Apr 7 13:53:08 2000 UTC
# Line 49  Line 49
49     in RECORD(FU.rk_tuple, [], v, CON(dc, [], VAR v, w, RET[VAR w]))     in RECORD(FU.rk_tuple, [], v, CON(dc, [], VAR v, w, RET[VAR w]))
50    end    end
51
fun trueLexp () = boolLexp true
fun falseLexp () = boolLexp false

52  exception Poly  exception Poly
53
54  (****************************************************************************  (****************************************************************************
55   *                   Commonly-used Lambda Types                             *   *                   Commonly-used FLINT Types                              *
56   ****************************************************************************)   ****************************************************************************)
57
58  (** assumptions: typed created here will be reprocessed in wrapping.sml *)  (** assumptions: typed created here will be reprocessed in wrapping.sml *)
# Line 67  Line 64
64  val booleqty  = eqLty (LT.ltc_bool)  val booleqty  = eqLty (LT.ltc_bool)
65  val realeqty  = eqLty (LT.ltc_real)  val realeqty  = eqLty (LT.ltc_real)
66
67  datatype resKind  (****************************************************************************
68    = VBIND of value   *              equal --- the equality function generator                   *
69    | PBIND of primop   ****************************************************************************)
70    | EBIND of lexp  exception Notfound
71
72  fun ptrEq(p, tc) = PBIND (NONE, p, eqTy tc, [])  val fkfun = {isrec=NONE, known=false, cconv=CC_FUN LT.ffc_rrflint, inline=IH_SAFE}
fun prim(p, lt) = PBIND (NONE, p, lt, [])
73
74  fun branch(PBIND p, vs, e1, e2) = BRANCH(p, vs, e1, e2)  fun branch (e, te, fe) =
| branch(VBIND v, vs, e1, e2) =
75        let val x = mkv()        let val x = mkv()
76         in LET([x], APP(v, vs),      in LET([x], e,
77              SWITCH(VAR x, BT.boolsign,              SWITCH(VAR x, BT.boolsign,
78                     [(DATAcon(trueDcon', [], mkv()), e1),                    [(DATAcon(trueDcon', [], mkv()), te),
79                      (DATAcon(falseDcon', [], mkv()), e2)], NONE))                     (DATAcon(falseDcon', [], mkv()), fe)], NONE))
end
| branch(EBIND e, vs, e1, e2) =
let val x = mkv()
in LET([x], e, branch(VBIND (VAR x), vs, e1, e2))
80        end        end
81
82  (****************************************************************************  fun equal (peqv, seqv) = let
*              equal --- the equality function generator                   *
****************************************************************************)
exception Notfound
83
84  fun equal (peqv, seqv, tc) =      fun eq (tc, x, y, 0, te, fe) = raise Poly
85  let        | eq (tc, x, y, d, te, fe) = let
86
87  val cache : (tyc * lvar * (fundec option ref)) list ref = ref nil          fun eq_tuple (_, _, [], te, fe) = te
88                     (* lexp ref is used for recursions ? *)            | eq_tuple (n, d, ty::tys, te, fe) =
89                let val a = mkv()
90                    val b = mkv()
91                in SELECT(x, n, a,
92                          SELECT(y, n, b,
93                                 eq(ty, VAR a, VAR b, d - 1,
94                                    eq_tuple(n + 1, d - 1, tys, te, fe),
95                                    fe)))
96                end
97
fun enter tc =
let val v = mkv()
val r = ref NONE
in cache := (tc, v, r) :: !cache; (v, r)
end
(* the order of cache is relevant; the hdr may use the tail *)

fun find tc =
let fun f ((t,v,e)::r) = if tcEqv(tc,t) then VBIND(VAR v) else f r
| f [] = (if !debugging
then say "equal.sml-find-notfound\n" else ();
raise Notfound)
in f (!cache)
end

fun atomeq tc =
if tcEqv(tc,LT.tcc_int) then prim(PO.IEQL,inteqty)
else if tcEqv(tc,LT.tcc_int32) then prim(PO.IEQL,int32eqty)
else if tcEqv(tc,LT.tcc_bool) then prim(PO.IEQL,booleqty)
else if tcEqv(tc,LT.tcc_string) then VBIND (VAR seqv)
else if (LT.tcp_app tc)
then let
val (x, _) = LT.tcd_app tc
98        in        in
99          if ((LT.tcp_prim x) andalso (LT.tcd_prim x = PT.ptc_ref))          if LT.tcp_tuple tc then
100            then ptrEq(PO.PTREQL, tc) (* 'a ref *)              case fe of (APP _ | RET _) =>
101  (** SOMEDAY                         eq_tuple(0, d, LT.tcd_tuple tc, te, fe)
102          else if ((LT.tcp_prim x) andalso (LT.tcd_prim x = PT.ptc_array))                       | _ =>
103            then ???                         let val f = mkv()
104  **)                         in FIX([(fkfun, f, [], fe)],
105                                  eq_tuple(0, d, LT.tcd_tuple tc,
106                                           te, APP(VAR f, [])))
107                           end
108            else if tcEqv(tc,LT.tcc_int) then
109                BRANCH((NONE, PO.IEQL, inteqty, []), [x,y], te, fe)
110            else if tcEqv(tc,LT.tcc_int32) then
111                BRANCH((NONE, PO.IEQL, int32eqty, []), [x,y], te, fe)
112            else if tcEqv(tc,LT.tcc_bool) then
113                BRANCH((NONE, PO.IEQL, booleqty, []), [x,y], te, fe)
114            else if tcEqv(tc,LT.tcc_string) then
115                branch(APP(VAR seqv, [x,y]), te, fe)
116            else if (LT.tcp_app tc) andalso
117                    let val (x, _) = LT.tcd_app tc
118                    in ((LT.tcp_prim x) andalso (LT.tcd_prim x = PT.ptc_ref))
119                    end then
120                BRANCH((NONE, PO.PTREQL, eqTy tc, []), [x,y], te, fe)
121            else raise Poly            else raise Poly
122        end        end
else raise Poly

val fkfun = {isrec=NONE, known=false, cconv=CC_FUN LT.ffc_rrflint, inline=IH_ALWAYS}
123
124  fun test(tc, 0) = raise Poly  in (fn (tc,x,y,d,te,fe) => eq (tc,x,y,d,te,fe)
125    | test(tc, depth) =         handle Poly =>
126       if LT.tcp_tuple tc then                let val f = mkv()
127         (let val ts = LT.tcd_tuple tc                in LET([f], TAPP(VAR peqv, [tc]),
128           in (find tc handle Notfound =>                       branch(APP(VAR f, [x,y]), te, fe))
let val x=mkv() and y=mkv()
val (v, patch) = enter tc

fun loop(n, tx::r) =
let val a = mkv() and b = mkv()
in SELECT(VAR x, n, a,
SELECT(VAR y, n, b,
branch(test(tx, depth), [VAR a, VAR b],
loop(n+1, r), falseLexp())))
end
| loop(_, []) = trueLexp()

val lt = LT.ltc_tyc tc
in patch := SOME (fkfun, v, [(x, lt), (y, lt)], loop(0, ts));
VBIND(VAR v)
end)
129          end)          end)
130       else atomeq tc  end

val body = test(tc, 10)
val fl = !cache

in
(case fl
of [] => body
| _ => let fun g ((tc, f, store), e) =
(case !store
of NONE => e
| SOME fd => FIX([fd], e))
in case body
of PBIND _ => bug "unexpected PBIND in equal"
| VBIND u => EBIND(foldr g (RET[u]) fl)
| EBIND e => EBIND(foldr g e fl)
end)

end handle Poly => EBIND(TAPP(VAR peqv, [tc]))

131
132  fun equal_branch ((d, p, lt, ts), vs, e1, e2) =  fun equal_branch ((d, p, lt, ts), vs, e1, e2) =
133    (case (d, p, ts)    (case (d, p, ts, vs)
134      of (SOME{default=pv, table=[(_,sv)]}, PO.POLYEQL, [tc]) =>      of (SOME{default=pv, table=[(_,sv)]}, PO.POLYEQL, [tc], [x, y]) =>
135            branch(equal(pv, sv, tc), vs, e1, e2)            equal (pv, sv) (tc, x, y, 10, e1, e2)
136       | _ => bug "unexpected case in equal_branch")       | _ => bug "unexpected case in equal_branch")
137
138  end (* toplevel local *)  end (* toplevel local *)
139  end (* structure Equal *)  end (* structure Equal *)

Legend:
 Removed from v.603 changed lines Added in v.604