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