X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FstgSyn%2FStgSyn.lhs;h=dd026eb80c9e0c990b588992a3a0a574b5b8ad6a;hp=a184d5e6c06d3b3c68d0f622f9c2bd507d0b7e20;hb=b2bd63f99d643f6b3eb30bb72bb9ae26d4183252;hpb=d5934bbb856aa0aa620c9b2e0fa51c90a1a5a048 diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.lhs index a184d5e..dd026eb 100644 --- a/compiler/stgSyn/StgSyn.lhs +++ b/compiler/stgSyn/StgSyn.lhs @@ -48,26 +48,29 @@ module StgSyn ( 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} %************************************************************************ @@ -103,27 +106,49 @@ data GenStgArg occ \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} %************************************************************************ @@ -168,13 +193,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} %************************************************************************ @@ -415,10 +443,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} @@ -427,11 +454,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} @@ -445,6 +474,7 @@ data StgBinderInfo -- slow entry code for the thing -- Thunks never get this value +noBinderInfo, stgUnsatOcc, stgSatOcc :: StgBinderInfo noBinderInfo = NoStgBinderInfo stgUnsatOcc = NoStgBinderInfo stgSatOcc = SatCallsOnly @@ -455,11 +485,12 @@ 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") +pp_binder_info SatCallsOnly = ptext (sLit "sat-only") \end{code} %************************************************************************ @@ -534,6 +565,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 @@ -552,6 +584,8 @@ in StgOpApp and COpStmt. \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 @@ -579,16 +613,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} %************************************************************************ @@ -609,8 +642,8 @@ pprGenStgBinding (StgNonRec bndr rhs) 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]) @@ -629,7 +662,7 @@ pprGenStgBindingWithSRT 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) @@ -680,7 +713,7 @@ pprStgExpr (StgOpApp op args _) = 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} @@ -697,13 +730,13 @@ pprStgExpr (StgLam _ bndrs body) 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) -} @@ -711,63 +744,68 @@ pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag a 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 -> @@ -775,6 +813,7 @@ pprStgLVs lvs empty else hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"] +#endif \end{code} \begin{code} @@ -786,7 +825,7 @@ pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag srt [{-no args-}] (StgApp fun = 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) @@ -798,8 +837,9 @@ 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}