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

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

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

revision 24, Thu Mar 12 00:49:58 1998 UTC revision 45, Sun Mar 22 20:11:09 1998 UTC
# Line 1  Line 1 
1  (* Copyright (c) 1997 YALE FLINT PROJECT *)  (* Copyright (c) 1997 YALE FLINT PROJECT *)
2  (* ltyutil.sml *)  (* ltyutil.sml *)
3    
4    (*** this file will go away soon *)
5    
6  signature LTYUTIL = sig  signature LTYUTIL = sig
7    
8  type tkind = LtyDef.tkind  type tkind = LtyDef.tkind
9  type tyc = LtyDef.tyc  type tyc = LtyDef.tyc
10  type lty = LtyDef.lty  type lty = LtyDef.lty
11    
12    (** used by the coercion and wrapping *)
13  val tcWrap : tyc -> tyc option  val tcWrap : tyc -> tyc option
 val ltWrap : lty -> lty option  
 val tcsWrap : tyc list -> tyc list option  
   
 val tcc_arw : tyc * tyc -> tyc  
 val tcd_arw : tyc -> tyc * tyc  
   
 (** based on the given tyc, return its appropriate Update operator *)  
 val tcUpd : tyc -> PrimOp.primop  
   
 (** type convertion; used in the ltNarrow phase *)  
 val tkLty : tkind -> lty  
 val tcNarrow : tyc -> tyc  
 val ltNarrow : lty -> lty  
 val ltNarrowSt : lty -> lty  
   
14  val genWrap : bool -> ((tyc -> tyc option) * (lty -> lty option)  val genWrap : bool -> ((tyc -> tyc option) * (lty -> lty option)
15                         * (tyc list -> tyc list option))                         * (tyc list -> tyc list option))
 val narrowGen : unit -> ((tyc -> tyc) * (lty -> lty) * (unit -> unit))  
16    
17  end  val genWrapNEW : bool -> ((tyc -> tyc) * (lty -> lty) *
18                              (tyc -> tyc) * (lty -> lty) * (unit -> unit))
19    end  (* signature LTYUTIL *)
20    
21  structure LtyUtil : LTYUTIL =  structure LtyUtil : LTYUTIL =
22  struct  struct
# Line 58  Line 47 
47  type lty = LtyDef.lty  type lty = LtyDef.lty
48  type tkindEnv = LT.tkindEnv  type tkindEnv = LT.tkindEnv
49    
 val tcc_arw = LT.tcc_parrow  
 val tcd_arw = LT.tcd_parrow  
 (*  
 fun tcc_arw (t1, t2) = LT.tcc_arrow((true, true), [t1], [t2])  
 fun tcd_arw t = case LT.tcd_arrow t  
                  of (_, [t1], [t2]) => (t1, t2)  
                   | _ => bug "unexpected case in tcd_arw"  
 *)  
   
50  structure TcDict = BinaryDict(struct type ord_key = tyc  structure TcDict = BinaryDict(struct type ord_key = tyc
51                                       val cmpKey = tc_cmp                                       val cmpKey = tc_cmp
52                                end)                                end)
# Line 87  Line 67 
67    
68  fun genWrap save =  fun genWrap save =
69  let  let
   
