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 733, Fri Nov 17 05:13:45 2000 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          structure M  = IntHashTable
18        open FLINT        open FLINT
19  in  in
20    
21  fun bug s = ErrorMsg.impossible ("LContract: "^s)  fun bug s = ErrorMsg.impossible ("LContract: "^s)
22  val say = Control.Print.say  val say = Control_Print.say
23  val ident = fn x => x  val ident = fn x => x
24  fun all p (a::r) = p a andalso all p r | all p nil = true  fun all p (a::r) = p a andalso all p r | all p nil = true
25    
# Line 36  Line 39 
39  datatype info  datatype info
40    = SimpVal of value    = SimpVal of value
41    | ListExp of value list    | ListExp of value list
42    | FunExp of DI.depth * lvar list * lexp    | FunExp of lvar list * lexp
43    | ConExp of dcon * tyc list * value    | ConExp of dcon * tyc list * value
44    | StdExp    | StdExp
45    
46  exception LContPass1  exception LContPass1
47  fun pass1 fdec =  fun pass1 fdec =
48    let val zz : (DI.depth option) Intmap.intmap = Intmap.new(32, LContPass1)    let val zz : (DI.depth option) M.hash_table = M.mkTable(32, LContPass1)
49        val add = Intmap.add zz        val add = M.insert zz
50        val get = Intmap.map zz        val get = M.lookup zz
51        val rmv = Intmap.rmv zz        fun rmv i = ignore (M.remove zz i) handle _ => ()
52        fun enter(x, d) = add(x, SOME d)        fun enter(x, d) = add(x, SOME d)
53        fun kill x = ((get x; rmv x) handle _ => ())        fun kill x = ((get x; rmv x) handle _ => ())
54        fun mark nd x =        fun mark nd x =
# Line 62  Line 65 
65    
66        fun cand x = (get x; true) handle _ => false        fun cand x = (get x; true) handle _ => false
67    
68        fun lpfd d (FK_FUN {isrec=SOME _,...}, v, vts, e) = lple d e        fun lpfd d ({isrec=SOME _,...}, v, vts, e) = lple d e
69          | lpfd d (_, v, vts, e) = (enter(v, d); lple d e)          | lpfd d (_, v, vts, e) = (enter(v, d); lple d e)
70    
71        and lple d e =        and lple d e =
72          let fun psv (VAR x) = kill x          let fun psv (VAR x) = kill x
73                | psv _ = ()                | psv _ = ()
74    
75              and pst (v, vks, e) = lple (DI.next d) e              and pst (tfk, v, vks, e) = lple (DI.next d) e
76    
77              and pse (RET vs) = app psv vs              and pse (RET vs) = app psv vs
78                | pse (LET(vs, e1, e2)) = (pse e1; pse e2)                | pse (LET(vs, e1, e2)) = (pse e1; pse e2)
# Line 92  Line 95 
95           in pse e           in pse e
96          end          end
97    
98     in lpfd DI.top fdec; (cand, fn () => Intmap.clear zz)     in lpfd DI.top fdec; (cand, fn () => M.clear zz)
99    end (* pass1 *)    end (* pass1 *)
100    
101  (************************************************************************  (************************************************************************
# Line 113  Line 116 
116   if init then (fn _ => false, fn () => ()) else pass1 fdec   if init then (fn _ => false, fn () => ()) else pass1 fdec
117    
118  exception LContract  exception LContract
119  val m : (int ref * info) Intmap.intmap = Intmap.new(32, LContract)  val m : (int ref * info) M.hash_table = M.mkTable(32, LContract)
120    
121  val enter = Intmap.add m  val enter = M.insert m
122  val get = Intmap.map m  val get = M.lookup m
123  val kill = Intmap.rmv m  fun kill i = ignore (M.remove m i) handle _ => ()
124    
125  fun chkIn (v, info) = enter(v, (ref 0, info))  fun chkIn (v, info) = enter(v, (ref 0, info))
126    
# Line 125  Line 128 
128  fun dead v = (case get v of (ref 0, _) => true  fun dead v = (case get v of (ref 0, _) => true
129                            | _ => false) handle _ => false                            | _ => false) handle _ => false
130    
131    fun once v = (case get v of (ref 1, _) => true | _ => false) handle _ => false
132    
133  (** check if all variables are dead *)  (** check if all variables are dead *)
134  fun alldead [] = true  fun alldead [] = true
135    | 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 170 
170  (** contracting a function application *)  (** contracting a function application *)
171  fun appInfo (VAR v) =  fun appInfo (VAR v) =
172        ((case get v        ((case get v
173           of (ref 0, FunExp (d, vs, e)) => SOME (d, vs, e)           of (ref 0, FunExp (vs, e)) => SOME (vs, e)
174            | _ => NONE) handle _ => NONE)            | _ => NONE) handle _ => NONE)
175    | appInfo _ = NONE    | appInfo _ = NONE
176    
177  fun transform [] = bug "unexpected case in transform"  
178    | transform (cfg as ((d, od, k)::rcfg)) = let  (** A very ad-hoc implementation of branch/switch eliminations *)
179       fun h (f, t, (d, od, k)::r, sk) = h(f, f(t, od, d, k+sk), r, k+sk)  local
180         | h (f, t, [], _) = t  
181       fun ltf t = h(LT.lt_adj_k, t, cfg, 0)  fun isBoolLty lt =
182       fun tcf t = h(LT.tc_adj_k, t, cfg, 0)    (case LT.ltd_arrow lt
183        of (_, [at], [rt]) =>
184             (LT.lt_eqv(at, LT.ltc_unit)) andalso (LT.lt_eqv(rt, LT.ltc_bool))
185         | _ => false)
186    
187    fun isBool true (RECORD(RK_TUPLE _, [], x,
188                      CON((_,DA.CONSTANT 1,lt), [], VAR x', v, RET [VAR v']))) =
189          (x = x') andalso (v = v') andalso (isBoolLty lt)
190      | isBool false (RECORD(RK_TUPLE _, [], x,
191                      CON((_,DA.CONSTANT 0,lt), [], VAR x', v, RET [VAR v']))) =
192          (x = x') andalso (v = v') andalso (isBoolLty lt)
193      | isBool _ _ = false
194    
195    (* functions that do the branch optimizations *)
196    fun boolDcon((DATAcon((_,DA.CONSTANT 1,lt1),[],v1), e1),
197                 (DATAcon((_,DA.CONSTANT 0,lt2),[],v2), e2)) =
198          if (isBoolLty lt1) andalso (isBoolLty lt2) then
199            SOME(RECORD(FU.rk_tuple,[],v1,e1), RECORD(FU.rk_tuple,[],v2,e2))
200          else NONE
201      | boolDcon(ce1 as (DATAcon((_,DA.CONSTANT 0,_),[],_), _),
202                 ce2 as (DATAcon((_,DA.CONSTANT 1,_),[],_), _)) =
203          boolDcon (ce2, ce1)
204      | boolDcon _ = NONE
205    
206    fun ssplit (LET(vs,e1,e2)) = (fn x => LET(vs,x,e2), e1)
207      | ssplit e = (ident, e)
208    
209    in
210    
211    fun branchopt([v], e1 as (BRANCH(p, us, e11, e12)), e2) =
212          let val (hdr, se2) = ssplit e2
213           in case se2
214               of SWITCH(VAR nv, _, [ce1, ce2], NONE) =>
215                    if (once v) andalso (nv = v) andalso (isBool true e11)
216                       andalso (isBool false e12)
217                    then (case boolDcon (ce1, ce2)
218                           of SOME (e21, e22) => SOME(hdr(BRANCH(p, us, e21, e22)))
219                            | NONE => NONE)
220                    else NONE
221                | _ => NONE
222          end
223      | branchopt _ = NONE
224    
225    end (* branchopt local *)
226    
227    
228    (** the main transformation function *)
229    
230       fun lpacc (DA.LVAR v) =       fun lpacc (DA.LVAR v) =
231             (case lpsv (VAR v) of VAR w => DA.LVAR w             (case lpsv (VAR v) of VAR w => DA.LVAR w
232                                 | _ => bug "unexpected in lpacc")                                 | _ => bug "unexpected in lpacc")
233         | lpacc _ = bug "unexpected path in lpacc"         | lpacc _ = bug "unexpected path in lpacc"
234    
235       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)
236         | lpdc (s, rep, t) = (s, rep, ltf t)         | lpdc (s, rep, t) = (s, rep, t)
237    
238       and lpcon (DATAcon (dc, ts, v)) = DATAcon(lpdc dc, map tcf ts, v)       and lpcon (DATAcon (dc, ts, v)) = DATAcon(lpdc dc, ts, v)
239         | lpcon c = c         | lpcon c = c
240    
241       and lpdt (SOME {default=v, table=ws}) =       and lpdt {default=v, table=ws} =
242             let fun h x =             let fun h x =
243                   case rename (VAR x) of VAR nv => nv                   case rename (VAR x) of VAR nv => nv
244                                        | _ => bug "unexpected acse in lpdt"                                        | _ => bug "unexpected acse in lpdt"
245              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})
246             end             end
        | lpdt NONE = NONE  
