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/branches/SMLNJ/src/compiler/FLINT/opt/specialize.sml
ViewVC logotype

Diff of /sml/branches/SMLNJ/src/compiler/FLINT/opt/specialize.sml

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

revision 23, Thu Mar 12 00:49:56 1998 UTC revision 24, Thu Mar 12 00:49:58 1998 UTC
# Line 6  Line 6 
6    
7  signature SPECIALIZE =  signature SPECIALIZE =
8  sig  sig
9    val specialize : FLINT.prog -> FLINT.prog    val specLexp : Lambda.lexp -> Lambda.lexp
10    
11  end (* signature SPECIALIZE *)  end (* signature SPECIALIZE *)
12    
13  structure Specialize : SPECIALIZE =  structure Specialize : SPECIALIZE =
# Line 16  Line 17 
17        structure LT = LtyExtern        structure LT = LtyExtern
18        structure DI = DebIndex        structure DI = DebIndex
19        structure PT = PrimTyc        structure PT = PrimTyc
20        structure PF = PFlatten        open Lambda
       open FLINT  
21  in  in
22    
23  val say = Control.Print.say  val say = Control.Print.say
24  fun bug s = ErrorMsg.impossible ("Specialize: " ^ s)  fun bug s = ErrorMsg.impossible ("Specialize: " ^ s)
25  fun mkv _ = LambdaVar.mkLvar()  val mkv = LambdaVar.mkLvar
26  val ident = fn le : FLINT.lexp => le  val ident = fn le : Lambda.lexp => le
27  fun tvar i = LT.tcc_var(DI.innermost, i)  fun tvar i = LT.tcc_var(DI.innermost, i)
28    
29  val tk_tbx = LT.tkc_box (* the special boxed tkind *)  fun mktvs ks =
30      let fun h (_::r, i, z) = h(r, i+1, (tvar i)::z)
31            | h ([], _, z) = rev z
32       in h (ks, 0, [])
33      end
34    
35    (* the special box tkind *)
36    val tk_tbx = LT.tkc_box
37  val tk_tmn = LT.tkc_mono  val tk_tmn = LT.tkc_mono
38  val tk_eqv = LT.tk_eqv  val tk_eqv = LT.tk_eqv
39    
# Line 39  Line 46 
46     in teq(xs, ys)     in teq(xs, ys)
47    end    end
48    
 (* accounting functions; how many functions have been specialized *)  
 fun mk_click () =  
   let val x = ref 0  
       fun click () = (x := (!x) + 1)  
       fun num_click () = !x  
    in (click, num_click)  
   end  
   
