ghc/compiler/coreSyn/CoreUtils.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[CoreUtils]{Utility functions on @Core@ syntax}
   5
   6 \begin{code}
   7 module CoreUtils (
   8         coreExprType, coreAltsType, coreExprCc,
   9
  10         mkCoreIfThenElse,
  11         argToExpr,
  12         unTagBinders, unTagBindersAlts,
  13
  14         maybeErrorApp,
  15         nonErrorRHSs,
  16         squashableDictishCcExpr
  17     ) where
  18
  19 #include "HsVersions.h"
  20
  21 import CoreSyn
  22
  23 import CostCentre       ( isDictCC, CostCentre, noCostCentre )
  24 import MkId             ( mkSysLocal )
  25 import Id               ( idType, isBottomingId,
  26                           mkIdWithNewUniq,
  27                           dataConRepType,
  28                           addOneToIdEnv, growIdEnvList, lookupIdEnv,
  29                           isNullIdEnv, IdEnv, Id
  30                         )
  31 import Literal          ( literalType, Literal(..) )
  32 import Maybes           ( catMaybes, maybeToBool )
  33 import PprCore
  34 import PrimOp           ( primOpType, PrimOp(..) )
  35 import SrcLoc           ( noSrcLoc )
  36 import TyVar            ( cloneTyVar,
  37                           isEmptyTyVarEnv, addToTyVarEnv, TyVarEnv,
  38                           TyVar, GenTyVar
  39                         )
  40 import Type             ( mkFunTy, mkForAllTy, mkTyVarTy,
  41                           splitFunTy_maybe, applyTys, isUnpointedType,
  42                           splitSigmaTy, splitFunTys, instantiateTy,
  43                           Type
  44                         )
  45 import TysWiredIn       ( trueDataCon, falseDataCon )
  46 import Unique           ( Unique )
  47 import BasicTypes       ( Unused )
  48 import UniqSupply       ( returnUs, thenUs,
  49                           mapUs, mapAndUnzipUs, getUnique,
  50                           UniqSM, UniqSupply
  51                         )
  52 import Util             ( zipEqual )
  53 import Outputable
  54
  55 type TypeEnv = TyVarEnv Type
  56 \end{code}
  57
  58 %************************************************************************
  59 %*                                                                      *
  60 \subsection{Find the type of a Core atom/expression}
  61 %*                                                                      *
  62 %************************************************************************
  63
  64 \begin{code}
  65 coreExprType :: CoreExpr -> Type
  66
  67 coreExprType (Var var) = idType   var
  68 coreExprType (Lit lit) = literalType lit
  69
  70 coreExprType (Let _ body)       = coreExprType body
  71 coreExprType (Case _ alts)      = coreAltsType alts
  72
  73 coreExprType (Note (Coerce ty _) e) = ty
  74 coreExprType (Note other_note e)    = coreExprType e
  75
  76 -- a Con is a fully-saturated application of a data constructor
  77 -- a Prim is <ditto> of a PrimOp
  78
  79 coreExprType (Con con args) =
  80 --                            pprTrace "appTyArgs" (hsep [ppr con, semi,
  81 --                                                         ppr con_ty, semi,
  82 --                                                         ppr args]) $
  83                               applyTypeToArgs con_ty args
  84                             where
  85                                 con_ty = dataConRepType con
  86
  87 coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args
  88
  89 coreExprType (Lam (ValBinder binder) expr)
  90   = idType binder `mkFunTy` coreExprType expr
  91
  92 coreExprType (Lam (TyBinder tyvar) expr)
  93   = mkForAllTy tyvar (coreExprType expr)
  94
  95 coreExprType (App expr (TyArg ty))
  96   =     -- Gather type args; more efficient to instantiate the type all at once
  97     go expr [ty]
  98   where
  99     go (App expr (TyArg ty)) tys = go expr (ty:tys)
 100     go expr                  tys = applyTys (coreExprType expr) tys
 101
 102 coreExprType (App expr val_arg)
 103   = ASSERT(isValArg val_arg)
 104     let
 105         fun_ty = coreExprType expr
 106     in
 107     case (splitFunTy_maybe fun_ty) of
 108           Just (_, result_ty) -> result_ty
 109 #ifdef DEBUG
 110           Nothing -> pprPanic "coreExprType:\n"
 111                         (vcat [ppr fun_ty,  ppr (App expr val_arg)])
 112 #endif
 113 \end{code}
 114
 115 \begin{code}
 116 coreAltsType :: CoreCaseAlts -> Type
 117
 118 coreAltsType (AlgAlts [] deflt)         = default_ty deflt
 119 coreAltsType (AlgAlts ((_,_,rhs1):_) _) = coreExprType rhs1
 120
 121 coreAltsType (PrimAlts [] deflt)       = default_ty deflt
 122 coreAltsType (PrimAlts ((_,rhs1):_) _) = coreExprType rhs1
 123
 124 default_ty NoDefault           = panic "coreExprType:Case:default_ty"
 125 default_ty (BindDefault _ rhs) = coreExprType rhs
 126 \end{code}
 127
 128 \begin{code}
 129 applyTypeToArgs op_ty (TyArg ty : args)
 130   =     -- Accumulate type arguments so we can instantiate all at once
 131     applyTypeToArgs (applyTys op_ty tys) rest_args
 132   where
 133     (tys, rest_args)         = go [ty] args
 134     go tys (TyArg ty : args) = go (ty:tys) args
 135     go tys rest_args         = (reverse tys, rest_args)
 136
 137 applyTypeToArgs op_ty (val_or_lit_arg:args)
 138   = case (splitFunTy_maybe op_ty) of
 139         Just (_, res_ty) -> applyTypeToArgs res_ty args
 140
 141 applyTypeToArgs op_ty [] = op_ty
 142 \end{code}
 143
 144 coreExprCc gets the cost centre enclosing an expression, if any.
 145 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
 146
 147 \begin{code}
 148 coreExprCc :: GenCoreExpr val_bdr val_occ flexi -> CostCentre
 149 coreExprCc (Note (SCC cc) e)   = cc
 150 coreExprCc (Note other_note e) = coreExprCc e
 151 coreExprCc (Lam _ e)           = coreExprCc e
 152 coreExprCc other               = noCostCentre
 153 \end{code}
 154
 155 %************************************************************************
 156 %*                                                                      *
 157 \subsection{Routines to manufacture bits of @CoreExpr@}
 158 %*                                                                      *
 159 %************************************************************************
 160
 161 \begin{code}
 162 mkCoreIfThenElse (Var bool) then_expr else_expr
 163     | bool == trueDataCon   = then_expr
 164     | bool == falseDataCon  = else_expr
 165
 166 mkCoreIfThenElse guard then_expr else_expr
 167   = Case guard
 168       (AlgAlts [ (trueDataCon,  [], then_expr),
 169                  (falseDataCon, [], else_expr) ]
 170        NoDefault )
 171 \end{code}
 172
 173 For making @Apps@ and @Lets@, we must take appropriate evasive
 174 action if the thing being bound has unboxed type.  @mkCoApp@ requires
 175 a name supply to do its work.
 176
 177 @mkCoApps@, @mkCoCon@ and @mkCoPrim@ also handle the
 178 arguments-must-be-atoms constraint.
 179
 180 \begin{code}
 181 data CoreArgOrExpr
 182   = AnArg   CoreArg
 183   | AnExpr  CoreExpr
 184
 185 mkCoApps :: CoreExpr -> [CoreArgOrExpr] -> UniqSM CoreExpr
 186 mkCoCon  :: Id       -> [CoreArgOrExpr] -> UniqSM CoreExpr
 187 mkCoPrim :: PrimOp   -> [CoreArgOrExpr] -> UniqSM CoreExpr
 188
 189 mkCoApps fun args = co_thing (mkGenApp fun) args
 190 mkCoCon  con args = co_thing (Con  con)     args
 191 mkCoPrim  op args = co_thing (Prim op)      args
 192
 193 co_thing :: ([CoreArg] -> CoreExpr)
 194          -> [CoreArgOrExpr]
 195          -> UniqSM CoreExpr
 196
 197 co_thing thing arg_exprs
 198   = mapAndUnzipUs expr_to_arg arg_exprs `thenUs` \ (args, maybe_binds) ->
 199     returnUs (mkCoLetsUnboxedToCase (catMaybes maybe_binds) (thing args))
 200   where
 201     expr_to_arg :: CoreArgOrExpr
 202                 -> UniqSM (CoreArg, Maybe CoreBinding)
 203
 204     expr_to_arg (AnArg  arg)     = returnUs (arg,      Nothing)
 205     expr_to_arg (AnExpr (Var v)) = returnUs (VarArg v, Nothing)
 206     expr_to_arg (AnExpr (Lit l)) = returnUs (LitArg l, Nothing)
 207     expr_to_arg (AnExpr other_expr)
 208       = let
 209             e_ty = coreExprType other_expr
 210         in
 211         getUnique `thenUs` \ uniq ->
 212         let
 213             new_var  = mkSysLocal SLIT("a") uniq e_ty noSrcLoc
 214         in
 215         returnUs (VarArg new_var, Just (NonRec new_var other_expr))
 216 \end{code}
 217
 218 \begin{code}
 219 argToExpr ::
 220   GenCoreArg val_occ flexi -> GenCoreExpr val_bdr val_occ flexi
 221
 222 argToExpr (VarArg v)   = Var v
 223 argToExpr (LitArg lit) = Lit lit
 224 \end{code}
 225
 226 All the following functions operate on binders, perform a uniform
 227 transformation on them; ie. the function @(\ x -> (x,False))@
 228 annotates all binders with False.
 229
 230 \begin{code}
 231 unTagBinders :: GenCoreExpr (Id,tag) bdee flexi -> GenCoreExpr Id bdee flexi
 232 unTagBinders expr = bop_expr fst expr
 233
 234 unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee flexi -> GenCoreCaseAlts Id bdee flexi
 235 unTagBindersAlts alts = bop_alts fst alts
 236 \end{code}
 237
 238 \begin{code}
 239 bop_expr  :: (a -> b) -> GenCoreExpr a bdee flexi -> GenCoreExpr b bdee flexi
 240
 241 bop_expr f (Var b)           = Var b
 242 bop_expr f (Lit lit)         = Lit lit
 243 bop_expr f (Con con args)    = Con con args
 244 bop_expr f (Prim op args)    = Prim op args
 245 bop_expr f (Lam binder expr) = Lam  (bop_binder f binder) (bop_expr f expr)
 246 bop_expr f (App expr arg)    = App  (bop_expr f expr) arg
 247 bop_expr f (Note note expr)  = Note note (bop_expr f expr)
 248 bop_expr f (Let bind expr)   = Let  (bop_bind f bind) (bop_expr f expr)
 249 bop_expr f (Case expr alts)  = Case (bop_expr f expr) (bop_alts f alts)
 250
 251 bop_binder f (ValBinder   v) = ValBinder (f v)
 252 bop_binder f (TyBinder    t) = TyBinder    t
 253
 254 bop_bind f (NonRec b e) = NonRec (f b) (bop_expr f e)
 255 bop_bind f (Rec pairs)  = Rec [(f b, bop_expr f e) | (b, e) <- pairs]
 256
 257 bop_alts f (AlgAlts alts deflt)
 258   = AlgAlts  [ (con, [f b | b <- binders], bop_expr f e)
 259              | (con, binders, e) <- alts ]
 260              (bop_deflt f deflt)
 261
 262 bop_alts f (PrimAlts alts deflt)
 263   = PrimAlts [ (lit, bop_expr f e) | (lit, e) <- alts ]
 264              (bop_deflt f deflt)
 265
 266 bop_deflt f (NoDefault)          = NoDefault
 267 bop_deflt f (BindDefault b expr) = BindDefault (f b) (bop_expr f expr)
 268 \end{code}
 269
 270 OLD (but left here because of the nice example): @singleAlt@ checks
 271 whether a bunch of case alternatives is actually just one alternative.
 272 It specifically {\em ignores} alternatives which consist of just a
 273 call to @error@, because they won't result in any code duplication.
 274
 275 Example:
 276 \begin{verbatim}
 277         case (case <something> of
 278                 True  -> <rhs>
 279                 False -> error "Foo") of
 280         <alts>
 281
 282 ===>
 283
 284         case <something> of
 285            True ->  case <rhs> of
 286                     <alts>
 287            False -> case error "Foo" of
 288                     <alts>
 289
 290 ===>
 291
 292         case <something> of
 293            True ->  case <rhs> of
 294                     <alts>
 295            False -> error "Foo"
 296 \end{verbatim}
 297 Notice that the \tr{<alts>} don't get duplicated.
 298
 299 \begin{code}
 300 nonErrorRHSs :: GenCoreCaseAlts a Id Unused -> [GenCoreExpr a Id Unused]
 301
 302 nonErrorRHSs alts
 303   = filter not_error_app (find_rhss alts)
 304   where
 305     find_rhss (AlgAlts  as deflt) = [rhs | (_,_,rhs) <- as] ++ deflt_rhs deflt
 306     find_rhss (PrimAlts as deflt) = [rhs | (_,rhs)   <- as] ++ deflt_rhs deflt
 307
 308     deflt_rhs NoDefault           = []
 309     deflt_rhs (BindDefault _ rhs) = [rhs]
 310
 311     not_error_app rhs
 312       = case (maybeErrorApp rhs Nothing) of
 313           Just _  -> False
 314           Nothing -> True
 315 \end{code}
 316
 317 maybeErrorApp checks whether an expression is of the form
 318
 319         error ty args
 320
 321 If so, it returns
 322
 323         Just (error ty' args)
 324
 325 where ty' is supplied as an argument to maybeErrorApp.
 326
 327 Here's where it is useful:
 328
 329                 case (error ty "Foo" e1 e2) of <alts>
 330  ===>
 331                 error ty' "Foo"
 332
 333 where ty' is the type of any of the alternatives.  You might think
 334 this never occurs, but see the comments on the definition of
 335 @singleAlt@.
 336
 337 Note: we *avoid* the case where ty' might end up as a primitive type:
 338 this is very uncool (totally wrong).
 339
 340 NOTICE: in the example above we threw away e1 and e2, but not the
 341 string "Foo".  How did we know to do that?
 342
 343 Answer: for now anyway, we only handle the case of a function whose
 344 type is of form
 345
 346         bottomingFn :: forall a. t1 -> ... -> tn -> a
 347                               ^---------------------^ NB!
 348
 349 Furthermore, we only count a bottomingApp if the function is applied
 350 to more than n args.  If so, we transform:
 351
 352         bottomingFn ty e1 ... en en+1 ... em
 353 to
 354         bottomingFn ty' e1 ... en
 355
 356 That is, we discard en+1 .. em
 357
 358 \begin{code}
 359 maybeErrorApp
 360         :: GenCoreExpr a Id Unused      -- Expr to look at
 361         -> Maybe Type                   -- Just ty => a result type *already cloned*;
 362                                         -- Nothing => don't know result ty; we
 363                                         -- *pretend* that the result ty won't be
 364                                         -- primitive -- somebody later must
 365                                         -- ensure this.
 366         -> Maybe (GenCoreExpr b Id Unused)
 367
 368 maybeErrorApp expr result_ty_maybe
 369   = case (collectArgs expr) of
 370       (Var fun, [ty], other_args)
 371         | isBottomingId fun
 372         && maybeToBool result_ty_maybe -- we *know* the result type
 373                                        -- (otherwise: live a fairy-tale existence...)
 374         && not (isUnpointedType result_ty) ->
 375
 376         case (splitSigmaTy (idType fun)) of
 377           ([tyvar], [], tau_ty) ->
 378               case (splitFunTys tau_ty) of { (arg_tys, res_ty) ->
 379               let
 380                   n_args_to_keep = length arg_tys
 381                   args_to_keep   = take n_args_to_keep other_args
 382               in
 383               if  (res_ty == mkTyVarTy tyvar)
 384                && n_args_to_keep <= length other_args
 385               then
 386                     -- Phew!  We're in business
 387                   Just (mkGenApp (Var fun) (TyArg result_ty : args_to_keep))
 388               else
 389                   Nothing
 390               }
 391
 392           other -> Nothing  -- Function type wrong shape
 393       other -> Nothing
 394   where
 395     Just result_ty = result_ty_maybe
 396 \end{code}
 397
 398 \begin{code}
 399 squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b c -> Bool
 400
 401 squashableDictishCcExpr cc expr
 402   = if not (isDictCC cc) then
 403         False -- that was easy...
 404     else
 405         squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier
 406   where
 407     squashable (Var _)      = True
 408     squashable (Con  _ _)   = True -- I think so... WDP 94/09
 409     squashable (Prim _ _)   = True -- ditto
 410     squashable (App f a)
 411       | notValArg a         = squashable f
 412     squashable other        = False
 413 \end{code}