ghc/compiler/coreSyn/CoreLift.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
   3 %
   4 \section[CoreLift]{Lifts unboxed bindings and any references to them}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module CoreLift (
  10         liftCoreBindings,
  11
  12         mkLiftedId,
  13         liftExpr,
  14         bindUnlift,
  15         applyBindUnlifts,
  16         isUnboxedButNotState
  17
  18     ) where
  19
  20 import Ubiq{-uitous-}
  21
  22 import CoreSyn
  23 import CoreUtils        ( coreExprType )
  24 import Id               ( idType, mkSysLocal,
  25                           nullIdEnv, growIdEnvList, lookupIdEnv, IdEnv(..),
  26                           GenId{-instances-}
  27                         )
  28 import Name             ( isLocallyDefined, getSrcLoc )
  29 import TyCon            ( isBoxedTyCon, TyCon{-instance-} )
  30 import Type             ( maybeAppDataTyConExpandingDicts, eqTy )
  31 import TysPrim          ( statePrimTyCon )
  32 import TysWiredIn       ( liftDataCon, mkLiftTy )
  33 import UniqSupply       ( getUnique, getUniques, splitUniqSupply, UniqSupply )
  34 import Util             ( zipEqual, zipWithEqual, assertPanic, panic )
  35
  36 infixr 9 `thenL`
  37
  38 updateIdType = panic "CoreLift.updateIdType"
  39 \end{code}
  40
  41 %************************************************************************
  42 %*                                                                      *
  43 \subsection{``lift'' for various constructs}
  44 %*                                                                      *
  45 %************************************************************************
  46
  47 @liftCoreBindings@ is the top-level interface function.
  48
  49 \begin{code}
  50 liftCoreBindings :: UniqSupply  -- unique supply
  51                  -> [CoreBinding]       -- unlifted bindings
  52                  -> [CoreBinding]       -- lifted bindings
  53
  54 liftCoreBindings us binds
  55   = initL (lift_top_binds binds) us
  56   where
  57     lift_top_binds [] = returnL []
  58
  59     lift_top_binds (b:bs)
  60       = liftBindAndScope True b (
  61           lift_top_binds bs `thenL` \ bs ->
  62           returnL (ItsABinds bs)
  63         )                       `thenL` \ (b, ItsABinds bs) ->
  64         returnL (b:bs)
  65
  66
  67 -----------------------
  68 liftBindAndScope :: Bool                -- top level ?
  69                  -> CoreBinding         -- As yet unprocessed
  70                  -> LiftM BindsOrExpr   -- Do the scope of the bindings
  71                  -> LiftM (CoreBinding, -- Processed
  72                            BindsOrExpr)
  73
  74 liftBindAndScope top_lev bind scopeM
  75   = liftBinders top_lev bind (
  76       liftCoreBind bind `thenL` \ bind ->
  77       scopeM            `thenL` \ bindsorexpr ->
  78       returnL (bind, bindsorexpr)
  79     )
  80
  81 -----------------------
  82 liftCoreArg :: CoreArg -> LiftM (CoreArg, CoreExpr -> CoreExpr)
  83
  84 liftCoreArg arg@(TyArg     _) = returnL (arg, id)
  85 liftCoreArg arg@(UsageArg  _) = returnL (arg, id)
  86 liftCoreArg arg@(LitArg    _) = returnL (arg, id)
  87 liftCoreArg arg@(VarArg v)
  88  = isLiftedId v                 `thenL` \ lifted ->
  89     case lifted of
  90         Nothing -> returnL (arg, id)
  91
  92         Just (lifted, unlifted) ->
  93             returnL (VarArg unlifted, bindUnlift lifted unlifted)
  94
  95
  96 -----------------------
  97 liftCoreBind :: CoreBinding -> LiftM CoreBinding
  98
  99 liftCoreBind (NonRec b rhs)
 100   = liftOneBind (b,rhs)         `thenL` \ (b,rhs) ->
 101     returnL (NonRec b rhs)
 102
 103 liftCoreBind (Rec pairs)
 104   = mapL liftOneBind pairs      `thenL` \ pairs ->
 105     returnL (Rec pairs)
 106
 107 -----------------------
 108 liftOneBind (binder,rhs)
 109   = liftCoreExpr rhs            `thenL` \ rhs ->
 110     isLiftedId binder           `thenL` \ lifted ->
 111     case lifted of
 112         Just (lifted, unlifted) ->
 113             returnL (lifted, liftExpr unlifted rhs)
 114         Nothing ->
 115             returnL (binder, rhs)
 116
 117 -----------------------
 118 liftCoreExpr :: CoreExpr -> LiftM CoreExpr
 119
 120 liftCoreExpr expr@(Var var)
 121   = isLiftedId var              `thenL` \ lifted ->
 122     case lifted of
 123         Nothing -> returnL expr
 124         Just (lifted, unlifted) ->
 125             returnL (bindUnlift lifted unlifted (Var unlifted))
 126
 127 liftCoreExpr expr@(Lit lit) = returnL expr
 128
 129 liftCoreExpr (SCC label expr)
 130   = liftCoreExpr expr           `thenL` \ expr ->
 131     returnL (SCC label expr)
 132
 133 liftCoreExpr (Coerce coerce ty expr)
 134   = liftCoreExpr expr           `thenL` \ expr ->
 135     returnL (Coerce coerce ty expr) -- ToDo:right?:Coerce
 136
 137 liftCoreExpr (Let (NonRec binder rhs) body) -- special case: no lifting
 138   = liftCoreExpr rhs    `thenL` \ rhs ->
 139     liftCoreExpr body   `thenL` \ body ->
 140     returnL (mkCoLetUnboxedToCase (NonRec binder rhs) body)
 141
 142 liftCoreExpr (Let bind body)    -- general case
 143   = liftBindAndScope False bind (
 144       liftCoreExpr body `thenL` \ body ->
 145       returnL (ItsAnExpr body)
 146     )                           `thenL` \ (bind, ItsAnExpr body) ->
 147     returnL (Let bind body)
 148
 149 liftCoreExpr (Con con args)
 150   = mapAndUnzipL liftCoreArg args       `thenL` \ (args, unlifts) ->
 151     returnL (applyBindUnlifts unlifts (Con con args))
 152
 153 liftCoreExpr (Prim op args)
 154   = mapAndUnzipL liftCoreArg args       `thenL` \ (args, unlifts) ->
 155     returnL (applyBindUnlifts unlifts (Prim op args))
 156
 157 liftCoreExpr (App fun arg)
 158   = lift_app fun [arg]
 159   where
 160     lift_app (App fun arg) args
 161       = lift_app fun (arg:args)
 162     lift_app other_fun args
 163       = liftCoreExpr other_fun          `thenL` \ other_fun ->
 164         mapAndUnzipL liftCoreArg args   `thenL` \ (args, unlifts) ->
 165         returnL (applyBindUnlifts unlifts (mkGenApp other_fun args))
 166
 167 liftCoreExpr (Lam binder expr)
 168   = liftCoreExpr expr           `thenL` \ expr ->
 169     returnL (Lam binder expr)
 170
 171 liftCoreExpr (Case scrut alts)
 172  = liftCoreExpr scrut           `thenL` \ scrut ->
 173    liftCoreAlts alts            `thenL` \ alts ->
 174    returnL (Case scrut alts)
 175
 176 ------------
 177 liftCoreAlts :: CoreCaseAlts -> LiftM CoreCaseAlts
 178
 179 liftCoreAlts (AlgAlts alg_alts deflt)
 180  = mapL liftAlgAlt alg_alts     `thenL` \ alg_alts ->
 181    liftDeflt deflt              `thenL` \ deflt ->
 182    returnL (AlgAlts alg_alts deflt)
 183
 184 liftCoreAlts (PrimAlts prim_alts deflt)
 185  = mapL liftPrimAlt prim_alts   `thenL` \ prim_alts ->
 186    liftDeflt deflt              `thenL` \ deflt ->
 187    returnL (PrimAlts prim_alts deflt)
 188
 189 ------------
 190 liftAlgAlt (con,args,rhs)
 191   = liftCoreExpr rhs            `thenL` \ rhs ->
 192     returnL (con,args,rhs)
 193
 194 ------------
 195 liftPrimAlt (lit,rhs)
 196   = liftCoreExpr rhs            `thenL` \ rhs ->
 197     returnL (lit,rhs)
 198
 199 ------------
 200 liftDeflt NoDefault
 201   = returnL NoDefault
 202 liftDeflt (BindDefault binder rhs)
 203   = liftCoreExpr rhs            `thenL` \ rhs ->
 204     returnL (BindDefault binder rhs)
 205 \end{code}
 206
 207 %************************************************************************
 208 %*                                                                      *
 209 \subsection{Misc functions}
 210 %*                                                                      *
 211 %************************************************************************
 212
 213 \begin{code}
 214 type LiftM a
 215   = IdEnv (Id, Id)      -- lifted Ids are mapped to:
 216                         --   * lifted Id with the same Unique
 217                         --     (top-level bindings must keep their
 218                         --      unique (see TopLevId in Id.lhs))
 219                         --   * unlifted version with a new Unique
 220     -> UniqSupply       -- unique supply
 221     -> a                -- result
 222
 223 data BindsOrExpr
 224   = ItsABinds [CoreBinding]
 225   | ItsAnExpr CoreExpr
 226
 227 initL m us = m nullIdEnv us
 228
 229 returnL :: a -> LiftM a
 230 returnL r idenv us = r
 231
 232 thenL :: LiftM a -> (a -> LiftM b) -> LiftM b
 233 thenL m k idenv s0
 234   = case (splitUniqSupply s0)   of { (s1, s2) ->
 235     case (m idenv s1)           of { r ->
 236     k r idenv s2 }}
 237
 238
 239 mapL :: (a -> LiftM b) -> [a] -> LiftM [b]
 240 mapL f [] = returnL []
 241 mapL f (x:xs)
 242   = f x                 `thenL` \ r ->
 243     mapL f xs           `thenL` \ rs ->
 244     returnL (r:rs)
 245
 246 mapAndUnzipL  :: (a -> LiftM (b1, b2))  -> [a] -> LiftM ([b1],[b2])
 247 mapAndUnzipL f [] = returnL ([],[])
 248 mapAndUnzipL f (x:xs)
 249   = f x                 `thenL` \ (r1, r2) ->
 250     mapAndUnzipL f xs   `thenL` \ (rs1,rs2) ->
 251     returnL ((r1:rs1),(r2:rs2))
 252
 253 -- liftBinders is only called for top-level or recusive case
 254 liftBinders :: Bool -> CoreBinding -> LiftM thing -> LiftM thing
 255
 256 liftBinders False (NonRec _ _) liftM idenv s0
 257   = panic "CoreLift:liftBinders"        -- should be caught by special case above
 258
 259 liftBinders top_lev bind liftM idenv s0
 260   = liftM (growIdEnvList idenv lift_map) s2
 261   where
 262     (s1, s2)   = splitUniqSupply s0
 263     lift_ids   = [ id | id <- bindersOf bind, isUnboxedButNotState (idType id) ]
 264     lift_uniqs = getUniques (length lift_ids) s1
 265     lift_map   = zipEqual "liftBinders" lift_ids (zipWithEqual "liftBinders" mkLiftedId lift_ids lift_uniqs)
 266
 267     -- ToDo: Give warning for recursive bindings involving unboxed values ???
 268
 269 isLiftedId :: Id -> LiftM (Maybe (Id, Id))
 270 isLiftedId id idenv us
 271   | isLocallyDefined id
 272      = lookupIdEnv idenv id
 273   | otherwise   -- ensure all imported ids are lifted
 274      = if isUnboxedButNotState (idType id)
 275        then Just (mkLiftedId id (getUnique us))
 276        else Nothing
 277
 278 mkLiftedId :: Id -> Unique -> (Id,Id)
 279 mkLiftedId id u
 280   = ASSERT (isUnboxedButNotState unlifted_ty)
 281     (lifted_id, unlifted_id)
 282   where
 283     id_name     = panic "CoreLift.mkLiftedId:id_name" --LATER: getOccName id
 284     lifted_id   = updateIdType id lifted_ty
 285     unlifted_id = mkSysLocal id_name u unlifted_ty (getSrcLoc id)
 286
 287     unlifted_ty = idType id
 288     lifted_ty   = mkLiftTy unlifted_ty
 289
 290 bindUnlift :: Id -> Id -> CoreExpr -> CoreExpr
 291 bindUnlift vlift vunlift expr
 292   = ASSERT (isUnboxedButNotState unlift_ty)
 293     ASSERT (lift_ty `eqTy` mkLiftTy unlift_ty)
 294     Case (Var vlift)
 295            (AlgAlts [(liftDataCon, [vunlift], expr)] NoDefault)
 296   where
 297     lift_ty   = idType vlift
 298     unlift_ty = idType vunlift
 299
 300 liftExpr :: Id -> CoreExpr -> CoreExpr
 301 liftExpr vunlift rhs
 302   = ASSERT (isUnboxedButNotState unlift_ty)
 303     ASSERT (rhs_ty `eqTy` unlift_ty)
 304     Case rhs (PrimAlts []
 305         (BindDefault vunlift (mkCon liftDataCon [] [unlift_ty] [VarArg vunlift])))
 306   where
 307     rhs_ty    = coreExprType rhs
 308     unlift_ty = idType vunlift
 309
 310
 311 applyBindUnlifts :: [CoreExpr -> CoreExpr] -> CoreExpr -> CoreExpr
 312 applyBindUnlifts []     expr = expr
 313 applyBindUnlifts (f:fs) expr = f (applyBindUnlifts fs expr)
 314
 315 isUnboxedButNotState ty
 316   = case (maybeAppDataTyConExpandingDicts ty) of
 317       Nothing -> False
 318       Just (tycon, _, _) ->
 319         not (isBoxedTyCon tycon) && not (tycon == statePrimTyCon)
 320 \end{code}