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 18, Wed Mar 11 21:00:18 1998 UTC revision 24, Thu Mar 12 00:49:58 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    
 (*** this file will go away soon *)  
   
4  signature LTYUTIL = sig  signature LTYUTIL = sig
5    
6  type tkind = LtyDef.tkind  type tkind = LtyDef.tkind
7  type tyc = LtyDef.tyc  type tyc = LtyDef.tyc
8  type lty = LtyDef.lty  type lty = LtyDef.lty
9    
 (** used by the coercion and wrapping *)  
10  val tcWrap : tyc -> tyc option  val tcWrap : tyc -> tyc option
11  val genWrap : bool -> ((tyc -> tyc option) * (lty -> lty option)  val ltWrap : lty -> lty option
12                         * (tyc list -> tyc list option))  val tcsWrap : tyc list -> tyc list option
13    
14    val tcc_arw : tyc * tyc -> tyc
15    val tcd_arw : tyc -> tyc * tyc
16    
17    (** based on the given tyc, return its appropriate Update operator *)
18    val tcUpd : tyc -> PrimOp.primop
19    
20  (** type convertion; used by the reify phase *)  (** type convertion; used in the ltNarrow phase *)
21  val tkLty : tkind -> lty  val tkLty : tkind -> lty
22    val tcNarrow : tyc -> tyc
23    val ltNarrow : lty -> lty
24    val ltNarrowSt : lty -> lty
25    
26  (** used by the ltNarrow phase *)  val genWrap : bool -> ((tyc -> tyc option) * (lty -> lty option)
27                           * (tyc list -> tyc list option))
28  val narrowGen : unit -> ((tyc -> tyc) * (lty -> lty) * (unit -> unit))  val narrowGen : unit -> ((tyc -> tyc) * (lty -> lty) * (unit -> unit))
29    
30  end  end
# Line 51  Line 58 
58  type lty = LtyDef.lty  type lty = LtyDef.lty
59  type tkindEnv = LT.tkindEnv  type tkindEnv = LT.tkindEnv
60    
61    val tcc_arw = LT.tcc_parrow
62    val tcd_arw = LT.tcd_parrow
63    (*
64    fun tcc_arw (t1, t2) = LT.tcc_arrow((true, true), [t1], [t2])
65    fun tcd_arw t = case LT.tcd_arrow t
66                     of (_, [t1], [t2]) => (t1, t2)
67                      | _ => bug "unexpected case in tcd_arw"
68    *)
69    
70  structure TcDict = BinaryDict(struct type ord_key = tyc  structure TcDict = BinaryDict(struct type ord_key = tyc
71                                       val cmpKey = tc_cmp                                       val cmpKey = tc_cmp
72                                end)                                end)
# Line 59  Line 75 
75                                       val cmpKey = lt_cmp                                       val cmpKey = lt_cmp
76                                end)                                end)
77    
 (*  
78  (** wrapping over a lambdatyc; assumption: arg is in normal form already *)  (** wrapping over a lambdatyc; assumption: arg is in normal form already *)
79  (** warning: this does not handle tycons of non-zero arity *)  (** warning: this does not handle tycons of non-zero arity *)
80  datatype ucvinfo = SOMEB of tyc  datatype ucvinfo = SOMEB of tyc
# Line 72  Line 87 
87    
88  fun genWrap save =  fun genWrap save =
89  let  let
90    
91  val m1 = ref (TcDict.mkDict())  val m1 = ref (TcDict.mkDict())
92  fun lookTc t =  fun lookTc t =
93    if save then    if save then
# Line 86  Line 102 
102      end      end
103    else tcWrap t    else tcWrap t
104    
   
105  and tcWrap x =  and tcWrap x =
106    (case (tc_out x)    (case (tc_out x)
107      of (TC_PRIM pt) =>      of (TC_PRIM pt) =>
108           if PT.unboxed pt then SOME (tcBox x) else NONE           if (PT.isvoid pt) then NONE else SOME (tcBox x)
109           (* if (PT.isvoid pt) then NONE else SOME (tcBox x) *)           (* if PT.unboxed pt then SOME (tcBox x) else NONE *)
110           (* warning: this does not handle tycons of non-zero arity *)           (* warning: this does not handle tycons of non-zero arity *)
111       | TC_TUPLE _ => SOME(ucvInfo x)       | TC_TUPLE _ => SOME(ucvInfo x)
112       | TC_ARROW _ => SOME(ucvInfo x)       | TC_ARROW _ => SOME(ucvInfo x)
# Line 138  Line 153 
153    (case (tc_out x)    (case (tc_out x)
154      of (TC_PRIM pt) => NOTHING      of (TC_PRIM pt) => NOTHING
155       | (TC_VAR _ | TC_PROJ _ | TC_ABS _ | TC_NVAR _) => SOMEU x       | (TC_VAR _ | TC_PROJ _ | TC_ABS _ | TC_NVAR _) => SOMEU x
156       | (TC_TUPLE (_,ts)) =>       | (TC_TUPLE ts) =>
157           let val nts = map tcUncover ts           let val nts = map tcUncover ts
158            in if (uinfoList nts) then            in if (uinfoList nts) then
159                 (let fun h(z, NOTHING) = z                 (let fun h(z, NOTHING) = z
# Line 150  Line 165 
165               else NOTHING               else NOTHING
166           end           end
167       | (TC_ARROW _) =>       | (TC_ARROW _) =>
168           let val (tc1, tc2) = LT.tcd_parrow x           let val (tc1, tc2) = tcd_arw x
169               val ntc1 =               val ntc1 =
170                 (case tc_out tc1                 (case tc_out tc1
171                   of TC_TUPLE (_, ts as [_, _]) =>                   of TC_TUPLE (ts as [_, _]) =>
172                        let val nts = map lookTc ts                        let val nts = map lookTc ts
173                         in if (opList nts) then                         in if (opList nts) then
174                              (let fun h(z, NONE) = z                              (let fun h(z, NONE) = z
# Line 171  Line 186 
186               val ntc2 = lookTc tc2               val ntc2 = lookTc tc2
187            in (case (ntc1, ntc2)            in (case (ntc1, ntc2)
188                 of (NOTHING, NONE) => NOTHING                 of (NOTHING, NONE) => NOTHING
189                  | (SOMEU z1, NONE) => SOMEU (LT.tcc_parrow(z1, tc2))                  | (SOMEU z1, NONE) => SOMEU (tcc_arw(z1, tc2))
190                  | (SOMEB z1, NONE) => SOMEB (tcBox(LT.tcc_parrow(z1, tc2)))                  | (SOMEB z1, NONE) => SOMEB (tcBox(tcc_arw(z1, tc2)))
191                  | (NOTHING, SOME z2) => SOMEU (LT.tcc_parrow(tc1, z2))                  | (NOTHING, SOME z2) => SOMEU (tcc_arw(tc1, z2))
192                  | (SOMEU z1, SOME z2) => SOMEU (LT.tcc_parrow(z1, z2))                  | (SOMEU z1, SOME z2) => SOMEU (tcc_arw(z1, z2))
193                  | (SOMEB z1, SOME z2) => SOMEB (tcBox(LT.tcc_parrow(z1, z2))))                  | (SOMEB z1, SOME z2) => SOMEB (tcBox(tcc_arw(z1, z2))))
194           end           end
195       | (TC_APP(tc, ts)) =>       | (TC_APP(tc, ts)) =>
196           (case tcUncover tc of NOTHING => NOTHING           (case tcUncover tc of NOTHING => NOTHING
# Line 184  Line 199 
199    
200  in (lookTc, ltWrap, tcsWrap)  in (lookTc, ltWrap, tcsWrap)
201  end  end
 *)  
202    
203  fun genWrap bbb =  val (tcWrap, ltWrap, tcsWrap) = genWrap false
   let fun tcWrap t =  
         let val nt = LtyKernel.tcc_wrap t  
          in if LT.tc_eqv(nt,t) then NONE  
             else SOME nt  
         end  
204    
205        and tcsWrap xs =  (** based on the given tyc, return its appropriate Update operator *)
206          let fun p([], flag, bs) = if flag then SOME(rev bs) else NONE  fun tcUpd (tc) =  (* tc is in normal form *)
207                | p(a::r, flag, bs) =    let fun h(TC_PRIM pt) =
208                    (case (tcWrap a) of NONE => p(r, flag, a::bs)              if PT.ubxupd pt then PO.UNBOXEDUPDATE
209                                      | SOME z => p(r, true, z::bs))              else if PT.bxupd pt then PO.BOXEDUPDATE
210           in p(xs, false, [])                   else PO.UPDATE
211            | h(TC_TUPLE _ | TC_ARROW _) = PO.BOXEDUPDATE
212            | h(TC_FIX ((1,tc,ts), 0)) =
213                let val ntc = case ts of [] => tc
214                                       | _ => LT.tcc_app(tc, ts)
215                 in (case (tc_out ntc)
216                      of TC_FN([k],b) => h (tc_out b)
217                       | _ => PO.UPDATE)
218                end
219            | h(TC_SUM tcs) =
220                let fun g (a::r) = if tc_eqv(a, LT.tcc_unit) then g r else false
221                      | g [] = true
222                 in if (g tcs) then PO.UNBOXEDUPDATE else PO.UPDATE
223          end          end
224            | h _ = PO.UPDATE
225        and ltWrap x =     in h(tc_out tc)
         (case lt_out x  
           of LT_TYC t => (case tcWrap t  
                            of NONE => NONE  
                             | SOME z => SOME(LT.ltc_tyc z))  
            | _ => bug "unexpected case in ltWrap")  
    in (tcWrap, ltWrap, tcsWrap)  
226    end    end
227    
 val (tcWrap, ltWrap, tcsWrap) = genWrap false  
   
228  (** val tkLty : tkind -> lty *)  (** val tkLty : tkind -> lty *)
229  fun tkLty tk =  fun tkLty tk =
230    (case tk_out tk    (case tk_out tk
231      of TK_MONO => LT.ltc_int      of TK_MONO => LT.ltc_int
232       | TK_BOX => LT.ltc_int       | TK_BOX => LT.ltc_int
233       | TK_SEQ ks => LT.ltc_tuple (map tkLty ks)       | TK_SEQ ks => LT.ltc_tuple (map tkLty ks)
234       | TK_FUN (ks, k) => LT.ltc_parrow(LT.ltc_tuple(map tkLty ks), tkLty k))       | TK_FUN (k1, k2) => LT.ltc_arw(tkLty k1, tkLty k2))
235    
236  fun tcNarrow t =  fun tcNarrow t =
237    (case (tc_out t)    (case (tc_out t)
238      of TC_PRIM pt =>      of TC_PRIM pt =>
239           if PT.isvoid pt then LT.tcc_void else t           if PT.isvoid pt then LT.tcc_void else t
240       | TC_TUPLE (_, tcs) => LT.tcc_tuple (map tcNarrow tcs)       | TC_TUPLE tcs => LT.tcc_tuple (map tcNarrow tcs)
241       | TC_ARROW (r, ts1, ts2) =>       | TC_ARROW (r, ts1, ts2) =>
242           LT.tcc_arrow(r, map tcNarrow ts1, map tcNarrow ts2)           LT.tcc_arrow(r, map tcNarrow ts1, map tcNarrow ts2)
243       | _ => LT.tcc_void)       | _ => LT.tcc_void)
# Line 247  Line 260 
260     in (case tc_out nt     in (case tc_out nt
261          of TC_PRIM pt =>          of TC_PRIM pt =>
262               if PT.isvoid pt then LT.tcc_void else nt               if PT.isvoid pt then LT.tcc_void else nt
263           | TC_TUPLE (_, tcs) => LT.tcc_tuple (map tcNarrowSt tcs)           | TC_TUPLE tcs => LT.tcc_tuple (map tcNarrowSt tcs)
264           | TC_ARROW (r, ts1, ts2) =>           | TC_ARROW (r, ts1, ts2) =>
265               LT.tcc_arrow(r, map tcNarrowSt ts1, map tcNarrowSt ts2)               LT.tcc_arrow(r, map tcNarrowSt ts1, map tcNarrowSt ts2)
266           | _ => LT.tcc_void)           | _ => LT.tcc_void)
# Line 266  Line 279 
279       | LT_IND _ => bug "unexpected INDs in ltNarrowSt"       | LT_IND _ => bug "unexpected INDs in ltNarrowSt"
280       | LT_ENV _ => bug "unexpected ENVs in ltNarrowSt")       | LT_ENV _ => bug "unexpected ENVs in ltNarrowSt")
281    
282    (*
283    val tcNarrow =
284      Stats.doPhase (Stats.makePhase "Compiler 053 1-tcNarw") tcNarrow
285    
286    val ltNarrow =
287      Stats.doPhase (Stats.makePhase "Compiler 053 2-ltNarw") ltNarrow
288    *)
289    
290  (* val narrowGen : unit -> ((tyc -> tyc) * (lty -> lty) * (unit -> unit)) *)  (* val narrowGen : unit -> ((tyc -> tyc) * (lty -> lty) * (unit -> unit)) *)
291  fun narrowGen ()  fun narrowGen ()
292   = let val m1 = ref (TcDict.mkDict())   = let val m1 = ref (TcDict.mkDict())
# Line 296  Line 317 
317           (case (tc_out t)           (case (tc_out t)
318             of TC_PRIM pt =>             of TC_PRIM pt =>
319                  if PT.isvoid pt then LT.tcc_void else t                  if PT.isvoid pt then LT.tcc_void else t
320              | TC_TUPLE (_, tcs) => LT.tcc_tuple (map lookTc tcs)              | TC_TUPLE tcs => LT.tcc_tuple (map lookTc tcs)
321              | TC_ARROW (r, ts1, ts2) =>              | TC_ARROW (r, ts1, ts2) =>
322                   LT.tcc_arrow(r, map lookTc ts1, map lookTc ts2)                   LT.tcc_arrow(r, map lookTc ts1, map lookTc ts2)
323              | _ => LT.tcc_void)              | _ => LT.tcc_void)

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

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