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