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