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 215, Wed Feb 17 14:17:40 1999 UTC revision 216, Fri Feb 26 12:55:26 1999 UTC
# Line 13  Line 13 
13  local  local
14      structure F  = FLINT      structure F  = FLINT
15      structure S  = IntSetF      structure S  = IntSetF
16        structure M  = IntmapF
17        structure O  = Option
18      structure OU = OptUtils      structure OU = OptUtils
19      structure FU = FlintUtil      structure FU = FlintUtil
20      structure LT = LtyDef      structure LT = LtyExtern
21      structure PO = PrimOp      structure PO = PrimOp
22      structure PP = PPFlint      structure PP = PPFlint
23  in  in
# Line 35  Line 37 
37  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
38  fun rmvs (s,lvs) = foldl S.rmv s lvs  fun rmvs (s,lvs) = foldl S.rmv s lvs
39    
 (*  
 fun join (f,args,fdecI as (fkI,fI,argsI,bodyI),fdecE as (fkE,fE,argsE,bodyE)) =  
     let val (nfk,_) = OU.fk_wrap(fk, NONE)  
         val argsv = map (fn (v,t) => F.VAR v) args  
         val nbody =  
             let val tmp = mklv()  
             in F.LET([tmp], F.APP(F.VAR fE, argsv),  
                      F.APP(F.VAR fI, (F.VAR tmp)::argsv))  
             end  
         val nfdec = (nfk,f,args,nbody)  
     in  
         SOME(fn e =>  
              F.FIX([fdecE],  
                    F.FIX([fdecI],  
                          F.FIX([nfdec], e))),  
              F.FIX([fdecI], F.FIX([nfdec], leI)),  
              S.add(fE, rmvs(S.union(fvI, FU.freevars bodyI),  
                             f::(map #1 args))))  
     end  
 *)  
40    
41  fun split (fdec as (fk,f,args,body)) = let  fun split (fdec as (fk,f,args,body)) = let
42      val {getLty, cleanUp} = Recover.recover (fdec, false)      val {getLty,addLty,...} = Recover.recover (fdec, false)
43    
44  (*  (* sexp: env -> lexp -> (leE, leI, fvI, leRet)
45   * - copy inlinable elements into a second lexp (expI)   * - env: IntSetF.set   current environment
46   * - make a `lexp -> lexp' wrapper expE that returns the original lexp   * - lexp: lexp         expression to split
47   *   with the argument as the last return-lexp   * - leRet: lexp        the core return expression of lexp
48   * - go through expI bottom-up eliminating dead elements and collecting   * - leE: lexp -> lexp  recursively split lexp:  leE leRet == lexp
49   *   free variables   * - leI: lexp option   inlinable part of lexp (if any)
50   * - return expE and expI along with expI's free variables   * - fvI: IntSetF.set   free variables of leI:   FU.freevars leI == fvI
51     *
52     * sexp splits the lexp into an expansive part and an inlinable part.
53     * The inlinable part is guaranteed to be side-effect free.
54     * The expansive part doesn't bother to eliminate unused copies of
55     *   elements copied to the inlinable part.
56     * If the inlinable part cannot be constructed, leI is set to F.RET[].
57     *   This implies that fvI == S.empty, which in turn prevents us from
58     *   mistakenly adding anything to leI.
59   *)   *)
60  fun sexp lexp =  fun sexp env lexp =
61      case lexp      let fun funeffect f = true          (* FIXME *)
62    
63            (* non-side effecting binds are copied to leI if exported *)
64            fun let1 (le,lewrap,lv,vs,effect) =
65                let val (leE,leI,fvI,leRet) = sexp (S.add(lv, env)) le
66                    val leE = lewrap o leE
67                in if effect orelse not (S.member fvI lv)
68                   then (leE, leI, fvI, leRet)
69                   else (leE, lewrap leI, addvs(S.rmv(lv, fvI), vs), leRet)
70                end
71    
72        in case lexp
73       (* we can completely move both RET and TAPP to the I part *)       (* we can completely move both RET and TAPP to the I part *)
74       of F.RET vs =>          of F.RECORD (rk,vs,lv,le as F.RET [F.VAR lv']) =>
75          SOME(fn e => e, lexp, addvs(S.empty, vs))             if lv' = lv
76               then (fn e => e, lexp, addvs(S.empty, vs), lexp)
77               else (fn e => e, le, S.singleton lv', le)
78             | F.RET vs =>
79               (fn e => e, lexp, addvs(S.empty, vs), lexp)
80        | F.TAPP (F.VAR tf,tycs) =>        | F.TAPP (F.VAR tf,tycs) =>
81          SOME(fn e => e, lexp, S.singleton tf)             (fn e => e, lexp, S.singleton tf, lexp)
82    
83        (* other non-binding lexps result in unsplittable functions *)           (* recursive splittable lexps *)
84        | F.APP (F.VAR f,args) => NONE           | F.FIX (fdecs,le) => sfix env (fdecs, le)
85        | (F.APP _ | F.TAPP _) => bug "strange (T)APP"           | F.TFN (tfdec,le) => stfn env (tfdec, le)
       | (F.SWITCH _ | F.RAISE _ | F.BRANCH _) => NONE  
86    
87        (* binding-lexps *)        (* binding-lexps *)
88        | (F.LET (_,_,le) | F.FIX (_,le) | F.TFN (_,le) |           | F.CON (dc,tycs,v,lv,le) =>
89           F.CON (_,_,_,_,le) | F.RECORD (_,_,_,le) | F.SELECT (_,_,_,le) |             let1(le, fn e => F.CON(dc, tycs, v, lv, e), lv, [v], false)
90           F.HANDLE (le,_) | F.PRIMOP (_,_,_,le)) =>           | F.RECORD (rk,vs,lv,le) =>
91          case sexp le             let1(le, fn e => F.RECORD(rk, vs, lv, e), lv, vs, false)
92           of NONE => NONE           | F.SELECT (v,i,lv,le) =>
93            | SOME (leE,leI,fvI) => let             let1(le, fn e => F.SELECT(v, i, lv, e), lv, [v], false)
94             | F.PRIMOP (po,vs,lv,le) =>
95               let1(le, fn e => F.PRIMOP(po, vs, lv, e), lv, vs, PO.effect(#2 po))
96    
97                  fun let1 (lewrap,lv,vs,effect) =           (* IMPROVEME: lvs should not be restricted to [lv] *)
98                      let val leE = lewrap o leE           | F.LET(lvs as [lv],body as F.TAPP (v,tycs),le) =>
99                      in if effect orelse not (S.member fvI lv)             let1(le, fn e => F.LET(lvs, body, e), lv, [v], false)
100                         then SOME(leE, leI, fvI)           | F.LET (lvs as [lv],body as F.APP (v,vs),le) =>
101                         else SOME(leE, lewrap leI,             let1(le, fn e => F.LET(lvs, body, e), lv, v::vs, true)
102                                   addvs(S.rmv(lv, fvI), vs))  
103             | F.SWITCH (v,ac,[(dc as F.DATAcon(_,_,lv),le)],NONE) =>
104               let1(le, fn e => F.SWITCH(v, ac, [(dc, e)], NONE), lv, [v], false)
105    
106             | F.LET (lvs,body,le) =>
107               let val (leE,leI,fvI,leRet) = sexp (S.union(S.make lvs, env)) le
108               in (fn e => F.LET(lvs, body, leE e), leI, fvI, leRet)
109               end
110    
111             | F.HANDLE (le,v) =>
112               let val (leE,leI,fvI,leRet) = sexp env le
113               in (fn e => F.HANDLE(leE e, v), leI, fvI, leRet)
114               end
115    
116             (* other non-binding lexps result in unsplittable functions *)
117             | F.APP (F.VAR f,args) =>
118               if funeffect f
119               then (fn e => e, F.RET[], S.empty, lexp)
120               else (fn e => e, lexp, addvs(S.singleton f, args), lexp)
121             | (F.APP _ | F.TAPP _) => bug "strange (T)APP"
122             | (F.SWITCH _ | F.RAISE _ | F.BRANCH _) =>
123               (fn e => e, F.RET[], S.empty, lexp)
124                      end                      end
125    
             in case lexp  
126                  (* Functions definitions fall into the following categories:                  (* Functions definitions fall into the following categories:
                  * - (mutually) recursive:  don't bother  
127                   * - inlinable:  if exported, copy to leI                   * - inlinable:  if exported, copy to leI
128     * - (mutually) recursive:  don't bother
129                   * - non-inlinable non-recursive:  split recursively *)                   * - non-inlinable non-recursive:  split recursively *)
130                  of F.FIX (fs,_) =>  and sfix env (fdecs,le) =
131                     let val leE = fn e => F.FIX(fs, leE e)      let val nenv = S.union(S.make(map #2 fdecs), env)
132                     in case fs          val (leE,leI,fvI,leRet) = sexp nenv le
133                         of [({inline=(F.IH_ALWAYS | F.IH_MAYBE _),...},          val nleE = fn e => F.FIX(fdecs, leE e)
134                              f,args,body)] =>      in case fdecs
135            of [({inline=(F.IH_ALWAYS | F.IH_MAYBE _),...},f,args,body)] =>
136                            if not (S.member fvI f)                            if not (S.member fvI f)
137                            then SOME(leE, leI, fvI)             then (nleE, leI, fvI, leRet)
138                            else SOME(leE, F.FIX(fs, leI),             else (nleE, F.FIX(fdecs, leI),
139                                      rmvs(S.union(fvI, FU.freevars body),                                      rmvs(S.union(fvI, FU.freevars body),
140                                           f::(map #1 args)))                        f::(map #1 args)),
141                          | [fdec as (fk as {isrec=NONE,...},f,args,_)] =>                   leRet)
142                            (case sfdec fdec           | [fdec as (fk as {cconv=F.CC_FCT,...},_,_,_)] =>
143                              of (_, NONE) => SOME(leE, leI, fvI)             sfdec env (leE,leI,fvI,leRet) fdec
144                               | (fdecE as (fkE,fE,argsE,bodyE), SOME fdecI) =>  
145                                 let val fdecI as (fkI,fI,argsI,bodyI) =           | _ => (nleE, leI, fvI, leRet)
146                                         FU.copyfdec fdecI      end
147    
148    and sfdec env (leE,leI,fvI,leRet) (fk,f,args,body) =
149        let val benv = S.union(S.make(map #1 args), env)
150            val (bodyE,bodyI,fvbI,bodyRet) = sexp benv body
151        in case bodyI
152            of F.RET[] =>
153               (fn e => F.FIX([(fk, f, args, bodyE bodyRet)], e),
154                leI, fvI, leRet)
155             | _ =>
156               let val fvbIs = S.members(S.diff(fvbI, benv))
157                   (* fdecE *)
158                   val fE = cplv f
159                   val fErets = (map F.VAR fvbIs)
160                   val bodyE = bodyE(F.RET fErets)
161                   (* val tmp = mklv()
162                   val bodyE = bodyE(F.RECORD(F.RK_STRUCT, map F.VAR fvbIs,
163                                              tmp, F.RET[F.VAR tmp])) *)
164                   val fdecE = (fk, fE, args, bodyE)
165                   val fElty = LT.ltc_fct(map #2 args, map getLty fErets)
166                   val _ = addLty(fE, fElty)
167    
168                   (* fdecI *)
169                   val fkI = {inline=F.IH_ALWAYS, cconv=F.CC_FCT,
170                              known=true, isrec=NONE}
171                   val argsI =
172                    (map (fn lv => (lv, getLty(F.VAR lv))) fvbIs) @ args
173                   (* val argI = mklv()
174                   val argsI = (argI, LT.ltc_str(map (getLty o F.VAR) fvbIs))::args
175    
176                   val (_,bodyI) = foldl (fn (lv,(n,le)) =>
177                                          (n+1, F.SELECT(F.VAR argI, n, lv, le)))
178                                         (0, bodyI) fvbIs *)
179                   val fdecI as (_,fI,_,_) = FU.copyfdec(fkI,f,argsI,bodyI)
180    
181                   (* nfdec *)
182                                     val (nfk,_) = OU.fk_wrap(fk, NONE)                                     val (nfk,_) = OU.fk_wrap(fk, NONE)
183                                     val nargs = map (fn (v,t) => (cplv v, t)) args                                     val nargs = map (fn (v,t) => (cplv v, t)) args
184                                     val argsv = map (fn (v,t) => F.VAR v) nargs                                     val argsv = map (fn (v,t) => F.VAR v) nargs
185                                     val nbody =                                     val nbody =
186                                         let val tmp = mklv()                     let val lvs = map cplv fvbIs
187                                         in F.LET([tmp], F.APP(F.VAR fE, argsv),                     in F.LET(lvs, F.APP(F.VAR fE, argsv),
188                                                  F.APP(F.VAR fI, (F.VAR tmp)::argsv))                              F.APP(F.VAR fI, (map F.VAR lvs)@argsv))
189                                         end                                         end
190                       (* let val lv = mklv()
191                       in F.LET([lv], F.APP(F.VAR fE, argsv),
192                                F.APP(F.VAR fI, (F.VAR lv)::argsv))
193                       end *)
194                                     val nfdec = (nfk,f,nargs,nbody)                                     val nfdec = (nfk,f,nargs,nbody)
195                                 in  
196                                     SOME(fn e => F.FIX([fdecE],                 (* and now, for the whole F.FIX *)
197                                                        F.FIX([fdecI],                 fun nleE e =
198                                                              F.FIX([nfdec], e))),                     F.FIX([fdecE], F.FIX([fdecI], F.FIX([nfdec], leE e)))
199    
200               in if not(S.member fvI f) then (nleE, leI, fvI, leRet)
201                  else (nleE,
202                                          F.FIX([fdecI], F.FIX([nfdec], leI)),                                          F.FIX([fdecI], F.FIX([nfdec], leI)),
203                                          S.add(fE, rmvs(S.union(fvI, FU.freevars bodyI),                      S.add(fE, S.union(S.rmv(f, fvI), S.inter(env, fvbI))),
204                                                           f::(map #1 args))))                      leRet)
205                                 end)             end
                         | _ => SOME(leE, leI, fvI)  
206                     end                     end
207    
208                   (* TFNs are kinda like FIX except there's no recursion *)                   (* TFNs are kinda like FIX except there's no recursion *)
209                   | F.TFN (tf,_) =>  and stfn env (tfdec as (tf,args,body),le) =
210                     (* FIXME *)      let val nenv = S.add(tf, env)
211                     SOME(fn e => F.TFN(tf, leE e), leI, fvI)          val (leE,leI,fvI,leRet) = sexp nenv le
212            val (bodyE,bodyI,fvbI,bodyRet) = sexp nenv body
213                   (* non-side effecting binds are copied to leI if exported *)      in case (bodyI, S.members(S.diff(fvbI, env)))
214                   | F.CON (dc,tycs,v,lv,_) =>          of ((F.RET _ | F.RECORD(_,_,_,F.RET _)),_) =>
215                     let1(fn e => F.CON(dc, tycs, v, lv, e), lv, [v], false)             (* split failed *)
216                   | F.RECORD (rk,vs,lv,_) =>             (fn e => F.TFN((tf, args, bodyE bodyRet), leE e), leI, fvI, leRet)
217                     let1(fn e => F.RECORD(rk, vs, lv, e), lv, vs, false)           | (_,[]) =>
218                   | F.SELECT (v,i,lv,_) =>             (* everything was split out *)
219                     let1(fn e => F.SELECT(v, i, lv, e), lv, [v], false)             let val ntfdec = (tf, args, bodyE bodyRet)
220                   | F.PRIMOP (po,vs,lv,_) =>             in (fn e => F.TFN(ntfdec, leE e),
221                     let1(fn e => F.PRIMOP(po,vs,lv,e), lv, vs, PO.effect(#2 po))                 F.TFN(ntfdec, leI),
222                   S.rmv(tf, S.union(fvI, fvbI)),
223                   (* IMPROVEME: lvs should not be restricted to [lv] *)                 leRet)
224                   | F.LET (lvs as [lv],body as F.TAPP (v,tycs),_) =>             end
225                     let1(fn e => F.LET(lvs, body, e), lv, [v], false)           | (_,fvbIs) =>
226                   | F.LET (lvs as [lv],body as F.APP (v,vs),_) =>             let (* tfdecE *)
227                     let1(fn e => F.LET(lvs, body, e), lv, v::vs, true)                 val tfE = cplv tf
228                   | F.LET (lvs,body,_) =>                 val tfEvs = map F.VAR fvbIs
229                     SOME(fn e => F.LET(lvs, body, leE e), leI, fvI)                 val bodyE = bodyE(F.RET tfEvs)
230                   val tfElty = LT.lt_nvpoly(args, map getLty tfEvs)
231                   | F.HANDLE (_,v) =>                 val _ = addLty(tfE, tfElty)
232                     SOME(fn e => F.HANDLE(leE e, v), leI, fvI)  
233                   | _ => bug "second match failed ?!?!"                 (* tfdecI *)
234                   val argsI = map (fn (v,k) => (cplv v, k)) args
235                   val tmap = ListPair.map (fn (a1,a2) =>
236                                            (#1 a1, LT.tcc_nvar(#1 a2)))
237                                           (args, argsI)
238                   val bodyI = FU.copy tmap M.empty
239                                       (F.LET(fvbIs, F.TAPP(F.VAR tfE, map #2 tmap),
240                                              bodyI))
241                   (* F.TFN *)
242                   fun nleE e =
243                       F.TFN((tfE, args, bodyE), F.TFN((tf, argsI, bodyI), leE e))
244    
245               in if not(S.member fvI tf) then (nleE, leI, fvI, leRet)
246                  else (nleE,
247                        F.TFN((tf, argsI, bodyI), leI),
248                        S.add(tfE, S.union(S.rmv(tf, fvI), S.inter(env, fvbI))),
249                        leRet)
250               end
251              end              end
252    
253    (* here, we use B-decomposition, so the args should not be
254     * considered as being in scope *)
255    val (bodyE,bodyI,fvbI,bodyRet) = sexp S.empty body
256    in case (bodyI, bodyRet)
257        of (F.RET _,_) => ((fk, f, args, bodyE bodyRet), NONE)
258         | (_,F.RECORD (rk,vs,lv,F.RET[lv'])) =>
259           let val fvbIs = S.members fvbI
260    
261               (* fdecE *)
262               val bodyE = bodyE(F.RECORD(rk, vs@(map F.VAR fvbIs), lv, F.RET[lv']))
263               val fdecE as (_,fE,_,_) = (fk, cplv f, args, bodyE)
264    
265  and sfdec (fdec as ({cconv=F.CC_FUN _,...},_,_,_)) = (fdec, NONE)             (* fdecI *)
   | sfdec (fdec as (fk as {inline,cconv,known,isrec},f,args,body)) =  
     case sexp body  
      of NONE => (fdec, NONE)  
       | SOME (leE,leI,fvI) =>  
         let val fvI = S.members(rmvs(fvI, map #1 args))  
             val fE = cplv f  
             val fI = cplv f  
             val tmp = mklv()  
             val bodyE = leE(F.RECORD(F.RK_STRUCT, map F.VAR fvI,  
                                      tmp, F.RET[F.VAR tmp]))  
266              val argI = mklv()              val argI = mklv()
267               val argLtys = (map getLty vs) @ (map (getLty o F.VAR) fvbIs)
268               val argsI = [(argI, LT.ltc_str argLtys)]
269              val (_,bodyI) = foldl (fn (lv,(n,le)) =>              val (_,bodyI) = foldl (fn (lv,(n,le)) =>
270                                     (n+1, F.SELECT(F.VAR argI, n, lv, le)))                                     (n+1, F.SELECT(F.VAR argI, n, lv, le)))
271                                    (0, leI) fvI                                   (length vs, bodyI) fvbIs
272              val fkI = {inline=F.IH_ALWAYS, cconv=cconv, known=known, isrec=NONE}             val fdecI as (_,fI,_,_) = FU.copyfdec (fk, f, argsI, bodyI)
             val argsI = (argI, LT.ltc_str(map (getLty o F.VAR) fvI))::args  
         in ((fk, fE, args, bodyE), SOME(fkI, fI, argsI, bodyI))  
         end  
273    
 in case sfdec fdec  
     of (fdec,NONE) => (fdec, NONE)  
      | (fdecE as (fkE,fE,argsE,bodyE), SOME fdecI) =>  
        let val fdecI as (fkI,fI,argsI,bodyI) = FU.copyfdec fdecI  
            val (nfk,_) = OU.fk_wrap(fk, NONE)  
274             val nargs = map (fn (v,t) => (cplv v, t)) args             val nargs = map (fn (v,t) => (cplv v, t)) args
            val argsv = map (fn (v,t) => F.VAR v) nargs  
            val tmp = mklv()  
275         in         in
276               (* (fdecE, SOME fdecI) *)
277             ((fk, f, nargs,             ((fk, f, nargs,
278               F.FIX([fdecE],               F.FIX([fdecE],
279                     F.FIX([fdecI],                     F.FIX([fdecI],
280                           F.LET([tmp], F.APP(F.VAR fE, argsv),                           F.LET([argI],
281                                 F.APP(F.VAR fI, (F.VAR tmp)::argsv))))),                                 F.APP(F.VAR fE, map (F.VAR o #1) nargs),
282                                   F.APP(F.VAR fI, [F.VAR argI]))))),
283              NONE)              NONE)
284         end         end
285    
286         | _ =>
287           (PPFlint.printLexp bodyRet;
288            bug "couldn't find the returned record")
289    
290  end  end
291    
292  end  end

Legend:
Removed from v.215  
changed lines
  Added in v.216

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