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 203, Sat Dec 19 20:51:39 1998 UTC revision 204, Sun Dec 20 11:23:30 1998 UTC
# Line 534  Line 534 
534                      * recursively *)                      * recursively *)
535                     (C.use NONE fi; undertake m f; (m,fs))                     (C.use NONE fi; undertake m f; (m,fs))
536                 else                 else
537                     let (*  val _ = say ("\nEntering "^(C.LVarString f)) *)                     let (* val _ = say ("Entering "^(C.LVarString f)^"\n") *)
538                         val saved_ic = inline_count()                         val saved_ic = inline_count()
539                         (* make up the bindings for args inside the body *)                         (* make up the bindings for args inside the body *)
540                         val actuals = if isSome isrec orelse                         val actuals = if isSome isrec orelse
# Line 561  Line 561 
561                          * the old uncontracted code *)                          * the old uncontracted code *)
562                         val nm = addbind(m, f, Fun(f, nbody, args, nfk, ref []))                         val nm = addbind(m, f, Fun(f, nbody, args, nfk, ref []))
563                     in (nm, (nfk, f, args, nbody)::fs)                     in (nm, (nfk, f, args, nbody)::fs)
564                     (*  before say ("\nExiting "^(C.LVarString f)) *)                       (* before say ("Exiting "^(C.LVarString f)^"\n") *)
565                     end                     end
566              end              end
567    
# Line 663  Line 663 
663          (* check for eta redexes *)          (* check for eta redexes *)
664          val (nm,fs,_) = foldl fcEta (nm,[],[]) fs          val (nm,fs,_) = foldl fcEta (nm,[],[]) fs
665    
666          val (funs,wrappers) =          val (wrappers,funs) =
667              List.partition (fn (_,_,_,{inline=F.IH_ALWAYS,...},_) => true              List.partition (fn (_,_,_,{inline=F.IH_ALWAYS,...},_) => true
668                               | _ => false) fs                               | _ => false) fs
669          val (funs,maybes) =          val (maybes,funs) =
670              List.partition (fn (_,_,_,{inline=F.IH_MAYBE _,...},_) => true              List.partition (fn (_,_,_,{inline=F.IH_MAYBE _,...},_) => true
671                               | _ => false) funs                               | _ => false) funs
672    
673          (* contract the main body *)          (* First contract the big inlinable functions.  This might make them
674          val nle = loop nm le cont           * non-inlinable and we'd rather know that before we inline them.
675          (* contract the functions *)           * Then we inline the body (so that we won't go through the inline-once
676             * functions twice), then the normal functions and finally the wrappers
677             * (which need to come last to make sure that they get inlined if
678             * at all possible) *)
679          val fs = []          val fs = []
         val (nm,fs) = foldl fcFun (nm,fs) funs  
680          val (nm,fs) = foldl fcFun (nm,fs) maybes          val (nm,fs) = foldl fcFun (nm,fs) maybes
681            val nle = loop nm le cont
682            val (nm,fs) = foldl fcFun (nm,fs) funs
683          val (nm,fs) = foldl fcFun (nm,fs) wrappers          val (nm,fs) = foldl fcFun (nm,fs) wrappers
684          (* junk newly unused funs *)          (* junk newly unused funs *)
685          val fs = List.filter (used o #2) fs          val fs = List.filter (used o #2) fs
# Line 686  Line 690 
690              (* gross hack: `wrap' might have added a second              (* gross hack: `wrap' might have added a second
691               * non-recursive function.  we need to split them into               * non-recursive function.  we need to split them into
692               * 2 FIXes.  This is _very_ ad-hoc. *)               * 2 FIXes.  This is _very_ ad-hoc. *)
693              F.FIX([f1], F.FIX([f2], nle))              F.FIX([f2], F.FIX([f1], nle))
694            | _ => F.FIX(fs, nle)            | _ => F.FIX(fs, nle)
695      end      end
696    
# Line 708  Line 712 
712                      * This inlining strategy looks inoffensive enough,                      * This inlining strategy looks inoffensive enough,
713                      * but still requires some care: see comments at the                      * but still requires some care: see comments at the
714                      * begining of this file and in cfun *)                      * begining of this file and in cfun *)
715                     (click_simpleinline();                     ((* say("SimpleInline of "^(C.LVarString g)^"\n"); *)
716                        click_simpleinline();
717                      ignore(C.unuse true gi);                      ignore(C.unuse true gi);
718                      loop m (F.LET(map #1 args, F.RET vs, body)) cont)                      loop m (F.LET(map #1 args, F.RET vs, body)) cont)
719                 fun copyinline () =                 fun copyinline () =
# Line 728  Line 733 
733                     let val nle = (F.LET(map #1 args, F.RET vs, body))                     let val nle = (F.LET(map #1 args, F.RET vs, body))
734                         val nle = C.copylexp M.empty nle                         val nle = C.copylexp M.empty nle
735                     in                     in
736                           (* say("CopyInline of "^(C.LVarString g)^"\n"); *)
737                         click_copyinline();                         click_copyinline();
738                         (app (unuseval m) vs);                         (app (unuseval m) vs);
739                         unusecall m g;                         unusecall m g;
# Line 890  Line 896 
896                        | g' (n,[]) =                        | g' (n,[]) =
897                          (case sval2lty sv                          (case sval2lty sv
898                            of SOME lty =>                            of SOME lty =>
899                               let val ltd = case rk                               let val ltd =
900                                              of F.RK_STRUCT => LT.ltd_str                                       case (rk, LT.ltp_tyc lty)
901                                               | F.RK_TUPLE _ => LT.ltd_tuple                                        of (F.RK_STRUCT,false) => LT.ltd_str
902                                               | _ => buglexp("bogus rk",le)                                         | (F.RK_TUPLE _,true) => LT.ltd_tuple
903                                           (* we might select out of a struct
904                                            * into a tuple or vice-versa *)
905                                           | _ => (fn _ => [])
906                               in if length(ltd lty) = n                               in if length(ltd lty) = n
907                                  then SOME sv else NONE                                  then SOME sv else NONE
908                               end                               end
# Line 943  Line 952 
952    
953  fun fcPrimop (po,vs,lv,le) =  fun fcPrimop (po,vs,lv,le) =
954      let val lvi = C.get lv      let val lvi = C.get lv
955          val pure = PO.purePrimop (#2 po)          val pure = not(PO.effect(#2 po))
956      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
957          let val nvs = map substval vs          let val nvs = map substval vs
958              val npo = cpo po              val npo = cpo po

Legend:
Removed from v.203  
changed lines
  Added in v.204

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