summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/cmm/CLabel.hs22
-rw-r--r--compiler/cmm/CmmBuildInfoTables.hs9
-rw-r--r--compiler/codeGen/StgCmm.hs1
-rw-r--r--compiler/codeGen/StgCmmEnv.hs8
-rw-r--r--compiler/codeGen/StgCmmExpr.hs5
-rw-r--r--compiler/codeGen/StgCmmMonad.hs25
-rw-r--r--compiler/codeGen/StgCmmPrim.hs15
-rw-r--r--compiler/ghc.cabal.in2
-rw-r--r--compiler/ghc.mk12
-rw-r--r--compiler/iface/IfaceSyn.lhs22
-rw-r--r--compiler/iface/MkIface.lhs17
-rw-r--r--compiler/main/HscMain.hs4
-rw-r--r--compiler/main/HscTypes.lhs34
-rw-r--r--compiler/nativeGen/PPC/CodeGen.hs4
-rw-r--r--compiler/nativeGen/PPC/Ppr.hs37
-rw-r--r--compiler/nativeGen/SPARC/Ppr.hs37
-rw-r--r--compiler/typecheck/TcHsType.lhs6
17 files changed, 137 insertions, 123 deletions
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index ed4b56767a..907f8521e1 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -13,6 +13,7 @@ module CLabel (
mkClosureLabel,
mkSRTLabel,
+ mkModSRTLabel,
mkInfoTableLabel,
mkEntryLabel,
mkSlowEntryLabel,
@@ -119,6 +120,8 @@ import DynFlags
import Platform
import UniqSet
+import Data.Maybe (isJust)
+
-- -----------------------------------------------------------------------------
-- The CLabel type
@@ -214,6 +217,9 @@ data CLabel
-- | Per-module table of tick locations
| HpcTicksLabel Module
+ -- | Static reference table
+ | SRTLabel (Maybe Module) !Unique
+
-- | Label of an StgLargeSRT
| LargeSRTLabel
{-# UNPACK #-} !Unique
@@ -271,7 +277,9 @@ pprDebugCLabel lbl
data IdLabelInfo
= Closure -- ^ Label for closure
- | SRT -- ^ Static reference table
+ | SRT -- ^ Static reference table (TODO: could be removed
+ -- with the old code generator, but might be needed
+ -- when we implement the New SRT Plan)
| InfoTable -- ^ Info tables for closures; always read-only
| Entry -- ^ Entry point
| Slow -- ^ Slow entry point
@@ -347,6 +355,9 @@ data DynamicLinkerLabelInfo
mkSlowEntryLabel :: Name -> CafInfo -> CLabel
mkSlowEntryLabel name c = IdLabel name c Slow
+mkModSRTLabel :: Maybe Module -> Unique -> CLabel
+mkModSRTLabel mb_mod u = SRTLabel mb_mod u
+
mkSRTLabel :: Name -> CafInfo -> CLabel
mkRednCountsLabel :: Name -> CafInfo -> CLabel
mkSRTLabel name c = IdLabel name c SRT
@@ -581,7 +592,7 @@ needsCDecl :: CLabel -> Bool
-- False <=> it's pre-declared; don't bother
-- don't bother declaring SRT & Bitmap labels, we always make sure
-- they are defined before use.
-needsCDecl (IdLabel _ _ SRT) = False
+needsCDecl (SRTLabel _ _) = False
needsCDecl (LargeSRTLabel _) = False
needsCDecl (LargeBitmapLabel _) = False
needsCDecl (IdLabel _ _ _) = True
@@ -729,6 +740,7 @@ externallyVisibleCLabel (CCS_Label _) = True
externallyVisibleCLabel (DynamicLinkerLabel _ _) = False
externallyVisibleCLabel (HpcTicksLabel _) = True
externallyVisibleCLabel (LargeBitmapLabel _) = False
+externallyVisibleCLabel (SRTLabel mb_mod _) = isJust mb_mod
externallyVisibleCLabel (LargeSRTLabel _) = False
externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel"
externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer"
@@ -776,6 +788,7 @@ labelType (RtsLabel (RtsApFast _)) = CodeLabel
labelType (CaseLabel _ CaseReturnInfo) = DataLabel
labelType (CaseLabel _ _) = CodeLabel
labelType (PlainModuleInitLabel _) = CodeLabel
+labelType (SRTLabel _ _) = CodeLabel
labelType (LargeSRTLabel _) = DataLabel
labelType (LargeBitmapLabel _) = DataLabel
labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel
@@ -978,6 +991,11 @@ pprCLbl (CaseLabel u (CaseAlt tag))
pprCLbl (CaseLabel u CaseDefault)
= hcat [pprUnique u, ptext (sLit "_dflt")]
+pprCLbl (SRTLabel mb_mod u)
+ = pp_mod <> pprUnique u <> pp_cSEP <> ptext (sLit "srt")
+ where pp_mod | Just mod <- mb_mod = ppr mod <> pp_cSEP
+ | otherwise = empty
+
pprCLbl (LargeSRTLabel u) = pprUnique u <> pp_cSEP <> ptext (sLit "srtd")
pprCLbl (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLit "btm")
-- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7')
diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index 309536b963..0cfcc0d5be 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -32,10 +32,9 @@ import Bitmap
import CLabel
import Cmm
import CmmUtils
-import IdInfo
import Data.List
import Maybes
-import Name
+import Module
import Outputable
import SMRep
import UniqSupply
@@ -137,9 +136,9 @@ instance Outputable TopSRT where
<+> ppr elts
<+> ppr eltmap
-emptySRT :: MonadUnique m => m TopSRT
-emptySRT =
- do top_lbl <- getUniqueM >>= \ u -> return $ mkSRTLabel (mkFCallName u "srt") NoCafRefs
+emptySRT :: MonadUnique m => Maybe Module -> m TopSRT
+emptySRT mb_mod =
+ do top_lbl <- getUniqueM >>= \ u -> return $ mkModSRTLabel mb_mod u
return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = Map.empty }
cafMember :: TopSRT -> CLabel -> Bool
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index b8ed1aa939..d74533d76e 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -143,7 +143,6 @@ cgTopRhs bndr (StgRhsCon _cc con args)
cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag _srt args body)
= ASSERT(null fvs) -- There should be no free variables
- setSRTLabel (mkSRTLabel (idName bndr) (idCafInfo bndr)) $
forkStatics (cgTopRhsClosure bndr cc bi upd_flag args body)
diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs
index 9f1f161d37..e4611237cc 100644
--- a/compiler/codeGen/StgCmmEnv.hs
+++ b/compiler/codeGen/StgCmmEnv.hs
@@ -180,15 +180,13 @@ cgLookupPanic :: Id -> FCode a
cgLookupPanic id
= do static_binds <- getStaticBinds
local_binds <- getBinds
- srt <- getSRTLabel
- pprPanic "StgCmmEnv: variable not found"
+ pprPanic "StgCmmEnv: variable not found"
(vcat [ppr id,
ptext (sLit "static binds for:"),
vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ],
ptext (sLit "local binds for:"),
- vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ],
- ptext (sLit "SRT label") <+> ppr srt
- ])
+ vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ]
+ ])
--------------------
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index ab6f888835..bc29c68c37 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -611,7 +611,10 @@ cgIdApp fun_id args
= do { fun_info <- getCgIdInfo fun_id
; case maybeLetNoEscape fun_info of
Just (blk_id, lne_regs) -> cgLneJump blk_id lne_regs args
- Nothing -> cgTailCall fun_id fun_info args }
+ Nothing -> cgTailCall (cg_id fun_info) fun_info args }
+ -- NB. use (cg_id fun_info) instead of fun_id, because the former
+ -- may be externalised for -split-objs.
+ -- See StgCmm.maybeExternaliseId.
cgLneJump :: BlockId -> [LocalReg] -> [StgArg] -> FCode ReturnKind
cgLneJump blk_id lne_regs args -- Join point; discard sequel
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index 2290914310..39bd1feef1 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -39,8 +39,7 @@ module StgCmmMonad (
Sequel(..), ReturnKind(..),
withSequel, getSequel,
- setSRTLabel, getSRTLabel,
- setTickyCtrLabel, getTickyCtrLabel,
+ setTickyCtrLabel, getTickyCtrLabel,
withUpdFrameOff, getUpdFrameOff, initUpdFrameOff,
@@ -155,8 +154,7 @@ data CgInfoDownwards -- information only passed *downwards* by the monad
cgd_dflags :: DynFlags,
cgd_mod :: Module, -- Module being compiled
cgd_statics :: CgBindings, -- [Id -> info] : static environment
- cgd_srt_lbl :: CLabel, -- Label of the current top-level SRT
- cgd_updfr_off :: UpdFrameOffset, -- Size of current update frame
+ cgd_updfr_off :: UpdFrameOffset, -- Size of current update frame
cgd_ticky :: CLabel, -- Current destination for ticky counts
cgd_sequel :: Sequel -- What to do at end of basic block
}
@@ -285,8 +283,7 @@ initCgInfoDown dflags mod
= MkCgInfoDown { cgd_dflags = dflags,
cgd_mod = mod,
cgd_statics = emptyVarEnv,
- cgd_srt_lbl = error "initC: srt_lbl",
- cgd_updfr_off = initUpdFrameOff,
+ cgd_updfr_off = initUpdFrameOff,
cgd_ticky = mkTopTickyCtrLabel,
cgd_sequel = initSequel }
@@ -472,22 +469,6 @@ getSequel = do { info <- getInfoDown
; return (cgd_sequel info) }
-- ----------------------------------------------------------------------------
--- Get/set the current SRT label
-
--- There is just one SRT for each top level binding; all the nested
--- bindings use sub-sections of this SRT. The label is passed down to
--- the nested bindings via the monad.
-
-getSRTLabel :: FCode CLabel -- Used only by cgPanic
-getSRTLabel = do info <- getInfoDown
- return (cgd_srt_lbl info)
-
-setSRTLabel :: CLabel -> FCode a -> FCode a
-setSRTLabel srt_lbl code
- = do info <- getInfoDown
- withInfoDown code (info { cgd_srt_lbl = srt_lbl})
-
--- ----------------------------------------------------------------------------
-- Get/set the size of the update frame
-- We keep track of the size of the update frame so that we
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index 3a7a456082..6c6005e88a 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -498,11 +498,16 @@ emitPrimOp [] SetByteArrayOp [ba,off,len,c] =
doSetByteArrayOp ba off len c
-- Population count
-emitPrimOp [res] PopCnt8Op [w] = emitPopCntCall res w W8
-emitPrimOp [res] PopCnt16Op [w] = emitPopCntCall res w W16
-emitPrimOp [res] PopCnt32Op [w] = emitPopCntCall res w W32
-emitPrimOp [res] PopCnt64Op [w] = emitPopCntCall res w W64
-emitPrimOp [res] PopCntOp [w] = emitPopCntCall res w wordWidth
+emitPrimOp [res] PopCnt8Op [w] =
+ emitPopCntCall res (CmmMachOp mo_WordTo8 [w]) W8
+emitPrimOp [res] PopCnt16Op [w] =
+ emitPopCntCall res (CmmMachOp mo_WordTo16 [w]) W16
+emitPrimOp [res] PopCnt32Op [w] =
+ emitPopCntCall res (CmmMachOp mo_WordTo32 [w]) W32
+emitPrimOp [res] PopCnt64Op [w] =
+ emitPopCntCall res w W64 -- arg always has type W64, no need to narrow
+emitPrimOp [res] PopCntOp [w] =
+ emitPopCntCall res w wordWidth
-- The rest just translate straightforwardly
emitPrimOp [res] op [arg]
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index e02e9d9869..8cec8271a2 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -49,7 +49,7 @@ Library
Exposed: False
Build-Depends: base >= 4 && < 5,
- directory >= 1 && < 1.2,
+ directory >= 1 && < 1.3,
process >= 1 && < 1.2,
bytestring >= 0.9 && < 0.11,
time < 1.5,
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index be2b631617..ad92b6f2e2 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -452,18 +452,6 @@ compiler_stage1_HC_OPTS += $(GhcStage1HcOpts)
compiler_stage2_HC_OPTS += $(GhcStage2HcOpts)
compiler_stage3_HC_OPTS += $(GhcStage3HcOpts)
-ifeq "$(GhcStage1DefaultNewCodegen)" "YES"
-compiler_stage1_HC_OPTS += -DGHC_DEFAULT_NEW_CODEGEN
-endif
-
-ifeq "$(GhcStage2DefaultNewCodegen)" "YES"
-compiler_stage2_HC_OPTS += -DGHC_DEFAULT_NEW_CODEGEN
-endif
-
-ifeq "$(GhcStage3DefaultNewCodegen)" "YES"
-compiler_stage3_HC_OPTS += -DGHC_DEFAULT_NEW_CODEGEN
-endif
-
ifneq "$(BINDIST)" "YES"
compiler_stage2_TAGS_HC_OPTS = -package ghc
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index bc5fc954eb..a41a9dac47 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -24,6 +24,7 @@ module IfaceSyn (
-- Misc
ifaceDeclImplicitBndrs, visibleIfConDecls,
+ ifaceDeclFingerprints,
-- Free Names
freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,
@@ -51,6 +52,10 @@ import Outputable
import FastString
import Module
import TysWiredIn ( eqTyConName )
+import Fingerprint
+import Binary
+
+import System.IO.Unsafe
infixl 3 &&&
\end{code}
@@ -448,6 +453,23 @@ ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ,
ifaceDeclImplicitBndrs _ = []
+-- -----------------------------------------------------------------------------
+-- The fingerprints of an IfaceDecl
+
+ -- We better give each name bound by the declaration a
+ -- different fingerprint! So we calculate the fingerprint of
+ -- each binder by combining the fingerprint of the whole
+ -- declaration with the name of the binder. (#5614, #7215)
+ifaceDeclFingerprints :: Fingerprint -> IfaceDecl -> [(OccName,Fingerprint)]
+ifaceDeclFingerprints hash decl
+ = (ifName decl, hash) :
+ [ (occ, computeFingerprint' (hash,occ))
+ | occ <- ifaceDeclImplicitBndrs decl ]
+ where
+ computeFingerprint' =
+ unsafeDupablePerformIO
+ . computeFingerprint (panic "ifaceDeclFingerprints")
+
----------------------------- Printing IfaceDecl ------------------------------
instance Outputable IfaceDecl where
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 93ca3853e2..d92cb4a185 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -530,25 +530,12 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
-- to assign fingerprints to all the OccNames that it binds, to
-- use when referencing those OccNames in later declarations.
--
- -- We better give each name bound by the declaration a
- -- different fingerprint! So we calculate the fingerprint of
- -- each binder by combining the fingerprint of the whole
- -- declaration with the name of the binder. (#5614)
extend_hash_env :: OccEnv (OccName,Fingerprint)
-> (Fingerprint,IfaceDecl)
-> IO (OccEnv (OccName,Fingerprint))
extend_hash_env env0 (hash,d) = do
- let
- sub_bndrs = ifaceDeclImplicitBndrs d
- fp_sub_bndr occ = computeFingerprint putNameLiterally (hash,occ)
- --
- sub_fps <- mapM fp_sub_bndr sub_bndrs
- return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env1
- (zip sub_bndrs sub_fps))
- where
- decl_name = ifName d
- item = (decl_name, hash)
- env1 = extendOccEnv env0 decl_name item
+ return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0
+ (ifaceDeclFingerprints hash d))
--
(local_env, decls_w_hashes) <-
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 22684126c2..6f9745dbfc 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -1399,7 +1399,9 @@ tryNewCodeGen hsc_env this_mod data_tycons
-- We are building a single SRT for the entire module, so
-- we must thread it through all the procedures as we cps-convert them.
us <- mkSplitUniqSupply 'S'
- let initTopSRT = initUs_ us emptySRT
+ let srt_mod | dopt Opt_SplitObjs dflags = Just this_mod
+ | otherwise = Nothing
+ initTopSRT = initUs_ us (emptySRT srt_mod)
let run_pipeline topSRT cmmgroup = do
(topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT cmmgroup
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 793740e96e..7c1f169440 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -744,6 +744,22 @@ emptyModIface mod
mi_trust = noIfaceTrustInfo,
mi_trust_pkg = False }
+
+-- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface'
+mkIfaceHashCache :: [(Fingerprint,IfaceDecl)]
+ -> (OccName -> Maybe (OccName, Fingerprint))
+mkIfaceHashCache pairs
+ = \occ -> lookupOccEnv env occ
+ where
+ env = foldr add_decl emptyOccEnv pairs
+ add_decl (v,d) env0 = foldr add env0 (ifaceDeclFingerprints v d)
+ where
+ add (occ,hash) env0 = extendOccEnv env0 occ (occ,hash)
+
+emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint)
+emptyIfaceHashCache _occ = Nothing
+
+
-- | The 'ModDetails' is essentially a cache for information in the 'ModIface'
-- for home modules only. Information relating to packages will be loaded into
-- global environments in 'ExternalPackageState'.
@@ -1460,24 +1476,6 @@ class Monad m => MonadThings m where
lookupTyCon = liftM tyThingTyCon . lookupThing
\end{code}
-\begin{code}
--- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface'
-mkIfaceHashCache :: [(Fingerprint,IfaceDecl)]
- -> (OccName -> Maybe (OccName, Fingerprint))
-mkIfaceHashCache pairs
- = \occ -> lookupOccEnv env occ
- where
- env = foldr add_decl emptyOccEnv pairs
- add_decl (v,d) env0 = foldr add_imp env1 (ifaceDeclImplicitBndrs d)
- where
- decl_name = ifName d
- env1 = extendOccEnv env0 decl_name (decl_name, v)
- add_imp bndr env = extendOccEnv env bndr (decl_name, v)
-
-emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint)
-emptyIfaceHashCache _occ = Nothing
-\end{code}
-
%************************************************************************
%* *
\subsection{Auxiliary types}
diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs
index ce4a54ca9b..6581375382 100644
--- a/compiler/nativeGen/PPC/CodeGen.hs
+++ b/compiler/nativeGen/PPC/CodeGen.hs
@@ -1060,23 +1060,23 @@ genCCall' platform gcp target dest_regs argsAndHints
GCPDarwin ->
case cmmTypeSize rep of
II8 -> (1, 0, 4, gprs)
+ II16 -> (1, 0, 4, gprs)
II32 -> (1, 0, 4, gprs)
-- The Darwin ABI requires that we skip a
-- corresponding number of GPRs when we use
-- the FPRs.
FF32 -> (1, 1, 4, fprs)
FF64 -> (2, 1, 8, fprs)
- II16 -> panic "genCCall' passArguments II16"
II64 -> panic "genCCall' passArguments II64"
FF80 -> panic "genCCall' passArguments FF80"
GCPLinux ->
case cmmTypeSize rep of
II8 -> (1, 0, 4, gprs)
+ II16 -> (1, 0, 4, gprs)
II32 -> (1, 0, 4, gprs)
-- ... the SysV ABI doesn't.
FF32 -> (0, 1, 4, fprs)
FF64 -> (0, 1, 8, fprs)
- II16 -> panic "genCCall' passArguments II16"
II64 -> panic "genCCall' passArguments II64"
FF80 -> panic "genCCall' passArguments FF80"
diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs
index 55cc6d2a0d..681b31d3eb 100644
--- a/compiler/nativeGen/PPC/Ppr.hs
+++ b/compiler/nativeGen/PPC/Ppr.hs
@@ -31,6 +31,7 @@ import RegClass
import TargetReg
import OldCmm
+import BlockId
import CLabel
@@ -50,7 +51,7 @@ pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc
pprNatCmmDecl (CmmData section dats) =
pprSectionHeader section $$ pprDatas dats
-pprNatCmmDecl proc@(CmmProc _ lbl (ListGraph blocks)) =
+pprNatCmmDecl proc@(CmmProc top_info lbl (ListGraph blocks)) =
case topInfoTable proc of
Nothing ->
case blocks of
@@ -59,19 +60,15 @@ pprNatCmmDecl proc@(CmmProc _ lbl (ListGraph blocks)) =
blocks -> -- special case for code without info table:
pprSectionHeader Text $$
pprLabel lbl $$ -- blocks guaranteed not null, so label needed
- vcat (map pprBasicBlock blocks)
+ vcat (map (pprBasicBlock top_info) blocks)
- Just (Statics info_lbl info) ->
+ Just (Statics info_lbl _) ->
sdocWithPlatform $ \platform ->
- pprSectionHeader Text $$
- (
- (if platformHasSubsectionsViaSymbols platform
- then ppr (mkDeadStripPreventer info_lbl) <> char ':'
- else empty) $$
- vcat (map pprData info) $$
- pprLabel info_lbl
- ) $$
- vcat (map pprBasicBlock blocks) $$
+ (if platformHasSubsectionsViaSymbols platform
+ then pprSectionHeader Text $$
+ ppr (mkDeadStripPreventer info_lbl) <> char ':'
+ else empty) $$
+ vcat (map (pprBasicBlock top_info) blocks) $$
-- above: Even the first block gets a label, because with branch-chain
-- elimination, it might be the target of a goto.
(if platformHasSubsectionsViaSymbols platform
@@ -89,10 +86,18 @@ pprNatCmmDecl proc@(CmmProc _ lbl (ListGraph blocks)) =
else empty)
-pprBasicBlock :: NatBasicBlock Instr -> SDoc
-pprBasicBlock (BasicBlock blockid instrs) =
- pprLabel (mkAsmTempLabel (getUnique blockid)) $$
- vcat (map pprInstr instrs)
+pprBasicBlock :: BlockEnv CmmStatics -> NatBasicBlock Instr -> SDoc
+pprBasicBlock info_env (BasicBlock blockid instrs)
+ = maybe_infotable $$
+ pprLabel (mkAsmTempLabel (getUnique blockid)) $$
+ vcat (map pprInstr instrs)
+ where
+ maybe_infotable = case mapLookup blockid info_env of
+ Nothing -> empty
+ Just (Statics info_lbl info) ->
+ pprSectionHeader Text $$
+ vcat (map pprData info) $$
+ pprLabel info_lbl
diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs
index e57e5e2725..8ae3b4b744 100644
--- a/compiler/nativeGen/SPARC/Ppr.hs
+++ b/compiler/nativeGen/SPARC/Ppr.hs
@@ -38,6 +38,7 @@ import PprBase
import OldCmm
import OldPprCmm()
import CLabel
+import BlockId
import Unique ( Uniquable(..), pprUnique )
import Outputable
@@ -52,7 +53,7 @@ pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc
pprNatCmmDecl (CmmData section dats) =
pprSectionHeader section $$ pprDatas dats
-pprNatCmmDecl proc@(CmmProc _ lbl (ListGraph blocks)) =
+pprNatCmmDecl proc@(CmmProc top_info lbl (ListGraph blocks)) =
case topInfoTable proc of
Nothing ->
case blocks of
@@ -61,19 +62,15 @@ pprNatCmmDecl proc@(CmmProc _ lbl (ListGraph blocks)) =
blocks -> -- special case for code without info table:
pprSectionHeader Text $$
pprLabel lbl $$ -- blocks guaranteed not null, so label needed
- vcat (map pprBasicBlock blocks)
+ vcat (map (pprBasicBlock top_info) blocks)
- Just (Statics info_lbl info) ->
+ Just (Statics info_lbl _) ->
sdocWithPlatform $ \platform ->
- pprSectionHeader Text $$
- (
- (if platformHasSubsectionsViaSymbols platform
- then ppr (mkDeadStripPreventer info_lbl) <> char ':'
- else empty) $$
- vcat (map pprData info) $$
- pprLabel info_lbl
- ) $$
- vcat (map pprBasicBlock blocks) $$
+ (if platformHasSubsectionsViaSymbols platform
+ then pprSectionHeader Text $$
+ ppr (mkDeadStripPreventer info_lbl) <> char ':'
+ else empty) $$
+ vcat (map (pprBasicBlock top_info) blocks) $$
-- above: Even the first block gets a label, because with branch-chain
-- elimination, it might be the target of a goto.
(if platformHasSubsectionsViaSymbols platform
@@ -91,10 +88,18 @@ pprNatCmmDecl proc@(CmmProc _ lbl (ListGraph blocks)) =
else empty)
-pprBasicBlock :: NatBasicBlock Instr -> SDoc
-pprBasicBlock (BasicBlock blockid instrs) =
- pprLabel (mkAsmTempLabel (getUnique blockid)) $$
- vcat (map pprInstr instrs)
+pprBasicBlock :: BlockEnv CmmStatics -> NatBasicBlock Instr -> SDoc
+pprBasicBlock info_env (BasicBlock blockid instrs)
+ = maybe_infotable $$
+ pprLabel (mkAsmTempLabel (getUnique blockid)) $$
+ vcat (map pprInstr instrs)
+ where
+ maybe_infotable = case mapLookup blockid info_env of
+ Nothing -> empty
+ Just (Statics info_lbl info) ->
+ pprSectionHeader Text $$
+ vcat (map pprData info) $$
+ pprLabel info_lbl
pprDatas :: CmmStatics -> SDoc
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index d0e89bbab9..1f61e378d8 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -321,7 +321,11 @@ tc_hs_type :: HsType Name -> ExpKind -> TcM TcType
tc_hs_type (HsParTy ty) exp_kind = tc_lhs_type ty exp_kind
tc_hs_type (HsDocTy ty _) exp_kind = tc_lhs_type ty exp_kind
tc_hs_type (HsQuasiQuoteTy {}) _ = panic "tc_hs_type: qq" -- Eliminated by renamer
-tc_hs_type (HsBangTy {}) _ = panic "tc_hs_type: bang" -- Unwrapped by con decls
+tc_hs_type ty@(HsBangTy {}) _
+ -- While top-level bangs at this point are eliminated (eg !(Maybe Int)),
+ -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of
+ -- bangs are invalid, so fail. (#7210)
+ = failWithTc (ptext (sLit "Unexpected strictness annotation:") <+> ppr ty)
tc_hs_type (HsRecTy _) _ = panic "tc_hs_type: record" -- Unwrapped by con decls
-- Record types (which only show up temporarily in constructor
-- signatures) should have been removed by now
View Lorry Controller Status