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, 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 \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
  96 type CoreArg  = Arg  CoreBndr
  97 type CoreBind = Bind CoreBndr
  98 type CoreAlt  = Alt  CoreBndr
  99 type CoreNote = Note
 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)
 108 type TaggedExpr t = Expr (Tagged t)
 109 type TaggedArg  t = Arg  (Tagged t)
 110 type TaggedAlt  t = Alt  (Tagged t)
 111 \end{code}
 112
 113
 114 %************************************************************************
 115 %*                                                                      *
 116 \subsection{Core-constructing functions with checking}
 117 %*                                                                      *
 118 %************************************************************************
 119
 120 \begin{code}
 121 mkApps    :: Expr b -> [Arg b]  -> Expr b
 122 mkTyApps  :: Expr b -> [Type]   -> Expr b
 123 mkValApps :: Expr b -> [Expr b] -> Expr b
 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
 130 mkStringLit :: String  -> Expr b
 131 mkConApp    :: DataCon -> [Arg b] -> Expr b
 132 mkPrimApp   :: PrimOp  -> [Arg b] -> Expr b
 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 \begin{code}
 148 mkLams :: [b] -> Expr b -> Expr b
 149 mkLams binders body = foldr Lam body binders
 150 \end{code}
 151
 152 \begin{code}
 153 mkLets :: [Bind b] -> Expr b -> Expr b
 154 mkLets binds body = foldr Let body binds
 155
 156 mkLetBinds :: [CoreBind] -> CoreExpr -> CoreExpr
 157 -- mkLetBinds is like mkLets, but it uses bindNonRec to
 158 -- make a case binding for unlifted things
 159 mkLetBinds []                   body = body
 160 mkLetBinds (NonRec b r : binds) body = bindNonRec b r (mkLetBinds binds body)
 161 mkLetBinds (bind       : binds) body = Let bind (mkLetBinds binds body)
 162
 163 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
 164 -- (bindNonRec x r b) produces either
 165 --      let x = r in b
 166 -- or
 167 --      case r of x { _DEFAULT_ -> b }
 168 --
 169 -- depending on whether x is unlifted or not
 170 bindNonRec bndr rhs body
 171   | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
 172   | otherwise                    = Let (NonRec bndr rhs) body
 173
 174 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
 175 mkIfThenElse guard then_expr else_expr
 176   = Case guard (mkWildId boolTy)
 177          [ (DataCon trueDataCon,  [], then_expr),
 178            (DataCon falseDataCon, [], else_expr) ]
 179 \end{code}
 180
 181 mkNote removes redundant coercions, and SCCs where possible
 182
 183 \begin{code}
 184 mkNote :: Note -> Expr b -> Expr b
 185 mkNote (Coerce to_ty1 from_ty1) (Note (Coerce to_ty2 from_ty2) expr)
 186  = ASSERT( from_ty1 == to_ty2 )
 187    mkNote (Coerce to_ty1 from_ty2) expr
 188
 189 mkNote (SCC cc1) expr@(Note (SCC cc2) _)
 190   | isDupdCC cc1        -- Discard the outer SCC provided we don't need
 191   = expr                -- to track its entry count
 192
 193 mkNote note@(SCC cc1) expr@(Lam x e)    -- Move _scc_ inside lambda
 194   = Lam x (mkNote note e)
 195
 196 -- Slide InlineCall in around the function
 197 mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
 198 mkNote InlineCall (Var v)   = Note InlineCall (Var v)
 199 mkNote InlineCall expr      = expr
 200
 201 mkNote note expr = Note note expr
 202 \end{code}
 203
 204 %************************************************************************
 205 %*                                                                      *
 206 \subsection{Simple access functions}
 207 %*                                                                      *
 208 %************************************************************************
 209
 210 \begin{code}
 211 bindersOf  :: Bind b -> [b]
 212 bindersOf (NonRec binder _) = [binder]
 213 bindersOf (Rec pairs)       = [binder | (binder, _) <- pairs]
 214
 215 rhssOfBind :: Bind b -> [Expr b]
 216 rhssOfBind (NonRec _ rhs) = [rhs]
 217 rhssOfBind (Rec pairs)    = [rhs | (_,rhs) <- pairs]
 218
 219 rhssOfAlts :: [Alt b] -> [Expr b]
 220 rhssOfAlts alts = [e | (_,_,e) <- alts]
 221
 222 isDeadBinder :: CoreBndr -> Bool
 223 isDeadBinder bndr | isId bndr = case getInlinePragma bndr of
 224                                         IAmDead -> True
 225                                         other   -> False
 226                   | otherwise = False   -- TyVars count as not dead
 227 \end{code}
 228
 229 We often want to strip off leading lambdas before getting down to
 230 business.  @collectBinders@ is your friend.
 231
 232 We expect (by convention) type-, and value- lambdas in that
 233 order.
 234
 235 \begin{code}
 236 collectBinders         :: Expr b -> ([b],         Expr b)
 237 collectTyBinders       :: CoreExpr -> ([TyVar],     CoreExpr)
 238 collectValBinders      :: CoreExpr -> ([Id],        CoreExpr)
 239 collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
 240
 241 collectTyAndValBinders expr
 242   = (tvs, ids, body)
 243   where
 244     (tvs, body1) = collectTyBinders expr
 245     (ids, body)  = collectValBinders body1
 246
 247 collectBinders expr
 248   = go [] expr
 249   where
 250     go tvs (Lam b e) = go (b:tvs) e
 251     go tvs e         = (reverse tvs, e)
 252
 253 collectTyBinders expr
 254   = go [] expr
 255   where
 256     go tvs (Lam b e) | isTyVar b = go (b:tvs) e
 257     go tvs e                     = (reverse tvs, e)
 258
 259 collectValBinders expr
 260   = go [] expr
 261   where
 262     go ids (Lam b e) | isId b = go (b:ids) e
 263     go ids body               = (reverse ids, body)
 264 \end{code}
 265
 266
 267 @collectArgs@ takes an application expression, returning the function
 268 and the arguments to which it is applied.
 269
 270 \begin{code}
 271 collectArgs :: Expr b -> (Expr b, [Arg b])
 272 collectArgs expr
 273   = go expr []
 274   where
 275     go (App f a) as = go f (a:as)
 276     go e         as = (e, as)
 277 \end{code}
 278
 279 coreExprCc gets the cost centre enclosing an expression, if any.
 280 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
 281
 282 \begin{code}
 283 coreExprCc :: Expr b -> CostCentre
 284 coreExprCc (Note (SCC cc) e)   = cc
 285 coreExprCc (Note other_note e) = coreExprCc e
 286 coreExprCc (Lam _ e)           = coreExprCc e
 287 coreExprCc other               = noCostCentre
 288 \end{code}
 289
 290
 291 %************************************************************************
 292 %*                                                                      *
 293 \subsection{Predicates}
 294 %*                                                                      *
 295 %************************************************************************
 296
 297 \begin{code}
 298 isValArg (Type _) = False
 299 isValArg other    = True
 300
 301 isTypeArg (Type _) = True
 302 isTypeArg other    = False
 303
 304 valArgCount :: [Arg b] -> Int
 305 valArgCount []              = 0
 306 valArgCount (Type _ : args) = valArgCount args
 307 valArgCount (other  : args) = 1 + valArgCount args
 308 \end{code}
 309
 310
 311 %************************************************************************
 312 %*                                                                      *
 313 \subsection{Annotated core; annotation at every node in the tree}
 314 %*                                                                      *
 315 %************************************************************************
 316
 317 \begin{code}
 318 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
 319
 320 data AnnExpr' bndr annot
 321   = AnnVar      Id
 322   | AnnCon      Con [AnnExpr bndr annot]
 323   | AnnLam      bndr (AnnExpr bndr annot)
 324   | AnnApp      (AnnExpr bndr annot) (AnnExpr bndr annot)
 325   | AnnCase     (AnnExpr bndr annot) bndr [AnnAlt bndr annot]
 326   | AnnLet      (AnnBind bndr annot) (AnnExpr bndr annot)
 327   | AnnNote     Note (AnnExpr bndr annot)
 328   | AnnType     Type
 329
 330 type AnnAlt bndr annot = (Con, [bndr], AnnExpr bndr annot)
 331
 332 data AnnBind bndr annot
 333   = AnnNonRec bndr (AnnExpr bndr annot)
 334   | AnnRec    [(bndr, AnnExpr bndr annot)]
 335 \end{code}
 336
 337 \begin{code}
 338 deAnnotate :: AnnExpr bndr annot -> Expr bndr
 339
 340 deAnnotate (_, AnnType  t)          = Type t
 341 deAnnotate (_, AnnVar   v)          = Var v
 342 deAnnotate (_, AnnCon   con args)   = Con con (map deAnnotate args)
 343 deAnnotate (_, AnnLam   binder body)= Lam binder (deAnnotate body)
 344 deAnnotate (_, AnnApp   fun arg)    = App (deAnnotate fun) (deAnnotate arg)
 345 deAnnotate (_, AnnNote  note body)  = Note note (deAnnotate body)
 346
 347 deAnnotate (_, AnnLet bind body)
 348   = Let (deAnnBind bind) (deAnnotate body)
 349   where
 350     deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
 351     deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
 352
 353 deAnnotate (_, AnnCase scrut v alts)
 354   = Case (deAnnotate scrut) v (map deAnnAlt alts)
 355   where
 356     deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
 357 \end{code}
 358