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 184, Sun Nov 8 21:18:20 1998 UTC revision 185, Tue Nov 10 21:01:05 1998 UTC
# Line 213  Line 213 
213      LT.tc_eqv(tyc1,tyc2) andalso tycs_eq(tycs1,tycs2)      LT.tc_eqv(tyc1,tyc2) andalso tycs_eq(tycs1,tycs2)
214    | tycs_eq _ = false    | tycs_eq _ = false
215    
216    fun contract (fdec as (_,f,_,_)) = let
217    
218    val inlineWitness = ref false
219    
220  (* cfg: is used for deBruijn renumbering when inlining at different depths  (* cfg: is used for deBruijn renumbering when inlining at different depths
221   * ifs (inlined functions): records which functions we're currently inlining   * ifs (inlined functions): records which functions we're currently inlining
222   *     in order to detect loops   *     in order to detect loops
# Line 328  Line 332 
332                    * and kill only the function name.  This inlining strategy                    * and kill only the function name.  This inlining strategy
333                    * looks inoffensive enough, but still requires some care:                    * looks inoffensive enough, but still requires some care:
334                    * see comments at the begining of this file and in cfun *)                    * see comments at the begining of this file and in cfun *)
335                   (C.unuse (fn _ => ()) true g;                   (inlineWitness := true;
336                      C.unuse (fn _ => ()) true g;
337                    ASSERT(not (used g), "killed");                    ASSERT(not (used g), "killed");
338                    (SOME(F.LET(map #1 args, F.RET vs, body), od), ifs))                    (SOME(F.LET(map #1 args, F.RET vs, body), od), ifs))
339    
# Line 344  Line 349 
349                   let val nle =                   let val nle =
350                           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))
351                   in                   in
352                         inlineWitness := true;
353                       (*  say ("\nInlining "^(C.LVarString g)); *)                       (*  say ("\nInlining "^(C.LVarString g)); *)
354                       (app (unuseval (undertake m)) vs) handle x => raise x;                       (app (unuseval (undertake m)) vs) handle x => raise x;
355                       (C.unuse (undertake m) true g) handle x => raise x;                       (C.unuse (undertake m) true g) handle x => raise x;
# Line 425  Line 431 
431                | cfun (m,fdec as ({inline,cconv,known,isrec},f,args,body)::fs,acc) =                | cfun (m,fdec as ({inline,cconv,known,isrec},f,args,body)::fs,acc) =
432                  if used f then                  if used f then
433                      let (*  val _ = say ("\nEntering "^(C.LVarString f)) *)                      let (*  val _ = say ("\nEntering "^(C.LVarString f)) *)
434                            val oldWitness =
435                                (!inlineWitness before inlineWitness := false)
436                          (* make up the bindings for args inside the body *)                          (* make up the bindings for args inside the body *)
437                          fun addnobind ((lv,lty),m) =                          fun addnobind ((lv,lty),m) =
438                              addbind(m, lv, Var(lv, SOME lty))                              addbind(m, lv, Var(lv, SOME lty))
439                          val nm = foldl addnobind m args                          val nm = foldl addnobind m args
440                          (* contract the body and create the resulting fundec *)                          (* contract the body and create the resulting fundec *)
441                          val nbody = cexp cfg (S.add(f, ifs)) nm body #2                          val nbody = cexp cfg (S.add(f, ifs)) nm body #2
442                          (* The `inline' bit has to be turned off because                          (* if inlining took place, the body might be completely
443                           * it applied to the function before contraction                           * changed (read: bigger), so we have to reset the
444                           * but might not apply to its new form (inlining might                           * `inline' bit *)
                          * have increased its size substantially or made it  
                          * recursive in a different way which could make further  
                          * inlining even dangerous) *)  
                         val nknown = known orelse not(C.escaping f)  
445                          val nfk = {isrec=isrec, cconv=cconv,                          val nfk = {isrec=isrec, cconv=cconv,
446                                     inline=F.IH_SAFE, known=nknown}                                     known=known orelse not(C.escaping f),
447                                       inline=if !inlineWitness
448                                              then F.IH_SAFE
449                                              else (inline before
450                                                    inlineWitness := oldWitness)}
451                          (* update the binding in the map.  This step is not                          (* update the binding in the map.  This step is not
452                           * not just a mere optimization but is necessary                           * not just a mere optimization but is necessary
453                           * because if we don't do it and the function                           * because if we don't do it and the function
# Line 467  Line 475 
475                       * escaping one.  It's dangerous for optimisations based                       * escaping one.  It's dangerous for optimisations based
476                       * on known functions (elimination of dead args, f.ex)                       * on known functions (elimination of dead args, f.ex)
477                       * and could generate cases where call>use in collect *)                       * and could generate cases where call>use in collect *)
478                      in if not (C.escaping f andalso                      in if not (C.escaping f andalso not (C.escaping g))
                                not (C.escaping g))  
479                         then let                         then let
480                             (* if an earlier function h has been eta-reduced                             (* if an earlier function h has been eta-reduced
481                              * to f, we have to be careful to update its                              * to f, we have to be careful to update its
# Line 518  Line 525 
525                          (* construct the new body *)                          (* construct the new body *)
526                          val nbody =                          val nbody =
527                              F.LET(map #1 (filter args),                              F.LET(map #1 (filter args),
528                                    F.RET(map valOf (filter (C.actuals g))),                                    F.RET(map O.valOf (filter (C.actuals g))),
529                                    body)                                    body)
530                      in (fk, g, nargs, nbody)                      in (fk, g, nargs, nbody)
531                      end                      end
# Line 613  Line 620 
620    
621        | F.SWITCH (v,ac,arms,def) =>        | F.SWITCH (v,ac,arms,def) =>
622          (case ((val2sval m v) handle x => raise x)          (case ((val2sval m v) handle x => raise x)
623            of sv as (Var{1=lvc,...} | Select{1=lvc,...} | Decon{1=lvc, ...}            of sv as Con (lvc,v,dc1,tycs1) =>
                     | (* will probably never happen *) Record{1=lvc,...}) =>  
              let fun carm (F.DATAcon(dc,tycs,lv),le) =  
                       let val ndc = cdcon dc  
                           val nm = addbind(m, lv, Decon(lv, F.VAR lvc, ndc, tycs))  
                           (* we can rebind lv to a more precise value  
                            * !!BEWARE!!  This rebinding is misleading:  
                            * - it gives the impression that `lvc' is built from  
                            *   `lv' although the reverse is true:  if `lvc' is  
                            *   undertaken, `lv's count should *not* be updated!  
                            *   Luckily, `lvc' will not become dead while rebound  
                            *   to Con(lv) because it's used by the SWITCH.  
                            *   All in all, it works fine, but it's not as  
                            *   straightforward as it seems.  
                            * - it seems to be a good idea, but it can hide  
                            *   other opt-opportunities since it hides the  
                            *   previous binding. *)  
                           val nm = addbind(nm, lvc, Con(lvc, F.VAR lv, ndc, tycs))  
                       in (F.DATAcon(ndc, tycs, lv), loop nm le #2)  
                       end  
                     | carm (con,le) = (con, loop m le #2)  
                   val narms = map carm arms  
                   val ndef = Option.map (fn le => loop m le #2) def  
              in  
                   cont(m, F.SWITCH(sval2val sv, ac, narms, ndef))  
              end  
   
            | Con (lvc,v,dc1,tycs1) =>  
624               let fun killle le = ((#1 (C.unuselexp (undertake m))) le) handle x => raise x               let fun killle le = ((#1 (C.unuselexp (undertake m))) le) handle x => raise x
625                   fun kill lv le =                   fun kill lv le =
626                       ((#1 (C.unuselexp (undertake (addbind(m,lv,Var(lv,NONE)))))) le) handle x => raise x                       ((#1 (C.unuselexp (undertake (addbind(m,lv,Var(lv,NONE)))))) le) handle x => raise x
# Line 648  Line 628 
628                     | killarm _ = buglexp("bad arm in switch(con)", le)                     | killarm _ = buglexp("bad arm in switch(con)", le)
629    
630                   fun carm ((F.DATAcon(dc2,tycs2,lv),le)::tl) =                   fun carm ((F.DATAcon(dc2,tycs2,lv),le)::tl) =
631                       if FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) then                       (* sometimes lty1 <> lty2 :-( so this doesn't work:
632                          *  FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) *)
633                         if #2 dc1 = #2 (cdcon dc2) then
634                           (map killarm tl; (* kill the rest *)                           (map killarm tl; (* kill the rest *)
635                            Option.map killle def; (* and the default case *)                            O.map killle def; (* and the default case *)
636                            loop (substitute(m, lv, val2sval m v, F.VAR lvc))                            loop (substitute(m, lv, val2sval m v, F.VAR lvc))
637                                 le cont)                                 le cont)
638                       else                       else
639                           (* kill this arm and continue with the rest *)                           (* kill this arm and continue with the rest *)
640                           (kill lv le; carm tl)                           (kill lv le; carm tl)
641                     | carm [] = loop m (Option.valOf def) cont                     | carm [] = loop m (O.valOf def) cont
642                     | carm _ = buglexp("unexpected arm in switch(con,...)", le)                     | carm _ = buglexp("unexpected arm in switch(con,...)", le)
643               in carm arms               in carm arms
644               end               end
645    
646             | Val v =>             | sv as Val v =>
647               let fun kill le = ((#1 (C.unuselexp (undertake m))) le) handle x => raise x               let fun kill le = ((#1 (C.unuselexp (undertake m))) le) handle x => raise x
648                   fun carm ((con,le)::tl) =                   fun carm ((con,le)::tl) =
649                       if eqConV(con, v) then                       if eqConV(con, v) then
650                            (map (kill o #2) tl;                            (map (kill o #2) tl;
651                             Option.map kill def;                             O.map kill def;
652                             loop m le cont)                             loop m le cont)
653                       else (kill le; carm tl)                       else (kill le; carm tl)
654                     | carm [] = loop m (Option.valOf def) cont                     | carm [] = loop m (O.valOf def) cont
655               in carm arms               in carm arms
656               end               end
657    
658               | sv as (Var{1=lvc,...} | Select{1=lvc,...} | Decon{1=lvc, ...}
659                 | (* will probably never happen *) Record{1=lvc,...}) =>
660                 (case (arms,def)
661                   of ([(F.DATAcon(dc,tycs,lv),le)],NONE) =>
662                      (* this is a mere DECON, so we can push the let binding
663                       * (hidden in cont) inside and maybe even drop the DECON *)
664                      let val ndc = cdcon dc
665                          val nm = addbind(m, lv, Decon(lv, F.VAR lvc, ndc, tycs))
666                          (* see below *)
667                          val nm = addbind(nm, lvc, Con(lvc, F.VAR lv, ndc, tycs))
668                          val nle = loop nm le cont
669                          val nv = sval2val sv
670                      in
671                          if used lv then
672                              F.SWITCH(nv,ac,[(F.DATAcon(ndc,tycs,lv),nle)],NONE)
673                          else (unuseval (undertake m) nv; nle)
674                      end
675                    | (([(_,le)],NONE) | ([],SOME le)) =>
676                      (* This should never happen, but we can optimize it away *)
677                      (unuseval (undertake m) (sval2val sv); loop m le cont)
678                    | _ =>
679                      let fun carm (F.DATAcon(dc,tycs,lv),le) =
680                              let val ndc = cdcon dc
681                                  val nm = addbind(m, lv,
682                                                   Decon(lv, F.VAR lvc, ndc, tycs))
683                                  (* we can rebind lv to a more precise value
684                                   * !!BEWARE!!  This rebinding is misleading:
685                                   * - it gives the impression that `lvc' is built
686                                   *   from`lv' although the reverse is true:
687                                   *   if `lvc' is undertaken, `lv's count should
688                                   *   *not* be updated!
689                                   *   Luckily, `lvc' will not become dead while
690                                   *   rebound to Con(lv) because it's used by the
691                                   *   SWITCH. All in all, it works fine, but it's
692                                   *   not as straightforward as it seems.
693                                   * - it seems to be a good idea, but it can hide
694                                   *   other opt-opportunities since it hides the
695                                   *   previous binding. *)
696                                  val nm = addbind(nm, lvc,
697                                                   Con(lvc, F.VAR lv, ndc, tycs))
698                              in (F.DATAcon(ndc, tycs, lv), loop nm le #2)
699                              end
700                            | carm (con,le) = (con, loop m le #2)
701                          val narms = map carm arms
702                          val ndef = Option.map (fn le => loop m le #2) def
703                      in cont(m, F.SWITCH(sval2val sv, ac, narms, ndef))
704                      end)
705    
706             | sv as (Fun _ | TFun _) =>             | sv as (Fun _ | TFun _) =>
707               bugval("unexpected switch arg", sval2val sv))               bugval("unexpected switch arg", sval2val sv))
708    
# Line 769  Line 800 
800          end          end
801  end  end
802    
803  fun contract (fdec as (_,f,_,_)) =  in
804      ((*  C.collect fdec; *)      (*  C.collect fdec; *)
805       case cexp (DI.top,DI.top) S.empty       case cexp (DI.top,DI.top) S.empty
806                 M.empty (F.FIX([fdec], F.RET[F.VAR f])) #2                 M.empty (F.FIX([fdec], F.RET[F.VAR f])) #2
807        of F.FIX([fdec], F.RET[F.VAR f]) => fdec        of F.FIX([fdec], F.RET[F.VAR f]) => fdec
808         | fdec => bug "invalid return fundec")        | fdec => bug "invalid return fundec"
809    end
810    
811  end  end
812  end  end

Legend:
Removed from v.184  
changed lines
  Added in v.185

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