49  (****************************************************************************  (****************************************************************************
50   *                  UTILITY FUNCTIONS FOR KIND AND TYPE BOUNDS              *   *                  UTILITY FUNCTIONS FOR KIND AND TYPE BOUNDS              *
51   ****************************************************************************)   ****************************************************************************)
# Line 59  Line 58 
58  datatype bnd  datatype bnd
59    = KBOX    = KBOX
60    | KTOP    | KTOP
61    | TBND of tyc    | TBND of LD.tyc
62    
63  type bnds = bnd list  type bnds = bnd list
64    
65    datatype dinfo
66      = ESCAPE
67      | NOCSTR
68      | CSTR of bnds
69    
70  (** THE FOLLOWING FUNCTION IS NOT FULLY DEFINED *)  (** THE FOLLOWING FUNCTION IS NOT FULLY DEFINED *)
71  fun kBnd kenv tc =  fun kBnd kenv tc =
72    (if LT.tcp_var tc then    (if LT.tcp_var tc then
73       (let val (i,j) = LT.tcd_var tc       (let val (i,j) = LT.tcd_var tc
74            val (_,ks) = List.nth(kenv, i-1)            val (_,ks) = List.nth(kenv, i-1)
75                              handle _ => bug "unexpected case A in kBnd"                              handle _ => bug "unexpected case A in kBnd"
76               val (_,k) = List.nth(ks, j)               val k = List.nth(ks, j)
77                              handle _ => bug "unexpected case B in kBnd"                              handle _ => bug "unexpected case B in kBnd"
78         in if tk_eqv(tk_tbx, k) then KBOX else KTOP         in if tk_eqv(tk_tbx, k) then KBOX else KTOP
79        end)        end)
# Line 90  Line 94 
94    | tmBnd kenv (tc, x as TBND t) =    | tmBnd kenv (tc, x as TBND t) =
95        if tc_eqv(tc, t) then x else kmBnd kenv (tc, kBnd kenv t)        if tc_eqv(tc, t) then x else kmBnd kenv (tc, kBnd kenv t)
96    
   
 datatype spkind  
   = FULL  
   | PART of bool list (* filter indicator; which one is gone *)  
   
 datatype spinfo  
   = NOSP  
   | NARROW of (tvar * tkind) list  
   | PARTSP of {ntvks: (tvar * tkind) list, nts: tyc list,  
                masks: bool list}  
   | FULLSP of tyc list * lvar list  
   
97  (*  (*
98   * Given a list of default kinds, and a list of bnd information, a depth,   * Given a list of bnd information, return a list of filter info;
99   * and the (tyc list * lvar list) list info in the itable, returns the   * if all bounds are of TBND form, we got a full specialization,
100   * the spinfo.   * we return NONE.
101   *)   *)
102  fun bndGen(oks, bnds, d, info) =  fun bndFlt bnds =
103    let (** pass 1 **)    let fun h ((TBND _)::bs, r, z) = h(bs, false::r, z)
104        fun g ((TBND _)::bs, r, z) = g(bs, false::r, z)          | h (_::bs, r, _) = h(bs, true::r, false)
105          | g (_::bs, r, _) = g(bs, true::r, false)          | h ([], r, z) = if z then NONE else SOME (rev r)
106          | g ([], r, z) = if z then FULL else PART (rev r)     in h(bnds, [], true)
107        val spk = g(bnds, [], true)    end
108    
109        val adj = case spk of FULL => (fn tc => tc)  (*
110     * Given a list of default kinds, and a list of bnd information, and a
111     * flag indicating whether it is full specialization;
112     * two pieces of information: resOp of (tkind list option * tyc list) option
113     * and the filterOp of (bool list) option
114     *)
115    fun bndGen(oks, bnds, fltOp, d) =
116      let val adj = case fltOp of NONE => (fn tc => tc)
117                            | _ => (fn tc => LT.tc_adj(tc, d, DI.next d))                            | _ => (fn tc => LT.tc_adj(tc, d, DI.next d))
118          (* if not full-specializations, we push depth one-level down *)          (* no full-specializations, so we push one-level down *)
   
       (** pass 2 **)  
       val n = length oks  
119    
120        (* invariants: n = length bnds = length (the-resulting-ts) *)        fun h([], [], i, [], ts, b) = (NONE, rev ts, b)
121        fun h([], [], i, [], ts, _) =          | h([], [], i, ks, ts, b) = (SOME(rev ks), rev ts, b)
             (case info of [(_, xs)] => FULLSP(rev ts, xs)  
                        | _ => bug "unexpected case in bndGen 3")  
         | h([], [], i, ks, ts, b) =  
             if b then NOSP else  
              if i = n then NARROW (rev ks)  
              else (case spk  
                     of PART masks =>  
                         PARTSP {ntvks=rev ks, nts=rev ts, masks=masks}  
                      | _ => bug "unexpected case 1 in bndGen")  
         | h(ok::oks, KTOP::bs, i, ks, ts, b) =  
              h(oks, bs, i+1, ok::ks, (tvar i)::ts, b)  
122          | h(ok::oks, (TBND tc)::bs, i, ks, ts, b) =          | h(ok::oks, (TBND tc)::bs, i, ks, ts, b) =
123               h(oks, bs, i, ks, (adj tc)::ts, false)               h(oks, bs, i, ks, (adj tc)::ts, false)
124          | h((tv,ok)::oks, KBOX::bs, i, ks, ts, b) =          | h(ok::oks, KTOP::bs, i, ks, ts, b) =
125                 h(oks, bs, i+1, ok::ks, (tvar i)::ts, b)
126            | h(ok::oks, KBOX::bs, i, ks, ts, b) =
127               let (* val nk = if tk_eqv(tk_tbx, ok) then ok else tk_tbx *)               let (* val nk = if tk_eqv(tk_tbx, ok) then ok else tk_tbx *)
128                   val (nk, b) =                   val nk = if tk_eqv(tk_tmn, ok) then tk_tbx else ok
129                     if tk_eqv(tk_tmn, ok) then (tk_tbx, false) else (ok, b)                in h(oks, bs, i+1, nk::ks, (tvar i)::ts, b)
               in h(oks, bs, i+1, (tv,nk)::ks, (tvar i)::ts, b)  
130               end               end
131          | h _ = bug "unexpected cases 2 in bndGen"          | h _ = bug "unexpected cases in bndGen"
   
132    
133     in h(oks, bnds, 0, [], [], true)        val (ksOp, ts, boring) = h(oks, bnds, 0, [], [], true)
134       in if boring then ((ksOp, NONE), NONE)
135          else ((ksOp, SOME ts), SOME fltOp)
136    end    end
137    
138    
# Line 154  Line 141 
141   ****************************************************************************)   ****************************************************************************)
142    
143  (*  (*
144   * We maintain a table mapping each lvar to its definition depth,   * We maintain a table mapping each lvar to a list of its use,
145   * its type, and a list of its uses, indexed by its specific type   * indexed by its specific type instances.
  * instances.  
146   *)   *)
147  exception ITABLE  exception ITABLE
148  exception DTABLE  exception DTABLE
149    
 datatype dinfo  
   = ESCAPE  
   | NOCSTR  
   | CSTR of bnds  
   
