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 200, Sat Nov 28 17:48:03 1998 UTC revision 201, Sat Nov 28 23:32:48 1998 UTC
# Line 250  Line 250 
250      in l le      in l le
251      end      end
252    
253    (* `extract' extracts the code of a switch arm into a function
254     * and replaces it with a call to that function *)
255    fun extract (con,le) =
256        let val f = mklv()
257            val fk = {isrec=NONE,known=true,inline=F.IH_SAFE,
258                      cconv=F.CC_FUN(LK.FF_FIXED)}
259        in case con of
260            F.DATAcon(dc as (_,_,lty),tycs,lv) =>
261            let val nlv = cplv lv
262                val _ = C.new (SOME[lv]) f
263                val _ = C.use NONE (C.new NONE nlv)
264                val (lty,_) = LT.ltd_parrow(hd(LT.lt_inst(lty, tycs)))
265            in ((F.DATAcon(dc, tycs, nlv),
266                 F.APP(F.VAR f, [F.VAR nlv])),
267                (fk, f, [(lv, lty)], le))
268            end
269          | con =>
270            let val _ = C.new (SOME[]) f
271            in ((con, F.APP(F.VAR f, [])),
272                (fk, f, [], le))
273            end
274        end
275    
276  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)
277    
278  (*  val c_inline         = Stats.newCounter[] *)  (*  val c_inline         = Stats.newCounter[] *)
# Line 391  Line 414 
414          (s, Access.EXN(Access.LVAR(substvar m lv)), lty)          (s, Access.EXN(Access.LVAR(substvar m lv)), lty)
415        | cdcon _ dc = dc        | cdcon _ dc = dc
416    
417  (* cfg: is used for deBruijn renumbering when inlining at different depths  (* ifs (inlined functions): records which functions we're currently inlining
  * ifs (inlined functions): records which functions we're currently inlining  
418   *     in order to detect loops   *     in order to detect loops
419   * m: is a map lvars to their defining expressions (svals) *)   * m: is a map lvars to their defining expressions (svals) *)
420  fun cexp ifs m le cont = let  fun fcexp ifs m le cont = let
421      val loop = cexp ifs      val loop = fcexp ifs
422      val substval = substval m      val substval = substval m
423      val cdcon = cdcon m      val cdcon = cdcon m
424      val cpo = cpo m      val cpo = cpo m
 in case le  
      of F.RET vs => cont(m, F.RET(map substval vs))  
425    
426        | F.LET (lvs,le,body) =>  fun fcLet (lvs,le,body) =
427          let fun k (nm,nle) =      loop m le
428             (fn (nm,nle) =>
429                  let fun cbody () =                  let fun cbody () =
430                          let val nm = (foldl (fn (lv,m) =>                          let val nm = (foldl (fn (lv,m) =>
431                                               addbind(m, lv, Var(lv, NONE)))                                               addbind(m, lv, Var(lv, NONE)))
# Line 423  Line 444 
444                             val nm = (ListPair.foldl simplesubst nm (lvs, vs))                             val nm = (ListPair.foldl simplesubst nm (lvs, vs))
445                         in loop nm body cont                         in loop nm body cont
446                         end                         end
447                       | _ => cbody()                 | F.TAPP _ =>
448                  end                   if List.all (C.dead o C.get) lvs
449              fun clet () = loop m le k                   then loop nm body cont
450          in case le                   else cbody()
451              of (F.BRANCH _ | F.SWITCH _) =>                 | (F.BRANCH _ | F.SWITCH _) =>
452                 (* this is a hack originally meant to cleanup the BRANCH mess                   (* this is a hack originally meant to cleanup the BRANCH
453                  * introduced in flintnm (where each branch returns just true or                    * mess introduced in flintnm (where each branch returns
454                  * false which is generally only used as input to a SWITCH).                    * just true or false which is generally only used as
455                  * The present code does slightly more than clean up this case *)                    * input to a SWITCH).
456                 (* As it stands, the code has at least 2 serious shortcomings:                    * The present code does more than clean up this case.
457                  * 1 - it applies to the code before fcontraction                    * It has one serious shortcoming: it ends up making
458                  * 2 - the SWITCH copied into each arm doesn't get reduced                    * three fcontract passes through the same code (plus
459                  *     early, so the inlining that should happen cannot                    * one cheap traversal). *)
460                  *     take place because by the time we know that the function                   let fun cassoc (lv,F.SWITCH(F.VAR v,ac,arms,NONE),wrap) =
461                  *     is a simple-inline candidate, fcontract already processed                           if lv <> v orelse C.usenb(C.get lv) > 1
462                  *     the call *)                           then cbody() else
   
                (* `extract' extracts the code of a switch arm into a function  
                 * and replaces it with a call to that function *)  
                let fun extract (con,le) =  
                        let val f = mklv()  
                            val fk = {isrec=NONE,known=true,inline=F.IH_SAFE,  
                                 cconv=F.CC_FUN(LK.FF_FIXED)}  
                        in case con of  
                            F.DATAcon(dc as (_,_,lty),tycs,lv) =>  
                            let val nlv = cplv lv  
                                val _ = C.new (SOME[lv]) f  
                                val _ = C.use NONE (C.new NONE nlv)  
                                val (lty,_) = LT.ltd_parrow(hd(LT.lt_inst(lty, tycs)))  
                            in ((F.DATAcon(dc, tycs, nlv),  
                                 F.APP(F.VAR f, [F.VAR nlv])),  
                                (fk, f, [(lv, lty)], le))  
                            end  
                          | con =>  
                            let val _ = C.new (SOME[]) f  
                            in ((con, F.APP(F.VAR f, [])),  
                                (fk, f, [], le))  
                            end  
                        end  
                    fun cassoc (lv,F.SWITCH(F.VAR v,ac,arms,NONE),wrap) =  
                        if lv <> v orelse C.usenb(C.get lv) > 1 then clet() else  
