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

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