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

Diff of /sml/trunk/src/compiler/FLINT/opt/specialize.sml

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

revision 196, Fri Nov 20 18:16:19 1998 UTC revision 197, Sun Nov 22 01:25:23 1998 UTC
# Line 14  Line 14 
14    
15  local structure LD = LtyDef  local structure LD = LtyDef
16        structure LT = LtyExtern        structure LT = LtyExtern
17          structure LK = LtyKernel
18        structure DI = DebIndex        structure DI = DebIndex
19        structure PT = PrimTyc        structure PT = PrimTyc
20        structure PF = PFlatten        structure PF = PFlatten
# Line 21  Line 22 
22  in  in
23    
24  val say = Control.Print.say  val say = Control.Print.say
25  fun bug s = ErrorMsg.impossible ("Specialize: " ^ s)  fun bug s = ErrorMsg.impossible ("SpecializeNvar: " ^ s)
26  fun mkv _ = LambdaVar.mkLvar()  fun mkv _ = LambdaVar.mkLvar()
27  val ident = fn le : FLINT.lexp => le  val ident = fn le : FLINT.lexp => le
 fun tvar i = LT.tcc_var(DI.innermost, i)  
28    
29  val tk_tbx = LT.tkc_box (* the special boxed tkind *)  val tk_tbx = LT.tkc_box (* the special boxed tkind *)
30  val tk_tmn = LT.tkc_mono  val tk_tmn = LT.tkc_mono
# Line 132  Line 132 
132                      of PART masks =>                      of PART masks =>
133                          PARTSP {ntvks=rev ks, nts=rev ts, masks=masks}                          PARTSP {ntvks=rev ks, nts=rev ts, masks=masks}
134                       | _ => bug "unexpected case 1 in bndGen")                       | _ => 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)  
135          | h(ok::oks, (TBND tc)::bs, i, ks, ts, b) =          | h(ok::oks, (TBND tc)::bs, i, ks, ts, b) =
136               h(oks, bs, i, ks, (adj tc)::ts, false)               h(oks, bs, i, ks, (adj tc)::ts, false)
137            | h((ok as (tv,_))::oks, KTOP::bs, i, ks, ts, b) =
138                 h(oks, bs, i+1, ok::ks, (LT.tcc_nvar tv)::ts, b)
139          | h((tv,ok)::oks, KBOX::bs, i, ks, ts, b) =          | 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, b) =                   val (nk, b) =
142                     if tk_eqv(tk_tmn, ok) then (tk_tbx, false) else (ok, 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)                in h(oks, bs, i+1, (tv,nk)::ks, (LT.tcc_nvar tv)::ts, b)
144               end               end
145          | h _ = bug "unexpected cases 2 in bndGen"          | h _ = bug "unexpected cases 2 in bndGen"
146    
# Line 237  Line 237 
237                end))                end))
238    end    end
239    
240    (** find out the set of nvars in a list of tycs *)
241    fun tcs_nvars tcs = SortedList.foldmerge (map LK.tc_nvars tcs)
242    
243  (** look and add a new type instance into the itable *)  (** look and add a new type instance into the itable *)
244  fun lookItable (IENV (itabs,dtab), d, v, ts, getlty) =  fun lookItable (IENV (itabs,dtab), d, v, ts, getlty, nv_depth) =
245    let val (dd, _) =    let val (dd, _) =
246          ((Intmap.map dtab v) handle _ => bug "unexpected cases in lookItable")          ((Intmap.map dtab v) handle _ => bug "unexpected cases in lookItable")
247    
248        val nd = Int.max(dd, LT.tcs_depth(ts, d))        val nd = List.foldr Int.max dd (map nv_depth (tcs_nvars ts))
249    
250        val (itab,_) = ((List.nth(itabs, d-nd)) handle _ =>        val (itab,_) = ((List.nth(itabs, d-nd)) handle _ =>
251                        bug "unexpected itables in lookItable")                        bug "unexpected itables in lookItable")
# Line 334  Line 337 
337   *                         MAIN FUNCTION                                    *   *                         MAIN FUNCTION                                    *
338   ****************************************************************************)   ****************************************************************************)
339    
340    (***** the substitution intmapf: named variable -> tyc *********)
341    type smap = (tvar * tyc) list
342    val initsmap = []
343    
344    fun mergesmaps (s1:smap as h1::t1, s2:smap as h2::t2) =
345        (case Int.compare (#1 h1, #1 h2) of
346             LESS => h1 :: (mergesmaps (t1, s2))
347           | GREATER => h2 :: (mergesmaps (s1, t2))
348           | EQUAL => h1 :: (mergesmaps (t1, t2)) (* drop h2 *)
349             )
350      | mergesmaps (s1, []) = s1
351      | mergesmaps ([], s2) = s2
352    
353    fun addsmap (tvks, ts, smap) =
354        let
355            fun select ((tvar,tkind),tyc) = (tvar,tyc)
356            val tvtcs = ListPair.map select (tvks, ts)
357            fun cmp ((tvar1,_), (tvar2,_)) = tvar1 > tvar2
358            val tvtcs = Sort.sort cmp tvtcs
359        in
360            mergesmaps (tvtcs, smap)
361        end
362    (***** end of the substitution intmapf hack *********************)
363    
364    (***** the nvar-depth intmapf: named variable -> DI.depth *********)
365    type nmap = DI.depth IntmapF.intmap
366    val initnmap = IntmapF.empty
367    fun addnmap (tvks, d, nmap) =
368      let fun h ((tv,_)::xs, nmap) =
369               h(xs, IntmapF.add(nmap, tv, d))
370            | h ([], nmap) = nmap
371       in h(tvks, nmap)
372      end
373    fun looknmap nmap nvar =
374        ((IntmapF.lookup nmap nvar) handle IntmapF.IntmapF =>
375         bug "unexpected case in looknmap")
376    (***** end of the substitution intmapf hack *********************)
377    
378    fun phase x = Stats.doPhase (Stats.makePhase x)
379    val recover = (* phase "Compiler 053 recover" *) Recover.recover
380    
381  fun specialize fdec =  fun specialize fdec =
382  let  let
383    
# Line 344  Line 388 
388   * that the main pass traverse the code in different order.   * that the main pass traverse the code in different order.
389   * There must be a simpler way, but I didn't find one yet (ZHONG).   * There must be a simpler way, but I didn't find one yet (ZHONG).
390   *)   *)
391  val {getLty=getLtyGen, cleanUp} = Recover.recover(fdec, false)  val {getLty=getlty, cleanUp} = recover(fdec, false)
392    
393  (* transform: infoEnv * DI.depth * lty cvt * tyc cvt  (* transform: infoEnv * DI.depth * lty cvt * tyc cvt
394                * (value -> lty) * bool -> (lexp -> lexp)                * smap * bool -> (lexp -> lexp)
395   *            where type 'a cvt = DI.depth -> 'a -> 'a   *            where type 'a cvt = DI.depth -> 'a -> 'a
396   * The 2nd argument is the depth of the resulting expression.   * The 2nd argument is the depth of the resulting expression.
397   * The 3rd and 4th arguments are used to encode the type translations.   * The 3rd and 4th arguments are used to encode the type translations.
398   * The 5th argument is the depth information in the original code,   * The 5th argument is the substitution map.
  *    it is useful for the getlty.  
399   * The 6th argument is a flag that indicates whether we need to   * The 6th argument is a flag that indicates whether we need to
400   * flatten the return results of the current function.   * flatten the return results of the current function.
401   *)   *)
402  fun transform (ienv, d, ltfg, tcfg, gtd, did_flat) =  val tc_nvar_subst = LT.tc_nvar_subst_gen()
403    let val ltf = ltfg d  val lt_nvar_subst = LT.lt_nvar_subst_gen()
404        val tcf = tcfg d  
405        val getlty = getLtyGen gtd  fun transform (ienv, d, nmap, smap, did_flat) =
406      let val tcf = tc_nvar_subst smap
407          val ltf = lt_nvar_subst smap
408          val nv_depth = looknmap nmap
409    
410        (* we chkin and chkout polymorphic values only *)        (* we chkin and chkout polymorphic values only *)
411        fun chkin v = entDtable (ienv, v, (d, ESCAPE))        fun chkin v = entDtable (ienv, v, (d, ESCAPE))
# Line 412  Line 458 
458                   if LT.ff_eqv (fflag, fflag') then LT.ffd_fspec fflag                   if LT.ff_eqv (fflag, fflag') then LT.ffd_fspec fflag
459                   else bug "unexpected code in lpfd"                   else bug "unexpected code in lpfd"
460    
   
