Fixed warnings in stgSyn/StgSyn

[ghc-hetmet.git] / compiler / stgSyn / StgSyn.lhs

diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.lhs
index 74832a2..893358b 100644 (file)
--- 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,10 +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
 \end{code}
 
 %************************************************************************
@@ -102,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 
@@ -122,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}
 
 %************************************************************************
@@ -167,13 +167,16 @@ constructors, primitives, and literals.
 \begin{code}
   | StgLit     Literal
   
+       -- StgConApp is vital for returning unboxed tuples
+       -- which can't be let-bound first
   | StgConApp  DataCon
                [GenStgArg occ] -- Saturated
 
   | StgOpApp   StgOp           -- Primitive op or foreign call
                [GenStgArg occ] -- Saturated
-               Type            -- Result type; we need to know the result type
-                               -- so that we can assign result registers.
+               Type            -- Result type
+                               -- We need to know this so that we can 
+                               -- assign result registers
 \end{code}
 
 %************************************************************************
@@ -349,6 +352,21 @@ Finally for @scc@ expressions we introduce a new STG construct.
   | StgSCC
        CostCentre              -- label of SCC expression
        (GenStgExpr bndr occ)   -- scc expression
+\end{code}
+
+%************************************************************************
+%*                                                                     *
+\subsubsection{@GenStgExpr@: @hpc@ expressions}
+%*                                                                     *
+%************************************************************************
+
+Finally for @scc@ expressions we introduce a new STG construct.
+
+\begin{code}
+  | StgTick
+    Module                     -- the module of the source of this tick
+    Int                                -- tick number
+    (GenStgExpr bndr occ)      -- sub expression
   -- end of GenStgExpr
 \end{code}
 
@@ -411,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}
@@ -429,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
@@ -439,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}
@@ -518,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
@@ -563,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}
 
 %************************************************************************
@@ -719,6 +741,10 @@ pprStgExpr (StgSCC cc expr)
   = sep [ hsep [ptext SLIT("_scc_"), ppr cc],
          pprStgExpr expr ]
 
+pprStgExpr (StgTick m n expr)
+  = sep [ hsep [ptext SLIT("_tick_"),  pprModule m,text (show n)],
+         pprStgExpr expr ]
+
 pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts)
   = sep [sep [ptext SLIT("case"),
           nest 4 (hsep [pprStgExpr expr,
@@ -733,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
 
@@ -748,6 +777,7 @@ instance Outputable AltType where
 \end{code}
 
 \begin{code}
+#ifdef DEBUG
 pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
 pprStgLVs lvs
   = getPprStyle $ \ sty ->
@@ -755,6 +785,7 @@ pprStgLVs lvs
        empty
     else
        hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
+#endif
 \end{code}
 
 \begin{code}
@@ -780,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}