projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Don't import FastString in HsVersions.h
[ghc-hetmet.git]
/
compiler
/
stgSyn
/
StgSyn.lhs
diff --git
a/compiler/stgSyn/StgSyn.lhs
b/compiler/stgSyn/StgSyn.lhs
index
2749081
..
42bcabb
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 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 )
import Literal ( Literal, literalType )
import ForeignCall ( ForeignCall )
import DataCon ( DataCon, dataConName )
@@
-63,11
+62,12
@@
import Outputable
import Util ( count )
import Type ( Type )
import TyCon ( TyCon )
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 Unique ( Unique )
import Bitmap
import StaticFlags ( opt_SccProfilingOn )
-import Module ( Module, pprModule )
+import Module
+import FastString
\end{code}
%************************************************************************
\end{code}
%************************************************************************
@@
-103,14
+103,14
@@
data GenStgArg occ
\end{code}
\begin{code}
\end{code}
\begin{code}
+isStgTypeArg :: StgArg -> Bool
isStgTypeArg (StgTypeArg _) = True
isStgTypeArg (StgTypeArg _) = True
-isStgTypeArg other = False
+isStgTypeArg _ = False
isDllArg :: PackageId -> StgArg -> Bool
-- Does this argument refer to something in a different DLL?
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
isDllConApp :: PackageId -> DataCon -> [StgArg] -> Bool
-- Does this constructor application refer to
@@
-123,7
+123,7
@@
stgArgType :: StgArg -> Type
-- Very half baked becase we have lost the type arguments
stgArgType (StgVarArg v) = idType v
stgArgType (StgLitArg lit) = literalType lit
-- 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}
%************************************************************************
\end{code}
%************************************************************************
@@
-168,6
+168,8
@@
constructors, primitives, and literals.
\begin{code}
| StgLit Literal
\begin{code}
| StgLit Literal
+ -- StgConApp is vital for returning unboxed tuples
+ -- which can't be let-bound first
| StgConApp DataCon
[GenStgArg occ] -- Saturated
| StgConApp DataCon
[GenStgArg occ] -- Saturated
@@
-428,11
+430,13
@@
stgBindHasCafRefs :: GenStgBinding bndr Id -> Bool
stgBindHasCafRefs (StgNonRec _ rhs) = rhsHasCafRefs rhs
stgBindHasCafRefs (StgRec binds) = any rhsHasCafRefs (map snd binds)
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
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}
stgArgHasCafRefs (StgVarArg id) = mayHaveCafRefs (idCafInfo id)
stgArgHasCafRefs _ = False
\end{code}
@@
-446,6
+450,7
@@
data StgBinderInfo
-- slow entry code for the thing
-- Thunks never get this value
-- slow entry code for the thing
-- Thunks never get this value
+noBinderInfo, stgUnsatOcc, stgSatOcc :: StgBinderInfo
noBinderInfo = NoStgBinderInfo
stgUnsatOcc = NoStgBinderInfo
stgSatOcc = SatCallsOnly
noBinderInfo = NoStgBinderInfo
stgUnsatOcc = NoStgBinderInfo
stgSatOcc = SatCallsOnly
@@
-456,9
+461,10
@@
satCallsOnly NoStgBinderInfo = False
combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
combineStgBinderInfo SatCallsOnly SatCallsOnly = SatCallsOnly
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}
pp_binder_info NoStgBinderInfo = empty
pp_binder_info SatCallsOnly = ptext SLIT("sat-only")
\end{code}
@@
-535,6
+541,7
@@
instance Outputable UpdateFlag where
ppr u
= char (case u of { ReEntrant -> 'r'; Updatable -> 'u'; SingleEntry -> 's' })
ppr u
= char (case u of { ReEntrant -> 'r'; Updatable -> 'u'; SingleEntry -> 's' })
+isUpdatable :: UpdateFlag -> Bool
isUpdatable ReEntrant = False
isUpdatable SingleEntry = False
isUpdatable Updatable = True
isUpdatable ReEntrant = False
isUpdatable SingleEntry = False
isUpdatable Updatable = True
@@
-580,16
+587,15
@@
data SRT = NoSRT
| SRT !Int{-offset-} !Int{-length-} !Bitmap{-bitmap-}
-- generated by computeSRTs
| 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
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 (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}
%************************************************************************
\end{code}
%************************************************************************
@@
-754,10
+760,13
@@
pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts)
nest 2 (vcat (map pprStgAlt alts)),
char '}']
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)
= 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
pprStgOp (StgPrimOp op) = ppr op
pprStgOp (StgFCallOp op _) = ppr op
@@
-769,6
+778,7
@@
instance Outputable AltType where
\end{code}
\begin{code}
\end{code}
\begin{code}
+#ifdef DEBUG
pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
pprStgLVs lvs
= getPprStyle $ \ sty ->
pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
pprStgLVs lvs
= getPprStyle $ \ sty ->
@@
-776,6
+786,7
@@
pprStgLVs lvs
empty
else
hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
empty
else
hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
+#endif
\end{code}
\begin{code}
\end{code}
\begin{code}
@@
-801,6
+812,7
@@
pprStgRhs (StgRhsCon cc con args)
= hcat [ ppr cc,
space, ppr con, ptext SLIT("! "), brackets (interppSP 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}
pprMaybeSRT (NoSRT) = empty
pprMaybeSRT srt = ptext SLIT("srt:") <> pprSRT srt
\end{code}