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         -- 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 mkVarApps :: CoreExpr -> [IdOrTyVar] -> CoreExpr
 175
 176 mkApps    f args = foldl App                       f args
 177 mkTyApps  f args = foldl (\ e a -> App e (Type a)) f args
 178 mkValApps f args = foldl (\ e a -> App e a)        f args
 179 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
 180
 181 mkLit       :: Literal -> Expr b
 182 mkStringLit :: String  -> Expr b
 183 mkConApp    :: DataCon -> [Arg b] -> Expr b
 184 mkPrimApp   :: PrimOp  -> [Arg b] -> Expr b
 185
 186 mkLit lit         = Con (Literal lit) []
 187 mkStringLit str   = Con (Literal (NoRepStr (_PK_ str) stringTy)) []
 188 mkConApp con args = Con (DataCon con) args
 189 mkPrimApp op args = Con (PrimOp op)   args
 190
 191 varToCoreExpr :: CoreBndr -> CoreExpr
 192 varToCoreExpr v | isId v    = Var v
 193                 | otherwise = Type (mkTyVarTy v)
 194 \end{code}
 195
 196 \begin{code}
 197 mkLams :: [b] -> Expr b -> Expr b
 198 mkLams binders body = foldr Lam body binders
 199 \end{code}
 200
 201 \begin{code}
 202 mkLets :: [Bind b] -> Expr b -> Expr b
 203 mkLets binds body = foldr Let body binds
 204
 205 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
 206 -- (bindNonRec x r b) produces either
 207 --      let x = r in b
 208 -- or
 209 --      case r of x { _DEFAULT_ -> b }
 210 --
 211 -- depending on whether x is unlifted or not
 212 -- It's used by the desugarer to avoid building bindings
 213 -- that give Core Lint a heart attack.  Actually the simplifier
 214 -- deals with them perfectly well.
 215 bindNonRec bndr rhs body
 216   | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
 217   | otherwise                    = Let (NonRec bndr rhs) body
 218
 219 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
 220 mkIfThenElse guard then_expr else_expr
 221   = Case guard (mkWildId boolTy)
 222          [ (DataCon trueDataCon,  [], then_expr),
 223            (DataCon falseDataCon, [], else_expr) ]
 224 \end{code}
 225
 226 mkNote removes redundant coercions, and SCCs where possible
 227
 228 \begin{code}
 229 mkNote :: Note -> Expr b -> Expr b
 230 mkNote (Coerce to_ty1 from_ty1) (Note (Coerce to_ty2 from_ty2) expr)
 231  = ASSERT( from_ty1 == to_ty2 )
 232    mkNote (Coerce to_ty1 from_ty2) expr
 233
 234 mkNote (SCC cc1) expr@(Note (SCC cc2) _)
 235   | isDupdCC cc1        -- Discard the outer SCC provided we don't need
 236   = expr                -- to track its entry count
 237
 238 mkNote note@(SCC cc1) expr@(Lam x e)    -- Move _scc_ inside lambda
 239   = Lam x (mkNote note e)
 240
 241 -- Drop trivial InlineMe's
 242 mkNote InlineMe expr@(Con _ _) = expr
 243 mkNote InlineMe expr@(Var v)   = expr
 244
 245 -- Slide InlineCall in around the function
 246 --      No longer necessary I think (SLPJ Apr 99)
 247 -- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
 248 -- mkNote InlineCall (Var v)   = Note InlineCall (Var v)
 249 -- mkNote InlineCall expr      = expr
 250
 251 mkNote note expr = Note note expr
 252 \end{code}
 253
 254 %************************************************************************
 255 %*                                                                      *
 256 \subsection{Simple access functions}
 257 %*                                                                      *
 258 %************************************************************************
 259
 260 \begin{code}
 261 bindersOf  :: Bind b -> [b]
 262 bindersOf (NonRec binder _) = [binder]
 263 bindersOf (Rec pairs)       = [binder | (binder, _) <- pairs]
 264
 265 bindersOfBinds :: [Bind b] -> [b]
 266 bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
 267
 268 rhssOfBind :: Bind b -> [Expr b]
 269 rhssOfBind (NonRec _ rhs) = [rhs]
 270 rhssOfBind (Rec pairs)    = [rhs | (_,rhs) <- pairs]
 271
 272 rhssOfAlts :: [Alt b] -> [Expr b]
 273 rhssOfAlts alts = [e | (_,_,e) <- alts]
 274
 275 isDeadBinder :: CoreBndr -> Bool
 276 isDeadBinder bndr | isId bndr = case getInlinePragma bndr of
 277                                         IAmDead -> True
 278                                         other   -> False
 279                   | otherwise = False   -- TyVars count as not dead
 280
 281 flattenBinds :: [Bind b] -> [(b, Expr b)]       -- Get all the lhs/rhs pairs
 282 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
 283 flattenBinds (Rec prs1   : binds) = prs1 ++ flattenBinds binds
 284 flattenBinds []                   = []
 285 \end{code}
 286
 287 We often want to strip off leading lambdas before getting down to
 288 business.  @collectBinders@ is your friend.
 289
 290 We expect (by convention) type-, and value- lambdas in that
 291 order.
 292
 293 \begin{code}
 294 collectBinders               :: Expr b -> ([b],         Expr b)
 295 collectBindersIgnoringNotes  :: Expr b -> ([b],         Expr b)
 296 collectTyBinders             :: CoreExpr -> ([TyVar],     CoreExpr)
 297 collectValBinders            :: CoreExpr -> ([Id],        CoreExpr)
 298 collectTyAndValBinders       :: CoreExpr -> ([TyVar], [Id], CoreExpr)
 299
 300 collectBinders expr
 301   = go [] expr
 302   where
 303     go bs (Lam b e) = go (b:bs) e
 304     go bs e          = (reverse bs, e)
 305
 306 -- This one ignores notes.  It's used in CoreUnfold and StrAnal
 307 -- when we aren't going to put the expression back together from
 308 -- the pieces, so we don't mind losing the Notes
 309 collectBindersIgnoringNotes expr
 310   = go [] expr
 311   where
 312     go bs (Lam b e)  = go (b:bs) e
 313     go bs (Note _ e) = go    bs  e
 314     go bs e          = (reverse bs, e)
 315
 316 collectTyAndValBinders expr
 317   = (tvs, ids, body)
 318   where
 319     (tvs, body1) = collectTyBinders expr
 320     (ids, body)  = collectValBinders body1
 321
 322 collectTyBinders expr
 323   = go [] expr
 324   where
 325     go tvs (Lam b e) | isTyVar b = go (b:tvs) e
 326     go tvs e                     = (reverse tvs, e)
 327
 328 collectValBinders expr
 329   = go [] expr
 330   where
 331     go ids (Lam b e) | isId b = go (b:ids) e
 332     go ids body               = (reverse ids, body)
 333 \end{code}
 334
 335
 336 @collectArgs@ takes an application expression, returning the function
 337 and the arguments to which it is applied.
 338
 339 \begin{code}
 340 collectArgs :: Expr b -> (Expr b, [Arg b])
 341 collectArgs expr
 342   = go expr []
 343   where
 344     go (App f a) as = go f (a:as)
 345     go e         as = (e, as)
 346 \end{code}
 347
 348 coreExprCc gets the cost centre enclosing an expression, if any.
 349 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
 350
 351 \begin{code}
 352 coreExprCc :: Expr b -> CostCentre
 353 coreExprCc (Note (SCC cc) e)   = cc
 354 coreExprCc (Note other_note e) = coreExprCc e
 355 coreExprCc (Lam _ e)           = coreExprCc e
 356 coreExprCc other               = noCostCentre
 357 \end{code}
 358
 359
 360 %************************************************************************
 361 %*                                                                      *
 362 \subsection{Predicates}
 363 %*                                                                      *
 364 %************************************************************************
 365
 366 \begin{code}
 367 isValArg (Type _) = False
 368 isValArg other    = True
 369
 370 isTypeArg (Type _) = True
 371 isTypeArg other    = False
 372
 373 valBndrCount :: [CoreBndr] -> Int
 374 valBndrCount []                   = 0
 375 valBndrCount (b : bs) | isId b    = 1 + valBndrCount bs
 376                       | otherwise = valBndrCount bs
 377
 378 valArgCount :: [Arg b] -> Int
 379 valArgCount []              = 0
 380 valArgCount (Type _ : args) = valArgCount args
 381 valArgCount (other  : args) = 1 + valArgCount args
 382 \end{code}
 383
 384
 385 %************************************************************************
 386 %*                                                                      *
 387 \subsection{Annotated core; annotation at every node in the tree}
 388 %*                                                                      *
 389 %************************************************************************
 390
 391 \begin{code}
 392 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
 393
 394 data AnnExpr' bndr annot
 395   = AnnVar      Id
 396   | AnnCon      Con [AnnExpr bndr annot]
 397   | AnnLam      bndr (AnnExpr bndr annot)
 398   | AnnApp      (AnnExpr bndr annot) (AnnExpr bndr annot)
 399   | AnnCase     (AnnExpr bndr annot) bndr [AnnAlt bndr annot]
 400   | AnnLet      (AnnBind bndr annot) (AnnExpr bndr annot)
 401   | AnnNote     Note (AnnExpr bndr annot)
 402   | AnnType     Type
 403
 404 type AnnAlt bndr annot = (Con, [bndr], AnnExpr bndr annot)
 405
 406 data AnnBind bndr annot
 407   = AnnNonRec bndr (AnnExpr bndr annot)
 408   | AnnRec    [(bndr, AnnExpr bndr annot)]
 409 \end{code}
 410
 411 \begin{code}
 412 deAnnotate :: AnnExpr bndr annot -> Expr bndr
 413
 414 deAnnotate (_, AnnType  t)          = Type t
 415 deAnnotate (_, AnnVar   v)          = Var v
 416 deAnnotate (_, AnnCon   con args)   = Con con (map deAnnotate args)
 417 deAnnotate (_, AnnLam   binder body)= Lam binder (deAnnotate body)
 418 deAnnotate (_, AnnApp   fun arg)    = App (deAnnotate fun) (deAnnotate arg)
 419 deAnnotate (_, AnnNote  note body)  = Note note (deAnnotate body)
 420
 421 deAnnotate (_, AnnLet bind body)
 422   = Let (deAnnBind bind) (deAnnotate body)
 423   where
 424     deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
 425     deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
 426
 427 deAnnotate (_, AnnCase scrut v alts)
 428   = Case (deAnnotate scrut) v (map deAnnAlt alts)
 429   where
 430     deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
 431 \end{code}
 432