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
 [smlnj] / sml / trunk / src / compiler / FLINT / opt / fcontract.sml # Diff of /sml/trunk/src/compiler/FLINT/opt/fcontract.sml

revision 163, Thu Oct 29 21:00:27 1998 UTC revision 164, Sat Oct 31 01:03:30 1998 UTC
# Line 240  Line 240
240           of F.VAR lv => lv           of F.VAR lv => lv
241            | v => bugval ("unexpected val", v)            | v => bugval ("unexpected val", v)
242
243      fun unuseval f (F.VAR lv) = C.unuse f false lv      fun unuseval f (F.VAR lv) = ((C.unuse f false lv) handle x => raise x)
244        | unuseval f _ = ()        | unuseval f _ = ()
245
246      (* called when a variable becomes dead.      (* called when a variable becomes dead.
# Line 265  Line 265
265
266      fun addbind (m,lv,sv) = M.add(m, lv, sv)      fun addbind (m,lv,sv) = M.add(m, lv, sv)
267
268      (* substitute a value sv for a variable lv and unuse value v.      (* substitute a value sv for a variable lv and unuse value v. *)
* This doesn't quite work for eta-redex since the `use' we have
* to remove in that case is a non-escaping use, whereas this code
* assumes that we're getting rid of an escaping use *)
269      fun substitute (m, lv1, sv, v) =      fun substitute (m, lv1, sv, v) =
270          (case sval2val sv of F.VAR lv2 => C.transfer(lv1,lv2) | v2 => ();          (case sval2val sv of F.VAR lv2 => C.transfer(lv1,lv2) | v2 => ();
271           unuseval (undertake m) v;           unuseval (undertake m) v;
272           addbind(m, lv1, sv)) handle x =>           addbind(m, lv1, sv)) handle x =>
273               (say "\nwhile substituting ";               (say ("\nwhile substituting "^
274                PP.printSval (F.VAR lv1);                     (C.LVarString lv1)^
275                say " for ";                     " -> ");
276                PP.printSval (sval2val sv);                PP.printSval (sval2val sv);
277                raise x)                raise x)
278
# Line 306  Line 303
303      fun inline ifs (f,vs) =      fun inline ifs (f,vs) =
304          case ((val2sval m f) handle x => raise x)          case ((val2sval m f) handle x => raise x)
305           of Fun(g,body,args,fk,od) =>           of Fun(g,body,args,fk,od) =>
306              (ASSERT(C.usenb g > 0, "C.usenb g > 0");              (ASSERT(used g, "used "^(C.LVarString g));
307               (* if a function is mutually recursive with one of the               if C.usenb g = 1 andalso od = d andalso not(S.member ifs g)
* functions inside which we are, inlining it will turn
* extrnal uses in internal ones.  The 'body move' optimization
* used below cannot be used in such a case *)
if C.usenb g = 1 andalso od = d andalso not (isrec fk)
308
309               (* simple inlining:  we should copy the body and then               (* simple inlining:  we should copy the body and then
310                * kill the function, but instead we just move the body                * kill the function, but instead we just move the body
311                * and kill only the function name.  This inlining strategy                * and kill only the function name.  This inlining strategy
312                * looks inoffensive enough, but still requires some care:                * looks inoffensive enough, but still requires some care:
313                * see comments at the begining of this file and in cfun *)                * see comments at the begining of this file and in cfun *)
314               then (C.unuse (fn _ => ()) true g; ASSERT(not (used g), "killed");               then ((C.unuse (fn _ => ()) true g) handle x => raise x; ASSERT(not (used g), "killed");
315                     (SOME(F.LET(map #1 args, F.RET vs, body), od), ifs))                     (SOME(F.LET(map #1 args, F.RET vs, body), od), ifs))
316
317               (* aggressive inlining (but hopefully safe).  We allow               (* aggressive inlining (but hopefully safe).  We allow
# Line 328  Line 321
321                * mutually recursive with its main function.  On another hand,                * mutually recursive with its main function.  On another hand,
322                * self recursion (C.recursive) is too dangerous to be inlined                * self recursion (C.recursive) is too dangerous to be inlined
323                * except for loop unrolling which we don't support yet *)                * except for loop unrolling which we don't support yet *)
324               else if ((inlinable fk orelse               else if inlinable fk andalso od = d andalso not(S.member ifs g) then
(C.usenb g = 1 andalso not (C.recursive g)))
andalso od = d andalso not(S.member ifs g)) then
325                   let val nle =                   let val nle =
326                           FU.copy M.empty (F.LET(map #1 args, F.RET vs, body))                           C.copylexp M.empty (F.LET(map #1 args, F.RET vs, body))
327                       val _ = if C.recursive g then                   in
328                           (say "\n inlining recursive function ";                       (app (unuseval (undertake m)) vs) handle x => raise x;
329                            PP.printSval (F.VAR g)) else ()                       (C.unuse (undertake m) true g) handle x => raise x;
in C.uselexp nle;
app (unuseval (undertake m)) vs;
(* FIXME: this `unuse' can lead to bogus counts if we
* currently are in a function mutually recursive with g *)
if isrec fk then () else C.unuse (undertake m) true g;
330                       (SOME(nle, od), S.add(g, ifs))                       (SOME(nle, od), S.add(g, ifs))
331                   end                   end
332               else (NONE, ifs))               else (NONE, ifs))
# Line 387  Line 373
373                             (* here I should also check that le1 != le2 *)                             (* here I should also check that le1 != le2 *)
374                             let val nle1 = F.LET([lv], le1, body)                             let val nle1 = F.LET([lv], le1, body)
375                                 val nlv = cplv lv                                 val nlv = cplv lv
376                                 val body2 = FU.copy (M.add(M.empty,lv,nlv)) body                                 val _ = C.new NONE nlv
377                                   val body2 = C.copylexp (M.add(M.empty, lv, nlv))
378                                                          body
379                                 val nle2 = F.LET([nlv], le2, body2)                                 val nle2 = F.LET([nlv], le2, body2)
380                             in C.new false nlv; C.uselexp body2;                             in
381                                 lopm(wrap(F.BRANCH(po, vs, nle1, nle2)))                                 lopm(wrap(F.BRANCH(po, vs, nle1, nle2)))
382                             end                             end
383                         else                         else
# Line 402  Line 390
390                      | _ => clet()                      | _ => clet()
391                 end                 end
392               | F.RET vs =>               | F.RET vs =>
393                 (let fun simplesubst ((lv,v),m) =                 let fun simplesubst ((lv,v),m) =
394                          let val sv = (val2sval m v) handle x => raise x                          let val sv = (val2sval m v) handle x => raise x
395                          in substitute(m, lv, sv, sval2val sv)                          in substitute(m, lv, sv, sval2val sv)
396                          end                          end
397                 in loop (foldl simplesubst m (ListPair.zip(lvs, vs))) body                 in loop (foldl simplesubst m (ListPair.zip(lvs, vs))) body
398                 end handle x => raise x)                 end
399               | F.APP(f,vs) =>               | F.APP(f,vs) => clet()
400                 (case inline ifs (f, vs)               (* let-associativity can be annoying here.  I should really use
401                   of (SOME(le,od),ifs) => cexp (d,od) ifs m (F.LET(lvs, le, body))                * continuation passing style instead.
402                    | (NONE,_) => clet())                * (case inline ifs (f, vs)
403                  * of (SOME(le,od),ifs) => cexp (d,od) ifs m (F.LET(lvs, le, body))
404                  *  | (NONE,_) => clet()) *)
405               | (F.TAPP _ | F.SWITCH _ | F.RAISE _ | F.HANDLE _) =>               | (F.TAPP _ | F.SWITCH _ | F.RAISE _ | F.HANDLE _) =>
406                 clet()                 clet()
407          end          end
408
409        | F.FIX (fs,le) =>        | F.FIX (fs,le) =>
410          let fun cfun (m,[]:F.fundec list,acc) = acc          let (* register dump bindings *)
411                val m = foldl (fn (fdec as (_,f,_,_),m) =>
412                               addbind(m, f, Var(f,NONE)))
413                              m fs
414
415                (* The actual function contraction *)
416                fun cfun (m,[]:F.fundec list,acc) = acc
417                | cfun (m,fdec as (fk,f,args,body)::fs,acc) =                | cfun (m,fdec as (fk,f,args,body)::fs,acc) =
418                  if used f then                  if used f then
419                      let (* make up the bindings for args inside the body *)                      let (*  val _ = say ("\nEntering "^(C.LVarString f)) *)
420                            (* make up the bindings for args inside the body *)
421                          fun addnobind ((lv,lty),m) =                          fun addnobind ((lv,lty),m) =
422                              addbind(m, lv, Var(lv, SOME lty))                              addbind(m, lv, Var(lv, SOME lty))
423                          val nm = foldl addnobind m args                          val nm = foldl addnobind m args
424                          (* contract the body and create the resulting fundec *)                          (* contract the body and create the resulting fundec *)
425                          val nbody = C.inside f (fn()=> loop nm body)                          val nbody = cexp cfg (S.add(f, ifs)) nm body
426                          (* fixup the fkind info with new data.                          (* The `inline' bit has to be turned off because
* C.recursive only tells us if a fun is self-recursive
* but doesn't deal with mutual recursion.
* Also the `inline' bit has to be turned off because
427                           * it applied to the function before contraction                           * it applied to the function before contraction
428                           * but might not apply to its new form (inlining might                           * but might not apply to its new form (inlining might
429                           * have increased its size substantially or made it                           * have increased its size substantially or made it
# Line 438  Line 432
432                          val nfk =                          val nfk =
433                              case fk of F.FK_FCT => fk                              case fk of F.FK_FCT => fk
434                                | F.FK_FUN {isrec,fixed,known,inline} =>                                | F.FK_FUN {isrec,fixed,known,inline} =>
435                                  let val nisrec = if isSome isrec andalso                                  let val nknown = known orelse not(C.escaping f)
436                                                      null fs andalso                                  in F.FK_FUN{isrec=isrec, fixed=fixed,
null acc andalso
not(C.recursive f)
then NONE else isrec
val nknown = known orelse not(C.escaping f)
in F.FK_FUN{isrec=nisrec, fixed=fixed,
437                                              inline=false, known=nknown}                                              inline=false, known=nknown}
438                                  end                                  end
439                          (* update the binding in the map.  This step is not                          (* update the binding in the map.  This step is not
# Line 455  Line 444
444                           * the old uncontracted code *)                           * the old uncontracted code *)
445                          val nm = addbind(m, f, Fun(f, nbody, args, nfk, od))                          val nm = addbind(m, f, Fun(f, nbody, args, nfk, od))
446                      in cfun(nm, fs, (nfk, f, args, nbody)::acc)                      in cfun(nm, fs, (nfk, f, args, nbody)::acc)
447                               (*  before say ("\nExiting "^(C.LVarString f)) *)
448                      end                      end
449                  else cfun(m, fs, acc)                  else cfun(m, fs, acc)
450
# Line 485  Line 475
475                                             then addbind(m, h, svg) else m)                                             then addbind(m, h, svg) else m)
476                                            m hs                                            m hs
477                         in                         in
478                             (* if g is one of the members of the FIX, f might                             (* I could almost reuse `substitute' but the
479                              * appear in its body, so we don't know what parts                              * unuse in substitute assumes the val is escaping *)
480                              * of the counts of f should be counted as inside                             C.transfer(f, g);
481                              * g and what parts should be counted as outside                             C.unuse (undertake m) true g;
482                              * so we take the conservative approach of counting                             (addbind(m, f, svg), f::hs)
* them in both *)
if isSome(List.find (fn (_,f,_,_) => f = g) fs)
then C.inside g (fn()=> C.addto(f,g)) else ();
C.transfer(f,g); C.unuse (undertake nm) true g;
(addbind(nm, f, svg),f::hs)
483                         end                         end
484                         (* the default case could ensure the inline *)                         (* the default case could ensure the inline *)
485                         else (m, hs)                         else (m, hs)
# Line 502  Line 487
487                  else (m, hs)                  else (m, hs)
488                | ceta (_,(m,hs)) = (m, hs)                | ceta (_,(m,hs)) = (m, hs)
489
490              (* add droparg wrapper if useful *)              (* drop constant arguments if possible *)
491              fun dropargs (f as (fk,g,args,body):F.fundec,fs) =              fun dropcstargs (f as (fk,g,args,body):F.fundec,fs) =
492                    case fk
493                     of F.FK_FCT => f::fs (* we can't make inlinable fcts *)
494                      | F.FK_FUN{inline=true,...} => f::fs (* no use *)
495                      | fk =>
496                        let val cst =
497                                ListPair.map
498                                    (fn (NONE,_) => false
499                                      | (SOME(F.VAR lv),(v,_)) =>
500                                        ((lookup m lv;
501                                          if used v andalso used lv then
502                                              (C.use NONE lv; true)
503                                          else false)
504                                             handle M.IntmapF => false)
505                                      | _ => true)
506                                    (C.actuals g, args)
507                        (* if all args are used, there's nothing we can do *)
508                        in if List.all not cst then f::fs else
509                            let fun newarg lv =
510                                    let val nlv = cplv lv in C.new NONE nlv; nlv end
511                                fun filter xs = OU.filter(cst, xs)
512                                (* construct the new arg list *)
513                                val nargs = ListPair.map
514                                                (fn ((a,t),true) => (newarg a,t)
515                                                  | ((a,t),false) => (a,t))
516                                                (args, cst)
517                                (* construct the new body *)
518                                val nbody =
519                                    F.LET(map #1 (filter args),
520                                          F.RET(map valOf (filter (C.actuals g))),
521                                          body)
522                            in (fk,g,nargs,nbody)::fs
523                            end
524                        end
525
526                (* add droparg wrapper to drop dead arguments *)
527                fun dropdeadargs (f as (fk,g,args,body):F.fundec,fs) =
528                  case fk                  case fk
529                   of F.FK_FCT => f::fs (* we can't make inlinable fcts *)                   of F.FK_FCT => f::fs (* we can't make inlinable fcts *)
530                    | F.FK_FUN{inline=true,...} => f::fs (* no use *)                    | F.FK_FUN{inline=true,...} => f::fs (* no use *)
531                    | fk as F.FK_FUN{isrec,...} =>                    | fk as F.FK_FUN{isrec,...} =>
532                      let val used = map (fn (v,t) => (C.usenb v > 0)) args                      let val used = map (used o #1) args
533                      (* if all args are used, there's nothing we can do *)                      (* if all args are used, there's nothing we can do *)
534                      in if List.all OU.id used then f::fs else                      in if List.all OU.id used then f::fs else
535                          let fun filter xs = OU.filter(used, xs)                          let fun filter xs = OU.filter(used, xs)
536                                val args' = filter args
537                              val ng = cplv g                              val ng = cplv g
val _ = (C.new true ng; C.use true ng; C.extcounts g)
538                              val nargs = map (fn (v,t) => (cplv v, t)) args                              val nargs = map (fn (v,t) => (cplv v, t)) args
539                              val _ = app (fn (v,t) =>                              val nargs' = map #1 (filter nargs)
540                                           (C.new false v; C.use false v))                              val appargs = (map F.VAR nargs')
541                                          nargs
542                              val appargs = (map (F.VAR o #1) nargs)                              val _ = C.new (SOME(map #1 args')) ng
543                                val _ = C.use (SOME appargs) ng
544                                val _ = app ((C.new NONE) o #1) nargs
545                                val _ = app (C.use NONE) nargs'
546
547                              val (nfk,nfk') = OU.fk_wrap(fk, isrec)                              val (nfk,nfk') = OU.fk_wrap(fk, isrec)
548                              val nf = (nfk, g, nargs,                              val nf = (nfk, g, nargs,
549                                        F.APP(F.VAR ng, filter appargs))                                        F.APP(F.VAR ng, appargs))
550                              val nf' = (nfk', ng, filter args, body)                              val nf' = (nfk', ng, args', body)
551                          in nf'::nf::fs                          in nf'::nf::fs
552                          end                          end
553                      end                      end
554
555              (* junk unused funs *)              (* add wrappers to drop unused arguments *)
556              val fs = List.filter (used o #2) fs              val fs = foldl dropcstargs [] fs
557
558              (* add wrappers to drop unused arguments *)              (* add wrappers to drop unused arguments *)
559              val fs = foldl dropargs [] fs              val fs = foldl dropdeadargs [] fs
560
561              (* register the new bindings (uncontracted for now) *)              (* register the new bindings (uncontracted for now) *)
562              val nm = foldl (fn (fdec as (fk,f,args,body),m) =>              val nm = foldl (fn (fdec as (fk,f,args,body),m) =>
# Line 573  Line 598
598          end          end
599
600        | F.TFN ((f,args,body),le) =>        | F.TFN ((f,args,body),le) =>
if used f then
601              let val nbody = cexp (DI.next d, DI.next od) ifs m body              let val nbody = cexp (DI.next d, DI.next od) ifs m body
602                  val nm = addbind(m, f, TFun(f, nbody, args, od))                  val nm = addbind(m, f, TFun(f, nbody, args, od))
603                  val nle = loop nm le                  val nle = loop nm le
604              in              in
605                  if used f then F.TFN((f, args, nbody), nle) else nle                  if used f then F.TFN((f, args, nbody), nle) else nle
606              end              end
else loop m le
607
608        | F.TAPP(f,tycs) => F.TAPP((substval f) handle x => raise x, tycs)        | F.TAPP(f,tycs) => F.TAPP((substval f) handle x => raise x, tycs)
609
# Line 614  Line 637
637               end               end
638
639             | Con (lvc,v,dc1,tycs1) =>             | Con (lvc,v,dc1,tycs1) =>
640               let fun killle le = (#1 (C.unuselexp (undertake m))) le               let fun killle le = ((#1 (C.unuselexp (undertake m))) le) handle x => raise x
641                   fun kill lv le =                   fun kill lv le =
642                       (#1 (C.unuselexp (undertake (addbind(m,lv,Var(lv,NONE)))))) le                       ((#1 (C.unuselexp (undertake (addbind(m,lv,Var(lv,NONE)))))) le) handle x => raise x
643                   fun killarm (F.DATAcon(_,_,lv),le) = kill lv le                   fun killarm (F.DATAcon(_,_,lv),le) = kill lv le
644                     | killarm _ = buglexp("bad arm in switch(con)", le)                     | killarm _ = buglexp("bad arm in switch(con)", le)
645
# Line 634  Line 657
657               end               end
658
659             | Val v =>             | Val v =>
660               let fun kill le = (#1 (C.unuselexp (undertake m))) le               let fun kill le = ((#1 (C.unuselexp (undertake m))) le) handle x => raise x
661                   fun carm ((con,le)::tl) =                   fun carm ((con,le)::tl) =
662                       if eqConV(con, v) then                       if eqConV(con, v) then
663                            (map (kill o #2) tl; Option.map kill def; loop m le)                            (map (kill o #2) tl; Option.map kill def; loop m le)
# Line 646  Line 669
669               bugval("unexpected switch arg", sval2val sv))               bugval("unexpected switch arg", sval2val sv))
670
671        | F.CON (dc1,tycs1,v,lv,le) =>        | F.CON (dc1,tycs1,v,lv,le) =>
(* Here we should try to nullify CON(DECON x) => x *)
if used lv then
672              let val ndc = cdcon dc1              let val ndc = cdcon dc1
673                  fun ccon sv =                  fun ccon sv =
674                      let val nv = sval2val sv                      let val nv = sval2val sv
# Line 664  Line 685
685                     else ccon sv                     else ccon sv
686                   | sv => ccon sv                   | sv => ccon sv
687              end              end
else loop m le
688
689        | F.RECORD (rk,vs,lv,le) =>        | F.RECORD (rk,vs,lv,le) =>
(* Here I could try to see if I'm reconstructing a preexisting record.
* The `lty option' of Var is there just for that purpose *)
if used lv then
690              (* g: check whether the record already exists *)              (* g: check whether the record already exists *)
691              let fun g (n,Select(_,v1,i)::ss) =              let fun g (n,Select(_,v1,i)::ss) =
692                      if n = i then                      if n = i then
# Line 704  Line 721
721                     in if used lv then F.RECORD(rk, nvs, lv, nle) else nle                     in if used lv then F.RECORD(rk, nvs, lv, nle) else nle
722                     end                     end
723              end              end
else loop m le
724
725        | F.SELECT (v,i,lv,le) =>        | F.SELECT (v,i,lv,le) =>
726          if used lv then          (case ((val2sval m v) handle x => raise x)
case ((val2sval m v) handle x => raise x)
727               of Record (lvr,vs) =>               of Record (lvr,vs) =>
728                  let val sv = (val2sval m (List.nth(vs, i))) handle x => raise x                  let val sv = (val2sval m (List.nth(vs, i))) handle x => raise x
729                  in loop (substitute(m, lv, sv, F.VAR lvr)) le                  in loop (substitute(m, lv, sv, F.VAR lvr)) le
# Line 718  Line 733
733                      val nm = addbind (m, lv, Select(lv, nv, i))                      val nm = addbind (m, lv, Select(lv, nv, i))
734                      val nle = loop nm le                      val nle = loop nm le
735                  in if used lv then F.SELECT(nv, i, lv, nle) else nle                  in if used lv then F.SELECT(nv, i, lv, nle) else nle
736                  end               end)
else loop m le
737
738        | F.RAISE (v,ltys) => F.RAISE((substval v) handle x => raise x, ltys)        | F.RAISE (v,ltys) => F.RAISE((substval v) handle x => raise x, ltys)
739
# Line 735  Line 749
749
750        | F.PRIMOP (po,vs,lv,le) =>        | F.PRIMOP (po,vs,lv,le) =>
751          let val impure = impurePO po          let val impure = impurePO po
752          in if impure orelse used lv then              val nvs = ((map substval vs) handle x => raise x)
let val nvs = ((map substval vs) handle x => raise x)
753                  val npo = cpo po                  val npo = cpo po
754                  val nm = addbind(m, lv, Var(lv,NONE))                  val nm = addbind(m, lv, Var(lv,NONE))
755                  val nle = loop nm le                  val nle = loop nm le
# Line 745  Line 758
758                  then F.PRIMOP(npo, nvs, lv, nle)                  then F.PRIMOP(npo, nvs, lv, nle)
759                  else nle                  else nle
760              end              end
else loop m le
end
761  end  end
762
763  fun contract (fdec as (_,f,_,_)) =  fun contract (fdec as (_,f,_,_)) =
764      (C.collect fdec;      ((*  C.collect fdec; *)
765       case cexp (DI.top,DI.top) S.empty M.empty (F.FIX([fdec], F.RET[F.VAR f]))       case cexp (DI.top,DI.top) S.empty M.empty (F.FIX([fdec], F.RET[F.VAR f]))
766        of F.FIX([fdec], F.RET[F.VAR f]) => fdec        of F.FIX([fdec], F.RET[F.VAR f]) => fdec
767         | fdec => bug "invalid return fundec")         | fdec => bug "invalid return fundec")

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

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