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, mkLetBinds, mkLams,
  13         mkApps, mkTyApps, mkValApps,
  14         mkLit, mkStringLit, mkConApp, mkPrimApp, mkNote, mkNilExpr,
  15         bindNonRec, mkIfThenElse, varToCoreExpr,
  16
  17         bindersOf, rhssOfBind, rhssOfAlts, isDeadBinder, isTyVar, isId,
  18         collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
  19         collectArgs,
  20         coreExprCc,
  21
  22         isValArg, isTypeArg, valArgCount,
  23
  24         -- Annotated expressions
  25         AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, deAnnotate
  26     ) where
  27
  28 #include "HsVersions.h"
  29
  30 import TysWiredIn       ( boolTy, stringTy, nilDataCon )
  31 import CostCentre       ( CostCentre, isDupdCC, noCostCentre )
  32 import Var              ( Var, Id, TyVar, IdOrTyVar, isTyVar, isId, idType )
  33 import Id               ( mkWildId, getInlinePragma )
  34 import Type             ( Type, UsageAnn, mkTyVarTy, isUnLiftedType )
  35 import IdInfo           ( InlinePragInfo(..) )
  36 import Const            ( Con(..), DataCon, Literal(NoRepStr), PrimOp )
  37 import TysWiredIn       ( trueDataCon, falseDataCon )
  38 import Outputable
  39 \end{code}
  40
  41 %************************************************************************
  42 %*                                                                      *
  43 \subsection{The main data types}
  44 %*                                                                      *
  45 %************************************************************************
  46
  47 These data types are the heart of the compiler
  48
  49 \begin{code}
  50 data Expr b     -- "b" for the type of binders,
  51   = Var   Id
  52   | Con   Con [Arg b]           -- Guaranteed saturated
  53                                 -- The Con can be a DataCon, Literal, PrimOP
  54                                 -- but cannot be DEFAULT
  55   | App   (Expr b) (Arg b)
  56   | Lam   b (Expr b)
  57   | Let   (Bind b) (Expr b)
  58   | Case  (Expr b) b [Alt b]    -- Binder gets bound to value of scrutinee
  59                                 -- DEFAULT case must be last, if it occurs at all
  60   | Note  Note (Expr b)
  61   | Type  Type                  -- This should only show up at the top
  62                                 -- level of an Arg
  63
  64 type Arg b = Expr b             -- Can be a Type
  65
  66 type Alt b = (Con, [b], Expr b)
  67         -- (DEFAULT, [], rhs) is the default alternative
  68         -- The Con can be a Literal, DataCon, or DEFAULT, but cannot be PrimOp
  69
  70 data Bind b = NonRec b (Expr b)
  71               | Rec [(b, (Expr b))]
  72
  73 data Note
  74   = SCC CostCentre
  75
  76   | Coerce
  77         Type            -- The to-type:   type of whole coerce expression
  78         Type            -- The from-type: type of enclosed expression
  79
  80   | InlineCall          -- Instructs simplifier to inline
  81                         -- the enclosed call
  82
  83   | TermUsg             -- A term-level usage annotation
  84         UsageAnn        -- (should not be a variable except during UsageSP inference)
  85 \end{code}
  86
  87
  88 %************************************************************************
  89 %*                                                                      *
  90 \subsection{Useful synonyms}
  91 %*                                                                      *
  92 %************************************************************************
  93
  94 The common case
  95
  96 \begin{code}
  97 type CoreBndr = IdOrTyVar
  98 type CoreExpr = Expr CoreBndr
  99 type CoreArg  = Arg  CoreBndr
 100 type CoreBind = Bind CoreBndr
 101 type CoreAlt  = Alt  CoreBndr
 102 type CoreNote = Note
 103 \end{code}
 104
 105 Binders are ``tagged'' with a \tr{t}:
 106
 107 \begin{code}
 108 type Tagged t = (CoreBndr, t)
 109
 110 type TaggedBind t = Bind (Tagged t)
 111 type TaggedExpr t = Expr (Tagged t)
 112 type TaggedArg  t = Arg  (Tagged t)
 113 type TaggedAlt  t = Alt  (Tagged t)
 114 \end{code}
 115
 116
 117 %************************************************************************
 118 %*                                                                      *
 119 \subsection{Core-constructing functions with checking}
 120 %*                                                                      *
 121 %************************************************************************
 122
 123 \begin{code}
 124 mkApps    :: Expr b -> [Arg b]  -> Expr b
 125 mkTyApps  :: Expr b -> [Type]   -> Expr b
 126 mkValApps :: Expr b -> [Expr b] -> Expr b
 127
 128 mkApps    f args = foldl App                       f args
 129 mkTyApps  f args = foldl (\ e a -> App e (Type a)) f args
 130 mkValApps f args = foldl (\ e a -> App e a)        f args
 131
 132 mkLit       :: Literal -> Expr b
 133 mkStringLit :: String  -> Expr b
 134 mkConApp    :: DataCon -> [Arg b] -> Expr b
 135 mkPrimApp   :: PrimOp  -> [Arg b] -> Expr b
 136
 137 mkLit lit         = Con (Literal lit) []
 138 mkStringLit str   = Con (Literal (NoRepStr (_PK_ str) stringTy)) []
 139 mkConApp con args = Con (DataCon con) args
 140 mkPrimApp op args = Con (PrimOp op)   args
 141
 142 mkNilExpr :: Type -> CoreExpr
 143 mkNilExpr ty = Con (DataCon nilDataCon) [Type ty]
 144
 145 varToCoreExpr :: CoreBndr -> CoreExpr
 146 varToCoreExpr v | isId v    = Var v
 147                 | otherwise = Type (mkTyVarTy v)
 148 \end{code}
 149
 150 \begin{code}
 151 mkLams :: [b] -> Expr b -> Expr b
 152 mkLams binders body = foldr Lam body binders
 153 \end{code}
 154
 155 \begin{code}
 156 mkLets :: [Bind b] -> Expr b -> Expr b
 157 mkLets binds body = foldr Let body binds
 158
 159 mkLetBinds :: [CoreBind] -> CoreExpr -> CoreExpr
 160 -- mkLetBinds is like mkLets, but it uses bindNonRec to
 161 -- make a case binding for unlifted things
 162 mkLetBinds []                   body = body
 163 mkLetBinds (NonRec b r : binds) body = bindNonRec b r (mkLetBinds binds body)
 164 mkLetBinds (bind       : binds) body = Let bind (mkLetBinds binds body)
 165
 166 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
 167 -- (bindNonRec x r b) produces either
 168 --      let x = r in b
 169 -- or
 170 --      case r of x { _DEFAULT_ -> b }
 171 --
 172 -- depending on whether x is unlifted or not
 173 bindNonRec bndr rhs body
 174   | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
 175   | otherwise                    = Let (NonRec bndr rhs) body
 176
 177 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
 178 mkIfThenElse guard then_expr else_expr
 179   = Case guard (mkWildId boolTy)
 180          [ (DataCon trueDataCon,  [], then_expr),
 181            (DataCon falseDataCon, [], else_expr) ]
 182 \end{code}
 183
 184 mkNote removes redundant coercions, and SCCs where possible
 185
 186 \begin{code}
 187 mkNote :: Note -> Expr b -> Expr b
 188 mkNote (Coerce to_ty1 from_ty1) (Note (Coerce to_ty2 from_ty2) expr)
 189  = ASSERT( from_ty1 == to_ty2 )
 190    mkNote (Coerce to_ty1 from_ty2) expr
 191
 192 mkNote (SCC cc1) expr@(Note (SCC cc2) _)
 193   | isDupdCC cc1        -- Discard the outer SCC provided we don't need
 194   = expr                -- to track its entry count
 195
 196 mkNote note@(SCC cc1) expr@(Lam x e)    -- Move _scc_ inside lambda
 197   = Lam x (mkNote note e)
 198
 199 -- Slide InlineCall in around the function
 200 mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
 201 mkNote InlineCall (Var v)   = Note InlineCall (Var v)
 202 mkNote InlineCall expr      = expr
 203
 204 mkNote note expr = Note note expr
 205 \end{code}
 206
 207 %************************************************************************
 208 %*                                                                      *
 209 \subsection{Simple access functions}
 210 %*                                                                      *
 211 %************************************************************************
 212
 213 \begin{code}
 214 bindersOf  :: Bind b -> [b]
 215 bindersOf (NonRec binder _) = [binder]
 216 bindersOf (Rec pairs)       = [binder | (binder, _) <- pairs]
 217
 218 rhssOfBind :: Bind b -> [Expr b]
 219 rhssOfBind (NonRec _ rhs) = [rhs]
 220 rhssOfBind (Rec pairs)    = [rhs | (_,rhs) <- pairs]
 221
 222 rhssOfAlts :: [Alt b] -> [Expr b]
 223 rhssOfAlts alts = [e | (_,_,e) <- alts]
 224
 225 isDeadBinder :: CoreBndr -> Bool
 226 isDeadBinder bndr | isId bndr = case getInlinePragma bndr of
 227                                         IAmDead -> True
 228                                         other   -> False
 229                   | otherwise = False   -- TyVars count as not dead
 230 \end{code}
 231
 232 We often want to strip off leading lambdas before getting down to
 233 business.  @collectBinders@ is your friend.
 234
 235 We expect (by convention) type-, and value- lambdas in that
 236 order.
 237
 238 \begin{code}
 239 collectBinders         :: Expr b -> ([b],         Expr b)
 240 collectTyBinders       :: CoreExpr -> ([TyVar],     CoreExpr)
 241 collectValBinders      :: CoreExpr -> ([Id],        CoreExpr)
 242 collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
 243
 244 collectTyAndValBinders expr
 245   = (tvs, ids, body)
 246   where
 247     (tvs, body1) = collectTyBinders expr
 248     (ids, body)  = collectValBinders body1
 249
 250 collectBinders expr
 251   = go [] expr
 252   where
 253     go tvs (Lam b e) = go (b:tvs) e
 254     go tvs e         = (reverse tvs, e)
 255
 256 collectTyBinders expr
 257   = go [] expr
 258   where
 259     go tvs (Lam b e) | isTyVar b = go (b:tvs) e
 260     go tvs e                     = (reverse tvs, e)
 261
 262 collectValBinders expr
 263   = go [] expr
 264   where
 265     go ids (Lam b e) | isId b = go (b:ids) e
 266     go ids body               = (reverse ids, body)
 267 \end{code}
 268
 269
 270 @collectArgs@ takes an application expression, returning the function
 271 and the arguments to which it is applied.
 272
 273 \begin{code}
 274 collectArgs :: Expr b -> (Expr b, [Arg b])
 275 collectArgs expr
 276   = go expr []
 277   where
 278     go (App f a) as = go f (a:as)
 279     go e         as = (e, as)
 280 \end{code}
 281
 282 coreExprCc gets the cost centre enclosing an expression, if any.
 283 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
 284
 285 \begin{code}
 286 coreExprCc :: Expr b -> CostCentre
 287 coreExprCc (Note (SCC cc) e)   = cc
 288 coreExprCc (Note other_note e) = coreExprCc e
 289 coreExprCc (Lam _ e)           = coreExprCc e
 290 coreExprCc other               = noCostCentre
 291 \end{code}
 292
 293
 294 %************************************************************************
 295 %*                                                                      *
 296 \subsection{Predicates}
 297 %*                                                                      *
 298 %************************************************************************
 299
 300 \begin{code}
 301 isValArg (Type _) = False
 302 isValArg other    = True
 303
 304 isTypeArg (Type _) = True
 305 isTypeArg other    = False
 306
 307 valArgCount :: [Arg b] -> Int
 308 valArgCount []              = 0
 309 valArgCount (Type _ : args) = valArgCount args
 310 valArgCount (other  : args) = 1 + valArgCount args
 311 \end{code}
 312
 313
 314 %************************************************************************
 315 %*                                                                      *
 316 \subsection{Annotated core; annotation at every node in the tree}
 317 %*                                                                      *
 318 %************************************************************************
 319
 320 \begin{code}
 321 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
 322
 323 data AnnExpr' bndr annot
 324   = AnnVar      Id
 325   | AnnCon      Con [AnnExpr bndr annot]
 326   | AnnLam      bndr (AnnExpr bndr annot)
 327   | AnnApp      (AnnExpr bndr annot) (AnnExpr bndr annot)
 328   | AnnCase     (AnnExpr bndr annot) bndr [AnnAlt bndr annot]
 329   | AnnLet      (AnnBind bndr annot) (AnnExpr bndr annot)
 330   | AnnNote     Note (AnnExpr bndr annot)
 331   | AnnType     Type
 332
 333 type AnnAlt bndr annot = (Con, [bndr], AnnExpr bndr annot)
 334
 335 data AnnBind bndr annot
 336   = AnnNonRec bndr (AnnExpr bndr annot)
 337   | AnnRec    [(bndr, AnnExpr bndr annot)]
 338 \end{code}
 339
 340 \begin{code}
 341 deAnnotate :: AnnExpr bndr annot -> Expr bndr
 342
 343 deAnnotate (_, AnnType  t)          = Type t
 344 deAnnotate (_, AnnVar   v)          = Var v
 345 deAnnotate (_, AnnCon   con args)   = Con con (map deAnnotate args)
 346 deAnnotate (_, AnnLam   binder body)= Lam binder (deAnnotate body)
 347 deAnnotate (_, AnnApp   fun arg)    = App (deAnnotate fun) (deAnnotate arg)
 348 deAnnotate (_, AnnNote  note body)  = Note note (deAnnotate body)
 349
 350 deAnnotate (_, AnnLet bind body)
 351   = Let (deAnnBind bind) (deAnnotate body)
 352   where
 353     deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
 354     deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
 355
 356 deAnnotate (_, AnnCase scrut v alts)
 357   = Case (deAnnotate scrut) v (map deAnnAlt alts)
 358   where
 359     deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
 360 \end{code}
 361