Convert a @CoreSyntax@ program to a @StgSyntax@ program.
\begin{code}
-module CoreToStg ( topCoreBindsToStg ) where
+module CoreToStg ( topCoreBindsToStg, coreToStgExpr ) where
#include "HsVersions.h"
import CoreUtils ( exprType )
import SimplUtils ( findDefault )
import CostCentre ( noCCS )
-import Id ( Id, mkSysLocal, idType, idStrictness, isExportedId,
+import Id ( Id, mkSysLocal, idType, idStrictness,
mkVanillaId, idName, idDemandInfo, idArity, setIdType,
idFlavour
)
+import Module ( Module )
import IdInfo ( StrictnessInfo(..), IdFlavour(..) )
-import DataCon ( dataConWrapId )
+import DataCon ( dataConWrapId, dataConTyCon )
+import TyCon ( isAlgTyCon )
import Demand ( Demand, isStrict, wwLazy )
-import Name ( setNameUnique )
+import Name ( setNameUnique, globaliseName, isLocalName, isGlobalName )
import VarEnv
import PrimOp ( PrimOp(..), setCCallUnique )
import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
- UsageAnn(..), tyUsg, applyTy, repType, seqType,
- splitRepFunTys, mkFunTys
+ applyTy, repType, seqType, splitTyConApp_maybe, splitTyConApp,
+ splitRepFunTys, mkFunTys,
+ uaUTy, usOnce, usMany, isTyVarTy
)
import UniqSupply -- all of it, really
-import BasicTypes ( TopLevelFlag(..), isNotTopLevel )
import UniqSet ( emptyUniqSet )
+import ErrUtils ( showPass, dumpIfSet_dyn )
+import CmdLineOpts ( DynFlags, DynFlag(..) )
import Maybes
import Outputable
\end{code}
are globally unique, not simply not-in-scope, which is all that
the simplifier ensures.
+4. If we are going to do object-file splitting, we make ALL top-level
+ names into Globals. Why?
+
+ In certain (prelude only) modules we split up the .hc file into
+ lots of separate little files, which are separately compiled by the C
+ compiler. That gives lots of little .o files. The idea is that if
+ you happen to mention one of them you don't necessarily pull them all
+ in. (Pulling in a piece you don't need can be v bad, because it may
+ mention other pieces you don't need either, and so on.)
+
+ Sadly, splitting up .hc files means that local names (like s234) are
+ now globally visible, which can lead to clashes between two .hc
+ files. So we make them all Global, so they are printed complete
+ with their module name.
+
+ We don't want to do this in CoreTidy, because at that stage we use
+ Global to mean "external" and hence "should appear in interface files".
+ This object-file splitting thing is a code generator matter that we
+ don't want to pollute earlier phases.
NOTE THAT:
#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))
\end{code}
\begin{code}
-topCoreBindsToStg :: UniqSupply -- name supply
- -> [CoreBind] -- input
- -> [StgBinding] -- output
-
-topCoreBindsToStg us core_binds
- = initUs_ us (coreBindsToStg emptyVarEnv core_binds)
+topCoreBindsToStg :: DynFlags -> Module -> [CoreBind] -> IO [StgBinding]
+topCoreBindsToStg dflags mod core_binds
+ = do showPass dflags "Core2Stg"
+ us <- mkSplitUniqSupply 'c'
+ return (initUs_ us (coreBindsToStg emptyVarEnv core_binds))
where
+ top_flag = Top mod
+
coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding]
coreBindsToStg env [] = returnUs []
coreBindsToStg env (b:bs)
- = coreBindToStg TopLevel env b `thenUs` \ (bind_spec, new_env) ->
+ = coreBindToStg top_flag env b `thenUs` \ (bind_spec, new_env) ->
coreBindsToStg new_env bs `thenUs` \ new_bs ->
case bind_spec of
NonRecF bndr rhs dem floats
ppr b ) -- No top-level cases!
mkStgBinds floats rhs `thenUs` \ new_rhs ->
- returnUs (StgNonRec bndr (exprToRhs dem TopLevel new_rhs)
+ returnUs (StgNonRec bndr (exprToRhs dem top_flag new_rhs)
: new_bs)
-- Keep all the floats inside...
-- Some might be cases etc
returnUs new_bs
\end{code}
+%************************************************************************
+%* *
+\subsection[coreToStgExpr]{Converting an expression (for the interpreter)}
+%* *
+%************************************************************************
+
+\begin{code}
+coreToStgExpr :: DynFlags -> CoreExpr -> IO StgExpr
+coreToStgExpr dflags core_expr
+ = do showPass dflags "Core2Stg"
+ us <- mkSplitUniqSupply 'c'
+ let stg_expr = initUs_ us (coreExprToStg emptyVarEnv core_expr)
+ dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" (ppr stg_expr)
+ return stg_expr
+\end{code}
%************************************************************************
%* *
%************************************************************************
\begin{code}
-coreBindToStg :: TopLevelFlag -> StgEnv -> CoreBind -> UniqSM (StgFloatBind, StgEnv)
+coreBindToStg :: TopLvl -> StgEnv -> CoreBind -> UniqSM (StgFloatBind, StgEnv)
coreBindToStg top_lev env (NonRec binder rhs)
= coreExprToStgFloat env rhs `thenUs` \ (floats, stg_rhs) ->
case (floats, stg_rhs) of
- ([], StgApp var []) | not (isExportedId binder)
- -> returnUs (NoBindF, extendVarEnv env binder var)
+ ([], StgApp var [])
+ | not (isGlobalName (idName binder))
+ -> returnUs (NoBindF, extendVarEnv env binder var)
+
+ | otherwise
+ -> newBinder top_lev env binder `thenUs` \ (new_env, new_binder) ->
+ returnUs (NonRecF new_binder stg_rhs dem floats, extendVarEnv new_env binder var)
-- A trivial binding let x = y in ...
-- can arise if postSimplExpr floats a NoRep literal out
-- so it seems sensible to deal with it well.
-- But we don't want to discard exported things. They can
-- occur; e.g. an exported user binding f = g
- other -> newLocalId top_lev env binder `thenUs` \ (new_env, new_binder) ->
+ other -> newBinder top_lev env binder `thenUs` \ (new_env, new_binder) ->
returnUs (NonRecF new_binder stg_rhs dem floats, new_env)
where
dem = bdrDem binder
coreBindToStg top_lev env (Rec pairs)
- = newLocalIds top_lev env binders `thenUs` \ (env', binders') ->
+ = newBinders top_lev env binders `thenUs` \ (env', binders') ->
mapUs (do_rhs env') pairs `thenUs` \ stg_rhss ->
returnUs (RecF (binders' `zip` stg_rhss), env')
where
%************************************************************************
\begin{code}
-exprToRhs :: RhsDemand -> TopLevelFlag -> StgExpr -> StgRhs
+exprToRhs :: RhsDemand -> TopLvl -> StgExpr -> StgRhs
exprToRhs dem _ (StgLam _ bndrs body)
= ASSERT( not (null bndrs) )
StgRhsClosure noCCS
then be run at load time to fix up static closures.
-}
exprToRhs dem toplev (StgConApp con args)
- | isNotTopLevel toplev || not (isDllConApp con args)
+ | isNotTop toplev || not (isDllConApp con args)
-- isDllConApp checks for LitLit args too
= StgRhsCon noCCS con args
-exprToRhs dem _ expr
+exprToRhs dem toplev expr
= upd `seq`
StgRhsClosure noCCS -- No cost centre (ToDo?)
stgArgOcc -- safe
[]
expr
where
- upd = if isOnceDem dem then SingleEntry else Updatable
- -- HA! Paydirt for "dem"
+ upd = if isOnceDem dem
+ then (if isNotTop 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}
= returnUs ([], StgLit lit)
coreExprToStgFloat env (Let bind body)
- = coreBindToStg NotTopLevel env bind `thenUs` \ (new_bind, new_env) ->
+ = coreBindToStg NotTop env bind `thenUs` \ (new_bind, new_env) ->
coreExprToStgFloat new_env body `thenUs` \ (floats, stg_body) ->
returnUs (new_bind:floats, stg_body)
\end{code}
(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
- newLocalIds NotTopLevel env id_binders `thenUs` \ (env', binders') ->
- coreExprToStgFloat env' body `thenUs` \ (floats, stg_body) ->
- mkStgBinds floats stg_body `thenUs` \ stg_body' ->
+ newLocalBinders env id_binders `thenUs` \ (env', binders') ->
+ coreExprToStgFloat env' body `thenUs` \ (floats, stg_body) ->
+ mkStgBinds floats stg_body `thenUs` \ stg_body' ->
case stg_body' of
StgLam ty lam_bndrs lam_body ->
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)
\begin{code}
coreExprToStgFloat env (Case scrut bndr alts)
= coreExprToStgFloat env scrut `thenUs` \ (binds, scrut') ->
- newLocalId NotTopLevel env bndr `thenUs` \ (env', bndr') ->
+ newLocalBinder env bndr `thenUs` \ (env', bndr') ->
alts_to_stg env' (findDefault alts) `thenUs` \ alts' ->
mkStgCase scrut' bndr' alts' `thenUs` \ expr' ->
returnUs (binds, expr')
returnUs (mkStgAlgAlts scrut_ty alts' deflt')
alg_alt_to_stg env (DataAlt con, bs, rhs)
- = newLocalIds NotTopLevel env (filter isId bs) `thenUs` \ (env', stg_bs) ->
- coreExprToStg env' rhs `thenUs` \ stg_rhs ->
+ = newLocalBinders env (filter isId bs) `thenUs` \ (env', stg_bs) ->
+ coreExprToStg env' rhs `thenUs` \ stg_rhs ->
returnUs (con, stg_bs, [ True | b <- stg_bs ]{-bogus use mask-}, stg_rhs)
-- NB the filter isId. Some of the binders may be
-- existential type variables, which STG doesn't care about
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}
\end{code}
\begin{code}
-newLocalId TopLevel env id
+----------------------------
+data TopLvl = Top Module | NotTop
+
+isNotTop NotTop = True
+isNotTop (Top _) = False
+
+----------------------------
+newBinder :: TopLvl -> StgEnv -> Id -> UniqSM (StgEnv, Id)
+newBinder (Top mod) env id = returnUs (env, newTopBinder mod id)
+newBinder NotTop env id = newLocalBinder env id
+
+newBinders (Top mod) env ids = returnUs (env, map (newTopBinder mod) ids)
+newBinders NotTop env ids = newLocalBinders env ids
+
+
+----------------------------
+newTopBinder mod id
-- Don't clone top-level binders. MkIface relies on their
-- uniques staying the same, so it can snaffle IdInfo off the
-- STG ids to put in interface files.
- = let
- name = idName id
- ty = idType id
- in
- name `seq`
+ = name' `seq`
seqType ty `seq`
- returnUs (env, mkVanillaId name ty)
-
-
-newLocalId NotTopLevel env id
+ mkVanillaId name' ty
+ where
+ name = idName id
+ name' | isLocalName name = globaliseName name mod
+ | otherwise = name
+ ty = idType id
+
+----------------------------
+newLocalBinder :: StgEnv -> Id -> UniqSM (StgEnv, Id)
+newLocalBinder env id
= -- Local binder, give it a new unique Id.
getUniqueUs `thenUs` \ uniq ->
let
seqType ty `seq`
returnUs (new_env, new_id)
-newLocalIds :: TopLevelFlag -> StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
-newLocalIds top_lev env []
+----------------------------
+newLocalBinders :: StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
+newLocalBinders env []
= returnUs (env, [])
-newLocalIds top_lev env (b:bs)
- = newLocalId top_lev env b `thenUs` \ (env', b') ->
- newLocalIds top_lev env' bs `thenUs` \ (env'', bs') ->
+
+newLocalBinders env (b:bs)
+ = newLocalBinder env b `thenUs` \ (env', b') ->
+ newLocalBinders env' bs `thenUs` \ (env'', bs') ->
returnUs (env'', b':bs')
\end{code}
%************************************************************************
\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
#endif
| isUnLiftedType bndr_rep_ty -- Use a case/PrimAlts
= ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
- mkStgCase rhs bndr (StgPrimAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' ->
+ mkStgCase rhs bndr (mkStgPrimAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' ->
mkStgBinds floats expr'
| is_whnf
= if is_strict then
-- Strict let with WHNF rhs
mkStgBinds floats $
- StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel rhs)) body
+ StgLet (StgNonRec bndr (exprToRhs dem NotTop rhs)) body
else
-- Lazy let with WHNF rhs; float until we find a strict binding
let
in
mkStgBinds floats_in rhs `thenUs` \ new_rhs ->
mkStgBinds floats_out $
- StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body
+ StgLet (StgNonRec bndr (exprToRhs dem NotTop new_rhs)) body
| otherwise -- Not WHNF
= if is_strict then
-- Strict let with non-WHNF rhs
- mkStgCase rhs bndr (StgAlgAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' ->
+ 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 ->
- returnUs (StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body)
+ returnUs (StgLet (StgNonRec bndr (exprToRhs dem NotTop new_rhs)) body)
where
bndr_rep_ty = repType (idType bndr)
\begin{code}
-- Discard alernatives in case (par# ..) of
mkStgCase scrut@(StgPrimApp ParOp _ _) bndr
- (StgPrimAlts ty _ deflt@(StgBindDefault _))
- = returnUs (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 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#
projects / ghc-hetmet.git / blobdiff