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 162, Tue Oct 27 22:16:21 1998 UTC revision 163, Thu Oct 29 21:00:27 1998 UTC
# Line 22  Line 22 
22   * - elimination of Con(Decon x)   * - elimination of Con(Decon x)
23   * - update counts when selecting a SWITCH alternative   * - update counts when selecting a SWITCH alternative
24   * - contracting RECORD(R.1,R.2) => R  (only if the type is easily available)   * - contracting RECORD(R.1,R.2) => R  (only if the type is easily available)
25     * - dropping of arguments
26   *)   *)
27    
28  (* things that lcontract.sml does that fcontract doesn't do (yet):  (* things that lcontract.sml does that fcontract doesn't do (yet):
# Line 39  Line 40 
40   * - Handler operations   * - Handler operations
41   * - primops expressions   * - primops expressions
42   * - branch expressions   * - branch expressions
  * - dropping of arguments  
43   *)   *)
44    
45  (* things that could also be added:  (* things that could also be added:
# Line 159  Line 159 
159      structure PP = PPFlint      structure PP = PPFlint
160      structure FU = FlintUtil      structure FU = FlintUtil
161      structure LT = LtyExtern      structure LT = LtyExtern
162        structure OU = OptUtils
163      structure CTRL = Control.FLINT      structure CTRL = Control.FLINT
164  in  in
165    
# Line 226  Line 227 
227            | Con{1=lv,...} | Select{1=lv,...} | Var{1=lv,...}) => F.VAR lv            | Con{1=lv,...} | Select{1=lv,...} | Var{1=lv,...}) => F.VAR lv
228            | Val v => v            | Val v => v
229    
230      fun val2sval m (F.VAR ov) = lookup m ov      fun val2sval m (F.VAR ov) =
231            ((lookup m ov) handle x => (PP.printSval(F.VAR ov); raise x))
232        | val2sval m v = Val v        | val2sval m v = Val v
233    
234      fun bugsv (msg,sv) = bugval(msg, sval2val sv)      fun bugsv (msg,sv) = bugval(msg, sval2val sv)
# Line 288  Line 290 
290          (s, Access.EXN(Access.LVAR(substvar lv)), lty)          (s, Access.EXN(Access.LVAR(substvar lv)), lty)
291        | cdcon dc = dc        | cdcon dc = dc
292    
293        fun isrec (F.FK_FCT | F.FK_FUN{isrec=NONE,...}) = false
294          | isrec _ = true
295    
296        fun inlinable F.FK_FCT = false
297          | inlinable (F.FK_FUN{inline,...}) = inline
298    
299      (* F.APP inlining (if any)      (* F.APP inlining (if any)
300       * `ifs' is the set of function we are currently inlining       * `ifs' is the set of function we are currently inlining
301       * `f' is the function, `vs' its arguments.       * `f' is the function, `vs' its arguments.
# Line 297  Line 305 
305       *)       *)
306      fun inline ifs (f,vs) =      fun inline ifs (f,vs) =
307          case ((val2sval m f) handle x => raise x)          case ((val2sval m f) handle x => raise x)
308           of Fun(g,body,args,F.FK_FUN{isrec,inline,...},od) =>           of Fun(g,body,args,fk,od) =>
309              (ASSERT(C.usenb g > 0, "C.usenb g > 0");              (ASSERT(C.usenb g > 0, "C.usenb g > 0");
310               if C.usenb g = 1 andalso od = d andalso not (C.recursive g)               (* if a function is mutually recursive with one of the
311                  * functions inside which we are, inlining it will turn
312                  * extrnal uses in internal ones.  The 'body move' optimization
313                  * used below cannot be used in such a case *)
314                 if C.usenb g = 1 andalso od = d andalso not (isrec fk)
315    
316               (* simple inlining:  we should copy the body and then               (* simple inlining:  we should copy the body and then
317                * kill the function, but instead we just move the body                * kill the function, but instead we just move the body
# Line 316  Line 328 
328                * mutually recursive with its main function.  On another hand,                * mutually recursive with its main function.  On another hand,
329                * self recursion (C.recursive) is too dangerous to be inlined                * self recursion (C.recursive) is too dangerous to be inlined
330                * except for loop unrolling which we don't support yet *)                * except for loop unrolling which we don't support yet *)
331               else if inline andalso od = d andalso not(S.member ifs g) then               else if ((inlinable fk orelse
332                   let val nle = FU.copy M.empty (F.LET(map #1 args, F.RET vs, body))                         (C.usenb g = 1 andalso not (C.recursive g)))
333                              andalso od = d andalso not(S.member ifs g)) then
334                     let val nle =
335                             FU.copy M.empty (F.LET(map #1 args, F.RET vs, body))
336                       val _ = if C.recursive g then                       val _ = if C.recursive g then
337                           (say "\n inlining recursive function ";                           (say "\n inlining recursive function ";
338                                PP.printSval (F.VAR g)) else ()                                PP.printSval (F.VAR g)) else ()
339                   in C.uselexp nle;                   in C.uselexp nle;
340                       app (unuseval (undertake m)) vs;                       app (unuseval (undertake m)) vs;
341                       C.unuse (undertake m) true g;                       (* FIXME: this `unuse' can lead to bogus counts if we
342                          * currently are in a function mutually recursive with g *)
343                          if isrec fk then () else C.unuse (undertake m) true g;
344                       (SOME(nle, od), S.add(g, ifs))                       (SOME(nle, od), S.add(g, ifs))
345                   end                   end
   
346               else (NONE, ifs))               else (NONE, ifs))
347            | sv => (NONE, ifs)            | sv => (NONE, ifs)
348  in  in
# Line 480  Line 496 
496                             C.transfer(f,g); C.unuse (undertake nm) true g;                             C.transfer(f,g); C.unuse (undertake nm) true g;
497                             (addbind(nm, f, svg),f::hs)                             (addbind(nm, f, svg),f::hs)
498                         end                         end
499                           (* the default case could ensure the inline *)
500                         else (m, hs)                         else (m, hs)
501                      end                      end
502                  else (m, hs)                  else (m, hs)
503                | ceta (_,(m,hs)) = (m, hs)                | ceta (_,(m,hs)) = (m, hs)
504    
505                (* add droparg wrapper if useful *)
506                fun dropargs (f as (fk,g,args,body):F.fundec,fs) =
507                    case fk
508                     of F.FK_FCT => f::fs (* we can't make inlinable fcts *)
509                      | F.FK_FUN{inline=true,...} => f::fs (* no use *)
510                      | fk as F.FK_FUN{isrec,...} =>
511                        let val used = map (fn (v,t) => (C.usenb v > 0)) args
512                        (* if all args are used, there's nothing we can do *)
513                        in if List.all OU.id used then f::fs else
514                            let fun filter xs = OU.filter(used, xs)
515                                val ng = cplv g
516                                val _ = (C.new true ng; C.use true ng; C.extcounts g)
517                                val nargs = map (fn (v,t) => (cplv v, t)) args
518                                val _ = app (fn (v,t) =>
519                                             (C.new false v; C.use false v))
520                                            nargs
521                                val appargs = (map (F.VAR o #1) nargs)
522                                val (nfk,nfk') = OU.fk_wrap(fk, isrec)
523                                val nf = (nfk, g, nargs,
524                                          F.APP(F.VAR ng, filter appargs))
525                                val nf' = (nfk', ng, filter args, body)
526                            in nf'::nf::fs
527                            end
528                        end
529    
530              (* junk unused funs *)              (* junk unused funs *)
531              val fs = List.filter (used o #2) fs              val fs = List.filter (used o #2) fs
532    
533                (* add wrappers to drop unused arguments *)
534                val fs = foldl dropargs [] fs
535    
536              (* register the new bindings (uncontracted for now) *)              (* register the new bindings (uncontracted for now) *)
537              val nm = foldl (fn (fdec as (fk,f,args,body),m) =>              val nm = foldl (fn (fdec as (fk,f,args,body),m) =>
538                              addbind(m, f, Fun(f, body, args, fk, od)))                              addbind(m, f, Fun(f, body, args, fk, od)))
# Line 508  Line 553 
553              (* junk newly unused funs *)              (* junk newly unused funs *)
554              val fs = List.filter (used o #2) fs              val fs = List.filter (used o #2) fs
555          in          in
556              if List.null fs then nle else F.FIX(fs,nle)              case fs
557                 of [] => nle
558                  | [f1 as (F.FK_FUN{isrec=NONE,...},f,args,F.APP _),f2] =>
559                    (* gross hack: dropargs might have added a second
560                     * non-recursive function.  we need to split them into
561                     * 2 FIXes.  This is very ad-hoc *)
562                    F.FIX([f2], F.FIX([f1], nle))
563                  | (F.FK_FUN{isrec=NONE,...},f,args,body)::_::_ =>
564                    bug "gross hack failed"
565                  | _ => F.FIX(fs, nle)
566          end          end
567    
568        | F.APP (f,vs) =>        | F.APP (f,vs) =>

Legend:
Removed from v.162  
changed lines
  Added in v.163

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