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 44, Sun Mar 22 20:10:57 1998 UTC revision 45, Sun Mar 22 20:11:09 1998 UTC
# Line 6  Line 6 
6    
7  signature SPECIALIZE =  signature SPECIALIZE =
8  sig  sig
9    val specLexp : Lambda.lexp -> Lambda.lexp    val specialize : FLINT.prog -> FLINT.prog
   
10  end (* signature SPECIALIZE *)  end (* signature SPECIALIZE *)
11    
12  structure Specialize : SPECIALIZE =  structure Specialize : SPECIALIZE =
# Line 17  Line 16 
16        structure LT = LtyExtern        structure LT = LtyExtern
17        structure DI = DebIndex        structure DI = DebIndex
18        structure PT = PrimTyc        structure PT = PrimTyc
19        open Lambda        structure PF = PFlatten
20          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  val mkv = LambdaVar.mkLvar  fun mkv _ = LambdaVar.mkLvar()
26  val ident = fn le : Lambda.lexp => le  val ident = fn le : FLINT.lexp => le
27  fun tvar i = LT.tcc_var(DI.innermost, i)  fun tvar i = LT.tcc_var(DI.innermost, i)
28    
29  fun mktvs ks =  val tk_tbx = LT.tkc_box (* the special boxed tkind *)
   let fun h (_::r, i, z) = h(r, i+1, (tvar i)::z)  
         | h ([], _, z) = rev z  
    in h (ks, 0, [])  
   end  
   
 (* the special box tkind *)  
 val tk_tbx = LT.tkc_box  
30  val tk_tmn = LT.tkc_mono  val tk_tmn = LT.tkc_mono
31  val tk_eqv = LT.tk_eqv  val tk_eqv = LT.tk_eqv
32    
# Line 46  Line 39 
39     in teq(xs, ys)     in teq(xs, ys)
40    end    end
41    
42    (* accounting functions; how many functions have been specialized *)
43    fun mk_click () =
44      let val x = ref 0
45          fun click () = (x := (!x) + 1)
46          fun num_click () = !x
47       in (click, num_click)
48      end
49    
50  (****************************************************************************  (****************************************************************************
51   *                  UTILITY FUNCTIONS FOR KIND AND TYPE BOUNDS              *   *                  UTILITY FUNCTIONS FOR KIND AND TYPE BOUNDS              *
52   ****************************************************************************)   ****************************************************************************)
# Line 58  Line 59 
59  datatype bnd  datatype bnd
60    = KBOX    = KBOX
61    | KTOP    | KTOP
62    | TBND of LD.tyc    | TBND of tyc
63    
64  type bnds = bnd list  type bnds = bnd list
65    
 datatype dinfo  
   = ESCAPE  
   | NOCSTR  
   | CSTR of bnds  
   
