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