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/fcontract.sml
 [smlnj] / sml / trunk / src / compiler / FLINT / opt / fcontract.sml

# Diff of /sml/trunk/src/compiler/FLINT/opt/fcontract.sml

revision 201, Sat Nov 28 23:32:48 1998 UTC revision 202, Sun Dec 13 02:29:45 1998 UTC
# Line 187  Line 187
187      structure LT = LtyExtern      structure LT = LtyExtern
188      structure LK = LtyKernel      structure LK = LtyKernel
189      structure OU = OptUtils      structure OU = OptUtils
190        structure PO = PrimOp
191      structure CTRL = Control.FLINT      structure CTRL = Control.FLINT
192  in  in
193
# Line 202  Line 203
203
204  datatype sval  datatype sval
205    = Val    of F.value                   (* F.value should never be F.VAR lv *)    = Val    of F.value                   (* F.value should never be F.VAR lv *)
206    | Fun    of F.lvar * F.lexp * (F.lvar * F.lty) list * F.fkind    | Fun    of F.lvar * F.lexp * (F.lvar * F.lty) list * F.fkind * sval list list ref
207    | TFun   of F.lvar * F.lexp * (F.tvar * F.tkind) list    | TFun   of F.lvar * F.lexp * (F.tvar * F.tkind) list
208    | Record of F.lvar * sval list    | Record of F.lvar * sval list
209    | Con    of F.lvar * sval * F.dcon * F.tyc list    | Con    of F.lvar * sval * F.dcon * F.tyc list
# Line 273  Line 274
274          end          end
275      end      end
276
277    fun inScope m lv = (M.lookup m lv; true) handle M.IntmapF => false
278
279  fun click s c = (if !CTRL.misc = 1 then say s else (); Stats.addCounter c 1)  fun click s c = (if !CTRL.misc = 1 then say s else (); Stats.addCounter c 1)
280
281  (*  val c_inline         = Stats.newCounter[] *)  (*  val c_inline         = Stats.newCounter[] *)
# Line 287  Line 290
290  (*  val c_etasplit       = Stats.newCounter[] *)  (*  val c_etasplit       = Stats.newCounter[] *)
291  (*  val c_branch         = Stats.newCounter[] *)  (*  val c_branch         = Stats.newCounter[] *)
292  (*  val c_dropargs       = Stats.newCounter[] *)  (*  val c_dropargs       = Stats.newCounter[] *)
293        val c_cstarg = Stats.newCounter[]
294        val c_outofscope = Stats.newCounter[]
295        val _ = Stats.registerStat(Stats.newStat("FC-cstarg", [c_cstarg]))
296        val _ = Stats.registerStat(Stats.newStat("FC-outofscope", [c_outofscope]))
297
298  fun contract (fdec as (_,f,_,_), counter) = let  fun contract (fdec as (_,f,_,_), counter) = let
299
# Line 322  Line 329
329                        (say("while in FContract.used "^(C.LVarString lv)^"\n");                        (say("while in FContract.used "^(C.LVarString lv)^"\n");
330                         raise x) *)                         raise x) *)
331
fun impurePO po = true              (* if a PrimOP is pure or not *)

