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 189, Sun Nov 15 22:29:42 1998 UTC revision 190, Thu Nov 19 21:01:17 1998 UTC
# Line 5  Line 5 
5  sig  sig
6    
7      (* needs Collect to be setup properly *)      (* needs Collect to be setup properly *)
8      val contract : FLINT.fundec * Stats.counter -> FLINT.fundec      val contract : FLINT.prog * Stats.counter -> FLINT.prog
9    
10  end  end
11    
# Line 145  Line 145 
145   *   do the dead-code elimination, so you can only avoid fcontracting a   *   do the dead-code elimination, so you can only avoid fcontracting a
146   *   a function if you can be sure that the body doesn't contain any dead-code,   *   a function if you can be sure that the body doesn't contain any dead-code,
147   *   which is generally  not known).   *   which is generally  not known).
148   * - once a function is fcontracted it is marked as non-inlinable since   * - once a function is fcontracted, its inlinable status is re-examined.
149   *   fcontraction might have changed its shape considerably (via inlining).   *   More specifically, if no inlining occured during its fcontraction, then
150     *   we assume that the code has just become smaller and should hence
151     *   still be considered inlinable.  On another hand, if inlining took place,
152     *   then we have to reset the inline-bit because the new body might
153     *   be completely different (i.e. much bigger) and inlining it might be
154     *   undesirable.
155   *   This means that in the case of   *   This means that in the case of
156   *       let fwrap x = body1 and f y = body2 in exp   *       let fwrap x = body1 and f y = body2 in exp
157   *   if fwrap is fcontracted before f, then fwrap cannot be inlined in f.   *   if fwrap is fcontracted before f and something gets inlined into it,
158     *   then fwrap cannot be inlined in f.
159   *   To minimize the impact of this problem, we make sure that we fcontract   *   To minimize the impact of this problem, we make sure that we fcontract
160   *   inlinable functions only after fcontracting other mutually recursive   *   inlinable functions only after fcontracting other mutually recursive
161   *   functions.   *   functions.  One way to solve the problem more thoroughly would be
162     *   to keep the uncontracted fwrap around until f has been contracted.
163     *   Such a trick hasn't seemed necessary yet.
164   * - at the very end of the optimization phase, cpsopt had a special pass   * - at the very end of the optimization phase, cpsopt had a special pass
165   *   that ignored the `NO_INLINE_INTO' hint (since at this stage, inlining   *   that ignored the `NO_INLINE_INTO' hint (since at this stage, inlining
166   *   into it doesn't have any undesirable side effects any more).  The present   *   into it doesn't have any undesirable side effects any more).  The present
# Line 226  Line 234 
234  (*  val c_eta    = Stats.newCounter[] *)  (*  val c_eta    = Stats.newCounter[] *)
235  (*  val c_etasplit       = Stats.newCounter[] *)  (*  val c_etasplit       = Stats.newCounter[] *)
236  (*  val c_branch         = Stats.newCounter[] *)  (*  val c_branch         = Stats.newCounter[] *)
 (*  val c_cstargs        = Stats.newCounter[] *)  
237  (*  val c_dropargs       = Stats.newCounter[] *)  (*  val c_dropargs       = Stats.newCounter[] *)
238    
239  fun contract (fdec as (_,f,_,_), counter) = let  fun contract (fdec as (_,f,_,_), counter) = let
# Line 243  Line 250 
250      fun click_eta      () = (click "e" counter)      fun click_eta      () = (click "e" counter)
251      fun click_etasplit () = (click "E" counter)      fun click_etasplit () = (click "E" counter)
252      fun click_branch   () = (click "b" counter)      fun click_branch   () = (click "b" counter)
     fun click_cstargs  () = (click "A" counter)  
