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

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

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

revision 422, Sun Sep 5 22:49:38 1999 UTC revision 423, Mon Sep 6 02:32:11 1999 UTC
# Line 25  Line 25 
25    
26  local  local
27      structure F  = FLINT      structure F  = FLINT
28      structure S = IntSetF      structure S = IntBinarySet
29      structure M = IntBinaryMap      structure M = IntBinaryMap
30      structure PP = PPFlint      structure PP = PPFlint
31      structure LT = LtyExtern      structure LT = LtyExtern
# Line 77  Line 77 
77    
78      val loop = fexp mf depth      val loop = fexp mf depth
79    
80      fun lookup (F.VAR lv) = M.find mf lv      fun lookup (F.VAR lv) = M.find(mf, lv)
81        | lookup _ = NONE        | lookup _ = NONE
82    
83      fun addv (s,F.VAR lv) = S.add(lv, s)      fun addv (s,F.VAR lv) = S.add(s, lv)
84        | addv (s,_) = s        | addv (s,_) = s
85      fun addvs (s,vs) = foldl (fn (v,s) => addv(s, v)) s vs      fun addvs (s,vs) = foldl (fn (v,s) => addv(s, v)) s vs
86      fun rmvs (s,lvs) = foldl S.rmv s lvs      fun rmvs (s,lvs) = foldl (fn (l,s) => S.delete(s, l)) s lvs
87    
88      (* Looks for free vars in the primop descriptor.      (* Looks for free vars in the primop descriptor.
89       * This is normally unnecessary since these are special vars anyway *)       * This is normally unnecessary since these are special vars anyway *)
# Line 200  Line 200 
200         in (s1 + s2, S.union(rmvs(fvl, lvs), fvb), F.LET(lvs, nbody, nle))         in (s1 + s2, S.union(rmvs(fvl, lvs), fvb), F.LET(lvs, nbody, nle))
201         end         end
202       | F.FIX (fdecs,le) =>       | F.FIX (fdecs,le) =>
203         let val funs = S.make(map #2 fdecs) (* set of funs defined by the FIX *)         let val funs = S.addList(S.empty, map #2 fdecs) (* set of funs defined by the FIX *)
204    
205             (* create call-counters for each fun and add them to fm *)             (* create call-counters for each fun and add them to fm *)
206             val (fs,mf) = foldl (fn ((fk,f,args,body),(fs,mf)) =>             val (fs,mf) = foldl (fn ((fk,f,args,body),(fs,mf)) =>
# Line 224  Line 224 
224                         val nm = M.insert(m, f, ([f'], 1, fk, fargs, fbody, cf, cs))                         val nm = M.insert(m, f, ([f'], 1, fk, fargs, fbody, cf, cs))
225                     (* now, retry ffun with the uncurried function *)                     (* now, retry ffun with the uncurried function *)
226                     in ffun((fk', f', fargs', fbody', ref 1),                     in ffun((fk', f', fargs', fbody', ref 1),
227                             (s+1, fv, S.add(f', funs), nm))                             (s+1, fv, S.add(funs, f'), nm))
228                     end                     end
229                   | _ => (* non-curried function *)                   | _ => (* non-curried function *)
230                     let val newdepth =                     let val newdepth =
# Line 238  Line 238 
238                                             (mf,[]) args                                             (mf,[]) args
239                         val (fs,ffv,body) = fexp mf newdepth body                         val (fs,ffv,body) = fexp mf newdepth body
240                         val ffv = rmvs(ffv, map #1 args) (* fun's freevars *)                         val ffv = rmvs(ffv, map #1 args) (* fun's freevars *)
241                         val ifv = S.inter(ffv, funs) (* set of rec funs ref'ed *)                         val ifv = S.intersection(ffv, funs) (* set of rec funs ref'ed *)
242                     in                     in
243                         (fs + s, S.union(ffv, fv), funs,                         (fs + s, S.union(ffv, fv), funs,
244                          M.insert(m,f,(S.members ifv, fs, fk, args, body, cf, cs)))                          M.insert(m,f,(S.listItems ifv, fs, fk, args, body, cf, cs)))
245                     end                     end
246    
247             (* process the main lexp and make it into a dummy function.             (* process the main lexp and make it into a dummy function.
# Line 253  Line 253 
253             val lename = LambdaVar.mkLvar()             val lename = LambdaVar.mkLvar()
254             val m = M.insert(M.empty,             val m = M.insert(M.empty,
255                              lename,                              lename,
256                              (S.members(S.inter(fv, funs)), 0,                              (S.listItems(S.intersection(fv, funs)), 0,
257                               {inline=F.IH_SAFE, isrec=NONE,                               {inline=F.IH_SAFE, isrec=NONE,
258                                known=true,cconv=F.CC_FCT},                                known=true,cconv=F.CC_FCT},
259                               [], le, ref 0, []))                               [], le, ref 0, []))
# Line 307  Line 307 
307             fun sccconvert (SCC.SIMPLE f,le) =             fun sccconvert (SCC.SIMPLE f,le) =
308                 F.FIX([sccSimple f (Option.valOf(M.find(m, f)))], le)                 F.FIX([sccSimple f (Option.valOf(M.find(m, f)))], le)
309               | sccconvert (SCC.RECURSIVE fs,le) =               | sccconvert (SCC.RECURSIVE fs,le) =
310                 F.FIX(map (fn f => sccRec f (Option.valOf(M.find(m, f))) fs, le)                 F.FIX(map (fn f => sccRec f (Option.valOf(M.find(m, f)))) fs, le)
311         in         in
312             case top             case top
313              of (SCC.SIMPLE f)::sccs =>              of (SCC.SIMPLE f)::sccs =>
314                 ((if (f = lename) then () else bugsay "f != lename");                 ((if (f = lename) then () else bugsay "f != lename");
315                  (s, S.diff(fv, funs), foldl sccconvert le sccs))                  (s, S.difference(fv, funs), foldl sccconvert le sccs))
316               | (SCC.RECURSIVE _)::_ => bug "recursive main body in SCC ?!?!?"               | (SCC.RECURSIVE _)::_ => bug "recursive main body in SCC ?!?!?"
317               | [] => bug "SCC going crazy"               | [] => bug "SCC going crazy"
318         end         end
# Line 331  Line 331 
331       | F.TFN ((tfk,f,args,body),le) =>       | F.TFN ((tfk,f,args,body),le) =>
332         let val (se,fve,le) = loop le         let val (se,fve,le) = loop le
333             val (sb,fvb,body) = loop body             val (sb,fvb,body) = loop body
334         in (sb + se, S.union(S.rmv(f, fve), fvb),         in (sb + se, S.union(S.delete(fve, f), fvb),
335             F.TFN((tfk, f, args, body), le))             F.TFN((tfk, f, args, body), le))
336         end         end
337       | F.TAPP (F.VAR f,args) =>       | F.TAPP (F.VAR f,args) =>
# Line 345  Line 345 
345         let fun farm (dcon as F.DATAcon(dc,_,lv),le) =         let fun farm (dcon as F.DATAcon(dc,_,lv),le) =
346                 (* the binding might end up costly, but we count it as 1 *)                 (* the binding might end up costly, but we count it as 1 *)
347                 let val (s,fv,le) = loop le                 let val (s,fv,le) = loop le
348                 in (1+s, fdcon(S.rmv(lv, fv),dc), (dcon, le))                 in (1+s, fdcon(S.delete(fv, lv),dc), (dcon, le))
349                 end                 end
350               | farm (dc,le) =               | farm (dc,le) =
351                 let val (s,fv,le) = loop le in (s, fv, (dc, le)) end                 let val (s,fv,le) = loop le in (s, fv, (dc, le)) end
# Line 366  Line 366 
366         end         end
367       | F.CON (dc,tycs,v,lv,le) =>       | F.CON (dc,tycs,v,lv,le) =>
368         let val (s,fv,le) = loop le         let val (s,fv,le) = loop le
369         in (2+s, fdcon(addv(S.rmv(lv, fv), v),dc), F.CON(dc, tycs, v, lv, le))         in (2+s, fdcon(addv(S.delete(fv, lv), v),dc), F.CON(dc, tycs, v, lv, le))
370         end         end
371       | F.RECORD (rk,vs,lv,le) =>       | F.RECORD (rk,vs,lv,le) =>
372         let val (s,fv,le) = loop le         let val (s,fv,le) = loop le
373         in ((length vs)+s, addvs(S.rmv(lv, fv), vs), F.RECORD(rk, vs, lv, le))         in ((length vs)+s, addvs(S.delete(fv, lv), vs), F.RECORD(rk, vs, lv, le))
374         end         end
375       | F.SELECT (v,i,lv,le) =>       | F.SELECT (v,i,lv,le) =>
376         let val (s,fv,le) = loop le         let val (s,fv,le) = loop le
# Line 378  Line 378 
378              of SOME(Arg(d,ac as ref(sp,ti))) =>              of SOME(Arg(d,ac as ref(sp,ti))) =>
379                 ac := (sp + 1, OU.pow2(depth - d) + ti)                 ac := (sp + 1, OU.pow2(depth - d) + ti)
380               | _ => ());               | _ => ());
381             (1+s, addv(S.rmv(lv, fv), v), F.SELECT(v,i,lv,le))             (1+s, addv(S.delete(fv, lv), v), F.SELECT(v,i,lv,le))
382         end         end
383       | F.RAISE (F.VAR v,ltys) =>       | F.RAISE (F.VAR v,ltys) =>
384         (* artificially high size estimate to discourage inlining *)         (* artificially high size estimate to discourage inlining *)
# Line 395  Line 395 
395         end         end
396       | F.PRIMOP (po,vs,lv,le) =>       | F.PRIMOP (po,vs,lv,le) =>
397         let val (s,fv,le) = loop le         let val (s,fv,le) = loop le
398         in (1+s, fpo(addvs(S.rmv(lv, fv), vs),po), F.PRIMOP(po,vs,lv,le))         in (1+s, fpo(addvs(S.delete(fv, lv), vs),po), F.PRIMOP(po,vs,lv,le))
399         end         end
400    
401       | F.APP _ => bug "bogus F.APP"       | F.APP _ => bug "bogus F.APP"
# Line 405  Line 405 
405    
406  fun fixfix ((fk,f,args,body):F.prog) =  fun fixfix ((fk,f,args,body):F.prog) =
407      let val (s,fv,nbody) = fexp M.empty 0 body      let val (s,fv,nbody) = fexp M.empty 0 body
408          val fv = S.diff(fv, S.make(map #1 args))          val fv = S.difference(fv, S.addList(S.empty, map #1 args))
409      in      in
410          (*  PPFlint.printLexp(F.RET(map F.VAR (S.members fv))); *)          (*  PPFlint.printLexp(F.RET(map F.VAR (S.members fv))); *)
411          assert(S.isEmpty(fv));          assert(S.isEmpty(fv));

Legend:
Removed from v.422  
changed lines
  Added in v.423

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