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