ghc/compiler/coreSyn/CoreLift.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
   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         CoreBinding, PlainCoreBinding(..),
  19         CoreExpr, PlainCoreExpr(..),
  20         Id, SplitUniqSupply, Unique
  21     ) where
  22
  23 IMPORT_Trace
  24 import Pretty
  25
  26 import AbsPrel          ( liftDataCon, mkLiftTy )
  27 import TysPrim          ( statePrimTyCon ) -- ToDo: get from AbsPrel
  28 import AbsUniType
  29 import Id               ( getIdUniType, updateIdType, mkSysLocal, isLocallyDefined )
  30 import IdEnv
  31 import Outputable
  32 import PlainCore
  33 import SplitUniq
  34 import Util
  35
  36 infixr 9 `thenL`
  37
  38 \end{code}
  39
  40 %************************************************************************
  41 %*                                                                      *
  42 \subsection{``lift'' for various constructs}
  43 %*                                                                      *
  44 %************************************************************************
  45
  46 @liftCoreBindings@ is the top-level interface function.
  47
  48 \begin{code}
  49 liftCoreBindings :: SplitUniqSupply     -- unique supply
  50                  -> [PlainCoreBinding]  -- unlifted bindings
  51                  -> [PlainCoreBinding]  -- lifted bindings
  52
  53 liftCoreBindings us binds
  54   = initL (lift_top_binds binds) us
  55   where
  56     lift_top_binds (b:bs)
  57       = liftBindAndScope True b (
  58           lift_top_binds bs `thenL` \ bs ->
  59           returnL (ItsABinds bs)
  60         )                       `thenL` \ (b, ItsABinds bs) ->
  61         returnL (b:bs)
  62
  63     lift_top_binds []
  64       = returnL []
  65
  66 liftBindAndScope :: Bool                        -- top level ?
  67                  -> PlainCoreBinding            -- As yet unprocessed
  68                  -> LiftM BindsOrExpr           -- Do the scope of the bindings
  69                  -> LiftM (PlainCoreBinding,    -- 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 liftCoreAtom :: PlainCoreAtom -> LiftM (PlainCoreAtom, PlainCoreExpr -> PlainCoreExpr)
  81
  82 liftCoreAtom (CoLitAtom lit)
  83  = returnL (CoLitAtom lit, id)
  84
  85 liftCoreAtom (CoVarAtom v)
  86  = isLiftedId v                 `thenL` \ lifted ->
  87     case lifted of
  88         Just (lifted, unlifted) ->
  89             returnL (CoVarAtom unlifted, bindUnlift lifted unlifted)
  90         Nothing ->
  91             returnL (CoVarAtom v, id)
  92
  93
  94 liftCoreBind :: PlainCoreBinding -> LiftM PlainCoreBinding
  95
  96 liftCoreBind (CoNonRec b rhs)
  97   = liftOneBind (b,rhs)         `thenL` \ (b,rhs) ->
  98     returnL (CoNonRec b rhs)
  99
 100 liftCoreBind (CoRec pairs)
 101   = mapL liftOneBind pairs      `thenL` \ pairs ->
 102     returnL (CoRec pairs)
 103
 104 liftOneBind (binder,rhs)
 105   = liftCoreExpr rhs            `thenL` \ rhs ->
 106     isLiftedId binder           `thenL` \ lifted ->
 107     case lifted of
 108         Just (lifted, unlifted) ->
 109             returnL (lifted, liftExpr unlifted rhs)
 110         Nothing ->
 111             returnL (binder, rhs)
 112
 113 liftCoreExpr :: PlainCoreExpr -> LiftM PlainCoreExpr
 114
 115 liftCoreExpr (CoVar var)
 116   = isLiftedId var              `thenL` \ lifted ->
 117     case lifted of
 118         Just (lifted, unlifted) ->
 119             returnL (bindUnlift lifted unlifted (CoVar unlifted))
 120         Nothing ->
 121             returnL (CoVar var)
 122
 123 liftCoreExpr (CoLit lit)
 124   = returnL (CoLit lit)
 125
 126 liftCoreExpr (CoSCC label expr)
 127   = liftCoreExpr expr           `thenL` \ expr ->
 128     returnL (CoSCC label expr)
 129
 130 liftCoreExpr (CoLet (CoNonRec binder rhs) body)         -- special case: no lifting
 131   = liftCoreExpr rhs    `thenL` \ rhs ->
 132     liftCoreExpr body   `thenL` \ body ->
 133     returnL (mkCoLetUnboxedToCase (CoNonRec binder rhs) body)
 134
 135 liftCoreExpr (CoLet bind body)  -- general case
 136   = liftBindAndScope False bind (
 137       liftCoreExpr body `thenL` \ body ->
 138       returnL (ItsAnExpr body)
 139     )                           `thenL` \ (bind, ItsAnExpr body) ->
 140     returnL (CoLet bind body)
 141
 142 liftCoreExpr (CoCon con tys args)
 143   = mapAndUnzipL liftCoreAtom args      `thenL` \ (args, unlifts) ->
 144     returnL (applyBindUnlifts unlifts (CoCon con tys args))
 145
 146 liftCoreExpr (CoPrim op tys args)
 147   = mapAndUnzipL liftCoreAtom args      `thenL` \ (args, unlifts) ->
 148     returnL (applyBindUnlifts unlifts (CoPrim op tys args))
 149
 150 liftCoreExpr (CoApp fun arg)
 151   = lift_app fun [arg]
 152   where
 153     lift_app (CoApp fun arg) args
 154       = lift_app fun (arg:args)
 155     lift_app other_fun args
 156       = liftCoreExpr other_fun          `thenL` \ other_fun ->
 157         mapAndUnzipL liftCoreAtom args  `thenL` \ (args, unlifts) ->
 158         returnL (applyBindUnlifts unlifts (foldl CoApp other_fun args))
 159
 160 liftCoreExpr (CoTyApp fun ty_arg)
 161   = liftCoreExpr fun            `thenL` \ fun ->
 162     returnL (CoTyApp fun ty_arg)
 163
 164 liftCoreExpr (CoLam binders expr)
 165   = liftCoreExpr expr           `thenL` \ expr ->
 166     returnL (CoLam binders expr)
 167
 168 liftCoreExpr (CoTyLam tyvar expr)
 169   = liftCoreExpr expr           `thenL` \ expr ->
 170     returnL (CoTyLam tyvar expr)
 171
 172 liftCoreExpr (CoCase scrut alts)
 173  = liftCoreExpr scrut           `thenL` \ scrut ->
 174    liftCoreAlts alts            `thenL` \ alts ->
 175    returnL (CoCase scrut alts)
 176
 177
 178 liftCoreAlts :: PlainCoreCaseAlternatives -> LiftM PlainCoreCaseAlternatives
 179
 180 liftCoreAlts (CoAlgAlts alg_alts deflt)
 181  = mapL liftAlgAlt alg_alts     `thenL` \ alg_alts ->
 182    liftDeflt deflt              `thenL` \ deflt ->
 183    returnL (CoAlgAlts alg_alts deflt)
 184
 185 liftCoreAlts (CoPrimAlts prim_alts deflt)
 186  = mapL liftPrimAlt prim_alts   `thenL` \ prim_alts ->
 187    liftDeflt deflt              `thenL` \ deflt ->
 188    returnL (CoPrimAlts prim_alts deflt)
 189
 190
 191 liftAlgAlt (con,args,rhs)
 192   = liftCoreExpr rhs            `thenL` \ rhs ->
 193     returnL (con,args,rhs)
 194
 195 liftPrimAlt (lit,rhs)
 196   = liftCoreExpr rhs            `thenL` \ rhs ->
 197     returnL (lit,rhs)
 198
 199 liftDeflt CoNoDefault
 200   = returnL CoNoDefault
 201 liftDeflt (CoBindDefault binder rhs)
 202   = liftCoreExpr rhs            `thenL` \ rhs ->
 203     returnL (CoBindDefault binder rhs)
 204
 205 \end{code}
 206
 207 %************************************************************************
 208 %*                                                                      *
 209 \subsection{Misc functions}
 210 %*                                                                      *
 211 %************************************************************************
 212
 213 \begin{code}
 214 type LiftM a = IdEnv (Id, Id)   -- lifted Ids are mapped to:
 215                                 --   * lifted Id with the same Unique
 216                                 --     (top-level bindings must keep their
 217                                 --      unique (see TopLevId in Id.lhs))
 218                                 --   * unlifted version with a new Unique
 219             -> SplitUniqSupply  -- unique supply
 220             -> a                -- result
 221
 222 data BindsOrExpr = ItsABinds [PlainCoreBinding]
 223                  | ItsAnExpr PlainCoreExpr
 224
 225 initL m us
 226   = m nullIdEnv us
 227
 228 returnL :: a -> LiftM a
 229 returnL r idenv us
 230   = 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 -> PlainCoreBinding -> LiftM thing -> LiftM thing
 255
 256 liftBinders False (CoNonRec _ _) liftM idenv s0
 257   = error "CoreLift:liftBinders"        -- should be caught by special case above
 258
 259 liftBinders top_lev bind liftM idenv s0
 260   = liftM (growIdEnvList idenv lift_map) s1
 261   where
 262     lift_ids = [ id | id <- bindersOf bind, isUnboxedButNotState (getIdUniType id) ]
 263     (lift_uniqs, s1) = getSUniquesAndDepleted (length lift_ids) s0
 264     lift_map = zip lift_ids (zipWith mkLiftedId lift_ids lift_uniqs)
 265
 266     -- ToDo: Give warning for recursive bindings involving unboxed values ???
 267
 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 (getIdUniType id)
 275        then Just (mkLiftedId id (getSUnique 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     = getOccurrenceName id
 284     lifted_id   = updateIdType id lifted_ty
 285     unlifted_id = mkSysLocal id_name u unlifted_ty (getSrcLoc id)
 286
 287     unlifted_ty = getIdUniType id
 288     lifted_ty   = mkLiftTy unlifted_ty
 289
 290 bindUnlift :: Id -> Id -> PlainCoreExpr -> PlainCoreExpr
 291 bindUnlift vlift vunlift expr
 292   = ASSERT (isUnboxedButNotState unlift_ty)
 293     ASSERT (lift_ty == mkLiftTy unlift_ty)
 294     CoCase (CoVar vlift)
 295            (CoAlgAlts [(liftDataCon, [vunlift], expr)] CoNoDefault)
 296   where
 297     lift_ty   = getIdUniType vlift
 298     unlift_ty = getIdUniType vunlift
 299
 300 liftExpr :: Id -> PlainCoreExpr -> PlainCoreExpr
 301 liftExpr vunlift rhs
 302   = ASSERT (isUnboxedButNotState unlift_ty)
 303     ASSERT (rhs_ty == unlift_ty)
 304     CoCase rhs (CoPrimAlts [] (CoBindDefault vunlift
 305                               (CoCon liftDataCon [unlift_ty] [CoVarAtom vunlift])))
 306   where
 307     rhs_ty    = typeOfCoreExpr rhs
 308     unlift_ty = getIdUniType vunlift
 309
 310
 311 applyBindUnlifts :: [PlainCoreExpr -> PlainCoreExpr] -> PlainCoreExpr -> PlainCoreExpr
 312 applyBindUnlifts []     expr = expr
 313 applyBindUnlifts (f:fs) expr = f (applyBindUnlifts fs expr)
 314
 315 isUnboxedButNotState ty
 316   = case (getUniDataTyCon_maybe ty) of
 317       Nothing -> False
 318       Just (tycon, _, _) ->
 319         not (isBoxedTyCon tycon) && not (tycon == statePrimTyCon)
 320 \end{code}