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/abcopt.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/FLINT/opt/abcopt.sml

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

revision 666, Fri Jun 16 08:27:00 2000 UTC revision 667, Fri Jun 16 17:25:51 2000 UTC
# Line 27  Line 27 
27  val pDebug = ref false  val pDebug = ref false
28    
29  val say = Control_Print.say  val say = Control_Print.say
30    
31  fun sayABC s =  fun sayABC s =
32      (* (if !CTRL.printABC then say s      (* (if !CTRL.printABC then say s
33       *  else ()) *) ()       *  else ()) *) ()
# Line 41  Line 42 
42    
43  fun abcOpt (pgm as (progkind, progname, progargs, progbody)) = let  fun abcOpt (pgm as (progkind, progname, progargs, progbody)) = let
44    
45        val lt_len = LT.ltc_tyc (LT.tcc_arrow (LT.ffc_fixed,
46                                               [LT.tcc_void],
47                                               [LT.tcc_int]))
48    
49      fun cse lmap rmap lexp = let      fun cse lmap rmap lexp = let
50    
51          fun substVar x =          fun substVar x =
# Line 121  Line 126 
126          g lexp          g lexp
127      end      end
128    
129      val lt_len = LT.ltc_tyc (LT.tcc_arrow (LT.ffc_fixed,      fun lenOp (src, mm, body) =
                                            [LT.tcc_void],  
                                            [LT.tcc_int]))  
   
     fun lenOp (src, body) =  
