Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] View of /sml/branches/SMLNJ/src/compiler/FLINT/opt/lcontract.sml
ViewVC logotype

View of /sml/branches/SMLNJ/src/compiler/FLINT/opt/lcontract.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 24 - (download) (annotate)
Thu Mar 12 00:49:58 1998 UTC (22 years, 11 months ago) by monnier
File size: 9239 byte(s)
*** empty log message ***
(* Copyright 1996 by Bell Laboratories *)
(* lcontract.sml *)

signature LCONTRACT =
sig
  val lcontract : Lambda.lexp -> Lambda.lexp
end 

structure LContract : LCONTRACT =
struct

local structure DI = DebIndex
      open Access Lambda
in

val sameName = LambdaVar.sameName
fun bug s = ErrorMsg.impossible ("LambdaOpt: "^s)
val ident = fn le => le
fun all p (a::r) = p a andalso all p r | all p nil = true

fun isDiff(x, VAR v) = (x <> v)
  | isDiff(x, GENOP({default,table}, _, _, _)) = 
      (x <> default) andalso (all (fn (_, w) => (x <> w)) table)
  | isDiff _ = true

datatype info
  = CompExp
  | SimpVal of value
  | ListExp of value list
  | FunExp of lvar * lty * lexp
  | SimpExp

fun isPure(SVAL _) = true
  | isPure(RECORD _) = true
  | isPure(SRECORD _) = true
  | isPure(VECTOR _) = true
  | isPure(SELECT _) = true
  | isPure(FN _) = true
  | isPure(TFN _) = true
  | isPure(CON _) = true
  | isPure(DECON _) = true (* this can be problematic *)
  | isPure(ETAG _) = true
  | isPure(PACK _) = true
  | isPure(WRAP _) = true
  | isPure(UNWRAP _) = true
  | isPure(SWITCH(v, _, ces, oe)) = 
      let fun g((_,x)::r) = if isPure x then g r else false
            | g [] = case oe of NONE => true | SOME z => isPure z
       in g ces
      end
  | isPure _ = false
  (*** the cases for FIX and LET have already been flattened, thus
       they should not occur ***)

exception LContPass1
fun pass1 lexp = 
  let val zz : (DI.depth option) Intmap.intmap = Intmap.new(32, LContPass1)
      val add = Intmap.add zz
      val get = Intmap.map zz
      val rmv = Intmap.rmv zz
      fun enter(x, d) = add(x, SOME d)
      fun kill x = ((get x; rmv x) handle _ => ())
      fun mark nd x = 
        (let val s = get x
             val _ = rmv x
          in case s
              of NONE => ()
               | SOME d => if (d=nd) then add(x, NONE)
                           else ()
         end) handle _ => ()

      fun cand x = (get x; true) handle _ => false

      fun loop (e, d) = 
        let fun psv (VAR x) = kill x
              | psv _ = ()
         
            and pse (SVAL v) = psv v
              | pse (FN(v, _, e)) = pse e
              | pse (APP(VAR x, v2)) = (mark d x; psv v2)
              | pse (APP(v1, v2)) = (psv v1; psv v2)
              | pse (FIX(vs, ts, es, be)) = (app pse es; pse be)
              | pse (LET(v, FN (_,_,e1), e2)) = (enter(v, d); pse e1; pse e2)
              | pse (LET(v, e1, e2)) = (pse e1; pse e2)
              | pse (TFN(ks, e)) = loop(e, DI.next d)
              | pse (TAPP(v, _)) = psv v
              | pse (VECTOR(vs,_)) = app psv vs
              | pse (RECORD vs) = app psv vs
              | pse (SRECORD vs) = app psv vs
              | pse (SELECT(_,v)) = psv v
              | pse (CON(_,_,v)) = psv v
              | pse (DECON(_,_,v)) = psv v
              | pse (SWITCH(v, _, ces, oe)) =
                  (psv v; app (fn (_,x) => pse x) ces; 
                   case oe of NONE => () | SOME x => pse x)
              | pse (ETAG(v, _)) = psv v
              | pse (HANDLE(e,v)) = (pse e; psv v)
              | pse (PACK(_,_,_,v)) = psv v
              | pse (WRAP(_,_,v)) = psv v
              | pse (UNWRAP(_,_,v)) = psv v
              | pse (RAISE _) = ()

         in pse e
        end

   in loop (lexp, DI.top); cand
  end

(************************************************************************
 *                      THE MAIN FUNCTION                               *
 ************************************************************************)
fun lcontract lexp = 
let 

val isCand = pass1 lexp

exception LContract
val m : (int ref * info) Intmap.intmap = Intmap.new(32, LContract)

val enter = Intmap.add m
val get = Intmap.map m
val kill = Intmap.rmv m

fun chkIn (v, info) = enter(v, (ref 0, info))

fun refer v = 
  ((case get v
     of (_, SimpVal sv) => SOME sv
      | (x, _) => (x := (!x) + 1; NONE)) handle _ => NONE)

fun selInfo v = (SOME(get v)) handle _ => NONE

fun chkOut v = 
  (let val x = get v
    in kill v; SOME x
   end handle _ => NONE)


fun mkInfo (_, RECORD vs) = ListExp vs
  | mkInfo (_, SRECORD vs) = ListExp vs
  | mkInfo (v, SELECT(i, VAR x)) = 
      let fun h z = 
            (case selInfo z
              of SOME(_, ListExp vs) => 
                   let val nv = List.nth(vs, i)
                         handle _ => bug "unexpected List.Nth in SELECT"
                    in SimpVal nv
                   end
               | SOME(_, SimpVal (VAR w)) => h w
               | _ => SimpExp)
        in h x
       end

  | mkInfo (v, e as FN x) = if isCand v then FunExp x else SimpExp
  | mkInfo (_, e) = if isPure e then SimpExp else CompExp