66  (** THE FOLLOWING FUNCTION IS NOT FULLY DEFINED *)  (** THE FOLLOWING FUNCTION IS NOT FULLY DEFINED *)
67  fun kBnd kenv tc =  fun kBnd kenv tc =
68    (if LT.tcp_var tc then    (if LT.tcp_var tc then
69       (let val (i,j) = LT.tcd_var tc       (let val (i,j) = LT.tcd_var tc
70            val (_,ks) = List.nth(kenv, i-1)            val (_,ks) = List.nth(kenv, i-1)
71                              handle _ => bug "unexpected case A in kBnd"                              handle _ => bug "unexpected case A in kBnd"
72               val k = List.nth(ks, j)               val (_,k) = List.nth(ks, j)
73                              handle _ => bug "unexpected case B in kBnd"                              handle _ => bug "unexpected case B in kBnd"
74         in if tk_eqv(tk_tbx, k) then KBOX else KTOP         in if tk_eqv(tk_tbx, k) then KBOX else KTOP
75        end)        end)
# Line 94  Line 90 
90    | tmBnd kenv (tc, x as TBND t) =    | tmBnd kenv (tc, x as TBND t) =
91        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)
92    
93  (*  
94   * Given a list of bnd information, return a list of filter info;  datatype spkind
95   * if all bounds are of TBND form, we got a full specialization,    = FULL
96   * we return NONE.    | PART of bool list (* filter indicator; which one is gone *)
97   *)  
98  fun bndFlt bnds =  datatype spinfo
99    let fun h ((TBND _)::bs, r, z) = h(bs, false::r, z)    = NOSP
100          | h (_::bs, r, _) = h(bs, true::r, false)    | NARROW of (tvar * tkind) list
101          | h ([], r, z) = if z then NONE else SOME (rev r)    | PARTSP of {ntvks: (tvar * tkind) list, nts: tyc list,
102     in h(bnds, [], true)                 masks: bool list}
103    end    | FULLSP of tyc list * lvar list
104    
105  (*  (*
106   * Given a list of default kinds, and a list of bnd information, and a   * Given a list of default kinds, and a list of bnd information, a depth,
107   * flag indicating whether it is full specialization;   * and the (tyc list * lvar list) list info in the itable, returns the
108   * two pieces of information: resOp of (tkind list option * tyc list) option   * the spinfo.
  * and the filterOp of (bool list) option  
109   *)   *)
110  fun bndGen(oks, bnds, fltOp, d) =  fun bndGen(oks, bnds, d, info) =
111    let val adj = case fltOp of NONE => (fn tc => tc)    let (** pass 1 **)
112          fun g ((TBND _)::bs, r, z) = g(bs, false::r, z)
113            | g (_::bs, r, _) = g(bs, true::r, false)
114            | g ([], r, z) = if z then FULL else PART (rev r)
115          val spk = g(bnds, [], true)
116    
117          val adj = case spk of FULL => (fn tc => tc)
118                              | _ => (fn tc => LT.tc_adj(tc, d, DI.next d))                              | _ => (fn tc => LT.tc_adj(tc, d, DI.next d))
119          (* no full-specializations, so we push one-level down *)          (* if not full-specializations, we push depth one-level down *)
120    
121        fun h([], [], i, [], ts, b) = (NONE, rev ts, b)        (** pass 2 **)
122          | h([], [], i, ks, ts, b) = (SOME(rev ks), rev ts, b)        val n = length oks
123          | h(ok::oks, (TBND tc)::bs, i, ks, ts, b) =  
124               h(oks, bs, i, ks, (adj tc)::ts, false)        (* invariants: n = length bnds = length (the-resulting-ts) *)
125          fun h([], [], i, [], ts, _) =
126                (case info of [(_, xs)] => FULLSP(rev ts, xs)
127                           | _ => bug "unexpected case in bndGen 3")
128            | h([], [], i, ks, ts, b) =
129                if b then NOSP else
130                 if i = n then NARROW (rev ks)
131                 else (case spk
132                        of PART masks =>
133                            PARTSP {ntvks=rev ks, nts=rev ts, masks=masks}
134                         | _ => bug "unexpected case 1 in bndGen")
135          | h(ok::oks, KTOP::bs, i, ks, ts, b) =          | h(ok::oks, KTOP::bs, i, ks, ts, b) =
136               h(oks, bs, i+1, ok::ks, (tvar i)::ts, b)               h(oks, bs, i+1, ok::ks, (tvar i)::ts, b)
137          | h(ok::oks, KBOX::bs, i, ks, ts, b) =          | h(ok::oks, (TBND tc)::bs, i, ks, ts, b) =
138                 h(oks, bs, i, ks, (adj tc)::ts, false)
139            | h((tv,ok)::oks, KBOX::bs, i, ks, ts, b) =
140               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 *)
141                   val nk = if tk_eqv(tk_tmn, ok) then tk_tbx else ok                   val (nk, b) =
142                in h(oks, bs, i+1, nk::ks, (tvar i)::ts, b)                     if tk_eqv(tk_tmn, ok) then (tk_tbx, false) else (ok, b)
143                  in h(oks, bs, i+1, (tv,nk)::ks, (tvar i)::ts, b)
144               end               end
145          | h _ = bug "unexpected cases in bndGen"          | h _ = bug "unexpected cases 2 in bndGen"
146    
147    
148        val (ksOp, ts, boring) = h(oks, bnds, 0, [], [], true)     in h(oks, bnds, 0, [], [], true)
    in if boring then ((ksOp, NONE), NONE)  
       else ((ksOp, SOME ts), SOME fltOp)  
149    end    end
150    
151    
# Line 141  Line 154 
154   ****************************************************************************)   ****************************************************************************)
155    
156  (*  (*
157   * We maintain a table mapping each lvar to a list of its use,   * We maintain a table mapping each lvar to its definition depth,
158   * indexed by its specific type instances.   * its type, and a list of its uses, indexed by its specific type
159     * instances.
160   *)   *)
161  exception ITABLE  exception ITABLE
162  exception DTABLE  exception DTABLE
163    
164    datatype dinfo
165      = ESCAPE
166      | NOCSTR
167      | CSTR of bnds
168    
169  type depth = DI.depth  type depth = DI.depth
170  type tkind = LD.tkind  type info = (tyc list * lvar list) list
171  type info = (tyc list * lvar) list  type itable = info Intmap.intmap   (* lvar -> (tyc list * lvar) *)
 type itable = info Intmap.intmap  
