ghc/compiler/coreSyn/CoreSyn.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[CoreSyn]{A data type for the Haskell compiler midsection}
   5
   6 \begin{code}
   7 module CoreSyn (
   8         Expr(..), Alt, Bind(..), Arg(..), Note(..),
   9         CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
  10         TaggedExpr, TaggedAlt, TaggedBind, TaggedArg,
  11
  12         mkLets, mkLams,
  13         mkApps, mkTyApps, mkValApps, mkVarApps,
  14         mkLit, mkStringLit, mkConApp, mkPrimApp, mkNote,
  15         bindNonRec, mkIfThenElse, varToCoreExpr,
  16
  17         bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, isDeadBinder, isTyVar, isId,
  18         collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
  19         collectArgs, collectBindersIgnoringNotes,
  20         coreExprCc,
  21         flattenBinds,
  22
  23         isValArg, isTypeArg, valArgCount, valBndrCount,
  24
  25         -- Seq stuff
  26         seqRules, seqExpr, seqExprs,
  27
  28         -- Size
  29         coreBindsSize,
  30
  31         -- Annotated expressions
  32         AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, deAnnotate,
  33
  34         -- Core rules
  35         CoreRules(..),  -- Representation needed by friends
  36         CoreRule(..),   -- CoreSubst, CoreTidy, CoreFVs, PprCore only
  37         emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules
  38     ) where
  39
  40 #include "HsVersions.h"
  41
  42 import TysWiredIn       ( boolTy, stringTy, nilDataCon )
  43 import CostCentre       ( CostCentre, isDupdCC, noCostCentre )
  44 import Var              ( Var, Id, TyVar, IdOrTyVar, isTyVar, isId, idType )
  45 import VarEnv
  46 import Id               ( mkWildId, getInlinePragma, idInfo )
  47 import Type             ( Type, UsageAnn, mkTyVarTy, isUnLiftedType, seqType )
  48 import IdInfo           ( InlinePragInfo(..), megaSeqIdInfo )
  49 import Const            ( Con(..), DataCon, Literal(NoRepStr), PrimOp )
  50 import TysWiredIn       ( trueDataCon, falseDataCon )
  51 import VarSet
  52 import Outputable
  53 \end{code}
  54
  55 %************************************************************************
  56 %*                                                                      *
  57 \subsection{The main data types}
  58 %*                                                                      *
  59 %************************************************************************
  60
  61 These data types are the heart of the compiler
  62
  63 \begin{code}
  64 infixl 8 `App`  -- App brackets to the left
  65
  66 data Expr b     -- "b" for the type of binders,
  67   = Var   Id
  68   | Con   Con [Arg b]           -- Guaranteed saturated
  69                                 -- The Con can be a DataCon, Literal, PrimOP
  70                                 -- but cannot be DEFAULT
  71   | App   (Expr b) (Arg b)
  72   | Lam   b (Expr b)
  73   | Let   (Bind b) (Expr b)
  74   | Case  (Expr b) b [Alt b]    -- Binder gets bound to value of scrutinee
  75                                 -- DEFAULT case must be last, if it occurs at all
  76   | Note  Note (Expr b)
  77   | Type  Type                  -- This should only show up at the top
  78                                 -- level of an Arg
  79
  80 type Arg b = Expr b             -- Can be a Type
  81
  82 type Alt b = (Con, [b], Expr b)
  83         -- (DEFAULT, [], rhs) is the default alternative
  84         -- The Con can be a Literal, DataCon, or DEFAULT, but cannot be PrimOp
  85
  86 data Bind b = NonRec b (Expr b)
  87               | Rec [(b, (Expr b))]
  88
  89 data Note
  90   = SCC CostCentre
  91
  92   | Coerce
  93         Type            -- The to-type:   type of whole coerce expression
  94         Type            -- The from-type: type of enclosed expression
  95
  96   | InlineCall          -- Instructs simplifier to inline
  97                         -- the enclosed call
  98
  99   | InlineMe            -- Instructs simplifer to treat the enclosed expression
 100                         -- as very small, and inline it at its call sites
 101
 102   | TermUsg             -- A term-level usage annotation
 103         UsageAnn        -- (should not be a variable except during UsageSP inference)
 104 \end{code}
 105
 106
 107 %************************************************************************
 108 %*                                                                      *
 109 \subsection{Transformation rules}
 110 %*                                                                      *
 111 %************************************************************************
 112
 113 The CoreRule type and its friends are dealt with mainly in CoreRules,
 114 but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
 115
 116 \begin{code}
 117 data CoreRules
 118   = Rules [CoreRule]
 119           IdOrTyVarSet          -- Locally-defined free vars of RHSs
 120
 121 data CoreRule
 122   = Rule FAST_STRING    -- Rule name
 123          [CoreBndr]     -- Forall'd variables
 124          [CoreExpr]     -- LHS args
 125          CoreExpr       -- RHS
 126
 127 emptyCoreRules :: CoreRules
 128 emptyCoreRules = Rules [] emptyVarSet
 129
 130 isEmptyCoreRules :: CoreRules -> Bool
 131 isEmptyCoreRules (Rules rs _) = null rs
 132
 133 rulesRhsFreeVars :: CoreRules -> IdOrTyVarSet
 134 rulesRhsFreeVars (Rules _ fvs) = fvs
 135
 136 rulesRules :: CoreRules -> [CoreRule]
 137 rulesRules (Rules rules _) = rules
 138 \end{code}
 139
 140
 141 %************************************************************************
 142 %*                                                                      *
 143 \subsection{Useful synonyms}
 144 %*                                                                      *
 145 %************************************************************************
 146
 147 The common case
 148
 149 \begin{code}
 150 type CoreBndr = IdOrTyVar
 151 type CoreExpr = Expr CoreBndr
 152 type CoreArg  = Arg  CoreBndr
 153 type CoreBind = Bind CoreBndr
 154 type CoreAlt  = Alt  CoreBndr
 155 type CoreNote = Note
 156 \end{code}
 157
 158 Binders are ``tagged'' with a \tr{t}:
 159
 160 \begin{code}
 161 type Tagged t = (CoreBndr, t)
 162
 163 type TaggedBind t = Bind (Tagged t)
 164 type TaggedExpr t = Expr (Tagged t)
 165 type TaggedArg  t = Arg  (Tagged t)
 166 type TaggedAlt  t = Alt  (Tagged t)
 167 \end{code}
 168
 169
 170 %************************************************************************
 171 %*                                                                      *
 172 \subsection{Core-constructing functions with checking}
 173 %*                                                                      *
 174 %************************************************************************
 175
 176 \begin{code}
 177 mkApps    :: Expr b -> [Arg b]  -> Expr b
 178 mkTyApps  :: Expr b -> [Type]   -> Expr b
 179 mkValApps :: Expr b -> [Expr b] -> Expr b
 180 mkVarApps :: CoreExpr -> [IdOrTyVar] -> CoreExpr
 181
 182 mkApps    f args = foldl App                       f args
 183 mkTyApps  f args = foldl (\ e a -> App e (Type a)) f args
 184 mkValApps f args = foldl (\ e a -> App e a)        f args
 185 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
 186
 187 mkLit       :: Literal -> Expr b
 188 mkStringLit :: String  -> Expr b
 189 mkConApp    :: DataCon -> [Arg b] -> Expr b
 190 mkPrimApp   :: PrimOp  -> [Arg b] -> Expr b
 191
 192 mkLit lit         = Con (Literal lit) []
 193 mkStringLit str   = Con (Literal (NoRepStr (_PK_ str) stringTy)) []
 194 mkConApp con args = Con (DataCon con) args
 195 mkPrimApp op args = Con (PrimOp op)   args
 196
 197 varToCoreExpr :: CoreBndr -> CoreExpr
 198 varToCoreExpr v | isId v    = Var v
 199                 | otherwise = Type (mkTyVarTy v)
 200 \end{code}
 201
 202 \begin{code}
 203 mkLams :: [b] -> Expr b -> Expr b
 204 mkLams binders body = foldr Lam body binders
 205 \end{code}
 206
 207 \begin{code}
 208 mkLets :: [Bind b] -> Expr b -> Expr b
 209 mkLets binds body = foldr Let body binds
 210
 211 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
 212 -- (bindNonRec x r b) produces either
 213 --      let x = r in b
 214 -- or
 215 --      case r of x { _DEFAULT_ -> b }
 216 --
 217 -- depending on whether x is unlifted or not
 218 -- It's used by the desugarer to avoid building bindings
 219 -- that give Core Lint a heart attack.  Actually the simplifier
 220 -- deals with them perfectly well.
 221 bindNonRec bndr rhs body
 222   | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
 223   | otherwise                    = Let (NonRec bndr rhs) body
 224
 225 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
 226 mkIfThenElse guard then_expr else_expr
 227   = Case guard (mkWildId boolTy)
 228          [ (DataCon trueDataCon,  [], then_expr),
 229            (DataCon falseDataCon, [], else_expr) ]
 230 \end{code}
 231
 232 mkNote removes redundant coercions, and SCCs where possible
 233
 234 \begin{code}
 235 mkNote :: Note -> Expr b -> Expr b
 236 mkNote (Coerce to_ty1 from_ty1) (Note (Coerce to_ty2 from_ty2) expr)
 237  = ASSERT( from_ty1 == to_ty2 )
 238    mkNote (Coerce to_ty1 from_ty2) expr
 239
 240 mkNote (SCC cc1) expr@(Note (SCC cc2) _)
 241   | isDupdCC cc1        -- Discard the outer SCC provided we don't need
 242   = expr                -- to track its entry count
 243
 244 mkNote note@(SCC cc1) expr@(Lam x e)    -- Move _scc_ inside lambda
 245   = Lam x (mkNote note e)
 246
 247 -- Drop trivial InlineMe's
 248 mkNote InlineMe expr@(Con _ _) = expr
 249 mkNote InlineMe expr@(Var v)   = expr
 250
 251 -- Slide InlineCall in around the function
 252 --      No longer necessary I think (SLPJ Apr 99)
 253 -- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
 254 -- mkNote InlineCall (Var v)   = Note InlineCall (Var v)
 255 -- mkNote InlineCall expr      = expr
 256
 257 mkNote note expr = Note note expr
 258 \end{code}
 259
 260 %************************************************************************
 261 %*                                                                      *
 262 \subsection{Simple access functions}
 263 %*                                                                      *
 264 %************************************************************************
 265
 266 \begin{code}
 267 bindersOf  :: Bind b -> [b]
 268 bindersOf (NonRec binder _) = [binder]
 269 bindersOf (Rec pairs)       = [binder | (binder, _) <- pairs]
 270
 271 bindersOfBinds :: [Bind b] -> [b]
 272 bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
 273
 274 rhssOfBind :: Bind b -> [Expr b]
 275 rhssOfBind (NonRec _ rhs) = [rhs]
 276 rhssOfBind (Rec pairs)    = [rhs | (_,rhs) <- pairs]
 277
 278 rhssOfAlts :: [Alt b] -> [Expr b]
 279 rhssOfAlts alts = [e | (_,_,e) <- alts]
 280
 281 isDeadBinder :: CoreBndr -> Bool
 282 isDeadBinder bndr | isId bndr = case getInlinePragma bndr of
 283                                         IAmDead -> True
 284                                         other   -> False
 285                   | otherwise = False   -- TyVars count as not dead
 286
 287 flattenBinds :: [Bind b] -> [(b, Expr b)]       -- Get all the lhs/rhs pairs
 288 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
 289 flattenBinds (Rec prs1   : binds) = prs1 ++ flattenBinds binds
 290 flattenBinds []                   = []
 291 \end{code}
 292
 293 We often want to strip off leading lambdas before getting down to
 294 business.  @collectBinders@ is your friend.
 295
 296 We expect (by convention) type-, and value- lambdas in that
 297 order.
 298
 299 \begin{code}
 300 collectBinders               :: Expr b -> ([b],         Expr b)
 301 collectBindersIgnoringNotes  :: Expr b -> ([b],         Expr b)
 302 collectTyBinders             :: CoreExpr -> ([TyVar],     CoreExpr)
 303 collectValBinders            :: CoreExpr -> ([Id],        CoreExpr)
 304 collectTyAndValBinders       :: CoreExpr -> ([TyVar], [Id], CoreExpr)
 305
 306 collectBinders expr
 307   = go [] expr
 308   where
 309     go bs (Lam b e) = go (b:bs) e
 310     go bs e          = (reverse bs, e)
 311
 312 -- This one ignores notes.  It's used in CoreUnfold and StrAnal
 313 -- when we aren't going to put the expression back together from
 314 -- the pieces, so we don't mind losing the Notes
 315 collectBindersIgnoringNotes expr
 316   = go [] expr
 317   where
 318     go bs (Lam b e)  = go (b:bs) e
 319     go bs (Note _ e) = go    bs  e
 320     go bs e          = (reverse bs, e)
 321
 322 collectTyAndValBinders expr
 323   = (tvs, ids, body)
 324   where
 325     (tvs, body1) = collectTyBinders expr
 326     (ids, body)  = collectValBinders body1
 327
 328 collectTyBinders expr
 329   = go [] expr
 330   where
 331     go tvs (Lam b e) | isTyVar b = go (b:tvs) e
 332     go tvs e                     = (reverse tvs, e)
 333
 334 collectValBinders expr
 335   = go [] expr
 336   where
 337     go ids (Lam b e) | isId b = go (b:ids) e
 338     go ids body               = (reverse ids, body)
 339 \end{code}
 340
 341
 342 @collectArgs@ takes an application expression, returning the function
 343 and the arguments to which it is applied.
 344
 345 \begin{code}
 346 collectArgs :: Expr b -> (Expr b, [Arg b])
 347 collectArgs expr
 348   = go expr []
 349   where
 350     go (App f a) as = go f (a:as)
 351     go e         as = (e, as)
 352 \end{code}
 353
 354 coreExprCc gets the cost centre enclosing an expression, if any.
 355 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
 356
 357 \begin{code}
 358 coreExprCc :: Expr b -> CostCentre
 359 coreExprCc (Note (SCC cc) e)   = cc
 360 coreExprCc (Note other_note e) = coreExprCc e
 361 coreExprCc (Lam _ e)           = coreExprCc e
 362 coreExprCc other               = noCostCentre
 363 \end{code}
 364
 365
 366 %************************************************************************
 367 %*                                                                      *
 368 \subsection{Predicates}
 369 %*                                                                      *
 370 %************************************************************************
 371
 372 \begin{code}
 373 isValArg (Type _) = False
 374 isValArg other    = True
 375
 376 isTypeArg (Type _) = True
 377 isTypeArg other    = False
 378
 379 valBndrCount :: [CoreBndr] -> Int
 380 valBndrCount []                   = 0
 381 valBndrCount (b : bs) | isId b    = 1 + valBndrCount bs
 382                       | otherwise = valBndrCount bs
 383
 384 valArgCount :: [Arg b] -> Int
 385 valArgCount []              = 0
 386 valArgCount (Type _ : args) = valArgCount args
 387 valArgCount (other  : args) = 1 + valArgCount args
 388 \end{code}
 389
 390
 391 %************************************************************************
 392 %*                                                                      *
 393 \subsection{Seq stuff}
 394 %*                                                                      *
 395 %************************************************************************
 396
 397 \begin{code}
 398 seqExpr :: CoreExpr -> ()
 399 seqExpr (Var v)       = v `seq` ()
 400 seqExpr (Con c as)    = seqExprs as
 401 seqExpr (App f a)     = seqExpr f `seq` seqExpr a
 402 seqExpr (Lam b e)     = seqBndr b `seq` seqExpr e
 403 seqExpr (Let b e)     = seqBind b `seq` seqExpr e
 404 seqExpr (Case e b as) = seqExpr e `seq` seqBndr b `seq` seqAlts as
 405 seqExpr (Note n e)    = seqNote n `seq` seqExpr e
 406 seqExpr (Type t)      = seqType t
 407
 408 seqExprs [] = ()
 409 seqExprs (e:es) = seqExpr e `seq` seqExprs es
 410
 411 seqNote (Coerce t1 t2) = seqType t1 `seq` seqType t2
 412 seqNote other          = ()
 413
 414 seqBndr b = b `seq` ()
 415
 416 seqBndrs [] = ()
 417 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
 418
 419 seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
 420 seqBind (Rec prs)    = seqPairs prs
 421
 422 seqPairs [] = ()
 423 seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
 424
 425 seqAlts [] = ()
 426 seqAlts ((c,bs,e):alts) = seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
 427
 428 seqRules :: CoreRules -> ()
 429 seqRules (Rules rules fvs) = seq_rules rules `seq` seqVarSet fvs
 430
 431 seq_rules [] = ()
 432 seq_rules (Rule fs bs es e : rules) = seqBndrs bs `seq` seqExprs (e:es) `seq` seq_rules rules
 433 \end{code}
 434
 435 \begin{code}
 436 coreBindsSize :: [CoreBind] -> Int
 437 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
 438
 439 exprSize :: CoreExpr -> Int
 440         -- A measure of the size of the expressions
 441         -- It also forces the expression pretty drastically as a side effect
 442 exprSize (Var v)       = varSize v
 443 exprSize (Con c as)    = c `seq` exprsSize as
 444 exprSize (App f a)     = exprSize f + exprSize a
 445 exprSize (Lam b e)     = varSize b + exprSize e
 446 exprSize (Let b e)     = bindSize b + exprSize e
 447 exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0  as
 448 exprSize (Note n e)    = exprSize e
 449 exprSize (Type t)      = seqType t `seq` 1
 450
 451 exprsSize = foldr ((+) . exprSize) 0
 452
 453 varSize :: IdOrTyVar -> Int
 454 varSize b | isTyVar b = 1
 455           | otherwise = seqType (idType b)              `seq`
 456                         megaSeqIdInfo (idInfo b)        `seq`
 457                         1
 458
 459 varsSize = foldr ((+) . varSize) 0
 460
 461 bindSize (NonRec b e) = varSize b + exprSize e
 462 bindSize (Rec prs)    = foldr ((+) . pairSize) 0 prs
 463
 464 pairSize (b,e) = varSize b + exprSize e
 465
 466 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
 467 \end{code}
 468
 469
 470 %************************************************************************
 471 %*                                                                      *
 472 \subsection{Annotated core; annotation at every node in the tree}
 473 %*                                                                      *
 474 %************************************************************************
 475
 476 \begin{code}
 477 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
 478
 479 data AnnExpr' bndr annot
 480   = AnnVar      Id
 481   | AnnCon      Con [AnnExpr bndr annot]
 482   | AnnLam      bndr (AnnExpr bndr annot)
 483   | AnnApp      (AnnExpr bndr annot) (AnnExpr bndr annot)
 484   | AnnCase     (AnnExpr bndr annot) bndr [AnnAlt bndr annot]
 485   | AnnLet      (AnnBind bndr annot) (AnnExpr bndr annot)
 486   | AnnNote     Note (AnnExpr bndr annot)
 487   | AnnType     Type
 488
 489 type AnnAlt bndr annot = (Con, [bndr], AnnExpr bndr annot)
 490
 491 data AnnBind bndr annot
 492   = AnnNonRec bndr (AnnExpr bndr annot)
 493   | AnnRec    [(bndr, AnnExpr bndr annot)]
 494 \end{code}
 495
 496 \begin{code}
 497 deAnnotate :: AnnExpr bndr annot -> Expr bndr
 498
 499 deAnnotate (_, AnnType  t)          = Type t
 500 deAnnotate (_, AnnVar   v)          = Var v
 501 deAnnotate (_, AnnCon   con args)   = Con con (map deAnnotate args)
 502 deAnnotate (_, AnnLam   binder body)= Lam binder (deAnnotate body)
 503 deAnnotate (_, AnnApp   fun arg)    = App (deAnnotate fun) (deAnnotate arg)
 504 deAnnotate (_, AnnNote  note body)  = Note note (deAnnotate body)
 505
 506 deAnnotate (_, AnnLet bind body)
 507   = Let (deAnnBind bind) (deAnnotate body)
 508   where
 509     deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
 510     deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
 511
 512 deAnnotate (_, AnnCase scrut v alts)
 513   = Case (deAnnotate scrut) v (map deAnnAlt alts)
 514   where
 515     deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
 516 \end{code}
 517