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