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  
ViewVC logotype

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

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

revision 185, Tue Nov 10 21:01:05 1998 UTC revision 186, Wed Nov 11 05:24:43 1998 UTC
# Line 225  Line 225 
225    
226      val loop = cexp cfg ifs      val loop = cexp cfg ifs
227    
228      fun used lv = C.usenb lv > 0      fun used lv = (C.usenb(C.get lv) > 0)
229                          handle x =>
230                          (say("while in FContract.used "^(C.LVarString lv)^"\n");
231                           raise x)
232    
233      fun impurePO po = true              (* if a PrimOP is pure or not *)      fun impurePO po = true              (* if a PrimOP is pure or not *)
234    
# Line 250  Line 253 
253            | Val v => v            | Val v => v
254    
255      fun val2sval m (F.VAR ov) =      fun val2sval m (F.VAR ov) =
256          ((lookup m ov) handle x => (PP.printSval(F.VAR ov); raise x))          ((lookup m ov) handle x => ((*  PP.printSval(F.VAR ov); *) raise x))
257        | val2sval m v = Val v        | val2sval m v = Val v
258    
259      fun bugsv (msg,sv) = bugval(msg, sval2val sv)      fun bugsv (msg,sv) = bugval(msg, sval2val sv)
# Line 262  Line 265 
265           of F.VAR lv => lv           of F.VAR lv => lv
266            | v => bugval ("unexpected val", v)            | v => bugval ("unexpected val", v)
267    
268      fun unuseval f (F.VAR lv) = ((C.unuse f false lv) handle x => raise x)      fun unuseval f (F.VAR lv) = ignore((C.unuse f false lv) handle x => raise x)
269        | unuseval f _ = ()        | unuseval f _ = ()
270    
271      (* called when a variable becomes dead.      (* called when a variable becomes dead.
# Line 270  Line 273 
273      fun undertake m lv =      fun undertake m lv =
274          let val undertake = undertake m          let val undertake = undertake m
275          in case lookup m lv          in case lookup m lv
276              of Var {1=nlv,...}   => ASSERT(nlv = lv, "nlv = lv")              of Var {1=nlv,...}   => ()
277               | Val v             => ()               | Val v             => ()
278               | Fun (lv,le,args,_,_) =>               | Fun (lv,le,args,_,_) =>
279                 (#2 (C.unuselexp undertake)) (lv, map #1 args, le)                 (#2 (C.unuselexp undertake)) (lv, map #1 args, le)
# Line 281  Line 284 
284               | Decon _ => ()               | Decon _ => ()
285          end          end
286                  handle M.IntmapF =>                  handle M.IntmapF =>
287                  (say "\nUnable to undertake "; PP.printSval(F.VAR lv))                  (say("Unable to undertake "^(C.LVarString lv)^"\n"))
288                       | x =>                       | x =>
289                         (say "\nwhile undertaking "; PP.printSval(F.VAR lv); raise x)                         (say("while undertaking "^(C.LVarString lv)^"\n"); raise x)
290    
291      fun addbind (m,lv,sv) = M.add(m, lv, sv)      fun addbind (m,lv,sv) = M.add(m, lv, sv)
292    
# Line 292  Line 295 
295          (case sval2val sv of F.VAR lv2 => C.transfer(lv1,lv2) | v2 => ();          (case sval2val sv of F.VAR lv2 => C.transfer(lv1,lv2) | v2 => ();
296           unuseval (undertake m) v;           unuseval (undertake m) v;
297           addbind(m, lv1, sv)) handle x =>           addbind(m, lv1, sv)) handle x =>
298               (say ("\nwhile substituting "^               (say ("while substituting "^
299                     (C.LVarString lv1)^                     (C.LVarString lv1)^
300                     " -> ");                     " -> ");
301                PP.printSval (sval2val sv);                PP.printSval (sval2val sv);
# Line 325  Line 328 
328           of Fun(g,body,args,{inline,...},od) =>           of Fun(g,body,args,{inline,...},od) =>
329              (ASSERT(used g, "used "^(C.LVarString g));              (ASSERT(used g, "used "^(C.LVarString g));
330               if d <> od then (NONE, ifs)               if d <> od then (NONE, ifs)
331               else if C.usenb g = 1 andalso not(S.member ifs g) then               else if ((C.usenb(C.get g))handle x => raise x) = 1 andalso not(S.member ifs g) then
332    
333                   (* simple inlining:  we should copy the body and then                   (* simple inlining:  we should copy the body and then
334                    * kill the function, but instead we just move the body                    * kill the function, but instead we just move the body
# Line 396  Line 399 
399                       | known (F.RET[_]) = true                       | known (F.RET[_]) = true
400                       | known _ = false                       | known _ = false
401                     fun cassoc (lv,v,body,wrap) =                     fun cassoc (lv,v,body,wrap) =
402                         if lv = v andalso C.usenb lv = 1 andalso                         if lv = v andalso ((C.usenb(C.get lv)) handle x=> raise x) = 1 andalso
403                             known le1 andalso known le2 then                             known le1 andalso known le2 then
404                             (* here I should also check that le1 != le2 *)                             (* here I should also check that le1 != le2 *)
405                             let val nle1 = F.LET([lv], le1, body)                             let val nle1 = F.LET([lv], le1, body)
# Line 443  Line 446 
446                           * changed (read: bigger), so we have to reset the                           * changed (read: bigger), so we have to reset the
447                           * `inline' bit *)                           * `inline' bit *)
448                          val nfk = {isrec=isrec, cconv=cconv,                          val nfk = {isrec=isrec, cconv=cconv,
449                                     known=known orelse not(C.escaping f),                                     known=known orelse not(C.escaping(C.get f))handle x => raise x,
450                                     inline=if !inlineWitness                                     inline=if !inlineWitness
451                                            then F.IH_SAFE                                            then F.IH_SAFE
452                                            else (inline before                                            else (inline before
# Line 461  Line 464 
464                  else cfun(m, fs, acc)                  else cfun(m, fs, acc)
465    
466              (* check for eta redex *)              (* check for eta redex *)
467              fun ceta ((fk,f,args,F.APP(g,vs)):F.fundec,(m,hs)) =              fun ceta (fdec as (fk,f,args,F.APP(g,vs)):F.fundec,(m,fs,hs)) =
468                  if vs = (map (F.VAR o #1) args) andalso                  if vs = (map (F.VAR o #1) args) andalso
469                      (* don't forget to check that g is not one of the args                      (* don't forget to check that g is not one of the args
470                       * and not f itself either *)                       * and not f itself either *)
# Line 475  Line 478 
478                       * escaping one.  It's dangerous for optimisations based                       * escaping one.  It's dangerous for optimisations based
479                       * on known functions (elimination of dead args, f.ex)                       * on known functions (elimination of dead args, f.ex)
480                       * and could generate cases where call>use in collect *)                       * and could generate cases where call>use in collect *)
481                      in if not (C.escaping f andalso not (C.escaping g))                      in if not (((C.escaping(C.get f))handle x => raise x) andalso not (C.escaping(C.get g))handle x => raise x)
482                         then let                         then let
483                             (* if an earlier function h has been eta-reduced                             (* if an earlier function h has been eta-reduced
484                              * to f, we have to be careful to update its                              * to f, we have to be careful to update its
# Line 490  Line 493 
493                              * unuse in substitute assumes the val is escaping *)                              * unuse in substitute assumes the val is escaping *)
494                             C.transfer(f, g);                             C.transfer(f, g);
495                             C.unuse (undertake m) true g;                             C.unuse (undertake m) true g;
496                             (addbind(m, f, svg), f::hs)                             (addbind(m, f, svg), fs, f::hs)
497                         end                         end
498                         (* the default case could ensure the inline *)                         (* the default case could ensure the inline *)
499                         else (m, hs)                         else (m, fdec::fs, hs)
500                      end                      end
501                  else (m, hs)                  else (m, fdec::fs, hs)
502                | ceta (_,(m,hs)) = (m, hs)                | ceta (fdec,(m,fs,hs)) = (m,fdec::fs,hs)
503    
504              (* drop constant arguments if possible *)              (* drop constant arguments if possible *)
505              fun cstargs (f as ({inline=F.IH_ALWAYS,...},_,_,_):F.fundec) = f              fun cstargs (f as ({inline=F.IH_ALWAYS,...},_,_,_):F.fundec) = f
506                | cstargs (f as (fk,g,args,body):F.fundec) =                | cstargs (f as (fk,g,args,body):F.fundec) =
507                  let val cst =                  let val actuals = (C.actuals (C.get g)) handle x => raise x
508                        val cst =
509                          ListPair.map                          ListPair.map
510                              (fn (NONE,_) => false                              (fn (NONE,_) => false
511                                | (SOME(F.VAR lv),(v,_)) =>                                | (SOME v,(a,_)) =>
512                                  ((lookup m lv;                                  ((case substval v
513                                    if used v andalso used lv then                                    of F.VAR lv =>
514                                        (C.use NONE lv; true)                                       if used a andalso used lv then
515                                    else false)                                           (C.use NONE (C.get lv); true)
516                                       handle M.IntmapF => false)                                       else false
517                                | _ => true)                                     | _ => false)
518                              (C.actuals g, args)                                      handle M.IntmapF => false))
519                                (actuals, args)
520                  (* if all args are used, there's nothing we can do *)                  (* if all args are used, there's nothing we can do *)
521                  in if List.all not cst then f else                  in if List.all not cst then f else
522                      let fun newarg lv =                      let fun newarg lv =
# Line 525  Line 530 
530                          (* construct the new body *)                          (* construct the new body *)
531                          val nbody =                          val nbody =
532                              F.LET(map #1 (filter args),                              F.LET(map #1 (filter args),
533                                    F.RET(map O.valOf (filter (C.actuals g))),                                    F.RET(map O.valOf (filter actuals)),
534                                    body)                                    body)
535                      in (fk, g, nargs, nbody)                      in (fk, g, nargs, nbody)
536                      end                      end
# Line 543  Line 548 
548                              val appargs = (map F.VAR nargs')                              val appargs = (map F.VAR nargs')
549                              val nf = (nfk, g, nargs, F.APP(F.VAR ng, appargs))                              val nf = (nfk, g, nargs, F.APP(F.VAR ng, appargs))
550                              val nf' = (nfk', ng, args', body)                              val nf' = (nfk', ng, args', body)
551    
552                                val ngi = C.new (SOME(map #1 args')) ng
553                                val nargsi = map ((C.new NONE) o #1) nargs
554                          in                          in
555                              C.new (SOME(map #1 args')) ng;                              C.use (SOME appargs) ngi;
556                              C.use (SOME appargs) ng;                              app (C.use NONE) nargsi;
                             app ((C.new NONE) o #1) nargs;  
                             app (C.use NONE) nargs';  
557                              nf'::nf::fs                              nf'::nf::fs
558                          end                          end
559                      val used = map (used o #1) args                      val used = map (used o #1) args
# Line 557  Line 563 
563                          dropargs (fn xs => OU.filter(used, xs))                          dropargs (fn xs => OU.filter(used, xs))
564    
565                      (* eta-split: add a wrapper for escaping uses *)                      (* eta-split: add a wrapper for escaping uses *)
566                      else if C.escaping g andalso C.called g then                      else
567                            let val gi = C.get g
568                            in if ((C.escaping gi)handle x => raise x) andalso ((C.called gi)handle x => raise x) then
569                          (* like dropargs but keeping all args *)                          (* like dropargs but keeping all args *)
570                          dropargs OU.id                          dropargs OU.id
571    
572                      else f::fs                      else f::fs
573                  end                  end
574                    end
575    
576                (* junk unused funs *)
577                val fs = List.filter (used o #2) fs
578    
579              (* redirect cst args to their source value *)              (* redirect cst args to their source value *)
580              val fs = map cstargs fs              val fs = map cstargs fs
# Line 575  Line 587 
587                              addbind(m, f, Fun(f, body, args, fk, od)))                              addbind(m, f, Fun(f, body, args, fk, od)))
588                             m fs                             m fs
589              (* check for eta redexes *)              (* check for eta redexes *)
590              val (nm,_) = foldl ceta (nm,[]) fs              val (nm,fs,_) = foldl ceta (nm,[],[]) fs
591    
592              (* move the inlinable functions to the end of the list *)              (* move the inlinable functions to the end of the list *)
593              val (f1s,f2s) =              val (f1s,f2s) =
# Line 593  Line 605 
605              case fs              case fs
606               of [] => nle               of [] => nle
607                | [f1 as ({isrec=NONE,...},_,_,_),f2] =>                | [f1 as ({isrec=NONE,...},_,_,_),f2] =>
608                  (* gross hack: dropargs might have added a second                  (* gross hack: `wrap' might have added a second
609                   * non-recursive function.  we need to split them into                   * non-recursive function.  we need to split them into
610                   * 2 FIXes.  This is _very_ ad-hoc *)                   * 2 FIXes.  This is _very_ ad-hoc *)
611                  F.FIX([f2], F.FIX([f1], nle))                  F.FIX([f2], F.FIX([f1], nle))
# Line 608  Line 620 
620          end          end
621    
622        | F.TFN ((f,args,body),le) =>        | F.TFN ((f,args,body),le) =>
623            if used f then
624          let val nbody = cexp (DI.next d, DI.next od) ifs m body #2          let val nbody = cexp (DI.next d, DI.next od) ifs m body #2
625              val nm = addbind(m, f, TFun(f, nbody, args, od))              val nm = addbind(m, f, TFun(f, nbody, args, od))
626              val nle = loop nm le cont              val nle = loop nm le cont
627          in          in
628              if used f then F.TFN((f, args, nbody), nle) else nle              if used f then F.TFN((f, args, nbody), nle) else nle
629          end          end
630            else loop m le cont
631    
632        | F.TAPP(f,tycs) =>        | F.TAPP(f,tycs) =>
633          cont(m, F.TAPP((substval f) handle x => raise x, tycs))          cont(m, F.TAPP((substval f) handle x => raise x, tycs))
# Line 707  Line 721 
721               bugval("unexpected switch arg", sval2val sv))               bugval("unexpected switch arg", sval2val sv))
722    
723        | F.CON (dc1,tycs1,v,lv,le) =>        | F.CON (dc1,tycs1,v,lv,le) =>
724            if used lv then
725          let val ndc = cdcon dc1          let val ndc = cdcon dc1
726              fun ccon sv =              fun ccon sv =
727                  let val nv = sval2val sv                  let val nv = sval2val sv
# Line 723  Line 738 
738                 else ccon sv                 else ccon sv
739               | sv => ccon sv               | sv => ccon sv
740          end          end
741            else loop m le cont
742    
743        | F.RECORD (rk,vs,lv,le) =>        | F.RECORD (rk,vs,lv,le) =>
744          (* g: check whether the record already exists *)          (* g: check whether the record already exists *)
745            if used lv then
746          let fun g (n,Select(_,v1,i)::ss) =          let fun g (n,Select(_,v1,i)::ss) =
747                  if n = i then                  if n = i then
748                      (case ss                      (case ss
# Line 759  Line 776 
776                 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
777                 end                 end
778          end          end
779            else loop m le cont
780    
781        | F.SELECT (v,i,lv,le) =>        | F.SELECT (v,i,lv,le) =>
782            if used lv then
783          (case ((val2sval m v) handle x => raise x)          (case ((val2sval m v) handle x => raise x)
784            of Record (lvr,vs) =>            of Record (lvr,vs) =>
785               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
# Line 772  Line 791 
791                   val nle = loop nm le cont                   val nle = loop nm le cont
792               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
793               end)               end)
794            else loop m le cont
795    
796        | F.RAISE (v,ltys) =>        | F.RAISE (v,ltys) =>
797          cont(m, F.RAISE((substval v) handle x => raise x, ltys))          cont(m, F.RAISE((substval v) handle x => raise x, ltys))
# Line 789  Line 809 
809    
810        | F.PRIMOP (po,vs,lv,le) =>        | F.PRIMOP (po,vs,lv,le) =>
811          let val impure = impurePO po          let val impure = impurePO po
812              val nvs = ((map substval vs) handle x => raise x)          in if impure orelse used lv then
813                let val nvs = ((map substval vs) handle x => raise x)
814              val npo = cpo po              val npo = cpo po
815              val nm = addbind(m, lv, Var(lv,NONE))              val nm = addbind(m, lv, Var(lv,NONE))
816              val nle = loop nm le cont              val nle = loop nm le cont
# Line 798  Line 819 
819              then F.PRIMOP(npo, nvs, lv, nle)              then F.PRIMOP(npo, nvs, lv, nle)
820              else nle              else nle
821          end          end
822               else loop m le cont
823            end
824  end  end
825    
826  in  in
Legend:
Removed from v.185  
changed lines
  Added in v.186
root@smlnj-gforge.cs.uchicago.edu
 ViewVC Help
Powered by ViewVC 1.0.0  
Powered By FusionForge