ghc/compiler/coreSyn/CoreSyn.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[CoreSyn]{A data type for the Haskell compiler midsection}
   5
   6 \begin{code}
   7 module CoreSyn (
   8         GenCoreBinding(..), GenCoreExpr(..),
   9         GenCoreArg(..), GenCoreBinder(..), GenCoreCaseAlts(..),
  10         GenCoreCaseDefault(..), CoreNote(..),
  11
  12         bindersOf, pairsFromCoreBinds, rhssOfBind,
  13
  14         mkGenApp, mkValApp, mkTyApp,
  15         mkApp, mkCon, mkPrim,
  16         mkValLam, mkTyLam,
  17         mkLam,
  18         collectBinders, collectValBinders, collectTyBinders,
  19         isValBinder, notValBinder,
  20
  21         collectArgs, initialTyArgs, initialValArgs, isValArg, notValArg, numValArgs,
  22
  23         mkCoLetAny, mkCoLetNoUnboxed, mkCoLetUnboxedToCase,
  24         mkCoLetsAny, mkCoLetsNoUnboxed, mkCoLetsUnboxedToCase,
  25         mkCoLetrecAny, mkCoLetrecNoUnboxed,
  26
  27         rhssOfAlts,
  28
  29         -- Common type instantiation...
  30         CoreBinding,
  31         CoreExpr,
  32         CoreBinder,
  33         CoreArg,
  34         CoreCaseAlts,
  35         CoreCaseDefault,
  36
  37         -- And not-so-common type instantiations...
  38         TaggedCoreBinding,
  39         TaggedCoreExpr,
  40         TaggedCoreBinder,
  41         TaggedCoreArg,
  42         TaggedCoreCaseAlts,
  43         TaggedCoreCaseDefault,
  44
  45         SimplifiableCoreBinding,
  46         SimplifiableCoreExpr,
  47         SimplifiableCoreBinder,
  48         SimplifiableCoreArg,
  49         SimplifiableCoreCaseAlts,
  50         SimplifiableCoreCaseDefault
  51     ) where
  52
  53 #include "HsVersions.h"
  54
  55 import CostCentre       ( CostCentre )
  56 import Id               ( idType, Id )
  57 import Type             ( isUnboxedType,GenType, Type )
  58 import TyVar            ( GenTyVar, TyVar )
  59 import Util             ( panic, assertPanic )
  60 import BinderInfo       ( BinderInfo )
  61 import BasicTypes       ( Unused )
  62 import Literal          ( Literal )
  63 import PrimOp           ( PrimOp )
  64 \end{code}
  65
  66 %************************************************************************
  67 %*                                                                      *
  68 \subsection[CoreTopBinding_and_CoreBinding]{@CoreTopBinding@ and @GenCoreBinding@}
  69 %*                                                                      *
  70 %************************************************************************
  71
  72 Core programs, bindings, expressions, etc., are parameterised with
  73 respect to the information kept about binding and bound occurrences of
  74 variables, called {\em binders} and {\em val_occ tyvar uvars}, respectively.  [I
  75 don't really like the pair of names; I prefer {\em binder} and {\em
  76 bounder}.  Or {\em binder} and {\em var}.]
  77
  78 A @GenCoreBinding@ is either a single non-recursive binding of a
  79 ``binder'' to an expression, or a mutually-recursive blob of same.
  80 \begin{code}
  81 data GenCoreBinding val_bdr val_occ flexi
  82   = NonRec      val_bdr (GenCoreExpr val_bdr val_occ flexi)
  83   | Rec         [(val_bdr, GenCoreExpr val_bdr val_occ flexi)]
  84 \end{code}
  85
  86 \begin{code}
  87 bindersOf :: GenCoreBinding val_bdr val_occ flexi -> [val_bdr]
  88
  89 pairsFromCoreBinds ::
  90   [GenCoreBinding val_bdr val_occ flexi] ->
  91   [(val_bdr, GenCoreExpr val_bdr val_occ flexi)]
  92
  93 rhssOfBind :: GenCoreBinding val_bdr val_occ flexi -> [GenCoreExpr val_bdr val_occ flexi]
  94
  95 bindersOf (NonRec binder _) = [binder]
  96 bindersOf (Rec pairs)       = [binder | (binder, _) <- pairs]
  97
  98 pairsFromCoreBinds []                  = []
  99 pairsFromCoreBinds ((NonRec b e) : bs) = (b,e) :  pairsFromCoreBinds bs
 100 pairsFromCoreBinds ((Rec  pairs) : bs) = pairs ++ pairsFromCoreBinds bs
 101
 102 rhssOfBind (NonRec _ rhs) = [rhs]
 103 rhssOfBind (Rec pairs)    = [rhs | (_,rhs) <- pairs]
 104 \end{code}
 105
 106 %************************************************************************
 107 %*                                                                      *
 108 \subsection[GenCoreExpr]{Core expressions: @GenCoreExpr@}
 109 %*                                                                      *
 110 %************************************************************************
 111
 112 @GenCoreExpr@ is the heart of the ``core'' data types; it is
 113 (more-or-less) boiled-down second-order polymorphic lambda calculus.
 114 For types in the core world, we just keep using @Types@.
 115 \begin{code}
 116 data GenCoreExpr val_bdr val_occ flexi
 117      = Var    val_occ
 118      | Lit    Literal   -- literal constants
 119 \end{code}
 120
 121 @Cons@ and @Prims@ are saturated constructor and primitive-op
 122 applications (see the comment).  Note: @Con@s are only set up by the
 123 simplifier (and by the desugarer when it knows what it's doing).  The
 124 desugarer sets up constructors as applications of global @Vars@s.
 125
 126 \begin{code}
 127      | Con      Id [GenCoreArg val_occ flexi]
 128                 -- Saturated constructor application:
 129                 -- The constructor is a function of the form:
 130                 --      /\ a1 -> ... /\ am -> \ b1 -> ... \ bn ->
 131                 -- <expr> where "/\" is a type lambda and "\" the
 132                 -- regular kind; there will be "m" Types and
 133                 -- "n" bindees in the Con args.
 134
 135      | Prim     PrimOp [GenCoreArg val_occ flexi]
 136                 -- saturated primitive operation;
 137
 138                 -- comment on Cons applies here, too.
 139 \end{code}
 140
 141 Ye olde abstraction and application operators.
 142 \begin{code}
 143      | Lam      (GenCoreBinder val_bdr flexi)
 144                 (GenCoreExpr   val_bdr val_occ flexi)
 145
 146      | App      (GenCoreExpr val_bdr val_occ flexi)
 147                 (GenCoreArg  val_occ flexi)
 148 \end{code}
 149
 150 Case expressions (\tr{case <expr> of <List of alternatives>}): there
 151 are really two flavours masquerading here---those for scrutinising
 152 {\em algebraic} types and those for {\em primitive} types.  Please see
 153 under @GenCoreCaseAlts@.
 154 \begin{code}
 155      | Case     (GenCoreExpr val_bdr val_occ flexi)
 156                 (GenCoreCaseAlts val_bdr val_occ flexi)
 157 \end{code}
 158
 159 A Core case expression \tr{case e of v -> ...} implies evaluation of
 160 \tr{e}; it is not equivalent to \tr{let v = in ...} (as with a Haskell
 161 \tr{case}).
 162
 163 Non-recursive @Lets@ only have one binding; having more than one
 164 doesn't buy you much, and it is an easy way to mess up variable
 165 scoping.
 166 \begin{code}
 167      | Let      (GenCoreBinding val_bdr val_occ flexi)
 168                 (GenCoreExpr val_bdr val_occ flexi)
 169                 -- both recursive and non-.
 170                 -- The "GenCoreBinding" records that information
 171 \end{code}
 172
 173 A @Note@ annotates a @CoreExpr@ with useful information
 174 of some kind.
 175 \begin{code}
 176      | Note     (CoreNote flexi)
 177                 (GenCoreExpr val_bdr val_occ flexi)
 178 \end{code}
 179
 180
 181 %************************************************************************
 182 %*                                                                      *
 183 \subsection{Core-notes}
 184 %*                                                                      *
 185 %************************************************************************
 186
 187 \begin{code}
 188 data CoreNote flexi
 189   = SCC
 190         CostCentre
 191
 192   | Coerce
 193         (GenType flexi)         -- The to-type:   type of whole coerce expression
 194         (GenType flexi)         -- The from-type: type of enclosed expression
 195
 196   | InlineCall                  -- Instructs simplifier to inline
 197                                 -- the enclosed call
 198 \end{code}
 199
 200
 201
 202 %************************************************************************
 203 %*                                                                      *
 204 \subsection{Core-constructing functions with checking}
 205 %*                                                                      *
 206 %************************************************************************
 207
 208 When making @Lets@, we may want to take evasive action if the thing
 209 being bound has unboxed type. We have different variants ...
 210
 211 @mkCoLet(s|rec)Any@             let-binds any binding, regardless of type
 212 @mkCoLet(s|rec)NoUnboxed@       prohibits unboxed bindings
 213 @mkCoLet(s)UnboxedToCase@       converts an unboxed binding to a case
 214                                 (unboxed bindings in a letrec are still prohibited)
 215
 216 \begin{code}
 217 mkCoLetAny :: GenCoreBinding Id Id flexi
 218            -> GenCoreExpr    Id Id flexi
 219            -> GenCoreExpr    Id Id flexi
 220 mkCoLetsAny :: [GenCoreBinding Id Id flexi] ->
 221                 GenCoreExpr Id Id flexi ->
 222                 GenCoreExpr Id Id flexi
 223
 224 mkCoLetrecAny :: [(val_bdr, GenCoreExpr val_bdr val_occ flexi)]
 225               -> GenCoreExpr val_bdr val_occ flexi
 226               -> GenCoreExpr val_bdr val_occ flexi
 227
 228 mkCoLetrecAny []    body = body
 229 mkCoLetrecAny binds body = Let (Rec binds) body
 230
 231 mkCoLetsAny []    expr = expr
 232 mkCoLetsAny binds expr = foldr mkCoLetAny expr binds
 233
 234 mkCoLetAny bind@(Rec binds)         body = mkCoLetrecAny binds body
 235 mkCoLetAny bind@(NonRec binder rhs) body = Let bind body
 236 \end{code}
 237
 238 \begin{code}
 239 mkCoLetNoUnboxed bind@(Rec binds) body
 240   = mkCoLetrecNoUnboxed binds body
 241
 242 mkCoLetNoUnboxed bind@(NonRec binder rhs) body
 243   = --ASSERT (not (isUnboxedType (idType binder)))
 244     case body of
 245       Var binder2 | binder == binder2
 246          -> rhs   -- hey, I have the rhs
 247       other
 248          -> Let bind body
 249
 250 mkCoLetsNoUnboxed []    expr = expr
 251 mkCoLetsNoUnboxed binds expr = foldr mkCoLetNoUnboxed expr binds
 252
 253 mkCoLetrecNoUnboxed []    body = body
 254 mkCoLetrecNoUnboxed binds body
 255   = ASSERT (all is_boxed_bind binds)
 256     Let (Rec binds) body
 257   where
 258     is_boxed_bind (binder, rhs)
 259       = (not . isUnboxedType . idType) binder
 260 \end{code}
 261
 262 \begin{code}
 263 mkCoLetUnboxedToCase bind@(Rec binds) body
 264   = mkCoLetrecNoUnboxed binds body
 265
 266 mkCoLetUnboxedToCase bind@(NonRec binder rhs) body
 267   = case body of
 268       Var binder2 | binder == binder2
 269          -> rhs   -- hey, I have the rhs
 270       other
 271          -> if (not (isUnboxedType (idType binder))) then
 272                 Let bind body            -- boxed...
 273             else
 274                 Case rhs                  -- unboxed...
 275                   (PrimAlts []
 276                     (BindDefault binder body))
 277
 278 mkCoLetsUnboxedToCase []    expr = expr
 279 mkCoLetsUnboxedToCase binds expr = foldr mkCoLetUnboxedToCase expr binds
 280 \end{code}
 281
 282 %************************************************************************
 283 %*                                                                      *
 284 \subsection{Case alternatives in @GenCoreExpr@}
 285 %*                                                                      *
 286 %************************************************************************
 287
 288 We have different kinds of @case@s, the differences being reflected in
 289 the kinds of alternatives a case has.  We maintain a distinction
 290 between cases for scrutinising algebraic datatypes, as opposed to
 291 primitive types.  In both cases, we carry around a @TyCon@, as a
 292 handle with which we can get info about the case (e.g., total number
 293 of data constructors for this type).
 294
 295 For example:
 296 \begin{verbatim}
 297 let# x=e in b
 298 \end{verbatim}
 299 becomes
 300 \begin{verbatim}
 301 Case e [ BindDefaultAlt x -> b ]
 302 \end{verbatim}
 303
 304 \begin{code}
 305 data GenCoreCaseAlts val_bdr val_occ flexi
 306   = AlgAlts     [(Id,                           -- alts: data constructor,
 307                   [val_bdr],                    -- constructor's parameters,
 308                   GenCoreExpr val_bdr val_occ flexi)]   -- rhs.
 309                 (GenCoreCaseDefault val_bdr val_occ flexi)
 310
 311   | PrimAlts    [(Literal,                      -- alts: unboxed literal,
 312                   GenCoreExpr val_bdr val_occ flexi)]   -- rhs.
 313                 (GenCoreCaseDefault val_bdr val_occ flexi)
 314
 315 -- obvious things: if there are no alts in the list, then the default
 316 -- can't be NoDefault.
 317
 318 data GenCoreCaseDefault val_bdr val_occ flexi
 319   = NoDefault                                   -- small con family: all
 320                                                 -- constructor accounted for
 321   | BindDefault val_bdr                         -- form: var -> expr;
 322                 (GenCoreExpr val_bdr val_occ flexi)     -- "val_bdr" may or may not
 323                                                 -- be used in RHS.
 324 \end{code}
 325
 326 \begin{code}
 327 rhssOfAlts (AlgAlts alts deflt)  = rhssOfDeflt deflt ++ [rhs | (_,_,rhs) <- alts]
 328 rhssOfAlts (PrimAlts alts deflt) = rhssOfDeflt deflt ++ [rhs | (_,rhs)   <- alts]
 329
 330 rhssOfDeflt NoDefault           = []
 331 rhssOfDeflt (BindDefault _ rhs) = [rhs]
 332 \end{code}
 333
 334 %************************************************************************
 335 %*                                                                      *
 336 \subsection{Core binders}
 337 %*                                                                      *
 338 %************************************************************************
 339
 340 \begin{code}
 341 data GenCoreBinder val_bdr flexi
 342   = ValBinder   val_bdr
 343   | TyBinder    (GenTyVar flexi)
 344
 345 isValBinder (ValBinder _) = True
 346 isValBinder _             = False
 347
 348 notValBinder = not . isValBinder
 349 \end{code}
 350
 351 Clump Lams together if possible.
 352
 353 \begin{code}
 354 mkValLam :: [val_bdr]
 355          -> GenCoreExpr val_bdr val_occ flexi
 356          -> GenCoreExpr val_bdr val_occ flexi
 357 mkTyLam  :: [GenTyVar flexi]
 358          -> GenCoreExpr val_bdr val_occ flexi
 359          -> GenCoreExpr val_bdr val_occ flexi
 360
 361 mkValLam binders body = foldr (Lam . ValBinder)   body binders
 362 mkTyLam  binders body = foldr (Lam . TyBinder)    body binders
 363
 364 mkLam :: [GenTyVar flexi] -> [val_bdr] -- ToDo: could add a [uvar] arg...
 365          -> GenCoreExpr val_bdr val_occ flexi
 366          -> GenCoreExpr val_bdr val_occ flexi
 367
 368 mkLam tyvars valvars body
 369   = mkTyLam tyvars (mkValLam valvars body)
 370 \end{code}
 371
 372 We often want to strip off leading lambdas before getting down to
 373 business.  @collectBinders@ is your friend.
 374
 375 We expect (by convention) usage-, type-, and value- lambdas in that
 376 order.
 377
 378 \begin{code}
 379 collectBinders ::
 380   GenCoreExpr val_bdr val_occ flexi ->
 381   ([GenTyVar flexi], [val_bdr], GenCoreExpr val_bdr val_occ flexi)
 382
 383 collectBinders expr
 384   = case collectValBinders body1 of { (vals,body) -> (tyvars, vals, body) }
 385   where
 386     (tyvars, body1) = collectTyBinders expr
 387
 388 collectTyBinders expr
 389   = tyvars expr []
 390   where
 391     tyvars (Lam (TyBinder t) body) tacc = tyvars body (t:tacc)
 392     tyvars other tacc = (reverse tacc, other)
 393
 394 collectValBinders :: GenCoreExpr val_bdr val_occ flexi ->
 395                      ([val_bdr], GenCoreExpr val_bdr val_occ flexi)
 396 collectValBinders expr
 397   = go [] expr
 398   where
 399     go acc (Lam (ValBinder v) b) = go (v:acc) b
 400     go acc body                  = (reverse acc, body)
 401
 402 \end{code}
 403
 404 %************************************************************************
 405 %*                                                                      *
 406 \subsection{Core arguments (atoms)}
 407 %*                                                                      *
 408 %************************************************************************
 409
 410 \begin{code}
 411 data GenCoreArg val_occ flexi
 412   = LitArg      Literal
 413   | VarArg      val_occ
 414   | TyArg       (GenType flexi)
 415 \end{code}
 416
 417 General and specific forms:
 418 \begin{code}
 419 mkGenApp :: GenCoreExpr val_bdr val_occ flexi
 420          -> [GenCoreArg val_occ flexi]
 421          -> GenCoreExpr val_bdr val_occ flexi
 422 mkTyApp  :: GenCoreExpr val_bdr val_occ flexi
 423          -> [GenType flexi]
 424          -> GenCoreExpr val_bdr val_occ flexi
 425 mkValApp :: GenCoreExpr val_bdr val_occ flexi
 426          -> [GenCoreArg val_occ flexi] -- but we ASSERT they are LitArg or VarArg
 427          -> GenCoreExpr val_bdr val_occ flexi
 428
 429 mkGenApp f args = foldl App                                f args
 430 mkTyApp  f args = foldl (\ e a -> App e (TyArg a))         f args
 431 mkValApp f args = foldl (\ e a -> App e (is_Lit_or_Var a)) f args
 432
 433 #ifndef DEBUG
 434 is_Lit_or_Var a = a
 435 #else
 436 is_Lit_or_Var a
 437   = if isValArg a then a else panic "CoreSyn.mkValApps:not LitArg or VarArg"
 438 #endif
 439
 440 isValArg (LitArg _) = True  -- often used for sanity-checking
 441 isValArg (VarArg _) = True
 442 isValArg _          = False
 443
 444 notValArg = not . isValArg -- exists only because it's a common use of isValArg
 445
 446 numValArgs as = length [ a | a <- as, isValArg a ] -- again, convenience
 447 \end{code}
 448
 449 \begin{code}
 450 mkApp  fun = mk_thing (mkGenApp fun)
 451 mkCon  con = mk_thing (Con      con)
 452 mkPrim op  = mk_thing (Prim     op)
 453
 454 mk_thing :: ([GenCoreArg val_occ flexi] -> GenCoreExpr val_bdr val_occ flexi)
 455          -> [GenType flexi]
 456          -> [GenCoreArg val_occ flexi]
 457          -> GenCoreExpr val_bdr val_occ flexi
 458 mk_thing thing tys vals
 459   = ASSERT( all isValArg vals )
 460     thing (map TyArg tys ++ vals)
 461 \end{code}
 462
 463 @collectArgs@ takes an application expression, returning the function
 464 and the arguments to which it is applied.
 465
 466 \begin{code}
 467 collectArgs :: GenCoreExpr val_bdr val_occ flexi
 468             -> (GenCoreExpr val_bdr val_occ flexi,
 469                 [GenType flexi],
 470                 [GenCoreArg val_occ flexi]{-ValArgs-})
 471
 472 collectArgs expr
 473   = valvars expr []
 474   where
 475     valvars (App fun v) vacc | isValArg v = valvars fun (v:vacc)
 476     valvars fun vacc
 477       = case (tyvars fun []) of { (expr, tacc) ->
 478         (expr, tacc, vacc) }
 479
 480     tyvars (App fun (TyArg t)) tacc = tyvars fun (t:tacc)
 481     tyvars fun tacc                 = (fun, tacc)
 482      -- WAS: tyvars fun tacc        = (expr, tacc)
 483      --   This doesn't look right (i.e., Plain Wrong),
 484      --   collectArgs should return the the function and
 485      --   not the whole expr.      -- Laszlo 8/98
 486
 487 \end{code}
 488
 489
 490 \begin{code}
 491 initialTyArgs :: [GenCoreArg val_occ flexi]
 492               -> ([GenType flexi], [GenCoreArg val_occ flexi])
 493 initialTyArgs (TyArg ty : args) = (ty:tys, args')
 494                                 where
 495                                   (tys, args') = initialTyArgs args
 496 initialTyArgs other             = ([],other)
 497
 498 initialValArgs :: [GenCoreArg val_occ flexi]
 499               -> ([GenCoreArg val_occ flexi], [GenCoreArg val_occ flexi])
 500 initialValArgs args = span isValArg args
 501 \end{code}
 502
 503
 504 %************************************************************************
 505 %*                                                                      *
 506 \subsection{The main @Core*@ instantiation of the @GenCore*@ types}
 507 %*                                                                      *
 508 %************************************************************************
 509
 510 \begin{code}
 511 type CoreBinding = GenCoreBinding  Id Id Unused
 512 type CoreExpr    = GenCoreExpr     Id Id Unused
 513 type CoreBinder  = GenCoreBinder   Id    Unused
 514 type CoreArg     = GenCoreArg         Id Unused
 515
 516 type CoreCaseAlts    = GenCoreCaseAlts    Id Id Unused
 517 type CoreCaseDefault = GenCoreCaseDefault Id Id Unused
 518 \end{code}
 519
 520 %************************************************************************
 521 %*                                                                      *
 522 \subsection{The @TaggedCore*@ instantiation of the @GenCore*@ types}
 523 %*                                                                      *
 524 %************************************************************************
 525
 526 Binders are ``tagged'' with a \tr{t}:
 527 \begin{code}
 528 type Tagged t = (Id, t)
 529
 530 type TaggedCoreBinding t = GenCoreBinding (Tagged t) Id Unused
 531 type TaggedCoreExpr    t = GenCoreExpr    (Tagged t) Id Unused
 532 type TaggedCoreBinder  t = GenCoreBinder  (Tagged t)    Unused
 533 type TaggedCoreArg     t = GenCoreArg                Id Unused
 534
 535 type TaggedCoreCaseAlts    t = GenCoreCaseAlts    (Tagged t) Id Unused
 536 type TaggedCoreCaseDefault t = GenCoreCaseDefault (Tagged t) Id Unused
 537 \end{code}
 538
 539 %************************************************************************
 540 %*                                                                      *
 541 \subsection{The @SimplifiableCore*@ instantiation of the @GenCore*@ types}
 542 %*                                                                      *
 543 %************************************************************************
 544
 545 Binders are tagged with @BinderInfo@:
 546 \begin{code}
 547 type Simplifiable = (Id, BinderInfo)
 548
 549 type SimplifiableCoreBinding = GenCoreBinding Simplifiable Id Unused
 550 type SimplifiableCoreExpr    = GenCoreExpr    Simplifiable Id Unused
 551 type SimplifiableCoreBinder  = GenCoreBinder  Simplifiable    Unused
 552 type SimplifiableCoreArg     = GenCoreArg                  Id Unused
 553
 554 type SimplifiableCoreCaseAlts    = GenCoreCaseAlts    Simplifiable Id Unused
 555 type SimplifiableCoreCaseDefault = GenCoreCaseDefault Simplifiable Id Unused
 556 \end{code}