70  val m1 = ref (TcDict.mkDict())  val m1 = ref (TcDict.mkDict())
71  fun lookTc t =  fun lookTc t =
72    if save then    if save then
# Line 102  Line 81 
81      end      end
82    else tcWrap t    else tcWrap t
83    
84    
85  and tcWrap x =  and tcWrap x =
86    (case (tc_out x)    (case (tc_out x)
87      of (TC_PRIM pt) =>      of (TC_PRIM pt) =>
88           if (PT.isvoid pt) then NONE else SOME (tcBox x)           if PT.unboxed pt then SOME (tcBox x) else NONE
89           (* if PT.unboxed pt then SOME (tcBox x) else NONE *)           (* if (PT.isvoid pt) then NONE else SOME (tcBox x) *)
90           (* warning: this does not handle tycons of non-zero arity *)           (* warning: this does not handle tycons of non-zero arity *)
91       | TC_TUPLE _ => SOME(ucvInfo x)       | TC_TUPLE _ => SOME(ucvInfo x)
92       | TC_ARROW _ => SOME(ucvInfo x)       | TC_ARROW _ => SOME(ucvInfo x)
# Line 153  Line 133 
133    (case (tc_out x)    (case (tc_out x)
134      of (TC_PRIM pt) => NOTHING      of (TC_PRIM pt) => NOTHING
135       | (TC_VAR _ | TC_PROJ _ | TC_ABS _ | TC_NVAR _) => SOMEU x       | (TC_VAR _ | TC_PROJ _ | TC_ABS _ | TC_NVAR _) => SOMEU x
136       | (TC_TUPLE ts) =>       | (TC_TUPLE (_,ts)) =>
137           let val nts = map tcUncover ts           let val nts = map tcUncover ts
138            in if (uinfoList nts) then            in if (uinfoList nts) then
139                 (let fun h(z, NOTHING) = z                 (let fun h(z, NOTHING) = z
# Line 165  Line 145 
145               else NOTHING               else NOTHING
146           end           end
147       | (TC_ARROW _) =>       | (TC_ARROW _) =>
148           let val (tc1, tc2) = tcd_arw x           let val (tc1, tc2) = LT.tcd_parrow x
149               val ntc1 =               val ntc1 =
150                 (case tc_out tc1                 (case tc_out tc1
151                   of TC_TUPLE (ts as [_, _]) =>                   of TC_TUPLE (_, ts as [_, _]) =>
152                        let val nts = map lookTc ts                        let val nts = map lookTc ts
153                         in if (opList nts) then                         in if (opList nts) then
154                              (let fun h(z, NONE) = z                             let fun h(z, NONE) = z
155                                     | h(_, SOME z) = z                                     | h(_, SOME z) = z
156                                   val nt = LT.tcc_tuple(ListPair.map h (ts, nts))                                   val nt = LT.tcc_tuple(ListPair.map h (ts, nts))
157                                in SOMEU nt                                in SOMEU nt
158                               end)                             end
159                            else NOTHING                            else NOTHING
160                        end                        end
161                    | (TC_VAR _ | TC_PROJ _ | TC_APP _ | TC_NVAR _) => SOMEB tc1                    | (TC_VAR _ | TC_PROJ _ | TC_APP _ | TC_NVAR _) => SOMEB tc1
# Line 186  Line 166 
166               val ntc2 = lookTc tc2               val ntc2 = lookTc tc2
167            in (case (ntc1, ntc2)            in (case (ntc1, ntc2)
168                 of (NOTHING, NONE) => NOTHING                 of (NOTHING, NONE) => NOTHING
169                  | (SOMEU z1, NONE) => SOMEU (tcc_arw(z1, tc2))                  | (SOMEU z1, NONE) => SOMEU (LT.tcc_parrow(z1, tc2))
170                  | (SOMEB z1, NONE) => SOMEB (tcBox(tcc_arw(z1, tc2)))                  | (SOMEB z1, NONE) => SOMEB (tcBox(LT.tcc_parrow(z1, tc2)))
171                  | (NOTHING, SOME z2) => SOMEU (tcc_arw(tc1, z2))                  | (NOTHING, SOME z2) => SOMEU (LT.tcc_parrow(tc1, z2))
172                  | (SOMEU z1, SOME z2) => SOMEU (tcc_arw(z1, z2))                  | (SOMEU z1, SOME z2) => SOMEU (LT.tcc_parrow(z1, z2))
173                  | (SOMEB z1, SOME z2) => SOMEB (tcBox(tcc_arw(z1, z2))))                  | (SOMEB z1, SOME z2) => SOMEB (tcBox(LT.tcc_parrow(z1, z2))))
174           end           end
175       | (TC_APP(tc, ts)) =>       | (TC_APP(tc, ts)) =>
176           (case tcUncover tc of NOTHING => NOTHING           (case tcUncover tc of NOTHING => NOTHING
# Line 202  Line 182 
182    
183  val (tcWrap, ltWrap, tcsWrap) = genWrap false  val (tcWrap, ltWrap, tcsWrap) = genWrap false
184    
185  (** based on the given tyc, return its appropriate Update operator *)  fun genWrapNEW bbb =
186  fun tcUpd (tc) =  (* tc is in normal form *)    let fun tc_wmap (w, u) t =
   let fun h(TC_PRIM pt) =  
             if PT.ubxupd pt then PO.UNBOXEDUPDATE  
             else if PT.bxupd pt then PO.BOXEDUPDATE  
                  else PO.UPDATE  
         | h(TC_TUPLE _ | TC_ARROW _) = PO.BOXEDUPDATE  
         | h(TC_FIX ((1,tc,ts), 0)) =  
             let val ntc = case ts of [] => tc  
                                    | _ => LT.tcc_app(tc, ts)  
              in (case (tc_out ntc)  
                   of TC_FN([k],b) => h (tc_out b)  
                    | _ => PO.UPDATE)  
             end  
         | h(TC_SUM tcs) =  
             let fun g (a::r) = if tc_eqv(a, LT.tcc_unit) then g r else false  
                   | g [] = true  
              in if (g tcs) then PO.UNBOXEDUPDATE else PO.UPDATE  
             end  
         | h _ = PO.UPDATE  
    in h(tc_out tc)  
   end  
   
 (** val tkLty : tkind -> lty *)  
 fun tkLty tk =  
   (case tk_out tk  
     of TK_MONO => LT.ltc_int  
      | TK_BOX => LT.ltc_int  
      | TK_SEQ ks => LT.ltc_tuple (map tkLty ks)  
      | TK_FUN (k1, k2) => LT.ltc_arw(tkLty k1, tkLty k2))  
   
 fun tcNarrow t =  
187    (case (tc_out t)    (case (tc_out t)
188      of TC_PRIM pt =>            of (TC_VAR _ | TC_NVAR _) => t
189           if PT.isvoid pt then LT.tcc_void else t             | TC_PRIM pt => if PT.unboxed pt then LT.tcc_wrap t else t
190       | TC_TUPLE tcs => LT.tcc_tuple (map tcNarrow tcs)             | TC_FN (ks, tc) => LT.tcc_fn(ks, w tc) (* impossible case *)
191       | TC_ARROW (r, ts1, ts2) =>             | TC_APP (tc, tcs) => LT.tcc_app(w tc, map w tcs)
192           LT.tcc_arrow(r, map tcNarrow ts1, map tcNarrow ts2)             | TC_SEQ tcs => LT.tcc_seq(map w tcs)
193       | _ => LT.tcc_void)             | TC_PROJ (tc, i) => LT.tcc_proj(w tc, i)
194               | TC_SUM tcs => LT.tcc_sum (map w tcs)
195  fun ltNarrow t =             | TC_FIX ((n,tc,ts), i) =>
196    (case lt_out t                 LT.tcc_fix((n, tc_norm (u tc), map w ts), i)
197      of LT_TYC tc => LT.ltc_tyc (tcNarrow tc)  
198       | LT_STR ts => LT.ltc_str (map ltNarrow ts)             | TC_TUPLE (_, ts) => LT.tcc_wrap(LT.tcc_tuple (map w ts)) (* ? *)
199       | LT_PST its => LT.ltc_pst (map (fn (i, t) => (i, ltNarrow t)) its)             | TC_ARROW (FF_VAR(b1,b2), ts1, ts2) =>
200       | LT_FCT (ts1, ts2) => LT.ltc_fct(map ltNarrow ts1, map ltNarrow ts2)                 let val nts1 =    (* too specific ! *)
201       | LT_POLY (ks, [x]) => LT.ltc_fct([LT.ltc_str (map tkLty ks)],                       (case ts1 of [t11,t12] => [w t11, w t12]
202                                        [ltNarrow x])                                  | _ => [w (tc_autotuple ts1)])
203       | LT_POLY (ks, _) => bug "unexpectd POLYs in ltNarrow"                     val nts2 = [w (tc_autotuple ts2)]
204       | LT_CONT _ => bug "unexpected CNTs in ltNarrow"                     val nt = LT.tcc_arrow(LT.ffc_fixed, nts1, nts2)
205       | LT_IND _ => bug "unexpected INDs in ltNarrow"                  in if b1 then nt else LT.tcc_wrap nt
206       | LT_ENV _ => bug "unexpected ENVs in ltNarrow")                 end
207               | TC_ARROW (FF_FIXED, _, _) =>
208  fun tcNarrowSt t =                  bug "unexpected TC_FIXED_ARROW in tc_umap"
209    let val nt = tc_whnm t             | TC_TOKEN (k, t) => bug "unexpected token tyc in tc_wmap"
210     in (case tc_out nt             | TC_BOX _ => bug "unexpected TC_BOX in tc_wmap"
211          of TC_PRIM pt =>             | TC_ABS _ => bug "unexpected TC_ABS in tc_wmap"
212               if PT.isvoid pt then LT.tcc_void else nt             | _ => bug "unexpected other tycs in tc_wmap")
          | TC_TUPLE tcs => LT.tcc_tuple (map tcNarrowSt tcs)  
          | TC_ARROW (r, ts1, ts2) =>  
              LT.tcc_arrow(r, map tcNarrowSt ts1, map tcNarrowSt ts2)  
          | _ => LT.tcc_void)  
   end  
213    
214  fun ltNarrowSt t =        fun tc_umap (u, w) t =
   (case lt_out (lt_whnm t)  
     of LT_TYC tc => LT.ltc_tyc (tcNarrowSt tc)  
      | LT_STR ts => LT.ltc_str (map ltNarrowSt ts)  
      | LT_PST its => LT.ltc_pst (map (fn (i, t) => (i, ltNarrowSt t)) its)  
      | LT_FCT (ts1, ts2) => LT.ltc_fct(map ltNarrowSt ts1, map ltNarrowSt ts2)  
      | LT_POLY (ks, [x]) => LT.ltc_fct([LT.ltc_str (map tkLty ks)],  
                                        [ltNarrowSt x])  
      | LT_POLY (ks, _) => bug "unexpectd POLYs in ltNarrowSt"  
      | LT_CONT _ => bug "unexpected CNTs in ltNarrowSt"  
      | LT_IND _ => bug "unexpected INDs in ltNarrowSt"  
      | LT_ENV _ => bug "unexpected ENVs in ltNarrowSt")  
   
 (*  
 val tcNarrow =  
   Stats.doPhase (Stats.makePhase "Compiler 053 1-tcNarw") tcNarrow  
   
 val ltNarrow =  
   Stats.doPhase (Stats.makePhase "Compiler 053 2-ltNarw") ltNarrow  
 *)  
   
 (* val narrowGen : unit -> ((tyc -> tyc) * (lty -> lty) * (unit -> unit)) *)  
 fun narrowGen ()  
  = let val m1 = ref (TcDict.mkDict())  
        val m2 = ref (LtDict.mkDict())  
        fun lookTc t =  
          let val u = !m1  
           in (case TcDict.peek(u, t)  
                of SOME t' => t'  
                 | NONE =>  
                     let val x = tcN t  
                         val _ = (m1 := TcDict.insert(u, t, x))  
                      in x  
                     end)  
          end  
   
        and lookLt t =  
          let val u = !m2  
           in (case LtDict.peek(u, t)  
                of SOME t' => t'  
                 | NONE =>  
                     let val x = ltN t  
                         val _ = (m2 := LtDict.insert(u, t, x))  
                      in x  
                     end)  
          end  
   
        and tcN t =  
215           (case (tc_out t)           (case (tc_out t)
216             of TC_PRIM pt =>            of (TC_VAR _ | TC_NVAR _ | TC_PRIM _) => t
217                  if PT.isvoid pt then LT.tcc_void else t             | TC_FN (ks, tc) => LT.tcc_fn(ks, u tc) (* impossible case *)
218              | TC_TUPLE tcs => LT.tcc_tuple (map lookTc tcs)             | TC_APP (tc, tcs) => LT.tcc_app(u tc, map w tcs)
219              | TC_ARROW (r, ts1, ts2) =>             | TC_SEQ tcs => LT.tcc_seq(map u tcs)
220                   LT.tcc_arrow(r, map lookTc ts1, map lookTc ts2)             | TC_PROJ (tc, i) => LT.tcc_proj(u tc, i)
221              | _ => LT.tcc_void)             | TC_SUM tcs => LT.tcc_sum (map u tcs)
222               | TC_FIX ((n,tc,ts), i) =>
223                   LT.tcc_fix((n, tc_norm (u tc), map w ts), i)
224    
225               | TC_TUPLE (rk, tcs) => LT.tcc_tuple(map u tcs)
226               | TC_ARROW (FF_VAR(b1,b2), ts1, ts2) =>
227                   LT.tcc_arrow(LT.ffc_fixed, map u ts1, map u ts2)
228               | TC_ARROW (FF_FIXED, _, _) =>
229                   bug "unexpected TC_FIXED_ARROW in tc_umap"
230               | TC_PARROW _ => bug "unexpected TC_PARROW in tc_umap"
231    
232               | TC_BOX _ => bug "unexpected TC_BOX in tc_umap"
233               | TC_ABS _ => bug "unexpected TC_ABS in tc_umap"
234               | TC_TOKEN (k, t) =>
235                   if token_eq(k, wrap_token) then
236                     bug "unexpected TC_WRAP in tc_umap"
237                   else tc_inj (TC_TOKEN (k, u t))
238    
239               | _ => bug "unexpected other tycs in tc_umap")
240    
241         and ltN t =        fun lt_umap (tcf, ltf) t =
242           (case (lt_out t)           (case (lt_out t)
243             of LT_TYC tc => LT.ltc_tyc (tcN tc)            of LT_TYC tc => LT.ltc_tyc (tcf tc)
244              | LT_STR ts => LT.ltc_str (map lookLt ts)             | LT_STR ts => LT.ltc_str (map ltf ts)
245              | LT_PST its => LT.ltc_pst (map (fn (i, t) => (i, lookLt t)) its)             | LT_FCT (ts1, ts2) => LT.ltc_fct(map ltf ts1, map ltf ts2)
246              | LT_FCT (ts1, ts2) => LT.ltc_fct(map lookLt ts1, map lookLt ts2)             | LT_POLY (ks, xs) => LT.ltc_poly(ks, map ltf xs)
247              | LT_POLY (ks, [x]) => LT.ltc_fct([LT.ltc_str (map tkLty ks)],             | LT_PST its => LT.ltc_pst (map (fn (i, t) => (i, ltf t)) its)
248                                                [lookLt x])             | LT_CONT _ => bug "unexpected CNTs in lt_umap"
249              | _ => bug "unexpected ltys in ltNarrow")             | LT_IND _ => bug "unexpected INDs in lt_umap"
250               | LT_ENV _ => bug "unexpected ENVs in lt_umap")
251    
252          val {tc_wmap=tcWrap, tc_umap=tcMap, lt_umap=ltMap, cleanup} =
253            LtyDict.wmemo_gen{tc_wmap=tc_wmap, tc_umap=tc_umap, lt_umap=lt_umap}
254    
255          fun ltWrap x =
256            LT.ltw_tyc (x, (fn tc => LT.ltc_tyc (tcWrap tc)),
257                        fn _ => bug "unexpected case in ltWrap")
258    
259      in (lookTc, lookLt, fn () => ())     in (tcWrap o tc_norm, ltWrap o lt_norm,
260           tcMap o tc_norm, ltMap o lt_norm, cleanup)
261     end     end
262    
263  end (* toplevel local *)  end (* toplevel local *)

Legend:
Removed from v.24  
changed lines
  Added in v.45

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