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

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

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

revision 219, Tue Mar 9 01:07:30 1999 UTC revision 220, Tue Mar 9 02:15:05 1999 UTC
# Line 20  Line 20 
20      structure LT = LtyExtern      structure LT = LtyExtern
21      structure PO = PrimOp      structure PO = PrimOp
22      structure PP = PPFlint      structure PP = PPFlint
23        structure CTRL = FLINT_Control
24  in  in
25    
26  val say = Control.Print.say  val say = Control_Print.say
27  fun bug msg = ErrorMsg.impossible ("FSplit: "^msg)  fun bug msg = ErrorMsg.impossible ("FSplit: "^msg)
28  fun buglexp (msg,le) = (say "\n"; PP.printLexp le; say " "; bug msg)  fun buglexp (msg,le) = (say "\n"; PP.printLexp le; say " "; bug msg)
29  fun bugval (msg,v) = (say "\n"; PP.printSval v; say " "; bug msg)  fun bugval (msg,v) = (say "\n"; PP.printSval v; say " "; bug msg)
# Line 37  Line 38 
38  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
39  fun rmvs (s,lvs) = foldl S.rmv s lvs  fun rmvs (s,lvs) = foldl S.rmv s lvs
40    
41    exception Unknown
42    
43  fun split (fdec as (fk,f,args,body)) = let  fun split (fdec as (fk,f,args,body)) = let
44      val {getLty,addLty,...} = Recover.recover (fdec, false)      val {getLty,addLty,...} = Recover.recover (fdec, false)
45    
46        val m = Intmap.new(64, Unknown)
47        fun addpurefun f = Intmap.add m (f, false)
48        fun funeffect f = (Intmap.map m f) handle Uknown => true
49    
50  (* sexp: env -> lexp -> (leE, leI, fvI, leRet)  (* sexp: env -> lexp -> (leE, leI, fvI, leRet)
51   * - env: IntSetF.set   current environment   * - env: IntSetF.set   current environment
52   * - lexp: lexp         expression to split   * - lexp: lexp         expression to split
# Line 58  Line 64 
64   *   mistakenly adding anything to leI.   *   mistakenly adding anything to leI.
65   *)   *)
66  fun sexp env lexp =  fun sexp env lexp =
67      let fun funeffect f = true          (* FIXME *)      let
   
68          (* non-side effecting binds are copied to leI if exported *)          (* non-side effecting binds are copied to leI if exported *)
69          fun let1 (le,lewrap,lv,vs,effect) =          fun let1 (le,lewrap,lv,vs,effect) =
70              let val (leE,leI,fvI,leRet) = sexp (S.add(lv, env)) le              let val (leE,leI,fvI,leRet) = sexp (S.add(lv, env)) le
# Line 97  Line 102 
102           (* IMPROVEME: lvs should not be restricted to [lv] *)           (* IMPROVEME: lvs should not be restricted to [lv] *)
103           | F.LET(lvs as [lv],body as F.TAPP (v,tycs),le) =>           | F.LET(lvs as [lv],body as F.TAPP (v,tycs),le) =>
104             let1(le, fn e => F.LET(lvs, body, e), lv, [v], false)             let1(le, fn e => F.LET(lvs, body, e), lv, [v], false)
105           | F.LET (lvs as [lv],body as F.APP (v,vs),le) =>           | F.LET (lvs as [lv],body as F.APP (v as F.VAR f,vs),le) =>
106             let1(le, fn e => F.LET(lvs, body, e), lv, v::vs, true)             let1(le, fn e => F.LET(lvs, body, e), lv, v::vs, funeffect f)
107    
108           | F.SWITCH (v,ac,[(dc as F.DATAcon(_,_,lv),le)],NONE) =>           | F.SWITCH (v,ac,[(dc as F.DATAcon(_,_,lv),le)],NONE) =>
109             let1(le, fn e => F.SWITCH(v, ac, [(dc, e)], NONE), lv, [v], false)             let1(le, fn e => F.SWITCH(v, ac, [(dc, e)], NONE), lv, [v], false)
# Line 108  Line 113 
113             in (fn e => F.LET(lvs, body, leE e), leI, fvI, leRet)             in (fn e => F.LET(lvs, body, leE e), leI, fvI, leRet)
114             end             end
115    
116           | F.HANDLE (le,v) =>           (* useless sophistication *)
            let val (leE,leI,fvI,leRet) = sexp env le  
            in (fn e => F.HANDLE(leE e, v), leI, fvI, leRet)  
            end  
   
          (* other non-binding lexps result in unsplittable functions *)  
