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
ViewVC logotype

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

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

revision 258, Wed Apr 21 23:58:52 1999 UTC revision 259, Thu Apr 22 09:30:22 1999 UTC
# Line 4  Line 4 
4  signature FCONTRACT =  signature FCONTRACT =
5  sig  sig
6    
7        type options = {etaSplit : bool, tfnInline : bool}
8    
9      (* needs Collect to be setup properly *)      (* needs Collect to be setup properly *)
10      val contract : FLINT.prog -> FLINT.prog      val contract : options -> FLINT.prog -> FLINT.prog
11    
12  end  end
13    
# Line 191  Line 193 
193      structure CTRL = FLINT_Control      structure CTRL = FLINT_Control
194  in  in
195    
196  val say = Control_Print.say  fun say s = (Control_Print.say s; Control_Print.flush())
197  fun bug msg = ErrorMsg.impossible ("FContract: "^msg)  fun bug msg = ErrorMsg.impossible ("FContract: "^msg)
198  fun buglexp (msg,le) = (say "\n"; PP.printLexp le; bug msg)  fun buglexp (msg,le) = (say "\n"; PP.printLexp le; bug msg)
199  fun bugval (msg,v) = (say "\n"; PP.printSval v; bug msg)  fun bugval (msg,v) = (say "\n"; PP.printSval v; bug msg)
# Line 201  Line 203 
203  val cplv = LambdaVar.dupLvar  val cplv = LambdaVar.dupLvar
204  val mklv = LambdaVar.mkLvar  val mklv = LambdaVar.mkLvar
205    
206    type options = {etaSplit : bool, tfnInline : bool}
207    
208  datatype sval  datatype sval
209    = Val    of F.value                   (* F.value should never be F.VAR lv *)    = Val    of F.value                   (* F.value should never be F.VAR lv *)
210    | Fun    of F.lvar * F.lexp * (F.lvar * F.lty) list * F.fkind * sval list list ref    | Fun    of F.lvar * F.lexp * (F.lvar * F.lty) list * F.fkind * sval list list ref
211    | TFun   of F.lvar * F.lexp * (F.tvar * F.tkind) list    | TFun   of F.lvar * F.lexp * (F.tvar * F.tkind) list * F.tfkind
212    | Record of F.lvar * sval list    | Record of F.lvar * sval list
213    | Con    of F.lvar * sval * F.dcon * F.tyc list    | Con    of F.lvar * sval * F.dcon * F.tyc list
214    | Decon  of F.lvar * sval * F.dcon * F.tyc list    | Decon  of F.lvar * sval * F.dcon * F.tyc list
# Line 279  Line 283 
283  fun click s c = (if !CTRL.misc = 1 then say s else ();  fun click s c = (if !CTRL.misc = 1 then say s else ();
284                   c := !c + 1 (* Stats.addCounter c 1 *) )                   c := !c + 1 (* Stats.addCounter c 1 *) )
285    
286  fun contract (fdec as (_,f,_,_)) = let  fun contract {etaSplit,tfnInline} (fdec as (_,f,_,_)) = let
287    
288      val c_dummy = ref 0 (* Stats.newCounter[] *)      val c_dummy = ref 0 (* Stats.newCounter[] *)
289      val c_miss = ref 0 (* Stats.newCounter[] *)      val c_miss = ref 0 (* Stats.newCounter[] *)
# Line 637  Line 641 
641                               dropargs (fn xs => OU.filter used xs))                               dropargs (fn xs => OU.filter used xs))
642    
643                          (* eta-split: add a wrapper for escaping uses *)                          (* eta-split: add a wrapper for escaping uses *)
644                          else if C.escaping gi then                          else if etaSplit andalso C.escaping gi then
645                              (* like dropargs but keeping all args *)                              (* like dropargs but keeping all args *)
646                              (click_etasplit(); dropargs (fn x => x))                              (click_etasplit(); dropargs (fn x => x))
647    
# Line 758  Line 762 
762  fun fcTfn ((tfk,f,args,body),le) =  fun fcTfn ((tfk,f,args,body),le) =
763      let val fi = C.get f      let val fi = C.get f
764      in if C.dead fi then (click_deadlexp(); loop m le cont) else      in if C.dead fi then (click_deadlexp(); loop m le cont) else
765          let val nbody = fcexp ifs m body #2          let val saved_ic = inline_count()
766              val nm = addbind(m, f, TFun(f, nbody, args))              val nbody = fcexp ifs m body #2
767                val ntfk =
768                    if inline_count() = saved_ic then tfk else {inline=F.IH_SAFE}
769                val nm = addbind(m, f, TFun(f, nbody, args, tfk))
770              val nle = loop nm le cont              val nle = loop nm le cont
771          in          in
772              if C.dead fi then nle else F.TFN((tfk, f, args, nbody), nle)              if C.dead fi then nle else F.TFN((tfk, f, args, nbody), nle)
773          end          end
774      end      end
775    
776    fun fcTapp (f,tycs) =
777        let val svf = val2sval m f
778        (* F.TAPP inlining (if any) *)
779    
780            fun noinline () = (cont(m, F.TAPP(sval2val svf, tycs)))
781    
782            fun specialize (g,tfk,args,body,tycs) =
783                let val prog =
784                        ({cconv=F.CC_FCT,inline=F.IH_SAFE,isrec=NONE,known=false},
785                         mklv(), [],
786                         F.TFN((tfk, g, args, body), F.TAPP(F.VAR g, tycs)))
787                    val F.LET(_,nprog,F.RET _) = #4(Specialize.specialize prog)
788                in PP.printLexp nprog; nprog end
789    
790        in case (tfnInline,svf)
791            of (true,TFun(g,body,args,tfk as {inline,...})) =>
792               let val gi = C.get g
793                   fun simpleinline () =
794                       (* simple inlining:  we should copy the body and then
795                        * kill the function, but instead we just move the body
796                        * and kill only the function name.
797                        * This inlining strategy looks inoffensive enough,
798                        * but still requires some care: see comments at the
799                        * begining of this file and in cfun *)
800                       (click_simpleinline();
801                        (*  say("simpleinline "^(C.LVarString g)^"\n"); *)
802                        ignore(C.unuse true gi);
803                        loop m (specialize(g, tfk, args, body, tycs)) cont)
804                   fun copyinline () =
805                       (* aggressive inlining.  We allow pretty much
806                        * any inlinling, but we detect and reject inlining
807                        * recursively which would else lead to infinite loop *)
808                       let val nle = (F.TFN((tfk, g, args, body),
809                                            F.TAPP(F.VAR g, tycs)))
810                           val nle = C.copylexp M.empty nle
811                       in
812                           click_copyinline();
813                           (*  say("copyinline "^(C.LVarString g)^"\n"); *)
814                           unusecall m g;
815                           fcexp (S.add(g, ifs)) m nle cont
816                       end
817    
818               in if C.usenb gi = 1 andalso not(S.member ifs g)
819                  then noinline() (* simpleinline() *)
820                  else case inline of
821                      F.IH_ALWAYS =>
822                      if S.member ifs g then noinline() else copyinline()
823                    | _ => noinline()
824               end
825             | sv => noinline()
826        end
827    
828    
829    
830  fun fcSwitch (v,ac,arms,def) =  fun fcSwitch (v,ac,arms,def) =
831      let fun fcsCon (lvc,svc,dc1:F.dcon,tycs1) =      let fun fcsCon (lvc,svc,dc1:F.dcon,tycs1) =
832              let fun killle le = C.unuselexp (undertake m) le              let fun killle le = C.unuselexp (undertake m) le
# Line 964  Line 1025 
1025        | F.FIX x => fcFix x        | F.FIX x => fcFix x
1026        | F.APP x => fcApp x        | F.APP x => fcApp x
1027        | F.TFN x => fcTfn x        | F.TFN x => fcTfn x
1028        | F.TAPP (f,tycs) => cont(m, F.TAPP(substval f, tycs))        (* | F.TAPP (f,tycs) => cont(m, F.TAPP(substval f, tycs)) *)
1029          | F.TAPP x => fcTapp x
1030        | F.SWITCH x => fcSwitch x        | F.SWITCH x => fcSwitch x
1031        | F.CON x => fcCon x        | F.CON x => fcCon x
1032        | F.RECORD x => fcRecord x        | F.RECORD x => fcRecord x

Legend:
Removed from v.258  
changed lines
  Added in v.259

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