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