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 183, Sun Nov 8 16:58:19 1998 UTC revision 184, Sun Nov 8 21:18:20 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   * - dropping of dead arguments
26     * - elimination of constant arguments
27   *)   *)
28    
29  (* things that lcontract.sml does that fcontract doesn't do (yet):  (* things that lcontract.sml does that fcontract doesn't do (yet):
# Line 43  Line 44 
44   *)   *)
45    
46  (* things that could also be added:  (* things that could also be added:
47   * - elimination of dead vars in let (subsumes what lcontract does)   * - elimination of dead vars in let
48   *)   *)
49    
50  (* things that would require some type info:  (* things that would require some type info:
# Line 109  Line 110 
110   *   once.  In the future, maybe.   *   once.  In the future, maybe.
111   *)   *)
112    
113    (* Dropping useless arguments.
114     * Arguments whose value is constant (i.e. the function is known and each
115     * call site provides the same value for that argument (or the argument
116     * itself in the case of recursive calls) can be safely removed and replaced
117     * inside the body by a simple let binding.  The only problem is that the
118     * constant argument might be out of scope at the function definition site.
119     * It is obviously always possible to move the function to bring the argument
120     * in scope, but since we don't do any code motion here, we're stuck.
121     * If it wasn't for this little problem, we could do the cst-arg removal in
122     * collect (we don't gain anything from doing it here).
123     * The removal of dead arguments (args not used in the body) on the other
124     * hand can quite well be done in collect, the only problem being that it
125     * is convenient to do it after the cst-arg removal so that we can rely
126     * on deadarg to do the actual removal of the cst-arg.
127     *)
128    
129  (* Simple inlining (inlining called-once functions, which doesn't require  (* Simple inlining (inlining called-once functions, which doesn't require
130   * alpha-renaming) seems inoffensive enough but is not always desirable.   * alpha-renaming) seems inoffensive enough but is not always desirable.
131   * The typical example is wrapper functions introduced by eta-expand: they   * The typical example is wrapper functions introduced by eta-expand: they
# Line 155  Line 172 
172      structure M  = IntmapF      structure M  = IntmapF
173      structure S  = IntSetF      structure S  = IntSetF
174      structure C  = Collect      structure C  = Collect
175        structure O  = Option
176      structure DI = DebIndex      structure DI = DebIndex
177      structure PP = PPFlint      structure PP = PPFlint
178      structure FU = FlintUtil      structure FU = FlintUtil
# Line 199  Line 217 
217   * ifs (inlined functions): records which functions we're currently inlining   * ifs (inlined functions): records which functions we're currently inlining
218   *     in order to detect loops   *     in order to detect loops
219   * m: is a map lvars to their defining expressions (svals) *)   * m: is a map lvars to their defining expressions (svals) *)
220  fun cexp (cfg as (d,od)) ifs m le = let  fun cexp (cfg as (d,od)) ifs m le cont = let
221    
222      val loop = cexp cfg ifs      val loop = cexp cfg ifs
223    
# Line 287  Line 305 
305          (s, Access.EXN(Access.LVAR(substvar lv)), lty)          (s, Access.EXN(Access.LVAR(substvar lv)), lty)
306        | cdcon dc = dc        | cdcon dc = dc
307    
308      fun isrec (F.FK_FCT | F.FK_FUN{isrec=NONE,...}) = false      fun zip ([],[]) = []
309        | isrec _ = true        | zip (x::xs,y::ys) = (x,y)::(zip(xs,ys))
310          | zip _ = bug "bad zip"
     fun inlinable F.FK_FCT = false  
       | inlinable (F.FK_FUN{inline,...}) = inline  
