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 188, Thu Nov 12 00:24:58 1998 UTC revision 189, Sun Nov 15 22:29:42 1998 UTC
# Line 5  Line 5 
5  sig  sig
6    
7      (* needs Collect to be setup properly *)      (* needs Collect to be setup properly *)
8      val contract : FLINT.fundec -> FLINT.fundec      val contract : FLINT.fundec * Stats.counter -> FLINT.fundec
9    
10  end  end
11    
# Line 197  Line 197 
197    = Val    of F.value                   (* F.value should never be F.VAR lv *)    = Val    of F.value                   (* F.value should never be F.VAR lv *)
198    | Fun    of F.lvar * F.lexp * (F.lvar * F.lty) list * F.fkind * DI.depth    | Fun    of F.lvar * F.lexp * (F.lvar * F.lty) list * F.fkind * DI.depth
199    | TFun   of F.lvar * F.lexp * (F.tvar * F.tkind) list * DI.depth    | TFun   of F.lvar * F.lexp * (F.tvar * F.tkind) list * DI.depth
200    | Record of F.lvar * F.value list    | Record of F.lvar * sval list
201    | Con    of F.lvar * F.value * F.dcon * F.tyc list    | Con    of F.lvar * sval * F.dcon * F.tyc list
202    | Decon  of F.lvar * F.value * F.dcon * F.tyc list    | Decon  of F.lvar * sval * F.dcon * F.tyc list
203    | Select of F.lvar * F.value * int    | Select of F.lvar * sval * int
204    | Var    of F.lvar * F.lty option     (* cop out case *)    | Var    of F.lvar * F.lty option     (* cop out case *)
205    
206  fun sval2lty (Var(_,x)) = x  fun sval2lty (Var(_,x)) = x
# Line 213  Line 213 
213      LT.tc_eqv(tyc1,tyc2) andalso tycs_eq(tycs1,tycs2)      LT.tc_eqv(tyc1,tyc2) andalso tycs_eq(tycs1,tycs2)
214    | tycs_eq _ = false    | tycs_eq _ = false
215    
216  fun contract (fdec as (_,f,_,_)) = let  fun click s c = (if !CTRL.misc = 1 then say s else (); Stats.addCounter c 1)
217    
218  val inlineWitness = ref false  (*  val c_inline         = Stats.newCounter[] *)
219    (*  val c_deadval        = Stats.newCounter[] *)
220    (*  val c_deadlexp       = Stats.newCounter[] *)
221    (*  val c_select         = Stats.newCounter[] *)
222    (*  val c_record         = Stats.newCounter[] *)
223    (*  val c_lacktype       = Stats.newCounter[] *)
224    (*  val c_con    = Stats.newCounter[] *)
225    (*  val c_switch         = Stats.newCounter[] *)
226    (*  val c_eta    = Stats.newCounter[] *)
227    (*  val c_etasplit       = Stats.newCounter[] *)
228    (*  val c_branch         = Stats.newCounter[] *)
229    (*  val c_cstargs        = Stats.newCounter[] *)
230    (*  val c_dropargs       = Stats.newCounter[] *)
231    
232    fun contract (fdec as (_,f,_,_), counter) = let
233    
234        val c_dummy = Stats.newCounter[]
235        val c_miss = Stats.newCounter[]
236    
237        fun click_deadval  () = (click "d" counter)
238        fun click_deadlexp () = (click "D" counter)
239        fun click_select   () = (click "s" counter)
240        fun click_record   () = (click "r" counter)
241        fun click_con      () = (click "c" counter)
242        fun click_switch   () = (click "s" counter)
243        fun click_eta      () = (click "e" counter)
244        fun click_etasplit () = (click "E" counter)
245        fun click_branch   () = (click "b" counter)
246        fun click_cstargs  () = (click "A" counter)
247        fun click_dropargs () = (click "a" counter)
248    
249        fun click_lacktype () = (click "t" c_miss)
250    
251        (* this counters is actually *used* by fcontract.
252         * It's  not used just for statistics. *)
253        val c_inline         = Stats.newCounter[counter]
254    (*      val c_inline1    = Stats.newCounter[c_inline] *)
255    (*      val c_inline2    = Stats.newCounter[c_inline] *)
256    (*      val c_unroll     = Stats.newCounter[c_inline] *)
257        fun click_simpleinline () = (click "i" c_inline)
258        fun click_copyinline   () = (click "I" c_inline)
259        fun click_unroll       () = (click "u" c_inline)
260        fun inline_count () = Stats.getCounter c_inline
261    
262  (* cfg: is used for deBruijn renumbering when inlining at different depths  (* cfg: is used for deBruijn renumbering when inlining at different depths
263   * ifs (inlined functions): records which functions we're currently inlining   * ifs (inlined functions): records which functions we're currently inlining
# Line 253  Line 295 
295            | Val v => v            | Val v => v
296    
297      fun val2sval m (F.VAR ov) =      fun val2sval m (F.VAR ov) =
298          ((lookup m ov) handle x => ((*  PP.printSval(F.VAR ov); *) raise x))          ((lookup m ov) handle x =>
299             (say("val2sval "^(C.LVarString ov)^"\n"); raise x))
300        | val2sval m v = Val v        | val2sval m v = Val v
301    
302      fun bugsv (msg,sv) = bugval(msg, sval2val sv)      fun bugsv (msg,sv) = bugval(msg, sval2val sv)
# Line 279  Line 322 
322                                    le))                                    le))
323               | TFun{1=lv,2=le,...} =>               | TFun{1=lv,2=le,...} =>
324                 C.unuselexp undertake le                 C.unuselexp undertake le
325               | (Select {2=v,...} | Con {2=v,...}) => unuseval m v               | (Select {2=sv,...} | Con {2=sv,...}) => unusesval m sv
326               | Record {2=vs,...} => app (unuseval m) vs               | Record {2=svs,...} => app (unusesval m) svs
327               (* decon's are implicit so we can't get rid of them *)               (* decon's are implicit so we can't get rid of them *)
328               | Decon _ => ()               | Decon _ => ()
329          end          end
# Line 289  Line 332 
332                       | x =>                       | x =>
333                         (say("while undertaking "^(C.LVarString lv)^"\n"); raise x)                         (say("while undertaking "^(C.LVarString lv)^"\n"); raise x)
334    
335        and unusesval m sv = unuseval m (sval2val sv)
336      and unuseval m (F.VAR lv) =      and unuseval m (F.VAR lv) =
337          if (C.unuse false (C.get lv)) then undertake m lv else ()          if (C.unuse false (C.get lv)) then undertake m lv else ()
338        | unuseval f _ = ()        | unuseval f _ = ()
# Line 343  Line 387 
387                    * and kill only the function name.  This inlining strategy                    * and kill only the function name.  This inlining strategy
388                    * looks inoffensive enough, but still requires some care:                    * looks inoffensive enough, but still requires some care:
389                    * see comments at the begining of this file and in cfun *)                    * see comments at the begining of this file and in cfun *)
390                   (inlineWitness := true;                   (click_simpleinline();
391                    ignore(C.unuse true (C.get g));                    ignore(C.unuse true (C.get g));
392                    ASSERT(not (used g), "killed");                    ASSERT(not (used g), "killed");
393                    (SOME(F.LET(map #1 args, F.RET vs, body), od), ifs))                    (SOME(F.LET(map #1 args, F.RET vs, body), od), ifs))
# Line 360  Line 404 
404                   let val nle =                   let val nle =
405                           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))
406                   in                   in
                      inlineWitness := true;  
407                       (*  say ("\nInlining "^(C.LVarString g)); *)                       (*  say ("\nInlining "^(C.LVarString g)); *)
408                       (app (unuseval m) vs) handle x => raise x;                       (app (unuseval m) vs) handle x => raise x;
409                       unusecall m g;                       unusecall m g;
410                       (SOME(nle, od),                       (SOME(nle, od),
411                        (* gross hack: to prevent further unrolling,                        (* gross hack: to prevent further unrolling,
412                         * I pretend that the rest is not inside the body *)                         * I pretend that the rest is not inside the body *)
413                        if inline = F.IH_UNROLL then S.rmv(g, ifs) else S.add(g, ifs))                        if inline = F.IH_UNROLL
414                          then (click_unroll(); S.rmv(g, ifs))
415                          else (click_copyinline(); S.add(g, ifs)))
416                   end                   end
417               else (NONE, ifs))               else (NONE, ifs))
418            | sv => (NONE, ifs)            | sv => (NONE, ifs)
# Line 417  Line 462 
462                                                        body                                                        body
463                                 val nle2 = F.LET([nlv], le2, body2)                                 val nle2 = F.LET([nlv], le2, body2)
464                             in                             in
465                                   click_branch();
466                                 loop m (wrap(F.BRANCH(po, vs, nle1, nle2))) cont                                 loop m (wrap(F.BRANCH(po, vs, nle1, nle2))) cont
467                             end                             end
468                         else                         else
# Line 432  Line 478 
478          end          end
479    
480        | F.FIX (fs,le) =>        | F.FIX (fs,le) =>
481          let (* register dump bindings *)          let (* The actual function contraction *)
             val m = foldl (fn (fdec as (_,f,_,_),m) =>  
                            addbind(m, f, Var(f,NONE)))  
                           m fs  
   
             (* The actual function contraction *)  
482              fun cfun (m,[]:F.fundec list,acc) = acc              fun cfun (m,[]:F.fundec list,acc) = acc
483                | cfun (m,fdec as ({inline,cconv,known,isrec},f,args,body)::fs,acc) =                | cfun (m,fdec as ({inline,cconv,known,isrec},f,args,body)::fs,acc) =
484                  if used f then                  let val fi = C.get f
485                    in if C.dead fi then cfun(m, fs, acc)
486                       else if C.iusenb fi = C.usenb fi then
487                           (* we need to be careful that undertake not be called
488                            * recursively *)
489                           (C.use NONE fi; undertake m f; cfun(m, fs, acc))
490                       else
491                      let (*  val _ = say ("\nEntering "^(C.LVarString f)) *)                      let (*  val _ = say ("\nEntering "^(C.LVarString f)) *)
492                          val oldWitness =                          val saved_ic = inline_count()
                             (!inlineWitness before inlineWitness := false)  
493                          (* make up the bindings for args inside the body *)                          (* make up the bindings for args inside the body *)
494                          fun addnobind ((lv,lty),m) =                          fun addnobind ((lv,lty),m) =
495                              addbind(m, lv, Var(lv, SOME lty))                              addbind(m, lv, Var(lv, SOME lty))
# Line 454  Line 500 
500                           * changed (read: bigger), so we have to reset the                           * changed (read: bigger), so we have to reset the
501                           * `inline' bit *)                           * `inline' bit *)
502                          val nfk = {isrec=isrec, cconv=cconv,                          val nfk = {isrec=isrec, cconv=cconv,
503                                     known=known orelse not(C.escaping(C.get f))handle x => raise x,                                     known=known orelse not(C.escaping fi),
504                                     inline=if !inlineWitness                                     inline=if inline_count() = saved_ic
505                                            then F.IH_SAFE                                            then inline
506                                            else (inline before                                            else F.IH_SAFE}
                                                 inlineWitness := oldWitness)}  
507                          (* update the binding in the map.  This step is not                          (* update the binding in the map.  This step is not
508                           * not just a mere optimization but is necessary                           * not just a mere optimization but is necessary
509                           * because if we don't do it and the function                           * because if we don't do it and the function
# Line 469  Line 514 
514                      in cfun(nm, fs, (nfk, f, args, nbody)::acc)                      in cfun(nm, fs, (nfk, f, args, nbody)::acc)
515                             (*  before say ("\nExiting "^(C.LVarString f)) *)                             (*  before say ("\nExiting "^(C.LVarString f)) *)
516                      end                      end
517                  else cfun(m, fs, acc)                  end
518    
519              (* check for eta redex *)              (* check for eta redex *)
520              fun ceta (fdec as (fk,f,args,F.APP(g,vs)):F.fundec,(m,fs,hs)) =              fun ceta (fdec as (fk,f,args,F.APP(g,vs)):F.fundec,(m,fs,hs)) =
# Line 486  Line 531 
531                       * escaping one.  It's dangerous for optimisations based                       * escaping one.  It's dangerous for optimisations based
532                       * on known functions (elimination of dead args, f.ex)                       * on known functions (elimination of dead args, f.ex)
533                       * and could generate cases where call>use in collect *)                       * and could generate cases where call>use in collect *)
534                      in if not (((C.escaping(C.get f))handle x => raise x) andalso not (C.escaping(C.get g))handle x => raise x)                      in if (C.escaping(C.get f)) andalso not(C.escaping(C.get g))
535                         then let                         (* the default case could ensure the inline *)
536                           then (m, fdec::fs, hs)
537                           else let
538                             (* if an earlier function h has been eta-reduced                             (* if an earlier function h has been eta-reduced
539                              * to f, we have to be careful to update its                              * to f, we have to be careful to update its
540                              * binding to not refer to f any more since f                              * binding to not refer to f any more since f
# Line 499  Line 546 
546                         in                         in
547                             (* I could almost reuse `substitute' but the                             (* I could almost reuse `substitute' but the
548                              * unuse in substitute assumes the val is escaping *)                              * unuse in substitute assumes the val is escaping *)
549                               click_eta();
550                             C.transfer(f, g);                             C.transfer(f, g);
551                             unusecall m g;                             unusecall m g;
552                             (addbind(m, f, svg), fs, f::hs)                             (addbind(m, f, svg), fs, f::hs)
553                         end                         end
                        (* the default case could ensure the inline *)  
                        else (m, fdec::fs, hs)  
554                      end                      end
555                  else (m, fdec::fs, hs)                  else (m, fdec::fs, hs)
556                | ceta (fdec,(m,fs,hs)) = (m,fdec::fs,hs)                | ceta (fdec,(m,fs,hs)) = (m,fdec::fs,hs)
# Line 516  Line 562 
562                      val cst =                      val cst =
563                          ListPair.map                          ListPair.map
564                              (fn (NONE,_) => false                              (fn (NONE,_) => false
565                                | (SOME v,(a,_)) =>                                | (SOME(F.VAR lv),(a,_)) =>
566                                  ((case substval v                                  ((case sval2val(lookup m lv)
567                                    of F.VAR lv =>                                    of F.VAR lv =>
568                                       if used a andalso used lv then                                       if used a andalso used lv then
569                                           (C.use NONE (C.get lv); true)                                           (C.use NONE (C.get lv); true)
570                                       else false                                       else false
571                                     | _ => false)                                     | _ => true)
572                                      handle M.IntmapF => false))                                      handle M.IntmapF => false)
573                                  | (SOME v,(a,_)) => true)
574                              (actuals, args)                              (actuals, args)
575                  (* if all args are used, there's nothing we can do *)                  (* if all args are used, there's nothing we can do *)
576                  in if List.all not cst then f else                  in if List.all not cst then f else
# Line 540  Line 587 
587                              F.LET(map #1 (filter args),                              F.LET(map #1 (filter args),
588                                    F.RET(map O.valOf (filter actuals)),                                    F.RET(map O.valOf (filter actuals)),
589                                    body)                                    body)
590                      in (fk, g, nargs, nbody)                      in click_cstargs();
591                            (fk, g, nargs, nbody)
592                      end                      end
593                  end                  end
594    
595              (* add wrapper for various purposes *)              (* add wrapper for various purposes *)
596              fun wrap (f as ({inline=F.IH_ALWAYS,...},_,_,_):F.fundec,fs) = f::fs              fun wrap (f as ({inline=F.IH_ALWAYS,...},_,_,_):F.fundec,fs) = f::fs
597                | wrap (f as (fk as {isrec,...},g,args,body):F.fundec,fs) =                | wrap (f as (fk as {isrec,...},g,args,body):F.fundec,fs) =
598                  let fun dropargs filter =                  let val gi = C.get g
599                        fun dropargs filter =
600                          let val (nfk,nfk') = OU.fk_wrap(fk, O.map #1 isrec)                          let val (nfk,nfk') = OU.fk_wrap(fk, O.map #1 isrec)
601                              val args' = filter args                              val args' = filter args
602                              val ng = cplv g                              val ng = cplv g
# Line 558  Line 607 
607                              val nf' = (nfk', ng, args', body)                              val nf' = (nfk', ng, args', body)
608    
609                              val ngi = C.new (SOME(map #1 args')) ng                              val ngi = C.new (SOME(map #1 args')) ng
                             val nargsi = map ((C.new NONE) o #1) nargs  
610                          in                          in
611                                C.ireset gi;
612                                app (ignore o (C.new NONE) o #1) nargs;
613                              C.use (SOME appargs) ngi;                              C.use (SOME appargs) ngi;
614                              app (C.use NONE) nargsi;                              app (C.use NONE o C.get) nargs';
615                              nf'::nf::fs                              nf'::nf::fs
616                          end                          end
617                      val used = map (used o #1) args                      val used = map (used o #1) args
618                  in                  in
619                        (* Don't introduce wrappers for escaping-only functions.
620                         * This is debatable since although wrappers are useless
621                         * on escaping-only functions, some of the escaping uses
622                         * might turn into calls in the course of fcontract, so
623                         * by not introducing wrappers here, we avoid useless work
624                         * but we also postpone useful work to later invocations. *)
625                        if C.called gi then
626                      (* if some args are not used, let's drop them *)                      (* if some args are not used, let's drop them *)
627                      if not (List.all OU.id used) then                      if not (List.all OU.id used) then
628                          dropargs (fn xs => OU.filter(used, xs))                              (click_dropargs();
629                                 dropargs (fn xs => OU.filter(used, xs)))
630    
631                      (* eta-split: add a wrapper for escaping uses *)                      (* eta-split: add a wrapper for escaping uses *)
632                      else                          else if C.escaping gi then
                         let val gi = C.get g  
                         in if ((C.escaping gi)handle x => raise x) andalso ((C.called gi)handle x => raise x) then  
633                              (* like dropargs but keeping all args *)                              (* like dropargs but keeping all args *)
634                              dropargs OU.id                              (click_etasplit(); dropargs OU.id)
635    
636                             else f::fs                             else f::fs
637                          end                      else f::fs
638                  end                  end
639    
640              (* junk unused funs *)              (* junk unused funs *)
641              val fs = List.filter (used o #2) fs              val fs = List.filter (fn (_,f,_,_) =>
642                                      used f orelse (click_deadlexp(); false))
643                                     fs
644    
645              (* redirect cst args to their source value *)              (* redirect cst args to their source value *)
646              val fs = map cstargs fs              val fs = map cstargs fs
# Line 628  Line 686 
686          end          end
687    
688        | F.TFN ((f,args,body),le) =>        | F.TFN ((f,args,body),le) =>
689          if used f then          let val fi = C.get f
690            in if C.dead fi then (click_deadlexp(); loop m le cont) else
691              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
692                  val nm = addbind(m, f, TFun(f, nbody, args, od))                  val nm = addbind(m, f, TFun(f, nbody, args, od))
693                  val nle = loop nm le cont                  val nle = loop nm le cont
694              in              in
695                  if used f then F.TFN((f, args, nbody), nle) else nle                  if C.dead fi then nle else F.TFN((f, args, nbody), nle)
696                end
697              end              end
         else loop m le cont  
698    
699        | F.TAPP(f,tycs) =>        | F.TAPP(f,tycs) =>
700            (* (case val2sval m f
701              of TFun(g,body,args,od) =>
702                 if d = od andalso C.usenb(C.get g) = 1 then
703                     let val (_,_,_,le) =
704                             ({inline=false,isrec=NONE,known=false,cconv=F.CC_FCT},
705                              LV.mkLvar(),[],
706                              F.TFN((g,args,body),TAPP(g,tycs)))
707                     in
708                         inlineWitness := true;
709                         ignore(C.unuse true (C.get g));
710                     end *)
711          cont(m, F.TAPP((substval f) handle x => raise x, tycs))          cont(m, F.TAPP((substval f) handle x => raise x, tycs))
712    
713        | F.SWITCH (v,ac,arms,def) =>        | F.SWITCH (v,ac,arms,def) =>
714          (case ((val2sval m v) handle x => raise x)          (case ((val2sval m v) handle x => raise x)
715            of sv as Con (lvc,v,dc1,tycs1) =>            of sv as Con (lvc,svc,dc1,tycs1) =>
716               let fun killle le = C.unuselexp (undertake m) le               let fun killle le = C.unuselexp (undertake m) le
717                   fun kill lv le =                   fun kill lv le =
718                       C.unuselexp (undertake (addbind(m,lv,Var(lv,NONE)))) le                       C.unuselexp (undertake (addbind(m,lv,Var(lv,NONE)))) le
# Line 655  Line 725 
725                       if #2 dc1 = #2 (cdcon dc2) then                       if #2 dc1 = #2 (cdcon dc2) then
726                           (map killarm tl; (* kill the rest *)                           (map killarm tl; (* kill the rest *)
727                            O.map killle def; (* and the default case *)                            O.map killle def; (* and the default case *)
728                            loop (substitute(m, lv, val2sval m v, F.VAR lvc))                            loop (substitute(m, lv, svc, F.VAR lvc))
729                                 le cont)                                 le cont)
730                       else                       else
731                           (* kill this arm and continue with the rest *)                           (* kill this arm and continue with the rest *)
732                           (kill lv le; carm tl)                           (kill lv le; carm tl)
733                     | carm [] = loop m (O.valOf def) cont                     | carm [] = loop m (O.valOf def) cont
734                     | carm _ = buglexp("unexpected arm in switch(con,...)", le)                     | carm _ = buglexp("unexpected arm in switch(con,...)", le)
735               in carm arms               in click_switch(); carm arms
736               end               end
737    
738             | sv as Val v =>             | sv as Val v =>
# Line 674  Line 744 
744                             loop m le cont)                             loop m le cont)
745                       else (kill le; carm tl)                       else (kill le; carm tl)
746                     | carm [] = loop m (O.valOf def) cont                     | carm [] = loop m (O.valOf def) cont
747               in carm arms               in click_switch(); carm arms
748               end               end
749    
750             | sv as (Var{1=lvc,...} | Select{1=lvc,...} | Decon{1=lvc, ...}             | sv as (Var{1=lvc,...} | Select{1=lvc,...} | Decon{1=lvc, ...}
# Line 684  Line 754 
754                    (* this is a mere DECON, so we can push the let binding                    (* this is a mere DECON, so we can push the let binding
755                     * (hidden in cont) inside and maybe even drop the DECON *)                     * (hidden in cont) inside and maybe even drop the DECON *)
756                    let val ndc = cdcon dc                    let val ndc = cdcon dc
757                        val nm = addbind(m, lv, Decon(lv, F.VAR lvc, ndc, tycs))                        val slv = Decon(lv, sv, ndc, tycs)
758                          val nm = addbind(m, lv, slv)
759                        (* see below *)                        (* see below *)
760                        val nm = addbind(nm, lvc, Con(lvc, F.VAR lv, ndc, tycs))                        val nm = addbind(nm, lvc, Con(lvc, slv, ndc, tycs))
761                        val nle = loop nm le cont                        val nle = loop nm le cont
762                        val nv = sval2val sv                        val nv = sval2val sv
763                    in                    in
# Line 700  Line 771 
771                  | _ =>                  | _ =>
772                    let fun carm (F.DATAcon(dc,tycs,lv),le) =                    let fun carm (F.DATAcon(dc,tycs,lv),le) =
773                            let val ndc = cdcon dc                            let val ndc = cdcon dc
774                                val nm = addbind(m, lv,                                val slv = Decon(lv, sv, ndc, tycs)
775                                                 Decon(lv, F.VAR lvc, ndc, tycs))                                val nm = addbind(m, lv, slv)
776                                (* we can rebind lv to a more precise value                                (* we can rebind lv to a more precise value
777                                 * !!BEWARE!!  This rebinding is misleading:                                 * !!BEWARE!!  This rebinding is misleading:
778                                 * - it gives the impression that `lvc' is built                                 * - it gives the impression that `lvc' is built
# Line 715  Line 786 
786                                 * - it seems to be a good idea, but it can hide                                 * - it seems to be a good idea, but it can hide
787                                 *   other opt-opportunities since it hides the                                 *   other opt-opportunities since it hides the
788                                 *   previous binding. *)                                 *   previous binding. *)
789                                val nm = addbind(nm, lvc,                                val nm = addbind(nm, lvc, Con(lvc,slv,ndc,tycs))
                                                Con(lvc, F.VAR lv, ndc, tycs))  
790                            in (F.DATAcon(ndc, tycs, lv), loop nm le #2)                            in (F.DATAcon(ndc, tycs, lv), loop nm le #2)
791                            end                            end
792                          | carm (con,le) = (con, loop m le #2)                          | carm (con,le) = (con, loop m le #2)
# Line 729  Line 799 
799               bugval("unexpected switch arg", sval2val sv))               bugval("unexpected switch arg", sval2val sv))
800    
801        | F.CON (dc1,tycs1,v,lv,le) =>        | F.CON (dc1,tycs1,v,lv,le) =>
802          if used lv then          let val lvi = C.get lv
803            in if C.dead lvi then (click_deadval(); loop m le cont) else
804              let val ndc = cdcon dc1              let val ndc = cdcon dc1
805                  fun ccon sv =                  fun ccon sv =
806                      let val nv = sval2val sv                      let val nm = addbind(m, lv, Con(lv, sv, ndc, tycs1))
                         val nm = addbind(m, lv, Con(lv, nv, ndc, tycs1))  
807                          val nle = loop nm le cont                          val nle = loop nm le cont
808                      in if used lv then F.CON(ndc, tycs1, nv, lv, nle) else nle                      in if C.dead lvi then nle
809                           else F.CON(ndc, tycs1, sval2val sv, lv, nle)
810                      end                      end
811              in case ((val2sval m v) handle x => raise x)              in case ((val2sval m v) handle x => raise x)
812                  of sv as (Decon (lvd,vc,dc2,tycs2)) =>                  of sv as (Decon (lvd,sv',dc2,tycs2)) =>
813                     if FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) then                     if FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) then
814                         let val sv = (val2sval m vc) handle x => raise x                         (click_con();
815                         in loop (substitute(m, lv, sv, F.VAR lvd)) le cont                          loop (substitute(m, lv, sv', F.VAR lvd)) le cont)
                        end  
816                     else ccon sv                     else ccon sv
817                   | sv => ccon sv                   | sv => ccon sv
818              end              end
819          else loop m le cont          end
820    
821        | F.RECORD (rk,vs,lv,le) =>        | F.RECORD (rk,vs,lv,le) =>
822          (* g: check whether the record already exists *)          (* g: check whether the record already exists *)
823          if used lv then          let val lvi = C.get lv
824              let fun g (n,Select(_,v1,i)::ss) =          in if C.dead lvi then (click_deadval(); loop m le cont) else
825                      if n = i then              let fun g (Select(_,sv,0)::ss) =
826                          (case ss                      let fun g' (n,Select(_,sv',i)::ss) =
827                            of Select(_,v2,_)::_ =>                              if n = i andalso (sval2val sv) = (sval2val sv')
828                               if v1 = v2 then g(n+1, ss) else NONE                              then g'(n+1,ss) else NONE
829                             | [] =>                            | g' (n,[]) =
830                               (case sval2lty (val2sval m v1)                              (case sval2lty sv
831                                 of SOME lty =>                                 of SOME lty =>
832                                    let val ltd = case rk                                    let val ltd = case rk
833                                                   of F.RK_STRUCT => LT.ltd_str                                                   of F.RK_STRUCT => LT.ltd_str
834                                                    | F.RK_TUPLE _ => LT.ltd_tuple                                                    | F.RK_TUPLE _ => LT.ltd_tuple
835                                                    | _ => buglexp("bogus rk",le)                                                    | _ => buglexp("bogus rk",le)
836                                    in if length(ltd lty) = n+1                                   in if length(ltd lty) = n
837                                       then SOME v1 else NONE                                      then SOME sv else NONE
838                                     end
839                                   | _ => (click_lacktype(); NONE)) (* sad *)
840                               | g' _ = NONE
841                        in g'(1,ss)
842                                    end                                    end
                                 | _ => NONE) (* sad case *)  
                            | _ => NONE)  
                     else NONE  
843                    | g _ = NONE                    | g _ = NONE
844                  val svs = ((map (val2sval m) vs) handle x => raise x)                  val svs = ((map (val2sval m) vs) handle x => raise x)
845              in case g (0,svs)              in case g svs
846                  of SOME v =>                  of SOME sv => (click_record();
847                     let val sv = (val2sval m v) handle x => raise x                                 loop (substitute(m, lv, sv, F.INT 0)) le cont
848                     in loop (substitute(m, lv, sv, F.INT 0)) le cont                                      before app (unuseval m) vs)
                            before app (unuseval m) vs  
                    end  
849                   | _ =>                   | _ =>
850                     let val nvs = map sval2val svs                     let val nm = addbind(m, lv, Record(lv, svs))
                        val nm = addbind(m, lv, Record(lv, nvs))  
851                         val nle = loop nm le cont                         val nle = loop nm le cont
852                     in if used lv then F.RECORD(rk, nvs, lv, nle) else nle                     in if C.dead lvi then nle
853                          else F.RECORD(rk, map sval2val svs, lv, nle)
854                       end
855                     end                     end
856              end              end
         else loop m le cont  
857    
858        | F.SELECT (v,i,lv,le) =>        | F.SELECT (v,i,lv,le) =>
859          if used lv then          let val lvi = C.get lv
860            in if C.dead lvi then (click_deadval(); loop m le cont) else
861              (case ((val2sval m v) handle x => raise x)              (case ((val2sval m v) handle x => raise x)
862                of Record (lvr,vs) =>                of Record (lvr,svs) =>
863                   let val sv = (val2sval m (List.nth(vs, i))) handle x => raise x                   let val sv = List.nth(svs, i)
864                   in loop (substitute(m, lv, sv, F.VAR lvr)) le cont                   in click_select();
865                         loop (substitute(m, lv, sv, F.VAR lvr)) le cont
866                   end                   end
867                 | sv =>                 | sv =>
868                   let val nv = sval2val sv                   let val nm = addbind (m, lv, Select(lv, sv, i))
                      val nm = addbind (m, lv, Select(lv, nv, i))  
869                       val nle = loop nm le cont                       val nle = loop nm le cont
870                   in if used lv then F.SELECT(nv, i, lv, nle) else nle                   in if C.dead lvi then nle
871                        else F.SELECT(sval2val sv, i, lv, nle)
872                   end)                   end)
873          else loop m le cont          end
874    
875        | F.RAISE (v,ltys) =>        | F.RAISE (v,ltys) =>
876          cont(m, F.RAISE((substval v) handle x => raise x, ltys))          cont(m, F.RAISE((substval v) handle x => raise x, ltys))
# Line 816  Line 887 
887          end          end
888    
889        | F.PRIMOP (po,vs,lv,le) =>        | F.PRIMOP (po,vs,lv,le) =>
890          let val impure = impurePO po          let val lvi = C.get lv
891          in if impure orelse used lv then              val pure = not(impurePO po)
892            in if pure andalso C.dead lvi then (click_deadval();loop m le cont) else
893              let val nvs = ((map substval vs) handle x => raise x)              let val nvs = ((map substval vs) handle x => raise x)
894                  val npo = cpo po                  val npo = cpo po
895                  val nm = addbind(m, lv, Var(lv,NONE))                  val nm = addbind(m, lv, Var(lv,NONE))
896                  val nle = loop nm le cont                  val nle = loop nm le cont
897              in              in
898                  if impure orelse used lv                  if pure andalso C.dead lvi then nle
899                  then F.PRIMOP(npo, nvs, lv, nle)                  else F.PRIMOP(npo, nvs, lv, nle)
                 else nle  
900              end              end
            else loop m le cont  
901          end          end
902  end  end
903    

Legend:
Removed from v.188  
changed lines
  Added in v.189

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