463                             let val (narms,fdecs) =                             let val (narms,fdecs) =
464                                     ListPair.unzip (map extract arms)                                     ListPair.unzip (map extract arms)
465                                 fun addswitch [v] =                                 fun addswitch [v] =
466                                     C.copylexp IntmapF.empty                                       C.copylexp
467                                             IntmapF.empty
468                                                (F.SWITCH(v,ac,narms,NONE))                                                (F.SWITCH(v,ac,narms,NONE))
469                                   | addswitch _ = bug "Wrong number of values"                                     | addswitch _ = bug "prob in addswitch"
470                                 (* replace each leaf `ret' with a copy                                 (* replace each leaf `ret' with a copy
471                                  * of the switch *)                                  * of the switch *)
472                                 val nle = append [lv] addswitch le                                   val nle = append [lv] addswitch nle
473                                 (* decorate with the functions extracted out                                   (* decorate with the functions extracted
474                                  * of the switch arms *)                                    * from the switch arms *)
475                                 val nle = foldl (fn (f,le) => F.FIX([f],le))                                   val nle =
476                                         foldl (fn (f,le) => F.FIX([f],le))
477                                                 (wrap nle) fdecs                                                 (wrap nle) fdecs
478                                 (* Ugly hack to alleviate problem 2 mentioned                                   (* Ugly hack: force one more traversal *)
479                                  * above: we go through the code twice *)                                   val nle = loop nm nle #2
                                val nle = loop m nle #2  
480                             in  click_branch();                             in  click_branch();
481                                 loop m nle cont                                   loop nm nle cont
482                             end                             end
483                           | cassoc _ = cbody()
484                 in case (lvs,body)                 in case (lvs,body)
485                     of ([lv],le as F.SWITCH(F.VAR v,_,_,NONE)) =>                       of ([lv],le as F.SWITCH _) =>
486                        cassoc(lv, le, fn x => x)                        cassoc(lv, le, fn x => x)
487                      | ([lv],F.LET(lvs,le as F.SWITCH(F.VAR v,_,_,NONE),rest)) =>                        | ([lv],F.LET(lvs,le as F.SWITCH _,rest)) =>
488                        cassoc(lv, le, fn le => F.LET(lvs,le,rest))                        cassoc(lv, le, fn le => F.LET(lvs,le,rest))
489                      | _ => clet()                        | _ => cbody()
                end  
              | _ => clet()  
