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
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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

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