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 Id               ( idType, mkSysLocal,
  22                           nullIdEnv, growIdEnvList, lookupIdEnv,
  23                           mkIdWithNewType,
  24                           IdEnv, GenId{-instances-}, 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 (SCC label expr)
 127   = liftCoreExpr expr           `thenL` \ expr ->
 128     returnL (SCC label expr)
 129
 130 liftCoreExpr (Coerce coerce ty expr)
 131   = liftCoreExpr expr           `thenL` \ expr ->
 132     returnL (Coerce coerce ty expr) -- ToDo:right?:Coerce
 133
 134 liftCoreExpr (Let (NonRec binder rhs) body) -- special case: no lifting
 135   = liftCoreExpr rhs    `thenL` \ rhs ->
 136     liftCoreExpr body   `thenL` \ body ->
 137     returnL (mkCoLetUnboxedToCase (NonRec binder rhs) body)
 138
 139 liftCoreExpr (Let bind body)    -- general case
 140   = liftBindAndScope False bind (
 141       liftCoreExpr body `thenL` \ body ->
 142       returnL (ItsAnExpr body)
 143     )                           `thenL` \ (bind, ItsAnExpr body) ->
 144     returnL (Let bind body)
 145
 146 liftCoreExpr (Con con args)
 147   = mapAndUnzipL liftCoreArg args       `thenL` \ (args, unlifts) ->
 148     returnL (applyBindUnlifts unlifts (Con con args))
 149
 150 liftCoreExpr (Prim op args)
 151   = mapAndUnzipL liftCoreArg args       `thenL` \ (args, unlifts) ->
 152     returnL (applyBindUnlifts unlifts (Prim op args))
 153
 154 liftCoreExpr (App fun arg)
 155   = lift_app fun [arg]
 156   where
 157     lift_app (App fun arg) args
 158       = lift_app fun (arg:args)
 159     lift_app other_fun args
 160       = liftCoreExpr other_fun          `thenL` \ other_fun ->
 161         mapAndUnzipL liftCoreArg args   `thenL` \ (args, unlifts) ->
 162         returnL (applyBindUnlifts unlifts (mkGenApp other_fun args))
 163
 164 liftCoreExpr (Lam binder expr)
 165   = liftCoreExpr expr           `thenL` \ expr ->
 166     returnL (Lam binder expr)
 167
 168 liftCoreExpr (Case scrut alts)
 169  = liftCoreExpr scrut           `thenL` \ scrut ->
 170    liftCoreAlts alts            `thenL` \ alts ->
 171    returnL (Case scrut alts)
 172
 173 ------------
 174 liftCoreAlts :: CoreCaseAlts -> LiftM CoreCaseAlts
 175
 176 liftCoreAlts (AlgAlts alg_alts deflt)
 177  = mapL liftAlgAlt alg_alts     `thenL` \ alg_alts ->
 178    liftDeflt deflt              `thenL` \ deflt ->
 179    returnL (AlgAlts alg_alts deflt)
 180
 181 liftCoreAlts (PrimAlts prim_alts deflt)
 182  = mapL liftPrimAlt prim_alts   `thenL` \ prim_alts ->
 183    liftDeflt deflt              `thenL` \ deflt ->
 184    returnL (PrimAlts prim_alts deflt)
 185
 186 ------------
 187 liftAlgAlt (con,args,rhs)
 188   = liftCoreExpr rhs            `thenL` \ rhs ->
 189     returnL (con,args,rhs)
 190
 191 ------------
 192 liftPrimAlt (lit,rhs)
 193   = liftCoreExpr rhs            `thenL` \ rhs ->
 194     returnL (lit,rhs)
 195
 196 ------------
 197 liftDeflt NoDefault
 198   = returnL NoDefault
 199 liftDeflt (BindDefault binder rhs)
 200   = liftCoreExpr rhs            `thenL` \ rhs ->
 201     returnL (BindDefault binder rhs)
 202 \end{code}
 203
 204 %************************************************************************
 205 %*                                                                      *
 206 \subsection{Misc functions}
 207 %*                                                                      *
 208 %************************************************************************
 209
 210 \begin{code}
 211 type LiftM a
 212   = IdEnv (Id, Id)      -- lifted Ids are mapped to:
 213                         --   * lifted Id with the same Unique
 214                         --     (top-level bindings must keep their unique
 215                         --   * unlifted version with a new Unique
 216     -> UniqSupply       -- unique supply
 217     -> a                -- result
 218
 219 data BindsOrExpr
 220   = ItsABinds [CoreBinding]
 221   | ItsAnExpr CoreExpr
 222
 223 initL m us = m nullIdEnv us
 224
 225 returnL :: a -> LiftM a
 226 returnL r idenv us = r
 227
 228 thenL :: LiftM a -> (a -> LiftM b) -> LiftM b
 229 thenL m k idenv s0
 230   = case (splitUniqSupply s0)   of { (s1, s2) ->
 231     case (m idenv s1)           of { r ->
 232     k r idenv s2 }}
 233
 234
 235 mapL :: (a -> LiftM b) -> [a] -> LiftM [b]
 236 mapL f [] = returnL []
 237 mapL f (x:xs)
 238   = f x                 `thenL` \ r ->
 239     mapL f xs           `thenL` \ rs ->
 240     returnL (r:rs)
 241
 242 mapAndUnzipL  :: (a -> LiftM (b1, b2))  -> [a] -> LiftM ([b1],[b2])
 243 mapAndUnzipL f [] = returnL ([],[])
 244 mapAndUnzipL f (x:xs)
 245   = f x                 `thenL` \ (r1, r2) ->
 246     mapAndUnzipL f xs   `thenL` \ (rs1,rs2) ->
 247     returnL ((r1:rs1),(r2:rs2))
 248
 249 -- liftBinders is only called for top-level or recusive case
 250 liftBinders :: Bool -> CoreBinding -> LiftM thing -> LiftM thing
 251
 252 liftBinders False (NonRec _ _) liftM idenv s0
 253   = panic "CoreLift:liftBinders"        -- should be caught by special case above
 254
 255 liftBinders top_lev bind liftM idenv s0
 256   = liftM (growIdEnvList idenv lift_map) s2
 257   where
 258     (s1, s2)   = splitUniqSupply s0
 259     lift_ids   = [ id | id <- bindersOf bind, isUnboxedButNotState (idType id) ]
 260     lift_uniqs = getUniques (length lift_ids) s1
 261     lift_map   = zipEqual "liftBinders" lift_ids (zipWithEqual "liftBinders" mkLiftedId lift_ids lift_uniqs)
 262
 263     -- ToDo: Give warning for recursive bindings involving unboxed values ???
 264
 265 isLiftedId :: Id -> LiftM (Maybe (Id, Id))
 266 isLiftedId id idenv us
 267   | isLocallyDefined id
 268      = lookupIdEnv idenv id
 269   | otherwise   -- ensure all imported ids are lifted
 270      = if isUnboxedButNotState (idType id)
 271        then Just (mkLiftedId id (getUnique us))
 272        else Nothing
 273
 274 mkLiftedId :: Id -> Unique -> (Id,Id)
 275 mkLiftedId id u
 276   = ASSERT (isUnboxedButNotState unlifted_ty)
 277     (lifted_id, unlifted_id)
 278   where
 279     id_name     = _PK_ (getOccString id)                -- yuk!
 280     lifted_id   = mkIdWithNewType id lifted_ty
 281     unlifted_id = mkSysLocal id_name u unlifted_ty (getSrcLoc id)
 282
 283     unlifted_ty = idType id
 284     lifted_ty   = mkLiftTy unlifted_ty
 285
 286 bindUnlift :: Id -> Id -> CoreExpr -> CoreExpr
 287 bindUnlift vlift vunlift expr
 288   = ASSERT (isUnboxedButNotState unlift_ty)
 289     ASSERT (lift_ty == mkLiftTy unlift_ty)
 290     Case (Var vlift)
 291            (AlgAlts [(liftDataCon, [vunlift], expr)] NoDefault)
 292   where
 293     lift_ty   = idType vlift
 294     unlift_ty = idType vunlift
 295
 296 liftExpr :: Id -> CoreExpr -> CoreExpr
 297 liftExpr vunlift rhs
 298   = ASSERT (isUnboxedButNotState unlift_ty)
 299     ASSERT (rhs_ty == unlift_ty)
 300     Case rhs (PrimAlts []
 301         (BindDefault vunlift (mkCon liftDataCon [unlift_ty] [VarArg vunlift])))
 302   where
 303     rhs_ty    = coreExprType rhs
 304     unlift_ty = idType vunlift
 305
 306
 307 applyBindUnlifts :: [CoreExpr -> CoreExpr] -> CoreExpr -> CoreExpr
 308 applyBindUnlifts []     expr = expr
 309 applyBindUnlifts (f:fs) expr = f (applyBindUnlifts fs expr)
 310
 311 isUnboxedButNotState ty =
 312     case (splitAlgTyConApp_maybe ty) of
 313       Nothing -> False
 314       Just (tycon, _, _) ->
 315         not (isBoxedTyCon tycon) && not (tycon == statePrimTyCon)
 316 \end{code}