suited to spineless tagless code generation.
\begin{code}
-{-# OPTIONS_GHC -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/WorkingConventions#Warnings
--- for details
-
module StgSyn (
GenStgArg(..),
GenStgLiveVars,
import CostCentre ( CostCentreStack, CostCentre )
import VarSet ( IdSet, isEmptyVarSet )
-import Var ( isId )
-import Id ( Id, idName, idType, idCafInfo )
+import Id
+import DataCon
import IdInfo ( mayHaveCafRefs )
-import Packages ( isDllName )
-import PackageConfig ( PackageId )
import Literal ( Literal, literalType )
import ForeignCall ( ForeignCall )
-import DataCon ( DataCon, dataConName )
import CoreSyn ( AltCon )
import PprCore ( {- instances -} )
-import PrimOp ( PrimOp )
+import PrimOp ( PrimOp, PrimCall )
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
+
+#if mingw32_TARGET_OS
+import Packages ( isDllName )
+import Type ( typePrimRep )
+import TyCon ( PrimRep(..) )
+#endif
\end{code}
%************************************************************************
\end{code}
\begin{code}
+isStgTypeArg :: StgArg -> Bool
isStgTypeArg (StgTypeArg _) = True
-isStgTypeArg other = 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
+isStgTypeArg _ = False
isDllConApp :: PackageId -> DataCon -> [StgArg] -> Bool
- -- Does this constructor application refer to
- -- anything in a different DLL?
- -- If so, we can't allocate it statically
+-- Does this constructor application refer to
+-- anything in a different *Windows* DLL?
+-- If so, we can't allocate it statically
+#if mingw32_TARGET_OS
isDllConApp this_pkg con args
- = isDllName this_pkg (dataConName con) || any (isDllArg this_pkg) args
+ = isDllName this_pkg (dataConName con) || any is_dll_arg args
+ where
+ is_dll_arg ::StgArg -> Bool
+ is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep (idType v))
+ && isDllName this_pkg (idName v)
+ is_dll_arg _ = False
+
+isAddrRep :: PrimRep -> Bool
+-- True of machine adddresses; these are the things that don't
+-- work across DLLs.
+-- The key point here is that VoidRep comes out False, so that
+-- a top level nullary GADT construtor is False for isDllConApp
+-- data T a where
+-- T1 :: T Int
+-- gives
+-- T1 :: forall a. (a~Int) -> T a
+-- and hence the top-level binding
+-- $WT1 :: T Int
+-- $WT1 = T1 Int (Coercion (Refl Int))
+-- The coercion argument here gets VoidRep
+isAddrRep AddrRep = True
+isAddrRep PtrRep = True
+isAddrRep _ = False
+
+#else
+isDllConApp _ _ _ = False
+#endif
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}
%************************************************************************
\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}
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}
-- slow entry code for the thing
-- Thunks never get this value
+noBinderInfo, stgUnsatOcc, stgSatOcc :: StgBinderInfo
noBinderInfo = NoStgBinderInfo
stgUnsatOcc = NoStgBinderInfo
stgSatOcc = 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")
+pp_binder_info SatCallsOnly = ptext (sLit "sat-only")
\end{code}
%************************************************************************
ppr u
= char (case u of { ReEntrant -> 'r'; Updatable -> 'u'; SingleEntry -> 's' })
+isUpdatable :: UpdateFlag -> Bool
isUpdatable ReEntrant = False
isUpdatable SingleEntry = False
isUpdatable Updatable = True
\begin{code}
data StgOp = StgPrimOp PrimOp
+ | StgPrimCallOp PrimCall
+
| StgFCallOp ForeignCall Unique
-- The Unique is occasionally needed by the C pretty-printer
-- (which lacks a unique supply), notably when generating a
| 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}
%************************************************************************
4 ((<>) (ppr rhs) semi)
pprGenStgBinding (StgRec pairs)
- = vcat ((ifPprDebug (ptext SLIT("{- StgRec (begin) -}"))) :
- (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))])
+ = vcat ((ifPprDebug (ptext (sLit "{- StgRec (begin) -}"))) :
+ (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext (sLit "{- StgRec (end) -}")))])
where
ppr_bind (bndr, expr)
= hang (hsep [ppr bndr, equals])
pprGenStgBindingWithSRT (bind,srts)
= vcat (pprGenStgBinding bind : map pprSRT srts)
where pprSRT (id,srt) =
- ptext SLIT("SRT") <> parens (ppr id) <> ptext SLIT(": ") <> ppr srt
+ ptext (sLit "SRT") <> parens (ppr id) <> ptext (sLit ": ") <> ppr srt
pprStgBindingsWithSRTs :: [(StgBinding,[(Id,[Id])])] -> SDoc
pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds)
= hsep [ pprStgOp op, brackets (interppSP args)]
pprStgExpr (StgLam _ bndrs body)
- =sep [ char '\\' <+> ppr bndrs <+> ptext SLIT("->"),
+ =sep [ char '\\' <+> ppr bndrs <+> ptext (sLit "->"),
pprStgExpr body ]
\end{code}
pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
expr@(StgLet _ _))
= ($$)
- (hang (hcat [ptext SLIT("let { "), ppr bndr, ptext SLIT(" = "),
+ (hang (hcat [ptext (sLit "let { "), ppr bndr, ptext (sLit " = "),
ppr cc,
pp_binder_info bi,
- ptext SLIT(" ["), ifPprDebug (interppSP free_vars), ptext SLIT("] \\"),
- ppr upd_flag, ptext SLIT(" ["),
+ ptext (sLit " ["), ifPprDebug (interppSP free_vars), ptext (sLit "] \\"),
+ ppr upd_flag, ptext (sLit " ["),
interppSP args, char ']'])
- 8 (sep [hsep [ppr rhs, ptext SLIT("} in")]]))
+ 8 (sep [hsep [ppr rhs, ptext (sLit "} in")]]))
(ppr expr)
-}
pprStgExpr (StgLet bind expr@(StgLet _ _))
= ($$)
- (sep [hang (ptext SLIT("let {"))
- 2 (hsep [pprGenStgBinding bind, ptext SLIT("} in")])])
+ (sep [hang (ptext (sLit "let {"))
+ 2 (hsep [pprGenStgBinding bind, ptext (sLit "} in")])])
(ppr expr)
-- general case
pprStgExpr (StgLet bind expr)
- = sep [hang (ptext SLIT("let {")) 2 (pprGenStgBinding bind),
- hang (ptext SLIT("} in ")) 2 (ppr expr)]
+ = sep [hang (ptext (sLit "let {")) 2 (pprGenStgBinding bind),
+ hang (ptext (sLit "} in ")) 2 (ppr expr)]
pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr)
- = sep [hang (ptext SLIT("let-no-escape {"))
+ = sep [hang (ptext (sLit "let-no-escape {"))
2 (pprGenStgBinding bind),
- hang ((<>) (ptext SLIT("} in "))
+ hang ((<>) (ptext (sLit "} in "))
(ifPprDebug (
nest 4 (
- hcat [ptext SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
- ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
+ hcat [ptext (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole),
+ ptext (sLit "]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
char ']']))))
2 (ppr expr)]
pprStgExpr (StgSCC cc expr)
- = sep [ hsep [ptext SLIT("_scc_"), ppr cc],
+ = sep [ hsep [ptext (sLit "_scc_"), ppr cc],
pprStgExpr expr ]
pprStgExpr (StgTick m n expr)
- = sep [ hsep [ptext SLIT("_tick_"), pprModule m,text (show n)],
+ = 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"),
+ = sep [sep [ptext (sLit "case"),
nest 4 (hsep [pprStgExpr expr,
ifPprDebug (dcolon <+> ppr alt_type)]),
- ptext SLIT("of"), ppr bndr, char '{'],
+ ptext (sLit "of"), ppr bndr, char '{'],
ifPprDebug (
nest 4 (
- hcat [ptext SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
- ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
- ptext SLIT("]; "),
+ hcat [ptext (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole),
+ ptext (sLit "]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
+ ptext (sLit "]; "),
pprMaybeSRT srt])),
nest 2 (vcat (map pprStgAlt alts)),
char '}']
-pprStgAlt (con, params, use_mask, expr)
- = hang (hsep [ppr con, interppSP params, ptext SLIT("->")])
+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 (StgPrimCallOp op)= ppr op
pprStgOp (StgFCallOp op _) = ppr op
instance Outputable AltType where
- ppr PolyAlt = ptext SLIT("Polymorphic")
- ppr (UbxTupAlt tc) = ptext SLIT("UbxTup") <+> ppr tc
- ppr (AlgAlt tc) = ptext SLIT("Alg") <+> ppr tc
- ppr (PrimAlt tc) = ptext SLIT("Prim") <+> ppr tc
+ ppr PolyAlt = ptext (sLit "Polymorphic")
+ ppr (UbxTupAlt tc) = ptext (sLit "UbxTup") <+> ppr tc
+ ppr (AlgAlt tc) = ptext (sLit "Alg") <+> ppr tc
+ ppr (PrimAlt tc) = ptext (sLit "Prim") <+> ppr tc
\end{code}
\begin{code}
+#ifdef DEBUG
pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
pprStgLVs lvs
= getPprStyle $ \ sty ->
empty
else
hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
+#endif
\end{code}
\begin{code}
= hcat [ ppr cc,
pp_binder_info bi,
brackets (ifPprDebug (ppr free_var)),
- ptext SLIT(" \\"), ppr upd_flag, pprMaybeSRT srt, ptext SLIT(" [] "), ppr func ]
+ ptext (sLit " \\"), ppr upd_flag, pprMaybeSRT srt, ptext (sLit " [] "), ppr func ]
-- general case
pprStgRhs (StgRhsClosure cc bi free_vars upd_flag srt args body)
pprStgRhs (StgRhsCon cc con args)
= hcat [ ppr cc,
- space, ppr con, ptext SLIT("! "), brackets (interppSP args)]
+ space, ppr con, ptext (sLit "! "), brackets (interppSP args)]
+pprMaybeSRT :: SRT -> SDoc
pprMaybeSRT (NoSRT) = empty
-pprMaybeSRT srt = ptext SLIT("srt:") <> pprSRT srt
+pprMaybeSRT srt = ptext (sLit "srt:") <> pprSRT srt
\end{code}
projects / ghc-hetmet.git / blobdiff