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

# Diff of /sml/trunk/src/compiler/FLINT/opt/lcontract.sml

revision 61, Mon Mar 30 19:27:36 1998 UTC revision 202, Sun Dec 13 02:29:45 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          structure PO = PrimOp
17        open FLINT        open FLINT
18  in  in
19
# 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 54  Line 56
56            in case s            in case s
57                of NONE => ()                of NONE => ()
58                 | SOME _ => add(x, NONE)  (* depth no longer matters *)                 | SOME _ => add(x, NONE)  (* depth no longer matters *)

(* Actually, depth does seem to matter, in one case at least.
* With  datatype equivalence turned on, we get a type error
* in CodeGen/cpscompile/mkRecord.sml.  The two types that
* fail to match are FIXes, and they are identical except
* that one has an argument which is TV(1,0) and the other
* has TV(2,0).  Previously, equivalence of two FIXes was
* always assumed to be true.  Now that we are checking,
* this discrepency pops up.  So there must still be a small
* bug with inlining across different depths.
*
* I've made it so that type errors do not halt compilation,
* so this type error will continue to occur when compiling
* the compiler.  Hopefully Zhong can look at this code
* soon.  --league, 30 March 1998
*)
59  (*  (*
60                 | SOME d => if (d=nd) then add(x, NONE)                 | SOME d => if (d=nd) then add(x, NONE)
61                             else ()                             else ()
# Line 78  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 =
# Line 141  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 *)
# Line 181  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 254  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 274  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 318  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 328  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 354  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.61 changed lines Added in v.202