X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreLift.lhs;h=59c655aca600404b7085e4d1323c204f1d45e744;hb=5eb1c77c795f92ed0f4c8023847e9d4be1a4fd0d;hp=9430cc572eb4102e58c025648b4e4efef278a2ee;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreLift.lhs b/ghc/compiler/coreSyn/CoreLift.lhs index 9430cc5..59c655a 100644 --- a/ghc/compiler/coreSyn/CoreLift.lhs +++ b/ghc/compiler/coreSyn/CoreLift.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996 % \section[CoreLift]{Lifts unboxed bindings and any references to them} @@ -12,27 +12,29 @@ module CoreLift ( mkLiftedId, liftExpr, bindUnlift, - applyBindUnlifts, - - CoreBinding, PlainCoreBinding(..), - CoreExpr, PlainCoreExpr(..), - Id, SplitUniqSupply, Unique - ) where + applyBindUnlifts -IMPORT_Trace + ) where -import AbsPrel ( liftDataCon, mkLiftTy ) -import TysPrim ( statePrimTyCon ) -- ToDo: get from AbsPrel -import AbsUniType -import Id ( getIdUniType, updateIdType, mkSysLocal, isLocallyDefined ) -import IdEnv -import Outputable -import PlainCore -import SplitUniq -import Util +IMP_Ubiq(){-uitous-} + +import CoreSyn +import CoreUtils ( coreExprType ) +import Id ( idType, mkSysLocal, + nullIdEnv, growIdEnvList, lookupIdEnv, SYN_IE(IdEnv), + GenId{-instances-} + ) +import Name ( isLocallyDefined, getSrcLoc ) +import TyCon ( isBoxedTyCon, TyCon{-instance-} ) +import Type ( maybeAppDataTyConExpandingDicts, eqTy ) +import TysPrim ( statePrimTyCon ) +import TysWiredIn ( liftDataCon, mkLiftTy ) +import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply ) +import Util ( zipEqual, zipWithEqual, assertPanic, panic ) infixr 9 `thenL` +updateIdType = panic "CoreLift.updateIdType" \end{code} %************************************************************************ @@ -44,66 +46,64 @@ infixr 9 `thenL` @liftCoreBindings@ is the top-level interface function. \begin{code} -liftCoreBindings :: SplitUniqSupply -- unique supply - -> [PlainCoreBinding] -- unlifted bindings - -> [PlainCoreBinding] -- lifted bindings +liftCoreBindings :: UniqSupply -- unique supply + -> [CoreBinding] -- unlifted bindings + -> [CoreBinding] -- lifted bindings liftCoreBindings us binds = initL (lift_top_binds binds) us where + lift_top_binds [] = returnL [] + lift_top_binds (b:bs) - = liftBindAndScope True (is_rec b) b ( - lift_top_binds bs `thenL` \ bs -> + = liftBindAndScope True b ( + lift_top_binds bs `thenL` \ bs -> returnL (ItsABinds bs) - ) `thenL` \ (b, ItsABinds bs) -> + ) `thenL` \ (b, ItsABinds bs) -> returnL (b:bs) - lift_top_binds [] - = returnL [] - -is_rec (CoNonRec _ _) = False -is_rec _ = True - -liftBindAndScope :: Bool -- True <=> a top level group - -> Bool -- True <=> a recursive group - -> PlainCoreBinding -- As yet unprocessed - -> LiftM BindsOrExpr -- Do the scope of the bindings - -> LiftM (PlainCoreBinding, -- Processed - BindsOrExpr) - -liftBindAndScope toplev is_rec bind scopeM - = liftBinders toplev is_rec binders ( + +----------------------- +liftBindAndScope :: Bool -- top level ? + -> CoreBinding -- As yet unprocessed + -> LiftM BindsOrExpr -- Do the scope of the bindings + -> LiftM (CoreBinding, -- Processed + BindsOrExpr) + +liftBindAndScope top_lev bind scopeM + = liftBinders top_lev bind ( liftCoreBind bind `thenL` \ bind -> scopeM `thenL` \ bindsorexpr -> returnL (bind, bindsorexpr) ) - where - binders = bindersOf bind - -liftCoreAtom :: PlainCoreAtom -> LiftM (PlainCoreAtom, PlainCoreExpr -> PlainCoreExpr) -liftCoreAtom (CoLitAtom lit) - = returnL (CoLitAtom lit, id) +----------------------- +liftCoreArg :: CoreArg -> LiftM (CoreArg, CoreExpr -> CoreExpr) -liftCoreAtom (CoVarAtom v) +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 -> case lifted of + Nothing -> returnL (arg, id) + Just (lifted, unlifted) -> - returnL (CoVarAtom unlifted, bindUnlift lifted unlifted) - Nothing -> - returnL (CoVarAtom v, id) + returnL (VarArg unlifted, bindUnlift lifted unlifted) -liftCoreBind :: PlainCoreBinding -> LiftM PlainCoreBinding +----------------------- +liftCoreBind :: CoreBinding -> LiftM CoreBinding -liftCoreBind (CoNonRec b rhs) +liftCoreBind (NonRec b rhs) = liftOneBind (b,rhs) `thenL` \ (b,rhs) -> - returnL (CoNonRec b rhs) + returnL (NonRec b rhs) -liftCoreBind (CoRec pairs) - = mapL liftOneBind pairs `thenL` \ pairs -> - returnL (CoRec pairs) +liftCoreBind (Rec pairs) + = mapL liftOneBind pairs `thenL` \ pairs -> + returnL (Rec pairs) +----------------------- liftOneBind (binder,rhs) = liftCoreExpr rhs `thenL` \ rhs -> isLiftedId binder `thenL` \ lifted -> @@ -111,100 +111,96 @@ liftOneBind (binder,rhs) Just (lifted, unlifted) -> returnL (lifted, liftExpr unlifted rhs) Nothing -> - returnL (binder, rhs) + returnL (binder, rhs) -liftCoreExpr :: PlainCoreExpr -> LiftM PlainCoreExpr +----------------------- +liftCoreExpr :: CoreExpr -> LiftM CoreExpr -liftCoreExpr (CoVar var) +liftCoreExpr expr@(Var var) = isLiftedId var `thenL` \ lifted -> case lifted of + Nothing -> returnL expr Just (lifted, unlifted) -> - returnL (bindUnlift lifted unlifted (CoVar unlifted)) - Nothing -> - returnL (CoVar var) + returnL (bindUnlift lifted unlifted (Var unlifted)) -liftCoreExpr (CoLit lit) - = returnL (CoLit lit) +liftCoreExpr expr@(Lit lit) = returnL expr -liftCoreExpr (CoSCC label expr) +liftCoreExpr (SCC label expr) = liftCoreExpr expr `thenL` \ expr -> - returnL (CoSCC label expr) + returnL (SCC label expr) -liftCoreExpr (CoLet (CoNonRec binder rhs) body) -- special case: for speed - = liftCoreExpr rhs `thenL` \ rhs2 -> - liftCoreExpr body `thenL` \ body2 -> - returnL (mkCoLetUnboxedToCase (CoNonRec binder rhs2) body2) +liftCoreExpr (Coerce coerce ty expr) + = liftCoreExpr expr `thenL` \ expr -> + returnL (Coerce coerce ty expr) -- ToDo:right?:Coerce + +liftCoreExpr (Let (NonRec binder rhs) body) -- special case: no lifting + = liftCoreExpr rhs `thenL` \ rhs -> + liftCoreExpr body `thenL` \ body -> + returnL (mkCoLetUnboxedToCase (NonRec binder rhs) body) -liftCoreExpr (CoLet bind body) -- general case - = liftBindAndScope False{-not top-level-} (is_rec bind) bind ( +liftCoreExpr (Let bind body) -- general case + = liftBindAndScope False bind ( liftCoreExpr body `thenL` \ body -> returnL (ItsAnExpr body) ) `thenL` \ (bind, ItsAnExpr body) -> - returnL (CoLet bind body) + returnL (Let bind body) -liftCoreExpr (CoCon con tys args) - = mapAndUnzipL liftCoreAtom args `thenL` \ (args, unlifts) -> - returnL (applyBindUnlifts unlifts (CoCon con tys args)) +liftCoreExpr (Con con args) + = mapAndUnzipL liftCoreArg args `thenL` \ (args, unlifts) -> + returnL (applyBindUnlifts unlifts (Con con args)) -liftCoreExpr (CoPrim op tys args) - = mapAndUnzipL liftCoreAtom args `thenL` \ (args, unlifts) -> - returnL (applyBindUnlifts unlifts (CoPrim op tys args)) +liftCoreExpr (Prim op args) + = mapAndUnzipL liftCoreArg args `thenL` \ (args, unlifts) -> + returnL (applyBindUnlifts unlifts (Prim op args)) -liftCoreExpr (CoApp fun arg) +liftCoreExpr (App fun arg) = lift_app fun [arg] where - lift_app (CoApp fun arg) args + lift_app (App fun arg) args = lift_app fun (arg:args) lift_app other_fun args = liftCoreExpr other_fun `thenL` \ other_fun -> - mapAndUnzipL liftCoreAtom args `thenL` \ (args, unlifts) -> - returnL (applyBindUnlifts unlifts (foldl CoApp other_fun args)) - -liftCoreExpr (CoTyApp fun ty_arg) - = liftCoreExpr fun `thenL` \ fun -> - returnL (CoTyApp fun ty_arg) - -liftCoreExpr (CoLam binders expr) - = liftCoreExpr expr `thenL` \ expr -> - returnL (CoLam binders expr) + mapAndUnzipL liftCoreArg args `thenL` \ (args, unlifts) -> + returnL (applyBindUnlifts unlifts (mkGenApp other_fun args)) -liftCoreExpr (CoTyLam tyvar expr) +liftCoreExpr (Lam binder expr) = liftCoreExpr expr `thenL` \ expr -> - returnL (CoTyLam tyvar expr) + returnL (Lam binder expr) -liftCoreExpr (CoCase scrut alts) +liftCoreExpr (Case scrut alts) = liftCoreExpr scrut `thenL` \ scrut -> liftCoreAlts alts `thenL` \ alts -> - returnL (CoCase scrut alts) + returnL (Case scrut alts) +------------ +liftCoreAlts :: CoreCaseAlts -> LiftM CoreCaseAlts -liftCoreAlts :: PlainCoreCaseAlternatives -> LiftM PlainCoreCaseAlternatives - -liftCoreAlts (CoAlgAlts alg_alts deflt) +liftCoreAlts (AlgAlts alg_alts deflt) = mapL liftAlgAlt alg_alts `thenL` \ alg_alts -> liftDeflt deflt `thenL` \ deflt -> - returnL (CoAlgAlts alg_alts deflt) + returnL (AlgAlts alg_alts deflt) -liftCoreAlts (CoPrimAlts prim_alts deflt) +liftCoreAlts (PrimAlts prim_alts deflt) = mapL liftPrimAlt prim_alts `thenL` \ prim_alts -> liftDeflt deflt `thenL` \ deflt -> - returnL (CoPrimAlts prim_alts deflt) - + returnL (PrimAlts prim_alts deflt) +------------ liftAlgAlt (con,args,rhs) = liftCoreExpr rhs `thenL` \ rhs -> returnL (con,args,rhs) +------------ liftPrimAlt (lit,rhs) = liftCoreExpr rhs `thenL` \ rhs -> returnL (lit,rhs) - -liftDeflt CoNoDefault - = returnL CoNoDefault -liftDeflt (CoBindDefault binder rhs) - = liftCoreExpr rhs `thenL` \ rhs -> - returnL (CoBindDefault binder rhs) +------------ +liftDeflt NoDefault + = returnL NoDefault +liftDeflt (BindDefault binder rhs) + = liftCoreExpr rhs `thenL` \ rhs -> + returnL (BindDefault binder rhs) \end{code} %************************************************************************ @@ -214,28 +210,28 @@ liftDeflt (CoBindDefault binder rhs) %************************************************************************ \begin{code} -type LiftM a = IdEnv (Id, Id) -- lifted Ids are mapped to: - -- * lifted Id with the same Unique - -- (top-level bindings must keep their - -- unique (see TopLevId in Id.lhs)) - -- * unlifted version with a new Unique - -> SplitUniqSupply -- unique supply - -> a -- result +type LiftM a + = IdEnv (Id, Id) -- lifted Ids are mapped to: + -- * lifted Id with the same Unique + -- (top-level bindings must keep their + -- unique (see TopLevId in Id.lhs)) + -- * unlifted version with a new Unique + -> UniqSupply -- unique supply + -> a -- result -data BindsOrExpr = ItsABinds [PlainCoreBinding] - | ItsAnExpr PlainCoreExpr +data BindsOrExpr + = ItsABinds [CoreBinding] + | ItsAnExpr CoreExpr -initL m us - = m nullIdEnv us +initL m us = m nullIdEnv us returnL :: a -> LiftM a -returnL r idenv us - = r +returnL r idenv us = r thenL :: LiftM a -> (a -> LiftM b) -> LiftM b thenL m k idenv s0 - = case splitUniqSupply s0 of { (s1, s2) -> - case (m idenv s1) of { r -> + = case (splitUniqSupply s0) of { (s1, s2) -> + case (m idenv s1) of { r -> k r idenv s2 }} @@ -253,63 +249,70 @@ mapAndUnzipL f (x:xs) mapAndUnzipL f xs `thenL` \ (rs1,rs2) -> returnL ((r1:rs1),(r2:rs2)) +-- liftBinders is only called for top-level or recusive case +liftBinders :: Bool -> CoreBinding -> LiftM thing -> LiftM thing -liftBinders :: Bool -> Bool -> [Id] -> LiftM thing -> LiftM thing -liftBinders toplev is_rec ids liftM idenv s0 +liftBinders False (NonRec _ _) liftM idenv s0 + = panic "CoreLift:liftBinders" -- should be caught by special case above ---ToDo | toplev || is_rec -- *must* play the lifting game - = liftM (growIdEnvList idenv lift_map) s1 +liftBinders top_lev bind liftM idenv s0 + = liftM (growIdEnvList idenv lift_map) s2 where - lift_ids = [ id | id <- ids, is_unboxed_but_not_state (getIdUniType id) ] - (lift_uniqs, s1) = getSUniquesAndDepleted (length lift_ids) s0 - lift_map = zip lift_ids (zipWith mkLiftedId lift_ids lift_uniqs) + (s1, s2) = splitUniqSupply s0 + lift_ids = [ id | id <- bindersOf bind, isUnboxedButNotState (idType id) ] + lift_uniqs = getUniques (length lift_ids) s1 + lift_map = zipEqual "liftBinders" lift_ids (zipWithEqual "liftBinders" mkLiftedId lift_ids lift_uniqs) + + -- ToDo: Give warning for recursive bindings involving unboxed values ??? isLiftedId :: Id -> LiftM (Maybe (Id, Id)) isLiftedId id idenv us - | isLocallyDefined id + | isLocallyDefined id = lookupIdEnv idenv id | otherwise -- ensure all imported ids are lifted - = if is_unboxed_but_not_state (getIdUniType id) - then Just (mkLiftedId id (getSUnique us)) + = if isUnboxedButNotState (idType id) + then Just (mkLiftedId id (getUnique us)) else Nothing mkLiftedId :: Id -> Unique -> (Id,Id) mkLiftedId id u - = ASSERT (is_unboxed_but_not_state unlifted_ty) + = ASSERT (isUnboxedButNotState unlifted_ty) (lifted_id, unlifted_id) where - id_name = getOccurrenceName id + id_name = panic "CoreLift.mkLiftedId:id_name" --LATER: getOccName id lifted_id = updateIdType id lifted_ty unlifted_id = mkSysLocal id_name u unlifted_ty (getSrcLoc id) - unlifted_ty = getIdUniType id + unlifted_ty = idType id lifted_ty = mkLiftTy unlifted_ty -bindUnlift :: Id -> Id -> PlainCoreExpr -> PlainCoreExpr +bindUnlift :: Id -> Id -> CoreExpr -> CoreExpr bindUnlift vlift vunlift expr - = ASSERT (is_unboxed_but_not_state unlift_ty && lift_ty == mkLiftTy unlift_ty) - CoCase (CoVar vlift) - (CoAlgAlts [(liftDataCon, [vunlift], expr)] CoNoDefault) + = ASSERT (isUnboxedButNotState unlift_ty) + ASSERT (lift_ty `eqTy` mkLiftTy unlift_ty) + Case (Var vlift) + (AlgAlts [(liftDataCon, [vunlift], expr)] NoDefault) where - lift_ty = getIdUniType vlift - unlift_ty = getIdUniType vunlift + lift_ty = idType vlift + unlift_ty = idType vunlift -liftExpr :: Id -> PlainCoreExpr -> PlainCoreExpr +liftExpr :: Id -> CoreExpr -> CoreExpr liftExpr vunlift rhs - = ASSERT (is_unboxed_but_not_state unlift_ty && rhs_ty == unlift_ty) - CoCase rhs (CoPrimAlts [] (CoBindDefault vunlift - (CoCon liftDataCon [unlift_ty] [CoVarAtom vunlift]))) + = ASSERT (isUnboxedButNotState unlift_ty) + ASSERT (rhs_ty `eqTy` unlift_ty) + Case rhs (PrimAlts [] + (BindDefault vunlift (mkCon liftDataCon [] [unlift_ty] [VarArg vunlift]))) where - rhs_ty = typeOfCoreExpr rhs - unlift_ty = getIdUniType vunlift + rhs_ty = coreExprType rhs + unlift_ty = idType vunlift -applyBindUnlifts :: [PlainCoreExpr -> PlainCoreExpr] -> PlainCoreExpr -> PlainCoreExpr +applyBindUnlifts :: [CoreExpr -> CoreExpr] -> CoreExpr -> CoreExpr applyBindUnlifts [] expr = expr applyBindUnlifts (f:fs) expr = f (applyBindUnlifts fs expr) -is_unboxed_but_not_state ty - = case (getUniDataTyCon_maybe ty) of +isUnboxedButNotState ty + = case (maybeAppDataTyConExpandingDicts ty) of Nothing -> False Just (tycon, _, _) -> not (isBoxedTyCon tycon) && not (tycon == statePrimTyCon)