code.delx.au - gnu-emacs-elpa/blob - testcases.sml

   1 (* copyright 1999 YALE FLINT project *)
   2 (* monnier@cs.yale.edu *)
   3
   4 (let val a = 1 val b = 2
   5      val c = 3
   6  in 1
   7  end)
   8
   9 (x := 1;
  10  case x of
  11      FOO => 1
  12    | BAR => 2;
  13  case x of
  14      FOO => 1
  15    | BAR =>
  16      (case y of
  17           FAR => 2
  18         | FRA => 3);
  19  hello)
  20
  21 let datatype foobar
  22       = FooB of int
  23       | FooA of bool * int
  24
  25     val x = if foo then
  26                 1
  27             else if bar then
  28                 2
  29             else
  30                 3
  31     val y = if foo
  32             then 1
  33             else if foo
  34             then 2
  35             else 3
  36 in
  37     if a then b else c;
  38     case M.find(m,f)
  39      of SOME(fl, filt) =>
  40         F.APP(F.VAR fl, OU.filter filt vs)
  41       | NONE => le;
  42     x := x + 1;
  43     (case foo
  44       of a => f
  45      )
  46 end
  47
  48 let
  49 in a;
  50    b
  51 end
  52
  53 let
  54 in if a then
  55        b
  56    else
  57        c
  58 end
  59
  60 let
  61 in case a of
  62     (* Do I really want that ? *)
  63     F => 1
  64   | D => 2
  65 end
  66
  67 let
  68 in if a then b else
  69    c
  70 end
  71
  72 structure Foo = struct
  73 val x = 1
  74 end
  75
  76 signature FSPLIT =
  77 sig
  78     type flint = FLINT.prog
  79     val split: flint -> flint * flint option
  80 end
  81
  82 structure FSplit :> FSPLIT =
  83 struct
  84
  85 local
  86     structure F  = FLINT
  87     structure S  = IntRedBlackSet
  88     structure M  = FLINTIntMap
  89     structure O  = Option
  90     structure OU = OptUtils
  91     structure FU = FlintUtil
  92     structure LT = LtyExtern
  93     structure PO = PrimOp
  94     structure PP = PPFlint
  95     structure CTRL = FLINT_Control
  96 in
  97
  98 val say = Control_Print.say
  99 fun bug msg = ErrorMsg.impossible ("FSplit: "^msg)
 100 fun buglexp (msg,le) = (say "\n"; PP.printLexp le; say " "; bug msg)
 101 fun bugval (msg,v) = (say "\n"; PP.printSval v; say " "; bug msg)
 102 fun assert p = if p then () else bug ("assertion failed")
 103
 104 type flint = F.prog
 105 val mklv = LambdaVar.mkLvar
 106 val cplv = LambdaVar.dupLvar
 107
 108 fun S_rmv(x, s) = S.delete(s, x) handle NotFound => s
 109
 110 fun addv (s,F.VAR lv) = S.add(s, lv)
 111   | addv (s,_) = s
 112 fun addvs (s,vs) = foldl (fn (v,s) => addv(s, v)) s vs
 113 fun rmvs (s,lvs) = foldl (fn (l,s) => S_rmv(l, s)) s lvs
 114
 115 exception Unknown
 116
 117 fun split (fdec as (fk,f,args,body)) = let
 118     val {getLty,addLty,...} = Recover.recover (fdec, false)
 119
 120     val m = Intmap.new(64, Unknown)
 121     fun addpurefun f = Intmap.add m (f, false)
 122     fun funeffect f = (Intmap.map m f) handle Uknown => true
 123
 124 (* sexp: env -> lexp -> (leE, leI, fvI, leRet)
 125  * - env: IntSetF.set   current environment
 126  * - lexp: lexp         expression to split
 127  * - leRet: lexp        the core return expression of lexp
 128  * - leE: lexp -> lexp  recursively split lexp:  leE leRet == lexp
 129  * - leI: lexp option   inlinable part of lexp (if any)
 130  * - fvI: IntSetF.set   free variables of leI:   FU.freevars leI == fvI
 131  *
 132  * sexp splits the lexp into an expansive part and an inlinable part.
 133  * The inlinable part is guaranteed to be side-effect free.
 134  * The expansive part doesn't bother to eliminate unused copies of
 135  *   elements copied to the inlinable part.
 136  * If the inlinable part cannot be constructed, leI is set to F.RET[].
 137  *   This implies that fvI == S.empty, which in turn prevents us from
 138  *   mistakenly adding anything to leI.
 139  *)
 140 fun sexp env lexp =                     (* fixindent *)
 141     let
 142         (* non-side effecting binds are copied to leI if exported *)
 143         fun let1 (le,lewrap,lv,vs,effect) =
 144             let val (leE,leI,fvI,leRet) = sexp (S.add(env, lv)) le
 145                 val leE = lewrap o leE
 146             in if effect orelse not (S.member(fvI, lv))
 147                then (leE, leI, fvI, leRet)
 148                else (leE, lewrap leI, addvs(S_rmv(lv, fvI), vs), leRet)
 149             end
 150
 151     in case lexp
 152         (* we can completely move both RET and TAPP to the I part *)
 153         of F.RECORD (rk,vs,lv,le as F.RET [F.VAR lv']) =>
 154            if lv' = lv
 155            then (fn e => e, lexp, addvs(S.empty, vs), lexp)
 156            else (fn e => e, le, S.singleton lv', le)
 157          | F.RET vs =>
 158            (fn e => e, lexp, addvs(S.empty, vs), lexp)
 159          | F.TAPP (F.VAR tf,tycs) =>
 160            (fn e => e, lexp, S.singleton tf, lexp)
 161
 162          (* recursive splittable lexps *)
 163          | F.FIX (fdecs,le) => sfix env (fdecs, le)
 164          | F.TFN (tfdec,le) => stfn env (tfdec, le)
 165
 166          (* binding-lexps *)
 167          | F.CON (dc,tycs,v,lv,le) =>
 168            let1(le, fn e => F.CON(dc, tycs, v, lv, e), lv, [v], false)
 169          | F.RECORD (rk,vs,lv,le) =>
 170            let1(le, fn e => F.RECORD(rk, vs, lv, e), lv, vs, false)
 171          | F.SELECT (v,i,lv,le) =>
 172            let1(le, fn e => F.SELECT(v, i, lv, e), lv, [v], false)
 173          | F.PRIMOP (po,vs,lv,le) =>
 174            let1(le, fn e => F.PRIMOP(po, vs, lv, e), lv, vs, PO.effect(#2 po))
 175
 176          (* IMPROVEME: lvs should not be restricted to [lv] *)
 177          | F.LET(lvs as [lv],body as F.TAPP (v,tycs),le) =>
 178            let1(le, fn e => F.LET(lvs, body, e), lv, [v], false)
 179          | F.LET (lvs as [lv],body as F.APP (v as F.VAR f,vs),le) =>
 180            let1(le, fn e => F.LET(lvs, body, e), lv, v::vs, funeffect f)
 181
 182          | F.SWITCH (v,ac,[(dc as F.DATAcon(_,_,lv),le)],NONE) =>
 183            let1(le, fn e => F.SWITCH(v, ac, [(dc, e)], NONE), lv, [v], false)
 184
 185          | F.LET (lvs,body,le) =>
 186            let val (leE,leI,fvI,leRet) = sexp (S.union(S.addList(S.empty, lvs), env)) le
 187            in (fn e => F.LET(lvs, body, leE e), leI, fvI, leRet)
 188            end
 189
 190          (* useless sophistication *)
 191          | F.APP (F.VAR f,args) =>
 192            if funeffect f
 193            then (fn e => e, F.RET[], S.empty, lexp)
 194            else (fn e => e, lexp, addvs(S.singleton f, args), lexp)
 195
 196          (* other non-binding lexps result in unsplittable functions *)
 197          | (F.APP _ | F.TAPP _) => bug "strange (T)APP"
 198          | (F.SWITCH _ | F.RAISE _ | F.BRANCH _ | F.HANDLE _) =>
 199            (fn e => e, F.RET[], S.empty, lexp)
 200     end
 201
 202 (* Functions definitions fall into the following categories:
 203  * - inlinable:  if exported, copy to leI
 204  * - (mutually) recursive:  don't bother
 205  * - non-inlinable non-recursive:  split recursively *)
 206 and sfix env (fdecs,le) =
 207     let val nenv = S.union(S.addList(S.empty, map #2 fdecs), env)
 208         val (leE,leI,fvI,leRet) = sexp nenv le
 209         val nleE = fn e => F.FIX(fdecs, leE e)
 210     in case fdecs
 211         of [({inline=inl as (F.IH_ALWAYS | F.IH_MAYBE _),...},f,args,body)] =>
 212            let val min = case inl of F.IH_MAYBE(n,_) => n | _ => 0
 213            in if not(S.member(fvI, f)) orelse min > !CTRL.splitThreshold
 214               then (nleE, leI, fvI, leRet)
 215               else (nleE, F.FIX(fdecs, leI),
 216                     rmvs(S.union(fvI, FU.freevars body),
 217                          f::(map #1 args)),
 218                     leRet)
 219            end
 220          | [fdec as (fk as {cconv=F.CC_FCT,...},_,_,_)] =>
 221            sfdec env (leE,leI,fvI,leRet) fdec
 222
 223          | _ => (nleE, leI, fvI, leRet)
 224     end
 225
 226 and sfdec env (leE,leI,fvI,leRet) (fk,f,args,body) =
 227     let val benv = S.union(S.addList(S.empty, map #1 args), env)
 228         val (bodyE,bodyI,fvbI,bodyRet) = sexp benv body
 229     in case bodyI
 230         of F.RET[] =>
 231            (fn e => F.FIX([(fk, f, args, bodyE bodyRet)], e),
 232             leI, fvI, leRet)
 233          | _ =>
 234            let val fvbIs = S.listItems(S.difference(fvbI, benv))
 235                val (nfk,fkE) = OU.fk_wrap(fk, NONE)
 236
 237                (* fdecE *)
 238                val fE = cplv f
 239                val fErets = (map F.VAR fvbIs)
 240                val bodyE = bodyE(F.RET fErets)
 241                (* val tmp = mklv()
 242                   val bodyE = bodyE(F.RECORD(F.RK_STRUCT, map F.VAR fvbIs,
 243                                              tmp, F.RET[F.VAR tmp])) *)
 244                val fdecE = (fkE, fE, args, bodyE)
 245                val fElty = LT.ltc_fct(map #2 args, map getLty fErets)
 246                val _ = addLty(fE, fElty)
 247
 248                (* fdecI *)
 249                val fkI = {inline=F.IH_ALWAYS, cconv=F.CC_FCT,
 250                           known=true, isrec=NONE}
 251                val argsI =
 252                    (map (fn lv => (lv, getLty(F.VAR lv))) fvbIs) @ args
 253                (* val argI = mklv()
 254                   val argsI = (argI, LT.ltc_str(map (getLty o F.VAR) fvbIs))::args
 255
 256                   val (_,bodyI) = foldl (fn (lv,(n,le)) =>
 257                                             (n+1, F.SELECT(F.VAR argI, n, lv, le)))
 258                                         (0, bodyI) fvbIs *)
 259                val fdecI as (_,fI,_,_) = FU.copyfdec(fkI,f,argsI,bodyI)
 260                val _ = addpurefun fI
 261
 262                (* nfdec *)
 263                val nargs = map (fn (v,t) => (cplv v, t)) args
 264                val argsv = map (fn (v,t) => F.VAR v) nargs
 265                val nbody =
 266                    let val lvs = map cplv fvbIs
 267                    in F.LET(lvs, F.APP(F.VAR fE, argsv),
 268                             F.APP(F.VAR fI, (map F.VAR lvs)@argsv))
 269                    end
 270                (* let val lv = mklv()
 271                   in F.LET([lv], F.APP(F.VAR fE, argsv),
 272                            F.APP(F.VAR fI, (F.VAR lv)::argsv))
 273                   end *)
 274                val nfdec = (nfk, f, nargs, nbody)
 275
 276                (* and now, for the whole F.FIX *)
 277                fun nleE e =
 278                    F.FIX([fdecE], F.FIX([fdecI], F.FIX([nfdec], leE e)))
 279
 280            in if not(S.member(fvI, f)) then (nleE, leI, fvI, leRet)
 281               else (nleE,
 282                     F.FIX([fdecI], F.FIX([nfdec], leI)),
 283                     S.add(S.union(S_rmv(f, fvI), S.intersection(env, fvbI)), fE),
 284                     leRet)
 285            end
 286     end
 287
 288 (* TFNs are kinda like FIX except there's no recursion *)
 289 and stfn env (tfdec as (tfk,tf,args,body),le) =
 290     let val (bodyE,bodyI,fvbI,bodyRet) =
 291             if #inline tfk = F.IH_ALWAYS
 292             then (fn e => body, body, FU.freevars body, body)
 293             else sexp env body
 294         val nenv = S.add(env, tf)
 295         val (leE,leI,fvI,leRet) = sexp nenv le
 296     in case (bodyI, S.listItems(S.difference(fvbI, env)))
 297         of ((F.RET _ | F.RECORD(_,_,_,F.RET _)),_) =>
 298            (* split failed *)
 299            (fn e => F.TFN((tfk, tf, args, bodyE bodyRet), leE e),
 300             leI, fvI, leRet)
 301          | (_,[]) =>
 302            (* everything was split out *)
 303            let val ntfdec = ({inline=F.IH_ALWAYS}, tf, args, bodyE bodyRet)
 304                val nlE = fn e => F.TFN(ntfdec, leE e)
 305            in if not(S.member(fvI, tf)) then (nlE, leI, fvI, leRet)
 306               else (nlE, F.TFN(ntfdec, leI),
 307                     S_rmv(tf, S.union(fvI, fvbI)), leRet)
 308            end
 309          | (_,fvbIs) =>
 310            let (* tfdecE *)
 311                val tfE = cplv tf
 312                val tfEvs = map F.VAR fvbIs
 313                val bodyE = bodyE(F.RET tfEvs)
 314                val tfElty = LT.lt_nvpoly(args, map getLty tfEvs)
 315                val _ = addLty(tfE, tfElty)
 316
 317                (* tfdecI *)
 318                val tfkI = {inline=F.IH_ALWAYS}
 319                val argsI = map (fn (v,k) => (cplv v, k)) args
 320                val tmap = ListPair.map (fn (a1,a2) =>
 321                                         (#1 a1, LT.tcc_nvar(#1 a2)))
 322                                        (args, argsI)
 323                val bodyI = FU.copy tmap M.empty
 324                                    (F.LET(fvbIs, F.TAPP(F.VAR tfE, map #2 tmap),
 325                                           bodyI))
 326                (* F.TFN *)
 327                fun nleE e =
 328                    F.TFN((tfk, tfE, args, bodyE),
 329                          F.TFN((tfkI, tf, argsI, bodyI), leE e))
 330
 331            in if not(S.member(fvI, tf)) then (nleE, leI, fvI, leRet)
 332               else (nleE,
 333                     F.TFN((tfkI, tf, argsI, bodyI), leI),
 334                     S.add(S.union(S_rmv(tf, fvI), S.intersection(env, fvbI)), tfE),
 335                     leRet)
 336            end
 337     end
 338
 339 (* here, we use B-decomposition, so the args should not be
 340  * considered as being in scope *)
 341 val (bodyE,bodyI,fvbI,bodyRet) = sexp S.empty body
 342 in case (bodyI, bodyRet)
 343     of (F.RET _,_) => ((fk, f, args, bodyE bodyRet), NONE)
 344      | (_,F.RECORD (rk,vs,lv,F.RET[lv'])) =>
 345        let val fvbIs = S.listItems fvbI
 346
 347            (* fdecE *)
 348            val bodyE = bodyE(F.RECORD(rk, vs@(map F.VAR fvbIs), lv, F.RET[lv']))
 349            val fdecE as (_,fE,_,_) = (fk, cplv f, args, bodyE)
 350
 351            (* fdecI *)
 352            val argI = mklv()
 353            val argLtys = (map getLty vs) @ (map (getLty o F.VAR) fvbIs)
 354            val argsI = [(argI, LT.ltc_str argLtys)]
 355            val (_,bodyI) = foldl (fn (lv,(n,le)) =>
 356                                   (n+1, F.SELECT(F.VAR argI, n, lv, le)))
 357                                  (length vs, bodyI) fvbIs
 358            val fdecI as (_,fI,_,_) = FU.copyfdec (fk, f, argsI, bodyI)
 359
 360            val nargs = map (fn (v,t) => (cplv v, t)) args
 361        in
 362            (fdecE, SOME fdecI)
 363        (* ((fk, f, nargs,
 364             F.FIX([fdecE],
 365                   F.FIX([fdecI],
 366                         F.LET([argI],
 367                               F.APP(F.VAR fE, map (F.VAR o #1) nargs),
 368                               F.APP(F.VAR fI, [F.VAR argI]))))),
 369            NONE) *)
 370        end
 371
 372      | _ => (fdec, NONE)                (* sorry, can't do that *)
 373 (* (PPFlint.printLexp bodyRet; bug "couldn't find the returned record") *)
 374
 375 end
 376
 377 end
 378 end