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