117           | F.APP (F.VAR f,args) =>           | F.APP (F.VAR f,args) =>
118             if funeffect f             if funeffect f
119             then (fn e => e, F.RET[], S.empty, lexp)             then (fn e => e, F.RET[], S.empty, lexp)
120             else (fn e => e, lexp, addvs(S.singleton f, args), lexp)             else (fn e => e, lexp, addvs(S.singleton f, args), lexp)
121    
122             (* other non-binding lexps result in unsplittable functions *)
123           | (F.APP _ | F.TAPP _) => bug "strange (T)APP"           | (F.APP _ | F.TAPP _) => bug "strange (T)APP"
124           | (F.SWITCH _ | F.RAISE _ | F.BRANCH _) =>           | (F.SWITCH _ | F.RAISE _ | F.BRANCH _ | F.HANDLE _) =>
125             (fn e => e, F.RET[], S.empty, lexp)             (fn e => e, F.RET[], S.empty, lexp)
126      end      end
127    
# Line 132  Line 134 
134          val (leE,leI,fvI,leRet) = sexp nenv le          val (leE,leI,fvI,leRet) = sexp nenv le
135          val nleE = fn e => F.FIX(fdecs, leE e)          val nleE = fn e => F.FIX(fdecs, leE e)
136      in case fdecs      in case fdecs
137          of [({inline=(F.IH_ALWAYS | F.IH_MAYBE _),...},f,args,body)] =>          of [({inline=inl as (F.IH_ALWAYS | F.IH_MAYBE _),...},f,args,body)] =>
138             if not (S.member fvI f)             let val min = case inl of F.IH_MAYBE(n,_) => n | _ => 0
139               in if not(S.member fvI f) orelse min > !CTRL.splitThreshold
140             then (nleE, leI, fvI, leRet)             then (nleE, leI, fvI, leRet)
141             else (nleE, F.FIX(fdecs, leI),             else (nleE, F.FIX(fdecs, leI),
142                   rmvs(S.union(fvI, FU.freevars body),                   rmvs(S.union(fvI, FU.freevars body),
143                        f::(map #1 args)),                        f::(map #1 args)),
144                   leRet)                   leRet)
145               end
146           | [fdec as (fk as {cconv=F.CC_FCT,...},_,_,_)] =>           | [fdec as (fk as {cconv=F.CC_FCT,...},_,_,_)] =>
147             sfdec env (leE,leI,fvI,leRet) fdec             sfdec env (leE,leI,fvI,leRet) fdec
148    
# Line 179  Line 183 
183                                        (n+1, F.SELECT(F.VAR argI, n, lv, le)))                                        (n+1, F.SELECT(F.VAR argI, n, lv, le)))
184                                       (0, bodyI) fvbIs *)                                       (0, bodyI) fvbIs *)
185                 val fdecI as (_,fI,_,_) = FU.copyfdec(fkI,f,argsI,bodyI)                 val fdecI as (_,fI,_,_) = FU.copyfdec(fkI,f,argsI,bodyI)
186                   val _ = addpurefun fI
187    
188                 (* nfdec *)                 (* nfdec *)
189                 val nargs = map (fn (v,t) => (cplv v, t)) args                 val nargs = map (fn (v,t) => (cplv v, t)) args
# Line 207  Line 212 
212      end      end
213    
214  (* TFNs are kinda like FIX except there's no recursion *)  (* TFNs are kinda like FIX except there's no recursion *)
215  and stfn env (tfdec as (tf,args,body),le) =  and stfn env (tfdec as (tfk,tf,args,body),le) =
216      let val nenv = S.add(tf, env)      let val (bodyE,bodyI,fvbI,bodyRet) =
217                if #inline tfk = F.IH_ALWAYS
218                then (fn e => body, body, FU.freevars body, body)
219                else sexp env body
220            val nenv = S.add(tf, env)
221          val (leE,leI,fvI,leRet) = sexp nenv le          val (leE,leI,fvI,leRet) = sexp nenv le
         val (bodyE,bodyI,fvbI,bodyRet) = sexp nenv body  