332      fun eqConV (F.INTcon i1,    F.INT i2)       = i1 = i2      fun eqConV (F.INTcon i1,    F.INT i2)       = i1 = i2
333        | eqConV (F.INT32con i1,  F.INT32 i2)     = i1 = i2        | eqConV (F.INT32con i1,  F.INT32 i2)     = i1 = i2
334        | eqConV (F.WORDcon i1,   F.WORD i2)      = i1 = i2        | eqConV (F.WORDcon i1,   F.WORD i2)      = i1 = i2
# Line 333  Line 338
338        | eqConV (con,v) = bugval("unexpected comparison with val", v)        | eqConV (con,v) = bugval("unexpected comparison with val", v)
339
340      fun lookup m lv = (M.lookup m lv)      fun lookup m lv = (M.lookup m lv)
341                            (* handle e as M.IntmapF =>                            handle e as M.IntmapF =>
342                            (say "\nlooking up unbound ";                            (say "\nlooking up unbound ";
343                             say (!PP.LVarString lv);                             say (!PP.LVarString lv);
344                             raise e) *)                             raise e)
345
346      fun sval2val sv =      fun sval2val sv =
347          case sv          case sv
# Line 365  Line 370
370          in case lookup m lv          in case lookup m lv
371              of Var {1=nlv,...}   => ()              of Var {1=nlv,...}   => ()
372               | Val v             => ()               | Val v             => ()
373               | Fun (lv,le,args,_) =>               | Fun (lv,le,args,_,_) =>
374                 C.unuselexp undertake                 C.unuselexp undertake
375                             (F.LET(map #1 args,                             (F.LET(map #1 args,
376                                    F.RET (map (fn _ => F.INT 0) args),                                    F.RET (map (fn _ => F.INT 0) args),
# Line 492  Line 497
497            end)            end)
498
499  fun fcFix (fs,le) =  fun fcFix (fs,le) =
500      let (* The actual function contraction *)      let (* merge actual arguments to extract the constant subpart *)
501          fun fcFun (m,[]:F.fundec list,acc) = acc          fun merge_actuals ((lv,lty),[],m) = addbind(m, lv, Var(lv, SOME lty))
502            | fcFun (m,fdec as ({inline,cconv,known,isrec},f,args,body)::fs,acc) =            | merge_actuals ((lv,lty),a::bs,m) = addbind(m, lv, Var(lv, SOME lty))
503                (* FIXME:  there's a bug here, but it's not caught by chkflint
504                   let fun f (b::bs) =
505                        if sval2val a = sval2val b then f bs
506                        else addbind(m, lv, Var(lv, SOME lty))
507                      | f [] =
508                        (click "C" c_cstarg;
509                         case sval2val a
510                          of v as F.VAR lv' =>
511                             (* FIXME: this inScope check is wrong for non-recursive
512                              * functions.  But it only matters if the function is
513                              * passed itself as a parameter which cannot happen
514                              * with the current type system I believe. *)
515                             if inScope m lv' then
516                                 let val sv =
517                                         case a of Var (v,NONE) => Var(v, SOME lty)
518                                                 | _ => a
519                                 in substitute(m, lv, sv, v)
520                                 end
521                             else (click "O" c_outofscope;
522
523                                   addbind(m, lv, Var(lv, SOME lty)))
524                           | v => substitute(m, lv, a, v))
525                in f bs
526                end *)
527            (* The actual function contraction *)
528            fun fcFun (m,[],acc) = acc
529              | fcFun (m,(f,body,args,fk as {inline,cconv,known,isrec},actuals)::fs,
530                       acc) =
531              let val fi = C.get f              let val fi = C.get f
532              in if C.dead fi then fcFun(m, fs, acc)              in if C.dead fi then fcFun(m, fs, acc)
533                 else if C.iusenb fi = C.usenb fi then                 else if C.iusenb fi = C.usenb fi then
# Line 505  Line 538
538                     let (*  val _ = say ("\nEntering "^(C.LVarString f)) *)                     let (*  val _ = say ("\nEntering "^(C.LVarString f)) *)
539                         val saved_ic = inline_count()                         val saved_ic = inline_count()
540                         (* make up the bindings for args inside the body *)                         (* make up the bindings for args inside the body *)
541                         fun addnobind ((lv,lty),m) =                         val actuals = if isSome isrec orelse
542                             addbind(m, lv, Var(lv, SOME lty))                                          C.escaping fi orelse
543                         val nm = foldl addnobind m args                                          null(!actuals)
544                                         then map (fn _ => []) args
545                                         else OU.transpose(!actuals)
546                           val nm = ListPair.foldl merge_actuals m (args, actuals)
547                         (* contract the body and create the resulting fundec *)                         (* contract the body and create the resulting fundec *)
548                         val nbody = fcexp (S.add(f, ifs)) nm body #2                         val nbody = fcexp (S.add(f, ifs)) nm body #2
549                         (* if inlining took place, the body might be completely                         (* if inlining took place, the body might be completely
# Line 524  Line 560
560                          * gets inlined afterwards, the counts will reflect the                          * gets inlined afterwards, the counts will reflect the
561                          * new contracted code while we'll be working on the                          * new contracted code while we'll be working on the
562                          * the old uncontracted code *)                          * the old uncontracted code *)
563                         val nm = addbind(m, f, Fun(f, nbody, args, nfk))                         val nm = if null fs then nm else
564                               addbind(m, f, Fun(f, nbody, args, nfk, ref []))
565                     in fcFun(nm, fs, (nfk, f, args, nbody)::acc)                     in fcFun(nm, fs, (nfk, f, args, nbody)::acc)
566                     (*  before say ("\nExiting "^(C.LVarString f)) *)                     (*  before say ("\nExiting "^(C.LVarString f)) *)
567                     end                     end
568              end              end
569
570          (* check for eta redex *)          (* check for eta redex *)
571          fun fcEta (fdec as (fk,f,args,F.APP(F.VAR g,vs)):F.fundec,          fun fcEta (fdec as (f,F.APP(F.VAR g,vs),args,_,_),(m,fs,hs)) =
(m,fs,hs)) =
572              if List.length args = List.length vs andalso              if List.length args = List.length vs andalso
573                  OU.ListPair_all (fn (v,(lv,t)) =>                  OU.ListPair_all (fn (v,(lv,t)) =>
574                                   case v of F.VAR v => v = lv andalso lv <> g                                   case v of F.VAR v => v = lv andalso lv <> g
# Line 622  Line 658
658          val fs = foldl wrap [] fs          val fs = foldl wrap [] fs
659
660          (* register the new bindings (uncontracted for now) *)          (* register the new bindings (uncontracted for now) *)
661          val nm = foldl (fn (fdec as (fk,f,args,body),m) =>          val (nm,fs) = foldl (fn (fdec as (fk,f,args,body),(m,fs)) =>
662                          addbind(m, f, Fun(f, body, args, fk)))                               let val nf = (f, body, args, fk, ref [])
663                         m fs                               in (addbind(m, f, Fun nf), nf::fs) end)
664                                (m,[]) fs
665          (* check for eta redexes *)          (* check for eta redexes *)
666          val (nm,fs,_) = foldl fcEta (nm,[],[]) fs          val (nm,fs,_) = foldl fcEta (nm,[],[]) fs
667
668          (* move the inlinable functions to the end of the list *)          (* move the inlinable functions to the end of the list *)
669          val (f1s,f2s) =          val (f1s,f2s) =
670              List.partition (fn ({inline=F.IH_ALWAYS,...},_,_,_) => true              List.partition (fn (_,_,_,{inline=F.IH_ALWAYS,...},_) => true
671                               | _ => false) fs                               | _ => false) fs
672          val fs = f2s @ f1s          val fs = f2s @ f1s
673
# Line 646  Line 683
683            | [f1 as ({isrec=NONE,...},_,_,_),f2] =>            | [f1 as ({isrec=NONE,...},_,_,_),f2] =>
684              (* gross hack: `wrap' might have added a second              (* gross hack: `wrap' might have added a second
685               * non-recursive function.  we need to split them into               * non-recursive function.  we need to split them into
686               * 2 FIXes.  This is _very_ ad-hoc *)               * 2 FIXes.  This is _very_ ad-hoc.  We know that the wrapper
687                 * ("wrap") is inlinable while the main function ("fun") isn't,
688                 * so `wrap' is in f1s and `fun' is in f2s.  Hence `wrap' is after
689                 * `fun' when passed to fcFun which inverts the order, so
690                 * f1 is `wrap' and f2 is `fun'. *)
691              F.FIX([f2], F.FIX([f1], nle))              F.FIX([f2], F.FIX([f1], nle))
692            | _ => F.FIX(fs, nle)            | _ => F.FIX(fs, nle)
693      end      end
694
695  fun fcApp (f,vs) =  fun fcApp (f,vs) =
696      let val nvs = map substval vs      let val svs = map (val2sval m) vs
697          val svf = val2sval m f          val svf = val2sval m f
698      (* F.APP inlining (if any) *)      (* F.APP inlining (if any) *)
in case svf
of Fun(g,body,args,{inline,...}) =>
if (C.usenb(C.get g)) = 1 andalso not(S.member ifs g) then
699
700        in case svf
701            of Fun(g,body,args,{inline,...},actuals) =>
702               let val gi = C.get g
703                   fun noinline () =
704                       (actuals := svs :: (!actuals);
705                        cont(m,F.APP(sval2val svf, map sval2val svs)))
706                   fun simpleinline () =
707                 (* simple inlining:  we should copy the body and then                 (* simple inlining:  we should copy the body and then
708                  * kill the function, but instead we just move the body                  * kill the function, but instead we just move the body
709                  * and kill only the function name.                  * and kill only the function name.
# Line 666  Line 711
711                  * but still requires some care: see comments at the                  * but still requires some care: see comments at the
712                  * begining of this file and in cfun *)                  * begining of this file and in cfun *)
713                 (click_simpleinline();                 (click_simpleinline();
714                  ignore(C.unuse true (C.get g));                      ignore(C.unuse true gi);
715                  loop m (F.LET(map #1 args, F.RET vs, body)) cont)                  loop m (F.LET(map #1 args, F.RET vs, body)) cont)
716                   fun copyinline () =
717             (* aggressive inlining.  We allow pretty much             (* aggressive inlining.  We allow pretty much
718              * any inlinling, but we detect and reject inlining              * any inlinling, but we detect and reject inlining
719              * recursively which would else lead to infinite loop *)              * recursively which would else lead to infinite loop *)
# Line 682  Line 727
727              * unrolling, which means that unrolling will introduce              * unrolling, which means that unrolling will introduce
728              * a second occurence of the `only call' but at that point              * a second occurence of the `only call' but at that point
729              * f has already been killed. *)              * f has already been killed. *)
730             else if (inline = F.IH_ALWAYS andalso not(S.member ifs g)) then                     let val nle = (F.LET(map #1 args, F.RET vs, body))
731                 let val nle =                         val nle = C.copylexp M.empty nle
C.copylexp M.empty (F.LET(map #1 args, F.RET vs, body))
732                 in                 in
733                     click_copyinline();                     click_copyinline();
734                     (app (unuseval m) vs);                     (app (unuseval m) vs);
735                     unusecall m g;                     unusecall m g;
736                     fcexp (S.add(g, ifs)) m nle cont                     fcexp (S.add(g, ifs)) m nle cont
737                 end                 end
738             else cont(m,F.APP(sval2val svf, nvs))
739           | sv => cont(m,F.APP(sval2val svf, nvs))             in if C.usenb gi = 1 andalso not(S.member ifs g) then simpleinline()
740                  else case inline of
741                      F.IH_SAFE => noinline()
742                    | F.IH_UNROLL => noinline()
743                    | F.IH_ALWAYS =>
744                      if S.member ifs g then noinline() else copyinline()
745                    | F.IH_MAYBE(min,ws) =>
746                      if S.member ifs g then noinline() else let
747                          fun value w _ (Val _ | Con _ | Record _) = w
748                            | value w v (Fun (f,_,args,_,_)) =
749                              if C.usenb(C.get v) = 1 then w * 2 else w
750                            | value w _ _ = 0
751                          val s = (OU.foldl3 (fn (sv,w,(v,t),s) => value w v sv + s)
752                                             0 (svs,ws,args))
753                                      handle OU.Unbalanced => 0
754                      in if s > min then copyinline() else noinline()
755                      end
756               end
757             | sv => cont(m,F.APP(sval2val svf, map sval2val svs))
758      end      end
759
760  fun fcTfn ((f,args,body),le) =  fun fcTfn ((f,args,body),le) =
# Line 883  Line 945
945
946  fun fcPrimop (po,vs,lv,le) =  fun fcPrimop (po,vs,lv,le) =
947      let val lvi = C.get lv      let val lvi = C.get lv
948          val pure = not(impurePO po)          val pure = PO.purePrimop (#2 po)
949      in if pure andalso C.dead lvi then (click_deadval();loop m le cont) else      in if pure andalso C.dead lvi then (click_deadval();loop m le cont) else
950          let val nvs = map substval vs          let val nvs = map substval vs
951              val npo = cpo po              val npo = cpo po

Legend:
 Removed from v.201 changed lines Added in v.202