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 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 54  Line 55 
55            in case s            in case s
56                of NONE => ()                of NONE => ()
57                 | SOME _ => add(x, NONE)  (* depth no longer matters *)                 | SOME _ => add(x, NONE)  (* depth no longer matters *)
58    
59                   (* Actually, depth does seem to matter, in one case at least.
60                    * With  datatype equivalence turned on, we get a type error
61                    * in CodeGen/cpscompile/mkRecord.sml.  The two types that
62                    * fail to match are FIXes, and they are identical except
63                    * that one has an argument which is TV(1,0) and the other
64                    * has TV(2,0).  Previously, equivalence of two FIXes was
65                    * always assumed to be true.  Now that we are checking,
66                    * this discrepency pops up.  So there must still be a small
67                    * bug with inlining across different depths.
68                    *
69                    * I've made it so that type errors do not halt compilation,
70                    * so this type error will continue to occur when compiling
71                    * the compiler.  Hopefully Zhong can look at this code
72                    * soon.  --league, 30 March 1998
73                    *)
74  (*  (*
75                 | SOME d => if (d=nd) then add(x, NONE)                 | SOME d => if (d=nd) then add(x, NONE)
76                             else ()                             else ()
# Line 125  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 169  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 198  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 238  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.17  
changed lines
  Added in v.71

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