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

   1 (* Copyright 1999,2004,2007,2010-2012 Stefan Monnier <monnier@gnu.org> *)
   2
   3 (* sml-mode here treats the second `=' as an equal op because it
   4  * thinks it's seeing something like "... type t = (s.t = ...)".  FIXME!  *)
   5 functor foo (structure s : S) where type t = s.t =
   6 struct                          (* fixindent *)
   7 val bar = fn a1 a2 a3
   8              a5 a6
   9              a4 => 1
  10 val rec bar =
  11  fn a1 a2 a3
  12     a5 a6 a4 => 1
  13 val bar =
  14  fn a1 a2 a3
  15     a5 a6
  16     a4 => (1
  17           ;(
  18               w
  19             ,
  20               s
  21             ,
  22               s
  23             , s , a ,
  24               a
  25             , s , a ,
  26               a
  27           )
  28           ;(
  29               w
  30              ,s
  31              ,a
  32           )
  33           ;(
  34               w
  35           ,   s
  36           ,   a
  37           )
  38           ;(   w
  39            ,   s
  40            ,   a
  41            )
  42           ;( w
  43             ,s
  44             ,a
  45            )
  46           ;3
  47            + a
  48              * 4
  49            + let val x = 3
  50              in toto
  51              end
  52            + if a then
  53                  b
  54              else
  55                  c
  56           ;4)
  57
  58 val ber = 1;
  59 val sdfg = 1
  60 val tut = fn (x,y) z y e r =>
  61              body
  62 val tut = fn (x,y) => fn z y => fn e r =>
  63              body
  64 val tut = fn (x,y)
  65              z
  66              y e
  67              r =>
  68              body
  69 val tut =
  70     (let
  71         local
  72             val x = 1 in val x = x end
  73         val a = 1 val b = 2
  74         local val x = 1 in val x = x end
  75         local val x = 1 in val x = x end
  76             local val x = 1 in val x = x end (* fixindent *)
  77             local val x = 1 in val x = x end
  78             val c = 3
  79     in
  80         let
  81             val x = 3
  82         in
  83             x +   a * b
  84                   * c
  85         end
  86     end)
  87
  88 val x =
  89     (* From "Christopher Dutchyn" <cdutchyn@cs.ubc.ca> *)
  90     (case foo of
  91        (* This is actually not valid SML anyway.  *)
  92        | BAR => baz
  93        | BAR => baz)
  94
  95
  96 val x =
  97     (x := 1;
  98      x := 2;
  99        (* Testing obedience to user overrides: *)
 100        x := 3;                  (* fixindent *)
 101        case x of
 102            FOO => 1
 103          | BAR =>
 104            2;
 105        case x of
 106            FOO => 1
 107          | BAR =>
 108            case y of
 109                FAR => 2
 110              | FRA => 3;
 111        hello);
 112
 113 datatype foobar
 114   = FooB of int
 115   | FooA of bool * int
 116 datatype foo = FOO | BAR of baz
 117      and baz = BAZ | QUUX of foo
 118
 119 fun toto = if a
 120            then
 121                b
 122            else c
 123
 124 datatype foo = FOO
 125              | BAR of baz
 126   and baz = BAZ                 (* fixindent *)
 127           | QUUX of foo
 128   and b = g
 129
 130 datatype foo = datatype M.foo
 131 val _ = 42 val x = 5
 132
 133 signature S = S' where type foo = int
 134 val _ = 42
 135
 136 val foo = [
 137     "blah"
 138   , let val x = f 42 in g (x,x,44) end
 139 ]
 140
 141 val foo = [
 142     "blah",
 143     let val x = f 42 in g (x,x,44) end
 144 ]
 145
 146 val foo =
 147     [
 148       "blah",
 149       let val x = f 42 in g (x,x,44) end
 150     ]
 151
 152 val foo = [ "blah"
 153           , let val x = f 42 in g (x,x,44) end
 154           , foldl (fn ((p,q),s) => g (p,q,Vector.length q) ^ ":" ^ s)
 155                   "" (Beeblebrox.masterCountList mlist2)
 156           , if null mlist2 then ";" else ""
 157           ]
 158
 159 fun foo (true::rest) = 1 + 2 * foo rest
 160   | foo (false::rest)
 161     = let val _ = 1 in 2 end
 162       + 2
 163         * foo rest
 164
 165 val x = if foo then
 166             1
 167         else if bar then
 168             2
 169         else
 170             3
 171 val y = if foo
 172         then 1
 173         else if foo
 174         then 2              (* Could also be indented by a basic offset.  *)
 175         else 3
 176
 177 val yt = 4
 178
 179 val x =
 180     (if a then b else c;
 181      case M.find(m,f)
 182       of SOME(fl, filt) =>
 183          F.APP(F.VAR fl, OU.filter filt vs)
 184        | NONE
 185          => le
 186        | NONE =>
 187          le
 188        | NONE => le;
 189      x := x + 1;
 190      (case foo
 191        of a => f
 192     ))
 193
 194 val y = (
 195     let fun f1 =
 196             let fun g1 x = 2
 197                 fun g2 y = 4
 198                 local fun toto y = 1
 199                 (* val x = 5 *)
 200                 in
 201                 fun g3 z = z
 202                 end
 203             in toto
 204             end
 205     in a;( ( let
 206                val f =1
 207            in
 208                toto
 209            end
 210            )
 211          )
 212              foo("(*")
 213          * 2;
 214     end;
 215
 216     let
 217     in a
 218      ; b
 219     end;
 220
 221     let
 222     in
 223         a +
 224         b +
 225         c
 226       ; b
 227     end;
 228
 229     let
 230     in if a then
 231            b
 232        else
 233            c
 234     end;
 235
 236     let
 237     in case a of
 238            F => 1
 239          | D => 2
 240     end;
 241
 242     let
 243     in case a
 244         of F => 1
 245          | D => 2
 246     end;
 247
 248     let
 249     in if a then b else
 250        c
 251     end;
 252
 253     let
 254     in if a then b
 255        else
 256            c
 257     end)
 258 end;
 259
 260 structure Foo = struct
 261 val x = 1
 262 end
 263
 264 structure Foo = struct val x = 1
 265                 end
 266
 267 signature FSPLIT =
 268 sig
 269     type flint = FLINT.prog
 270     val split: flint -> flint * flint option
 271 end
 272
 273 structure FSplit :> FSPLIT =
 274 struct
 275
 276 local
 277     structure F  = FLINT
 278     structure S  = IntRedBlackSet
 279     structure M  = FLINTIntMap
 280     structure O  = Option
 281     structure OU = OptUtils
 282     structure FU = FlintUtil
 283     structure LT = LtyExtern
 284     structure PO = PrimOp
 285     structure PP = PPFlint
 286     structure CTRL = FLINT_Control
 287 in
 288
 289 val say = Control_Print.say
 290 fun bug msg = ErrorMsg.impossible ("FSplit: "^msg)
 291 fun buglexp (msg,le) = (say "\n"; PP.printLexp le; say " "; bug msg)
 292 fun bugval (msg,v) = (say "\n"; PP.printSval v; say " "; bug msg)
 293 fun assert p = if p then () else bug ("assertion failed")
 294
 295 type flint = F.prog
 296 val mklv = LambdaVar.mkLvar
 297 val cplv = LambdaVar.dupLvar
 298
 299 fun S_rmv(x, s) = S.delete(s, x) handle NotFound => s
 300
 301 fun addv (s,F.VAR lv) = S.add(s, lv)
 302   | addv (s,_) = s
 303 fun addvs (s,vs) = foldl (fn (v,s) => addv(s, v)) s vs
 304 fun rmvs (s,lvs) = foldl (fn (l,s) => S_rmv(l, s)) s lvs
 305
 306 exception Unknown
 307
 308 fun split (fdec as (fk,f,args,body)) = let
 309     val {getLty,addLty,...} = Recover.recover (fdec, false)
 310
 311     val m = Intmap.new(64, Unknown)
 312     fun addpurefun f = Intmap.add m (f, false)
 313     fun funeffect f = (Intmap.map m f) handle Uknown => true
 314
 315 (* sexp: env -> lexp -> (leE, leI, fvI, leRet)
 316  * - env: IntSetF.set   current environment
 317  * - lexp: lexp         expression to split
 318  * - leRet: lexp        the core return expression of lexp
 319  * - leE: lexp -> lexp  recursively split lexp:  leE leRet == lexp
 320  * - leI: lexp option   inlinable part of lexp (if any)
 321  * - fvI: IntSetF.set   free variables of leI:   FU.freevars leI == fvI
 322  *
 323  * sexp splits the lexp into an expansive part and an inlinable part.
 324  * The inlinable part is guaranteed to be side-effect free.
 325  * The expansive part doesn't bother to eliminate unused copies of
 326  *   elements copied to the inlinable part.
 327  * If the inlinable part cannot be constructed, leI is set to F.RET[].
 328  *   This implies that fvI == S.empty, which in turn prevents us from
 329  *   mistakenly adding anything to leI.
 330  *)
 331 fun sexp env lexp =                     (* fixindent *)
 332     let
 333         (* non-side effecting binds are copied to leI if exported *)
 334         fun let1 (le,lewrap,lv,vs,effect) =
 335             let  val (leE,leI,fvI,leRet) = sexp (S.add(env, lv)) le
 336                  val leE = lewrap o leE
 337             in if effect orelse not (S.member(fvI, lv))
 338                then (leE, leI, fvI, leRet)
 339                else (leE, lewrap leI, addvs(S_rmv(lv, fvI), vs), leRet)
 340             end
 341
 342     in case lexp
 343         (* we can completely move both RET and TAPP to the I part *)
 344         of F.RECORD (rk,vs,lv,le as F.RET [F.VAR lv']) =>
 345            if lv' = lv
 346            then (fn e => e, lexp, addvs(S.empty, vs), lexp)
 347            else (fn e => e, le, S.singleton lv', le)
 348          | F.RET vs =>
 349            (fn e => e, lexp, addvs(S.empty, vs), lexp)
 350          | F.TAPP (F.VAR tf,tycs) =>
 351            (fn e => e, lexp, S.singleton tf, lexp)
 352
 353          (* recursive splittable lexps *)
 354          | F.FIX (fdecs,le) => sfix env (fdecs, le)
 355          | F.TFN (tfdec,le) => stfn env (tfdec, le)
 356
 357          (* binding-lexps *)
 358          | F.CON (dc,tycs,v,lv,le) =>
 359            let1(le, fn e => F.CON(dc, tycs, v, lv, e), lv, [v], false)
 360          | F.RECORD (rk,vs,lv,le) =>
 361            let1(le, fn e => F.RECORD(rk, vs, lv, e), lv, vs, false)
 362          | F.SELECT (v,i,lv,le) =>
 363            let1(le, fn e => F.SELECT(v, i, lv, e), lv, [v], false)
 364          | F.PRIMOP (po,vs,lv,le) =>
 365            let1(le, fn e => F.PRIMOP(po, vs, lv, e), lv, vs, PO.effect(#2 po))
 366
 367          (* IMPROVEME: lvs should not be restricted to [lv] *)
 368          | F.LET(lvs as [lv],body as F.TAPP (v,tycs),le) =>
 369            let1(le, fn e => F.LET(lvs, body, e), lv, [v], false)
 370          | F.LET (lvs as [lv],body as F.APP (v as F.VAR f,vs),le) =>
 371            let1(le, fn e => F.LET(lvs, body, e), lv, v::vs, funeffect f)
 372
 373          | F.SWITCH (v,ac,[(dc as F.DATAcon(_,_,lv),le)],NONE) =>
 374            let1(le, fn e => F.SWITCH(v, ac, [(dc, e)], NONE), lv, [v], false)
 375
 376          | F.LET (lvs,body,le) =>
 377            let val (leE,leI,fvI,leRet) = sexp (S.union(S.addList(S.empty, lvs), env)) le
 378            in (fn e => F.LET(lvs, body, leE e), leI, fvI, leRet)
 379            end
 380
 381          (* useless sophistication *)
 382          | F.APP (F.VAR f,args) =>
 383            if funeffect f
 384            then (fn e => e, F.RET[], S.empty, lexp)
 385            else (fn e => e, lexp, addvs(S.singleton f, args), lexp)
 386
 387          (* other non-binding lexps result in unsplittable functions *)
 388          | (F.APP _ | F.TAPP _) => bug "strange (T)APP"
 389          | (F.SWITCH _ | F.RAISE _ | F.BRANCH _ | F.HANDLE _) =>
 390            (fn e => e, F.RET[], S.empty, lexp)
 391     end
 392
 393 (* Functions definitions fall into the following categories:
 394  * - inlinable:  if exported, copy to leI
 395  * - (mutually) recursive:  don't bother
 396  * - non-inlinable non-recursive:  split recursively *)
 397 and sfix env (fdecs,le) =
 398     let val nenv = S.union(S.addList(S.empty, map #2 fdecs), env)
 399         val (leE,leI,fvI,leRet) = sexp nenv le
 400         val nleE = fn e => F.FIX(fdecs, leE e)
 401     in case fdecs
 402         of [({inline=inl as (F.IH_ALWAYS | F.IH_MAYBE _),...},f,args,body)] =>
 403            let val min = case inl of F.IH_MAYBE(n,_) => n | _ => 0
 404            in if not(S.member(fvI, f)) orelse min > !CTRL.splitThreshold
 405               then (nleE, leI, fvI, leRet)
 406               else (nleE, F.FIX(fdecs, leI),
 407                     rmvs(S.union(fvI, FU.freevars body),
 408                          f::(map #1 args)),
 409                     leRet)
 410            end
 411          | [fdec as (fk as {cconv=F.CC_FCT,...},_,_,_)] =>
 412            sfdec env (leE,leI,fvI,leRet) fdec
 413
 414          | _ => (nleE, leI, fvI, leRet)
 415     end
 416
 417 and sfdec env (leE,leI,fvI,leRet) (fk,f,args,body) =
 418     let val benv = S.union(S.addList(S.empty, map #1 args), env)
 419         val (bodyE,bodyI,fvbI,bodyRet) = sexp benv body
 420     in case bodyI
 421         of F.RET[] =>
 422            (fn e => F.FIX([(fk, f, args, bodyE bodyRet)], e),
 423             leI, fvI, leRet)
 424          | _ =>
 425            let val fvbIs = S.listItems(S.difference(fvbI, benv))
 426                val (nfk,fkE) = OU.fk_wrap(fk, NONE)
 427
 428                (* fdecE *)
 429                val fE = cplv f
 430                val fErets = (map F.VAR fvbIs)
 431                val bodyE = bodyE(F.RET fErets)
 432                (* val tmp = mklv()
 433                 val bodyE = bodyE(F.RECORD(F.RK_STRUCT, map F.VAR fvbIs,
 434                                            tmp, F.RET[F.VAR tmp])) *)
 435                val fdecE = (fkE, fE, args, bodyE)
 436                val fElty = LT.ltc_fct(map #2 args, map getLty fErets)
 437                val _ = addLty(fE, fElty)
 438
 439                (* fdecI *)
 440                val fkI = {inline=F.IH_ALWAYS, cconv=F.CC_FCT,
 441                           known=true, isrec=NONE}
 442                val argsI =
 443                    (map (fn lv => (lv, getLty(F.VAR lv))) fvbIs) @ args
 444                val fdecI as (_,fI,_,_) = FU.copyfdec(fkI,f,argsI,bodyI)
 445                val _ = addpurefun fI
 446
 447                (* nfdec *)
 448                val nargs = map (fn (v,t) => (cplv v, t)) args
 449                val argsv = map (fn (v,t) => F.VAR v) nargs
 450                val nbody =
 451                    let val lvs = map cplv fvbIs
 452                    in F.LET(lvs, F.APP(F.VAR fE, argsv),
 453                             F.APP(F.VAR fI, (map F.VAR lvs)@argsv))
 454                    end
 455                (* let val lv = mklv()
 456                   in F.LET([lv], F.APP(F.VAR fE, argsv),
 457                            F.APP(F.VAR fI, (F.VAR lv)::argsv))
 458                   end *)
 459                val nfdec = (nfk, f, nargs, nbody)
 460
 461                (* and now, for the whole F.FIX *)
 462                fun nleE e =
 463                    F.FIX([fdecE], F.FIX([fdecI], F.FIX([nfdec], leE e)))
 464
 465            in if not(S.member(fvI, f)) then (nleE, leI, fvI, leRet)
 466               else (nleE,
 467                     F.FIX([fdecI], F.FIX([nfdec], leI)),
 468                     S.add(S.union(S_rmv(f, fvI), S.intersection(env, fvbI)), fE),
 469                     leRet)
 470            end
 471     end
 472
 473 (* TFNs are kinda like FIX except there's no recursion *)
 474 and stfn env (tfdec as (tfk,tf,args,body),le) =
 475     let val (bodyE,bodyI,fvbI,bodyRet) =
 476             if #inline tfk = F.IH_ALWAYS
 477             then (fn e => body, body, FU.freevars body, body)
 478             else sexp env body
 479         val nenv = S.add(env, tf)
 480         val (leE,leI,fvI,leRet) = sexp nenv le
 481     in case (bodyI, S.listItems(S.difference(fvbI, env)))
 482         of ((F.RET _ | F.RECORD(_,_,_,F.RET _)),_) =>
 483            (* split failed *)
 484            (fn e => F.TFN((tfk, tf, args, bodyE bodyRet), leE e),
 485             leI, fvI, leRet)
 486          | (_,[]) =>
 487            (* everything was split out *)
 488            let val ntfdec = ({inline=F.IH_ALWAYS}, tf, args, bodyE bodyRet)
 489                val nlE = fn e => F.TFN(ntfdec, leE e)
 490            in if not(S.member(fvI, tf)) then (nlE, leI, fvI, leRet)
 491               else (nlE, F.TFN(ntfdec, leI),
 492                     S_rmv(tf, S.union(fvI, fvbI)), leRet)
 493            end
 494          | (_,fvbIs) =>
 495            let (* tfdecE *)
 496                val tfE = cplv tf
 497                val tfEvs = map F.VAR fvbIs
 498                val bodyE = bodyE(F.RET tfEvs)
 499                val tfElty = LT.lt_nvpoly(args, map getLty tfEvs)
 500                val _ = addLty(tfE, tfElty)
 501
 502                (* tfdecI *)
 503                val tfkI = {inline=F.IH_ALWAYS}
 504                val argsI = map (fn (v,k) => (cplv v, k)) args
 505                (* val tmap = ListPair.map (fn (a1,a2) =>
 506                 *                               (#1 a1, LT.tcc_nvar(#1 a2)))
 507                 *                              (args, argsI) *)
 508                val bodyI = FU.copy tmap M.empty
 509                                    (F.LET(fvbIs, F.TAPP(F.VAR tfE, map #2 tmap),
 510                                           bodyI))
 511                (* F.TFN *)
 512                fun nleE e =
 513                    F.TFN((tfk, tfE, args, bodyE),
 514                          F.TFN((tfkI, tf, argsI, bodyI), leE e))
 515
 516            in if not(S.member(fvI, tf)) then (nleE, leI, fvI, leRet)
 517               else (nleE,
 518                     F.TFN((tfkI, tf, argsI, bodyI), leI),
 519                     S.add(S.union(S_rmv(tf, fvI), S.intersection(env, fvbI)), tfE),
 520                     leRet)
 521            end
 522     end
 523
 524 (* here, we use B-decomposition, so the args should not be
 525  * considered as being in scope *)
 526 val (bodyE,bodyI,fvbI,bodyRet) = sexp S.empty body
 527 in case (bodyI, bodyRet)
 528     of (F.RET _,_) => ((fk, f, args, bodyE bodyRet), NONE)
 529      | (_,F.RECORD (rk,vs,lv,F.RET[lv'])) =>
 530        let val fvbIs = S.listItems fvbI
 531
 532            (* fdecE *)
 533            val bodyE = bodyE(F.RECORD(rk, vs@(map F.VAR fvbIs), lv, F.RET[lv']))
 534            val fdecE as (_,fE,_,_) = (fk, cplv f, args, bodyE)
 535
 536            (* fdecI *)
 537            val argI = mklv()
 538            val argLtys = (map getLty vs) @ (map (getLty o F.VAR) fvbIs)
 539            val argsI = [(argI, LT.ltc_str argLtys)]
 540            val (_,bodyI) = foldl (fn (lv,(n,le)) =>
 541                                      (n+1, F.SELECT(F.VAR argI, n, lv, le)))
 542                                  (length vs, bodyI) fvbIs
 543            val fdecI as (_,fI,_,_) = FU.copyfdec (fk, f, argsI, bodyI)
 544
 545            val nargs = map (fn (v,t) => (cplv v, t)) args
 546        in
 547            (fdecE, SOME fdecI)
 548        (* ((fk, f, nargs,
 549             F.FIX([fdecE],
 550                   F.FIX([fdecI],
 551                         F.LET([argI],
 552                               F.APP(F.VAR fE, map (F.VAR o #1) nargs),
 553                               F.APP(F.VAR fI, [F.VAR argI]))))),
 554            NONE) *)
 555        end
 556
 557      | _ => (fdec, NONE)                (* sorry, can't do that *)
 558 (* (PPFlint.printLexp bodyRet; bug "couldn't find the returned record") *)
 559
 560 end
 561
 562 end
 563 end