\section[CoreLift]{Lifts unboxed bindings and any references to them}
\begin{code}
-#include "HsVersions.h"
-
module CoreLift (
liftCoreBindings,
) where
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
import CoreSyn
import CoreUtils ( coreExprType )
import Id ( idType, mkSysLocal,
- nullIdEnv, growIdEnvList, lookupIdEnv, SYN_IE(IdEnv),
- GenId{-instances-}
+ nullIdEnv, growIdEnvList, lookupIdEnv,
+ mkIdWithNewType,
+ IdEnv, GenId{-instances-}, Id
)
import Name ( isLocallyDefined, getSrcLoc, getOccString )
import TyCon ( isBoxedTyCon, TyCon{-instance-} )
-import Type ( maybeAppDataTyConExpandingDicts, eqTy )
+import Type ( splitAlgTyConApp_maybe )
import TysPrim ( statePrimTyCon )
import TysWiredIn ( liftDataCon, mkLiftTy )
+import Unique ( Unique )
import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply )
import Util ( zipEqual, zipWithEqual, assertPanic, panic )
infixr 9 `thenL`
-updateIdType = panic "CoreLift.updateIdType"
\end{code}
%************************************************************************
liftCoreArg :: CoreArg -> LiftM (CoreArg, CoreExpr -> CoreExpr)
liftCoreArg arg@(TyArg _) = returnL (arg, id)
-liftCoreArg arg@(UsageArg _) = returnL (arg, id)
liftCoreArg arg@(LitArg _) = returnL (arg, id)
liftCoreArg arg@(VarArg v)
= isLiftedId v `thenL` \ lifted ->
(lifted_id, unlifted_id)
where
id_name = _PK_ (getOccString id) -- yuk!
- lifted_id = updateIdType id lifted_ty
+ lifted_id = mkIdWithNewType id lifted_ty
unlifted_id = mkSysLocal id_name u unlifted_ty (getSrcLoc id)
unlifted_ty = idType id
bindUnlift :: Id -> Id -> CoreExpr -> CoreExpr
bindUnlift vlift vunlift expr
= ASSERT (isUnboxedButNotState unlift_ty)
- ASSERT (lift_ty `eqTy` mkLiftTy unlift_ty)
+ ASSERT (lift_ty == mkLiftTy unlift_ty)
Case (Var vlift)
(AlgAlts [(liftDataCon, [vunlift], expr)] NoDefault)
where
liftExpr :: Id -> CoreExpr -> CoreExpr
liftExpr vunlift rhs
= ASSERT (isUnboxedButNotState unlift_ty)
- ASSERT (rhs_ty `eqTy` unlift_ty)
+ ASSERT (rhs_ty == unlift_ty)
Case rhs (PrimAlts []
- (BindDefault vunlift (mkCon liftDataCon [] [unlift_ty] [VarArg vunlift])))
+ (BindDefault vunlift (mkCon liftDataCon [unlift_ty] [VarArg vunlift])))
where
rhs_ty = coreExprType rhs
unlift_ty = idType vunlift
applyBindUnlifts [] expr = expr
applyBindUnlifts (f:fs) expr = f (applyBindUnlifts fs expr)
-isUnboxedButNotState ty
- = case (maybeAppDataTyConExpandingDicts ty) of
+isUnboxedButNotState ty =
+ case (splitAlgTyConApp_maybe ty) of
Nothing -> False
Just (tycon, _, _) ->
not (isBoxedTyCon tycon) && not (tycon == statePrimTyCon)