461                 (** get the newly specialized types **)                 (** get the newly specialized types **)
462                 val (natys, nrtys) = (map ltf atys, map ltf rtys)                 val (natys, nrtys) = (map ltf atys, map ltf rtys)
463    
# Line 425  Line 470 
470                 (** process the function body *)                 (** process the function body *)
471                 val nbe =                 val nbe =
472                   if ndid_flat = did_flat then loop be                   if ndid_flat = did_flat then loop be
473                   else transform (ienv, d, ltfg, tcfg, gtd, ndid_flat) be                   else transform (ienv, d, nmap, smap, ndid_flat) be
474    
475                 val (arg_lvs, nnbe) = unflatten (map #1 vts, nbe)                 val (arg_lvs, nnbe) = unflatten (map #1 vts, nbe)
476    
# Line 443  Line 488 
488        and lptf ((v, tvks, e1), ne2) =        and lptf ((v, tvks, e1), ne2) =
489          let val nienv = pushItable(ienv, tvks)          let val nienv = pushItable(ienv, tvks)
490              val nd = DI.next d              val nd = DI.next d
491              val ne1 = transform (nienv, nd, ltfg, tcfg, DI.next gtd, false) e1              val nnmap = addnmap(tvks, nd, nmap)
492                val ne1 = transform (nienv, nd, nnmap, smap, false) e1
493              val hdr = popItable nienv              val hdr = popItable nienv
494           in TFN((v, tvks, hdr ne1), ne2)           in TFN((v, tvks, hdr ne1), ne2)
495          end          end
# Line 476  Line 522 
522    
523                     val ne1 =                     val ne1 =
524                      if ndid_flat = did_flat then loop e1                      if ndid_flat = did_flat then loop e1
525                      else transform (ienv, d, ltfg, tcfg, gtd, ndid_flat) e1                      else transform (ienv, d, nmap, smap, ndid_flat) e1
526                  in LET(nvs, ne1, ne2)                  in LET(nvs, ne1, ne2)
527                 end                 end
528    
# Line 522  Line 568 
568                            (* assume nts is already shifted one level down *)                            (* assume nts is already shifted one level down *)
569                            let val nienv = pushItable(ienv, ntvks)                            let val nienv = pushItable(ienv, ntvks)
570                                val xd = DI.next d                                val xd = DI.next d
571                                fun nltfg nd lt =                                val nnmap = addnmap(ntvks, xd, nmap)
572                                  let val lt1 = LT.lt_sp_sink(ks, lt, d, nd)                                val nsmap = addsmap(tvks, nts, smap)
                                     val lt2 = ltfg (DI.next nd) lt1  
                                  in (LT.lt_sp_adj(ks, lt2, nts, nd-xd, 0))  
                                 end  
                               fun ntcfg nd tc =  
                                 let val tc1 = LT.tc_sp_sink(ks, tc, d, nd)  
                                     val tc2 = tcfg (DI.next nd) tc1  
                                  in (LT.tc_sp_adj(ks, tc2, nts, nd-xd, 0))  
                                 end  
573                                val ne1 =                                val ne1 =
574                                  transform (nienv, xd, nltfg, ntcfg,                                  transform (nienv, xd, nnmap, nsmap, false) e1
                                            DI.next gtd, false) e1  
575                                val hdr0 = popItable nienv                                val hdr0 = popItable nienv
576                             in TFN((v, ntvks, hdr0 ne1), ne2)                             in TFN((v, ntvks, hdr0 ne1), ne2)
577                            end                            end
578                        | FULLSP (nts, xs) =>                        | FULLSP (nts, xs) =>
579                            let fun nltfg nd lt =                            let
580                                  (LT.lt_sp_adj(ks, ltfg (DI.next nd) lt,                                val nnmap = addnmap(tvks, d, nmap)
581                                                nts, nd-d, 0))                                val nsmap = addsmap(tvks, nts, smap)
582                                fun ntcfg nd tc =                                val ne1 = transform (ienv, d, nnmap, nsmap, false) e1
                                 (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  
583                             in click(); LET(xs, ne1, ne2)                             in click(); LET(xs, ne1, ne2)
584                            end)                            end)
585                 end  (* case TFN *)                 end  (* case TFN *)
586    
587             | TAPP(u as VAR v, ts) =>             | TAPP(u as VAR v, ts) =>
588                 let val nts = map tcf ts                 let val nts = map tcf ts
589                     val vs = lookItable(ienv, d, v, nts, getlty)                     val vs = lookItable(ienv, d, v, nts, getlty, nv_depth)
590                  in if did_flat then                  in if did_flat then
591                       let val vts = LT.lt_inst(ltf (getlty u), nts)                       let val vts = LT.lt_inst(ltf (getlty u), nts)
592                           val ((_,_,ndid_flat),flatten) =                           val ((_,_,ndid_flat),flatten) =
# Line 604  Line 637 
637  in  in
638  (case fdec  (case fdec
639    of (fk as {cconv=CC_FCT, ...}, f, vts, e) =>    of (fk as {cconv=CC_FCT, ...}, f, vts, e) =>
640        let val tcfg = fn (d : DI.depth) => fn (x : LD.tyc) => x        let val ienv = initInfoEnv()
           val ltfg = fn (d : DI.depth) => fn (x : LD.lty) => x  
           val ienv = initInfoEnv()  
641            val d = DI.top            val d = DI.top
642            val _ = app (fn (x,_) => entDtable(ienv, x, (d, ESCAPE))) vts            val _ = app (fn (x,_) => entDtable(ienv, x, (d, ESCAPE))) vts
643            val ne = transform (ienv, d, ltfg, tcfg, d, false) e            val ne = transform (ienv, d, initnmap, initsmap, false) e
644            val hdr = chkOutEscs (ienv, map #1 vts)            val hdr = chkOutEscs (ienv, map #1 vts)
645            val nfdec = (fk, f, vts, hdr ne) before (cleanUp())            val nfdec = (fk, f, vts, hdr ne) before (cleanUp())
646         in if (num_click()) > 0 then (*  LContract.lcontract *) nfdec         in if (num_click()) > 0 then (*  LContract.lcontract *) nfdec

Legend:
Removed from v.196  
changed lines
  Added in v.197

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