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 258, Wed Apr 21 23:58:52 1999 UTC
+revision 259, Thu Apr 22 09:30:22 1999 UTC
 Line 4
  signature FCONTRACT =
  sig
+     type options = {etaSplit : bool, tfnInline : bool}
      (* needs Collect to be setup properly *)
-     val contract : FLINT.prog -> FLINT.prog
+     val contract : options -> FLINT.prog -> FLINT.prog
  end
-Line 191
+Line 193
      structure CTRL = FLINT_Control
  in
- val say = Control_Print.say
+ fun say s = (Control_Print.say s; Control_Print.flush())
  fun bug msg = ErrorMsg.impossible ("FContract: "^msg)
  fun buglexp (msg,le) = (say "\n"; PP.printLexp le; bug msg)
  fun bugval (msg,v) = (say "\n"; PP.printSval v; bug msg)
-Line 201
+Line 203
  val cplv = LambdaVar.dupLvar
  val mklv = LambdaVar.mkLvar
+ type options = {etaSplit : bool, tfnInline : bool}
  datatype sval
    = Val    of F.value                   (* F.value should never be F.VAR lv *)
    | Fun    of F.lvar * F.lexp * (F.lvar * F.lty) list * F.fkind * sval list list ref
-   | TFun   of F.lvar * F.lexp * (F.tvar * F.tkind) list
+   | TFun   of F.lvar * F.lexp * (F.tvar * F.tkind) list * F.tfkind
    | Record of F.lvar * sval list
    | Con    of F.lvar * sval * F.dcon * F.tyc list
    | Decon  of F.lvar * sval * F.dcon * F.tyc list
-Line 279
+Line 283
  fun click s c = (if !CTRL.misc = 1 then say s else ();
                   c := !c + 1 (* Stats.addCounter c 1 *) )
- fun contract (fdec as (_,f,_,_)) = let
+ fun contract {etaSplit,tfnInline} (fdec as (_,f,_,_)) = let
      val c_dummy = ref 0 (* Stats.newCounter[] *)
      val c_miss = ref 0 (* Stats.newCounter[] *)
-Line 637
+Line 641
                               dropargs (fn xs => OU.filter used xs))
                          (* eta-split: add a wrapper for escaping uses *)
-                         else if C.escaping gi then
+                         else if etaSplit andalso C.escaping gi then
                              (* like dropargs but keeping all args *)
                              (click_etasplit(); dropargs (fn x => x))
-Line 758
+Line 762
  fun fcTfn ((tfk,f,args,body),le) =
      let val fi = C.get f
      in if C.dead fi then (click_deadlexp(); loop m le cont) else
-         let val nbody = fcexp ifs m body #2
+         let val saved_ic = inline_count()
-             val nm = addbind(m, f, TFun(f, nbody, args))
+             val nbody = fcexp ifs m body #2
+             val ntfk =
+                 if inline_count() = saved_ic then tfk else {inline=F.IH_SAFE}
+             val nm = addbind(m, f, TFun(f, nbody, args, tfk))
              val nle = loop nm le cont
          in
              if C.dead fi then nle else F.TFN((tfk, f, args, nbody), nle)
          end
      end
+ fun fcTapp (f,tycs) =
+     let val svf = val2sval m f
+     (* F.TAPP inlining (if any) *)
+         fun noinline () = (cont(m, F.TAPP(sval2val svf, tycs)))
+         fun specialize (g,tfk,args,body,tycs) =
+             let val prog =
+                     ({cconv=F.CC_FCT,inline=F.IH_SAFE,isrec=NONE,known=false},
+                      mklv(), [],
+                      F.TFN((tfk, g, args, body), F.TAPP(F.VAR g, tycs)))
+                 val F.LET(_,nprog,F.RET _) = #4(Specialize.specialize prog)
+             in PP.printLexp nprog; nprog end
+     in case (tfnInline,svf)
+         of (true,TFun(g,body,args,tfk as {inline,...})) =>
+            let val gi = C.get g
+                fun simpleinline () =
+                    (* simple inlining:  we should copy the body and then
+                     * kill the function, but instead we just move the body
+                     * and kill only the function name.
+                     * This inlining strategy looks inoffensive enough,
+                     * but still requires some care: see comments at the
+                     * begining of this file and in cfun *)
+                    (click_simpleinline();
+                     (*  say("simpleinline "^(C.LVarString g)^"\n"); *)
+                     ignore(C.unuse true gi);
+                     loop m (specialize(g, tfk, args, body, tycs)) cont)
+                fun copyinline () =
+                    (* aggressive inlining.  We allow pretty much
+                     * any inlinling, but we detect and reject inlining
+                     * recursively which would else lead to infinite loop *)
+                    let val nle = (F.TFN((tfk, g, args, body),
+                                         F.TAPP(F.VAR g, tycs)))
+                        val nle = C.copylexp M.empty nle
+                    in
+                        click_copyinline();
+                        (*  say("copyinline "^(C.LVarString g)^"\n"); *)
+                        unusecall m g;
+                        fcexp (S.add(g, ifs)) m nle cont
+                    end
+            in if C.usenb gi = 1 andalso not(S.member ifs g)
+               then noinline() (* simpleinline() *)
+               else case inline of
+                   F.IH_ALWAYS =>
+                   if S.member ifs g then noinline() else copyinline()
+                 | _ => noinline()
+            end
+          | sv => noinline()
+     end
  fun fcSwitch (v,ac,arms,def) =
      let fun fcsCon (lvc,svc,dc1:F.dcon,tycs1) =
              let fun killle le = C.unuselexp (undertake m) le
-Line 964
+Line 1025
        | F.FIX x => fcFix x
        | F.APP x => fcApp x
        | F.TFN x => fcTfn x
-       | F.TAPP (f,tycs) => cont(m, F.TAPP(substval f, tycs))
+       (* | F.TAPP (f,tycs) => cont(m, F.TAPP(substval f, tycs)) *)
+       | F.TAPP x => fcTapp x
        | F.SWITCH x => fcSwitch x
        | F.CON x => fcCon x
        | F.RECORD x => fcRecord x

 Legend:



Removed from v.258
 


changed lines


 
Added in v.259
 Legend:



Removed from v.258
 


changed lines


 
Added in v.259
-Removed from v.258
+Added in v.259

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