fun lpacc (LVAR v) = 
      (case lpsv (VAR v)
        of VAR w => LVAR w
         | _ => bug "unexpected in lpacc")
  | lpacc _ = bug "unexpected path in lpacc"

and lpdc (s, EXN acc, t) = (s, EXN(lpacc acc), t)
  | lpdc x = x

and lpcon (DATAcon dc) = DATAcon(lpdc dc)
  | lpcon c = c

and lpdt {default=v, table=ws} =
  let fun h x = case (refer x)
                 of SOME(VAR nv) => nv
                  | NONE => x
   in {default=h v, table=map (fn (ts,w) => (ts,h w)) ws}
  end

and lpsv x = 
  (case x
    of VAR v => (case (refer v) of SOME nsv => lpsv nsv 
                                 | NONE => (x : value))
     | GENOP(dict, p, lt, ts) => GENOP(lpdt dict, p, lt, ts)
     | _ => x)

and loop le =
  (case le
    of SVAL v => SVAL(lpsv v)
     | FN(v, t, e) => FN(v, t, loop e)
     | APP(v1 as VAR x, v2) => 
         (case selInfo x
           of SOME(ref c, FunExp(z,_,b)) => 
               (if (c = 0) then loop(LET(z, SVAL v2, b))
                else bug "unexpected FunExp in APP")
(* commented out because it won't have any effect for the time being.
            | SOME(_, SimpVal (y as VAR _)) => loop(APP(y, v2)) 
*)
            | _ => APP(lpsv v1, lpsv v2))
     | APP(v1, v2) => APP(lpsv v1, lpsv v2)
     | FIX(vs, ts, es, b) => 
         let fun g ((FN _)::r) = g r
               | g (_::r) = false
               | g [] = true
             val _ = if g es then () else bug "unexpected cases in loop-FIX"
             val _ = app (fn x => chkIn(x, SimpExp)) vs
             val nb = loop b
             val ws = map chkOut vs

             fun h ((SOME(ref 0, _))::r) = h r
               | h (_::r) = false
               | h [] = true
          in if h ws then nb 
             else FIX(vs, ts, map loop es, nb)
         end
     | LET(v, LET(u, e1, e2), e3) => 
         loop(LET(u, e1, LET(v, e2, e3)))
     | LET(v, FIX(vs, ts, es, b), e) =>
         loop(FIX(vs, ts, es, LET(v, b, e)))
     | LET(v, SVAL sv, e2) => 
         (chkIn(v, SimpVal sv); loop e2)
     | LET(v, e1, e2 as SVAL (VAR x)) =>
         if (v = x) then loop e1
         else if isPure e1 then loop e2
              else LET(v, loop e1, loop e2)
     | LET(v, e1 as FN(v1, t1, b1), e2 as APP(VAR x, sv)) =>
         if isDiff(v, sv) then
           (if (v = x) then loop(LET(v1, SVAL sv, b1)) else loop e2)
         else LET(v, loop e1, loop e2)
     | LET(v, e1, e2) => 
         let val _ = chkIn(v, mkInfo(v,e1))
             val ne2 = loop e2
             val w = chkOut v
          in case w 
              of SOME(_, CompExp) => LET(v, loop e1, ne2)
               | SOME(ref 0, _) => ne2
               | _ => (case (e1, ne2)
                        of (FN(v1,t1,b1), APP(VAR x, sv)) =>
                             if isDiff(v, sv) then
                              (if (v=x) then loop(LET(v1, SVAL sv,b1))
                               else ne2)
                             else LET(v, loop e1, ne2)
                         | (_, SVAL(VAR x)) =>
                             if isPure e1 then (if v=x then loop e1
                                                else ne2)
                             else LET(v, loop e1, ne2)
                         | _ => LET(v, loop e1, ne2))
         end
     | TFN(ks, e) => TFN(ks, loop e)
     | TAPP(v, ts) => TAPP(lpsv v, ts)
     | VECTOR(vs, t) => VECTOR(map lpsv vs, t)
     | RECORD vs => RECORD (map lpsv vs)
     | SRECORD vs => SRECORD (map lpsv vs)
     | SELECT(i, v as VAR x) => 
         (case selInfo x
           of SOME(_, ListExp vs) => 
                let val nv = List.nth(vs, i)
                      handle _ => bug "unexpected List.Nth in SELECT"
                 in SVAL(lpsv nv)
                end
            | SOME(_, SimpVal (y as VAR _)) => loop(SELECT(i, y))
            | _ => SELECT(i, lpsv v))
     | SELECT(i, v) => SELECT(i, lpsv v)
     | CON(c, ts, v) => CON(lpdc c, ts, lpsv v)
     | DECON(c, ts, v) => DECON(lpdc c, ts, lpsv v)
     | SWITCH (v, cs, ces, oe) => 
         let val nv = lpsv v
             val nces = map (fn (c, e) => (lpcon c, loop e)) ces
             val noe = case oe of NONE => NONE | SOME e => SOME (loop e)
          in SWITCH(nv, cs, nces, noe)
         end
     | ETAG(v, t) => ETAG(lpsv v, t)
     | RAISE(v, t) => RAISE(lpsv v, t)
     | HANDLE(e, v) => HANDLE(loop e, lpsv v)
     | PACK(t, ts1, ts2, v) => PACK(t, ts1, ts2, lpsv v)
     | WRAP(t, b, v) => WRAP(t, b, lpsv v)
     | UNWRAP(t, b, v) => UNWRAP(t, b, lpsv v))

val nlexp = loop lexp
in (Intmap.clear m; nlexp)
end 

end (* toplevel local *)
end (* structure LContract *)


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