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