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
[smlnj] / 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

revision 70, Fri Apr 3 00:06:55 1998 UTC revision 71, Fri Apr 3 01:57:57 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 141  Line 142 
142  fun dead v = (case get v of (ref 0, _) => true  fun dead v = (case get v of (ref 0, _) => true
143                            | _ => false) handle _ => false                            | _ => false) handle _ => false
144    
145    fun once v = (case get v of (ref 1, _) => true | _ => false) handle _ => false
146    
147  (** check if all variables are dead *)  (** check if all variables are dead *)
148  fun alldead [] = true  fun alldead [] = true
149    | alldead (v::r) = if dead v then alldead r else false    | alldead (v::r) = if dead v then alldead r else false
# Line 185  Line 188 
188            | _ => NONE) handle _ => NONE)            | _ => NONE) handle _ => NONE)
189    | appInfo _ = NONE    | appInfo _ = NONE
190    
191    
192    (** A very ad-hoc implementation of branch/switch eliminations *)
193    local
194    
195    fun isBoolLty lt =
196      (case LT.ltd_arrow lt
197        of (_, [at], [rt]) =>
198             (LT.lt_eqv(at, LT.ltc_unit)) andalso (LT.lt_eqv(rt, LT.ltc_bool))
199         | _ => false)
200    
201    fun isBool true (RECORD(RK_TUPLE _, [], x,
202                      CON((_,DA.CONSTANT 1,lt), [], VAR x', v, RET [VAR v']))) =
203          (x = x') andalso (v = v') andalso (isBoolLty lt)
204      | isBool false (RECORD(RK_TUPLE _, [], x,
205                      CON((_,DA.CONSTANT 0,lt), [], VAR x', v, RET [VAR v']))) =
206          (x = x') andalso (v = v') andalso (isBoolLty lt)
207      | isBool _ _ = false
208    
209    (* functions that do the branch optimizations *)
210    fun boolDcon((DATAcon((_,DA.CONSTANT 1,lt1),[],v1), e1),
211                 (DATAcon((_,DA.CONSTANT 0,lt2),[],v2), e2)) =
212          if (isBoolLty lt1) andalso (isBoolLty lt2) then
213            SOME(RECORD(FU.rk_tuple,[],v1,e1), RECORD(FU.rk_tuple,[],v2,e2))
214          else NONE
215      | boolDcon(ce1 as (DATAcon((_,DA.CONSTANT 0,_),[],_), _),
216                 ce2 as (DATAcon((_,DA.CONSTANT 1,_),[],_), _)) =
217          boolDcon (ce2, ce1)
218      | boolDcon _ = NONE
219    
220    fun ssplit (LET(vs,e1,e2)) = (fn x => LET(vs,x,e2), e1)
221      | ssplit e = (ident, e)
222    
223    in
224    
225    fun branchopt([v], e1 as (BRANCH(p, us, e11, e12)), e2) =
226          let val (hdr, se2) = ssplit e2
227           in case se2
228               of SWITCH(VAR nv, _, [ce1, ce2], NONE) =>
229                    if (once v) andalso (nv = v) andalso (isBool true e11)
230                       andalso (isBool false e12)
231                    then (case boolDcon (ce1, ce2)
232                           of SOME (e21, e22) => SOME(hdr(BRANCH(p, us, e21, e22)))
233                            | NONE => NONE)
234                    else NONE
235                | _ => NONE
236          end
237      | branchopt _ = NONE
238    
239    end (* branchopt local *)
240    
241    
242    (** the main transformation function *)
243  fun transform [] = bug "unexpected case in transform"  fun transform [] = bug "unexpected case in transform"
244    | transform (cfg as ((d, od, k)::rcfg)) = let    | transform (cfg as ((d, od, k)::rcfg)) = let
245       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 214  Line 269 
269       and lpsv x = (case x of VAR v => rename x | _ => x)       and lpsv x = (case x of VAR v => rename x | _ => x)
270    
271       and lpfd (fk, v, vts, e) =       and lpfd (fk, v, vts, e) =
272         (fk, v, map (fn (v,t) => (v,ltf t)) vts, #1(loop e))         let val nfk =
273                 case fk
274                  of FK_FUN{isrec=SOME t, known, inline, fixed} =>
275                       FK_FUN{isrec=SOME(map ltf t), known=known, inline=inline,
276                               fixed=fixed}
277                   | _ => fk
278            in (nfk, v, map (fn (v,t) => (v,ltf t)) vts, #1(loop e))
279           end
280    
281       and lplet (hdr: lexp -> lexp, pure, v: lvar, info: info, e) =       and lplet (hdr: lexp -> lexp, pure, v: lvar, info: info, e) =
282         let val _ = chkIn(v, info)         let val _ = chkIn(v, info)
# Line 254  Line 316 
316                    val (ne1, b1) = loop e1                    val (ne1, b1) = loop e1
317                    val (ne2, b2) = loop e2                    val (ne2, b2) = loop e2
318                 in if (alldead vs) andalso b1 then (ne2, b2)                 in if (alldead vs) andalso b1 then (ne2, b2)
319                    else (case ne2                    else (case branchopt(vs, ne1, ne2)
320                             of SOME xx => (xx, b1 andalso b2)
321                              | NONE =>
322                                  (case ne2
323                           of (RET us) =>                           of (RET us) =>
324                                if isEqs(vs, us) then (ne1, b1)                                if isEqs(vs, us) then (ne1, b1)
325                                else (LET(vs, ne1, ne2), b1)                                else (LET(vs, ne1, ne2), b1)
326                            | _ => (LET(vs, ne1, ne2), b1 andalso b2))                                   | _ => (LET(vs, ne1, ne2), b1 andalso b2)))
327                end                end
328    
329            | FIX(fdecs, e) =>            | FIX(fdecs, e) =>
Legend:
Removed from v.70  
changed lines
  Added in v.71
root@smlnj-gforge.cs.uchicago.edu
 ViewVC Help
Powered by ViewVC 1.0.0  
Powered By FusionForge