253      fun click_dropargs () = (click "a" counter)      fun click_dropargs () = (click "a" counter)
254    
255      fun click_lacktype () = (click "t" c_miss)      fun click_lacktype () = (click "t" c_miss)
# Line 399  Line 405 
405                * mutually recursive with its main function.  On another hand,                * mutually recursive with its main function.  On another hand,
406                * self recursion (C.recursive) is too dangerous to be inlined                * self recursion (C.recursive) is too dangerous to be inlined
407                * except for loop unrolling *)                * except for loop unrolling *)
408               else if (inline = F.IH_ALWAYS andalso not(S.member ifs g)) orelse               (* unrolling is not as straightforward as it seems:
409                   (inline = F.IH_UNROLL andalso (S.member ifs g)) then                * if you inline the function you're currently fcontracting,
410                  * you're asking for trouble: there is a hidden assumption
411                  * in the counting that the old code will be replaced by the new
412                  * code (and is hence dead).  If the function to be unrolled
413                  * has the only call to function f, then f might get simpleinlined
414                  * before unrolling, which means that unrolling will introduce
415                  * a second occurence of the `only call' but at that point f
416                  * has already been killed. *)
417                 else if (inline = F.IH_ALWAYS andalso not(S.member ifs g)) (*orelse
418                     (inline = F.IH_UNROLL andalso (S.member ifs g)) *) then
419                   let val nle =                   let val nle =
420                           C.copylexp M.empty (F.LET(map #1 args, F.RET vs, body))                           C.copylexp M.empty (F.LET(map #1 args, F.RET vs, body))
421                   in                   in
# Line 424  Line 439 
439          let fun clet () =          let fun clet () =
440                  loop m le                  loop m le
441                       (fn (m,F.RET vs) =>                       (fn (m,F.RET vs) =>
442                        let fun simplesubst ((lv,v),m) =                        let fun simplesubst (lv,v,m) =
443                                let val sv = (val2sval m v) handle x => raise x                                let val sv = (val2sval m v) handle x => raise x
444                                in substitute(m, lv, sv, sval2val sv)                                in substitute(m, lv, sv, sval2val sv)
445                                end                                end
446                            val nm = (foldl simplesubst m (zip(lvs, vs)))                            val nm = (ListPair.foldl simplesubst m (lvs, vs))
447                        in loop nm body cont                        in loop nm body cont
448                        end                        end
449                         | (m,nle) =>                         | (m,nle) =>
# Line 469  Line 484 
484                             clet()                             clet()
485                 in case (lvs,body)                 in case (lvs,body)
486                     of ([lv],le as F.SWITCH(F.VAR v,_,_,NONE)) =>                     of ([lv],le as F.SWITCH(F.VAR v,_,_,NONE)) =>
487                        cassoc(lv, v, le, OU.id)                        cassoc(lv, v, le, fn x => x)
488                      | ([lv],F.LET(lvs,le as F.SWITCH(F.VAR v,_,_,NONE),rest)) =>                      | ([lv],F.LET(lvs,le as F.SWITCH(F.VAR v,_,_,NONE),rest)) =>
489                        cassoc(lv, v, le, fn le => F.LET(lvs,le,rest))                        cassoc(lv, v, le, fn le => F.LET(lvs,le,rest))
490                      | _ => clet()                      | _ => clet()
# Line 555  Line 570 
570                  else (m, fdec::fs, hs)                  else (m, fdec::fs, hs)
571                | ceta (fdec,(m,fs,hs)) = (m,fdec::fs,hs)                | ceta (fdec,(m,fs,hs)) = (m,fdec::fs,hs)
572    
             (* drop constant arguments if possible *)  
             fun cstargs (f as ({inline=F.IH_ALWAYS,...},_,_,_):F.fundec) = f  
               | cstargs (f as (fk,g,args,body):F.fundec) =  
                 let val actuals = (C.actuals (C.get g)) handle x => raise x  
                     val cst =  
                         ListPair.map  
                             (fn (NONE,_) => false  
                               | (SOME(F.VAR lv),(a,_)) =>  
                                 ((case sval2val(lookup m lv)  
                                   of F.VAR lv =>  
                                      if used a andalso used lv then  
                                          (C.use NONE (C.get lv); true)  
                                      else false  
                                    | _ => true)  
                                     handle M.IntmapF => false)  
                               | (SOME v,(a,_)) => true)  
                             (actuals, args)  
                 (* if all args are used, there's nothing we can do *)  
                 in if List.all not cst then f else  
                     let fun newarg lv =  
                             let val nlv = cplv lv in C.new NONE nlv; nlv end  
                         fun filter xs = OU.filter(cst, xs)  
                         (* construct the new arg list *)  
                         val nargs = ListPair.map  
                                         (fn ((a,t),true) => (newarg a,t)  
                                           | ((a,t),false) => (a,t))  
                                         (args, cst)  
                         (* construct the new body *)  
                         val nbody =  
                             F.LET(map #1 (filter args),  
                                   F.RET(map O.valOf (filter actuals)),  
                                   body)  
                     in click_cstargs();  
                         (fk, g, nargs, nbody)  
                     end  
                 end  
   
573              (* add wrapper for various purposes *)              (* add wrapper for various purposes *)
574              fun wrap (f as ({inline=F.IH_ALWAYS,...},_,_,_):F.fundec,fs) = f::fs              fun wrap (f as ({inline=F.IH_ALWAYS,...},_,_,_):F.fundec,fs) = f::fs
575                | wrap (f as (fk as {isrec,...},g,args,body):F.fundec,fs) =                | wrap (f as (fk as {isrec,...},g,args,body):F.fundec,fs) =
# Line 614  Line 592 
592                              app (C.use NONE o C.get) nargs';                              app (C.use NONE o C.get) nargs';
593                              nf'::nf::fs                              nf'::nf::fs
594                          end                          end
                     val used = map (used o #1) args  
595                      in                      in
596                      (* Don't introduce wrappers for escaping-only functions.                      (* Don't introduce wrappers for escaping-only functions.
597                       * This is debatable since although wrappers are useless                       * This is debatable since although wrappers are useless
# Line 622  Line 599 
599                       * might turn into calls in the course of fcontract, so                       * might turn into calls in the course of fcontract, so
600                       * by not introducing wrappers here, we avoid useless work                       * by not introducing wrappers here, we avoid useless work
601                       * but we also postpone useful work to later invocations. *)                       * but we also postpone useful work to later invocations. *)
602                      if C.called gi then                      if C.dead gi then fs else
603                            let val used = map (used o #1) args
604                            in if C.called gi then
605                          (* if some args are not used, let's drop them *)                          (* if some args are not used, let's drop them *)
606                          if not (List.all OU.id used) then                              if not (List.all (fn x => x) used) then
607                              (click_dropargs();                              (click_dropargs();
608                               dropargs (fn xs => OU.filter(used, xs)))                               dropargs (fn xs => OU.filter(used, xs)))
609    
610                          (* eta-split: add a wrapper for escaping uses *)                          (* eta-split: add a wrapper for escaping uses *)
611                          else if C.escaping gi then                          else if C.escaping gi then
612                              (* like dropargs but keeping all args *)                              (* like dropargs but keeping all args *)
613                              (click_etasplit(); dropargs OU.id)                                  (click_etasplit(); dropargs (fn x => x))
614    
615                          else f::fs                          else f::fs
616                      else f::fs                      else f::fs
617                  end                  end
618                    end
             (* junk unused funs *)  
             val fs = List.filter (fn (_,f,_,_) =>  
                                   used f orelse (click_deadlexp(); false))  
                                  fs  
   
             (* redirect cst args to their source value *)  
             val fs = map cstargs fs  
619    
620              (* add various wrappers *)              (* add various wrappers *)
621              val fs = foldl wrap [] fs              val fs = foldl wrap [] fs
# Line 681  Line 653 
653        | F.APP (f,vs) =>        | F.APP (f,vs) =>
654          let val nvs = ((map substval vs) handle x => raise x)          let val nvs = ((map substval vs) handle x => raise x)
655          in case inline ifs (f, nvs)          in case inline ifs (f, nvs)
656              of (SOME(le,od),nifs) => cexp (d,od) ifs m le cont              of (SOME(le,od),nifs) => cexp (d,od) nifs m le cont
657               | (NONE,_) => cont(m,F.APP((substval f) handle x => raise x, nvs))               | (NONE,_) => cont(m,F.APP((substval f) handle x => raise x, nvs))
658          end          end
659    

Legend:
Removed from v.189  
changed lines
  Added in v.190

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