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/branches/SMLNJ/src/compiler/FLINT/opt/lcontract.sml
[smlnj] / sml / branches / SMLNJ / src / compiler / FLINT / opt / lcontract.sml  
ViewVC logotype

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

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

revision 45, Sun Mar 22 20:11:09 1998 UTC revision 69, Fri Apr 3 00:06:55 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 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 169  Line 172 
172            | _ => NONE) handle _ => NONE)            | _ => NONE) handle _ => NONE)
173    | appInfo _ = NONE    | appInfo _ = NONE
174    
175    
176    (** A very ad-hoc implementation of branch/switch eliminations *)
177    local
178    
179    fun isBoolLty lt =
180      (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  fun transform [] = bug "unexpected case in transform"  fun transform [] = bug "unexpected case in transform"
228    | transform (cfg as ((d, od, k)::rcfg)) = let    | transform (cfg as ((d, od, k)::rcfg)) = let
229       fun h (f, t, (d, od, k)::r, sk) = h(f, f(t, od, d, k+sk), r, k+sk)       fun h (f, t, (d, od, k)::r, sk) = h(f, f(t, od, d, k+sk), r, k+sk)
# Line 198  Line 253 
253       and lpsv x = (case x of VAR v => rename x | _ => x)       and lpsv x = (case x of VAR v => rename x | _ => x)
254    
255       and lpfd (fk, v, vts, e) =       and lpfd (fk, v, vts, e) =
256         (fk, v, map (fn (v,t) => (v,ltf t)) vts, #1(loop e))         let val nfk =
257                 case fk
258                  of FK_FUN{isrec=SOME t, known, inline, fixed} =>
259                       FK_FUN{isrec=SOME(map ltf t), known=known, inline=inline,
260                               fixed=fixed}
261                   | _ => fk
262            in (nfk, v, map (fn (v,t) => (v,ltf t)) vts, #1(loop e))
263           end
264    
265       and lplet (hdr: lexp -> lexp, pure, v: lvar, info: info, e) =       and lplet (hdr: lexp -> lexp, pure, v: lvar, info: info, e) =
266         let val _ = chkIn(v, info)         let val _ = chkIn(v, info)
# Line 238  Line 300 
300                    val (ne1, b1) = loop e1                    val (ne1, b1) = loop e1
301                    val (ne2, b2) = loop e2                    val (ne2, b2) = loop e2
302                 in if (alldead vs) andalso b1 then (ne2, b2)                 in if (alldead vs) andalso b1 then (ne2, b2)
303                    else (case ne2                    else (case branchopt(vs, ne1, ne2)
304                             of SOME xx => (xx, b1 andalso b2)
305                              | NONE =>
306                                  (case ne2
307                           of (RET us) =>                           of (RET us) =>
308                                if isEqs(vs, us) then (ne1, b1)                                if isEqs(vs, us) then (ne1, b1)
309                                else (LET(vs, ne1, ne2), b1)                                else (LET(vs, ne1, ne2), b1)
310                            | _ => (LET(vs, ne1, ne2), b1 andalso b2))                                   | _ => (LET(vs, ne1, ne2), b1 andalso b2)))
311                end                end
312    
313            | FIX(fdecs, e) =>            | FIX(fdecs, e) =>
Legend:
Removed from v.45  
changed lines
  Added in v.69
root@smlnj-gforge.cs.uchicago.edu
 ViewVC Help
Powered by ViewVC 1.0.0  
Powered By FusionForge