311    
312      (* F.APP inlining (if any)      (* F.APP inlining (if any)
313       * `ifs' is the set of function we are currently inlining       * `ifs' is the set of function we are currently inlining
# Line 302  Line 318 
318       *)       *)
319      fun inline ifs (f,vs) =      fun inline ifs (f,vs) =
320          case ((val2sval m f) handle x => raise x)          case ((val2sval m f) handle x => raise x)
321           of Fun(g,body,args,fk,od) =>           of Fun(g,body,args,{inline,...},od) =>
322              (ASSERT(used g, "used "^(C.LVarString g));              (ASSERT(used g, "used "^(C.LVarString g));
323               if C.usenb g = 1 andalso od = d andalso not(S.member ifs g)               if d <> od then (NONE, ifs)
324                 else if C.usenb g = 1 andalso not(S.member ifs g) then
325    
326               (* simple inlining:  we should copy the body and then               (* simple inlining:  we should copy the body and then
327                * kill the function, but instead we just move the body                * kill the function, but instead we just move the body
328                * and kill only the function name.  This inlining strategy                * and kill only the function name.  This inlining strategy
329                * looks inoffensive enough, but still requires some care:                * looks inoffensive enough, but still requires some care:
330                * see comments at the begining of this file and in cfun *)                * see comments at the begining of this file and in cfun *)
331               then ((C.unuse (fn _ => ()) true g) handle x => raise x; ASSERT(not (used g), "killed");                   (C.unuse (fn _ => ()) true g;
332                      ASSERT(not (used g), "killed");
333                     (SOME(F.LET(map #1 args, F.RET vs, body), od), ifs))                     (SOME(F.LET(map #1 args, F.RET vs, body), od), ifs))
334    
335               (* aggressive inlining (but hopefully safe).  We allow               (* aggressive inlining (but hopefully safe).  We allow
# Line 320  Line 338 
338                * happen that a wrapper (that should be inlined) has to be made                * happen that a wrapper (that should be inlined) has to be made
339                * mutually recursive with its main function.  On another hand,                * mutually recursive with its main function.  On another hand,
340                * self recursion (C.recursive) is too dangerous to be inlined                * self recursion (C.recursive) is too dangerous to be inlined
341                * except for loop unrolling which we don't support yet *)                * except for loop unrolling *)
342               else if inlinable fk andalso od = d andalso not(S.member ifs g) then               else if (inline = F.IH_ALWAYS andalso not(S.member ifs g)) orelse
343                     (inline = F.IH_UNROLL andalso (S.member ifs g)) then
344                   let val nle =                   let val nle =
345                           C.copylexp M.empty (F.LET(map #1 args, F.RET vs, body))                           C.copylexp M.empty (F.LET(map #1 args, F.RET vs, body))
346                   in                   in
347                         (*  say ("\nInlining "^(C.LVarString g)); *)
348                       (app (unuseval (undertake m)) vs) handle x => raise x;                       (app (unuseval (undertake m)) vs) handle x => raise x;
349                       (C.unuse (undertake m) true g) handle x => raise x;                       (C.unuse (undertake m) true g) handle x => raise x;
350                       (SOME(nle, od), S.add(g, ifs))                       (SOME(nle, od),
351                          (* gross hack: to prevent further unrolling,
352                           * I pretend that the rest is not inside the body *)
353                          if inline = F.IH_UNROLL then S.rmv(g, ifs) else S.add(g, ifs))
354                   end                   end
355               else (NONE, ifs))               else (NONE, ifs))
356            | sv => (NONE, ifs)            | sv => (NONE, ifs)
357  in  in
358      case le      case le
359       of F.RET vs => F.RET((map substval vs) handle x => raise x)       of F.RET vs => cont(m, F.RET(map substval vs) handle x => raise x)
360    
361        | F.LET (lvs,le,body) =>        | F.LET (lvs,le,body) =>
362          let fun cassoc le = F.LET(lvs, le, body)          let fun clet () =
363              (* default behavior *)                  loop m le
364              fun clet () =                       (fn (m,F.RET vs) =>
365                  let val nle = loop m le                        let fun simplesubst ((lv,v),m) =
366                      val nm = foldl (fn (lv,m) => addbind(m, lv, Var(lv, NONE)))                                let val sv = (val2sval m v) handle x => raise x
367                                     m lvs                                in substitute(m, lv, sv, sval2val sv)
368                  in case loop nm body                                end
369                              val nm = (foldl simplesubst m (zip(lvs, vs)))
370                          in loop nm body cont
371                          end
372                           | (m,nle) =>
373                             let val nm = (foldl (fn (lv,m) =>
374                                                  addbind(m, lv, Var(lv, NONE)))
375                                                 m lvs)
376                             in case loop nm body cont
377                      of F.RET vs => if vs = (map F.VAR lvs) then nle                      of F.RET vs => if vs = (map F.VAR lvs) then nle
378                                     else F.LET(lvs, nle, F.RET vs)                                     else F.LET(lvs, nle, F.RET vs)
379                       | nbody => F.LET(lvs, nle, nbody)                       | nbody => F.LET(lvs, nle, nbody)
380                  end                           end)
             val lopm = loop m  
381          in case le          in case le
382              (* apply let associativity  *)              of F.BRANCH (po,vs,le1,le2) =>
             of F.LET(lvs1,le',le) => lopm(F.LET(lvs1, le', cassoc le))  
              | F.FIX(fdecs,le) => lopm(F.FIX(fdecs, cassoc le))  
              | F.TFN(tfdec,le) => lopm(F.TFN(tfdec, cassoc le))  
              | F.CON(dc,tycs,v,lv,le) => lopm(F.CON(dc, tycs, v, lv, cassoc le))  
              | F.RECORD(rk,vs,lv,le) => lopm(F.RECORD(rk, vs, lv, cassoc le))  
              | F.SELECT(v,i,lv,le) => lopm(F.SELECT(v, i, lv, cassoc le))  
              | F.PRIMOP(po,vs,lv,le) => lopm(F.PRIMOP(po, vs, lv, cassoc le))  
383               (* this is a hack originally meant to cleanup the BRANCH mess               (* this is a hack originally meant to cleanup the BRANCH mess
384                * introduced in flintnm (where each branch returns just true or                * introduced in flintnm (where each branch returns just true or
385                * false which is generally only used as input to a SWITCH).                * false which is generally only used as input to a SWITCH).
386                * The present code does slightly more than clean up this case *)                * The present code does slightly more than clean up this case *)
              | F.BRANCH (po,vs,le1,le2) =>  
387                 let fun known (F.RECORD(_,_,_,le)) = known le                 let fun known (F.RECORD(_,_,_,le)) = known le
388                       | known (F.CON(_,_,_,v,F.RET[F.VAR v'])) = (v = v')                       | known (F.CON(_,_,_,v,F.RET[F.VAR v'])) = (v = v')
389                       | known (F.RET[F.VAR v]) = false                       | known (F.RET[F.VAR v]) = false
390                       | known (F.RET[_]) = true                       | known (F.RET[_]) = true
391                       | known _ = false                       | known _ = false
392                     fun cassoc (lv,v,body) wrap =                     fun cassoc (lv,v,body,wrap) =
393                         if lv = v andalso C.usenb lv = 1 andalso                         if lv = v andalso C.usenb lv = 1 andalso
394                             known le1 andalso known le2 then                             known le1 andalso known le2 then
395                             (* here I should also check that le1 != le2 *)                             (* here I should also check that le1 != le2 *)
# Line 378  Line 400 
400                                                        body                                                        body
401                                 val nle2 = F.LET([nlv], le2, body2)                                 val nle2 = F.LET([nlv], le2, body2)
402                             in                             in
403                                 lopm(wrap(F.BRANCH(po, vs, nle1, nle2)))                                 loop m (wrap(F.BRANCH(po, vs, nle1, nle2))) cont
404                             end                             end
405                         else                         else
406                             clet()                             clet()
407                 in case (lvs,body)                 in case (lvs,body)
408                     of ([lv],le as F.SWITCH(F.VAR v,_,_,NONE)) =>                     of ([lv],le as F.SWITCH(F.VAR v,_,_,NONE)) =>
409                        cassoc(lv, v, le) (fn x => x)                        cassoc(lv, v, le, OU.id)
410                      | ([lv],F.LET(lvs,le as F.SWITCH(F.VAR v,_,_,NONE),rest)) =>                      | ([lv],F.LET(lvs,le as F.SWITCH(F.VAR v,_,_,NONE),rest)) =>
411                        cassoc(lv, v, le) (fn le => F.LET(lvs,le,rest))                        cassoc(lv, v, le, fn le => F.LET(lvs,le,rest))
412                      | _ => clet()                      | _ => clet()
413                 end                 end
414               | F.RET vs =>               | _ => clet()
                let fun simplesubst ((lv,v),m) =  
                         let val sv = (val2sval m v) handle x => raise x  
                         in substitute(m, lv, sv, sval2val sv)  
                         end  
                in loop (foldl simplesubst m (ListPair.zip(lvs, vs))) body  
                end  
              | F.APP(f,vs) => clet()  
              (* let-associativity can be annoying here.  I should really use  
               * continuation passing style instead.  
               * (case inline ifs (f, vs)  
               * of (SOME(le,od),ifs) => cexp (d,od) ifs m (F.LET(lvs, le, body))  
               *  | (NONE,_) => clet()) *)  
              | (F.TAPP _ | F.SWITCH _ | F.RAISE _ | F.HANDLE _) =>  
                clet()  
415          end          end
416    
417        | F.FIX (fs,le) =>        | F.FIX (fs,le) =>
# Line 414  Line 422 
422    
423              (* The actual function contraction *)              (* The actual function contraction *)
424              fun cfun (m,[]:F.fundec list,acc) = acc              fun cfun (m,[]:F.fundec list,acc) = acc
425                | cfun (m,fdec as (fk,f,args,body)::fs,acc) =                | cfun (m,fdec as ({inline,cconv,known,isrec},f,args,body)::fs,acc) =
426                  if used f then                  if used f then
427                      let (*  val _ = say ("\nEntering "^(C.LVarString f)) *)                      let (*  val _ = say ("\nEntering "^(C.LVarString f)) *)
428                          (* make up the bindings for args inside the body *)                          (* make up the bindings for args inside the body *)
# Line 422  Line 430 
430                              addbind(m, lv, Var(lv, SOME lty))                              addbind(m, lv, Var(lv, SOME lty))
431                          val nm = foldl addnobind m args                          val nm = foldl addnobind m args
432                          (* contract the body and create the resulting fundec *)                          (* contract the body and create the resulting fundec *)
433                          val nbody = cexp cfg (S.add(f, ifs)) nm body                          val nbody = cexp cfg (S.add(f, ifs)) nm body #2
434                          (* The `inline' bit has to be turned off because                          (* The `inline' bit has to be turned off because
435                           * it applied to the function before contraction                           * it applied to the function before contraction
436                           * but might not apply to its new form (inlining might                           * but might not apply to its new form (inlining might
437                           * have increased its size substantially or made it                           * have increased its size substantially or made it
438                           * recursive in a different way which could make further                           * recursive in a different way which could make further
439                           * inlining even dangerous) *)                           * inlining even dangerous) *)
440                          val nfk =                          val nknown = known orelse not(C.escaping f)
441                              case fk of F.FK_FCT => fk                          val nfk = {isrec=isrec, cconv=cconv,
442                                | F.FK_FUN {isrec,fixed,known,inline} =>                                     inline=F.IH_SAFE, known=nknown}
                                 let val nknown = known orelse not(C.escaping f)  
                                 in F.FK_FUN{isrec=isrec, fixed=fixed,  
                                             inline=false, known=nknown}  
                                 end  
443                          (* update the binding in the map.  This step is not                          (* update the binding in the map.  This step is not
444                           * not just a mere optimization but is necessary                           * not just a mere optimization but is necessary
445                           * because if we don't do it and the function                           * because if we don't do it and the function
# Line 488  Line 492 
492                | ceta (_,(m,hs)) = (m, hs)                | ceta (_,(m,hs)) = (m, hs)
493    
494              (* drop constant arguments if possible *)              (* drop constant arguments if possible *)
495              fun dropcstargs (f as (fk,g,args,body):F.fundec,fs) =              fun cstargs (f as ({inline=F.IH_ALWAYS,...},_,_,_):F.fundec) = f
496                  case fk                | cstargs (f as (fk,g,args,body):F.fundec) =
                  of F.FK_FCT => f::fs (* we can't make inlinable fcts *)  
                   | F.FK_FUN{inline=true,...} => f::fs (* no use *)  
                   | fk =>  
497                      let val cst =                      let val cst =
498                              ListPair.map                              ListPair.map
499                                  (fn (NONE,_) => false                                  (fn (NONE,_) => false
# Line 505  Line 506 
506                                    | _ => true)                                    | _ => true)
507                                  (C.actuals g, args)                                  (C.actuals g, args)
508                      (* if all args are used, there's nothing we can do *)                      (* if all args are used, there's nothing we can do *)
509                      in if List.all not cst then f::fs else                  in if List.all not cst then f else
510                          let fun newarg lv =                          let fun newarg lv =
511                                  let val nlv = cplv lv in C.new NONE nlv; nlv end                                  let val nlv = cplv lv in C.new NONE nlv; nlv end
512                              fun filter xs = OU.filter(cst, xs)                              fun filter xs = OU.filter(cst, xs)
# Line 519  Line 520 
520                                  F.LET(map #1 (filter args),                                  F.LET(map #1 (filter args),
521                                        F.RET(map valOf (filter (C.actuals g))),                                        F.RET(map valOf (filter (C.actuals g))),
522                                        body)                                        body)
523                          in (fk,g,nargs,nbody)::fs                      in (fk, g, nargs, nbody)
524                          end                          end
525                      end                      end
526    
527              (* add droparg wrapper to drop dead arguments *)              (* add wrapper for various purposes *)
528              fun dropdeadargs (f as (fk,g,args,body):F.fundec,fs) =              fun wrap (f as ({inline=F.IH_ALWAYS,...},_,_,_):F.fundec,fs) = f::fs
529                  case fk                | wrap (f as (fk as {isrec,...},g,args,body):F.fundec,fs) =
530                   of F.FK_FCT => f::fs (* we can't make inlinable fcts *)                  let fun dropargs filter =
531                    | F.FK_FUN{inline=true,...} => f::fs (* no use *)                          let val (nfk,nfk') = OU.fk_wrap(fk, O.map #1 isrec)
                   | fk as F.FK_FUN{isrec,...} =>  
                     let val used = map (used o #1) args  
                     (* if all args are used, there's nothing we can do *)  
                     in if List.all OU.id used then f::fs else  
                         let fun filter xs = OU.filter(used, xs)  
532                              val args' = filter args                              val args' = filter args
533                              val ng = cplv g                              val ng = cplv g
534                              val nargs = map (fn (v,t) => (cplv v, t)) args                              val nargs = map (fn (v,t) => (cplv v, t)) args
535                              val nargs' = map #1 (filter nargs)                              val nargs' = map #1 (filter nargs)
536                              val appargs = (map F.VAR nargs')                              val appargs = (map F.VAR nargs')
537                                val nf = (nfk, g, nargs, F.APP(F.VAR ng, appargs))
                             val _ = C.new (SOME(map #1 args')) ng  
                             val _ = C.use (SOME appargs) ng  
                             val _ = app ((C.new NONE) o #1) nargs  
                             val _ = app (C.use NONE) nargs'  
   
                             val (nfk,nfk') = OU.fk_wrap(fk, isrec)  
                             val nf = (nfk, g, nargs,  
                                       F.APP(F.VAR ng, appargs))  
538                              val nf' = (nfk', ng, args', body)                              val nf' = (nfk', ng, args', body)
539                          in nf'::nf::fs                          in
540                                C.new (SOME(map #1 args')) ng;
541                                C.use (SOME appargs) ng;
542                                app ((C.new NONE) o #1) nargs;
543                                app (C.use NONE) nargs';
544                                nf'::nf::fs
545                          end                          end
546                        val used = map (used o #1) args
547                    in
548                        (* if some args are not used, let's drop them *)
549                        if not (List.all OU.id used) then
550                            dropargs (fn xs => OU.filter(used, xs))
551    
552                        (* eta-split: add a wrapper for escaping uses *)
553                        else if C.escaping g andalso C.called g then
554                            (* like dropargs but keeping all args *)
555                            dropargs OU.id
556    
557                        else f::fs
558                      end                      end
559    
560              (* add wrappers to drop unused arguments *)              (* redirect cst args to their source value *)
561              val fs = foldl dropcstargs [] fs              val fs = map cstargs fs
562    
563              (* add wrappers to drop unused arguments *)              (* add various wrappers *)
564              val fs = foldl dropdeadargs [] fs              val fs = foldl wrap [] fs
565    
566              (* register the new bindings (uncontracted for now) *)              (* register the new bindings (uncontracted for now) *)
567              val nm = foldl (fn (fdec as (fk,f,args,body),m) =>              val nm = foldl (fn (fdec as (fk,f,args,body),m) =>
# Line 567  Line 572 
572    
573              (* move the inlinable functions to the end of the list *)              (* move the inlinable functions to the end of the list *)
574              val (f1s,f2s) =              val (f1s,f2s) =
575                  List.partition (fn (F.FK_FUN{inline,...},_,_,_) => inline                  List.partition (fn ({inline=F.IH_ALWAYS,...},_,_,_) => true
576                                   | _ => false) fs                                   | _ => false) fs
577              val fs = f2s @ f1s              val fs = f2s @ f1s
578    
579              (* contract the main body *)              (* contract the main body *)
580              val nle = loop nm le              val nle = loop nm le cont
581              (* contract the functions *)              (* contract the functions *)
582              val fs = cfun(nm, fs, [])              val fs = cfun(nm, fs, [])
583              (* junk newly unused funs *)              (* junk newly unused funs *)
# Line 580  Line 585 
585          in          in
586              case fs              case fs
587               of [] => nle               of [] => nle
588                | [f1 as (F.FK_FUN{isrec=NONE,...},f,args,F.APP _),f2] =>                | [f1 as ({isrec=NONE,...},_,_,_),f2] =>
589                  (* gross hack: dropargs might have added a second                  (* gross hack: dropargs might have added a second
590                   * non-recursive function.  we need to split them into                   * non-recursive function.  we need to split them into
591                   * 2 FIXes.  This is very ad-hoc *)                   * 2 FIXes.  This is _very_ ad-hoc *)
592                  F.FIX([f2], F.FIX([f1], nle))                  F.FIX([f2], F.FIX([f1], nle))
               | (F.FK_FUN{isrec=NONE,...},f,args,body)::_::_ =>  
                 bug "gross hack failed"  
593                | _ => F.FIX(fs, nle)                | _ => F.FIX(fs, nle)
594          end          end
595    
596        | F.APP (f,vs) =>        | F.APP (f,vs) =>
597          let val nvs = ((map substval vs) handle x => raise x)          let val nvs = ((map substval vs) handle x => raise x)
598          in case inline ifs (f, nvs)          in case inline ifs (f, nvs)
599              of (SOME(le,od),ifs) => cexp (d,od) ifs m le              of (SOME(le,od),nifs) => cexp (d,od) ifs m le cont
600               | (NONE,_) => F.APP((substval f) handle x => raise x, nvs)               | (NONE,_) => cont(m,F.APP((substval f) handle x => raise x, nvs))
601          end          end
602    
603        | F.TFN ((f,args,body),le) =>        | F.TFN ((f,args,body),le) =>
604          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 #2
605              val nm = addbind(m, f, TFun(f, nbody, args, od))              val nm = addbind(m, f, TFun(f, nbody, args, od))
606              val nle = loop nm le              val nle = loop nm le cont
607          in          in
608              if used f then F.TFN((f, args, nbody), nle) else nle              if used f then F.TFN((f, args, nbody), nle) else nle
609          end          end
610    
611        | F.TAPP(f,tycs) => F.TAPP((substval f) handle x => raise x, tycs)        | F.TAPP(f,tycs) =>
612            cont(m, F.TAPP((substval f) handle x => raise x, tycs))
613    
614        | F.SWITCH (v,ac,arms,def) =>        | F.SWITCH (v,ac,arms,def) =>
615          (case ((val2sval m v) handle x => raise x)          (case ((val2sval m v) handle x => raise x)
# Line 627  Line 631 
631                             *   other opt-opportunities since it hides the                             *   other opt-opportunities since it hides the
632                             *   previous binding. *)                             *   previous binding. *)
633                            val nm = addbind(nm, lvc, Con(lvc, F.VAR lv, ndc, tycs))                            val nm = addbind(nm, lvc, Con(lvc, F.VAR lv, ndc, tycs))
634                        in (F.DATAcon(ndc, tycs, lv), loop nm le)                        in (F.DATAcon(ndc, tycs, lv), loop nm le #2)
635                        end                        end
636                      | carm (con,le) = (con, loop m le)                      | carm (con,le) = (con, loop m le #2)
637                    val narms = map carm arms                    val narms = map carm arms
638                    val ndef = Option.map (loop m) def                    val ndef = Option.map (fn le => loop m le #2) def
639               in               in
640                    F.SWITCH(sval2val sv, ac, narms, ndef)                    cont(m, F.SWITCH(sval2val sv, ac, narms, ndef))
641               end               end
642    
643             | Con (lvc,v,dc1,tycs1) =>             | Con (lvc,v,dc1,tycs1) =>
# Line 647  Line 651 
651                       if FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) then                       if FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) then
652                           (map killarm tl; (* kill the rest *)                           (map killarm tl; (* kill the rest *)
653                            Option.map killle def; (* and the default case *)                            Option.map killle def; (* and the default case *)
654                            loop (substitute(m, lv, val2sval m v, F.VAR lvc)) le)                            loop (substitute(m, lv, val2sval m v, F.VAR lvc))
655                                   le cont)
656                       else                       else
657                           (* kill this arm and continue with the rest *)                           (* kill this arm and continue with the rest *)
658                           (kill lv le; carm tl)                           (kill lv le; carm tl)
659                     | carm [] = loop m (Option.valOf def)                     | carm [] = loop m (Option.valOf def) cont
660                     | carm _ = buglexp("unexpected arm in switch(con,...)", le)                     | carm _ = buglexp("unexpected arm in switch(con,...)", le)
661               in carm arms               in carm arms
662               end               end
# Line 660  Line 665 
665               let fun kill le = ((#1 (C.unuselexp (undertake m))) le) handle x => raise x               let fun kill le = ((#1 (C.unuselexp (undertake m))) le) handle x => raise x
666                   fun carm ((con,le)::tl) =                   fun carm ((con,le)::tl) =
667                       if eqConV(con, v) then                       if eqConV(con, v) then
668                            (map (kill o #2) tl; Option.map kill def; loop m le)                            (map (kill o #2) tl;
669                               Option.map kill def;
670                               loop m le cont)
671                       else (kill le; carm tl)                       else (kill le; carm tl)
672                     | carm [] = loop m (Option.valOf def)                     | carm [] = loop m (Option.valOf def) cont
673               in carm arms               in carm arms
674               end               end
675             | sv as (Fun _ | TFun _) =>             | sv as (Fun _ | TFun _) =>
# Line 673  Line 680 
680              fun ccon sv =              fun ccon sv =
681                  let val nv = sval2val sv                  let val nv = sval2val sv
682                      val nm = addbind(m, lv, Con(lv, nv, ndc, tycs1))                      val nm = addbind(m, lv, Con(lv, nv, ndc, tycs1))
683                      val nle = loop nm le                      val nle = loop nm le cont
684                  in if used lv then F.CON(ndc, tycs1, nv, lv, nle) else nle                  in if used lv then F.CON(ndc, tycs1, nv, lv, nle) else nle
685                  end                  end
686          in case ((val2sval m v) handle x => raise x)          in case ((val2sval m v) handle x => raise x)
687              of sv as (Decon (lvd,vc,dc2,tycs2)) =>              of sv as (Decon (lvd,vc,dc2,tycs2)) =>
688                 if FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) then                 if FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) then
689                     let val sv = (val2sval m vc) handle x => raise x                     let val sv = (val2sval m vc) handle x => raise x
690                     in loop (substitute(m, lv, sv, F.VAR lvd)) le                     in loop (substitute(m, lv, sv, F.VAR lvd)) le cont
691                     end                     end
692                 else ccon sv                 else ccon sv
693               | sv => ccon sv               | sv => ccon sv
# Line 711  Line 718 
718          in case g (0,svs)          in case g (0,svs)
719              of SOME v =>              of SOME v =>
720                 let val sv = (val2sval m v) handle x => raise x                 let val sv = (val2sval m v) handle x => raise x
721                 in loop (substitute(m, lv, sv, F.INT 0)) le                 in loop (substitute(m, lv, sv, F.INT 0)) le cont
722                         before app (unuseval (undertake m)) vs                         before app (unuseval (undertake m)) vs
723                 end                 end
724               | _ =>               | _ =>
725                 let val nvs = map sval2val svs                 let val nvs = map sval2val svs
726                     val nm = addbind(m, lv, Record(lv, nvs))                     val nm = addbind(m, lv, Record(lv, nvs))
727                     val nle = loop nm le                     val nle = loop nm le cont
728                 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
729                 end                 end
730          end          end
# Line 726  Line 733 
733          (case ((val2sval m v) handle x => raise x)          (case ((val2sval m v) handle x => raise x)
734            of Record (lvr,vs) =>            of Record (lvr,vs) =>
735               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
736               in loop (substitute(m, lv, sv, F.VAR lvr)) le               in loop (substitute(m, lv, sv, F.VAR lvr)) le cont
737               end               end
738             | sv =>             | sv =>
739               let val nv = sval2val sv               let val nv = sval2val sv
740                   val nm = addbind (m, lv, Select(lv, nv, i))                   val nm = addbind (m, lv, Select(lv, nv, i))
741                   val nle = loop nm le                   val nle = loop nm le cont
742               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
743               end)               end)
744    
745        | F.RAISE (v,ltys) => F.RAISE((substval v) handle x => raise x, ltys)        | F.RAISE (v,ltys) =>
746            cont(m, F.RAISE((substval v) handle x => raise x, ltys))
747    
748        | F.HANDLE (le,v) => F.HANDLE(loop m le, (substval v) handle x => raise x)        | F.HANDLE (le,v) =>
749            cont(m, F.HANDLE(loop m le #2, (substval v) handle x => raise x))
750    
751        | F.BRANCH (po,vs,le1,le2) =>        | F.BRANCH (po,vs,le1,le2) =>
752          let 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 nle1 = loop m le1              val nle1 = loop m le1 #2
755              val nle2 = loop m le2              val nle2 = loop m le2 #2
756          in F.BRANCH(npo, nvs, nle1, nle2)          in cont(m, F.BRANCH(npo, nvs, nle1, nle2))
757          end          end
758    
759        | F.PRIMOP (po,vs,lv,le) =>        | F.PRIMOP (po,vs,lv,le) =>
# Line 752  Line 761 
761              val nvs = ((map substval vs) handle x => raise x)              val nvs = ((map substval vs) handle x => raise x)
762              val npo = cpo po              val npo = cpo po
763              val nm = addbind(m, lv, Var(lv,NONE))              val nm = addbind(m, lv, Var(lv,NONE))
764              val nle = loop nm le              val nle = loop nm le cont
765          in          in
766              if impure orelse used lv              if impure orelse used lv
767              then F.PRIMOP(npo, nvs, lv, nle)              then F.PRIMOP(npo, nvs, lv, nle)
# Line 762  Line 771 
771    
772  fun contract (fdec as (_,f,_,_)) =  fun contract (fdec as (_,f,_,_)) =
773      ((*  C.collect fdec; *)      ((*  C.collect fdec; *)
774       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
775                   M.empty (F.FIX([fdec], F.RET[F.VAR f])) #2
776        of F.FIX([fdec], F.RET[F.VAR f]) => fdec        of F.FIX([fdec], F.RET[F.VAR f]) => fdec
777         | fdec => bug "invalid return fundec")         | fdec => bug "invalid return fundec")
778    

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