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