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 197, Sun Nov 22 01:25:23 1998 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        open FLINT        open FLINT
17  in  in
18    
# Line 36  Line 37 
37  datatype info  datatype info
38    = SimpVal of value    = SimpVal of value
39    | ListExp of value list    | ListExp of value list
40    | FunExp of DI.depth * lvar list * lexp    | FunExp of lvar list * lexp
41    | ConExp of dcon * tyc list * value    | ConExp of dcon * tyc list * value
42    | StdExp    | StdExp
43    
# Line 62  Line 63 
63    
64        fun cand x = (get x; true) handle _ => false        fun cand x = (get x; true) handle _ => false
65    
66        fun lpfd d (FK_FUN {isrec=SOME _,...}, v, vts, e) = lple d e        fun lpfd d ({isrec=SOME _,...}, v, vts, e) = lple d e
67          | lpfd d (_, v, vts, e) = (enter(v, d); lple d e)          | lpfd d (_, v, vts, e) = (enter(v, d); lple d e)
68    
69        and lple d e =        and lple d e =
# Line 125  Line 126 
126  fun dead v = (case get v of (ref 0, _) => true  fun dead v = (case get v of (ref 0, _) => true
127                            | _ => false) handle _ => false                            | _ => false) handle _ => false
128    
129    fun once v = (case get v of (ref 1, _) => true | _ => false) handle _ => false
130    
131  (** check if all variables are dead *)  (** check if all variables are dead *)
132  fun alldead [] = true  fun alldead [] = true
133    | 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 168 
168  (** contracting a function application *)  (** contracting a function application *)
169  fun appInfo (VAR v) =  fun appInfo (VAR v) =
170        ((case get v        ((case get v
171           of (ref 0, FunExp (d, vs, e)) => SOME (d, vs, e)           of (ref 0, FunExp (vs, e)) => SOME (vs, e)
172            | _ => NONE) handle _ => NONE)            | _ => NONE) handle _ => NONE)
173    | appInfo _ = NONE    | appInfo _ = NONE
174    
175  fun transform [] = bug "unexpected case in transform"  
176    | transform (cfg as ((d, od, k)::rcfg)) = let  (** A very ad-hoc implementation of branch/switch eliminations *)
177       fun h (f, t, (d, od, k)::r, sk) = h(f, f(t, od, d, k+sk), r, k+sk)  local
178         | h (f, t, [], _) = t  
179       fun ltf t = h(LT.lt_adj_k, t, cfg, 0)  fun isBoolLty lt =
180       fun tcf t = h(LT.tc_adj_k, t, cfg, 0)    (case LT.ltd_arrow lt
181        of (_, [at], [rt]) =>
182             (LT.lt_eqv(at, LT.ltc_unit)) andalso (LT.lt_eqv(rt, LT.ltc_bool))
183         | _ => false)
184    
185    fun isBool true (RECORD(RK_TUPLE _, [], x,
186                      CON((_,DA.CONSTANT 1,lt), [], VAR x', v, RET [VAR v']))) =
187          (x = x') andalso (v = v') andalso (isBoolLty lt)
188      | isBool false (RECORD(RK_TUPLE _, [], x,
189                      CON((_,DA.CONSTANT 0,lt), [], VAR x', v, RET [VAR v']))) =
190          (x = x') andalso (v = v') andalso (isBoolLty lt)
191      | isBool _ _ = false
192    
193    (* functions that do the branch optimizations *)
194    fun boolDcon((DATAcon((_,DA.CONSTANT 1,lt1),[],v1), e1),
195                 (DATAcon((_,DA.CONSTANT 0,lt2),[],v2), e2)) =
196          if (isBoolLty lt1) andalso (isBoolLty lt2) then
197            SOME(RECORD(FU.rk_tuple,[],v1,e1), RECORD(FU.rk_tuple,[],v2,e2))
198          else NONE
199      | boolDcon(ce1 as (DATAcon((_,DA.CONSTANT 0,_),[],_), _),
200                 ce2 as (DATAcon((_,DA.CONSTANT 1,_),[],_), _)) =
201          boolDcon (ce2, ce1)
202      | boolDcon _ = NONE
203    
204    fun ssplit (LET(vs,e1,e2)) = (fn x => LET(vs,x,e2), e1)
205      | ssplit e = (ident, e)
206    
207    in
208    
209    fun branchopt([v], e1 as (BRANCH(p, us, e11, e12)), e2) =
210          let val (hdr, se2) = ssplit e2
211           in case se2
212               of SWITCH(VAR nv, _, [ce1, ce2], NONE) =>
213                    if (once v) andalso (nv = v) andalso (isBool true e11)
214                       andalso (isBool false e12)
215                    then (case boolDcon (ce1, ce2)
216                           of SOME (e21, e22) => SOME(hdr(BRANCH(p, us, e21, e22)))
217                            | NONE => NONE)
218                    else NONE
219                | _ => NONE
220          end
221      | branchopt _ = NONE
222    
223    end (* branchopt local *)
224    
225    
226    (** the main transformation function *)
227    
228       fun lpacc (DA.LVAR v) =       fun lpacc (DA.LVAR v) =
229             (case lpsv (VAR v) of VAR w => DA.LVAR w             (case lpsv (VAR v) of VAR w => DA.LVAR w
230                                 | _ => bug "unexpected in lpacc")                                 | _ => bug "unexpected in lpacc")
231         | lpacc _ = bug "unexpected path in lpacc"         | lpacc _ = bug "unexpected path in lpacc"
232    
233       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)
234         | lpdc (s, rep, t) = (s, rep, ltf t)         | lpdc (s, rep, t) = (s, rep, t)
235    
236       and lpcon (DATAcon (dc, ts, v)) = DATAcon(lpdc dc, map tcf ts, v)       and lpcon (DATAcon (dc, ts, v)) = DATAcon(lpdc dc, ts, v)
237         | lpcon c = c         | lpcon c = c
238    
239       and lpdt (SOME {default=v, table=ws}) =       and lpdt (SOME {default=v, table=ws}) =
# Line 197  Line 246 
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 (v, tvks, xe), e) =>
323                lplet ((fn z => TFN((v, tvks,                lplet ((fn z => TFN((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 313  Line 367 
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,ts) of (NONE, []) => px
370                                         | _ => (lpdt d, p, lt, map tcf ts),                                         | _ => (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, ts)
375                                         of (NONE, []) => px                                         of (NONE, []) => px
376                                          | _ => (lpdt dt, p, lt, map tcf ts)),                                          | _ => (lpdt dt, p, lt, ts)),
377                                       map lpsv vs, v, z)),                                       map lpsv vs, v, z)),
378                       false (* isPure p *), v, StdExp, e))                       false (* isPure p *), v, StdExp, e))
379    
      in loop  
     end (* function transform *)  
   
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.197

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