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 72, Sun Apr 5 19:07:40 1998 UTC revision 73, Sun Apr 5 20:59:43 1998 UTC
# Line 16  Line 16 
16   * be careful to make sure that a dead variable will indeed not appear   * be careful to make sure that a dead variable will indeed not appear
17   * in the output lexp since it might else reference other dead variables *)   * in the output lexp since it might else reference other dead variables *)
18    
19  (* things that lcontract.sml did that fcontract doesn't do (yet):  (* things that lcontract.sml does that fcontract doesn't do (yet):
20   * - inline across DeBruijn depths   * - inline across DeBruijn depths
21   * - elimination of let [dead-vs] = pure in body   * - elimination of let [dead-vs] = pure in body
22     * - contraction of let [v] = branch in switch
23   *)   *)
24    
25  (* things that cpsopt/eta.sml did that fcontract doesn't do:  (* things that cpsopt/eta.sml did that fcontract doesn't do:
# Line 62  Line 63 
63    | Select of F.lvar * F.value * int    | Select of F.lvar * F.value * int
64    | Con    of F.lvar * F.value * F.dcon    | Con    of F.lvar * F.value * F.dcon
65    
66    
67    (* this global map should really be replaced by a IntmapF that's passed
68     * around, as it was before, but there are some tricky issues *)
69  exception NotFound  exception NotFound
70  val m : sval M.intmap = M.new(128, NotFound)  val m : sval M.intmap = M.new(128, NotFound)
71    
# Line 163  Line 167 
167       of F.RET vs => F.RET(map substval vs)       of F.RET vs => F.RET(map substval vs)
168    
169        | F.LET (lvs,le,body) =>        | F.LET (lvs,le,body) =>
170          let fun clet (F.LET(lvs1,le1,le2)) = F.LET(lvs1, le1, clet le2)          let fun clet' le = (* default rule for `clet' *)
171                    (app (fn lv => addbind (lv, Val(F.VAR lv))) lvs;
172                     case loop body
173                      of F.RET vs => if vs = (map F.VAR lvs) then le
174                                     else F.LET(lvs, le, F.RET vs)
175                       | nbody => F.LET(lvs, le, nbody))
176    
177                (* the case for LET should be improved.
178                 * Proper treatment of BRANCH should be possible once the real
179                 * inlining support is added *)
180                fun clet (F.LET(lvs1,le1,le2)) = F.LET(lvs1, le1, clet le2)
181                (* let associativity                (* let associativity
182                 * !!BEWARE!! applying the associativity rule might                 * !!BEWARE!! applying the associativity rule might
183                 * change the liveness of the bound variables *)                 * change the liveness of the bound variables *)
# Line 194  Line 208 
208                     then F.PRIMOP(po, vs, lv, nbody)                     then F.PRIMOP(po, vs, lv, nbody)
209                     else nbody                     else nbody
210                  end                  end
211    
212                  (* | clet (le as F.BRANCH(po,vs,le1,le2)) =
213                   *   (case (lvs,body)
214                   *     of ([lv],F.SWITCH(F.VAR v,_,_,_)) =>
215                   *        if lv = v andalso C.usenb lv = 1 then
216                   *            F.BRANCH(po,vs,clet le1, clet le2)
217                   *        else
218                   *            clet' le
219                   *      | _ => clet' le) *)
220    
221                (* F.RAISE never returns so the body of the let could be                (* F.RAISE never returns so the body of the let could be
222                 * dropped on the floor, but since I don't propagate                 * dropped on the floor, but since I don't propagate
223                 * types I can't come up with the right return type                 * types I can't come up with the right return type
# Line 205  Line 229 
229                  (app (fn (lv,v) => substitute (lv, val2sval v, v))                  (app (fn (lv,v) => substitute (lv, val2sval v, v))
230                       (ListPair.zip(lvs, vs));                       (ListPair.zip(lvs, vs));
231                       loop body)                       loop body)
232                | clet le =                | clet le = clet' le
                 (app (fn lv => addbind (lv, Val(F.VAR lv))) lvs;  
                  case loop body  
                   of F.RET vs => if vs = (map F.VAR lvs) then le  
                                  else F.LET(lvs, le, F.RET vs)  
                    | nbody => F.LET(lvs, le, nbody))  
233          in          in
234              clet (loop le)              clet (loop le)
235          end          end
# Line 238  Line 257 
257                                          not (C.escaping g)) andalso                                          not (C.escaping g)) andalso
258                                      vs = (map (F.VAR o #1) args)                                      vs = (map (F.VAR o #1) args)
259                                  then                                  then
260                                      if null acc then                                      if false andalso null acc then
261                                          let val g = F.VAR g                                          let val g = F.VAR g
262                                          in (substitute (f, val2sval g, g); acc)                                          in (substitute (f, val2sval g, g); acc)
263                                          end                                          end
# Line 269  Line 288 
288                           addbind (f, Fun(f, body, args, fk, od)))                           addbind (f, Fun(f, body, args, fk, od)))
289                          fs                          fs
290    
291              (* recurse on the bodies *)              (* contract the main body *)
292                val nle = loop le
293    
294                (* contract the functions *)
295              val fs = cfun fs []              val fs = cfun fs []
296    
297              val nle = loop le           (* contract the main body *)              (* junk newly unused funs *)
298              val fs = List.filter (used o #2) fs (* junk newly unused funs *)              val fs = List.filter (used o #2) fs
299          in          in
300              if List.null fs              if List.null fs
301              then nle              then nle
# Line 319  Line 341 
341            of sv as (Val(F.VAR lv) | Select(lv,_,_)) =>            of sv as (Val(F.VAR lv) | Select(lv,_,_)) =>
342               (let fun carm (F.DATAcon(dc,tycs,lv),le) =               (let fun carm (F.DATAcon(dc,tycs,lv),le) =
343                        (addbind(lv, Val(F.VAR lv));                        (addbind(lv, Val(F.VAR lv));
344                           (* here I should also temporarily bind sv to
345                            * the corresponding Con *)
346                         (F.DATAcon(cdcon dc, tycs, lv), loop le))                         (F.DATAcon(cdcon dc, tycs, lv), loop le))
347                      | carm (con,le) = (con, loop le)                      | carm (con,le) = (con, loop le)
348                    val narms = map carm arms                    val narms = map carm arms

Legend:
Removed from v.72  
changed lines
  Added in v.73

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