130          (sayABC ("hoisting: length of "^(lvname src)^"\n");          (sayABC ("hoisting: length of "^(lvname src)^"\n");
131           F.PRIMOP((NONE, PO.LENGTH, lt_len, []),           case M.find(mm, src)
132              of NONE => bug "strange bug!"
133               | SOME lty =>
134                 F.PRIMOP((NONE, PO.LENGTH, lty, []),
135                    [F.VAR src],                    [F.VAR src],
136                    mklv(),                    mklv(),
137                    body))                    body))
138    
139      val agressiveHoist = ref true      val agressiveHoist = ref true
140        val mapUnion = M.unionWith (fn (a, b) => a)
141        val mapIntersect = M.intersectWith (fn (a, b) => a)
142        fun remove' (m, k) = let val (m', _) = M.remove(m, k) in m' end
143    
144      fun sayVars nil = ()      fun sayVars nil = ()
145        | sayVars (x::nil) = sayABC (lvname x)        | sayVars (x::nil) = sayABC (lvname x)
# Line 141  Line 148 
148           sayABC ", ";           sayABC ", ";
149           sayVars xs)           sayVars xs)
150    
151      fun hoist (F.RET x)= (S.empty, (F.RET x))      fun hoist (F.RET x)= (M.empty, (F.RET x))
152    
153        | hoist (F.LET (vars, lexp, body)) =        | hoist (F.LET (vars, lexp, body)) =
154          let          let
155              val (s1, lexp') = hoist lexp              val (m1, lexp') = hoist lexp
156              val (s2, body') = hoist body              val (m2, body') = hoist body
157              fun f x = S.member(s2, x)              fun ft x = M.inDomain(m2, x)
158              val hlist = List.filter f vars              val hlist = List.filter ft vars
159    
160              fun h nil ss b = (ss, b)              fun h nil mm b = (mm, b)
161                | h (x::xs) ss b =                | h (x::xs) mm b =
162                  h xs (S.delete (ss, x)) (lenOp(x, b))                  h xs (remove' (mm, x)) (lenOp(x, mm, b))
163    
164              val (s2', body'') = h hlist s2 body'              val (m2', body'') = h hlist m2 body'
165          in          in
166              (S.union(s1, s2'),              (mapUnion (m1, m2'), F.LET (vars, lexp', body''))
              F.LET (vars, lexp', body''))  
167          end          end
168    
169        | hoist (F.FIX (fundecs, body)) =        | hoist (F.FIX (fundecs, body)) =
# Line 168  Line 174 
174                  let                  let
175                      val varList = map #1 lvtys                      val varList = map #1 lvtys
176    
177                      val (s, b) = hoist body                      val (m, b) = hoist body
178    
179                      fun ft x = S.member (s, x)                      fun ft x = M.inDomain (m, x)
180    
181                      val toHoist = (List.filter ft varList)                      val toHoist = List.filter ft varList
182    
183                      fun h ss nil b = (ss, b)                      fun h mm nil b = (mm, b)
184                        | h ss (v::vs) b =                        | h mm (v::vs) b =
185                          h (S.delete (ss, v)) vs (lenOp(v, b))                          h (remove' (mm, v)) vs (lenOp(v, mm, b))
186    
187                      val (set, body') = h s toHoist b                      val (m', body') = h m toHoist b
188    
189                  in                  in
190                      (*                      (*
# Line 186  Line 192 
192                      sayVars (S.listItems set);                      sayVars (S.listItems set);
193                      sayABC ("]\n");                      sayABC ("]\n");
194                       *)                       *)
195                      sayABC ("List of hoisted vars in "^(lvname lv)^" (FIX): [");                      sayABC ("List of hoisted vars in "^
196                                (lvname lv)^" (FIX): [");
197                      sayVars (toHoist);                      sayVars (toHoist);
198                      sayABC ("]\n");                      sayABC ("]\n");
199                      (set, (fk, lv, lvtys, body'))                      (m', (fk, lv, lvtys, body'))
200                  end                  end
201    
202    
# Line 198  Line 205 
205              val fsets = map #1 fsbody              val fsets = map #1 fsbody
206              val fbody = map #2 fsbody              val fbody = map #2 fsbody
207    
208              val (bset, newbody) = hoist body              val (bmap, newbody) = hoist body
209    
210              val sss = foldl S.union bset fsets              val mmm = foldl mapUnion bmap fsets
211    
212          in          in
213              (sss, F.FIX (fbody, newbody))              (mmm, F.FIX (fbody, newbody))
214          end          end
215    
216        | hoist (F.APP x) = (S.empty, F.APP x)        | hoist (F.APP x) = (M.empty, F.APP x)
217    
218        | hoist (F.TFN (tfundec as (tfkind, lv, tvtks, tfnbody), body)) =        | hoist (F.TFN (tfundec as (tfkind, lv, tvtks, tfnbody), body)) =
219          let          let
220              val (stfn, btfn) = hoist tfnbody              val (mtfn, btfn) = hoist tfnbody
221              val (s, b) = hoist body              val (m, b) = hoist body
222          in          in
223              (S.union (stfn, s), F.TFN (tfundec, b))              (mapUnion (mtfn, m), F.TFN (tfundec, b))
224          end          end
225    
226        | hoist (F.TAPP (v, tl)) = (S.empty, F.TAPP (v, tl))        | hoist (F.TAPP (v, tl)) = (M.empty, F.TAPP (v, tl))
227    
228        (* if agressive, use union; otherwise, intersect! *)        (* if agressive, use union; otherwise use intersect *)
229        (* no var defined, so no hoisting *)        (* no var defined, so no hoisting *)
230        | hoist (F.SWITCH (v, consig, clexps, lexp)) =        | hoist (F.SWITCH (v, consig, clexps, lexp)) =
231          let          let
# Line 226  Line 233 
233    
234              val sblist = (map hoist lexps)              val sblist = (map hoist lexps)
235    
236              val sets = map #1 sblist              val maps = map #1 sblist
237              val bodys = map #2 sblist              val bodys = map #2 sblist
238    
239              val (defSet, defBody) =              val (defMap, defBody) =
240                  case lexp                  case lexp
241                   of SOME l =>                   of SOME l =>
242                      let                      let
243                          val (s, b) = hoist l                          val (m, b) = hoist l
244                      in                      in
245                          (SOME s, SOME b)                          (SOME m, SOME b)
246                      end                      end
247                    | NONE => (NONE, NONE)                    | NONE => (NONE, NONE)
248    
249              (* agressive may not always be benificial *)              (* agressive may not always be benificial *)
250              (* it's turned off by default *)              (* it's turned off by default *)
251              val setOper = if !agressiveHoist then S.union              val mapOper = if !agressiveHoist then mapUnion
252                            else S.intersection                            else mapIntersect
253    
254              val resSet = (foldl setOper (hd sets) (tl sets))              val resSet = (foldl mapOper (hd maps) (tl maps))
255    
256              fun helper nil nil = nil              fun helper nil nil = nil
257                | helper ((c, le)::xs) (le'::ys) =                | helper ((c, le)::xs) (le'::ys) =
# Line 254  Line 261 
261              val resClexps = helper clexps bodys              val resClexps = helper clexps bodys
262    
263          in          in
264              ((case defSet              ((case defMap
265                 of SOME s => setOper(s, resSet)                 of SOME m => mapOper(m, resSet)
266                  | NONE => resSet),                  | NONE => resSet),
267               F.SWITCH (v, consig, resClexps, defBody))               F.SWITCH (v, consig, resClexps, defBody))
268          end          end
# Line 264  Line 271 
271        (* but anyways... *)        (* but anyways... *)
272        | hoist (F.CON (d, tl, v, lv, le)) =        | hoist (F.CON (d, tl, v, lv, le)) =
273          let          let
274              val (s, b) = hoist le              val (m, b) = hoist le
275          in          in
276              if S.member (s, lv) then              if M.inDomain (m, lv) then
277                  (S.delete (s, lv),                  (remove' (m, lv),
278                   F.CON (d, tl, v, lv, lenOp(lv, b)))                   F.CON (d, tl, v, lv, lenOp(lv, m, b)))
279              else (s, F.CON (d, tl, v, lv, b))              else (m, F.CON (d, tl, v, lv, b))
280          end          end
281    
282          (* there probably isn't anything interesting here either *)
       (* there prob. isn't anything interesting here either *)  
283        (* but anyways... *)        (* but anyways... *)
284        | hoist (F.RECORD (rk, vals, lv, le)) =        | hoist (F.RECORD (rk, vals, lv, le)) =
285          let          let
286              val (s, b) = hoist le              val (m, b) = hoist le
287          in          in
288              if S.member (s, lv) then              if M.inDomain (m, lv) then
289                  (S.delete (s, lv),                  (remove' (m, lv),
290                   F.RECORD (rk, vals, lv, lenOp(lv, b)))                   F.RECORD (rk, vals, lv, lenOp(lv, m, b)))
291              else (s, F.RECORD (rk, vals, lv, b))              else (m, F.RECORD (rk, vals, lv, b))
292          end          end
293    
294        | hoist (F.SELECT (v, f, lv, le)) =        | hoist (F.SELECT (v, f, lv, le)) =
295          let          let
296              val (s, b) = hoist le              val (m, b) = hoist le
297          in          in
298              if (S.member (s, lv)) then              if (M.inDomain (m, lv)) then
299                  (S.delete(s, lv),                  (remove' (m, lv),
300                   F.SELECT (v, f, lv, lenOp(lv, b)))                   F.SELECT (v, f, lv, lenOp(lv, m, b)))
301              else (s, F.SELECT (v, f, lv, b))              else (m, F.SELECT (v, f, lv, b))
302          end          end
303    
304        | hoist (F.RAISE (v, ltys)) =        | hoist (F.RAISE (v, ltys)) =
305          (S.empty, F.RAISE (v, ltys))          (M.empty, F.RAISE (v, ltys))
306    
307        | hoist (F.HANDLE (le, v)) =        | hoist (F.HANDLE (le, v)) =
308          let          let
309              val (s, b) = hoist le              val (m, b) = hoist le
310          in          in
311              (s, F.HANDLE (b, v))              (m, F.HANDLE (b, v))
312          end          end
313    
314        (* what's used is just intersection of that of        (* what's used is just intersection of that of
# Line 310  Line 316 
316         *)         *)
317        | hoist (F.BRANCH (po, vals, le1, le2)) =        | hoist (F.BRANCH (po, vals, le1, le2)) =
318          let          let
319              val (s1, b1) = hoist le1              val (m1, b1) = hoist le1
320              val (s2, b2) = hoist le2              val (m2, b2) = hoist le2
321              val setOper =              val mapOper =
322                  if (!agressiveHoist) then S.union                  if (!agressiveHoist) then mapUnion
323                  else S.intersection                  else mapIntersect
324          in          in
325              (*              (*
326              sayABC "for this branch: [";              sayABC "for this branch: [";
327              sayVars (S.listItems (S.union (s1, s2)));              sayVars (S.listItems (S.union (s1, s2)));
328              sayABC "]\n";              sayABC "]\n";
329               *)               *)
330              (* let's be agressive here! *)              (mapOper (m1, m2), F.BRANCH (po, vals, b1, b2))
             (setOper (s1, s2),  
              F.BRANCH (po, vals, b1, b2))  
331          end          end
332    
333        (* the use site *)        (* the use site *)
334        | hoist (F.PRIMOP(p as (d, PO.LENGTH, lty, tycs),        | hoist (F.PRIMOP(p as (d, PO.LENGTH, lty, tycs),
335                          vals, dest, body)) =                          vals, dest, body)) =
336          let          let
337              val (s, b) = hoist body              val (m, b) = hoist body
338          in          in
339                sayABC "got one!\n";
340              (case vals              (case vals
341                of [F.VAR x] => (S.add(s, x), F.PRIMOP(p, vals, dest, b))                of [F.VAR x] => (M.insert(m, x, lty),
342                 | _ => (s, F.PRIMOP(p, vals, dest, b)))                                 F.PRIMOP(p, vals, dest, b))
343                   | _ => (m, F.PRIMOP(p, vals, dest, b)))
344          end          end
345    
346        (* the result of a primop is unlikely to be an        (* the result of a primop is unlikely to be an
# Line 343  Line 349 
349    
350        | hoist (F.PRIMOP (p, vals, dest, body)) =        | hoist (F.PRIMOP (p, vals, dest, body)) =
351          let          let
352              val (s, b) = hoist body              val (m, b) = hoist body
353          in          in
354              if S.member (s, dest) then              if M.inDomain (m, dest) then
355                  (S.delete (s, dest),                  (remove' (m, dest),
356                   F.PRIMOP (p, vals, dest, lenOp(dest, b)))                   F.PRIMOP (p, vals, dest, lenOp(dest, m, b)))
357              else (s, F.PRIMOP (p, vals, dest, b))              else (m, F.PRIMOP (p, vals, dest, b))
358          end          end
359    
360      fun elimSwitches cmpsVV cmpsIV lexp = let      fun elimSwitches cmpsVV cmpsIV lexp = let
# Line 526  Line 532 
532       *       *
533       *   say "\nbyebye! i'm done!\n\n")       *   say "\nbyebye! i'm done!\n\n")
534       * else (); *)       * else (); *)
535    
536      (* can eventually be removed after testing *)      (* can eventually be removed after testing *)
537      (*      (*
538      case (S.listItems s)      case (S.listItems s)

Legend:
Removed from v.666  
changed lines
  Added in v.667

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