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