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/lcontract.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/FLINT/opt/lcontract.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

sml/branches/SMLNJ/src/compiler/FLINT/opt/lcontract.sml revision 17, Wed Mar 11 21:00:18 1998 UTC sml/trunk/src/compiler/FLINT/opt/lcontract.sml revision 651, Thu Jun 1 18:34:03 2000 UTC
# Line 12  Line 12 
12  local structure DI = DebIndex  local structure DI = DebIndex
13        structure DA = Access        structure DA = Access
14        structure LT = LtyExtern        structure LT = LtyExtern
15          structure FU = FlintUtil
16          structure PO = PrimOp
17          structure S  = Intset
18          structure M  = Intmap
19        open FLINT        open FLINT
20  in  in
21    
22  fun bug s = ErrorMsg.impossible ("LContract: "^s)  fun bug s = ErrorMsg.impossible ("LContract: "^s)
23  val say = Control.Print.say  val say = Control_Print.say
24  val ident = fn x => x  val ident = fn x => x
25  fun all p (a::r) = p a andalso all p r | all p nil = true  fun all p (a::r) = p a andalso all p r | all p nil = true
26    
# Line 36  Line 40 
40  datatype info  datatype info
41    = SimpVal of value    = SimpVal of value
42    | ListExp of value list    | ListExp of value list
43    | FunExp of DI.depth * lvar list * lexp    | FunExp of lvar list * lexp
44    | ConExp of dcon * tyc list * value    | ConExp of dcon * tyc list * value
45    | StdExp    | StdExp
46    
# Line 62  Line 66 
66    
67        fun cand x = (get x; true) handle _ => false        fun cand x = (get x; true) handle _ => false
68    
69        fun lpfd d (FK_FUN {isrec=SOME _,...}, v, vts, e) = lple d e        fun lpfd d ({isrec=SOME _,...}, v, vts, e) = lple d e
70          | lpfd d (_, v, vts, e) = (enter(v, d); lple d e)          | lpfd d (_, v, vts, e) = (enter(v, d); lple d e)
71    
72        and lple d e =        and lple d e =
73          let fun psv (VAR x) = kill x          let fun psv (VAR x) = kill x
74                | psv _ = ()                | psv _ = ()
75    
76              and pst (v, vks, e) = lple (DI.next d) e              and pst (tfk, v, vks, e) = lple (DI.next d) e
77    
78              and pse (RET vs) = app psv vs              and pse (RET vs) = app psv vs
79                | pse (LET(vs, e1, e2)) = (pse e1; pse e2)                | pse (LET(vs, e1, e2)) = (pse e1; pse e2)
# Line 125  Line 129 
129  fun dead v = (case get v of (ref 0, _) => true  fun dead v = (case get v of (ref 0, _) => true
130                            | _ => false) handle _ => false                            | _ => false) handle _ => false
131    
132    fun once v = (case get v of (ref 1, _) => true | _ => false) handle _ => false
133    
134  (** check if all variables are dead *)  (** check if all variables are dead *)
135  fun alldead [] = true  fun alldead [] = true
136    | alldead (v::r) = if dead v then alldead r else false    | alldead (v::r) = if dead v then alldead r else false
# Line 165  Line 171 
171  (** contracting a function application *)  (** contracting a function application *)
172  fun appInfo (VAR v) =  fun appInfo (VAR v) =
173        ((case get v        ((case get v
174           of (ref 0, FunExp (d, vs, e)) => SOME (d, vs, e)           of (ref 0, FunExp (vs, e)) => SOME (vs, e)
175            | _ => NONE) handle _ => NONE)            | _ => NONE) handle _ => NONE)
176    | appInfo _ = NONE    | appInfo _ = NONE
177    
178  fun transform [] = bug "unexpected case in transform"  
179    | transform (cfg as ((d, od, k)::rcfg)) = let  (** A very ad-hoc implementation of branch/switch eliminations *)
180       fun h (f, t, (d, od, k)::r, sk) = h(f, f(t, od, d, k+sk), r, k+sk)  local
181         | h (f, t, [], _) = t  
182       fun ltf t = h(LT.lt_adj_k, t, cfg, 0)  fun isBoolLty lt =
183       fun tcf t = h(LT.tc_adj_k, t, cfg, 0)    (case LT.ltd_arrow lt
184        of (_, [at], [rt]) =>
185             (LT.lt_eqv(at, LT.ltc_unit)) andalso (LT.lt_eqv(rt, LT.ltc_bool))
186         | _ => false)
187    
188    fun isBool true (RECORD(RK_TUPLE _, [], x,
189                      CON((_,DA.CONSTANT 1,lt), [], VAR x', v, RET [VAR v']))) =
190          (x = x') andalso (v = v') andalso (isBoolLty lt)
191      | isBool false (RECORD(RK_TUPLE _, [], x,
192                      CON((_,DA.CONSTANT 0,lt), [], VAR x', v, RET [VAR v']))) =
193          (x = x') andalso (v = v') andalso (isBoolLty lt)
194      | isBool _ _ = false
195    
196    (* functions that do the branch optimizations *)
197    fun boolDcon((DATAcon((_,DA.CONSTANT 1,lt1),[],v1), e1),
198                 (DATAcon((_,DA.CONSTANT 0,lt2),[],v2), e2)) =
199          if (isBoolLty lt1) andalso (isBoolLty lt2) then
200            SOME(RECORD(FU.rk_tuple,[],v1,e1), RECORD(FU.rk_tuple,[],v2,e2))
201          else NONE
202      | boolDcon(ce1 as (DATAcon((_,DA.CONSTANT 0,_),[],_), _),
203                 ce2 as (DATAcon((_,DA.CONSTANT 1,_),[],_), _)) =
204          boolDcon (ce2, ce1)
205      | boolDcon _ = NONE
206    
207    fun ssplit (LET(vs,e1,e2)) = (fn x => LET(vs,x,e2), e1)
208      | ssplit e = (ident, e)
209    
210    in
211    
212    fun branchopt([v], e1 as (BRANCH(p, us, e11, e12)), e2) =
213          let val (hdr, se2) = ssplit e2
214           in case se2
215               of SWITCH(VAR nv, _, [ce1, ce2], NONE) =>
216                    if (once v) andalso (nv = v) andalso (isBool true e11)
217                       andalso (isBool false e12)
218                    then (case boolDcon (ce1, ce2)
219                           of SOME (e21, e22) => SOME(hdr(BRANCH(p, us, e21, e22)))
220                            | NONE => NONE)
221                    else NONE
222                | _ => NONE
223          end
224      | branchopt _ = NONE
225    
226    end (* branchopt local *)
227    
228    
229    (** the main transformation function *)
230    
231       fun lpacc (DA.LVAR v) =       fun lpacc (DA.LVAR v) =
232             (case lpsv (VAR v) of VAR w => DA.LVAR w             (case lpsv (VAR v) of VAR w => DA.LVAR w
233                                 | _ => bug "unexpected in lpacc")                                 | _ => bug "unexpected in lpacc")
234         | lpacc _ = bug "unexpected path in lpacc"         | lpacc _ = bug "unexpected path in lpacc"
235    
236       and lpdc (s, DA.EXN acc, t) = (s, DA.EXN(lpacc acc), ltf t)       and lpdc (s, DA.EXN acc, t) = (s, DA.EXN(lpacc acc), t)
237         | lpdc (s, rep, t) = (s, rep, ltf t)         | lpdc (s, rep, t) = (s, rep, t)
238    
239       and lpcon (DATAcon (dc, ts, v)) = DATAcon(lpdc dc, map tcf ts, v)       and lpcon (DATAcon (dc, ts, v)) = DATAcon(lpdc dc, ts, v)
240         | lpcon c = c         | lpcon c = c
241    
242       and lpdt (SOME {default=v, table=ws}) =       and lpdt {default=v, table=ws} =
243             let fun h x =             let fun h x =
244                   case rename (VAR x) of VAR nv => nv                   case rename (VAR x) of VAR nv => nv
245                                        | _ => bug "unexpected acse in lpdt"                                        | _ => bug "unexpected acse in lpdt"
246              in (SOME {default=h v, table=map (fn (ts,w) => (ts,h w)) ws})              in (SOME {default=h v, table=map (fn (ts,w) => (ts,h w)) ws})
247             end             end
        | lpdt NONE = NONE  