222      in case (bodyI, S.members(S.diff(fvbI, env)))      in case (bodyI, S.members(S.diff(fvbI, env)))
223          of ((F.RET _ | F.RECORD(_,_,_,F.RET _)),_) =>          of ((F.RET _ | F.RECORD(_,_,_,F.RET _)),_) =>
224             (* split failed *)             (* split failed *)
225             (fn e => F.TFN((tf, args, bodyE bodyRet), leE e), leI, fvI, leRet)             (fn e => F.TFN((tfk, tf, args, bodyE bodyRet), leE e),
226                leI, fvI, leRet)
227           | (_,[]) =>           | (_,[]) =>
228             (* everything was split out *)             (* everything was split out *)
229             let val ntfdec = (tf, args, bodyE bodyRet)             let val ntfdec = ({inline=F.IH_ALWAYS}, tf, args, bodyE bodyRet)
230             in (fn e => F.TFN(ntfdec, leE e),                 val nlE = fn e => F.TFN(ntfdec, leE e)
231                 F.TFN(ntfdec, leI),             in if not(S.member fvI tf) then (nlE, leI, fvI, leRet)
232                 S.rmv(tf, S.union(fvI, fvbI)),                else (nlE, F.TFN(ntfdec, leI),
233                 leRet)                      S.rmv(tf, S.union(fvI, fvbI)), leRet)
234             end             end
235           | (_,fvbIs) =>           | (_,fvbIs) =>
236             let (* tfdecE *)             let (* tfdecE *)
# Line 232  Line 241 
241                 val _ = addLty(tfE, tfElty)                 val _ = addLty(tfE, tfElty)
242    
243                 (* tfdecI *)                 (* tfdecI *)
244                   val tfkI = {inline=F.IH_ALWAYS}
245                 val argsI = map (fn (v,k) => (cplv v, k)) args                 val argsI = map (fn (v,k) => (cplv v, k)) args
246                 val tmap = ListPair.map (fn (a1,a2) =>                 val tmap = ListPair.map (fn (a1,a2) =>
247                                          (#1 a1, LT.tcc_nvar(#1 a2)))                                          (#1 a1, LT.tcc_nvar(#1 a2)))
# Line 241  Line 251 
251                                            bodyI))                                            bodyI))
252                 (* F.TFN *)                 (* F.TFN *)
253                 fun nleE e =                 fun nleE e =
254                     F.TFN((tfE, args, bodyE), F.TFN((tf, argsI, bodyI), leE e))                     F.TFN((tfk, tfE, args, bodyE),
255                             F.TFN((tfkI, tf, argsI, bodyI), leE e))
256    
257             in if not(S.member fvI tf) then (nleE, leI, fvI, leRet)             in if not(S.member fvI tf) then (nleE, leI, fvI, leRet)
258                else (nleE,                else (nleE,
259                      F.TFN((tf, argsI, bodyI), leI),                      F.TFN((tfkI, tf, argsI, bodyI), leI),
260                      S.add(tfE, S.union(S.rmv(tf, fvI), S.inter(env, fvbI))),                      S.add(tfE, S.union(S.rmv(tf, fvI), S.inter(env, fvbI))),
261                      leRet)                      leRet)
262             end             end

Legend:
Removed from v.219  
changed lines
  Added in v.220

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