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

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

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