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