150  type depth = DI.depth  type depth = DI.depth
151  type info = (tyc list * lvar list) list  type tkind = LD.tkind
152  type itable = info Intmap.intmap   (* lvar -> (tyc list * lvar) *)  type info = (tyc list * lvar) list
153    type itable = info Intmap.intmap
154  type dtable = (depth * dinfo) Intmap.intmap  type dtable = (depth * dinfo) Intmap.intmap
155  datatype infoEnv = IENV of (itable * (tvar * tkind) list) list * dtable  datatype infoEnv = IENV of (itable * tkind list) list * dtable
156    
 (****************************************************************************  
  *              UTILITY FUNCTIONS FOR TYPE SPECIALIZATIONS                  *  
  ****************************************************************************)  
157  (** initializing a new info environment : unit -> infoEnv *)  (** initializing a new info environment : unit -> infoEnv *)
158  fun initInfoEnv () =  fun initInfoEnv () =
159    let val itable : itable = Intmap.new (32, ITABLE)    let val itable : itable = Intmap.new (32, ITABLE)
# Line 195  Line 174 
174  (*  (*
175   * Register a dtable entry; modify the least upper bound of a particular   * Register a dtable entry; modify the least upper bound of a particular
176   * type binding; notice I am only moving kind info upwards, not type   * type binding; notice I am only moving kind info upwards, not type
177   * info, I could move type info upwards though.   * info, I could move type info upwards though, but it is just some
178     * extra complications.
179   *)   *)
180  fun regDtable (IENV(kenv, dtable), v, infos) =  fun regDtable (IENV(kenv, dtable), v, infos) =
181    let val (dd, dinfo) =    let val (dd, dinfo) =
# Line 204  Line 184 
184     in (case dinfo     in (case dinfo
185          of ESCAPE => ()          of ESCAPE => ()
186           | _ =>           | _ =>
187               let fun h ((ts, _), ESCAPE) = ESCAPE               (let fun h ((ts, _), ESCAPE) = ESCAPE
188                     | h ((ts, _), NOCSTR) = CSTR (map (kBnd kenv) ts)                     | h ((ts, _), NOCSTR) = CSTR (map (kBnd kenv) ts)
189                     | h ((ts, _), CSTR bnds) =                     | h ((ts, _), CSTR bnds) =
190                         let val nbnds = ListPair.map (kmBnd kenv) (ts, bnds)                         let val nbnds = ListPair.map (kmBnd kenv) (ts, bnds)
# Line 212  Line 192 
192                         end                         end
193                   val ndinfo = foldr h dinfo infos                   val ndinfo = foldr h dinfo infos
194                in Intmap.add dtable (v, (dd, ndinfo))                in Intmap.add dtable (v, (dd, ndinfo))
195               end)                end))
196    end (* function regDtable *)    end
197    
198  (*  (*
199   * Calculate the least upper bound of all type instances;   * Calculate the least upper bound of all type instances;
# Line 238  Line 218 
218    end    end
219    
220  (** look and add a new type instance into the itable *)  (** look and add a new type instance into the itable *)
221  fun lookItable (IENV (itabs,dtab), d, v, ts, getlty) =  fun lookItable (IENV (itabs,dtab), d, v, ts) =
222    let val (dd, _) =    let val (dd, _) =
223          ((Intmap.map dtab v) handle _ => bug "unexpected cases in lookItable")          ((Intmap.map dtab v) handle _ => bug "unexpected cases in lookItable")
224    
# Line 250  Line 230 
230        val nts = map (fn t => LT.tc_adj(t, d, nd)) ts        val nts = map (fn t => LT.tc_adj(t, d, nd)) ts
231        val xi = (Intmap.map itab v) handle _ => []        val xi = (Intmap.map itab v) handle _ => []
232    
233        fun h ((ots,xs)::r) = if tcs_eqv(ots, nts) then (map VAR xs) else h r        fun h ((ots,x)::r) = if tcs_eqv(ots, nts) then (VAR x) else h r
234          | h [] = let val oldt = getlty (VAR v)          | h [] = let val nv =  mkv()
235                       val bb = LT.lt_inst(oldt, ts)                       val _ = Intmap.add itab (v, (nts, nv)::xi)
236                       val nvs =  map mkv  bb                    in VAR nv
                      val _ = Intmap.add itab (v, (nts, nvs)::xi)  
                   in map VAR nvs  
237                   end                   end
238     in h xi     in h xi
239    end    end
240    
241  (** push a new layer of type abstraction : infoEnv -> infoEnv *)  (** push a new layer of type abstraction : infoEnv -> infoEnv *)
242  fun pushItable (IENV(itables, dtable), tvks) =  fun pushItable (IENV(itables, dtable), ks) =
243    let val nt : itable = Intmap.new(32, ITABLE)    let val nt : itable = Intmap.new(32, ITABLE)
244     in (IENV((nt,tvks)::itables, dtable))     in (IENV((nt,ks)::itables, dtable))
245    end    end
246    
247  (*  (*
# Line 276  Line 254 
254        let val infos = Intmap.intMapToList nt        let val infos = Intmap.intMapToList nt
255            fun h ((v,info), hdr) =            fun h ((v,info), hdr) =
256              let val _ = regDtable(ienv, v, info)              let val _ = regDtable(ienv, v, info)
257                  fun g ((ts, xs), e) = LET(xs, TAPP(VAR v, ts), e)                  fun g ((ts, x), e) = LET(x, TAPP(VAR v, ts), e)
258               in fn e => foldr g (hdr e) info               in fn e => foldr g (hdr e) info
259              end              end
260         in foldr h ident infos         in foldr h ident infos
# Line 287  Line 265 
265        bug "unexpected empty information env in chkOut"        bug "unexpected empty information env in chkOut"
266    | chkOutEsc (ienv as IENV((nt,_)::_, _), v) =    | chkOutEsc (ienv as IENV((nt,_)::_, _), v) =
267        let val info = (Intmap.map nt v) handle _ => []        let val info = (Intmap.map nt v) handle _ => []
268            fun g ((ts, xs), e) = LET(xs, TAPP(VAR v, ts), e)            fun g ((ts, x), e) = LET(x, TAPP(VAR v, ts), e)
269            val hdr = fn e => foldr g e info            val hdr = fn e => foldr g e info
270            val _ = Intmap.rmv nt v  (* so that v won't be considered again *)            val _ = Intmap.rmv nt v  (* so that v won't be considered again *)
271         in hdr         in hdr
272        end        end
273    
 fun chkOutEscs (ienv, vs) =  
   foldr (fn (v,h) => (chkOutEsc(ienv, v)) o h) ident vs  
   
274  (*  (*
275   * Check out a regular variable from the info env, build the header   * Check out a regular variable from the info env, build the header
276   * properly, of course, adjust the corresponding dtable entry.   * properly, of course, adjust the corresponding dtable entry.
# Line 305  Line 280 
280    
281    | chkOutNorm (ienv as IENV((nt,_)::_, dtable), v, oks, d) =    | chkOutNorm (ienv as IENV((nt,_)::_, dtable), v, oks, d) =
282        let val info = (Intmap.map nt v) handle _ => []        let val info = (Intmap.map nt v) handle _ => []
283            val (_, dinfo) = sumDtable(ienv, v, info)            val (dd, dinfo) = sumDtable(ienv, v, info)
284            val spinfo =            val (resOp, filterOp) =
285              (case dinfo              (case dinfo
286                of ESCAPE => NOSP                of ESCAPE => ((NONE,NONE), NONE)
287                 | NOCSTR => (* must be a dead function, let's double check *)                 | NOCSTR => (* must be a dead function, let's double check *)
288                     (case info of [] => NOSP                     (case info of [] => ((NONE,NONE), NONE)
289                                 | _ => bug "unexpected cases in chkOutNorm")                                 | _ => bug "unexpected cases in chkOutNorm")
290                 | CSTR bnds => bndGen(oks, bnds, d, info))                 | CSTR bnds => bndGen(oks, bnds, bndFlt bnds, d))
291    
292            fun mkhdr((ts, xs), e) =            fun tapp(e, ts, NONE) = TAPP(e, ts)
293              (case spinfo              | tapp(e, ts, SOME (NONE)) = SVAL e
294                of FULLSP _ => e              | tapp(e, ts, SOME (SOME flags)) =
                | PARTSP {masks, ...} =>  
295                     let fun h([], [], z) = rev z                     let fun h([], [], z) = rev z
296                           | h(a::r, b::s, z) =                           | h(a::r, b::s, z) =
297                               if b then h(r, s, a::z) else h(r, s, z)                               if b then h(r, s, a::z) else h(r, s, z)
298                           | h _ = bug "unexpected cases in tapp"                           | h _ = bug "unexpected cases in tapp"
299                      in LET(xs, TAPP(VAR v, h(ts, masks, [])), e)                   in TAPP(e, h(ts, flags, []))
300                     end                     end
301                 | _ => LET(xs, TAPP(VAR v, ts), e))  
302            val hdr = fn e => foldr mkhdr e info            fun g ((ts, x), e) = LET(x, tapp(VAR v, ts, filterOp), e)
303              val hdr = fn e => foldr g e info
304            val _ = Intmap.rmv nt v  (* so that v won't be considered again *)            val _ = Intmap.rmv nt v  (* so that v won't be considered again *)
305         in (hdr, spinfo)         in (hdr, resOp)
306        end        end
307    
308  (****************************************************************************  (****************************************************************************
309   *                         MAIN FUNCTION                                    *   *                         MAIN FUNCTIONS                                   *
310   ****************************************************************************)   ****************************************************************************)
311    
312  fun specialize fdec =  (*
313  let   * Function transform has the following type:
314     *
315  val (click, num_click) = mk_click ()   *    infoEnv * lty cvt * tyc cvt * DI.depth -> (lexp -> lexp)
316     *
 (* In pass1, we calculate the old type of each variables in the FLINT  
  * expression. The reason we can't merge this with the main pass is  
  * that the main pass traverse the code in different order.  
  * There must be a simpler way, but I didn't find one yet (ZHONG).  
  *)  
 val {getLty=getLtyGen, cleanUp} = Recover.recover fdec  
   
 (* transform: infoEnv * DI.depth * lty cvt * tyc cvt  
               * (value -> lty) * bool -> (lexp -> lexp)  
317   *            where type 'a cvt = DI.depth -> 'a -> 'a   *            where type 'a cvt = DI.depth -> 'a -> 'a
318   * The 2nd argument is the depth of the resulting expression.   *
319   * The 3rd and 4th arguments are used to encode the type translations.   * The 2nd and 3rd arguments are used to encode the necessary type
320   * The 5th argument is the depth information in the original code,   * translations. The 4th argument is the depth the resulting expression
321   *    it is useful for the getlty.   * will be at.
  * The 6th argument is a flag that indicates whether we need to  
  * flatten the return results of the current function.  
322   *)   *)
323  fun transform (ienv, d, ltfg, tcfg, gtd, did_flat) =  fun transform (ienv, ltf, tcf, d) =
324    let val ltf = ltfg d  let
       val tcf = tcfg d  
       val getlty = getLtyGen gtd  
   
       (* we chkin and chkout polymorphic values only *)  
       fun chkin v = entDtable (ienv, v, (d, ESCAPE))  
       fun chkout v = chkOutEsc (ienv, v)  
       fun chkins vs = app chkin vs  
       fun chkouts vs = chkOutEscs (ienv, vs)  
   
       (* lpvar : value -> value *)  
       fun lpvar (u as (VAR v)) = (escDtable(ienv, v); u)  
         | lpvar u = u  
   
       (* lpvars : value list -> value list *)  
       fun lpvars vs = map lpvar vs  
   
       (* lpprim : primop -> primop *)  
       fun lpprim (d, po, lt, ts) = (d, po, ltf lt, map tcf ts)  
   
       (* lpdc : dcon -> dcon *)  
       fun lpdc (s, rep, lt) = (s, rep, ltf lt)  
   
       (* lplet : lvar * lexp -> (lexp -> lexp) *)  
       fun lplet (v, e, cont) =  
         let val _ = chkin v  
             val ne = loop e  
          in cont ((chkout v) ne)  
         end  
   
       (* lplets : lvar list * lexp -> (lexp -> lexp) *)  
       and lplets (vs, e, cont) =  
         let val _ = chkins vs  
             val ne = loop e  
          in cont ((chkouts vs) ne)  
         end  
   
       (* lpcon : con * lexp -> con * lexp *)  
       and lpcon (DATAcon (dc, ts, v), e) =  
             (DATAcon (lpdc dc, map tcf ts, v), lplet(v, e, fn x => x))  
         | lpcon (c, e) = (c, loop e)  
   
       (* lpfd : fundec -> fundec *** requires REWORK *** *)  
       and lpfd (fk as FK_FCT, f, vts, be) =  
            (fk, f, map (fn (v,t) => (v, ltf t)) vts,  
                    lplets (map #1 vts, be, fn e => e))  
         | lpfd (fk as FK_FUN {fixed=(b1,b2),isrec,known,inline}, f, vts, be) =  
            let (** first get the original arg and res types of f *)  
                val ((b1',b2'), atys, rtys) = LT.ltd_arrow (getlty (VAR f))  
   
                (** just a sanity check; should turn it off later **)  
                val _ = if (b1=b1') andalso (b2=b2') then ()  
                        else bug "unexpected code in lpfd"  
   
                (** get the newly specialized types **)  
                val (natys, nrtys) = (map ltf atys, map ltf rtys)  
   
                (** do we need flatten the arguments and the results *)  
                val ((arg_raw, arg_ltys, _), unflatten) =  
                  PF.v_unflatten (natys, b1)  
   
                val (body_raw, body_ltys, ndid_flat) = PF.t_flatten (nrtys, b2)  
   
                (** process the function body *)  
                val nbe =  
                  if ndid_flat = did_flat then loop be  
                  else transform (ienv, d, ltfg, tcfg, gtd, ndid_flat) be  
   
                val (arg_lvs, nnbe) = unflatten (map #1 vts, nbe)  
325    
326                 (** fix the isrec information *)  fun lpsv sv =
327                 val nisrec = case isrec of NONE => NONE    (case sv
328                                          | SOME _ => SOME body_ltys      of (INT _ | WORD _ | INT32 _ | WORD32 _ | REAL _ | STRING _) => sv
329                 val nfk = FK_FUN {isrec=nisrec, fixed=(arg_raw, body_raw),       | VAR v => (escDtable(ienv, v); sv)
330                                   known=known, inline=inline}       | PRIM (p, lt, ts) => PRIM(p, ltf d lt, map (tcf d) ts)
331             (* I don't think this is really necessary because all primops
332                have closed types, but probably it is quite cheap *)
333         | GENOP(dict, p, lt, ts) => GENOP(dict, p, ltf d lt, map (tcf d) ts))
334    
335              in (nfk, f, ListPair.zip(arg_lvs, arg_ltys), nnbe)  fun loop le =
336             end    (case le
337        of SVAL sv => SVAL(lpsv sv)
338         | TAPP(VAR v, ts) =>
339             (SVAL(lookItable(ienv, d, v, map (tcf d) ts)))
340         | TAPP(sv, ts) => TAPP(lpsv sv, map (tcf d) ts)
341    
342        (* lptf : tfundec * lexp -> lexp *** Invariant: ne2 has been processed *)       | TFN(ks, e) =>
343        and lptf ((v, tvks, e1), ne2) =           let val nienv = pushItable(ienv, ks)
         let val nienv = pushItable(ienv, tvks)  
344              val nd = DI.next d              val nd = DI.next d
345              val ne1 = transform (nienv, nd, ltfg, tcfg, DI.next gtd, false) e1               val ne = transform (nienv, ltf, tcf, nd) e
346              val hdr = popItable nienv              val hdr = popItable nienv
347           in TFN((v, tvks, hdr ne1), ne2)            in TFN(ks, hdr ne)
         end  
   
       (* loop : lexp -> lexp *)  
       and loop le =  
         (case le  
           of RET vs =>  
                if did_flat then  
                  let val vts = map (ltf o getlty) vs  
                      val ((_,_,ndid_flat),flatten) = PF.v_flatten(vts, false)  
                   in if ndid_flat then  
                        let val (nvs, hdr) = flatten vs  
                         in hdr(RET nvs)  
                        end  
                      else RET(lpvars vs)  
                  end  
                else RET(lpvars vs)  
            | LET(vs, e1, e2) =>  
                let (* first get the original types *)  
                    val vtys = map (ltf o getlty o VAR) vs  
                    (* second get the newly specialized types *)  
                    val ((_, _, ndid_flat), unflatten) =  
                       PF.v_unflatten(vtys, false)  
                           (* treat the let type as always "cooked" *)  
                    val _ = chkins vs  
                    val ne2 = loop e2  
                    val ne2 = (chkouts vs) ne2  
                    val (nvs, ne2) = unflatten(vs, ne2)  
   
                    val ne1 =  
                     if ndid_flat = did_flat then loop e1  
                     else transform (ienv, d, ltfg, tcfg, gtd, ndid_flat) e1  
                 in LET(nvs, ne1, ne2)  
                end  
   
            | FIX(fdecs, e) => FIX(map lpfd fdecs, loop e)  
            | APP(v, vs) =>  
                let val vty =getlty v  
                 in if LT.ltp_fct vty then APP(lpvar v, lpvars vs)  
                    else  
                      let (** first get the original arg and res types of v *)  
                          val ((b1,b2), atys, rtys) = LT.ltd_arrow (getlty v)  
                          (** get the newly specialized types **)  
                          val (natys, nrtys) = (map ltf atys, map ltf rtys)  
   
                          val (nvs, hdr1) = (#2 (PF.v_flatten (atys, b1))) vs  
                          val hdr2 =  
                            if did_flat then ident  
                            else (let val ((_, _, ndid_flat), unflatten) =  
                                        PF.v_unflatten(nrtys, b2)  
                                      val fvs = map mkv nrtys  
                                   in if ndid_flat then  
                                        let val (nvs, xe) =  
                                              unflatten(fvs, RET (map VAR fvs))  
                                         in fn le => LET(nvs, le, xe)  
                                        end  
                                      else ident  
                                  end)  
                       in hdr1 (APP(lpvar v, lpvars nvs))  
                      end  
348                 end                 end
349    
350             | TFN((v, tvks, e1), e2) =>       | LET(v, e1 as TFN(ks, be1), e2) =>
351                 let val _ = entDtable(ienv, v, (d,NOCSTR))                 let val _ = entDtable(ienv, v, (d,NOCSTR))
352                     val ne2 = loop e2                     val ne2 = loop e2
353                     val ks = map #2 tvks               val (hdr, resOp) = chkOutNorm(ienv, v, ks, d)
354                     val (hdr2, spinfo) = chkOutNorm(ienv, v, tvks, d)               val ne1 =
355                     val ne2 = hdr2 ne2                 (case resOp
356                  in (case spinfo                   of (NONE, NONE) => loop e1
357                       of NOSP => lptf((v, tvks, e1), ne2)                    | (SOME nks, NONE) => loop(TFN(nks, be1))
358                        | NARROW ntvks => lptf((v, ntvks, e1), ne2)                    | (NONE, SOME nts) =>
359                        | PARTSP {ntvks, nts, ...} =>                       let fun nltf nd lt =
360                            (* assume nts is already shifted one level down *)                             (LT.lt_sp_adj(ks, ltf (DI.next nd) lt, nts, nd-d, 0))
361                            let val nienv = pushItable(ienv, ntvks)                           fun ntcf nd tc =
362                               (LT.tc_sp_adj(ks, tcf (DI.next nd) tc, nts, nd-d, 0))
363                          in transform (ienv, nltf, ntcf, d) be1
364                         end
365                         (** this unfortunately relies on the value restrictions *)
366    
367                      | (SOME nks, SOME nts) =>
368                         (** assume nts is already shifted one level down *)
369                         let val nienv = pushItable(ienv, nks)
370                                val xd = DI.next d                                val xd = DI.next d
371                                fun nltfg nd lt =  
372                             fun nltf nd lt =
373                                  let val lt1 = LT.lt_sp_sink(ks, lt, d, nd)                                  let val lt1 = LT.lt_sp_sink(ks, lt, d, nd)
374                                      val lt2 = ltfg (DI.next nd) lt1                                 val lt2 = ltf (DI.next nd) lt1
375                                   in (LT.lt_sp_adj(ks, lt2, nts, nd-xd, 0))                                   in (LT.lt_sp_adj(ks, lt2, nts, nd-xd, 0))
376                                  end                                  end
377                                fun ntcfg nd tc =                           fun ntcf nd tc =
378                                  let val tc1 = LT.tc_sp_sink(ks, tc, d, nd)                                  let val tc1 = LT.tc_sp_sink(ks, tc, d, nd)
379                                      val tc2 = tcfg (DI.next nd) tc1                                 val tc2 = tcf (DI.next nd) tc1
380                                   in (LT.tc_sp_adj(ks, tc2, nts, nd-xd, 0))                                   in (LT.tc_sp_adj(ks, tc2, nts, nd-xd, 0))
381                                  end                                  end
382                                val ne1 =                           val nbe1 = transform (nienv, nltf, ntcf, xd) be1
                                 transform (nienv, xd, nltfg, ntcfg,  
                                            DI.next gtd, false) e1  
383                                val hdr0 = popItable nienv                                val hdr0 = popItable nienv
384                             in TFN((v, ntvks, hdr0 ne1), ne2)                        in (TFN(nks, hdr0 nbe1))
                           end  
                       | FULLSP (nts, xs) =>  
                           let fun nltfg nd lt =  
                                 (LT.lt_sp_adj(ks, ltfg (DI.next nd) lt,  
                                               nts, nd-d, 0))  
                               fun ntcfg nd tc =  
                                 (LT.tc_sp_adj(ks, tcfg (DI.next nd) tc,  
                                               nts, nd-d, 0))  
                               val ne1 = transform (ienv, d, nltfg, ntcfg,  
                                                    DI.next gtd, false) e1  
                            in click(); LET(xs, ne1, ne2)  
385                            end)                            end)
386                 end  (* case TFN *)            in LET(v, ne1, hdr ne2)
387             end
388    
389             | TAPP(VAR v, ts) =>       | LET(v, e1, e2) =>
390                 RET (lookItable(ienv, d, v, map tcf ts, getlty))           let val _ = entDtable(ienv, v, (d,ESCAPE))
391                 val ne2 = loop e2
392                 val hdr = chkOutEsc(ienv, v)
393              in LET(v, loop e1, hdr ne2)
394             end
395    
396         | FN(v, t, e) =>
397             let val _ = entDtable(ienv, v, (d,ESCAPE))
398                 val ne = loop e
399                 val hdr = chkOutEsc(ienv, v)
400              in FN(v, ltf d t, hdr ne)
401             end
402    
403         | FIX(vs, ts, es, eb) => FIX(vs, map (ltf d) ts, map loop es, loop eb)
404             (* ASSUMPTIONS WE MADE HERE: all lvars defined in vs can't be
405                polymorphic functions, that is, all ltys in ts must be
406                monomorphic types *)
407    
408         | APP(sv1, sv2) => APP(lpsv sv1, lpsv sv2)
409    
410         | PACK (lt, ts, nts, sv) =>
411             PACK(ltf d lt, map (tcf d) ts, map (tcf d) nts, lpsv sv)
412    
413         | CON ((s,r,lt), ts, sv) =>
414             CON((s, r, ltf d lt), map (tcf d) ts, lpsv sv)
415    
416         | DECON ((s,r,lt), ts, sv) =>
417             DECON((s, r, ltf d lt), map (tcf d) ts, lpsv sv)
418    
419         | SWITCH (sv, reps, cases, opp) =>
420             let val nsv = lpsv sv
421                 val ncases = map (fn (c, x) => (c, loop x)) cases
422                 val nopp = (case opp of NONE => NONE
423                                       | SOME x => SOME(loop x))
424              in SWITCH(nsv, reps, ncases, nopp)
425             end
426    
427         | RECORD vs => RECORD (map lpsv vs)
428         | SRECORD vs => SRECORD (map lpsv vs)
429         | VECTOR (vs, t) => VECTOR(map lpsv vs, tcf d t)
430         | SELECT (i, sv) => SELECT(i, lpsv sv)
431         | ETAG (sv, t) => ETAG(lpsv sv, ltf d t)
432         | RAISE (sv, t) => RAISE(lpsv sv, ltf d t)
433         | HANDLE (e, sv) => HANDLE(loop e, lpsv sv)
434         | _ => bug "unexpected lambda expression in transform")
435    
            | SWITCH (v, csig, cases, opp) =>  
                SWITCH(lpvar v, csig, map lpcon cases,  
                       case opp of NONE => NONE | SOME e => SOME(loop e))  
            | CON (dc, ts, u, v, e) =>  
                lplet (v, e, fn ne => CON(lpdc dc, map tcf ts, lpvar u, v, ne))  
   
            | RECORD (rk as RK_VECTOR t, vs, v, e) =>  
                lplet (v, e, fn ne => RECORD(RK_VECTOR (tcf t),  
                                             lpvars vs, v, ne))  
            | RECORD(rk, vs, v, e) =>  
                lplet (v, e, fn ne => RECORD(rk, lpvars vs, v, ne))  
            | SELECT (u, i, v, e) =>  
                lplet (v, e, fn ne => SELECT(lpvar u, i, v, ne))  
   
            | RAISE (sv, ts) =>  
                let val nts = map ltf ts  
                    val nsv = lpvar sv  
                 in if did_flat then  
                      let val (_, nnts, _) = PF.t_flatten(nts, false)  
                       in RAISE(nsv, nnts)  
                      end  
                    else  
                      RAISE(nsv, nts)  
                end  
            | HANDLE (e, v) => HANDLE(loop e, lpvar v)  
   
            | BRANCH (p, vs, e1, e2) =>  
                BRANCH(lpprim p, lpvars vs, loop e1, loop e2)  
            | PRIMOP (p, vs, v, e) =>  
                lplet (v, e, fn ne => PRIMOP(lpprim p, lpvars vs, v, ne))  
            | _ => bug "unexpected lexps in loop")  
436     in loop     in loop
437    end (* function transform *)    end (* function transform *)
438    
439  in  (* Definition of the main function *)
440  (case fdec  fun specLexp (FN(v, t, e)) =
441    of (fk as FK_FCT, f, vts, e) =>        let val tcf = fn (d : DI.depth) => fn (x : LD.tyc) => x
442        let val tcfg = fn (d : DI.depth) => fn (x : LD.tyc) => x            val ltf = fn (d : DI.depth) => fn (x : LD.lty) => x
           val ltfg = fn (d : DI.depth) => fn (x : LD.lty) => x  
443            val ienv = initInfoEnv()            val ienv = initInfoEnv()
444            val d = DI.top            val d = DI.top
445            val _ = app (fn (x,_) => entDtable(ienv, x, (d, ESCAPE))) vts            val _ = entDtable(ienv, v, (d, ESCAPE))
446            val ne = transform (ienv, d, ltfg, tcfg, d, false) e            val ne = transform (ienv, ltf, tcf, d) e
447            val hdr = chkOutEscs (ienv, map #1 vts)            val hdr = chkOutEsc(ienv, v)
448            val nfdec = (fk, f, vts, hdr ne) before (cleanUp())  
449         in if (num_click()) > 0 then LContract.lcontract nfdec            (*** invariant: itable should be empty ! ***)
450            (* if we did specialize, we run a round of lcontract on the result *)         in FN(v, t, hdr ne)
           else nfdec  
451        end        end
452     | _ => bug "non FK_FCT program in specialize")    | specLexp _ = bug "unexpected lambda expressions specLexp"
 end (* function specialize *)  
453    
454  end (* toplevel local *)  end (* toplevel local *)
455  end (* structure Specialize *)  end (* structure Specialize *)

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

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