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 module CoreLift (
   8         liftCoreBindings,
   9
  10         mkLiftedId,
  11         liftExpr,
  12         bindUnlift,
  13         applyBindUnlifts
  14
  15     ) where
  16
  17 #include "HsVersions.h"
  18
  19 import CoreSyn
  20 import CoreUtils        ( coreExprType )
  21 import MkId             ( mkSysLocal )
  22 import Id               ( idType, mkIdWithNewType,
  23                           nullIdEnv, growIdEnvList, lookupIdEnv,
  24                           IdEnv, Id
  25                         )
  26 import Name             ( isLocallyDefined, getSrcLoc, getOccString )
  27 import TyCon            ( isBoxedTyCon, TyCon{-instance-} )
  28 import Type             ( splitAlgTyConApp_maybe )
  29 import TysPrim          ( statePrimTyCon )
  30 import TysWiredIn       ( liftDataCon, mkLiftTy )
  31 import Unique           ( Unique )
  32 import UniqSupply       ( getUnique, getUniques, splitUniqSupply, UniqSupply )
  33 import Util             ( zipEqual, zipWithEqual, assertPanic, panic )
  34
  35 infixr 9 `thenL`
  36
  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@(LitArg    _) = returnL (arg, id)
  84 liftCoreArg arg@(VarArg v)
  85  = isLiftedId v                 `thenL` \ lifted ->
  86     case lifted of
  87         Nothing -> returnL (arg, id)
  88
  89         Just (lifted, unlifted) ->
  90             returnL (VarArg unlifted, bindUnlift lifted unlifted)
  91
  92
  93 -----------------------
  94 liftCoreBind :: CoreBinding -> LiftM CoreBinding
  95
  96 liftCoreBind (NonRec b rhs)
  97   = liftOneBind (b,rhs)         `thenL` \ (b,rhs) ->
  98     returnL (NonRec b rhs)
  99
 100 liftCoreBind (Rec pairs)
 101   = mapL liftOneBind pairs      `thenL` \ pairs ->
 102     returnL (Rec pairs)
 103
 104 -----------------------
 105 liftOneBind (binder,rhs)
 106   = liftCoreExpr rhs            `thenL` \ rhs ->
 107     isLiftedId binder           `thenL` \ lifted ->
 108     case lifted of
 109         Just (lifted, unlifted) ->
 110             returnL (lifted, liftExpr unlifted rhs)
 111         Nothing ->
 112             returnL (binder, rhs)
 113
 114 -----------------------
 115 liftCoreExpr :: CoreExpr -> LiftM CoreExpr
 116
 117 liftCoreExpr expr@(Var var)
 118   = isLiftedId var              `thenL` \ lifted ->
 119     case lifted of
 120         Nothing -> returnL expr
 121         Just (lifted, unlifted) ->
 122             returnL (bindUnlift lifted unlifted (Var unlifted))
 123
 124 liftCoreExpr expr@(Lit lit) = returnL expr
 125
 126 liftCoreExpr (Note note expr)
 127   = liftCoreExpr expr           `thenL` \ expr ->
 128     returnL (Note note expr)
 129
 130 liftCoreExpr (Let (NonRec binder rhs) body) -- special case: no lifting
 131   = liftCoreExpr rhs    `thenL` \ rhs ->
 132     liftCoreExpr body   `thenL` \ body ->
 133     returnL (mkCoLetUnboxedToCase (NonRec binder rhs) body)
 134
 135 liftCoreExpr (Let bind body)    -- general case
 136   = liftBindAndScope False bind (
 137       liftCoreExpr body `thenL` \ body ->
 138       returnL (ItsAnExpr body)
 139     )                           `thenL` \ (bind, ItsAnExpr body) ->
 140     returnL (Let bind body)
 141
 142 liftCoreExpr (Con con args)
 143   = mapAndUnzipL liftCoreArg args       `thenL` \ (args, unlifts) ->
 144     returnL (applyBindUnlifts unlifts (Con con args))
 145
 146 liftCoreExpr (Prim op args)
 147   = mapAndUnzipL liftCoreArg args       `thenL` \ (args, unlifts) ->
 148     returnL (applyBindUnlifts unlifts (Prim op args))
 149
 150 liftCoreExpr (App fun arg)
 151   = lift_app fun [arg]
 152   where
 153     lift_app (App fun arg) args
 154       = lift_app fun (arg:args)
 155     lift_app other_fun args
 156       = liftCoreExpr other_fun          `thenL` \ other_fun ->
 157         mapAndUnzipL liftCoreArg args   `thenL` \ (args, unlifts) ->
 158         returnL (applyBindUnlifts unlifts (mkGenApp other_fun args))
 159
 160 liftCoreExpr (Lam binder expr)
 161   = liftCoreExpr expr           `thenL` \ expr ->
 162     returnL (Lam binder expr)
 163
 164 liftCoreExpr (Case scrut alts)
 165  = liftCoreExpr scrut           `thenL` \ scrut ->
 166    liftCoreAlts alts            `thenL` \ alts ->
 167    returnL (Case scrut alts)
 168
 169 ------------
 170 liftCoreAlts :: CoreCaseAlts -> LiftM CoreCaseAlts
 171
 172 liftCoreAlts (AlgAlts alg_alts deflt)
 173  = mapL liftAlgAlt alg_alts     `thenL` \ alg_alts ->
 174    liftDeflt deflt              `thenL` \ deflt ->
 175    returnL (AlgAlts alg_alts deflt)
 176
 177 liftCoreAlts (PrimAlts prim_alts deflt)
 178  = mapL liftPrimAlt prim_alts   `thenL` \ prim_alts ->
 179    liftDeflt deflt              `thenL` \ deflt ->
 180    returnL (PrimAlts prim_alts deflt)
 181
 182 ------------
 183 liftAlgAlt (con,args,rhs)
 184   = liftCoreExpr rhs            `thenL` \ rhs ->
 185     returnL (con,args,rhs)
 186
 187 ------------
 188 liftPrimAlt (lit,rhs)
 189   = liftCoreExpr rhs            `thenL` \ rhs ->
 190     returnL (lit,rhs)
 191
 192 ------------
 193 liftDeflt NoDefault
 194   = returnL NoDefault
 195 liftDeflt (BindDefault binder rhs)
 196   = liftCoreExpr rhs            `thenL` \ rhs ->
 197     returnL (BindDefault binder rhs)
 198 \end{code}
 199
 200 %************************************************************************
 201 %*                                                                      *
 202 \subsection{Misc functions}
 203 %*                                                                      *
 204 %************************************************************************
 205
 206 \begin{code}
 207 type LiftM a
 208   = IdEnv (Id, Id)      -- lifted Ids are mapped to:
 209                         --   * lifted Id with the same Unique
 210                         --     (top-level bindings must keep their unique
 211                         --   * unlifted version with a new Unique
 212     -> UniqSupply       -- unique supply
 213     -> a                -- result
 214
 215 data BindsOrExpr
 216   = ItsABinds [CoreBinding]
 217   | ItsAnExpr CoreExpr
 218
 219 initL m us = m nullIdEnv us
 220
 221 returnL :: a -> LiftM a
 222 returnL r idenv us = r
 223
 224 thenL :: LiftM a -> (a -> LiftM b) -> LiftM b
 225 thenL m k idenv s0
 226   = case (splitUniqSupply s0)   of { (s1, s2) ->
 227     case (m idenv s1)           of { r ->
 228     k r idenv s2 }}
 229
 230
 231 mapL :: (a -> LiftM b) -> [a] -> LiftM [b]
 232 mapL f [] = returnL []
 233 mapL f (x:xs)
 234   = f x                 `thenL` \ r ->
 235     mapL f xs           `thenL` \ rs ->
 236     returnL (r:rs)
 237
 238 mapAndUnzipL  :: (a -> LiftM (b1, b2))  -> [a] -> LiftM ([b1],[b2])
 239 mapAndUnzipL f [] = returnL ([],[])
 240 mapAndUnzipL f (x:xs)
 241   = f x                 `thenL` \ (r1, r2) ->
 242     mapAndUnzipL f xs   `thenL` \ (rs1,rs2) ->
 243     returnL ((r1:rs1),(r2:rs2))
 244
 245 -- liftBinders is only called for top-level or recusive case
 246 liftBinders :: Bool -> CoreBinding -> LiftM thing -> LiftM thing
 247
 248 liftBinders False (NonRec _ _) liftM idenv s0
 249   = panic "CoreLift:liftBinders"        -- should be caught by special case above
 250
 251 liftBinders top_lev bind liftM idenv s0
 252   = liftM (growIdEnvList idenv lift_map) s2
 253   where
 254     (s1, s2)   = splitUniqSupply s0
 255     lift_ids   = [ id | id <- bindersOf bind, isUnboxedButNotState (idType id) ]
 256     lift_uniqs = getUniques (length lift_ids) s1
 257     lift_map   = zipEqual "liftBinders" lift_ids (zipWithEqual "liftBinders" mkLiftedId lift_ids lift_uniqs)
 258
 259     -- ToDo: Give warning for recursive bindings involving unboxed values ???
 260
 261 isLiftedId :: Id -> LiftM (Maybe (Id, Id))
 262 isLiftedId id idenv us
 263   | isLocallyDefined id
 264      = lookupIdEnv idenv id
 265   | otherwise   -- ensure all imported ids are lifted
 266      = if isUnboxedButNotState (idType id)
 267        then Just (mkLiftedId id (getUnique us))
 268        else Nothing
 269
 270 mkLiftedId :: Id -> Unique -> (Id,Id)
 271 mkLiftedId id u
 272   = ASSERT (isUnboxedButNotState unlifted_ty)
 273     (lifted_id, unlifted_id)
 274   where
 275     id_name     = _PK_ (getOccString id)                -- yuk!
 276     lifted_id   = mkIdWithNewType id lifted_ty
 277     unlifted_id = mkSysLocal id_name u unlifted_ty (getSrcLoc id)
 278
 279     unlifted_ty = idType id
 280     lifted_ty   = mkLiftTy unlifted_ty
 281
 282 bindUnlift :: Id -> Id -> CoreExpr -> CoreExpr
 283 bindUnlift vlift vunlift expr
 284   = ASSERT (isUnboxedButNotState unlift_ty)
 285     ASSERT (lift_ty == mkLiftTy unlift_ty)
 286     Case (Var vlift)
 287            (AlgAlts [(liftDataCon, [vunlift], expr)] NoDefault)
 288   where
 289     lift_ty   = idType vlift
 290     unlift_ty = idType vunlift
 291
 292 liftExpr :: Id -> CoreExpr -> CoreExpr
 293 liftExpr vunlift rhs
 294   = ASSERT (isUnboxedButNotState unlift_ty)
 295     ASSERT (rhs_ty == unlift_ty)
 296     Case rhs (PrimAlts []
 297         (BindDefault vunlift (mkCon liftDataCon [unlift_ty] [VarArg vunlift])))
 298   where
 299     rhs_ty    = coreExprType rhs
 300     unlift_ty = idType vunlift
 301
 302
 303 applyBindUnlifts :: [CoreExpr -> CoreExpr] -> CoreExpr -> CoreExpr
 304 applyBindUnlifts []     expr = expr
 305 applyBindUnlifts (f:fs) expr = f (applyBindUnlifts fs expr)
 306
 307 isUnboxedButNotState ty =
 308     case (splitAlgTyConApp_maybe ty) of
 309       Nothing -> False
 310       Just (tycon, _, _) ->
 311         not (isBoxedTyCon tycon) && not (tycon == statePrimTyCon)
 312 \end{code}