247    
248       and lpsv x = (case x of VAR v => rename x | _ => x)       and lpsv x = (case x of VAR v => rename x | _ => x)
249    
250       and lpfd (fk, v, vts, e) =       and lpfd ({isrec, known, inline, cconv}, v, vts, e) =
251         (fk, v, map (fn (v,t) => (v,ltf t)) vts, #1(loop e))           (* The function body might have changed so we need to reset
252              * the inlining hint *)
253             ({isrec=isrec, known=known, inline=IH_SAFE, cconv=cconv},
254              v, vts, #1(loop e))
255    
256       and lplet (hdr: lexp -> lexp, pure, v: lvar, info: info, e) =       and lplet (hdr: lexp -> lexp, pure, v: lvar, info: info, e) =
257         let val _ = chkIn(v, info)         let val _ = chkIn(v, info)
# Line 238  Line 291 
291                    val (ne1, b1) = loop e1                    val (ne1, b1) = loop e1
292                    val (ne2, b2) = loop e2                    val (ne2, b2) = loop e2
293                 in if (alldead vs) andalso b1 then (ne2, b2)                 in if (alldead vs) andalso b1 then (ne2, b2)
294                    else (case ne2                    else (case branchopt(vs, ne1, ne2)
295                             of SOME xx => (xx, b1 andalso b2)
296                              | NONE =>
297                                  (case ne2
298                           of (RET us) =>                           of (RET us) =>
299                                if isEqs(vs, us) then (ne1, b1)                                if isEqs(vs, us) then (ne1, b1)
300                                else (LET(vs, ne1, ne2), b1)                                else (LET(vs, ne1, ne2), b1)
301                            | _ => (LET(vs, ne1, ne2), b1 andalso b2))                                   | _ => (LET(vs, ne1, ne2), b1 andalso b2)))
302                end                end
303    
304            | FIX(fdecs, e) =>            | FIX(fdecs, e) =>
305                let fun g (FK_FUN {isrec=SOME _, ...} :fkind, v, _, _) =                let fun g ({isrec=SOME _, ...} :fkind, v, _, _) =
306                           chkIn(v, StdExp)                           chkIn(v, StdExp)
307                      | g ((_, v, vts, xe) : fundec) =                      | g ((_, v, vts, xe) : fundec) =
308                           chkIn(v, if isCand v then FunExp(od, map #1 vts, xe)                           chkIn(v, if isCand v then FunExp(map #1 vts, xe)
309                                    else StdExp)                                    else StdExp)
310                    val _ = app g fdecs                    val _ = app g fdecs
311                    val (ne, b) = loop e                    val (ne, b) = loop e
# Line 258  Line 314 
314                end                end
315            | APP(u, us) =>            | APP(u, us) =>
316                (case appInfo u                (case appInfo u
317                  of SOME(od', vs, e) =>                  of SOME(vs, e) =>
318                       let val ne = LET(vs, RET us, e)                       let val ne = LET(vs, RET us, e)
319                        in transform ((od, od', 0)::cfg) ne                        in loop ne
320                       end                       end
321                   | _ => (APP(lpsv u, map lpsv us), false))                   | _ => (APP(lpsv u, map lpsv us), false))
322    
323            | TFN(tfdec as (v, tvks, xe), e) =>            | TFN(tfdec as (tfk, v, tvks, xe), e) =>
324                lplet ((fn z => TFN((v, tvks,                lplet ((fn z => TFN((tfk, v, tvks,
325                                #1(transform ((DI.next d, DI.next od,                                #1(loop xe)), z)),
                                             k+1)::rcfg) xe)), z)),  
326                       true, v, StdExp, e)                       true, v, StdExp, e)
327            | TAPP(u, ts) => (TAPP(lpsv u, map tcf ts), true)            | TAPP(u, ts) => (TAPP(lpsv u, ts), true)
328    
329            | CON(c, ts, u, v, e) =>   (* this could be made more finegrain *)            | CON(c, ts, u, v, e) =>   (* this could be made more finegrain *)
330                lplet ((fn z => CON(lpdc c, map tcf ts, lpsv u, v, z)),                lplet ((fn z => CON(lpdc c, ts, lpsv u, v, z)),
331                       true, v, ConExp(c,ts,u), e)                       true, v, ConExp(c,ts,u), e)
332            | SWITCH (v, cs, ces, oe) =>            | SWITCH (v, cs, ces, oe) =>
333                (case swiInfo(v, ces, oe)                (case swiInfo(v, ces, oe)
# Line 302  Line 357 
357                   | NONE => lplet ((fn z => SELECT(lpsv u, i, v, z)),                   | NONE => lplet ((fn z => SELECT(lpsv u, i, v, z)),
358                                    true, v, StdExp, e))                                    true, v, StdExp, e))
359    
360            | RAISE(v, ts) => (RAISE(lpsv v, map ltf ts), false)            | RAISE(v, ts) => (RAISE(lpsv v, ts), false)
361            | HANDLE(e, v) =>            | HANDLE(e, v) =>
362                let val (ne, b) = loop e                let val (ne, b) = loop e
363                 in if b then (ne, true)                 in if b then (ne, true)
# Line 312  Line 367 
367            | BRANCH(px as (d, p, lt, ts), vs, e1, e2) =>            | BRANCH(px as (d, p, lt, ts), vs, e1, e2) =>
368                let val (ne1, b1) = loop e1                let val (ne1, b1) = loop e1
369                    val (ne2, b2) = loop e2                    val (ne2, b2) = loop e2
370                 in (BRANCH(case (d,ts) of (NONE, []) => px                 in (BRANCH(case d of NONE => px
371                                         | _ => (lpdt d, p, lt, map tcf ts),                                    | SOME d => (lpdt d, p, lt, ts),
372                            map lpsv vs, ne1, ne2), false)                            map lpsv vs, ne1, ne2), false)
373                end                end
374            | PRIMOP(px as (dt, p, lt, ts), vs, v, e) =>            | PRIMOP(px as (dt, p, lt, ts), vs, v, e) =>
375                lplet ((fn z => PRIMOP((case (dt, ts)                lplet ((fn z => PRIMOP((case dt
376                                         of (NONE, []) => px                                         of NONE => px
377                                          | _ => (lpdt dt, p, lt, map tcf ts)),                                          | SOME d => (lpdt d, p, lt, ts)),
378                                       map lpsv vs, v, z)),                                       map lpsv vs, v, z)),
379                       false (* isPure p *), v, StdExp, e))                       false (* PO.purePrimop p *), v, StdExp, e))
   
      in loop  
     end (* function transform *)  
380    
381  val d = DI.top  val d = DI.top
382  val (fk, f, vts, e) = fdec  val (fk, f, vts, e) = fdec
383  in (fk, f, vts, #1 (transform [(d, d, 0)] e))  in (fk, f, vts, #1 (loop e))
384     before (Intmap.clear m; cleanUp())     before (M.clear m; cleanUp())
385  end (* function lcontract *)  end (* function lcontract *)
386    
387  (** run the lambda contraction twice *)  (** run the lambda contraction twice *)
# Line 337  Line 389 
389    
390  end (* toplevel local *)  end (* toplevel local *)
391  end (* structure LContract *)  end (* structure LContract *)
   

Legend:
Removed from v.17  
changed lines
  Added in v.733

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