X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FstgSyn%2FStgSyn.lhs;h=893358b8cd878de2fe68ee3a40c87a17bcbd3c22;hp=527848f41bfd19eeb7728bf282cc3699f0c74f4c;hb=c85f986ca64b6590150aab711713c9c08b70cf9d;hpb=0b34654125ca8551a1ce82919236d67a862b59bd

diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.lhs
index 527848f..893358b 100644
--- a/compiler/stgSyn/StgSyn.lhs
+++ b/compiler/stgSyn/StgSyn.lhs
@@ -52,7 +52,6 @@ import Var		( isId )
 import Id		( Id, idName, idType, idCafInfo )
 import IdInfo		( mayHaveCafRefs )
 import Packages		( isDllName )
-import PackageConfig	( PackageId )
 import Literal		( Literal, literalType )
 import ForeignCall	( ForeignCall )
 import DataCon		( DataCon, dataConName )
@@ -63,11 +62,11 @@ 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 )
-import Module		( Module, pprModule )
+import Module
 \end{code}
 
 %************************************************************************
@@ -103,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 
@@ -123,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}
 
 %************************************************************************
@@ -430,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}
@@ -448,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
@@ -458,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}
@@ -537,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
@@ -582,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}
 
 %************************************************************************
@@ -756,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
 
@@ -771,6 +777,7 @@ instance Outputable AltType where
 \end{code}
 
 \begin{code}
+#ifdef DEBUG
 pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
 pprStgLVs lvs
   = getPprStyle $ \ sty ->
@@ -778,6 +785,7 @@ pprStgLVs lvs
 	empty
     else
 	hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
+#endif
 \end{code}
 
 \begin{code}
@@ -803,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}