X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=c69ae3720d43c53454e7a69b145f511823079225;hb=ea659be5faea43df1b2c113d2f22947dff23367e;hp=6e2d065b5f90655f92c7c850c860561beb0e3e09;hpb=e4b0fab5a594c4ea29ddecdf216b4887420f26a4;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 6e2d065..c69ae37 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -20,29 +20,24 @@ import StgSyn -- output import CoreUtils ( exprType ) import SimplUtils ( findDefault ) import CostCentre ( noCCS ) -import Id ( Id, mkSysLocal, idType, idStrictness, idUnique, isExportedId, mkVanillaId, - externallyVisibleId, setIdUnique, idName, - idDemandInfo, idArity, setIdType, idFlavour +import Id ( Id, mkSysLocal, idType, idStrictness, isExportedId, + mkVanillaId, idName, idDemandInfo, idArity, setIdType, + idFlavour ) -import Var ( Var, varType, modifyIdInfo ) -import IdInfo ( setDemandInfo, StrictnessInfo(..), IdFlavour(..) ) -import UsageSPUtils ( primOpUsgTys ) -import DataCon ( DataCon, dataConName, isDynDataCon, dataConWrapId ) -import Demand ( Demand, isStrict, wwStrict, wwLazy ) -import Name ( Name, nameModule, isLocallyDefinedName, setNameUnique ) -import Module ( isDynamicModule ) -import Literal ( Literal(..) ) +import IdInfo ( StrictnessInfo(..), IdFlavour(..) ) +import DataCon ( dataConWrapId, dataConTyCon ) +import TyCon ( isAlgTyCon ) +import Demand ( Demand, isStrict, wwLazy ) +import Name ( setNameUnique ) import VarEnv -import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..), primOpUsg ) +import PrimOp ( PrimOp(..), setCCallUnique ) import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe, - UsageAnn(..), tyUsg, applyTy, mkUsgTy, repType, seqType, - splitRepFunTys, mkFunTys + applyTy, repType, seqType, splitTyConApp_maybe, splitTyConApp, + splitRepFunTys, mkFunTys, + uaUTy, usOnce, usMany, isTyVarTy ) -import TysPrim ( intPrimTy ) import UniqSupply -- all of it, really -import Util ( lengthExceeds ) -import BasicTypes ( TopLevelFlag(..), isNotTopLevel, Arity ) -import CmdLineOpts ( opt_D_verbose_stg2stg, opt_UsageSPOn ) +import BasicTypes ( TopLevelFlag(..), isNotTopLevel ) import UniqSet ( emptyUniqSet ) import Maybes import Outputable @@ -151,10 +146,12 @@ isOnceTy ty #ifdef USMANY opt_UsageSPOn && -- can't expect annotations if -fusagesp is off #endif - case tyUsg ty of - UsOnce -> True - UsMany -> False - UsVar uv -> pprPanic "CoreToStg: unexpected uvar annot:" (ppr uv) + once + where + u = uaUTy ty + once | u == usOnce = True + | u == usMany = False + | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany bdrDem :: Id -> RhsDemand bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id)) @@ -173,12 +170,10 @@ locations. \begin{code} bOGUS_LVs :: StgLiveVars -bOGUS_LVs | opt_D_verbose_stg2stg = emptyUniqSet - | otherwise =panic "bOGUS_LVs" +bOGUS_LVs = emptyUniqSet bOGUS_FVs :: [Id] -bOGUS_FVs | opt_D_verbose_stg2stg = [] - | otherwise = panic "bOGUS_FVs" +bOGUS_FVs = [] \end{code} \begin{code} @@ -302,14 +297,11 @@ exprToRhs dem _ (StgLam _ bndrs body) then be run at load time to fix up static closures. -} exprToRhs dem toplev (StgConApp con args) - | isNotTopLevel toplev || - (not is_dynamic && - all (not . isLitLitArg) args) + | isNotTopLevel toplev || not (isDllConApp con args) + -- isDllConApp checks for LitLit args too = StgRhsCon noCCS con args - where - is_dynamic = isDynDataCon con || any (isDynArg) args -exprToRhs dem _ expr +exprToRhs dem toplev expr = upd `seq` StgRhsClosure noCCS -- No cost centre (ToDo?) stgArgOcc -- safe @@ -319,8 +311,22 @@ exprToRhs dem _ expr [] expr where - upd = if isOnceDem dem then SingleEntry else Updatable - -- HA! Paydirt for "dem" + upd = if isOnceDem dem + then (if isNotTopLevel toplev + then SingleEntry -- HA! Paydirt for "dem" + else +#ifdef DEBUG + trace "WARNING: SE CAFs unsupported, forcing UPD instead" $ +#endif + Updatable) + else Updatable + -- For now we forbid SingleEntry CAFs; they tickle the + -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link, + -- and I don't understand why. There's only one SE_CAF (well, + -- only one that tickled a great gaping bug in an earlier attempt + -- at ClosureInfo.getEntryConvention) in the whole of nofib, + -- specifically Main.lvl6 in spectral/cryptarithm2. + -- So no great loss. KSW 2000-07. \end{code} @@ -436,7 +442,7 @@ coreExprToStgFloat env expr@(Lam _ _) (binders, body) = collectBinders expr id_binders = filter isId binders in - if null id_binders then -- It was all type/usage binders; tossed + if null id_binders then -- It was all type binders; tossed coreExprToStgFloat env body else -- At least some value binders @@ -507,7 +513,6 @@ coreExprToStgFloat env expr@(App _ _) collect_args (Note (Coerce ty _) e) = let (the_fun,ads,_,ss) = collect_args e in (the_fun,ads,ty,ss) collect_args (Note InlineCall e) = collect_args e - collect_args (Note (TermUsg _) e) = collect_args e collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty,ss) = collect_args fun in (the_fun,ads,applyTy fun_ty tyarg,ss) @@ -546,7 +551,8 @@ coreExprToStgFloat env (Case scrut bndr alts) = coreExprToStgFloat env scrut `thenUs` \ (binds, scrut') -> newLocalId NotTopLevel env bndr `thenUs` \ (env', bndr') -> alts_to_stg env' (findDefault alts) `thenUs` \ alts' -> - returnUs (binds, mkStgCase scrut' bndr' alts') + mkStgCase scrut' bndr' alts' `thenUs` \ expr' -> + returnUs (binds, expr') where scrut_ty = idType bndr prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty) @@ -580,8 +586,6 @@ coreExprToStgFloat env (Case scrut bndr alts) default_to_stg env (Just rhs) = coreExprToStg env rhs `thenUs` \ stg_rhs -> returnUs (StgBindDefault stg_rhs) - -- The binder is used for prim cases and not otherwise - -- (hack for old code gen) \end{code} @@ -647,9 +651,26 @@ newLocalIds top_lev env (b:bs) %************************************************************************ \begin{code} -mkStgAlgAlts ty alts deflt = seqType ty `seq` StgAlgAlts ty alts deflt -mkStgPrimAlts ty alts deflt = seqType ty `seq` StgPrimAlts ty alts deflt -mkStgLam ty bndrs body = seqType ty `seq` StgLam ty bndrs body +-- There are two things going on in mkStgAlgAlts +-- a) We pull out the type constructor for the case, from the data +-- constructor, if there is one. See notes with the StgAlgAlts data type +-- b) We force the type constructor to avoid space leaks + +mkStgAlgAlts ty alts deflt + = case alts of + -- Get the tycon from the data con + (dc, _, _, _):_ -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt + + -- Otherwise just do your best + [] -> case splitTyConApp_maybe (repType ty) of + Just (tc,_) | isAlgTyCon tc -> StgAlgAlts (Just tc) alts deflt + other -> StgAlgAlts Nothing alts deflt + +mkStgPrimAlts ty alts deflt + = case splitTyConApp ty of + (tc,_) -> StgPrimAlts tc alts deflt + +mkStgLam ty bndrs body = seqType ty `seq` StgLam ty bndrs body mkStgApp :: StgEnv -> Id -> [StgArg] -> Type -> UniqSM StgExpr -- The type is the type of the entire application @@ -659,11 +680,14 @@ mkStgApp env fn args ty -> saturate fn_alias args ty $ \ args' ty' -> returnUs (StgConApp dc args') - PrimOpId (CCallOp (CCall (DynamicTarget _) a b c)) + PrimOpId (CCallOp ccall) -- Sigh...make a guaranteed unique name for a dynamic ccall + -- Done here, not earlier, because it's a code-gen thing -> saturate fn_alias args ty $ \ args' ty' -> - getUniqueUs `thenUs` \ u -> - returnUs (StgPrimApp (CCallOp (CCall (DynamicTarget u) a b c)) args' ty') + getUniqueUs `thenUs` \ uniq -> + let ccall' = setCCallUnique ccall uniq in + returnUs (StgPrimApp (CCallOp ccall') args' ty') + PrimOpId op -> saturate fn_alias args ty $ \ args' ty' -> @@ -792,8 +816,8 @@ mk_stg_let bndr rhs dem floats body #endif | isUnLiftedType bndr_rep_ty -- Use a case/PrimAlts = ASSERT( not (isUnboxedTupleType bndr_rep_ty) ) - mkStgBinds floats $ - mkStgCase rhs bndr (StgPrimAlts bndr_rep_ty [] (StgBindDefault body)) + mkStgCase rhs bndr (mkStgPrimAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' -> + mkStgBinds floats expr' | is_whnf = if is_strict then @@ -812,8 +836,8 @@ mk_stg_let bndr rhs dem floats body | otherwise -- Not WHNF = if is_strict then -- Strict let with non-WHNF rhs - mkStgBinds floats $ - mkStgCase rhs bndr (StgAlgAlts bndr_rep_ty [] (StgBindDefault body)) + mkStgCase rhs bndr (mkStgAlgAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' -> + mkStgBinds floats expr' else -- Lazy let with non-WHNF rhs, so keep the floats in the RHS mkStgBinds floats rhs `thenUs` \ new_rhs -> @@ -887,15 +911,15 @@ way to enforce ordering --SDM. \begin{code} -- Discard alernatives in case (par# ..) of mkStgCase scrut@(StgPrimApp ParOp _ _) bndr - (StgPrimAlts ty _ deflt@(StgBindDefault _)) - = StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts ty [] deflt) + (StgPrimAlts tycon _ deflt@(StgBindDefault _)) + = returnUs (StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts tycon [] deflt)) mkStgCase (StgPrimApp SeqOp [scrut] _) bndr (StgPrimAlts _ _ deflt@(StgBindDefault rhs)) - = mkStgCase scrut_expr new_bndr (StgAlgAlts scrut_ty [] (StgBindDefault rhs)) + = mkStgCase scrut_expr new_bndr new_alts where - new_alts | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) StgPrimAlts scrut_ty [] deflt - | otherwise = StgAlgAlts scrut_ty [] deflt + new_alts | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) mkStgPrimAlts scrut_ty [] deflt + | otherwise = mkStgAlgAlts scrut_ty [] deflt scrut_ty = stgArgType scrut new_bndr = setIdType bndr scrut_ty -- NB: SeqOp :: forall a. a -> Int# @@ -911,9 +935,15 @@ mkStgCase (StgPrimApp SeqOp [scrut] _) bndr StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l mkStgCase scrut bndr alts - = ASSERT( case scrut of { StgLam _ _ _ -> False; other -> True } ) - -- We should never find - -- case (\x->e) of { ... } - -- The simplifier eliminates such things - StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT alts + = deStgLam scrut `thenUs` \ scrut' -> + -- It is (just) possible to get a lambda as a srutinee here + -- Namely: fromDyn (toDyn ((+1)::Int->Int)) False) + -- gives: case ...Bool == Int->Int... of + -- True -> case coerce Bool (\x -> + 1 x) of + -- True -> ... + -- False -> ... + -- False -> ... + -- The True branch of the outer case will never happen, of course. + + returnUs (StgCase scrut' bOGUS_LVs bOGUS_LVs bndr noSRT alts) \end{code}