172  type dtable = (depth * dinfo) Intmap.intmap  type dtable = (depth * dinfo) Intmap.intmap
173  datatype infoEnv = IENV of (itable * tkind list) list * dtable  datatype infoEnv = IENV of (itable * (tvar * tkind) list) list * dtable
174    
175    (****************************************************************************
176     *              UTILITY FUNCTIONS FOR TYPE SPECIALIZATIONS                  *
177     ****************************************************************************)
178  (** initializing a new info environment : unit -> infoEnv *)  (** initializing a new info environment : unit -> infoEnv *)
179  fun initInfoEnv () =  fun initInfoEnv () =
180    let val itable : itable = Intmap.new (32, ITABLE)    let val itable : itable = Intmap.new (32, ITABLE)
# Line 174  Line 195 
195  (*  (*
196   * Register a dtable entry; modify the least upper bound of a particular   * Register a dtable entry; modify the least upper bound of a particular
197   * type binding; notice I am only moving kind info upwards, not type   * type binding; notice I am only moving kind info upwards, not type
198   * info, I could move type info upwards though, but it is just some   * info, I could move type info upwards though.
  * extra complications.  
199   *)   *)
200  fun regDtable (IENV(kenv, dtable), v, infos) =  fun regDtable (IENV(kenv, dtable), v, infos) =
201    let val (dd, dinfo) =    let val (dd, dinfo) =
# Line 184  Line 204 
204     in (case dinfo     in (case dinfo
205          of ESCAPE => ()          of ESCAPE => ()
206           | _ =>           | _ =>
207               (let fun h ((ts, _), ESCAPE) = ESCAPE               let fun h ((ts, _), ESCAPE) = ESCAPE
208                      | h ((ts, _), NOCSTR) = CSTR (map (kBnd kenv) ts)                      | h ((ts, _), NOCSTR) = CSTR (map (kBnd kenv) ts)
209                      | h ((ts, _), CSTR bnds) =                      | h ((ts, _), CSTR bnds) =
210                          let val nbnds = ListPair.map (kmBnd kenv) (ts, bnds)                          let val nbnds = ListPair.map (kmBnd kenv) (ts, bnds)
# Line 192  Line 212 
212                          end                          end
213                    val ndinfo = foldr h dinfo infos                    val ndinfo = foldr h dinfo infos
214                 in Intmap.add dtable (v, (dd, ndinfo))                 in Intmap.add dtable (v, (dd, ndinfo))
215                end))               end)
216    end    end (* function regDtable *)
217    
218  (*  (*
219   * Calculate the least upper bound of all type instances;   * Calculate the least upper bound of all type instances;
# Line 218  Line 238 
238    end    end
239    
240  (** look and add a new type instance into the itable *)  (** look and add a new type instance into the itable *)
241  fun lookItable (IENV (itabs,dtab), d, v, ts) =  fun lookItable (IENV (itabs,dtab), d, v, ts, getlty) =
242    let val (dd, _) =    let val (dd, _) =
243          ((Intmap.map dtab v) handle _ => bug "unexpected cases in lookItable")          ((Intmap.map dtab v) handle _ => bug "unexpected cases in lookItable")
244    
# Line 230  Line 250 
250        val nts = map (fn t => LT.tc_adj(t, d, nd)) ts        val nts = map (fn t => LT.tc_adj(t, d, nd)) ts
251        val xi = (Intmap.map itab v) handle _ => []        val xi = (Intmap.map itab v) handle _ => []
252    
253        fun h ((ots,x)::r) = if tcs_eqv(ots, nts) then (VAR x) else h r        fun h ((ots,xs)::r) = if tcs_eqv(ots, nts) then (map VAR xs) else h r
254          | h [] = let val nv =  mkv()          | h [] = let val oldt = getlty (VAR v)     (*** old type is ok ***)
255                       val _ = Intmap.add itab (v, (nts, nv)::xi)                       val bb = LT.lt_inst(oldt, ts)
256                    in VAR nv                       val nvs =  map mkv  bb
257                         val _ = Intmap.add itab (v, (nts, nvs)::xi)
258                      in map VAR nvs
259                   end                   end
260     in h xi     in h xi
261    end    end
262    
263  (** push a new layer of type abstraction : infoEnv -> infoEnv *)  (** push a new layer of type abstraction : infoEnv -> infoEnv *)
264  fun pushItable (IENV(itables, dtable), ks) =  fun pushItable (IENV(itables, dtable), tvks) =
265    let val nt : itable = Intmap.new(32, ITABLE)    let val nt : itable = Intmap.new(32, ITABLE)
266     in (IENV((nt,ks)::itables, dtable))     in (IENV((nt,tvks)::itables, dtable))
267    end    end
268    
269  (*  (*
# Line 254  Line 276 
276        let val infos = Intmap.intMapToList nt        let val infos = Intmap.intMapToList nt
277            fun h ((v,info), hdr) =            fun h ((v,info), hdr) =
278              let val _ = regDtable(ienv, v, info)              let val _ = regDtable(ienv, v, info)
279                  fun g ((ts, x), e) = LET(x, TAPP(VAR v, ts), e)                  fun g ((ts, xs), e) = LET(xs, TAPP(VAR v, ts), e)
280               in fn e => foldr g (hdr e) info               in fn e => foldr g (hdr e) info
281              end              end
282         in foldr h ident infos         in foldr h ident infos
# Line 265  Line 287 
287        bug "unexpected empty information env in chkOut"        bug "unexpected empty information env in chkOut"
288    | chkOutEsc (ienv as IENV((nt,_)::_, _), v) =    | chkOutEsc (ienv as IENV((nt,_)::_, _), v) =
289        let val info = (Intmap.map nt v) handle _ => []        let val info = (Intmap.map nt v) handle _ => []
290            fun g ((ts, x), e) = LET(x, TAPP(VAR v, ts), e)            fun g ((ts, xs), e) = LET(xs, TAPP(VAR v, ts), e)
291            val hdr = fn e => foldr g e info            val hdr = fn e => foldr g e info
292            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 *)
293         in hdr         in hdr
294        end        end
295    
296    fun chkOutEscs (ienv, vs) =
297      foldr (fn (v,h) => (chkOutEsc(ienv, v)) o h) ident vs
298    
299  (*  (*
300   * Check out a regular variable from the info env, build the header   * Check out a regular variable from the info env, build the header
301   * properly, of course, adjust the corresponding dtable entry.   * properly, of course, adjust the corresponding dtable entry.
# Line 280  Line 305 
305    
306    | chkOutNorm (ienv as IENV((nt,_)::_, dtable), v, oks, d) =    | chkOutNorm (ienv as IENV((nt,_)::_, dtable), v, oks, d) =
307        let val info = (Intmap.map nt v) handle _ => []        let val info = (Intmap.map nt v) handle _ => []
308            val (dd, dinfo) = sumDtable(ienv, v, info)            val (_, dinfo) = sumDtable(ienv, v, info)
309            val (resOp, filterOp) =            val spinfo =
310              (case dinfo              (case dinfo
311                of ESCAPE => ((NONE,NONE), NONE)                of ESCAPE => NOSP
312                 | NOCSTR => (* must be a dead function, let's double check *)                 | NOCSTR => (* must be a dead function, let's double check *)
313                     (case info of [] => ((NONE,NONE), NONE)                     (case info of [] => NOSP
314                                 | _ => bug "unexpected cases in chkOutNorm")                                 | _ => bug "unexpected cases in chkOutNorm")
315                 | CSTR bnds => bndGen(oks, bnds, bndFlt bnds, d))                 | CSTR bnds => bndGen(oks, bnds, d, info))
316    
317            fun tapp(e, ts, NONE) = TAPP(e, ts)            fun mkhdr((ts, xs), e) =
318              | tapp(e, ts, SOME (NONE)) = SVAL e              (case spinfo
319              | tapp(e, ts, SOME (SOME flags)) =                of FULLSP _ => e
320                   | PARTSP {masks, ...} =>
321                  let fun h([], [], z) = rev z                  let fun h([], [], z) = rev z
322                        | h(a::r, b::s, z) =                        | h(a::r, b::s, z) =
323                            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)
324                        | h _ = bug "unexpected cases in tapp"                        | h _ = bug "unexpected cases in tapp"
325                   in TAPP(e, h(ts, flags, []))                      in LET(xs, TAPP(VAR v, h(ts, masks, [])), e)
326                  end                  end
327                   | _ => LET(xs, TAPP(VAR v, ts), e))
328            fun g ((ts, x), e) = LET(x, tapp(VAR v, ts, filterOp), e)            val hdr = fn e => foldr mkhdr e info
           val hdr = fn e => foldr g e info  
329            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 *)
330         in (hdr, resOp)         in (hdr, spinfo)
331        end        end
332    
333  (****************************************************************************  (****************************************************************************
334   *                         MAIN FUNCTIONS                                   *   *                         MAIN FUNCTION                                    *
335   ****************************************************************************)   ****************************************************************************)
336    
337  (*  fun specialize fdec =
338   * Function transform has the following type:  let
339   *  
340   *    infoEnv * lty cvt * tyc cvt * DI.depth -> (lexp -> lexp)  val (click, num_click) = mk_click ()
341   *  
342    (* In pass1, we calculate the old type of each variables in the FLINT
343     * expression. The reason we can't merge this with the main pass is
344     * that the main pass traverse the code in different order.
345     * There must be a simpler way, but I didn't find one yet (ZHONG).
346     *)
347    val {getLty=getLtyGen, cleanUp} = Recover.recover fdec
348    
349    (* transform: infoEnv * DI.depth * lty cvt * tyc cvt
350                  * (value -> lty) * bool -> (lexp -> lexp)
351   *  where type 'a cvt = DI.depth -> 'a -> 'a   *  where type 'a cvt = DI.depth -> 'a -> 'a
352   *   * The 2nd argument is the depth of the resulting expression.
353   * The 2nd and 3rd arguments are used to encode the necessary type   * The 3rd and 4th arguments are used to encode the type translations.
354   * translations. The 4th argument is the depth the resulting expression   * The 5th argument is the depth information in the original code,
355   * will be at.   *    it is useful for the getlty.
356     * The 6th argument is a flag that indicates whether we need to
357     * flatten the return results of the current function.
358   *)   *)
359  fun transform (ienv, ltf, tcf, d) =  fun transform (ienv, d, ltfg, tcfg, gtd, did_flat) =
360  let    let val ltf = ltfg d
361          val tcf = tcfg d
362          val getlty = getLtyGen gtd
363    
364          (* we chkin and chkout polymorphic values only *)
365          fun chkin v = entDtable (ienv, v, (d, ESCAPE))
366          fun chkout v = chkOutEsc (ienv, v)
367          fun chkins vs = app chkin vs
368          fun chkouts vs = chkOutEscs (ienv, vs)
369    
370          (* lpvar : value -> value *)
371          fun lpvar (u as (VAR v)) = (escDtable(ienv, v); u)
372            | lpvar u = u
373    
374          (* lpvars : value list -> value list *)
375          fun lpvars vs = map lpvar vs
376    
377          (* lpprim : primop -> primop *)
378          fun lpprim (d, po, lt, ts) = (d, po, ltf lt, map tcf ts)
379    
380          (* lpdc : dcon -> dcon *)
381          fun lpdc (s, rep, lt) = (s, rep, ltf lt)
382    
383          (* lplet : lvar * lexp -> (lexp -> lexp) *)
384          fun lplet (v, e, cont) =
385            let val _ = chkin v
386                val ne = loop e
387             in cont ((chkout v) ne)
388            end
389    
390          (* lplets : lvar list * lexp -> (lexp -> lexp) *)
391          and lplets (vs, e, cont) =
392            let val _ = chkins vs
393                val ne = loop e
394             in cont ((chkouts vs) ne)
395            end
396    
397  fun lpsv sv =        (* lpcon : con * lexp -> con * lexp *)
398    (case sv        and lpcon (DATAcon (dc, ts, v), e) =
399      of (INT _ | WORD _ | INT32 _ | WORD32 _ | REAL _ | STRING _) => sv              (DATAcon (lpdc dc, map tcf ts, v), lplet(v, e, fn x => x))
400       | VAR v => (escDtable(ienv, v); sv)          | lpcon (c, e) = (c, loop e)
      | PRIM (p, lt, ts) => PRIM(p, ltf d lt, map (tcf d) ts)  
          (* I don't think this is really necessary because all primops  
             have closed types, but probably it is quite cheap *)  
      | GENOP(dict, p, lt, ts) => GENOP(dict, p, ltf d lt, map (tcf d) ts))  
401    
402  fun loop le =        (* lpfd : fundec -> fundec *** requires REWORK *** *)
403    (case le        and lpfd (fk as FK_FCT, f, vts, be) =
404      of SVAL sv => SVAL(lpsv sv)             (fk, f, map (fn (v,t) => (v, ltf t)) vts,
405       | TAPP(VAR v, ts) =>                     lplets (map #1 vts, be, fn e => e))
406           (SVAL(lookItable(ienv, d, v, map (tcf d) ts)))          | lpfd (fk as FK_FUN {fixed=fflag,isrec,known,inline}, f, vts, be) =
407       | TAPP(sv, ts) => TAPP(lpsv sv, map (tcf d) ts)             let (** first get the original arg and res types of f *)
408                   val (fflag', atys, rtys) = LT.ltd_arrow (getlty (VAR f))
409    
410                   (** just a sanity check; should turn it off later **)
411                   val (b1,b2) =
412                     if LT.ff_eqv (fflag, fflag') then LT.ffd_fspec fflag
413                     else bug "unexpected code in lpfd"
414    
415    
416                   (** get the newly specialized types **)
417                   val (natys, nrtys) = (map ltf atys, map ltf rtys)
418    
419       | TFN(ks, e) =>                 (** do we need flatten the arguments and the results *)
420           let val nienv = pushItable(ienv, ks)                 val ((arg_raw, arg_ltys, _), unflatten) =
421                     PF.v_unflatten (natys, b1)
422    
423                   val (body_raw, body_ltys, ndid_flat) = PF.t_flatten (nrtys, b2)
424    
425                   (** process the function body *)
426                   val nbe =
427                     if ndid_flat = did_flat then loop be
428                     else transform (ienv, d, ltfg, tcfg, gtd, ndid_flat) be
429    
430                   val (arg_lvs, nnbe) = unflatten (map #1 vts, nbe)
431    
432                   (** fix the isrec information *)
433                   val nisrec = case isrec of NONE => NONE
434                                            | SOME _ => SOME body_ltys
435                   val nfixed = LT.ffc_fspec(fflag, (arg_raw, body_raw))
436                   val nfk = FK_FUN {isrec=nisrec, fixed=nfixed,
437                                     known=known, inline=inline}
438    
439                in (nfk, f, ListPair.zip(arg_lvs, arg_ltys), nnbe)
440               end
441    
442          (* lptf : tfundec * lexp -> lexp *** Invariant: ne2 has been processed *)
443          and lptf ((v, tvks, e1), ne2) =
444            let val nienv = pushItable(ienv, tvks)
445               val nd = DI.next d               val nd = DI.next d
446               val ne = transform (nienv, ltf, tcf, nd) e              val ne1 = transform (nienv, nd, ltfg, tcfg, DI.next gtd, false) e1
447               val hdr = popItable nienv               val hdr = popItable nienv
448            in TFN(ks, hdr ne)           in TFN((v, tvks, hdr ne1), ne2)
449           end           end
450    
451       | LET(v, e1 as TFN(ks, be1), e2) =>        (* loop : lexp -> lexp *)
452           let val _ = entDtable(ienv, v, (d,NOCSTR))        and loop le =
453            (case le
454              of RET vs =>
455                   if did_flat then
456                     let val vts = map (ltf o getlty) vs
457                         val ((_,_,ndid_flat),flatten) = PF.v_flatten(vts, false)
458                      in if ndid_flat then
459                           let val (nvs, hdr) = flatten vs
460                            in hdr(RET nvs)
461                           end
462                         else RET(lpvars vs)
463                     end
464                   else RET(lpvars vs)
465               | LET(vs, e1, e2) =>
466                   let (* first get the original types *)
467                       val vtys = map (ltf o getlty o VAR) vs
468                       (* second get the newly specialized types *)
469                       val ((_, _, ndid_flat), unflatten) =
470                          PF.v_unflatten(vtys, false)
471                              (* treat the let type as always "cooked" *)
472                       val _ = chkins vs
473               val ne2 = loop e2               val ne2 = loop e2
474               val (hdr, resOp) = chkOutNorm(ienv, v, ks, d)                     val ne2 = (chkouts vs) ne2
475                       val (nvs, ne2) = unflatten(vs, ne2)
476    
477               val ne1 =               val ne1 =
478                 (case resOp                      if ndid_flat = did_flat then loop e1
479                   of (NONE, NONE) => loop e1                      else transform (ienv, d, ltfg, tcfg, gtd, ndid_flat) e1
480                    | (SOME nks, NONE) => loop(TFN(nks, be1))                  in LET(nvs, ne1, ne2)
481                    | (NONE, SOME nts) =>                 end
482                       let fun nltf nd lt =  
483                             (LT.lt_sp_adj(ks, ltf (DI.next nd) lt, nts, nd-d, 0))             | FIX(fdecs, e) => FIX(map lpfd fdecs, loop e)
484                           fun ntcf nd tc =             | APP(v, vs) =>
485                             (LT.tc_sp_adj(ks, tcf (DI.next nd) tc, nts, nd-d, 0))                 let val vty = getlty v
486                        in transform (ienv, nltf, ntcf, d) be1                  in if LT.ltp_fct vty then APP(lpvar v, lpvars vs)
487                       end                     else
488                       (** this unfortunately relies on the value restrictions *)                       let (** first get the original arg and res types of v *)
489                             val (fflag, atys, rtys) = LT.ltd_arrow vty
490                    | (SOME nks, SOME nts) =>                           val (b1, b2) = LT.ffd_fspec fflag
491                       (** assume nts is already shifted one level down *)  
492                       let val nienv = pushItable(ienv, nks)                           (** get the newly specialized types **)
493                           val xd = DI.next d                           val (natys, nrtys) = (map ltf atys, map ltf rtys)
494    
495                             val (nvs, hdr1) = (#2 (PF.v_flatten (natys, b1))) vs
496                             val hdr2 =
497                               if did_flat then ident
498                               else (let val ((_, _, ndid_flat), unflatten) =
499                                           PF.v_unflatten(nrtys, b2)
500                                         val fvs = map mkv nrtys
501                                      in if ndid_flat then
502                                           let val (nvs, xe) =
503                                                 unflatten(fvs, RET (map VAR fvs))
504                                            in fn le => LET(nvs, le, xe)
505                                           end
506                                         else ident
507                                     end)
508                          in hdr1 (APP(lpvar v, lpvars nvs))
509                         end
510                   end
511    
512                           fun nltf nd lt =             | TFN((v, tvks, e1), e2) =>
513                   let val _ = entDtable(ienv, v, (d,NOCSTR))
514                       val ne2 = loop e2
515                       val ks = map #2 tvks
516                       val (hdr2, spinfo) = chkOutNorm(ienv, v, tvks, d)
517                       val ne2 = hdr2 ne2
518                    in (case spinfo
519                         of NOSP => lptf((v, tvks, e1), ne2)
520                          | NARROW ntvks => lptf((v, ntvks, e1), ne2)
521                          | PARTSP {ntvks, nts, ...} =>
522                              (* assume nts is already shifted one level down *)
523                              let val nienv = pushItable(ienv, ntvks)
524                                  val xd = DI.next d
525                                  fun nltfg nd lt =
526                             let val lt1 = LT.lt_sp_sink(ks, lt, d, nd)                             let val lt1 = LT.lt_sp_sink(ks, lt, d, nd)
527                                 val lt2 = ltf (DI.next nd) lt1                                      val lt2 = ltfg (DI.next nd) lt1
528                              in (LT.lt_sp_adj(ks, lt2, nts, nd-xd, 0))                              in (LT.lt_sp_adj(ks, lt2, nts, nd-xd, 0))
529                             end                             end
530                           fun ntcf nd tc =                                fun ntcfg nd tc =
531                             let val tc1 = LT.tc_sp_sink(ks, tc, d, nd)                             let val tc1 = LT.tc_sp_sink(ks, tc, d, nd)
532                                 val tc2 = tcf (DI.next nd) tc1                                      val tc2 = tcfg (DI.next nd) tc1
533                              in (LT.tc_sp_adj(ks, tc2, nts, nd-xd, 0))                              in (LT.tc_sp_adj(ks, tc2, nts, nd-xd, 0))
534                             end                             end
535                           val nbe1 = transform (nienv, nltf, ntcf, xd) be1                                val ne1 =
536                                    transform (nienv, xd, nltfg, ntcfg,
537                                               DI.next gtd, false) e1
538                           val hdr0 = popItable nienv                           val hdr0 = popItable nienv
539                        in (TFN(nks, hdr0 nbe1))                             in TFN((v, ntvks, hdr0 ne1), ne2)
                      end)  
           in LET(v, ne1, hdr ne2)  
540           end           end
541                          | FULLSP (nts, xs) =>
542                              let fun nltfg nd lt =
543                                    (LT.lt_sp_adj(ks, ltfg (DI.next nd) lt,
544                                                  nts, nd-d, 0))
545                                  fun ntcfg nd tc =
546                                    (LT.tc_sp_adj(ks, tcfg (DI.next nd) tc,
547                                                  nts, nd-d, 0))
548                                  val ne1 = transform (ienv, d, nltfg, ntcfg,
549                                                       DI.next gtd, false) e1
550                               in click(); LET(xs, ne1, ne2)
551                              end)
552                   end  (* case TFN *)
553    
554       | LET(v, e1, e2) =>             | TAPP(u as VAR v, ts) =>
555           let val _ = entDtable(ienv, v, (d,ESCAPE))                 let val nts = map tcf ts
556               val ne2 = loop e2                     val vs = lookItable(ienv, d, v, nts, getlty)
557               val hdr = chkOutEsc(ienv, v)                  in if did_flat then
558            in LET(v, loop e1, hdr ne2)                       let val vts = LT.lt_inst(ltf (getlty u), nts)
559           end                           val ((_,_,ndid_flat),flatten) =
560                                PF.v_flatten(vts, false)
561       | FN(v, t, e) =>                        in if ndid_flat then
562           let val _ = entDtable(ienv, v, (d,ESCAPE))                             let val (nvs, hdr) = flatten vs
563               val ne = loop e                              in hdr(RET nvs)
564               val hdr = chkOutEsc(ienv, v)                             end
565            in FN(v, ltf d t, hdr ne)                           else RET vs
566           end                       end
567                       else RET vs
568       | FIX(vs, ts, es, eb) => FIX(vs, map (ltf d) ts, map loop es, loop eb)                 end
569           (* ASSUMPTIONS WE MADE HERE: all lvars defined in vs can't be  
570              polymorphic functions, that is, all ltys in ts must be             | SWITCH (v, csig, cases, opp) =>
571              monomorphic types *)                 SWITCH(lpvar v, csig, map lpcon cases,
572                          case opp of NONE => NONE | SOME e => SOME(loop e))
573       | APP(sv1, sv2) => APP(lpsv sv1, lpsv sv2)             | CON (dc, ts, u, v, e) =>
574                   lplet (v, e, fn ne => CON(lpdc dc, map tcf ts, lpvar u, v, ne))
575       | PACK (lt, ts, nts, sv) =>  
576           PACK(ltf d lt, map (tcf d) ts, map (tcf d) nts, lpsv sv)             | RECORD (rk as RK_VECTOR t, vs, v, e) =>
577                   lplet (v, e, fn ne => RECORD(RK_VECTOR (tcf t),
578       | CON ((s,r,lt), ts, sv) =>                                              lpvars vs, v, ne))
579           CON((s, r, ltf d lt), map (tcf d) ts, lpsv sv)             | RECORD(rk, vs, v, e) =>
580                   lplet (v, e, fn ne => RECORD(rk, lpvars vs, v, ne))
581       | DECON ((s,r,lt), ts, sv) =>             | SELECT (u, i, v, e) =>
582           DECON((s, r, ltf d lt), map (tcf d) ts, lpsv sv)                 lplet (v, e, fn ne => SELECT(lpvar u, i, v, ne))
583    
584       | SWITCH (sv, reps, cases, opp) =>             | RAISE (sv, ts) =>
585           let val nsv = lpsv sv                 let val nts = map ltf ts
586               val ncases = map (fn (c, x) => (c, loop x)) cases                     val nsv = lpvar sv
587               val nopp = (case opp of NONE => NONE                  in if did_flat then
588                                     | SOME x => SOME(loop x))                       let val (_, nnts, _) = PF.t_flatten(nts, false)
589            in SWITCH(nsv, reps, ncases, nopp)                        in RAISE(nsv, nnts)
590           end                       end
591                       else
592       | RECORD vs => RECORD (map lpsv vs)                       RAISE(nsv, nts)
593       | SRECORD vs => SRECORD (map lpsv vs)                 end
594       | VECTOR (vs, t) => VECTOR(map lpsv vs, tcf d t)             | HANDLE (e, v) => HANDLE(loop e, lpvar v)
595       | SELECT (i, sv) => SELECT(i, lpsv sv)  
596       | ETAG (sv, t) => ETAG(lpsv sv, ltf d t)             | BRANCH (p, vs, e1, e2) =>
597       | RAISE (sv, t) => RAISE(lpsv sv, ltf d t)                 BRANCH(lpprim p, lpvars vs, loop e1, loop e2)
598       | HANDLE (e, sv) => HANDLE(loop e, lpsv sv)             | PRIMOP (p, vs, v, e) =>
599       | _ => bug "unexpected lambda expression in transform")                 lplet (v, e, fn ne => PRIMOP(lpprim p, lpvars vs, v, ne))
600               | _ => bug "unexpected lexps in loop")
601   in loop   in loop
602  end (* function transform *)  end (* function transform *)
603    
604  (* Definition of the main function *)  in
605  fun specLexp (FN(v, t, e)) =  (case fdec
606        let val tcf = fn (d : DI.depth) => fn (x : LD.tyc) => x    of (fk as FK_FCT, f, vts, e) =>
607            val ltf = fn (d : DI.depth) => fn (x : LD.lty) => x        let val tcfg = fn (d : DI.depth) => fn (x : LD.tyc) => x
608              val ltfg = fn (d : DI.depth) => fn (x : LD.lty) => x
609            val ienv = initInfoEnv()            val ienv = initInfoEnv()
610            val d = DI.top            val d = DI.top
611            val _ = entDtable(ienv, v, (d, ESCAPE))            val _ = app (fn (x,_) => entDtable(ienv, x, (d, ESCAPE))) vts
612            val ne = transform (ienv, ltf, tcf, d) e            val ne = transform (ienv, d, ltfg, tcfg, d, false) e
613            val hdr = chkOutEsc(ienv, v)            val hdr = chkOutEscs (ienv, map #1 vts)
614              val nfdec = (fk, f, vts, hdr ne) before (cleanUp())
615            (*** invariant: itable should be empty ! ***)         in if (num_click()) > 0 then LContract.lcontract nfdec
616         in FN(v, t, hdr ne)            (* if we did specialize, we run a round of lcontract on the result *)
617              else nfdec
618        end        end
619    | specLexp _ = bug "unexpected lambda expressions specLexp"     | _ => bug "non FK_FCT program in specialize")
620    end (* function specialize *)
621    
622  end (* toplevel local *)  end (* toplevel local *)
623  end (* structure Specialize *)  end (* structure Specialize *)

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

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