248    
249       and lpsv x = (case x of VAR v => rename x | _ => x)       and lpsv x = (case x of VAR v => rename x | _ => x)
250    
251       and lpfd (fk, v, vts, e) =       and lpfd ({isrec, known, inline, cconv}, v, vts, e) =
252         (fk, v, map (fn (v,t) => (v,ltf t)) vts, #1(loop e))           (* The function body might have changed so we need to reset
253              * the inlining hint *)
254             ({isrec=isrec, known=known, inline=IH_SAFE, cconv=cconv},
255              v, vts, #1(loop e))
256    
257       and lplet (hdr: lexp -> lexp, pure, v: lvar, info: info, e) =       and lplet (hdr: lexp -> lexp, pure, v: lvar, info: info, e) =
258         let val _ = chkIn(v, info)         let val _ = chkIn(v, info)
# Line 238  Line 292 
292                    val (ne1, b1) = loop e1                    val (ne1, b1) = loop e1
293                    val (ne2, b2) = loop e2                    val (ne2, b2) = loop e2
294                 in if (alldead vs) andalso b1 then (ne2, b2)                 in if (alldead vs) andalso b1 then (ne2, b2)
295                    else (case ne2                    else (case branchopt(vs, ne1, ne2)
296                             of SOME xx => (xx, b1 andalso b2)
297                              | NONE =>
298                                  (case ne2
299                           of (RET us) =>                           of (RET us) =>
300                                if isEqs(vs, us) then (ne1, b1)                                if isEqs(vs, us) then (ne1, b1)
301                                else (LET(vs, ne1, ne2), b1)                                else (LET(vs, ne1, ne2), b1)
302                            | _ => (LET(vs, ne1, ne2), b1 andalso b2))                                   | _ => (LET(vs, ne1, ne2), b1 andalso b2)))
303                end                end
304    
305            | FIX(fdecs, e) =>            | FIX(fdecs, e) =>
306                let fun g (FK_FUN {isrec=SOME _, ...} :fkind, v, _, _) =                let fun g ({isrec=SOME _, ...} :fkind, v, _, _) =
307                           chkIn(v, StdExp)                           chkIn(v, StdExp)
308                      | g ((_, v, vts, xe) : fundec) =                      | g ((_, v, vts, xe) : fundec) =
309                           chkIn(v, if isCand v then FunExp(od, map #1 vts, xe)                           chkIn(v, if isCand v then FunExp(map #1 vts, xe)
310                                    else StdExp)                                    else StdExp)
311                    val _ = app g fdecs                    val _ = app g fdecs
312                    val (ne, b) = loop e                    val (ne, b) = loop e
# Line 258  Line 315 
315                end                end
316            | APP(u, us) =>            | APP(u, us) =>
317                (case appInfo u                (case appInfo u
318                  of SOME(od', vs, e) =>                  of SOME(vs, e) =>
319                       let val ne = LET(vs, RET us, e)                       let val ne = LET(vs, RET us, e)
320                        in transform ((od, od', 0)::cfg) ne                        in loop ne
321                       end                       end
322                   | _ => (APP(lpsv u, map lpsv us), false))                   | _ => (APP(lpsv u, map lpsv us), false))
323    
324            | TFN(tfdec as (v, tvks, xe), e) =>            | TFN(tfdec as (tfk, v, tvks, xe), e) =>
325                lplet ((fn z => TFN((v, tvks,                lplet ((fn z => TFN((tfk, v, tvks,
326                                #1(transform ((DI.next d, DI.next od,                                #1(loop xe)), z)),
                                             k+1)::rcfg) xe)), z)),  
327                       true, v, StdExp, e)                       true, v, StdExp, e)
328            | TAPP(u, ts) => (TAPP(lpsv u, map tcf ts), true)            | TAPP(u, ts) => (TAPP(lpsv u, ts), true)
329    
330            | CON(c, ts, u, v, e) =>   (* this could be made more finegrain *)            | CON(c, ts, u, v, e) =>   (* this could be made more finegrain *)
331                lplet ((fn z => CON(lpdc c, map tcf ts, lpsv u, v, z)),                lplet ((fn z => CON(lpdc c, ts, lpsv u, v, z)),
332                       true, v, ConExp(c,ts,u), e)                       true, v, ConExp(c,ts,u), e)
333            | SWITCH (v, cs, ces, oe) =>            | SWITCH (v, cs, ces, oe) =>
334                (case swiInfo(v, ces, oe)                (case swiInfo(v, ces, oe)
# Line 302  Line 358 
358                   | NONE => lplet ((fn z => SELECT(lpsv u, i, v, z)),                   | NONE => lplet ((fn z => SELECT(lpsv u, i, v, z)),
359                                    true, v, StdExp, e))                                    true, v, StdExp, e))
360    
361            | RAISE(v, ts) => (RAISE(lpsv v, map ltf ts), false)            | RAISE(v, ts) => (RAISE(lpsv v, ts), false)
362            | HANDLE(e, v) =>            | HANDLE(e, v) =>
363                let val (ne, b) = loop e                let val (ne, b) = loop e
364                 in if b then (ne, true)                 in if b then (ne, true)
# Line 312  Line 368 
368            | BRANCH(px as (d, p, lt, ts), vs, e1, e2) =>            | BRANCH(px as (d, p, lt, ts), vs, e1, e2) =>
369                let val (ne1, b1) = loop e1                let val (ne1, b1) = loop e1
370                    val (ne2, b2) = loop e2                    val (ne2, b2) = loop e2
371                 in (BRANCH(case (d,ts) of (NONE, []) => px                 in (BRANCH(case d of NONE => px
372                                         | _ => (lpdt d, p, lt, map tcf ts),                                    | SOME d => (lpdt d, p, lt, ts),
373                            map lpsv vs, ne1, ne2), false)                            map lpsv vs, ne1, ne2), false)
374                end                end
375            | PRIMOP(px as (dt, p, lt, ts), vs, v, e) =>            | PRIMOP(px as (dt, p, lt, ts), vs, v, e) =>
376                lplet ((fn z => PRIMOP((case (dt, ts)                lplet ((fn z => PRIMOP((case dt
377                                         of (NONE, []) => px                                         of NONE => px
378                                          | _ => (lpdt dt, p, lt, map tcf ts)),                                          | SOME d => (lpdt d, p, lt, ts)),
379                                       map lpsv vs, v, z)),                                       map lpsv vs, v, z)),
380                       false (* isPure p *), v, StdExp, e))                       false (* PO.purePrimop p *), v, StdExp, e))
   
      in loop  
     end (* function transform *)  
381    
382  val d = DI.top  val d = DI.top
383  val (fk, f, vts, e) = fdec  val (fk, f, vts, e) = fdec
384  in (fk, f, vts, #1 (transform [(d, d, 0)] e))  in (fk, f, vts, #1 (loop e))
385     before (Intmap.clear m; cleanUp())     before (Intmap.clear m; cleanUp())
386  end (* function lcontract *)  end (* function lcontract *)
387    
# Line 337  Line 390 
390    
391  end (* toplevel local *)  end (* toplevel local *)
392  end (* structure LContract *)  end (* structure LContract *)
   

Legend:
Removed from v.17  
changed lines
  Added in v.651

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