490          end          end
491                   | _ => cbody()
492              end)
493    
494        | F.FIX (fs,le) =>  fun fcFix (fs,le) =
495          let (* The actual function contraction *)          let (* The actual function contraction *)
496              fun cfun (m,[]:F.fundec list,acc) = acc          fun fcFun (m,[]:F.fundec list,acc) = acc
497                | cfun (m,fdec as ({inline,cconv,known,isrec},f,args,body)::fs,acc) =            | fcFun (m,fdec as ({inline,cconv,known,isrec},f,args,body)::fs,acc) =
498                  let val fi = C.get f                  let val fi = C.get f
499                  in if C.dead fi then cfun(m, fs, acc)              in if C.dead fi then fcFun(m, fs, acc)
500                     else if C.iusenb fi = C.usenb fi then                     else if C.iusenb fi = C.usenb fi then
501                         (* we need to be careful that undertake not be called                         (* we need to be careful that undertake not be called
502                          * recursively *)                          * recursively *)
503                         (C.use NONE fi; undertake m f; cfun(m, fs, acc))                     (C.use NONE fi; undertake m f; fcFun(m, fs, acc))
504                     else                     else
505                      let (*  val _ = say ("\nEntering "^(C.LVarString f)) *)                      let (*  val _ = say ("\nEntering "^(C.LVarString f)) *)
506                          val saved_ic = inline_count()                          val saved_ic = inline_count()
# Line 511  Line 509 
509                              addbind(m, lv, Var(lv, SOME lty))                              addbind(m, lv, Var(lv, SOME lty))
510                          val nm = foldl addnobind m args                          val nm = foldl addnobind m args
511                          (* contract the body and create the resulting fundec *)                          (* contract the body and create the resulting fundec *)
512                          val nbody = cexp (S.add(f, ifs)) nm body #2                         val nbody = fcexp (S.add(f, ifs)) nm body #2
513                          (* if inlining took place, the body might be completely                          (* if inlining took place, the body might be completely
514                           * changed (read: bigger), so we have to reset the                           * changed (read: bigger), so we have to reset the
515                           * `inline' bit *)                           * `inline' bit *)
# Line 527  Line 525 
525                           * new contracted code while we'll be working on the                           * new contracted code while we'll be working on the
526                           * the old uncontracted code *)                           * the old uncontracted code *)
527                          val nm = addbind(m, f, Fun(f, nbody, args, nfk))                          val nm = addbind(m, f, Fun(f, nbody, args, nfk))
528                      in cfun(nm, fs, (nfk, f, args, nbody)::acc)                     in fcFun(nm, fs, (nfk, f, args, nbody)::acc)
529                             (*  before say ("\nExiting "^(C.LVarString f)) *)                             (*  before say ("\nExiting "^(C.LVarString f)) *)
530                      end                      end
531                  end                  end
532    
533              (* check for eta redex *)              (* check for eta redex *)
534              fun ceta (fdec as (fk,f,args,F.APP(F.VAR g,vs)):F.fundec,          fun fcEta (fdec as (fk,f,args,F.APP(F.VAR g,vs)):F.fundec,
535                        (m,fs,hs)) =                        (m,fs,hs)) =
536                  if List.length args = List.length vs andalso                  if List.length args = List.length vs andalso
537                      OU.ListPair_all (fn (v,(lv,t)) =>                      OU.ListPair_all (fn (v,(lv,t)) =>
# Line 571  Line 569 
569                         end                         end
570                      end                      end
571                  else (m, fdec::fs, hs)                  else (m, fdec::fs, hs)
572                | ceta (fdec,(m,fs,hs)) = (m,fdec::fs,hs)            | fcEta (fdec,(m,fs,hs)) = (m,fdec::fs,hs)
573    
574              (* add wrapper for various purposes *)              (* add wrapper for various purposes *)
575              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
# Line 628  Line 626 
626                              addbind(m, f, Fun(f, body, args, fk)))                              addbind(m, f, Fun(f, body, args, fk)))
627                             m fs                             m fs
628              (* check for eta redexes *)              (* check for eta redexes *)
629              val (nm,fs,_) = foldl ceta (nm,[],[]) fs          val (nm,fs,_) = foldl fcEta (nm,[],[]) fs
630    
631              (* move the inlinable functions to the end of the list *)              (* move the inlinable functions to the end of the list *)
632              val (f1s,f2s) =              val (f1s,f2s) =
# Line 639  Line 637 
637              (* contract the main body *)              (* contract the main body *)
638              val nle = loop nm le cont              val nle = loop nm le cont
639              (* contract the functions *)              (* contract the functions *)
640              val fs = cfun(nm, fs, [])          val fs = fcFun(nm, fs, [])
641              (* junk newly unused funs *)              (* junk newly unused funs *)
642              val fs = List.filter (used o #2) fs              val fs = List.filter (used o #2) fs
643          in          in
# Line 653  Line 651 
651                | _ => F.FIX(fs, nle)                | _ => F.FIX(fs, nle)
652          end          end
653    
654        | F.APP (f,vs) =>  fun fcApp (f,vs) =
655          let val nvs = map substval vs          let val nvs = map substval vs
656              val svf = val2sval m f              val svf = val2sval m f
657          (* F.APP inlining (if any) *)          (* F.APP inlining (if any) *)
# Line 671  Line 669 
669                      ignore(C.unuse true (C.get g));                      ignore(C.unuse true (C.get g));
670                      loop m (F.LET(map #1 args, F.RET vs, body)) cont)                      loop m (F.LET(map #1 args, F.RET vs, body)) cont)
671    
672                 (* aggressive (but safe) inlining.  We allow pretty much             (* aggressive inlining.  We allow pretty much
673                  * any inlinling, but we detect and reject inlining                  * any inlinling, but we detect and reject inlining
674                  * recursively which would else lead to infinite loop *)                  * recursively which would else lead to infinite loop *)
675                 (* unrolling is not as straightforward as it seems:                 (* unrolling is not as straightforward as it seems:
# Line 691  Line 689 
689                         click_copyinline();                         click_copyinline();
690                         (app (unuseval m) vs);                         (app (unuseval m) vs);
691                         unusecall m g;                         unusecall m g;
692                         cexp (S.add(g, ifs)) m nle cont                     fcexp (S.add(g, ifs)) m nle cont
693                     end                     end
694                 else cont(m,F.APP(sval2val svf, nvs))                 else cont(m,F.APP(sval2val svf, nvs))
695               | sv => cont(m,F.APP(sval2val svf, nvs))               | sv => cont(m,F.APP(sval2val svf, nvs))
696          end          end
697    
698        | F.TFN ((f,args,body),le) =>  fun fcTfn ((f,args,body),le) =
699          let val fi = C.get f          let val fi = C.get f
700          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
701              let val nbody = cexp ifs m body #2          let val nbody = fcexp ifs m body #2
702                  val nm = addbind(m, f, TFun(f, nbody, args))                  val nm = addbind(m, f, TFun(f, nbody, args))
703                  val nle = loop nm le cont                  val nle = loop nm le cont
704              in              in
# Line 708  Line 706 
706              end              end
707          end          end
708    
709        | F.TAPP(f,tycs) =>  fun fcSwitch (v,ac,arms,def) =
710          (* (case val2sval m f      let fun fcsCon (lvc,svc,dc1:F.dcon,tycs1) =
           of TFun(g,body,args,od) =>  
              if d = od andalso C.usenb(C.get g) = 1 then  
                  let val (_,_,_,le) =  
                          ({inline=false,isrec=NONE,known=false,cconv=F.CC_FCT},  
                           LV.mkLvar(),[],  
                           F.TFN((g,args,body),TAPP(g,tycs)))  
                  in  
                      inlineWitness := true;  
                      ignore(C.unuse true (C.get g));  
                  end *)  
         cont(m, F.TAPP(substval f, tycs))  
   
       | F.SWITCH (v,ac,arms,def) =>  
         (case val2sval m v  
           of sv as Con (lvc,svc,dc1,tycs1) =>  
711               let fun killle le = C.unuselexp (undertake m) le               let fun killle le = C.unuselexp (undertake m) le
712                   fun kill lv le =                   fun kill lv le =
713                       C.unuselexp (undertake (addbind(m,lv,Var(lv,NONE)))) le                       C.unuselexp (undertake (addbind(m,lv,Var(lv,NONE)))) le
# Line 747  Line 730 
730               in click_switch(); carm arms               in click_switch(); carm arms
731               end               end
732    
733             | sv as Val v =>          fun fcsVal v =
734               let fun kill le = C.unuselexp (undertake m) le               let fun kill le = C.unuselexp (undertake m) le
735                   fun carm ((con,le)::tl) =                   fun carm ((con,le)::tl) =
736                       if eqConV(con, v) then                       if eqConV(con, v) then
# Line 759  Line 742 
742               in click_switch(); carm arms               in click_switch(); carm arms
743               end               end
744    
745             | sv as (Var{1=lvc,...} | Select{1=lvc,...} | Decon{1=lvc, ...}          fun fcsDefault (sv,lvc) =
746               | (* will probably never happen *) Record{1=lvc,...}) =>              case (arms,def)
              (case (arms,def)  
747                 of ([(F.DATAcon(dc,tycs,lv),le)],NONE) =>                 of ([(F.DATAcon(dc,tycs,lv),le)],NONE) =>
748                    (* this is a mere DECON, so we can push the let binding                    (* this is a mere DECON, so we can push the let binding
749                     * (hidden in cont) inside and maybe even drop the DECON *)                     * (hidden in cont) inside and maybe even drop the DECON *)
# Line 805  Line 787 
787                        val narms = map carm arms                        val narms = map carm arms
788                        val ndef = Option.map (fn le => loop m le #2) def                        val ndef = Option.map (fn le => loop m le #2) def
789                    in cont(m, F.SWITCH(sval2val sv, ac, narms, ndef))                    in cont(m, F.SWITCH(sval2val sv, ac, narms, ndef))
790                    end)                  end
791    
792        in case val2sval m v
793            of sv as Con x => fcsCon x
794             | sv as Val v => fcsVal v
795             | sv as (Var{1=lvc,...} | Select{1=lvc,...} | Decon{1=lvc, ...}
796             | (* will probably never happen *) Record{1=lvc,...}) =>
797               fcsDefault(sv, lvc)
798             | sv as (Fun _ | TFun _) =>             | sv as (Fun _ | TFun _) =>
799               bugval("unexpected switch arg", sval2val sv))             bugval("unexpected switch arg", sval2val sv)
800        end
801    
802        | F.CON (dc1,tycs1,v,lv,le) =>  fun fcCon (dc1,tycs1,v,lv,le) =
803          let val lvi = C.get lv          let val lvi = C.get lv
804          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
805              let val ndc = cdcon dc1              let val ndc = cdcon dc1
# Line 830  Line 819 
819              end              end
820          end          end
821    
822        | F.RECORD (rk,vs,lv,le) =>  fun fcRecord (rk,vs,lv,le) =
823          (* g: check whether the record already exists *)          (* g: check whether the record already exists *)
824          let val lvi = C.get lv          let val lvi = C.get lv
825          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
# Line 867  Line 856 
856              end              end
857          end          end
858    
859        | F.SELECT (v,i,lv,le) =>  fun fcSelect (v,i,lv,le) =
860          let val lvi = C.get lv          let val lvi = C.get lv
861          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
862              (case val2sval m v              (case val2sval m v
# Line 884  Line 873 
873                   end)                   end)
874          end          end
875    
876        | F.RAISE (v,ltys) =>  fun fcBranch (po,vs,le1,le2) =
         cont(m, F.RAISE(substval v, ltys))  
   
       | F.HANDLE (le,v) =>  
         cont(m, F.HANDLE(loop m le #2, substval v))  
   
       | F.BRANCH (po,vs,le1,le2) =>  
877          let val nvs = map substval vs          let val nvs = map substval vs
878              val npo = cpo po              val npo = cpo po
879              val nle1 = loop m le1 #2              val nle1 = loop m le1 #2
# Line 898  Line 881 
881          in cont(m, F.BRANCH(npo, nvs, nle1, nle2))          in cont(m, F.BRANCH(npo, nvs, nle1, nle2))
882          end          end
883    
884        | F.PRIMOP (po,vs,lv,le) =>  fun fcPrimop (po,vs,lv,le) =
885          let val lvi = C.get lv          let val lvi = C.get lv
886              val pure = not(impurePO po)              val pure = not(impurePO po)
887          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
# Line 911  Line 894 
894                  else F.PRIMOP(npo, nvs, lv, nle)                  else F.PRIMOP(npo, nvs, lv, nle)
895              end              end
896          end          end
897    
898    in case le
899         of F.RET vs => cont(m, F.RET(map substval vs))
900          | F.LET x => fcLet x
901          | F.FIX x => fcFix x
902          | F.APP x => fcApp x
903          | F.TFN x => fcTfn x
904          | F.TAPP (f,tycs) => cont(m, F.TAPP(substval f, tycs))
905          | F.SWITCH x => fcSwitch x
906          | F.CON x => fcCon x
907          | F.RECORD x => fcRecord x
908          | F.SELECT x => fcSelect x
909          | F.RAISE (v,ltys) => cont(m, F.RAISE(substval v, ltys))
910          | F.HANDLE (le,v) => cont(m, F.HANDLE(loop m le #2, substval v))
911          | F.BRANCH x => fcBranch x
912          | F.PRIMOP x => fcPrimop x
913  end  end
914    
915  in  in
916      (*  C.collect fdec; *)      (*  C.collect fdec; *)
917      case cexp S.empty      case fcexp S.empty
918                M.empty (F.FIX([fdec], F.RET[F.VAR f])) #2                M.empty (F.FIX([fdec], F.RET[F.VAR f])) #2
919       of F.FIX([fdec], F.RET[F.VAR f]) => fdec       of F.FIX([fdec], F.RET[F.VAR f]) => fdec
920        | fdec => bug "invalid return fundec"        | fdec => bug "invalid return fundec"

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

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