X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2FstgSyn%2FStgSyn.lhs;h=2fc36a1e23ffad3b4db1140fae3fafb8bcd83737;hb=8d6bc9bf51829ea04da5f599b84114ef220f0a19;hp=cf9487cf6e1fce2e2ad442a81d8909edf963855f;hpb=ad94d40948668032189ad22a0ad741ac1f645f50;p=ghc-hetmet.git

diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.lhs
index cf9487c..2fc36a1 100644
--- a/compiler/stgSyn/StgSyn.lhs
+++ b/compiler/stgSyn/StgSyn.lhs
@@ -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/CodingStyle#Warnings
--- for details
-
 module StgSyn (
 	GenStgArg(..), 
 	GenStgLiveVars,
@@ -59,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 )
@@ -67,14 +59,14 @@ import CoreSyn		( AltCon )
 import PprCore		( {- instances -} )
 import PrimOp		( PrimOp )
 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
+import FastString
 \end{code}
 
 %************************************************************************
@@ -110,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 
@@ -130,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}
 
 %************************************************************************
@@ -425,10 +417,9 @@ The second flavour of right-hand-side is for constructors (simple but important)
 
 \begin{code}
 stgRhsArity :: StgRhs -> Int
-stgRhsArity (StgRhsClosure _ _ _ _ _ bndrs _) = count isId bndrs
-  -- The arity never includes type parameters, so
-  -- when keeping type arguments and binders in the Stg syntax 
-  -- (opt_RuntimeTypes) we have to fliter out the type binders.
+stgRhsArity (StgRhsClosure _ _ _ _ _ bndrs _) 
+  = ASSERT( all isId bndrs ) length bndrs
+  -- The arity never includes type parameters, but they should have gone by now
 stgRhsArity (StgRhsCon _ _ _) = 0
 \end{code}
 
@@ -437,11 +428,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}
@@ -455,6 +448,7 @@ data StgBinderInfo
 			-- slow entry code for the thing
 			-- Thunks never get this value
 
+noBinderInfo, stgUnsatOcc, stgSatOcc :: StgBinderInfo
 noBinderInfo = NoStgBinderInfo
 stgUnsatOcc  = NoStgBinderInfo
 stgSatOcc    = SatCallsOnly
@@ -465,9 +459,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}
@@ -544,6 +539,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
@@ -589,16 +585,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}
 
 %************************************************************************
@@ -763,10 +758,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
 
@@ -778,6 +776,7 @@ instance Outputable AltType where
 \end{code}
 
 \begin{code}
+#ifdef DEBUG
 pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
 pprStgLVs lvs
   = getPprStyle $ \ sty ->
@@ -785,6 +784,7 @@ pprStgLVs lvs
 	empty
     else
 	hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
+#endif
 \end{code}
 
 \begin{code}
@@ -810,6 +810,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}