Commit 61a00ea2 authored by twanvl's avatar twanvl

Fixed warnings in stgSyn/StgSyn

parent 39dbcf69
......@@ -9,13 +9,6 @@ form of @CoreSyntax@, the style being one that happens to be ideally
suited to spineless tagless code generation.
\begin{code}
{-# OPTIONS -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
module StgSyn (
GenStgArg(..),
GenStgLiveVars,
......@@ -69,7 +62,7 @@ import Outputable
import Util ( count )
import Type ( Type )
import TyCon ( TyCon )
import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet )
import UniqSet
import Unique ( Unique )
import Bitmap
import StaticFlags ( opt_SccProfilingOn )
......@@ -109,14 +102,14 @@ data GenStgArg occ
\end{code}
\begin{code}
isStgTypeArg :: StgArg -> Bool
isStgTypeArg (StgTypeArg _) = True
isStgTypeArg other = False
isStgTypeArg _ = False
isDllArg :: PackageId -> StgArg -> Bool
-- Does this argument refer to something in a different DLL?
isDllArg this_pkg (StgTypeArg v) = False
isDllArg this_pkg (StgVarArg v) = isDllName this_pkg (idName v)
isDllArg this_pkg (StgLitArg lit) = False
isDllArg this_pkg (StgVarArg v) = isDllName this_pkg (idName v)
isDllArg _ _ = False
isDllConApp :: PackageId -> DataCon -> [StgArg] -> Bool
-- Does this constructor application refer to
......@@ -129,7 +122,7 @@ stgArgType :: StgArg -> Type
-- Very half baked becase we have lost the type arguments
stgArgType (StgVarArg v) = idType v
stgArgType (StgLitArg lit) = literalType lit
stgArgType (StgTypeArg lit) = panic "stgArgType called on stgTypeArg"
stgArgType (StgTypeArg _) = panic "stgArgType called on stgTypeArg"
\end{code}
%************************************************************************
......@@ -436,11 +429,13 @@ stgBindHasCafRefs :: GenStgBinding bndr Id -> Bool
stgBindHasCafRefs (StgNonRec _ rhs) = rhsHasCafRefs rhs
stgBindHasCafRefs (StgRec binds) = any rhsHasCafRefs (map snd binds)
rhsHasCafRefs :: GenStgRhs bndr Id -> Bool
rhsHasCafRefs (StgRhsClosure _ _ _ upd srt _ _)
= isUpdatable upd || nonEmptySRT srt
rhsHasCafRefs (StgRhsCon _ _ args)
= any stgArgHasCafRefs args
stgArgHasCafRefs :: GenStgArg Id -> Bool
stgArgHasCafRefs (StgVarArg id) = mayHaveCafRefs (idCafInfo id)
stgArgHasCafRefs _ = False
\end{code}
......@@ -454,6 +449,7 @@ data StgBinderInfo
-- slow entry code for the thing
-- Thunks never get this value
noBinderInfo, stgUnsatOcc, stgSatOcc :: StgBinderInfo
noBinderInfo = NoStgBinderInfo
stgUnsatOcc = NoStgBinderInfo
stgSatOcc = SatCallsOnly
......@@ -464,9 +460,10 @@ satCallsOnly NoStgBinderInfo = False
combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
combineStgBinderInfo SatCallsOnly SatCallsOnly = SatCallsOnly
combineStgBinderInfo info1 info2 = NoStgBinderInfo
combineStgBinderInfo _ _ = NoStgBinderInfo
--------------
pp_binder_info :: StgBinderInfo -> SDoc
pp_binder_info NoStgBinderInfo = empty
pp_binder_info SatCallsOnly = ptext SLIT("sat-only")
\end{code}
......@@ -543,6 +540,7 @@ instance Outputable UpdateFlag where
ppr u
= char (case u of { ReEntrant -> 'r'; Updatable -> 'u'; SingleEntry -> 's' })
isUpdatable :: UpdateFlag -> Bool
isUpdatable ReEntrant = False
isUpdatable SingleEntry = False
isUpdatable Updatable = True
......@@ -588,16 +586,15 @@ data SRT = NoSRT
| SRT !Int{-offset-} !Int{-length-} !Bitmap{-bitmap-}
-- generated by computeSRTs
noSRT :: SRT
noSRT = NoSRT
nonEmptySRT :: SRT -> Bool
nonEmptySRT NoSRT = False
nonEmptySRT (SRTEntries vs) = not (isEmptyVarSet vs)
nonEmptySRT _ = True
pprSRT (NoSRT) = ptext SLIT("_no_srt_")
pprSRT :: SRT -> SDoc
pprSRT (NoSRT) = ptext SLIT("_no_srt_")
pprSRT (SRTEntries ids) = text "SRT:" <> ppr ids
pprSRT (SRT off length bitmap) = parens (ppr off <> comma <> text "*bitmap*")
pprSRT (SRT off _ _) = parens (ppr off <> comma <> text "*bitmap*")
\end{code}
%************************************************************************
......@@ -762,10 +759,13 @@ pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts)
nest 2 (vcat (map pprStgAlt alts)),
char '}']
pprStgAlt (con, params, use_mask, expr)
pprStgAlt :: (Outputable bndr, Outputable occ, Ord occ)
=> GenStgAlt bndr occ -> SDoc
pprStgAlt (con, params, _use_mask, expr)
= hang (hsep [ppr con, interppSP params, ptext SLIT("->")])
4 (ppr expr <> semi)
pprStgOp :: StgOp -> SDoc
pprStgOp (StgPrimOp op) = ppr op
pprStgOp (StgFCallOp op _) = ppr op
......@@ -777,6 +777,7 @@ instance Outputable AltType where
\end{code}
\begin{code}
#ifdef DEBUG
pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
pprStgLVs lvs
= getPprStyle $ \ sty ->
......@@ -784,6 +785,7 @@ pprStgLVs lvs
empty
else
hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
#endif
\end{code}
\begin{code}
......@@ -809,6 +811,7 @@ pprStgRhs (StgRhsCon cc con args)
= hcat [ ppr cc,
space, ppr con, ptext SLIT("! "), brackets (interppSP args)]
pprMaybeSRT :: SRT -> SDoc
pprMaybeSRT (NoSRT) = empty
pprMaybeSRT srt = ptext SLIT("srt:") <> pprSRT srt
\end{code}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment