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 62, Tue Mar 31 05:13:22 1998 UTC revision 63, Tue Mar 31 05:26:42 1998 UTC
# Line 19  Line 19 
19  (* things that lcontract did that fcontract doesn't do (yet):  (* things that lcontract did that fcontract doesn't do (yet):
20   *   *
21   * - inline across DeBruijn depths   * - inline across DeBruijn depths
22   * - switch(con) concellation   * - elimination of let [dead-vs] = pure in body
23   * - elimination of let [dead-vs] = pure in body *)   *)
24    
25  structure FContract :> FCONTRACT =  structure FContract :> FCONTRACT =
26  struct  struct
# Line 44  Line 44 
44    
45  datatype sval  datatype sval
46    = Val    of F.value    = Val    of F.value
   | Var    of F.lvar  
47    | 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
48    | 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
49    | Record of F.lvar * F.value list    | Record of F.lvar * F.value list
# Line 62  Line 61 
61    
62      fun impurePO po = true              (* if a PrimOP is pure or not *)      fun impurePO po = true              (* if a PrimOP is pure or not *)
63    
64        fun eqConV (F.INTcon i1,    F.INT i2)       = i1 = i2
65          | eqConV (F.INT32con i1,  F.INT32 i2)     = i1 = i2
66          | eqConV (F.WORDcon i1,   F.WORD i2)      = i1 = i2
67          | eqConV (F.WORD32con i1, F.WORD32 i2)    = i1 = i2
68          | eqConV (F.REALcon r1,   F.REAL r2)      = r1 = r2
69          | eqConV (F.STRINGcon s1, F.STRING s2)    = s1 = s2
70          | eqConV (con,v) = bugval("unexpected comparison with val", v)
71    
72      fun lookup lv = M.map m lv      fun lookup lv = M.map m lv
73  (*                      handle e as NotFound => *)  (*                      handle e as NotFound => *)
74  (*                      (say (concat ["\nlooking up unbound ", *)  (*                      (say (concat ["\nlooking up unbound ", *)
# Line 70  Line 77 
77    
78      fun sval2val sv =      fun sval2val sv =
79          case sv          case sv
80           of (Var lv | Fun{1=lv,...} | TFun{1=lv,...} | Record{1=lv,...}           of (Fun{1=lv,...} | TFun{1=lv,...} | Record{1=lv,...}
81            | Select{1=lv,...} | Con{1=lv,...} | Val (F.VAR lv)) => F.VAR lv            | Select{1=lv,...} | Con{1=lv,...}) => F.VAR lv
82            | Val v => v            | Val v => v
83    
84      fun val2sval (F.VAR ov) = ((lookup ov) handle x => raise x)      fun val2sval (F.VAR ov) = lookup ov
85        | val2sval v = Val v        | val2sval v = Val v
86    
87      fun bugsv (msg,sv) = bugval(msg, sval2val sv)      fun bugsv (msg,sv) = bugval(msg, sval2val sv)
# Line 92  Line 99 
99      (* called when a variable becomes dead.      (* called when a variable becomes dead.
100       * it simply adjusts the use-counts *)       * it simply adjusts the use-counts *)
101      fun undertake lv =      fun undertake lv =
102          (case lookup lv          case lookup lv
103           of Val v               => unuseval undertake v           of Val (F.VAR nlv)     => ASSERT(nlv = lv, "nlv = lv")
104            | Var nlv             => ASSERT(nlv = lv, "nlv = lv")            | Val v               => unuseval undertake v
105            | ( Fun {1=lv,2=le,...} | TFun{1=lv,2=le,...} ) =>            | ( Fun {1=lv,2=le,...} | TFun{1=lv,2=le,...} ) =>
106               C.inside lv (fn()=> C.unuselexp undertake le)               C.inside lv (fn()=> C.unuselexp undertake le)
107            | ( Select {2=v,...} | Con {2=v,...} ) =>            | ( Select {2=v,...} | Con {2=v,...} ) =>
108               unuseval undertake v               unuseval undertake v
109            | Record {2=vs,...}   => app (unuseval undertake) vs)            | Record {2=vs,...}   => app (unuseval undertake) vs
              handle x =>  
              (say "while undertaking "; PP.printSval(F.VAR lv); say "\n";  
               raise x)  
110    
111      fun addbind (lv,sv) =      fun addbind (lv,sv) =
112          let fun eqsv (sv1,sv2) = (sval2val sv1) = (sval2val sv2)          let fun eqsv (sv1,sv2) = (sval2val sv1) = (sval2val sv2)
# Line 119  Line 123 
123      fun substitute (lv1, sv, v) =      fun substitute (lv1, sv, v) =
124          (case sval2val sv of F.VAR lv2 => C.transfer(lv1,lv2) | v2 => ();          (case sval2val sv of F.VAR lv2 => C.transfer(lv1,lv2) | v2 => ();
125           unuseval undertake v;           unuseval undertake v;
126           addbind (lv1, sv)) handle x => raise x           addbind (lv1, sv))
127    
128      (* common code for all the lexps "let v = <op>[v1,...] in ..." *)      (* common code for all the lexps "let v = <op>[v1,...] in ..." *)
129      fun clet1 (svcon,lecon) (lv,vs,le) =      fun clet1 (svcon,lecon) (lv,vs,le) =
# Line 144  Line 148 
148    
149  in  in
150      case le      case le
151       of F.RET vs => (F.RET (map substval vs) handle x => raise x)       of F.RET vs => F.RET(map substval vs)
152    
153        | F.LET (lvs,le,body) =>        | F.LET (lvs,le,body) =>
154          (let fun clet (F.LET(lvs1,le1,le2)) = F.LET(lvs1, le1, clet le2)          let fun clet (F.LET(lvs1,le1,le2)) = F.LET(lvs1, le1, clet le2)
155                 (* let associativity                 (* let associativity
156                  * !!BEWARE!! applying the associativity rule might                  * !!BEWARE!! applying the associativity rule might
157                  * change the liveness of the bound variables *)                  * change the liveness of the bound variables *)
# Line 190  Line 194 
194                        (ListPair.zip(lvs, vs));                        (ListPair.zip(lvs, vs));
195                        loop body)                        loop body)
196                 | clet le =                 | clet le =
197                   (app (fn lv => addbind (lv, Var lv)) lvs;                  (app (fn lv => addbind (lv, Val(F.VAR lv))) lvs;
198                    case loop body                    case loop body
199                     of F.RET vs => if vs = (map F.VAR lvs) then le                     of F.RET vs => if vs = (map F.VAR lvs) then le
200                                    else F.LET(lvs, le, F.RET vs)                                    else F.LET(lvs, le, F.RET vs)
201                      | nbody => F.LET(lvs, le, nbody))                      | nbody => F.LET(lvs, le, nbody))
202          in          in
203              clet (loop le)              clet (loop le)
204          end handle x => raise x)          end
205    
206        | F.FIX (fs,le) =>        | F.FIX (fs,le) =>
207          (let fun cfun [] acc = rev acc          let fun cfun [] acc = rev acc
208                 | cfun (fdec as (fk,f,args,body)::fs) acc =                 | cfun (fdec as (fk,f,args,body)::fs) acc =
209                   if used f then                   if used f then
210                       let (* make up the bindings for args inside the body *)                       let (* make up the bindings for args inside the body *)
211                           val _ = app (fn lv => addbind (lv, Var lv))                          val _ = app (fn lv => addbind (lv, Val(F.VAR lv)))
212                                       (map #1 args)                                       (map #1 args)
213                           (* contract the body and create the resulting fundec *)                           (* contract the body and create the resulting fundec *)
214                           val nbody = C.inside f (fn()=> loop body)                           val nbody = C.inside f (fn()=> loop body)
# Line 238  Line 242 
242              if List.null fs              if List.null fs
243              then nle              then nle
244              else F.FIX(fs,nle)              else F.FIX(fs,nle)
245          end handle x => raise x)          end
246    
247        | F.APP (f,vs) =>        | F.APP (f,vs) =>
248          (let val nvs = map substval vs          let val nvs = map substval vs
249          in case val2sval f          in case val2sval f
250              of Fun(g,body,args,fk,od) =>              of Fun(g,body,args,fk,od) =>
251                 (ASSERT(C.usenb g > 0, "C.usenb g > 0");                 (ASSERT(C.usenb g > 0, "C.usenb g > 0");
# Line 257  Line 261 
261                  else F.APP(F.VAR g, nvs))                  else F.APP(F.VAR g, nvs))
262    
263               | sv => F.APP(sval2val sv, nvs)               | sv => F.APP(sval2val sv, nvs)
264          end handle x => raise x)          end
265    
266        | F.TFN ((f,args,body),le) =>        | F.TFN ((f,args,body),le) =>
267          ((if used f then          if used f then
268               let (* val _ = addbind (f, TFun(f, body, args, od)) *)               let (* val _ = addbind (f, TFun(f, body, args, od)) *)
269                   val nbody = cexp (DI.next d, DI.next od) body                   val nbody = cexp (DI.next d, DI.next od) body
270                   val _ = addbind (f, TFun(f, nbody, args, od))                   val _ = addbind (f, TFun(f, nbody, args, od))
# Line 270  Line 274 
274                   then F.TFN((f, args, nbody), nle)                   then F.TFN((f, args, nbody), nle)
275                   else nle                   else nle
276               end               end
277           else loop le) handle x => raise x)          else loop le
278    
279        | F.TAPP(f,tycs) => F.TAPP(substval f, tycs)        | F.TAPP(f,tycs) => F.TAPP(substval f, tycs)
280    
281        | F.SWITCH (v,ac,arms,def) =>        | F.SWITCH (v,ac,arms,def) =>
282          (let val nv = substval v          (case val2sval v
283               fun carm (F.DATAcon(dc,tycs,lv),le) =            of sv as (Val(F.VAR lv) | Select(lv,_,_)) =>
284                   (addbind(lv, Var lv);               (let fun carm (F.DATAcon(dc,tycs,lv),le) =
285                          (addbind(lv, Val(F.VAR lv));
286                    (F.DATAcon(cdcon dc, tycs, lv), loop le))                    (F.DATAcon(cdcon dc, tycs, lv), loop le))
287                 | carm (con,le) = (con, loop le)                 | carm (con,le) = (con, loop le)
288               val narms = map carm arms               val narms = map carm arms
289               val ndef = Option.map loop def               val ndef = Option.map loop def
290          in          in
291              F.SWITCH(nv,ac,narms,ndef)                    F.SWITCH(sval2val sv, ac, narms, ndef)
292          end handle x => raise x)          end handle x => raise x)
293    
294               | Con (lvc,v,(_,conrep,_)) =>
295                 let fun carm ((F.DATAcon((_,crep,_),tycs,lv),le)::tl) =
296                         if crep = conrep then
297                             (substitute(lv, val2sval v, F.VAR lvc);
298                              loop le)
299                         else carm tl
300                       | carm [] = loop (Option.valOf def)
301                       | carm _ = buglexp("unexpected arm in switch(con,...)", le)
302                 in carm arms
303                 end
304    
305               | Val v =>
306                 let fun carm ((con,le)::tl) =
307                         if eqConV(con, v) then loop le else carm tl
308                       | carm [] = loop(Option.valOf def)
309                 in carm arms
310                 end
311               | sv => bugval("unexpected switch argument", sval2val sv))
312    
313        | F.CON (dc,tycs,v,lv,le) =>        | F.CON (dc,tycs,v,lv,le) =>
314          let val ndc = cdcon dc          let val ndc = cdcon dc
315          in clet1 (fn [nv] => Con(lv, nv, ndc),          in clet1 (fn [nv] => Con(lv, nv, ndc),
# Line 319  Line 343 
343        | F.HANDLE (le,v) => F.HANDLE(loop le, substval v)        | F.HANDLE (le,v) => F.HANDLE(loop le, substval v)
344    
345        | F.BRANCH (po,vs,le1,le2) =>        | F.BRANCH (po,vs,le1,le2) =>
346          (let val nvs = map substval vs          let val nvs = map substval vs
347               val npo = cpo po               val npo = cpo po
348               val nle1 = loop le1               val nle1 = loop le1
349               val nle2 = loop le2               val nle2 = loop le2
350          in F.BRANCH(npo, nvs, nle1, le2)          in F.BRANCH(npo, nvs, nle1, le2)
351          end handle x => raise x)          end
352    
353        | F.PRIMOP (po,vs,lv,le) =>        | F.PRIMOP (po,vs,lv,le) =>
354          (let val nvs = map substval vs          let val nvs = map substval vs
355               val npo = cpo po               val npo = cpo po
356               val _ = addbind(lv, Var lv)              val _ = addbind(lv, Val(F.VAR lv))
357               val nle = loop le               val nle = loop le
358          in if impurePO po orelse used lv          in if impurePO po orelse used lv
359             then F.PRIMOP(npo, nvs, lv, nle)             then F.PRIMOP(npo, nvs, lv, nle)
360             else nle             else nle
361          end handle x => raise x)          end
362    
363  end handle x => raise x  end
364    
365  fun contract (fdec as (_,f,_,_)) =  fun contract (fdec as (_,f,_,_)) =
366      let val _ = M.clear m      let val _ = M.clear m

Legend:
Removed from v.62  
changed lines
  Added in v.63

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