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 198, Sun Nov 22 02:11:29 1998 UTC revision 199, Wed Nov 25 18:30:38 1998 UTC
# Line 211  Line 211 
211  fun sval2lty (Var(_,x)) = x  fun sval2lty (Var(_,x)) = x
212    | sval2lty (Decon(_,_,(_,_,lty),tycs)) =    | sval2lty (Decon(_,_,(_,_,lty),tycs)) =
213      SOME(hd(#2 (LT.ltd_arrow (hd(LT.lt_inst(lty, tycs))))))      SOME(hd(#2 (LT.ltd_arrow (hd(LT.lt_inst(lty, tycs))))))
214      | sval2lty (Select(_,sv,i)) =
215        (case sval2lty sv of SOME lty => SOME(LT.lt_select(lty, i)) | _ => NONE)
216    | sval2lty _ = NONE    | sval2lty _ = NONE
217    
218  fun tycs_eq ([],[]) = true  fun tycs_eq ([],[]) = true
# Line 262  Line 264 
264      fun click_unroll       () = (click "u" c_inline)      fun click_unroll       () = (click "u" c_inline)
265      fun inline_count () = Stats.getCounter c_inline      fun inline_count () = Stats.getCounter c_inline
266    
 (* cfg: is used for deBruijn renumbering when inlining at different depths  
  * ifs (inlined functions): records which functions we're currently inlining  
  *     in order to detect loops  
  * m: is a map lvars to their defining expressions (svals) *)  
 fun cexp ifs m le cont = let  
   
     val loop = cexp ifs  
   
267      fun used lv = (C.usenb(C.get lv) > 0)      fun used lv = (C.usenb(C.get lv) > 0)
268                        handle x =>                        (* handle x =>
269                        (say("while in FContract.used "^(C.LVarString lv)^"\n");                        (say("while in FContract.used "^(C.LVarString lv)^"\n");
270                         raise x)                         raise x) *)
271    
272      fun impurePO po = true              (* if a PrimOP is pure or not *)      fun impurePO po = true              (* if a PrimOP is pure or not *)
273    
# Line 298  Line 292 
292            | Val v => v            | Val v => v
293    
294      fun val2sval m (F.VAR ov) =      fun val2sval m (F.VAR ov) =
295          ((lookup m ov) handle x =>          ((lookup m ov) (* handle x =>
296           (say("val2sval "^(C.LVarString ov)^"\n"); raise x))           (say("val2sval "^(C.LVarString ov)^"\n"); raise x) *) )
297        | val2sval m v = Val v        | val2sval m v = Val v
298    
299      fun bugsv (msg,sv) = bugval(msg, sval2val sv)      fun bugsv (msg,sv) = bugval(msg, sval2val sv)
300    
301      fun subst m ov = sval2val (lookup m ov)      fun subst m ov = sval2val (lookup m ov)
302      val substval = sval2val o (val2sval m)      fun substval m = sval2val o (val2sval m)
303      fun substvar lv =      fun substvar m lv =
304          case substval(F.VAR lv)          case substval m (F.VAR lv)
305           of F.VAR lv => lv           of F.VAR lv => lv
306            | v => bugval ("unexpected val", v)            | v => bugval ("unexpected val", v)
307    
# Line 349  Line 343 
343      fun substitute (m, lv1, sv, v) =      fun substitute (m, lv1, sv, v) =
344          (case sval2val sv of F.VAR lv2 => C.transfer(lv1,lv2) | v2 => ();          (case sval2val sv of F.VAR lv2 => C.transfer(lv1,lv2) | v2 => ();
345           unuseval m v;           unuseval m v;
346           addbind(m, lv1, sv)) handle x =>           addbind(m, lv1, sv)) (* handle x =>
347               (say ("while substituting "^               (say ("while substituting "^
348                     (C.LVarString lv1)^                     (C.LVarString lv1)^
349                     " -> ");                     " -> ");
350                PP.printSval (sval2val sv);                PP.printSval (sval2val sv);
351                raise x)                raise x) *)
352    
353      (* common code for primops *)      (* common code for primops *)
354      fun cpo (SOME{default,table},po,lty,tycs) =      fun cpo m (SOME{default,table},po,lty,tycs) =
355          (SOME{default=substvar default,          (SOME{default=substvar m default,
356                table=map (fn (tycs,lv) => (tycs, substvar lv)) table},                table=map (fn (tycs,lv) => (tycs, substvar m lv)) table},
357           po,lty,tycs)           po,lty,tycs)
358        | cpo po = po        | cpo _ po = po
359    
360      fun cdcon (s,Access.EXN(Access.LVAR lv),lty) =      fun cdcon m (s,Access.EXN(Access.LVAR lv),lty) =
361          (s, Access.EXN(Access.LVAR(substvar lv)), lty)          (s, Access.EXN(Access.LVAR(substvar m lv)), lty)
362        | cdcon dc = dc        | cdcon _ dc = dc
   
     fun zip ([],[]) = []  
       | zip (x::xs,y::ys) = (x,y)::(zip(xs,ys))  
       | zip _ = bug "bad zip"  
   
     (* F.APP inlining (if any)  
      * `ifs' is the set of function we are currently inlining  
      * `f' is the function, `vs' its arguments.  
      * return either (NONE, ifs) if inlining cannot be done or  
      * (SOME lexp, nifs) where `lexp' is the expansion of APP(f,vs) and  
      * `nifs' is the new set of functions we are currently inlining.  
      *)  
     fun inline ifs (f,vs) =  
         case ((val2sval m f) handle x => raise x)  
          of Fun(g,body,args,{inline,...}) =>  
             (if ((C.usenb(C.get g))handle x => raise x) = 1 andalso not(S.member ifs g) then  
   
                  (* 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();  
                   ignore(C.unuse true (C.get g));  
                   (SOME(F.LET(map #1 args, F.RET vs, body)), ifs))  
363    
364               (* aggressive inlining (but hopefully safe).  We allow  (* cfg: is used for deBruijn renumbering when inlining at different depths
365                * inlining for mutually recursive functions (isrec)   * ifs (inlined functions): records which functions we're currently inlining
366                * despite the potential risk.  The reason is that it can   *     in order to detect loops
367                * happen that a wrapper (that should be inlined) has to be made   * m: is a map lvars to their defining expressions (svals) *)
368                * mutually recursive with its main function.  On another hand,  fun cexp ifs m le cont = let
369                * self recursion (C.recursive) is too dangerous to be inlined      val loop = cexp ifs
370                * except for loop unrolling *)      val substval = substval m
371               (* unrolling is not as straightforward as it seems:      val cdcon = cdcon m
372                * if you inline the function you're currently fcontracting,      val cpo = cpo m
373                * you're asking for trouble: there is a hidden assumption  in case le
374                * in the counting that the old code will be replaced by the new       of F.RET vs => cont(m, F.RET(map substval vs))
               * code (and is hence dead).  If the function to be unrolled  
               * has the only call to function f, then f might get simpleinlined  
               * before unrolling, which means that unrolling will introduce  
               * a second occurence of the `only call' but at that point f  
               * has already been killed. *)  
              else if (inline = F.IH_ALWAYS andalso not(S.member ifs g)) (*orelse  
                  (inline = F.IH_UNROLL andalso (S.member ifs g)) *) then  
                  let val nle =  
                          C.copylexp M.empty (F.LET(map #1 args, F.RET vs, body))  
                  in  
                      (*  say ("\nInlining "^(C.LVarString g)); *)  
                      (app (unuseval m) vs) handle x => raise x;  
                      unusecall m g;  
                      (SOME nle,  
                       (* gross hack: to prevent further unrolling,  
                        * I pretend that the rest is not inside the body *)  
                       if inline = F.IH_UNROLL  
                       then (click_unroll(); S.rmv(g, ifs))  
                       else (click_copyinline(); S.add(g, ifs)))  
                  end  
              else (NONE, ifs))  
           | sv => (NONE, ifs)  
 in  
     case le  
      of F.RET vs => cont(m, F.RET(map substval vs) handle x => raise x)  
375    
376        | F.LET (lvs,le,body) =>        | F.LET (lvs,le,body) =>
377          let fun clet () =          let fun clet () =
378                  loop m le                  loop m le
379                       (fn (m,F.RET vs) =>                       (fn (m,F.RET vs) =>
380                        let fun simplesubst (lv,v,m) =                        let fun simplesubst (lv,v,m) =
381                                let val sv = (val2sval m v) handle x => raise x                                let val sv = val2sval m v
382                                in substitute(m, lv, sv, sval2val sv)                                in substitute(m, lv, sv, sval2val sv)
383                                end                                end
384                            val nm = (ListPair.foldl simplesubst m (lvs, vs))                            val nm = (ListPair.foldl simplesubst m (lvs, vs))
# Line 449  Line 393 
393                                              else F.LET(lvs, nle, F.RET vs)                                              else F.LET(lvs, nle, F.RET vs)
394                                | nbody => F.LET(lvs, nle, nbody)                                | nbody => F.LET(lvs, nle, nbody)
395                           end)                           end)
396          in case le          in (* case le
397              of F.BRANCH (po,vs,le1,le2) =>              of F.BRANCH (po,vs,le1,le2) =>
398                 (* this is a hack originally meant to cleanup the BRANCH mess                 (* this is a hack originally meant to cleanup the BRANCH mess
399                  * introduced in flintnm (where each branch returns just true or                  * introduced in flintnm (where each branch returns just true or
# Line 483  Line 427 
427                        cassoc(lv, v, le, fn le => F.LET(lvs,le,rest))                        cassoc(lv, v, le, fn le => F.LET(lvs,le,rest))
428                      | _ => clet()                      | _ => clet()
429                 end                 end
430               | _ => clet()               | _ => *) clet()
431          end          end
432    
433        | F.FIX (fs,le) =>        | F.FIX (fs,le) =>
# Line 513  Line 457 
457                                     inline=if inline_count() = saved_ic                                     inline=if inline_count() = saved_ic
458                                            then inline                                            then inline
459                                            else F.IH_SAFE}                                            else F.IH_SAFE}
460                          (* update the binding in the map.  This step is not                          (* update the binding in the map.  This step is
461                           * not just a mere optimization but is necessary                           * not just a mere optimization but is necessary
462                           * because if we don't do it and the function                           * because if we don't do it and the function
463                           * gets inlined afterwards, the counts will reflect the                           * gets inlined afterwards, the counts will reflect the
# Line 526  Line 470 
470                  end                  end
471    
472              (* check for eta redex *)              (* check for eta redex *)
473              fun ceta (fdec as (fk,f,args,F.APP(g,vs)):F.fundec,(m,fs,hs)) =              fun ceta (fdec as (fk,f,args,F.APP(F.VAR g,vs)):F.fundec,
474                  if vs = (map (F.VAR o #1) args) andalso                        (m,fs,hs)) =
475                      (* don't forget to check that g is not one of the args                  if List.length args = List.length vs andalso
476                       * and not f itself either *)                      OU.ListPair_all (fn (v,(lv,t)) =>
477                      (List.find (fn v => v = g) (F.VAR f::vs)) = NONE                                       case v of F.VAR v => v = lv andalso lv <> g
478                                                 | _ => false)
479                                        (vs, args)
480                  then                  then
481                      let val svg = val2sval m g                      let val svg = lookup m g
482                          val g = case sval2val svg                          val g = case sval2val svg
483                                   of F.VAR g => g                                   of F.VAR g => g
484                                    | v => bugval("not a variable", v)                                    | v => bugval("not a variable", v)
# Line 645  Line 591 
591          end          end
592    
593        | F.APP (f,vs) =>        | F.APP (f,vs) =>
594          let val nvs = ((map substval vs) handle x => raise x)          let val nvs = map substval vs
595          in case inline ifs (f, nvs)              val svf = val2sval m f
596              of (SOME le,nifs) => cexp nifs m le cont          (* F.APP inlining (if any) *)
597               | (NONE,_) => cont(m,F.APP((substval f) handle x => raise x, nvs))          in case svf
598                of Fun(g,body,args,{inline,...}) =>
599                   if (C.usenb(C.get g)) = 1 andalso not(S.member ifs g) then
600    
601                       (* simple inlining:  we should copy the body and then
602                        * kill the function, but instead we just move the body
603                        * and kill only the function name.
604                        * This inlining strategy looks inoffensive enough,
605                        * but still requires some care: see comments at the
606                        * begining of this file and in cfun *)
607                       (click_simpleinline();
608                        ignore(C.unuse true (C.get g));
609                        loop m (F.LET(map #1 args, F.RET vs, body)) cont)
610    
611                   (* aggressive (but safe) inlining.  We allow pretty much
612                    * any inlinling, but we detect and reject inlining
613                    * recursively which would else lead to infinite loop *)
614                   (* unrolling is not as straightforward as it seems:
615                    * if you inline the function you're currently
616                    * fcontracting, you're asking for trouble: there is a
617                    * hidden assumption in the counting that the old code
618                    * will be replaced by the new code (and is hence dead).
619                    * If the function to be unrolled has the only call to
620                    * function f, then f might get simpleinlined before
621                    * unrolling, which means that unrolling will introduce
622                    * a second occurence of the `only call' but at that point
623                    * f has already been killed. *)
624                   else if (inline = F.IH_ALWAYS andalso not(S.member ifs g)) then
625                       let val nle =
626                               C.copylexp M.empty (F.LET(map #1 args, F.RET vs, body))
627                       in
628                           click_copyinline();
629                           (app (unuseval m) vs);
630                           unusecall m g;
631                           cexp (S.add(g, ifs)) m nle cont
632                       end
633                   else cont(m,F.APP(sval2val svf, nvs))
634                 | sv => cont(m,F.APP(sval2val svf, nvs))
635          end          end
636    
637        | F.TFN ((f,args,body),le) =>        | F.TFN ((f,args,body),le) =>
# Line 674  Line 657 
657                       inlineWitness := true;                       inlineWitness := true;
658                       ignore(C.unuse true (C.get g));                       ignore(C.unuse true (C.get g));
659                   end *)                   end *)
660          cont(m, F.TAPP((substval f) handle x => raise x, tycs))          cont(m, F.TAPP(substval f, tycs))
661    
662        | F.SWITCH (v,ac,arms,def) =>        | F.SWITCH (v,ac,arms,def) =>
663          (case ((val2sval m v) handle x => raise x)          (case val2sval m v
664            of sv as Con (lvc,svc,dc1,tycs1) =>            of sv as Con (lvc,svc,dc1,tycs1) =>
665               let fun killle le = C.unuselexp (undertake m) le               let fun killle le = C.unuselexp (undertake m) le
666                   fun kill lv le =                   fun kill lv le =
# Line 723  Line 706 
706                        val slv = Decon(lv, sv, ndc, tycs)                        val slv = Decon(lv, sv, ndc, tycs)
707                        val nm = addbind(m, lv, slv)                        val nm = addbind(m, lv, slv)
708                        (* see below *)                        (* see below *)
709                        val nm = addbind(nm, lvc, Con(lvc, slv, ndc, tycs))                        (* val nm = addbind(nm, lvc, Con(lvc, slv, ndc, tycs)) *)
710                        val nle = loop nm le cont                        val nle = loop nm le cont
711                        val nv = sval2val sv                        val nv = sval2val sv
712                    in                    in
# Line 752  Line 735 
735                                 * - it seems to be a good idea, but it can hide                                 * - it seems to be a good idea, but it can hide
736                                 *   other opt-opportunities since it hides the                                 *   other opt-opportunities since it hides the
737                                 *   previous binding. *)                                 *   previous binding. *)
738                                val nm = addbind(nm, lvc, Con(lvc,slv,ndc,tycs))                                (* val nm = addbind(nm, lvc, Con(lvc,slv,ndc,tycs)) *)
739                            in (F.DATAcon(ndc, tycs, lv), loop nm le #2)                            in (F.DATAcon(ndc, tycs, lv), loop nm le #2)
740                            end                            end
741                          | carm (con,le) = (con, loop m le #2)                          | carm (con,le) = (con, loop m le #2)
# Line 774  Line 757 
757                      in if C.dead lvi then nle                      in if C.dead lvi then nle
758                         else F.CON(ndc, tycs1, sval2val sv, lv, nle)                         else F.CON(ndc, tycs1, sval2val sv, lv, nle)
759                      end                      end
760              in case ((val2sval m v) handle x => raise x)              in case val2sval m v
761                  of sv as (Decon (lvd,sv',dc2,tycs2)) =>                  of sv as (Decon (lvd,sv',dc2,tycs2)) =>
762                     if FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) then                     if FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) then
763                         (click_con();                         (click_con();
# Line 807  Line 790 
790                      in g'(1,ss)                      in g'(1,ss)
791                      end                      end
792                    | g _ = NONE                    | g _ = NONE
793                  val svs = ((map (val2sval m) vs) handle x => raise x)                  val svs = map (val2sval m) vs
794              in case g svs              in case g svs
795                  of SOME sv => (click_record();                  of SOME sv => (click_record();
796                                 loop (substitute(m, lv, sv, F.INT 0)) le cont                                 loop (substitute(m, lv, sv, F.INT 0)) le cont
# Line 824  Line 807 
807        | F.SELECT (v,i,lv,le) =>        | F.SELECT (v,i,lv,le) =>
808          let val lvi = C.get lv          let val lvi = C.get lv
809          in if C.dead lvi then (click_deadval(); loop m le cont) else          in if C.dead lvi then (click_deadval(); loop m le cont) else
810              (case ((val2sval m v) handle x => raise x)              (case val2sval m v
811                of Record (lvr,svs) =>                of Record (lvr,svs) =>
812                   let val sv = List.nth(svs, i)                   let val sv = List.nth(svs, i)
813                   in click_select();                   in click_select();
# Line 839  Line 822 
822          end          end
823    
824        | F.RAISE (v,ltys) =>        | F.RAISE (v,ltys) =>
825          cont(m, F.RAISE((substval v) handle x => raise x, ltys))          cont(m, F.RAISE(substval v, ltys))
826    
827        | F.HANDLE (le,v) =>        | F.HANDLE (le,v) =>
828          cont(m, F.HANDLE(loop m le #2, (substval v) handle x => raise x))          cont(m, F.HANDLE(loop m le #2, substval v))
829    
830        | F.BRANCH (po,vs,le1,le2) =>        | F.BRANCH (po,vs,le1,le2) =>
831          let val nvs = ((map substval vs) handle x => raise x)          let val nvs = map substval vs
832              val npo = cpo po              val npo = cpo po
833              val nle1 = loop m le1 #2              val nle1 = loop m le1 #2
834              val nle2 = loop m le2 #2              val nle2 = loop m le2 #2
# Line 856  Line 839 
839          let val lvi = C.get lv          let val lvi = C.get lv
840              val pure = not(impurePO po)              val pure = not(impurePO po)
841          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
842              let val nvs = ((map substval vs) handle x => raise x)              let val nvs = map substval vs
843                  val npo = cpo po                  val npo = cpo po
844                  val nm = addbind(m, lv, Var(lv,NONE))                  val nm = addbind(m, lv, Var(lv,NONE))
845                  val nle = loop nm le cont                  val nle = loop nm le cont

Legend:
Removed from v.198  
changed lines
  Added in v.199

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