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/fixfix.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/FLINT/opt/fixfix.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 183, Sun Nov 8 16:58:19 1998 UTC revision 184, Sun Nov 8 21:18:20 1998 UTC
# Line 30  Line 30 
30      structure PP = PPFlint      structure PP = PPFlint
31      structure LT = LtyExtern      structure LT = LtyExtern
32      structure OU = OptUtils      structure OU = OptUtils
33        structure CTRL = Control.FLINT
34  in  in
35    
36  val say = Control.Print.say  val say = Control.Print.say
# Line 41  Line 42 
42  val cplv = LambdaVar.dupLvar  val cplv = LambdaVar.dupLvar
43    
44  (* to limit the amount of uncurrying *)  (* to limit the amount of uncurrying *)
45  val maxargs = Control.FLINT.maxargs  val maxargs = CTRL.maxargs
46    
47  structure SccNode = struct  structure SccNode = struct
48      type node = LambdaVar.lvar      type node = LambdaVar.lvar
# Line 80  Line 81 
81       * - r:bool indicates whether the head was recursive       * - r:bool indicates whether the head was recursive
82       * - na:int gives the number of args still allowed *)       * - na:int gives the number of args still allowed *)
83      fun curry (hd,r,na) (le as (F.FIX([(fk,f,args,body)], F.RET[F.VAR lv]))) =      fun curry (hd,r,na) (le as (F.FIX([(fk,f,args,body)], F.RET[F.VAR lv]))) =
84          if lv = f then          if lv = f andalso #inline fk = F.IH_SAFE then
85              case fk              let val fisrec = isSome(#isrec fk)
              of F.FK_FCT => ([], le)    (* don't bother *)  
               | F.FK_FUN {inline=true,...} => ([], le) (* don't bother *)  
               | F.FK_FUN fk' =>  
                 let val fisrec = isSome(#isrec fk')  
86                      val na = na - length args                      val na = na - length args
87                  in if na >= 0 andalso (hd orelse r orelse not fisrec) then                  in if na >= 0 andalso (hd orelse r orelse not fisrec) then
88                      (* recursive functions are only accepted for uncurrying                      (* recursive functions are only accepted for uncurrying
# Line 106  Line 103 
103      fun uncurry (args as (fk,f,fargs)::_::_,body) =      fun uncurry (args as (fk,f,fargs)::_::_,body) =
104          let val f' = cplv f     (* the new fun name *)          let val f' = cplv f     (* the new fun name *)
105    
106              fun getrtypes ([],rtys) = (NONE, rtys)              (* find the rtys of the uncurried function *)
107                | getrtypes ((fk,f,fargs:(F.lvar * F.lty) list)::rest,rtys) =              fun getrtypes (({isrec=SOME(rtys,_),...}:F.fkind,_,_),_) = SOME rtys
108                  case fk                | getrtypes ((_,_,_),rtys) =
109                   of F.FK_FUN{isrec=SOME rtys,...} =>                  Option.map (fn [lty] => #2(LT.ltd_fkfun lty)
                     let val fty = LT.ltc_fkfun(fk, map #2 fargs, rtys)  
                         val (_,rtys) = getrtypes(rest, SOME rtys)  
                     in (SOME fty, rtys)  
                     end  
                   | _ =>  
                     let val rtys = Option.map (fn [lty] => #2(LT.ltd_fkfun lty)  
110                                                  | _ => bug "strange isrec") rtys                                                  | _ => bug "strange isrec") rtys
                         val (fty,rtys) = getrtypes(rest,rtys)  
                         val fty = Option.map  
                                       (fn lty =>  
                                        LT.ltc_fkfun(fk, map #2 fargs, [lty]))  
                                       fty  
                     in (fty,rtys)  
                     end  
111    
112              (* create the new fkinds *)              (* create the new fkinds *)
113              val (fty,rtys') = getrtypes(args, NONE)              val (nfk,nfk') = OU.fk_wrap(fk, foldl getrtypes NONE args)
             val (nfk,nfk') = OU.fk_wrap(fk, rtys')  
114    
115              (* funarg renaming *)              (* funarg renaming *)
116              fun newargs fargs = map (fn (a,t) => (cplv a,t)) fargs              fun newargs fargs = map (fn (a,t) => (cplv a,t)) fargs
117    
118              (* create (curried) wrappers to be inlined *)              (* create (curried) wrappers to be inlined *)
119              fun recurry ([],args) = F.APP(F.VAR f', map (F.VAR o #1) args)              fun recurry ([],args) = F.APP(F.VAR f', map (F.VAR o #1) args)
120                | recurry ((fk,f,fargs)::rest,args) =                | recurry (({inline,isrec,known,cconv},f,fargs)::rest,args) =
121                  let val fk = case fk                  let val fk = {inline=F.IH_ALWAYS, isrec=NONE,
122                                of F.FK_FCT => fk                                known=known, cconv=cconv}
                                | F.FK_FUN{isrec,fixed,known,inline} =>  
                                  F.FK_FUN{isrec=NONE, fixed=fixed,  
                                           known=known, inline=true}  
123                      val nfargs = newargs fargs                      val nfargs = newargs fargs
124                      val g = cplv f'                      val g = cplv f'
125                  in F.FIX([(fk, g, nfargs, recurry(rest, args @ nfargs))],                  in F.FIX([(fk, g, nfargs, recurry(rest, args @ nfargs))],
# Line 162  Line 142 
142                | uncurry' ((fk,f,fargs)::rest,args) =                | uncurry' ((fk,f,fargs)::rest,args) =
143                  let val le = uncurry'(rest, args @ fargs)                  let val le = uncurry'(rest, args @ fargs)
144                  in case fk                  in case fk
145                      of F.FK_FUN{isrec=SOME _, ...} =>                      of {isrec=SOME _,cconv,known,inline} =>
146                         let val nfargs = newargs fargs                         let val nfargs = newargs fargs
147                             val fk = case fk                             val fk = {isrec=NONE, inline=F.IH_ALWAYS,
148                                       of F.FK_FCT => fk                                       known=known, cconv=cconv}
                                       | F.FK_FUN{isrec,fixed,known,inline} =>  
                                         F.FK_FUN{isrec=NONE, fixed=fixed,  
                                                  known=known, inline=true}  
149                         in F.FIX([(fk, f, nfargs,                         in F.FIX([(fk, f, nfargs,
150                                    recurry(rest, args @ nfargs))],                                    recurry(rest, args @ nfargs))],
151                                  le)                                  le)
# Line 202  Line 179 
179             val (s,fv,le) = fexp(fv, le)             val (s,fv,le) = fexp(fv, le)
180             val lename = LambdaVar.mkLvar()             val lename = LambdaVar.mkLvar()
181             val m = M.singleton(lename, (S.members(S.inter(fv, funs)), 0,             val m = M.singleton(lename, (S.members(S.inter(fv, funs)), 0,
182                                          F.FK_FCT, [], le))                                          {inline=F.IH_SAFE, isrec=NONE,
183                                             known=true,cconv=F.CC_FCT},
184                                            [], le))
185    
186             (* process each fun *)             (* process each fun *)
187             fun ffun (fdec as (fk,f,args,body):F.fundec,(s,fv,funs,m)) =             fun ffun (fdec as (fk,f,args,body):F.fundec,(s,fv,funs,m)) =
# Line 234  Line 213 
213             (* turns them back into flint code *)             (* turns them back into flint code *)
214             fun sccconvert (SCC.SIMPLE f,le) =             fun sccconvert (SCC.SIMPLE f,le) =
215                 (* a simple function.  Fix the fk accordingly *)                 (* a simple function.  Fix the fk accordingly *)
216                 let val (_,s,fk,args,body) = M.lookup m f                 let val (_,s,{isrec,cconv,known,inline},args,body) = M.lookup m f
217                     val fk =                     val fk =
                        case fk  
                         of F.FK_FCT => F.FK_FCT  
                          | F.FK_FUN {isrec,fixed,known,inline} =>  
218                             (* small functions inlining heuristic *)                             (* small functions inlining heuristic *)
219                             let val small = s < !Control.FLINT.inlineThreshold                         let val inline' =
220                             in F.FK_FUN{isrec=NONE, fixed=fixed,                                 if inline = F.IH_SAFE andalso
221                                         known=known, inline=inline orelse small}                                     s < !CTRL.inlineThreshold then
222                                       F.IH_ALWAYS
223                                   else inline
224                           in {isrec=NONE, inline=inline',
225                               known=known, cconv=cconv}
226                             end                             end
227                 in F.FIX([(fk, f, args, body)], le)                 in F.FIX([(fk, f, args, body)], le)
228                 end                 end
229               | sccconvert (SCC.RECURSIVE fs,le) =               | sccconvert (SCC.RECURSIVE fs,le) =
230                 let fun scfun f =                 let fun scfun f =
231                         let val (_,_,fk,args,body) = M.lookup m f                         let val (_,s,fk as {isrec,cconv,known,inline},args,le) =
232                         in (fk, f, args, body) end                                 M.lookup m f
233                               val fk' =
234                                   (* let's check for unroll opportunities.
235                                    * This heuristic is pretty bad since it doesn't
236                                    * take the number of rec-calls into account *)
237                                   case (isrec,inline)
238                                    of (SOME(_,(F.LK_LOOP|F.LK_WHILE)),F.IH_SAFE) =>
239                                       if s < !CTRL.unrollThreshold then
240                                           {inline=F.IH_UNROLL, isrec=isrec,
241                                            cconv=cconv, known=known}
242                                       else fk
243                                     | _ => fk
244                           in (fk, f, args, le) end
245                 in F.FIX(map scfun fs, le)                 in F.FIX(map scfun fs, le)
246                 end                 end
247         in         in

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

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