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