diff options
77 files changed, 1427 insertions, 1830 deletions
diff --git a/compiler/basicTypes/Literal.lhs b/compiler/basicTypes/Literal.lhs index 220ef9edd1..a590eae1b2 100644 --- a/compiler/basicTypes/Literal.lhs +++ b/compiler/basicTypes/Literal.lhs @@ -351,10 +351,9 @@ litIsDupable dflags (LitInteger i _) = inIntRange dflags i litIsDupable _ _ = True litFitsInChar :: Literal -> Bool -litFitsInChar (MachInt i) - = fromInteger i <= ord minBound - && fromInteger i >= ord maxBound -litFitsInChar _ = False +litFitsInChar (MachInt i) = i >= toInteger (ord minBound) + && i <= toInteger (ord maxBound) +litFitsInChar _ = False litIsLifted :: Literal -> Bool litIsLifted (LitInteger {}) = True diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 1ff76c6fe4..a5d559e9ff 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -13,7 +13,7 @@ module CLabel ( mkClosureLabel, mkSRTLabel, - mkModSRTLabel, + mkTopSRTLabel, mkInfoTableLabel, mkEntryLabel, mkSlowEntryLabel, @@ -120,8 +120,6 @@ import DynFlags import Platform import UniqSet -import Data.Maybe (isJust) - -- ----------------------------------------------------------------------------- -- The CLabel type @@ -218,7 +216,7 @@ data CLabel | HpcTicksLabel Module -- | Static reference table - | SRTLabel (Maybe Module) !Unique + | SRTLabel !Unique -- | Label of an StgLargeSRT | LargeSRTLabel @@ -355,8 +353,8 @@ 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 +mkTopSRTLabel :: Unique -> CLabel +mkTopSRTLabel u = SRTLabel u mkSRTLabel :: Name -> CafInfo -> CLabel mkRednCountsLabel :: Name -> CafInfo -> CLabel @@ -592,7 +590,7 @@ needsCDecl :: CLabel -> Bool -- False <=> it's pre-declared; don't bother -- don't bother declaring Bitmap labels, we always make sure -- they are defined before use. -needsCDecl (SRTLabel _ _) = True +needsCDecl (SRTLabel _) = True needsCDecl (LargeSRTLabel _) = False needsCDecl (LargeBitmapLabel _) = False needsCDecl (IdLabel _ _ _) = True @@ -740,7 +738,7 @@ externallyVisibleCLabel (CCS_Label _) = True externallyVisibleCLabel (DynamicLinkerLabel _ _) = False externallyVisibleCLabel (HpcTicksLabel _) = True externallyVisibleCLabel (LargeBitmapLabel _) = False -externallyVisibleCLabel (SRTLabel mb_mod _) = isJust mb_mod +externallyVisibleCLabel (SRTLabel _) = False externallyVisibleCLabel (LargeSRTLabel _) = False externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel" externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer" @@ -788,7 +786,7 @@ labelType (RtsLabel (RtsApFast _)) = CodeLabel labelType (CaseLabel _ CaseReturnInfo) = DataLabel labelType (CaseLabel _ _) = CodeLabel labelType (PlainModuleInitLabel _) = CodeLabel -labelType (SRTLabel _ _) = DataLabel +labelType (SRTLabel _) = DataLabel labelType (LargeSRTLabel _) = DataLabel labelType (LargeBitmapLabel _) = DataLabel labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel @@ -991,10 +989,8 @@ 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 (SRTLabel u) + = pprUnique u <> pp_cSEP <> ptext (sLit "srt") pprCLbl (LargeSRTLabel u) = pprUnique u <> pp_cSEP <> ptext (sLit "srtd") pprCLbl (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLit "btm") diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index d587d60f95..ecaab57d76 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -14,28 +14,23 @@ {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} module CmmBuildInfoTables ( CAFSet, CAFEnv, cafAnal - , doSRTs, TopSRT, emptySRT, srtToData ) + , doSRTs, TopSRT, emptySRT, isEmptySRT, srtToData ) where #include "HsVersions.h" --- These should not be imported here! -import StgCmmUtils import Hoopl - import Digraph -import qualified Prelude as P -import Prelude hiding (succ) - import BlockId import Bitmap import CLabel +import PprCmmDecl () import Cmm import CmmUtils +import CmmInfo import Data.List import DynFlags import Maybes -import Module import Outputable import SMRep import UniqSupply @@ -47,6 +42,9 @@ import Data.Set (Set) import qualified Data.Set as Set import Control.Monad +import qualified Prelude as P +import Prelude hiding (succ) + foldSet :: (a -> b -> b) -> b -> Set a -> b foldSet = Set.foldr @@ -137,11 +135,14 @@ instance Outputable TopSRT where <+> ppr elts <+> ppr eltmap -emptySRT :: MonadUnique m => Maybe Module -> m TopSRT -emptySRT mb_mod = - do top_lbl <- getUniqueM >>= \ u -> return $ mkModSRTLabel mb_mod u +emptySRT :: MonadUnique m => m TopSRT +emptySRT = + do top_lbl <- getUniqueM >>= \ u -> return $ mkTopSRTLabel u return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = Map.empty } +isEmptySRT :: TopSRT -> Bool +isEmptySRT srt = null (rev_elts srt) + cafMember :: TopSRT -> CLabel -> Bool cafMember srt lbl = Map.member lbl (elt_map srt) @@ -228,7 +229,7 @@ maxBmpSize dflags = widthInBits (wordWidth dflags) `div` 2 -- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT. to_SRT :: DynFlags -> CLabel -> Int -> Int -> Bitmap -> UniqSM (Maybe CmmDecl, C_SRT) to_SRT dflags top_srt off len bmp - | len > maxBmpSize dflags || bmp == [toStgWord dflags (fromStgHalfWord (srt_escape dflags))] + | len > maxBmpSize dflags || bmp == [toStgWord dflags (fromStgHalfWord (srtEscape dflags))] = do id <- getUniqueM let srt_desc_lbl = mkLargeSRTLabel id tbl = CmmData RelocatableReadOnlyData $ @@ -236,7 +237,7 @@ to_SRT dflags top_srt off len bmp ( cmmLabelOffW dflags top_srt off : mkWordCLit dflags (toStgWord dflags (fromIntegral len)) : map (mkWordCLit dflags) bmp) - return (Just tbl, C_SRT srt_desc_lbl 0 (srt_escape dflags)) + return (Just tbl, C_SRT srt_desc_lbl 0 (srtEscape dflags)) | otherwise = return (Nothing, C_SRT top_srt off (toStgHalfWord dflags (fromStgWord (head bmp)))) -- The fromIntegral converts to StgHalfWord diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index 9d335c6f7b..6aa4d6cbfa 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -9,6 +9,7 @@ module CmmInfo ( mkEmptyContInfoTable, cmmToRawCmm, mkInfoTable, + srtEscape ) where #include "HsVersions.h" @@ -384,3 +385,9 @@ newStringLit bytes = do { uniq <- getUniqueUs ; return (mkByteStringCLit uniq bytes) } + +-- Misc utils + +-- | Value of the srt field of an info table when using an StgLargeSRT +srtEscape :: DynFlags -> StgHalfWord +srtEscape dflags = toStgHalfWord dflags (-1) diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs index 5505b92f5a..6f75f5451c 100644 --- a/compiler/cmm/CmmLayoutStack.hs +++ b/compiler/cmm/CmmLayoutStack.hs @@ -3,8 +3,9 @@ module CmmLayoutStack ( cmmLayoutStack, setInfoTableStackMap ) where -import StgCmmUtils ( callerSaveVolatileRegs ) -- XXX -import StgCmmForeign ( saveThreadState, loadThreadState ) -- XXX +import StgCmmUtils ( callerSaveVolatileRegs ) -- XXX layering violation +import StgCmmForeign ( saveThreadState, loadThreadState ) -- XXX layering violation +import StgCmmLayout ( entryCode ) -- XXX layering violation import Cmm import BlockId @@ -939,7 +940,8 @@ lowerSafeForeignCall dflags block -- received an exception during the call, then the stack might be -- different. Hence we continue by jumping to the top stack frame, -- not by jumping to succ. - jump = CmmCall { cml_target = CmmLoad (CmmReg spReg) (bWord dflags) + jump = CmmCall { cml_target = entryCode dflags $ + CmmLoad (CmmReg spReg) (bWord dflags) , cml_cont = Just succ , cml_args_regs = regs , cml_args = widthInBytes (wordWidth dflags) diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index 0df24a6a66..32afa1d078 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -7,8 +7,6 @@ ----------------------------------------------------------------------------- module CmmOpt ( - cmmEliminateDeadBlocks, - cmmMiniInline, cmmMachOpFold, cmmMachOpFoldM, cmmLoopifyForC, @@ -17,282 +15,15 @@ module CmmOpt ( #include "HsVersions.h" import OldCmm -import OldPprCmm -import CmmNode (wrapRecExp) -import CmmUtils import DynFlags import CLabel -import UniqFM -import Unique -import Util import FastTypes import Outputable import Platform -import BlockId import Data.Bits import Data.Maybe -import Data.List - --- ----------------------------------------------------------------------------- --- Eliminates dead blocks - -{- -We repeatedly expand the set of reachable blocks until we hit a -fixpoint, and then prune any blocks that were not in this set. This is -actually a required optimization, as dead blocks can cause problems -for invariants in the linear register allocator (and possibly other -places.) --} - --- Deep fold over statements could probably be abstracted out, but it --- might not be worth the effort since OldCmm is moribund -cmmEliminateDeadBlocks :: [CmmBasicBlock] -> [CmmBasicBlock] -cmmEliminateDeadBlocks [] = [] -cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) = - let -- Calculate what's reachable from what block - reachableMap = foldl' f emptyUFM blocks -- lazy in values - where f m (BasicBlock block_id stmts) = addToUFM m block_id (reachableFrom stmts) - reachableFrom stmts = foldl stmt [] stmts - where - stmt m CmmNop = m - stmt m (CmmComment _) = m - stmt m (CmmAssign _ e) = expr m e - stmt m (CmmStore e1 e2) = expr (expr m e1) e2 - stmt m (CmmCall c _ as _) = f (actuals m as) c - where f m (CmmCallee e _) = expr m e - f m (CmmPrim _ Nothing) = m - f m (CmmPrim _ (Just stmts)) = foldl' stmt m stmts - stmt m (CmmBranch b) = b:m - stmt m (CmmCondBranch e b) = b:(expr m e) - stmt m (CmmSwitch e bs) = catMaybes bs ++ expr m e - stmt m (CmmJump e _) = expr m e - stmt m (CmmReturn) = m - actuals m as = foldl' (\m h -> expr m (hintlessCmm h)) m as - -- We have to do a deep fold into CmmExpr because - -- there may be a BlockId in the CmmBlock literal. - expr m (CmmLit l) = lit m l - expr m (CmmLoad e _) = expr m e - expr m (CmmReg _) = m - expr m (CmmMachOp _ es) = foldl' expr m es - expr m (CmmStackSlot _ _) = m - expr m (CmmRegOff _ _) = m - lit m (CmmBlock b) = b:m - lit m _ = m - -- go todo done - reachable = go [base_id] (setEmpty :: BlockSet) - where go [] m = m - go (x:xs) m - | setMember x m = go xs m - | otherwise = go (add ++ xs) (setInsert x m) - where add = fromMaybe (panic "cmmEliminateDeadBlocks: unknown block") - (lookupUFM reachableMap x) - in filter (\(BasicBlock block_id _) -> setMember block_id reachable) blocks - --- ----------------------------------------------------------------------------- --- The mini-inliner - -{- -This pass inlines assignments to temporaries. Temporaries that are -only used once are unconditionally inlined. Temporaries that are used -two or more times are only inlined if they are assigned a literal. It -works as follows: - - - count uses of each temporary - - for each temporary: - - attempt to push it forward to the statement that uses it - - only push forward past assignments to other temporaries - (assumes that temporaries are single-assignment) - - if we reach the statement that uses it, inline the rhs - and delete the original assignment. - -[N.B. In the Quick C-- compiler, this optimization is achieved by a - combination of two dataflow passes: forward substitution (peephole - optimization) and dead-assignment elimination. ---NR] - -Possible generalisations: here is an example from factorial - -Fac_zdwfac_entry: - cmG: - _smi = R2; - if (_smi != 0) goto cmK; - R1 = R3; - jump I64[Sp]; - cmK: - _smn = _smi * R3; - R2 = _smi + (-1); - R3 = _smn; - jump Fac_zdwfac_info; - -We want to inline _smi and _smn. To inline _smn: - - - we must be able to push forward past assignments to global regs. - We can do this if the rhs of the assignment we are pushing - forward doesn't refer to the global reg being assigned to; easy - to test. - -To inline _smi: - - - It is a trivial replacement, reg for reg, but it occurs more than - once. - - We can inline trivial assignments even if the temporary occurs - more than once, as long as we don't eliminate the original assignment - (this doesn't help much on its own). - - We need to be able to propagate the assignment forward through jumps; - if we did this, we would find that it can be inlined safely in all - its occurrences. --} - -countUses :: UserOfLocalRegs a => a -> UniqFM Int -countUses a = foldRegsUsed (\m r -> addToUFM_C (+) m r 1) emptyUFM a - -cmmMiniInline :: DynFlags -> [CmmBasicBlock] -> [CmmBasicBlock] -cmmMiniInline dflags blocks = map do_inline blocks - where do_inline (BasicBlock id stmts) - = BasicBlock id (cmmMiniInlineStmts dflags (countUses blocks) stmts) - -cmmMiniInlineStmts :: DynFlags -> UniqFM Int -> [CmmStmt] -> [CmmStmt] -cmmMiniInlineStmts _ _ [] = [] -cmmMiniInlineStmts dflags uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts) - -- not used: just discard this assignment - | 0 <- lookupWithDefaultUFM uses 0 u - = cmmMiniInlineStmts dflags uses stmts - - -- used (foldable to small thing): try to inline at all the use sites - | Just n <- lookupUFM uses u, - e <- wrapRecExp foldExp expr, - isTiny e - = - ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt stmt)) $ - case lookForInlineMany u e stmts of - (m, stmts') - | n == m -> cmmMiniInlineStmts dflags (delFromUFM uses u) stmts' - | otherwise -> - stmt : cmmMiniInlineStmts dflags (adjustUFM (\x -> x - m) uses u) stmts' - - -- used once (non-literal): try to inline at the use site - | Just 1 <- lookupUFM uses u, - Just stmts' <- lookForInline u expr stmts - = - ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt stmt)) $ - cmmMiniInlineStmts dflags uses stmts' - where - isTiny (CmmLit _) = True - isTiny (CmmReg (CmmGlobal _)) = True - -- not CmmLocal: that might invalidate the usage analysis results - isTiny _ = False - - foldExp (CmmMachOp op args) = cmmMachOpFold dflags op args - foldExp e = e - - ncgDebugTrace str x = if ncgDebugIsOn then trace str x else x - -cmmMiniInlineStmts platform uses (stmt:stmts) - = stmt : cmmMiniInlineStmts platform uses stmts - --- | Takes a register, a 'CmmLit' expression assigned to that --- register, and a list of statements. Inlines the expression at all --- use sites of the register. Returns the number of substituations --- made and the, possibly modified, list of statements. -lookForInlineMany :: Unique -> CmmExpr -> [CmmStmt] -> (Int, [CmmStmt]) -lookForInlineMany u expr stmts = lookForInlineMany' u expr regset stmts - where regset = foldRegsUsed extendRegSet emptyRegSet expr - -lookForInlineMany' :: Unique -> CmmExpr -> RegSet -> [CmmStmt] -> (Int, [CmmStmt]) -lookForInlineMany' _ _ _ [] = (0, []) -lookForInlineMany' u expr regset stmts@(stmt : rest) - | Just n <- lookupUFM (countUses stmt) u, okToInline expr stmt - = let stmt' = inlineStmt u expr stmt in - if okToSkip stmt' u expr regset - then case lookForInlineMany' u expr regset rest of - (m, stmts) -> let z = n + m - in z `seq` (z, stmt' : stmts) - else (n, stmt' : rest) - - | okToSkip stmt u expr regset - = case lookForInlineMany' u expr regset rest of - (n, stmts) -> (n, stmt : stmts) - - | otherwise - = (0, stmts) - - -lookForInline :: Unique -> CmmExpr -> [CmmStmt] -> Maybe [CmmStmt] -lookForInline u expr stmts = lookForInline' u expr regset stmts - where regset = foldRegsUsed extendRegSet emptyRegSet expr - -lookForInline' :: Unique -> CmmExpr -> RegSet -> [CmmStmt] -> Maybe [CmmStmt] -lookForInline' _ _ _ [] = panic "lookForInline' []" -lookForInline' u expr regset (stmt : rest) - | Just 1 <- lookupUFM (countUses stmt) u, okToInline expr stmt - = Just (inlineStmt u expr stmt : rest) - - | okToSkip stmt u expr regset - = case lookForInline' u expr regset rest of - Nothing -> Nothing - Just stmts -> Just (stmt:stmts) - - | otherwise - = Nothing - - --- we don't inline into CmmCall if the expression refers to global --- registers. This is a HACK to avoid global registers clashing with --- C argument-passing registers, really the back-end ought to be able --- to handle it properly, but currently neither PprC nor the NCG can --- do it. See also CgForeignCall:load_args_into_temps. -okToInline :: CmmExpr -> CmmStmt -> Bool -okToInline expr CmmCall{} = hasNoGlobalRegs expr -okToInline _ _ = True - --- Expressions aren't side-effecting. Temporaries may or may not --- be single-assignment depending on the source (the old code --- generator creates single-assignment code, but hand-written Cmm --- and Cmm from the new code generator is not single-assignment.) --- So we do an extra check to make sure that the register being --- changed is not one we were relying on. I don't know how much of a --- performance hit this is (we have to create a regset for every --- instruction.) -- EZY -okToSkip :: CmmStmt -> Unique -> CmmExpr -> RegSet -> Bool -okToSkip stmt u expr regset - = case stmt of - CmmNop -> True - CmmComment{} -> True - CmmAssign (CmmLocal r@(LocalReg u' _)) _rhs | u' /= u && not (r `elemRegSet` regset) -> True - CmmAssign g@(CmmGlobal _) _rhs -> not (g `regUsedIn` expr) - CmmStore _ _ -> not_a_load expr - _other -> False - where - not_a_load (CmmMachOp _ args) = all not_a_load args - not_a_load (CmmLoad _ _) = False - not_a_load _ = True - -inlineStmt :: Unique -> CmmExpr -> CmmStmt -> CmmStmt -inlineStmt u a (CmmAssign r e) = CmmAssign r (inlineExpr u a e) -inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e2) -inlineStmt u a (CmmCall target regs es ret) - = CmmCall (infn target) regs es' ret - where infn (CmmCallee fn cconv) = CmmCallee (inlineExpr u a fn) cconv - infn (CmmPrim p mStmts) = CmmPrim p (fmap (map (inlineStmt u a)) mStmts) - es' = [ (CmmHinted (inlineExpr u a e) hint) | (CmmHinted e hint) <- es ] -inlineStmt u a (CmmCondBranch e d) = CmmCondBranch (inlineExpr u a e) d -inlineStmt u a (CmmSwitch e d) = CmmSwitch (inlineExpr u a e) d -inlineStmt u a (CmmJump e live) = CmmJump (inlineExpr u a e) live -inlineStmt _ _ other_stmt = other_stmt - -inlineExpr :: Unique -> CmmExpr -> CmmExpr -> CmmExpr -inlineExpr u a e@(CmmReg (CmmLocal (LocalReg u' _))) - | u == u' = a - | otherwise = e -inlineExpr u a e@(CmmRegOff (CmmLocal (LocalReg u' rep)) off) - | u == u' = CmmMachOp (MO_Add width) [a, CmmLit (CmmInt (fromIntegral off) width)] - | otherwise = e - where - width = typeWidth rep -inlineExpr u a (CmmLoad e rep) = CmmLoad (inlineExpr u a e) rep -inlineExpr u a (CmmMachOp op es) = CmmMachOp op (map (inlineExpr u a) es) -inlineExpr _ _ other_expr = other_expr -- ----------------------------------------------------------------------------- -- MachOp constant folder diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index 25fda1ca07..5fca9e7164 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -114,7 +114,8 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) procPointAnalysis proc_points g dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" pp_map gs <- {-# SCC "splitAtProcPoints" #-} runUniqSM $ - splitAtProcPoints l call_pps proc_points pp_map (CmmProc h l g) + splitAtProcPoints dflags l call_pps proc_points pp_map + (CmmProc h l g) dumps Opt_D_dump_cmmz_split "Post splitting" gs ------------- Populate info tables with stack info ----------------- diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs index 58f2e54ffa..471faf8b0c 100644 --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -11,6 +11,7 @@ where import Prelude hiding (last, unzip, succ, zip) +import DynFlags import BlockId import CLabel import Cmm @@ -26,8 +27,6 @@ import UniqSupply import Hoopl -import qualified Data.Map as Map - -- Compute a minimal set of proc points for a control-flow graph. -- Determine a protocol for each proc point (which live variables will @@ -207,9 +206,9 @@ extendPPSet platform g blocks procPoints = -- Input invariant: A block should only be reachable from a single ProcPoint. -- ToDo: use the _ret naming convention that the old code generator -- used. -- EZY -splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status -> +splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status -> CmmDecl -> UniqSM [CmmDecl] -splitAtProcPoints entry_label callPPs procPoints procMap +splitAtProcPoints dflags entry_label callPPs procPoints procMap (CmmProc (TopInfo {info_tbls = info_tbls}) top_l g@(CmmGraph {g_entry=entry})) = do -- Build a map from procpoints to the blocks they reach @@ -234,12 +233,15 @@ splitAtProcPoints entry_label callPPs procPoints procMap -- * Labels for the info tables of their new procedures (only if -- the proc point is a callPP) -- Due to common blockification, we may overestimate the set of procpoints. - let add_label map pp = Map.insert pp lbls map + let add_label map pp = mapInsert pp lbls map where lbls | pp == entry = (entry_label, Just (toInfoLbl entry_label)) | otherwise = (blockLbl pp, guard (setMember pp callPPs) >> Just (infoTblLbl pp)) - procLabels = foldl add_label Map.empty + + procLabels :: LabelMap (CLabel, Maybe CLabel) + procLabels = foldl add_label mapEmpty (filter (flip mapMember (toBlockMap g)) (setElems procPoints)) + -- In each new graph, add blocks jumping off to the new procedures, -- and replace branches to procpoints with branches to the jump-off blocks let add_jump_block (env, bs) (pp, l) = @@ -259,8 +261,17 @@ splitAtProcPoints entry_label callPPs procPoints procMap CmmCondBranch _ ti fi -> add_if_pp ti (add_if_pp fi rst) CmmSwitch _ tbl -> foldr add_if_pp rst (catMaybes tbl) _ -> rst - add_if_pp id rst = case Map.lookup id procLabels of - Just (lbl, mb_info_lbl) -> (id, mb_info_lbl `orElse` lbl) : rst + + -- when jumping to a PP that has an info table, if + -- tablesNextToCode is off we must jump to the entry + -- label instead. + jump_label (Just info_lbl) _ + | tablesNextToCode dflags = info_lbl + | otherwise = toEntryLbl info_lbl + jump_label Nothing block_lbl = block_lbl + + add_if_pp id rst = case mapLookup id procLabels of + Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst Nothing -> rst (jumpEnv, jumpBlocks) <- foldM add_jump_block (mapEmpty, []) needed_jumps @@ -274,8 +285,10 @@ splitAtProcPoints entry_label callPPs procPoints procMap let g' = ofBlockMap ppId blockEnv''' -- pprTrace "g' pre jumps" (ppr g') $ do return (mapInsert ppId g' newGraphEnv) + graphEnv <- foldM add_jumps emptyBlockMap $ mapToList graphEnv - let to_proc (bid, g) = case expectJust "pp label" $ Map.lookup bid procLabels of + + let to_proc (bid, g) = case expectJust "pp label" $ mapLookup bid procLabels of (lbl, Just info_lbl) | bid == entry -> CmmProc (TopInfo {info_tbls=info_tbls, stack_info=stack_info}) @@ -295,7 +308,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap replacePPIds g = {-# SCC "replacePPIds" #-} mapGraphNodes (id, mapExp repl, mapExp repl) g where repl e@(CmmLit (CmmBlock bid)) = - case Map.lookup bid procLabels of + case mapLookup bid procLabels of Just (_, Just info_lbl) -> CmmLit (CmmLabel info_lbl) _ -> e repl e = e @@ -312,7 +325,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap return -- pprTrace "procLabels" (ppr procLabels) -- pprTrace "splitting graphs" (ppr procs) procs -splitAtProcPoints _ _ _ _ t@(CmmData _ _) = return [t] +splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t] -- Only called from CmmProcPoint.splitAtProcPoints. NB. does a diff --git a/compiler/cmm/CmmRewriteAssignments.hs b/compiler/cmm/CmmRewriteAssignments.hs index 585d78e95b..0f2aeaa939 100644 --- a/compiler/cmm/CmmRewriteAssignments.hs +++ b/compiler/cmm/CmmRewriteAssignments.hs @@ -15,10 +15,11 @@ module CmmRewriteAssignments ( rewriteAssignments ) where +import StgCmmUtils -- XXX layering violation + import Cmm import CmmUtils import CmmOpt -import StgCmmUtils import DynFlags import UniqSupply diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs index 8c5c99d469..7acc4dd460 100644 --- a/compiler/cmm/CmmSink.hs +++ b/compiler/cmm/CmmSink.hs @@ -3,7 +3,7 @@ module CmmSink ( cmmSink ) where -import StgCmmUtils (callerSaves) +import CodeGen.Platform (callerSaves) import Cmm import BlockId @@ -155,7 +155,7 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets') where should_drop = conflicts dflags a final_last - || {- not (isTiny rhs) && -} live_in_multi live_sets r + || {- not (isSmall rhs) && -} live_in_multi live_sets r || r `Set.member` live_in_joins live_sets' | should_drop = live_sets @@ -172,12 +172,21 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks mapFromList [ (l, filterAssignments dflags (getLive l) assigs'') | l <- succs ] -{- --- tiny: an expression we don't mind duplicating -isTiny :: CmmExpr -> Bool -isTiny (CmmReg _) = True -isTiny (CmmLit _) = True -isTiny _other = False +{- TODO: enable this later, when we have some good tests in place to + measure the effect and tune it. + +-- small: an expression we don't mind duplicating +isSmall :: CmmExpr -> Bool +isSmall (CmmReg (CmmLocal _)) = True -- not globals, we want to coalesce them instead +isSmall (CmmLit _) = True +isSmall (CmmMachOp (MO_Add _) [x,y]) = isTrivial x && isTrivial y +isSmall (CmmRegOff (CmmLocal _) _) = True +isSmall _ = False + +isTrivial :: CmmExpr -> Bool +isTrivial (CmmReg (CmmLocal _)) = True +isTrivial (CmmLit _) = True +isTrivial _ = False -} -- diff --git a/compiler/cmm/CmmType.hs b/compiler/cmm/CmmType.hs index b6deb01bcd..d6da5a4022 100644 --- a/compiler/cmm/CmmType.hs +++ b/compiler/cmm/CmmType.hs @@ -12,6 +12,9 @@ module CmmType , wordWidth, halfWordWidth, cIntWidth, cLongWidth , halfWordMask , narrowU, narrowS + , rEP_CostCentreStack_mem_alloc + , rEP_CostCentreStack_scc_count + , rEP_StgEntCounter_allocs ) where @@ -239,6 +242,26 @@ narrowS W64 x = fromIntegral (fromIntegral x :: Int64) narrowS _ _ = panic "narrowTo" ------------------------------------------------------------------------- + +-- These don't really belong here, but I don't know where is best to +-- put them. + +rEP_CostCentreStack_mem_alloc :: DynFlags -> CmmType +rEP_CostCentreStack_mem_alloc dflags + = cmmBits (widthFromBytes (pc_REP_CostCentreStack_mem_alloc pc)) + where pc = sPlatformConstants (settings dflags) + +rEP_CostCentreStack_scc_count :: DynFlags -> CmmType +rEP_CostCentreStack_scc_count dflags + = cmmBits (widthFromBytes (pc_REP_CostCentreStack_scc_count pc)) + where pc = sPlatformConstants (settings dflags) + +rEP_StgEntCounter_allocs :: DynFlags -> CmmType +rEP_StgEntCounter_allocs dflags + = cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocs pc)) + where pc = sPlatformConstants (settings dflags) + +------------------------------------------------------------------------- {- Note [Signed vs unsigned] ~~~~~~~~~~~~~~~~~~~~~~~~~ Should a CmmType include a signed vs. unsigned distinction? diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs index 3233dbed8c..4ba82cd8f8 100644 --- a/compiler/cmm/MkGraph.hs +++ b/compiler/cmm/MkGraph.hs @@ -11,7 +11,7 @@ module MkGraph , mkJumpReturnsTo , mkJump, mkDirectJump, mkForeignJump, mkForeignJumpExtra, mkJumpGC , mkCbranch, mkSwitch - , mkReturn, mkReturnSimple, mkComment, mkCallEntry, mkBranch + , mkReturn, mkComment, mkCallEntry, mkBranch , copyInOflow, copyOutOflow , noExtraStack , toCall, Transfer(..) @@ -69,34 +69,38 @@ flattenCmmAGraph id stmts = CmmGraph { g_entry = id, g_graph = GMany NothingO body NothingO } where - blocks = flatten1 (fromOL stmts) (blockJoinHead (CmmEntry id) emptyBlock) [] - body = foldr addBlock emptyBody blocks + body = foldr addBlock emptyBody $ flatten id stmts [] -- - -- flatten: turn a list of CgStmt into a list of Blocks. We know - -- that any code before the first label is unreachable, so just drop - -- it. + -- flatten: given an entry label and a CmmAGraph, make a list of blocks. -- -- NB. avoid the quadratic-append trap by passing in the tail of the -- list. This is important for Very Long Functions (e.g. in T783). -- - flatten :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C] - flatten [] blocks = blocks + flatten :: Label -> CmmAGraph -> [Block CmmNode C C] -> [Block CmmNode C C] + flatten id g blocks + = flatten1 (fromOL g) (blockJoinHead (CmmEntry id) emptyBlock) blocks - flatten (CgLabel id : stmts) blocks + -- + -- flatten0: we are outside a block at this point: any code before + -- the first label is unreachable, so just drop it. + -- + flatten0 :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C] + flatten0 [] blocks = blocks + + flatten0 (CgLabel id : stmts) blocks = flatten1 stmts block blocks where !block = blockJoinHead (CmmEntry id) emptyBlock - flatten (CgFork fork_id stmts : rest) blocks - = flatten1 (fromOL stmts) (blockJoinHead (CmmEntry fork_id) emptyBlock) $ - flatten rest blocks + flatten0 (CgFork fork_id stmts : rest) blocks + = flatten fork_id stmts $ flatten0 rest blocks - flatten (CgLast _ : stmts) blocks = flatten stmts blocks - flatten (CgStmt _ : stmts) blocks = flatten stmts blocks + flatten0 (CgLast _ : stmts) blocks = flatten0 stmts blocks + flatten0 (CgStmt _ : stmts) blocks = flatten0 stmts blocks -- -- flatten1: we have a partial block, collect statements until the - -- next last node to make a block, then call flatten to get the rest + -- next last node to make a block, then call flatten0 to get the rest -- of the blocks -- flatten1 :: [CgStmt] -> Block CmmNode C O @@ -112,7 +116,7 @@ flattenCmmAGraph id stmts = = blockJoinTail block (CmmBranch (entryLabel block)) : blocks flatten1 (CgLast stmt : stmts) block blocks - = block' : flatten stmts blocks + = block' : flatten0 stmts blocks where !block' = blockJoinTail block stmt flatten1 (CgStmt stmt : stmts) block blocks @@ -120,8 +124,7 @@ flattenCmmAGraph id stmts = where !block' = blockSnoc block stmt flatten1 (CgFork fork_id stmts : rest) block blocks - = flatten1 (fromOL stmts) (blockJoinHead (CmmEntry fork_id) emptyBlock) $ - flatten1 rest block blocks + = flatten fork_id stmts $ flatten1 rest block blocks -- a label here means that we should start a new block, and the -- current block should fall through to the new block. @@ -228,11 +231,6 @@ mkReturn dflags e actuals updfr_off = lastWithArgs dflags Ret Old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0 -mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph -mkReturnSimple dflags actuals updfr_off = - mkReturn dflags e actuals updfr_off - where e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags) - mkBranch :: BlockId -> CmmAGraph mkBranch bid = mkLast (CmmBranch bid) diff --git a/compiler/cmm/OldCmmLint.hs b/compiler/cmm/OldCmmLint.hs index 5dd3209892..f158369b13 100644 --- a/compiler/cmm/OldCmmLint.hs +++ b/compiler/cmm/OldCmmLint.hs @@ -19,7 +19,6 @@ module OldCmmLint ( import BlockId import OldCmm -import CLabel import Outputable import OldPprCmm() import FastString @@ -50,10 +49,9 @@ runCmmLint _ l p = lintCmmDecl :: DynFlags -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint () lintCmmDecl dflags (CmmProc _ lbl (ListGraph blocks)) - = addLintInfo (text "in proc " <> pprCLabel platform lbl) $ + = addLintInfo (text "in proc " <> ppr lbl) $ let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks in mapM_ (lintCmmBlock dflags labels) blocks - where platform = targetPlatform dflags lintCmmDecl _ (CmmData {}) = return () diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs index d2491d3089..2cb90e9a22 100644 --- a/compiler/cmm/PprCmmDecl.hs +++ b/compiler/cmm/PprCmmDecl.hs @@ -38,13 +38,11 @@ module PprCmmDecl ) where -import CLabel import PprCmmExpr import Cmm import DynFlags import Outputable -import Platform import FastString import Data.List @@ -72,7 +70,7 @@ instance (Outputable d, Outputable info, Outputable i) ppr t = pprTop t instance Outputable CmmStatics where - ppr x = sdocWithPlatform $ \platform -> pprStatics platform x + ppr = pprStatics instance Outputable CmmStatic where ppr = pprStatic @@ -141,9 +139,8 @@ instance Outputable ForeignHint where -- Strings are printed as C strings, and we print them as I8[], -- following C-- -- -pprStatics :: Platform -> CmmStatics -> SDoc -pprStatics platform (Statics lbl ds) - = vcat ((pprCLabel platform lbl <> colon) : map ppr ds) +pprStatics :: CmmStatics -> SDoc +pprStatics (Statics lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds) pprStatic :: CmmStatic -> SDoc pprStatic s = case s of diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs index 5537e575d4..c124b5f68a 100644 --- a/compiler/codeGen/CgProf.hs +++ b/compiler/codeGen/CgProf.hs @@ -23,8 +23,6 @@ module CgProf ( ) where #include "HsVersions.h" -#include "../includes/dist-derivedconstants/header/DerivedConstants.h" - -- For REP_xxx constants, which are MachReps import ClosureInfo import CgUtils @@ -110,6 +108,7 @@ profAlloc :: CmmExpr -> CmmExpr -> Code profAlloc words ccs = ifProfiling $ do dflags <- getDynFlags + let alloc_rep = typeWidth (rEP_CostCentreStack_mem_alloc dflags) stmtC (addToMemE alloc_rep (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags)) (CmmMachOp (MO_UU_Conv (wordWidth dflags) alloc_rep) $ @@ -117,8 +116,6 @@ profAlloc words ccs mkIntExpr dflags (profHdrSize dflags)]])) -- subtract the "profiling overhead", which is the -- profiling header in a closure. - where - alloc_rep = typeWidth REP_CostCentreStack_mem_alloc -- ----------------------------------------------------------------------- -- Setting the current cost centre on entry to a closure @@ -215,7 +212,7 @@ sizeof_ccs_words dflags | ms == 0 = ws | otherwise = ws + 1 where - (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE dflags + (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` wORD_SIZE dflags -- --------------------------------------------------------------------------- -- Set the current cost centre stack @@ -239,7 +236,7 @@ pushCostCentre result ccs cc bumpSccCount :: DynFlags -> CmmExpr -> CmmStmt bumpSccCount dflags ccs - = addToMem (typeWidth REP_CostCentreStack_scc_count) + = addToMem (typeWidth (rEP_CostCentreStack_scc_count dflags)) (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1 ----------------------------------------------------------------------------- diff --git a/compiler/codeGen/CgTicky.hs b/compiler/codeGen/CgTicky.hs index 79215f6582..21837e787b 100644 --- a/compiler/codeGen/CgTicky.hs +++ b/compiler/codeGen/CgTicky.hs @@ -43,9 +43,6 @@ module CgTicky ( staticTickyHdr, ) where -#include "../includes/dist-derivedconstants/header/DerivedConstants.h" - -- For REP_xxx constants, which are MachReps - import ClosureInfo import CgUtils import CgMonad @@ -298,7 +295,7 @@ tickyAllocHeap hp if hp == 0 then [] -- Inside the stmtC to avoid control else [ -- dependency on the argument -- Bump the allcoation count in the StgEntCounter - addToMem (typeWidth REP_StgEntCounter_allocs) + addToMem (typeWidth (rEP_StgEntCounter_allocs dflags)) (CmmLit (cmmLabelOffB ticky_ctr (oFFSET_StgEntCounter_allocs dflags))) hp, -- Bump ALLOC_HEAP_ctr diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs deleted file mode 100644 index 311f947248..0000000000 --- a/compiler/codeGen/CodeGen.lhs +++ /dev/null @@ -1,234 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - -The Code Generator - -This module says how things get going at the top level. - -@codeGen@ is the interface to the outside world. The \tr{cgTop*} -functions drive the mangling of top-level bindings. - -\begin{code} - -module CodeGen ( codeGen ) where - -#include "HsVersions.h" - --- Required so that CgExpr is reached via at least one non-SOURCE --- import. Before, that wasn't the case, and CM therefore didn't --- bother to compile it. -import CgExpr ( {-NOTHING!-} ) -- DO NOT DELETE THIS IMPORT -import CgProf -import CgMonad -import CgBindery -import CgClosure -import CgCon -import CgUtils -import CgHpc - -import CLabel -import OldCmm -import OldPprCmm () - -import StgSyn -import PrelNames -import DynFlags - -import HscTypes -import CostCentre -import Id -import Name -import TyCon -import Module -import ErrUtils -import Panic -import Outputable -import Util - -import OrdList -import Stream (Stream, liftIO) -import qualified Stream - -import Data.IORef - -codeGen :: DynFlags - -> Module -- Module we are compiling - -> [TyCon] -- Type constructors - -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. - -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs - -> HpcInfo -- Profiling info - -> Stream IO CmmGroup () - -- N.B. returning '[Cmm]' and not 'Cmm' here makes it - -- possible for object splitting to split up the - -- pieces later. - -codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info - - = do { liftIO $ showPass dflags "CodeGen" - - ; cgref <- liftIO $ newIORef =<< initC - ; let cg :: FCode CmmGroup -> Stream IO CmmGroup () - cg fcode = do - cmm <- liftIO $ do - st <- readIORef cgref - let (a,st') = runC dflags this_mod st fcode - - dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" $ ppr a - - -- NB. stub-out cgs_tops and cgs_stmts. This fixes - -- a big space leak. DO NOT REMOVE! - writeIORef cgref $! st'{ cgs_tops = nilOL, - cgs_stmts = nilOL } - return a - Stream.yield cmm - - ; cg (getCmm $ mkModuleInit dflags cost_centre_info this_mod hpc_info) - - ; mapM_ (cg . getCmm . cgTopBinding dflags) stg_binds - - ; mapM_ (cg . cgTyCon) data_tycons - } - -mkModuleInit - :: DynFlags - -> CollectedCCs -- cost centre info - -> Module - -> HpcInfo - -> Code - -mkModuleInit dflags cost_centre_info this_mod hpc_info - = do { -- Allocate the static boolean that records if this - ; whenC (dopt Opt_Hpc dflags) $ - hpcTable this_mod hpc_info - - ; whenC (dopt Opt_SccProfilingOn dflags) $ do - initCostCentres cost_centre_info - - -- For backwards compatibility: user code may refer to this - -- label for calling hs_add_root(). - ; emitDecl (CmmData Data (Statics (mkPlainModuleInitLabel this_mod) [])) - - ; whenC (this_mod == mainModIs dflags) $ - emitSimpleProc (mkPlainModuleInitLabel rOOT_MAIN) $ return () - } -\end{code} - - - -Cost-centre profiling: Besides the usual stuff, we must produce -declarations for the cost-centres defined in this module; - -(The local cost-centres involved in this are passed into the -code-generator.) - -\begin{code} -initCostCentres :: CollectedCCs -> Code --- Emit the declarations, and return code to register them -initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs) - = do dflags <- getDynFlags - if not (dopt Opt_SccProfilingOn dflags) - then nopC - else do mapM_ emitCostCentreDecl local_CCs - mapM_ emitCostCentreStackDecl singleton_CCSs -\end{code} - -%************************************************************************ -%* * -\subsection[codegen-top-bindings]{Converting top-level STG bindings} -%* * -%************************************************************************ - -@cgTopBinding@ is only used for top-level bindings, since they need -to be allocated statically (not in the heap) and need to be labelled. -No unboxed bindings can happen at top level. - -In the code below, the static bindings are accumulated in the -@MkCgState@, and transferred into the ``statics'' slot by @forkStatics@. -This is so that we can write the top level processing in a compositional -style, with the increasing static environment being plumbed as a state -variable. - -\begin{code} -cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> Code -cgTopBinding dflags (StgNonRec id rhs, srts) - = do { id' <- maybeExternaliseId dflags id - ; mapM_ (mkSRT [id']) srts - ; (id,info) <- cgTopRhs id' rhs - ; addBindC id info -- Add the *un-externalised* Id to the envt, - -- so we find it when we look up occurrences - } - -cgTopBinding dflags (StgRec pairs, srts) - = do { let (bndrs, rhss) = unzip pairs - ; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs - ; let pairs' = zip bndrs' rhss - ; mapM_ (mkSRT bndrs') srts - ; _new_binds <- fixC (\ new_binds -> do - { addBindsC new_binds - ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' }) - ; nopC } - -mkSRT :: [Id] -> (Id,[Id]) -> Code -mkSRT _ (_,[]) = nopC -mkSRT these (id,ids) - = do { ids <- mapFCs remap ids - ; id <- remap id - ; emitRODataLits "CodeGen.mkSRT" (mkSRTLabel (idName id) (idCafInfo id)) - (map (\id -> CmmLabel $ mkClosureLabel (idName id) (idCafInfo id)) ids) - } - where - -- Sigh, better map all the ids against the environment in - -- case they've been externalised (see maybeExternaliseId below). - remap id = case filter (==id) these of - (id':_) -> returnFC id' - [] -> do { info <- getCgIdInfo id; return (cgIdInfoId info) } - --- Urgh! I tried moving the forkStatics call from the rhss of cgTopRhs --- to enclose the listFCs in cgTopBinding, but that tickled the --- statics "error" call in initC. I DON'T UNDERSTAND WHY! - -cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo) - -- The Id is passed along for setting up a binding... - -- It's already been externalised if necessary - -cgTopRhs bndr (StgRhsCon _cc con args) - = forkStatics (cgTopRhsCon bndr 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)) $ - setSRT srt $ - forkStatics (cgTopRhsClosure bndr cc bi upd_flag args body) -\end{code} - - -%************************************************************************ -%* * -\subsection{Stuff to support splitting} -%* * -%************************************************************************ - -If we're splitting the object, we need to externalise all the top-level names -(and then make sure we only use the externalised one in any C label we use -which refers to this name). - -\begin{code} -maybeExternaliseId :: DynFlags -> Id -> FCode Id -maybeExternaliseId dflags id - | dopt Opt_SplitObjs dflags, -- Externalise the name for -split-objs - isInternalName name = do { mod <- getModuleName - ; returnFC (setIdName id (externalise mod)) } - | otherwise = returnFC id - where - externalise mod = mkExternalName uniq mod new_occ loc - name = idName id - uniq = nameUnique name - new_occ = mkLocalOcc uniq (nameOccName name) - loc = nameSrcSpan name - -- We want to conjure up a name that can't clash with any - -- existing name. So we generate - -- Mod_$L243foo - -- where 243 is the unique. -\end{code} diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index f1022e5280..37ca5e0d43 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -52,7 +52,7 @@ codeGen :: DynFlags -> Module -> [TyCon] -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. - -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs + -> [StgBinding] -- Bindings to convert -> HpcInfo -> Stream IO CmmGroup () -- Output as a stream, so codegen can -- be interleaved with output @@ -114,8 +114,8 @@ This is so that we can write the top level processing in a compositional style, with the increasing static environment being plumbed as a state variable. -} -cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> FCode () -cgTopBinding dflags (StgNonRec id rhs, _srts) +cgTopBinding :: DynFlags -> StgBinding -> FCode () +cgTopBinding dflags (StgNonRec id rhs) = do { id' <- maybeExternaliseId dflags id ; (info, fcode) <- cgTopRhs id' rhs ; fcode @@ -123,7 +123,7 @@ cgTopBinding dflags (StgNonRec id rhs, _srts) -- so we find it when we look up occurrences } -cgTopBinding dflags (StgRec pairs, _srts) +cgTopBinding dflags (StgRec pairs) = do { let (bndrs, rhss) = unzip pairs ; bndrs' <- Prelude.mapM (maybeExternaliseId dflags) bndrs ; let pairs' = zip bndrs' rhss diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 02d3d0246f..89d27dd161 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -468,8 +468,7 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details { fv_bindings <- mapM bind_fv fv_details -- Load free vars out of closure *after* -- heap check, to reduce live vars over check - ; if node_points then load_fvs node lf_info fv_bindings - else return () + ; when node_points $ load_fvs node lf_info fv_bindings ; void $ cgExpr body }} } diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 307d3715b3..a8ffc12bb0 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -163,9 +163,7 @@ cgLetNoEscapeClosure bndr cc_slot _unused_cc args body code = forkProc $ do { restoreCurrentCostCentre cc_slot ; arg_regs <- bindArgsToRegs args - ; void $ altHeapCheck arg_regs (cgExpr body) } - -- Using altHeapCheck just reduces - -- instructions to save on stack + ; void $ noEscapeHeapCheck arg_regs (cgExpr body) } ------------------------------------------------------------------------ diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index fb3739177c..b7cca48f5a 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -10,7 +10,7 @@ module StgCmmHeap ( getVirtHp, setVirtHp, setRealHp, getHpRelOffset, hpRel, - entryHeapCheck, altHeapCheck, altHeapCheckReturnsTo, + entryHeapCheck, altHeapCheck, noEscapeHeapCheck, altHeapCheckReturnsTo, mkVirtHeapOffsets, mkVirtConstrOffsets, mkStaticClosureFields, mkStaticClosure, @@ -371,7 +371,7 @@ entryHeapCheck cl_info nodeSet arity args code loop_id <- newLabelC emitLabel loop_id - heapCheck True (gc_call updfr_sz <*> mkBranch loop_id) code + heapCheck True True (gc_call updfr_sz <*> mkBranch loop_id) code {- -- This code is slightly outdated now and we could easily keep the above @@ -436,32 +436,41 @@ entryHeapCheck cl_info nodeSet arity args code -- else we do a normal call to stg_gc_noregs altHeapCheck :: [LocalReg] -> FCode a -> FCode a -altHeapCheck regs code = do +altHeapCheck regs code = altOrNoEscapeHeapCheck False regs code + +altOrNoEscapeHeapCheck :: Bool -> [LocalReg] -> FCode a -> FCode a +altOrNoEscapeHeapCheck checkYield regs code = do dflags <- getDynFlags case cannedGCEntryPoint dflags regs of - Nothing -> genericGC code + Nothing -> genericGC checkYield code Just gc -> do lret <- newLabelC let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) regs lcont <- newLabelC emitOutOfLine lret (copyin <*> mkBranch lcont) emitLabel lcont - cannedGCReturnsTo False gc regs lret off code + cannedGCReturnsTo checkYield False gc regs lret off code altHeapCheckReturnsTo :: [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a altHeapCheckReturnsTo regs lret off code = do dflags <- getDynFlags case cannedGCEntryPoint dflags regs of - Nothing -> genericGC code - Just gc -> cannedGCReturnsTo True gc regs lret off code + Nothing -> genericGC False code + Just gc -> cannedGCReturnsTo False True gc regs lret off code + +-- noEscapeHeapCheck is implemented identically to altHeapCheck (which +-- is more efficient), but cannot be optimized away in the non-allocating +-- case because it may occur in a loop +noEscapeHeapCheck :: [LocalReg] -> FCode a -> FCode a +noEscapeHeapCheck regs code = altOrNoEscapeHeapCheck True regs code -cannedGCReturnsTo :: Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff +cannedGCReturnsTo :: Bool -> Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a -cannedGCReturnsTo cont_on_stack gc regs lret off code +cannedGCReturnsTo checkYield cont_on_stack gc regs lret off code = do dflags <- getDynFlags updfr_sz <- getUpdFrameOff - heapCheck False (gc_call dflags gc updfr_sz) code + heapCheck False checkYield (gc_call dflags gc updfr_sz) code where reg_exprs = map (CmmReg . CmmLocal) regs -- Note [stg_gc arguments] @@ -470,13 +479,13 @@ cannedGCReturnsTo cont_on_stack gc regs lret off code | cont_on_stack = mkJumpReturnsTo dflags label GC reg_exprs lret off sp | otherwise = mkCallReturnsTo dflags label GC reg_exprs lret off sp (0,[]) -genericGC :: FCode a -> FCode a -genericGC code +genericGC :: Bool -> FCode a -> FCode a +genericGC checkYield code = do updfr_sz <- getUpdFrameOff lretry <- newLabelC emitLabel lretry call <- mkCall generic_gc (GC, GC) [] [] updfr_sz (0,[]) - heapCheck False (call <*> mkBranch lretry) code + heapCheck False checkYield (call <*> mkBranch lretry) code cannedGCEntryPoint :: DynFlags -> [LocalReg] -> Maybe CmmExpr cannedGCEntryPoint dflags regs @@ -524,22 +533,23 @@ mkGcLabel :: String -> CmmExpr mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit s))) ------------------------------- -heapCheck :: Bool -> CmmAGraph -> FCode a -> FCode a -heapCheck checkStack do_gc code +heapCheck :: Bool -> Bool -> CmmAGraph -> FCode a -> FCode a +heapCheck checkStack checkYield do_gc code = getHeapUsage $ \ hpHw -> -- Emit heap checks, but be sure to do it lazily so -- that the conditionals on hpHw don't cause a black hole - do { codeOnly $ do_checks checkStack hpHw do_gc + do { codeOnly $ do_checks checkStack checkYield hpHw do_gc ; tickyAllocHeap hpHw ; doGranAllocate hpHw ; setRealHp hpHw ; code } do_checks :: Bool -- Should we check the stack? + -> Bool -- Should we check for preemption? -> WordOff -- Heap headroom -> CmmAGraph -- What to do on failure -> FCode () -do_checks checkStack alloc do_gc = do +do_checks checkStack checkYield alloc do_gc = do dflags <- getDynFlags let alloc_lit = mkIntExpr dflags (alloc * wORD_SIZE dflags) -- Bytes @@ -557,15 +567,22 @@ do_checks checkStack alloc do_gc = do hp_oflo = CmmMachOp (mo_wordUGt dflags) [CmmReg hpReg, CmmReg (CmmGlobal HpLim)] + -- Yielding if HpLim == 0 + yielding = CmmMachOp (mo_wordEq dflags) + [CmmReg (CmmGlobal HpLim), CmmLit (zeroCLit dflags)] + alloc_n = mkAssign (CmmGlobal HpAlloc) alloc_lit gc_id <- newLabelC when checkStack $ do emit =<< mkCmmIfGoto sp_oflo gc_id - when (alloc /= 0) $ do - emitAssign hpReg bump_hp - emit =<< mkCmmIfThen hp_oflo (alloc_n <*> mkBranch gc_id) + if (alloc /= 0) + then do + emitAssign hpReg bump_hp + emit =<< mkCmmIfThen hp_oflo (alloc_n <*> mkBranch gc_id) + else do + when (not (dopt Opt_OmitYields dflags) && checkYield) (emit =<< mkCmmIfGoto yielding gc_id) emitOutOfLine gc_id $ do_gc -- this is expected to jump back somewhere diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 69a0d1a0cf..75d8d1c38f 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -61,6 +61,7 @@ import Util import Data.List import Outputable import FastString +import Control.Monad ------------------------------------------------------------------------ -- Call and return sequences @@ -84,9 +85,11 @@ emitReturn results ; case sequel of Return _ -> do { adjustHpBackwards - ; emit (mkReturnSimple dflags results updfr_off) } + ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags) + ; emit (mkReturn dflags (entryCode dflags e) results updfr_off) + } AssignTo regs adjust -> - do { if adjust then adjustHpBackwards else return () + do { when adjust adjustHpBackwards ; emitMultiAssign regs results } ; return AssignedDirectly } diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index ba65a556b2..b666554403 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -31,8 +31,6 @@ module StgCmmProf ( ) where #include "HsVersions.h" -#include "../includes/dist-derivedconstants/header/DerivedConstants.h" - -- For REP_xxx constants, which are MachReps import StgCmmClosure import StgCmmUtils @@ -169,6 +167,7 @@ profAlloc :: CmmExpr -> CmmExpr -> FCode () profAlloc words ccs = ifProfiling $ do dflags <- getDynFlags + let alloc_rep = rEP_CostCentreStack_mem_alloc dflags emit (addToMemE alloc_rep (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags)) (CmmMachOp (MO_UU_Conv (wordWidth dflags) (typeWidth alloc_rep)) $ @@ -176,8 +175,6 @@ profAlloc words ccs mkIntExpr dflags (profHdrSize dflags)]])) -- subtract the "profiling overhead", which is the -- profiling header in a closure. - where - alloc_rep = REP_CostCentreStack_mem_alloc -- ----------------------------------------------------------------------- -- Setting the current cost centre on entry to a closure @@ -277,7 +274,7 @@ sizeof_ccs_words dflags | ms == 0 = ws | otherwise = ws + 1 where - (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE dflags + (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` wORD_SIZE dflags -- --------------------------------------------------------------------------- -- Set the current cost centre stack @@ -302,7 +299,7 @@ pushCostCentre result ccs cc bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph bumpSccCount dflags ccs - = addToMem REP_CostCentreStack_scc_count + = addToMem (rEP_CostCentreStack_scc_count dflags) (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1 ----------------------------------------------------------------------------- diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index d7517e8256..79ad3ff822 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -46,8 +46,6 @@ module StgCmmTicky ( ) where #include "HsVersions.h" -#include "../includes/dist-derivedconstants/header/DerivedConstants.h" - -- For REP_xxx constants, which are MachReps import StgCmmClosure import StgCmmUtils @@ -321,7 +319,7 @@ tickyAllocHeap hp if hp == 0 then [] -- Inside the emitMiddle to avoid control else [ -- dependency on the argument -- Bump the allcoation count in the StgEntCounter - addToMem REP_StgEntCounter_allocs + addToMem (rEP_StgEntCounter_allocs dflags) (CmmLit (cmmLabelOffB ticky_ctr (oFFSET_StgEntCounter_allocs dflags))) hp, -- Bump ALLOC_HEAP_ctr diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index f5dc2b6d31..386e7f46d6 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -37,9 +37,7 @@ module StgCmmUtils ( mkWordCLit, newStringCLit, newByteStringCLit, packHalfWordsCLit, - blankWord, - - srt_escape + blankWord ) where #include "HsVersions.h" @@ -719,6 +717,3 @@ assignTemp' e let reg = CmmLocal lreg emitAssign reg e return (CmmReg reg) - -srt_escape :: DynFlags -> StgHalfWord -srt_escape dflags = toStgHalfWord dflags (-1) diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index f07cccffe0..6d83150eb6 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -245,7 +245,6 @@ Library StgCmmTicky StgCmmUtils ClosureInfo - CodeGen SMRep CoreArity CoreFVs @@ -364,7 +363,6 @@ Library SimplMonad SimplUtils Simplify - SRT SimplStg StgStats UnariseStg diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index c0667b02d1..7ae46532c5 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -293,6 +293,7 @@ data DynFlag | Opt_IrrefutableTuples | Opt_CmmSink | Opt_CmmElimCommonBlocks + | Opt_OmitYields -- Interface files | Opt_IgnoreInterfacePragmas @@ -348,7 +349,6 @@ data DynFlag | Opt_RunCPSZ | Opt_AutoLinkPackages | Opt_ImplicitImportQualified - | Opt_TryNewCodeGen -- keeping stuff | Opt_KeepHiDiffs @@ -2268,7 +2268,6 @@ fFlags = [ ( "print-bind-contents", Opt_PrintBindContents, nop ), ( "run-cps", Opt_RunCPS, nop ), ( "run-cpsz", Opt_RunCPSZ, nop ), - ( "new-codegen", Opt_TryNewCodeGen, nop ), ( "vectorise", Opt_Vectorise, nop ), ( "avoid-vect", Opt_AvoidVect, nop ), ( "regs-graph", Opt_RegsGraph, nop ), @@ -2278,6 +2277,7 @@ fFlags = [ ( "irrefutable-tuples", Opt_IrrefutableTuples, nop ), ( "cmm-sink", Opt_CmmSink, nop ), ( "cmm-elim-common-blocks", Opt_CmmElimCommonBlocks, nop ), + ( "omit-yields", Opt_OmitYields, nop ), ( "gen-manifest", Opt_GenManifest, nop ), ( "embed-manifest", Opt_EmbedManifest, nop ), ( "ext-core", Opt_EmitExternalCore, nop ), @@ -2425,9 +2425,8 @@ xFlags = [ ( "MultiWayIf", Opt_MultiWayIf, nop ), ( "MonoLocalBinds", Opt_MonoLocalBinds, nop ), ( "RelaxedPolyRec", Opt_RelaxedPolyRec, - \ turn_on -> if not turn_on - then deprecate "You can't turn off RelaxedPolyRec any more" - else return () ), + \ turn_on -> unless turn_on + $ deprecate "You can't turn off RelaxedPolyRec any more" ), ( "ExtendedDefaultRules", Opt_ExtendedDefaultRules, nop ), ( "ImplicitParams", Opt_ImplicitParams, nop ), ( "ScopedTypeVariables", Opt_ScopedTypeVariables, nop ), @@ -2464,7 +2463,7 @@ defaultFlags platform Opt_SharedImplib, - Opt_TryNewCodeGen, + Opt_OmitYields, Opt_GenManifest, Opt_EmbedManifest, diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 6f9745dbfc..f04ca020e2 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -75,6 +75,7 @@ module HscMain ) where #ifdef GHCI +import Id import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) import Linker import CoreTidy ( tidyExpr ) @@ -90,7 +91,6 @@ import Panic import GHC.Exts #endif -import Id import Module import Packages import RdrName @@ -119,7 +119,6 @@ import ProfInit import TyCon import Name import SimplStg ( stg2stg ) -import CodeGen ( codeGen ) import qualified OldCmm as Old import qualified Cmm as New import CmmParse ( parseCmmFile ) @@ -136,7 +135,6 @@ import Fingerprint ( Fingerprint ) import DynFlags import ErrUtils -import UniqSupply ( mkSplitUniqSupply ) import Outputable import HscStats ( ppSourceStats ) @@ -144,7 +142,7 @@ import HscTypes import MkExternalCore ( emitExternalCore ) import FastString import UniqFM ( emptyUFM ) -import UniqSupply ( initUs_ ) +import UniqSupply import Bag import Exception import qualified Stream @@ -1285,16 +1283,10 @@ hscGenHardCode cgguts mod_summary = do ------------------ Code generation ------------------ - cmms <- if dopt Opt_TryNewCodeGen dflags - then {-# SCC "NewCodeGen" #-} + cmms <- {-# SCC "NewCodeGen" #-} tryNewCodeGen hsc_env this_mod data_tycons cost_centre_info stg_binds hpc_info - else {-# SCC "CodeGen" #-} - return (codeGen dflags this_mod data_tycons - cost_centre_info - stg_binds hpc_info) - ------------------ Code output ----------------------- rawcmms0 <- {-# SCC "cmmToRawCmm" #-} @@ -1370,7 +1362,7 @@ hscCompileCmmFile hsc_env filename = runHsc hsc_env $ do tryNewCodeGen :: HscEnv -> Module -> [TyCon] -> CollectedCCs - -> [(StgBinding,[(Id,[Id])])] + -> [StgBinding] -> HpcInfo -> IO (Stream IO Old.CmmGroup ()) -- Note we produce a 'Stream' of CmmGroups, so that the @@ -1399,17 +1391,33 @@ 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 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 - return (topSRT,cmmOfZgraph cmmgroup) - - let pipeline_stream = {-# SCC "cmmPipeline" #-} do - topSRT <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1 - Stream.yield (cmmOfZgraph (srtToData topSRT)) + -- When splitting, we generate one SRT per split chunk, otherwise + -- we generate one SRT for the whole module. + let + pipeline_stream + | dopt Opt_SplitObjs dflags + = {-# SCC "cmmPipeline" #-} + let run_pipeline us cmmgroup = do + let (topSRT', us') = initUs us emptySRT + (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT' cmmgroup + let srt | isEmptySRT topSRT = [] + | otherwise = srtToData topSRT + return (us',cmmOfZgraph (srt ++ cmmgroup)) + + in do _ <- Stream.mapAccumL run_pipeline us ppr_stream1 + return () + + | otherwise + = {-# SCC "cmmPipeline" #-} + let initTopSRT = initUs_ us emptySRT in + + let run_pipeline topSRT cmmgroup = do + (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT cmmgroup + return (topSRT,cmmOfZgraph cmmgroup) + + in do topSRT <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1 + Stream.yield (cmmOfZgraph (srtToData topSRT)) let dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" $ ppr a @@ -1422,7 +1430,7 @@ tryNewCodeGen hsc_env this_mod data_tycons myCoreToStg :: DynFlags -> Module -> CoreProgram - -> IO ( [(StgBinding,[(Id,[Id])])] -- output program + -> IO ( [StgBinding] -- output program , CollectedCCs) -- cost centre info (declared and used) myCoreToStg dflags this_mod prepd_binds = do stg_binds diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 8c608f1bf1..47fd96c426 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -51,7 +51,7 @@ import NCGMonad import BlockId import CgUtils ( fixStgRegisters ) import OldCmm -import CmmOpt ( cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold ) +import CmmOpt ( cmmMachOpFold ) import OldPprCmm import CLabel @@ -133,16 +133,17 @@ The machine-dependent bits break down as follows: data NcgImpl statics instr jumpDest = NcgImpl { cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl statics instr], - generateJumpTableForInstr :: DynFlags -> instr -> Maybe (NatCmmDecl statics instr), + generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr), getJumpDestBlockId :: jumpDest -> Maybe BlockId, canShortcut :: instr -> Maybe jumpDest, shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics, shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr, pprNatCmmDecl :: NatCmmDecl statics instr -> SDoc, - maxSpillSlots :: DynFlags -> Int, - allocatableRegs :: Platform -> [RealReg], + maxSpillSlots :: Int, + allocatableRegs :: [RealReg], ncg_x86fp_kludge :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr], ncgExpandTop :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr], + ncgAllocMoreStack :: Int -> NatCmmDecl statics instr -> NatCmmDecl statics instr, ncgMakeFarBranches :: [NatBasicBlock instr] -> [NatBasicBlock instr] } @@ -154,15 +155,16 @@ nativeCodeGen dflags h us cmms nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms x86NcgImpl = NcgImpl { cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen - ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr + ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr dflags ,getJumpDestBlockId = X86.Instr.getJumpDestBlockId ,canShortcut = X86.Instr.canShortcut ,shortcutStatics = X86.Instr.shortcutStatics ,shortcutJump = X86.Instr.shortcutJump ,pprNatCmmDecl = X86.Ppr.pprNatCmmDecl - ,maxSpillSlots = X86.Instr.maxSpillSlots - ,allocatableRegs = X86.Regs.allocatableRegs + ,maxSpillSlots = X86.Instr.maxSpillSlots dflags + ,allocatableRegs = X86.Regs.allocatableRegs platform ,ncg_x86fp_kludge = id + ,ncgAllocMoreStack = X86.Instr.allocMoreStack platform ,ncgExpandTop = id ,ncgMakeFarBranches = id } @@ -172,30 +174,32 @@ nativeCodeGen dflags h us cmms ArchPPC -> nCG' $ NcgImpl { cmmTopCodeGen = PPC.CodeGen.cmmTopCodeGen - ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr + ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr dflags ,getJumpDestBlockId = PPC.RegInfo.getJumpDestBlockId ,canShortcut = PPC.RegInfo.canShortcut ,shortcutStatics = PPC.RegInfo.shortcutStatics ,shortcutJump = PPC.RegInfo.shortcutJump ,pprNatCmmDecl = PPC.Ppr.pprNatCmmDecl - ,maxSpillSlots = PPC.Instr.maxSpillSlots - ,allocatableRegs = PPC.Regs.allocatableRegs + ,maxSpillSlots = PPC.Instr.maxSpillSlots dflags + ,allocatableRegs = PPC.Regs.allocatableRegs platform ,ncg_x86fp_kludge = id + ,ncgAllocMoreStack = noAllocMoreStack ,ncgExpandTop = id ,ncgMakeFarBranches = makeFarBranches } ArchSPARC -> nCG' $ NcgImpl { cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen - ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr + ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr dflags ,getJumpDestBlockId = SPARC.ShortcutJump.getJumpDestBlockId ,canShortcut = SPARC.ShortcutJump.canShortcut ,shortcutStatics = SPARC.ShortcutJump.shortcutStatics ,shortcutJump = SPARC.ShortcutJump.shortcutJump ,pprNatCmmDecl = SPARC.Ppr.pprNatCmmDecl - ,maxSpillSlots = SPARC.Instr.maxSpillSlots - ,allocatableRegs = \_ -> SPARC.Regs.allocatableRegs + ,maxSpillSlots = SPARC.Instr.maxSpillSlots dflags + ,allocatableRegs = SPARC.Regs.allocatableRegs ,ncg_x86fp_kludge = id + ,ncgAllocMoreStack = noAllocMoreStack ,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop ,ncgMakeFarBranches = id } @@ -206,6 +210,23 @@ nativeCodeGen dflags h us cmms ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch" + +-- +-- Allocating more stack space for spilling is currently only +-- supported for the linear register allocator on x86/x86_64, the rest +-- default to the panic below. To support allocating extra stack on +-- more platforms provide a definition of ncgAllocMoreStack. +-- +noAllocMoreStack :: Int -> NatCmmDecl statics instr -> NatCmmDecl statics instr +noAllocMoreStack amount _ + = panic $ "Register allocator: out of stack slots (need " ++ show amount ++ ")\n" + ++ " If you are trying to compile SHA1.hs from the crypto library then this\n" + ++ " is a known limitation in the linear allocator.\n" + ++ "\n" + ++ " Try enabling the graph colouring allocator with -fregs-graph instead." + ++ " You can still file a bug report if you like.\n" + + nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags -> NcgImpl statics instr jumpDest @@ -419,7 +440,7 @@ cmmNativeGen dflags ncgImpl us cmm count = foldr (\r -> plusUFM_C unionUniqSets $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r)) emptyUFM - $ allocatableRegs ncgImpl platform + $ allocatableRegs ncgImpl -- do the graph coloring register allocation let ((alloced, regAllocStats), usAlloc) @@ -428,7 +449,7 @@ cmmNativeGen dflags ncgImpl us cmm count $ Color.regAlloc dflags alloc_regs - (mkUniqSet [0 .. maxSpillSlots ncgImpl dflags]) + (mkUniqSet [0 .. maxSpillSlots ncgImpl]) withLiveness -- dump out what happened during register allocation @@ -457,11 +478,20 @@ cmmNativeGen dflags ncgImpl us cmm count else do -- do linear register allocation + let reg_alloc proc = do + (alloced, maybe_more_stack, ra_stats) <- + Linear.regAlloc dflags proc + case maybe_more_stack of + Nothing -> return ( alloced, ra_stats ) + Just amount -> + return ( ncgAllocMoreStack ncgImpl amount alloced + , ra_stats ) + let ((alloced, regAllocStats), usAlloc) = {-# SCC "RegAlloc" #-} initUs usLive $ liftM unzip - $ mapM (Linear.regAlloc dflags) withLiveness + $ mapM reg_alloc withLiveness dumpIfSet_dyn dflags Opt_D_dump_asm_regalloc "Registers allocated" @@ -490,7 +520,7 @@ cmmNativeGen dflags ncgImpl us cmm count ---- generate jump tables let tabled = {-# SCC "generateJumpTables" #-} - generateJumpTables dflags ncgImpl kludged + generateJumpTables ncgImpl kludged ---- shortcut branches let shorted = @@ -711,12 +741,12 @@ makeFarBranches blocks -- Analyzes all native code and generates data sections for all jump -- table instructions. generateJumpTables - :: DynFlags -> NcgImpl statics instr jumpDest - -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr] -generateJumpTables dflags ncgImpl xs = concatMap f xs + :: NcgImpl statics instr jumpDest + -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr] +generateJumpTables ncgImpl xs = concatMap f xs where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs f p = [p] - g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl dflags) xs) + g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs) -- ----------------------------------------------------------------------------- -- Shortcut branches @@ -828,15 +858,13 @@ genMachCode dflags cmmTopCodeGen cmm_top Here we do: (a) Constant folding - (b) Simple inlining: a temporary which is assigned to and then - used, once, can be shorted. (c) Position independent code and dynamic linking (i) introduce the appropriate indirections and position independent refs (ii) compile a list of imported symbols (d) Some arch-specific optimizations -(a) and (b) will be moving to the new Hoopl pipeline, however, (c) and +(a) will be moving to the new Hoopl pipeline, however, (c) and (d) are only needed by the native backend and will continue to live here. @@ -851,14 +879,7 @@ Ideas for other things we could do (put these in Hoopl please!): cmmToCmm :: DynFlags -> RawCmmDecl -> (RawCmmDecl, [CLabel]) cmmToCmm _ top@(CmmData _ _) = (top, []) cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do - let reachable_blocks | dopt Opt_TryNewCodeGen dflags = blocks - | otherwise = cmmEliminateDeadBlocks blocks - -- The new codegen path has already eliminated unreachable blocks by now - - inlined_blocks | dopt Opt_TryNewCodeGen dflags = reachable_blocks - | otherwise = cmmMiniInline dflags reachable_blocks - - blocks' <- mapM cmmBlockConFold inlined_blocks + blocks' <- mapM cmmBlockConFold blocks return $ CmmProc info lbl (ListGraph blocks') newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #)) diff --git a/compiler/nativeGen/Instruction.hs b/compiler/nativeGen/Instruction.hs index 64ba32c6dc..86f5ae435d 100644 --- a/compiler/nativeGen/Instruction.hs +++ b/compiler/nativeGen/Instruction.hs @@ -163,3 +163,16 @@ class Instruction instr where -> [instr] + -- Subtract an amount from the C stack pointer + mkStackAllocInstr + :: Platform -- TODO: remove (needed by x86/x86_64 + -- because they share an Instr type) + -> Int + -> instr + + -- Add an amount to the C stack pointer + mkStackDeallocInstr + :: Platform -- TODO: remove (needed by x86/x86_64 + -- because they share an Instr type) + -> Int + -> instr diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs index 464a88a08b..1f5e809abb 100644 --- a/compiler/nativeGen/PPC/Instr.hs +++ b/compiler/nativeGen/PPC/Instr.hs @@ -64,6 +64,8 @@ instance Instruction Instr where mkRegRegMoveInstr _ = ppc_mkRegRegMoveInstr takeRegRegMoveInstr = ppc_takeRegRegMoveInstr mkJumpInstr = ppc_mkJumpInstr + mkStackAllocInstr = panic "no ppc_mkStackAllocInstr" + mkStackDeallocInstr = panic "no ppc_mkStackDeallocInstr" -- ----------------------------------------------------------------------------- diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs index 32970336ad..f85cdb7eff 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs @@ -1,23 +1,16 @@ -{-# OPTIONS -fno-warn-missing-signatures #-} --- | Carries interesting info for debugging / profiling of the --- graph coloring register allocator. -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details +-- | Carries interesting info for debugging / profiling of the +-- graph coloring register allocator. module RegAlloc.Graph.Stats ( - RegAllocStats (..), + RegAllocStats (..), - pprStats, - pprStatsSpills, - pprStatsLifetimes, - pprStatsConflict, - pprStatsLifeConflict, + pprStats, + pprStatsSpills, + pprStatsLifetimes, + pprStatsConflict, + pprStatsLifeConflict, - countSRMs, addSRM + countSRMs, addSRM ) where @@ -45,251 +38,260 @@ import Data.List data RegAllocStats statics instr - -- initial graph - = RegAllocStatsStart - { raLiveCmm :: [LiveCmmDecl statics instr] -- ^ initial code, with liveness - , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the initial, uncolored graph - , raSpillCosts :: SpillCostInfo } -- ^ information to help choose which regs to spill - - -- a spill stage - | RegAllocStatsSpill - { raCode :: [LiveCmmDecl statics instr] -- ^ the code we tried to allocate registers for - , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the partially colored graph - , raCoalesced :: UniqFM VirtualReg -- ^ the regs that were coaleced - , raSpillStats :: SpillStats -- ^ spiller stats - , raSpillCosts :: SpillCostInfo -- ^ number of instrs each reg lives for - , raSpilled :: [LiveCmmDecl statics instr] } -- ^ code with spill instructions added - - -- a successful coloring - | RegAllocStatsColored - { raCode :: [LiveCmmDecl statics instr] -- ^ the code we tried to allocate registers for - , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the uncolored graph - , raGraphColored :: Color.Graph VirtualReg RegClass RealReg -- ^ the coalesced and colored graph - , raCoalesced :: UniqFM VirtualReg -- ^ the regs that were coaleced - , raCodeCoalesced :: [LiveCmmDecl statics instr] -- ^ code with coalescings applied - , raPatched :: [LiveCmmDecl statics instr] -- ^ code with vregs replaced by hregs - , raSpillClean :: [LiveCmmDecl statics instr] -- ^ code with unneeded spill\/reloads cleaned out - , raFinal :: [NatCmmDecl statics instr] -- ^ final code - , raSRMs :: (Int, Int, Int) } -- ^ spill\/reload\/reg-reg moves present in this code + -- initial graph + = RegAllocStatsStart + { raLiveCmm :: [LiveCmmDecl statics instr] -- ^ initial code, with liveness + , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the initial, uncolored graph + , raSpillCosts :: SpillCostInfo } -- ^ information to help choose which regs to spill + + -- a spill stage + | RegAllocStatsSpill + { raCode :: [LiveCmmDecl statics instr] -- ^ the code we tried to allocate registers for + , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the partially colored graph + , raCoalesced :: UniqFM VirtualReg -- ^ the regs that were coaleced + , raSpillStats :: SpillStats -- ^ spiller stats + , raSpillCosts :: SpillCostInfo -- ^ number of instrs each reg lives for + , raSpilled :: [LiveCmmDecl statics instr] } -- ^ code with spill instructions added + + -- a successful coloring + | RegAllocStatsColored + { raCode :: [LiveCmmDecl statics instr] -- ^ the code we tried to allocate registers for + , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the uncolored graph + , raGraphColored :: Color.Graph VirtualReg RegClass RealReg -- ^ the coalesced and colored graph + , raCoalesced :: UniqFM VirtualReg -- ^ the regs that were coaleced + , raCodeCoalesced :: [LiveCmmDecl statics instr] -- ^ code with coalescings applied + , raPatched :: [LiveCmmDecl statics instr] -- ^ code with vregs replaced by hregs + , raSpillClean :: [LiveCmmDecl statics instr] -- ^ code with unneeded spill\/reloads cleaned out + , raFinal :: [NatCmmDecl statics instr] -- ^ final code + , raSRMs :: (Int, Int, Int) } -- ^ spill\/reload\/reg-reg moves present in this code instance (Outputable statics, Outputable instr) => Outputable (RegAllocStats statics instr) where ppr (s@RegAllocStatsStart{}) = sdocWithPlatform $ \platform -> - text "# Start" - $$ text "# Native code with liveness information." - $$ ppr (raLiveCmm s) - $$ text "" - $$ text "# Initial register conflict graph." - $$ Color.dotGraph - (targetRegDotColor platform) - (trivColorable platform - (targetVirtualRegSqueeze platform) - (targetRealRegSqueeze platform)) - (raGraph s) + text "# Start" + $$ text "# Native code with liveness information." + $$ ppr (raLiveCmm s) + $$ text "" + $$ text "# Initial register conflict graph." + $$ Color.dotGraph + (targetRegDotColor platform) + (trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) + (raGraph s) ppr (s@RegAllocStatsSpill{}) = - text "# Spill" + text "# Spill" - $$ text "# Code with liveness information." - $$ ppr (raCode s) - $$ text "" + $$ text "# Code with liveness information." + $$ ppr (raCode s) + $$ text "" - $$ (if (not $ isNullUFM $ raCoalesced s) - then text "# Registers coalesced." - $$ (vcat $ map ppr $ ufmToList $ raCoalesced s) - $$ text "" - else empty) + $$ (if (not $ isNullUFM $ raCoalesced s) + then text "# Registers coalesced." + $$ (vcat $ map ppr $ ufmToList $ raCoalesced s) + $$ text "" + else empty) - $$ text "# Spills inserted." - $$ ppr (raSpillStats s) - $$ text "" + $$ text "# Spills inserted." + $$ ppr (raSpillStats s) + $$ text "" - $$ text "# Code with spills inserted." - $$ ppr (raSpilled s) + $$ text "# Code with spills inserted." + $$ ppr (raSpilled s) ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) = sdocWithPlatform $ \platform -> - text "# Colored" - - $$ text "# Code with liveness information." - $$ ppr (raCode s) - $$ text "" - - $$ text "# Register conflict graph (colored)." - $$ Color.dotGraph - (targetRegDotColor platform) - (trivColorable platform - (targetVirtualRegSqueeze platform) - (targetRealRegSqueeze platform)) - (raGraphColored s) - $$ text "" - - $$ (if (not $ isNullUFM $ raCoalesced s) - then text "# Registers coalesced." - $$ (vcat $ map ppr $ ufmToList $ raCoalesced s) - $$ text "" - else empty) - - $$ text "# Native code after coalescings applied." - $$ ppr (raCodeCoalesced s) - $$ text "" - - $$ text "# Native code after register allocation." - $$ ppr (raPatched s) - $$ text "" - - $$ text "# Clean out unneeded spill/reloads." - $$ ppr (raSpillClean s) - $$ text "" - - $$ text "# Final code, after rewriting spill/rewrite pseudo instrs." - $$ ppr (raFinal s) - $$ text "" - $$ text "# Score:" - $$ (text "# spills inserted: " <> int spills) - $$ (text "# reloads inserted: " <> int reloads) - $$ (text "# reg-reg moves remaining: " <> int moves) - $$ text "" + text "# Colored" + + $$ text "# Code with liveness information." + $$ ppr (raCode s) + $$ text "" + + $$ text "# Register conflict graph (colored)." + $$ Color.dotGraph + (targetRegDotColor platform) + (trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) + (raGraphColored s) + $$ text "" + + $$ (if (not $ isNullUFM $ raCoalesced s) + then text "# Registers coalesced." + $$ (vcat $ map ppr $ ufmToList $ raCoalesced s) + $$ text "" + else empty) + + $$ text "# Native code after coalescings applied." + $$ ppr (raCodeCoalesced s) + $$ text "" + + $$ text "# Native code after register allocation." + $$ ppr (raPatched s) + $$ text "" + + $$ text "# Clean out unneeded spill/reloads." + $$ ppr (raSpillClean s) + $$ text "" + + $$ text "# Final code, after rewriting spill/rewrite pseudo instrs." + $$ ppr (raFinal s) + $$ text "" + $$ text "# Score:" + $$ (text "# spills inserted: " <> int spills) + $$ (text "# reloads inserted: " <> int reloads) + $$ (text "# reg-reg moves remaining: " <> int moves) + $$ text "" -- | Do all the different analysis on this list of RegAllocStats -pprStats - :: [RegAllocStats statics instr] - -> Color.Graph VirtualReg RegClass RealReg - -> SDoc - +pprStats + :: [RegAllocStats statics instr] + -> Color.Graph VirtualReg RegClass RealReg + -> SDoc + pprStats stats graph - = let outSpills = pprStatsSpills stats - outLife = pprStatsLifetimes stats - outConflict = pprStatsConflict stats - outScatter = pprStatsLifeConflict stats graph + = let outSpills = pprStatsSpills stats + outLife = pprStatsLifetimes stats + outConflict = pprStatsConflict stats + outScatter = pprStatsLifeConflict stats graph - in vcat [outSpills, outLife, outConflict, outScatter] + in vcat [outSpills, outLife, outConflict, outScatter] -- | Dump a table of how many spill loads \/ stores were inserted for each vreg. pprStatsSpills - :: [RegAllocStats statics instr] -> SDoc + :: [RegAllocStats statics instr] -> SDoc pprStatsSpills stats = let - finals = [ s | s@RegAllocStatsColored{} <- stats] + finals = [ s | s@RegAllocStatsColored{} <- stats] - -- sum up how many stores\/loads\/reg-reg-moves were left in the code - total = foldl' addSRM (0, 0, 0) - $ map raSRMs finals + -- sum up how many stores\/loads\/reg-reg-moves were left in the code + total = foldl' addSRM (0, 0, 0) + $ map raSRMs finals - in ( text "-- spills-added-total" - $$ text "-- (stores, loads, reg_reg_moves_remaining)" - $$ ppr total - $$ text "") + in ( text "-- spills-added-total" + $$ text "-- (stores, loads, reg_reg_moves_remaining)" + $$ ppr total + $$ text "") -- | Dump a table of how long vregs tend to live for in the initial code. pprStatsLifetimes - :: [RegAllocStats statics instr] -> SDoc + :: [RegAllocStats statics instr] -> SDoc pprStatsLifetimes stats - = let info = foldl' plusSpillCostInfo zeroSpillCostInfo - [ raSpillCosts s - | s@RegAllocStatsStart{} <- stats ] + = let info = foldl' plusSpillCostInfo zeroSpillCostInfo + [ raSpillCosts s + | s@RegAllocStatsStart{} <- stats ] - lifeBins = binLifetimeCount $ lifeMapFromSpillCostInfo info + lifeBins = binLifetimeCount $ lifeMapFromSpillCostInfo info - in ( text "-- vreg-population-lifetimes" - $$ text "-- (instruction_count, number_of_vregs_that_lived_that_long)" - $$ (vcat $ map ppr $ eltsUFM lifeBins) - $$ text "\n") + in ( text "-- vreg-population-lifetimes" + $$ text "-- (instruction_count, number_of_vregs_that_lived_that_long)" + $$ (vcat $ map ppr $ eltsUFM lifeBins) + $$ text "\n") binLifetimeCount :: UniqFM (VirtualReg, Int) -> UniqFM (Int, Int) binLifetimeCount fm - = let lifes = map (\l -> (l, (l, 1))) - $ map snd - $ eltsUFM fm + = let lifes = map (\l -> (l, (l, 1))) + $ map snd + $ eltsUFM fm - in addListToUFM_C - (\(l1, c1) (_, c2) -> (l1, c1 + c2)) - emptyUFM - lifes + in addListToUFM_C + (\(l1, c1) (_, c2) -> (l1, c1 + c2)) + emptyUFM + lifes -- | Dump a table of how many conflicts vregs tend to have in the initial code. pprStatsConflict - :: [RegAllocStats statics instr] -> SDoc + :: [RegAllocStats statics instr] -> SDoc pprStatsConflict stats - = let confMap = foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2))) - emptyUFM - $ map Color.slurpNodeConflictCount - [ raGraph s | s@RegAllocStatsStart{} <- stats ] + = let confMap = foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2))) + emptyUFM + $ map Color.slurpNodeConflictCount + [ raGraph s | s@RegAllocStatsStart{} <- stats ] - in ( text "-- vreg-conflicts" - $$ text "-- (conflict_count, number_of_vregs_that_had_that_many_conflicts)" - $$ (vcat $ map ppr $ eltsUFM confMap) - $$ text "\n") + in ( text "-- vreg-conflicts" + $$ text "-- (conflict_count, number_of_vregs_that_had_that_many_conflicts)" + $$ (vcat $ map ppr $ eltsUFM confMap) + $$ text "\n") -- | For every vreg, dump it's how many conflicts it has and its lifetime --- good for making a scatter plot. +-- good for making a scatter plot. pprStatsLifeConflict - :: [RegAllocStats statics instr] - -> Color.Graph VirtualReg RegClass RealReg -- ^ global register conflict graph - -> SDoc + :: [RegAllocStats statics instr] + -> Color.Graph VirtualReg RegClass RealReg -- ^ global register conflict graph + -> SDoc pprStatsLifeConflict stats graph - = let lifeMap = lifeMapFromSpillCostInfo - $ foldl' plusSpillCostInfo zeroSpillCostInfo - $ [ raSpillCosts s | s@RegAllocStatsStart{} <- stats ] - - scatter = map (\r -> let lifetime = case lookupUFM lifeMap r of - Just (_, l) -> l - Nothing -> 0 - Just node = Color.lookupNode graph r - in parens $ hcat $ punctuate (text ", ") - [ doubleQuotes $ ppr $ Color.nodeId node - , ppr $ sizeUniqSet (Color.nodeConflicts node) - , ppr $ lifetime ]) - $ map Color.nodeId - $ eltsUFM - $ Color.graphMap graph - - in ( text "-- vreg-conflict-lifetime" - $$ text "-- (vreg, vreg_conflicts, vreg_lifetime)" - $$ (vcat scatter) - $$ text "\n") + = let lifeMap = lifeMapFromSpillCostInfo + $ foldl' plusSpillCostInfo zeroSpillCostInfo + $ [ raSpillCosts s | s@RegAllocStatsStart{} <- stats ] + + scatter = map (\r -> let lifetime = case lookupUFM lifeMap r of + Just (_, l) -> l + Nothing -> 0 + Just node = Color.lookupNode graph r + in parens $ hcat $ punctuate (text ", ") + [ doubleQuotes $ ppr $ Color.nodeId node + , ppr $ sizeUniqSet (Color.nodeConflicts node) + , ppr $ lifetime ]) + $ map Color.nodeId + $ eltsUFM + $ Color.graphMap graph + + in ( text "-- vreg-conflict-lifetime" + $$ text "-- (vreg, vreg_conflicts, vreg_lifetime)" + $$ (vcat scatter) + $$ text "\n") -- | Count spill/reload/reg-reg moves. --- Lets us see how well the register allocator has done. -countSRMs - :: Instruction instr - => LiveCmmDecl statics instr -> (Int, Int, Int) +-- Lets us see how well the register allocator has done. +countSRMs + :: Instruction instr + => LiveCmmDecl statics instr -> (Int, Int, Int) countSRMs cmm - = execState (mapBlockTopM countSRM_block cmm) (0, 0, 0) + = execState (mapBlockTopM countSRM_block cmm) (0, 0, 0) +countSRM_block :: Instruction instr + => GenBasicBlock (LiveInstr instr) + -> State (Int, Int, Int) (GenBasicBlock (LiveInstr instr)) countSRM_block (BasicBlock i instrs) - = do instrs' <- mapM countSRM_instr instrs - return $ BasicBlock i instrs' + = do instrs' <- mapM countSRM_instr instrs + return $ BasicBlock i instrs' +countSRM_instr :: Instruction instr + => LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr) countSRM_instr li - | LiveInstr SPILL{} _ <- li - = do modify $ \(s, r, m) -> (s + 1, r, m) - return li - - | LiveInstr RELOAD{} _ <- li - = do modify $ \(s, r, m) -> (s, r + 1, m) - return li - - | LiveInstr instr _ <- li - , Just _ <- takeRegRegMoveInstr instr - = do modify $ \(s, r, m) -> (s, r, m + 1) - return li - - | otherwise - = return li + | LiveInstr SPILL{} _ <- li + = do modify $ \(s, r, m) -> (s + 1, r, m) + return li + + | LiveInstr RELOAD{} _ <- li + = do modify $ \(s, r, m) -> (s, r + 1, m) + return li + + | LiveInstr instr _ <- li + , Just _ <- takeRegRegMoveInstr instr + = do modify $ \(s, r, m) -> (s, r, m + 1) + return li + + | otherwise + = return li -- sigh.. +addSRM :: (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int) addSRM (s1, r1, m1) (s2, r2, m2) - = (s1+s2, r1+r2, m1+m2) + = let !s = s1 + s2 + !r = r1 + r2 + !m = m1 + m2 + in (s, r, m) diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index 3f92ed975b..a15bca07e7 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -139,22 +139,27 @@ regAlloc :: (Outputable instr, Instruction instr) => DynFlags -> LiveCmmDecl statics instr - -> UniqSM (NatCmmDecl statics instr, Maybe RegAllocStats) + -> UniqSM ( NatCmmDecl statics instr + , Maybe Int -- number of extra stack slots required, + -- beyond maxSpillSlots + , Maybe RegAllocStats) regAlloc _ (CmmData sec d) = return ( CmmData sec d + , Nothing , Nothing ) regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl []) = return ( CmmProc info lbl (ListGraph []) + , Nothing , Nothing ) regAlloc dflags (CmmProc static lbl sccs) | LiveInfo info (Just first_id) (Just block_live) _ <- static = do -- do register allocation on each component. - (final_blocks, stats) + (final_blocks, stats, stack_use) <- linearRegAlloc dflags first_id block_live sccs -- make sure the block that was first in the input list @@ -162,7 +167,15 @@ regAlloc dflags (CmmProc static lbl sccs) let ((first':_), rest') = partition ((== first_id) . blockId) final_blocks + let max_spill_slots = maxSpillSlots dflags + extra_stack + | stack_use > max_spill_slots + = Just (stack_use - max_spill_slots) + | otherwise + = Nothing + return ( CmmProc info lbl (ListGraph (first' : rest')) + , extra_stack , Just stats) -- bogus. to make non-exhaustive match warning go away. @@ -184,7 +197,7 @@ linearRegAlloc -> BlockId -- ^ the first block -> BlockMap RegSet -- ^ live regs on entry to each basic block -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" - -> UniqSM ([NatBasicBlock instr], RegAllocStats) + -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int) linearRegAlloc dflags first_id block_live sccs = let platform = targetPlatform dflags @@ -204,14 +217,14 @@ linearRegAlloc' -> BlockId -- ^ the first block -> BlockMap RegSet -- ^ live regs on entry to each basic block -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" - -> UniqSM ([NatBasicBlock instr], RegAllocStats) + -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int) linearRegAlloc' dflags initFreeRegs first_id block_live sccs = do us <- getUs - let (_, _, stats, blocks) = + let (_, stack, stats, blocks) = runR dflags emptyBlockMap initFreeRegs emptyRegMap (emptyStackMap dflags) us $ linearRA_SCCs first_id block_live [] sccs - return (blocks, stats) + return (blocks, stats, getStackUse stack) linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr) diff --git a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs index b1fc3c169e..69cf411751 100644 --- a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs +++ b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs @@ -21,15 +21,13 @@ module RegAlloc.Linear.StackMap ( StackSlot, StackMap(..), emptyStackMap, - getStackSlotFor + getStackSlotFor, + getStackUse ) where -import RegAlloc.Linear.FreeRegs - import DynFlags -import Outputable import UniqFM import Unique @@ -40,7 +38,7 @@ type StackSlot = Int data StackMap = StackMap { -- | The slots that are still available to be allocated. - stackMapFreeSlots :: [StackSlot] + stackMapNextFreeSlot :: !Int -- | Assignment of vregs to stack slots. , stackMapAssignment :: UniqFM StackSlot } @@ -48,7 +46,7 @@ data StackMap -- | An empty stack map, with all slots available. emptyStackMap :: DynFlags -> StackMap -emptyStackMap dflags = StackMap [0 .. maxSpillSlots dflags] emptyUFM +emptyStackMap _ = StackMap 0 emptyUFM -- | If this vreg unique already has a stack assignment then return the slot number, @@ -56,24 +54,13 @@ emptyStackMap dflags = StackMap [0 .. maxSpillSlots dflags] emptyUFM -- getStackSlotFor :: StackMap -> Unique -> (StackMap, Int) -getStackSlotFor (StackMap [] _) _ - - -- This happens all the time when trying to compile darcs' SHA1.hs, see Track #1993 - -- SHA1.lhs has also been added to the Crypto library on Hackage, - -- so we see this all the time. - -- - -- It would be better to automatically invoke the graph allocator, or do something - -- else besides panicing, but that's a job for a different day. -- BL 2009/02 - -- - = panic $ "RegAllocLinear.getStackSlotFor: out of stack slots\n" - ++ " If you are trying to compile SHA1.hs from the crypto library then this\n" - ++ " is a known limitation in the linear allocator.\n" - ++ "\n" - ++ " Try enabling the graph colouring allocator with -fregs-graph instead." - ++ " You can still file a bug report if you like.\n" - -getStackSlotFor fs@(StackMap (freeSlot:stack') reserved) reg = - case lookupUFM reserved reg of - Just slot -> (fs, slot) - Nothing -> (StackMap stack' (addToUFM reserved reg freeSlot), freeSlot) +getStackSlotFor fs@(StackMap _ reserved) reg + | Just slot <- lookupUFM reserved reg = (fs, slot) + +getStackSlotFor (StackMap freeSlot reserved) reg = + (StackMap (freeSlot+1) (addToUFM reserved reg freeSlot), freeSlot) + +-- | Return the number of stack slots that were allocated +getStackUse :: StackMap -> Int +getStackUse (StackMap freeSlot _) = freeSlot diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index ac58944f1c..608f0a423b 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -5,8 +5,6 @@ -- (c) The University of Glasgow 2004 -- ----------------------------------------------------------------------------- -{-# OPTIONS -Wall -fno-warn-name-shadowing #-} - module RegAlloc.Liveness ( RegSet, RegMap, emptyRegMap, @@ -138,6 +136,11 @@ instance Instruction instr => Instruction (InstrSR instr) where mkJumpInstr target = map Instr (mkJumpInstr target) + mkStackAllocInstr platform amount = + Instr (mkStackAllocInstr platform amount) + + mkStackDeallocInstr platform amount = + Instr (mkStackDeallocInstr platform amount) -- | An instruction with liveness information. diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs index 9404badea6..f55c660118 100644 --- a/compiler/nativeGen/SPARC/Instr.hs +++ b/compiler/nativeGen/SPARC/Instr.hs @@ -108,6 +108,8 @@ instance Instruction Instr where mkRegRegMoveInstr = sparc_mkRegRegMoveInstr takeRegRegMoveInstr = sparc_takeRegRegMoveInstr mkJumpInstr = sparc_mkJumpInstr + mkStackAllocInstr = panic "no sparc_mkStackAllocInstr" + mkStackDeallocInstr = panic "no sparc_mkStackDeallocInstr" -- | SPARC instruction set. diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index b83ede89aa..fbbc37e6c9 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -1214,22 +1214,22 @@ getCondCode (CmmMachOp mop [x, y]) MO_F_Lt W64 -> condFltCode LTT x y MO_F_Le W64 -> condFltCode LE x y - MO_Eq _ -> condIntCode EQQ x y - MO_Ne _ -> condIntCode NE x y + MO_Eq _ -> condIntCode EQQ x y + MO_Ne _ -> condIntCode NE x y - MO_S_Gt _ -> condIntCode GTT x y - MO_S_Ge _ -> condIntCode GE x y - MO_S_Lt _ -> condIntCode LTT x y - MO_S_Le _ -> condIntCode LE x y + MO_S_Gt _ -> condIntCode GTT x y + MO_S_Ge _ -> condIntCode GE x y + MO_S_Lt _ -> condIntCode LTT x y + MO_S_Le _ -> condIntCode LE x y MO_U_Gt _ -> condIntCode GU x y MO_U_Ge _ -> condIntCode GEU x y MO_U_Lt _ -> condIntCode LU x y MO_U_Le _ -> condIntCode LEU x y - _other -> pprPanic "getCondCode(x86,x86_64,sparc)" (ppr (CmmMachOp mop [x,y])) + _other -> pprPanic "getCondCode(x86,x86_64)" (ppr (CmmMachOp mop [x,y])) -getCondCode other = pprPanic "getCondCode(2)(x86,sparc)" (ppr other) +getCondCode other = pprPanic "getCondCode(2)(x86,x86_64)" (ppr other) @@ -1276,7 +1276,8 @@ condIntCode' _ cond x (CmmLit (CmmInt 0 pk)) = do return (CondCode False cond code) -- anything vs operand -condIntCode' is32Bit cond x y | isOperand is32Bit y = do +condIntCode' is32Bit cond x y + | isOperand is32Bit y = do dflags <- getDynFlags (x_reg, x_code) <- getNonClobberedReg x (y_op, y_code) <- getOperand y @@ -1284,6 +1285,17 @@ condIntCode' is32Bit cond x y | isOperand is32Bit y = do code = x_code `appOL` y_code `snocOL` CMP (cmmTypeSize (cmmExprType dflags x)) y_op (OpReg x_reg) return (CondCode False cond code) +-- operand vs. anything: invert the comparison so that we can use a +-- single comparison instruction. + | isOperand is32Bit x + , Just revcond <- maybeFlipCond cond = do + dflags <- getDynFlags + (y_reg, y_code) <- getNonClobberedReg y + (x_op, x_code) <- getOperand x + let + code = y_code `appOL` x_code `snocOL` + CMP (cmmTypeSize (cmmExprType dflags x)) x_op (OpReg y_reg) + return (CondCode False revcond code) -- anything vs anything condIntCode' _ cond x y = do diff --git a/compiler/nativeGen/X86/Cond.hs b/compiler/nativeGen/X86/Cond.hs index ce97095222..586dabd8f4 100644 --- a/compiler/nativeGen/X86/Cond.hs +++ b/compiler/nativeGen/X86/Cond.hs @@ -1,39 +1,32 @@ - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module X86.Cond ( - Cond(..), - condUnsigned, - condToSigned, - condToUnsigned + Cond(..), + condUnsigned, + condToSigned, + condToUnsigned, + maybeFlipCond ) where data Cond - = ALWAYS -- What's really used? ToDo - | EQQ - | GE - | GEU - | GTT - | GU - | LE - | LEU - | LTT - | LU - | NE - | NEG - | POS - | CARRY - | OFLO - | PARITY - | NOTPARITY - deriving Eq + = ALWAYS -- What's really used? ToDo + | EQQ + | GE + | GEU + | GTT + | GU + | LE + | LEU + | LTT + | LU + | NE + | NEG + | POS + | CARRY + | OFLO + | PARITY + | NOTPARITY + deriving Eq condUnsigned :: Cond -> Bool condUnsigned GU = True @@ -57,3 +50,19 @@ condToUnsigned LTT = LU condToUnsigned GE = GEU condToUnsigned LE = LEU condToUnsigned x = x + +-- | @maybeFlipCond c@ returns @Just c'@ if it is possible to flip the +-- arguments to the conditional @c@, and the new condition should be @c'@. +maybeFlipCond :: Cond -> Maybe Cond +maybeFlipCond cond = case cond of + EQQ -> Just EQQ + NE -> Just NE + LU -> Just GU + GU -> Just LU + LEU -> Just GEU + GEU -> Just LEU + LTT -> Just GTT + GTT -> Just LTT + LE -> Just GE + GE -> Just LE + _other -> Nothing diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index 7f0e48e769..7bd9b0cc9e 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -11,7 +11,7 @@ module X86.Instr (Instr(..), Operand(..), getJumpDestBlockId, canShortcut, shortcutStatics, - shortcutJump, i386_insert_ffrees, + shortcutJump, i386_insert_ffrees, allocMoreStack, maxSpillSlots, archWordSize) where @@ -58,6 +58,8 @@ instance Instruction Instr where mkRegRegMoveInstr = x86_mkRegRegMoveInstr takeRegRegMoveInstr = x86_takeRegRegMoveInstr mkJumpInstr = x86_mkJumpInstr + mkStackAllocInstr = x86_mkStackAllocInstr + mkStackDeallocInstr = x86_mkStackDeallocInstr -- ----------------------------------------------------------------------------- @@ -620,14 +622,13 @@ x86_mkSpillInstr -> Instr x86_mkSpillInstr dflags reg delta slot - = let off = spillSlotToOffset dflags slot + = let off = spillSlotToOffset dflags slot - delta in - let off_w = (off - delta) `div` (if is32Bit then 4 else 8) - in case targetClassOfReg platform reg of + case targetClassOfReg platform reg of RcInteger -> MOV (archWordSize is32Bit) - (OpReg reg) (OpAddr (spRel dflags off_w)) - RcDouble -> GST FF80 reg (spRel dflags off_w) {- RcFloat/RcDouble -} - RcDoubleSSE -> MOV FF64 (OpReg reg) (OpAddr (spRel dflags off_w)) + (OpReg reg) (OpAddr (spRel dflags off)) + RcDouble -> GST FF80 reg (spRel dflags off) {- RcFloat/RcDouble -} + RcDoubleSSE -> MOV FF64 (OpReg reg) (OpAddr (spRel dflags off)) _ -> panic "X86.mkSpillInstr: no match" where platform = targetPlatform dflags is32Bit = target32Bit platform @@ -641,14 +642,13 @@ x86_mkLoadInstr -> Instr x86_mkLoadInstr dflags reg delta slot - = let off = spillSlotToOffset dflags slot + = let off = spillSlotToOffset dflags slot - delta in - let off_w = (off-delta) `div` (if is32Bit then 4 else 8) - in case targetClassOfReg platform reg of + case targetClassOfReg platform reg of RcInteger -> MOV (archWordSize is32Bit) - (OpAddr (spRel dflags off_w)) (OpReg reg) - RcDouble -> GLD FF80 (spRel dflags off_w) reg {- RcFloat/RcDouble -} - RcDoubleSSE -> MOV FF64 (OpAddr (spRel dflags off_w)) (OpReg reg) + (OpAddr (spRel dflags off)) (OpReg reg) + RcDouble -> GLD FF80 (spRel dflags off) reg {- RcFloat/RcDouble -} + RcDoubleSSE -> MOV FF64 (OpAddr (spRel dflags off)) (OpReg reg) _ -> panic "X86.x86_mkLoadInstr" where platform = targetPlatform dflags is32Bit = target32Bit platform @@ -666,12 +666,7 @@ maxSpillSlots dflags -- the C stack pointer. spillSlotToOffset :: DynFlags -> Int -> Int spillSlotToOffset dflags slot - | slot >= 0 && slot < maxSpillSlots dflags = 64 + spillSlotSize dflags * slot - | otherwise - = pprPanic "spillSlotToOffset:" - ( text "invalid spill location: " <> int slot - $$ text "maxSpillSlots: " <> int (maxSpillSlots dflags)) -------------------------------------------------------------------------------- @@ -744,8 +739,25 @@ x86_mkJumpInstr id = [JXX ALWAYS id] - - +x86_mkStackAllocInstr + :: Platform + -> Int + -> Instr +x86_mkStackAllocInstr platform amount + = case platformArch platform of + ArchX86 -> SUB II32 (OpImm (ImmInt amount)) (OpReg esp) + ArchX86_64 -> SUB II64 (OpImm (ImmInt amount)) (OpReg rsp) + _ -> panic "x86_mkStackAllocInstr" + +x86_mkStackDeallocInstr + :: Platform + -> Int + -> Instr +x86_mkStackDeallocInstr platform amount + = case platformArch platform of + ArchX86 -> ADD II32 (OpImm (ImmInt amount)) (OpReg esp) + ArchX86_64 -> ADD II64 (OpImm (ImmInt amount)) (OpReg rsp) + _ -> panic "x86_mkStackDeallocInstr" i386_insert_ffrees :: [GenBasicBlock Instr] @@ -753,18 +765,12 @@ i386_insert_ffrees i386_insert_ffrees blocks | or (map (any is_G_instr) [ instrs | BasicBlock _ instrs <- blocks ]) - = map ffree_before_nonlocal_transfers blocks - + = map insertGFREEs blocks | otherwise = blocks - where - ffree_before_nonlocal_transfers (BasicBlock id insns) - = BasicBlock id (foldr p [] insns) - where p insn r = case insn of - CALL _ _ -> GFREE : insn : r - JMP _ _ -> GFREE : insn : r - JXX_GBL _ _ -> panic "i386_insert_ffrees: cannot handle JXX_GBL" - _ -> insn : r + where + insertGFREEs (BasicBlock id insns) + = BasicBlock id (insertBeforeNonlocalTransfers GFREE insns) -- if you ever add a new FP insn to the fake x86 FP insn set, -- you must update this too @@ -796,6 +802,57 @@ is_G_instr instr _ -> False +-- +-- Note [extra spill slots] +-- +-- If the register allocator used more spill slots than we have +-- pre-allocated (rESERVED_C_STACK_BYTES), then we must allocate more +-- C stack space on entry and exit from this proc. Therefore we +-- insert a "sub $N, %rsp" at every entry point, and an "add $N, %rsp" +-- before every non-local jump. +-- +-- This became necessary when the new codegen started bundling entire +-- functions together into one proc, because the register allocator +-- assigns a different stack slot to each virtual reg within a proc. +-- To avoid using so many slots we could also: +-- +-- - split up the proc into connected components before code generator +-- +-- - rename the virtual regs, so that we re-use vreg names and hence +-- stack slots for non-overlapping vregs. +-- +allocMoreStack + :: Platform + -> Int + -> NatCmmDecl statics X86.Instr.Instr + -> NatCmmDecl statics X86.Instr.Instr + +allocMoreStack _ _ top@(CmmData _ _) = top +allocMoreStack platform amount (CmmProc info lbl (ListGraph code)) = + CmmProc info lbl (ListGraph (map insert_stack_insns code)) + where + alloc = mkStackAllocInstr platform amount + dealloc = mkStackDeallocInstr platform amount + + is_entry_point id = id `mapMember` info + + insert_stack_insns (BasicBlock id insns) + | is_entry_point id = BasicBlock id (alloc : block') + | otherwise = BasicBlock id block' + where + block' = insertBeforeNonlocalTransfers dealloc insns + + +insertBeforeNonlocalTransfers :: Instr -> [Instr] -> [Instr] +insertBeforeNonlocalTransfers insert insns + = foldr p [] insns + where p insn r = case insn of + CALL _ _ -> insert : insn : r + JMP _ _ -> insert : insn : r + JXX_GBL _ _ -> panic "insertBeforeNonlocalTransfers: cannot handle JXX_GBL" + _ -> insn : r + + data JumpDest = DestBlockId BlockId | DestImm Imm getJumpDestBlockId :: JumpDest -> Maybe BlockId diff --git a/compiler/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs index 4eec96f5e1..6b2fe16855 100644 --- a/compiler/nativeGen/X86/Regs.hs +++ b/compiler/nativeGen/X86/Regs.hs @@ -196,13 +196,13 @@ addrModeRegs _ = [] spRel :: DynFlags - -> Int -- ^ desired stack offset in words, positive or negative + -> Int -- ^ desired stack offset in bytes, positive or negative -> AddrMode spRel dflags n | target32Bit (targetPlatform dflags) - = AddrBaseIndex (EABaseReg esp) EAIndexNone (ImmInt (n * wORD_SIZE dflags)) + = AddrBaseIndex (EABaseReg esp) EAIndexNone (ImmInt n) | otherwise - = AddrBaseIndex (EABaseReg rsp) EAIndexNone (ImmInt (n * wORD_SIZE dflags)) + = AddrBaseIndex (EABaseReg rsp) EAIndexNone (ImmInt n) -- The register numbers must fit into 32 bits on x86, so that we can -- use a Word32 to represent the set of free registers in the register diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 91f00ecf2f..aaa4f054ba 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -1869,8 +1869,6 @@ explicitNamespacesBit :: Int explicitNamespacesBit = 29 lambdaCaseBit :: Int lambdaCaseBit = 30 -multiWayIfBit :: Int -multiWayIfBit = 31 always :: Int -> Bool @@ -1926,8 +1924,6 @@ explicitNamespacesEnabled :: Int -> Bool explicitNamespacesEnabled flags = testBit flags explicitNamespacesBit lambdaCaseEnabled :: Int -> Bool lambdaCaseEnabled flags = testBit flags lambdaCaseBit -multiWayIfEnabled :: Int -> Bool -multiWayIfEnabled flags = testBit flags multiWayIfBit -- PState for parsing options pragmas -- @@ -1991,7 +1987,6 @@ mkPState flags buf loc = .|. typeLiteralsBit `setBitIf` xopt Opt_DataKinds flags .|. explicitNamespacesBit `setBitIf` xopt Opt_ExplicitNamespaces flags .|. lambdaCaseBit `setBitIf` xopt Opt_LambdaCase flags - .|. multiWayIfBit `setBitIf` xopt Opt_MultiWayIf flags -- setBitIf :: Int -> Bool -> Int b `setBitIf` cond | cond = bit b diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index 3f1236599a..aa4156bfdb 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -385,37 +385,38 @@ litEq is_eq = msum -- minBound, so we can replace such comparison with False. boundsCmp :: Comparison -> RuleM CoreExpr boundsCmp op = do + dflags <- getDynFlags [a, b] <- getArgs - liftMaybe $ mkRuleFn op a b + liftMaybe $ mkRuleFn dflags op a b data Comparison = Gt | Ge | Lt | Le -mkRuleFn :: Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr -mkRuleFn Gt (Lit lit) _ | isMinBound lit = Just falseVal -mkRuleFn Le (Lit lit) _ | isMinBound lit = Just trueVal -mkRuleFn Ge _ (Lit lit) | isMinBound lit = Just trueVal -mkRuleFn Lt _ (Lit lit) | isMinBound lit = Just falseVal -mkRuleFn Ge (Lit lit) _ | isMaxBound lit = Just trueVal -mkRuleFn Lt (Lit lit) _ | isMaxBound lit = Just falseVal -mkRuleFn Gt _ (Lit lit) | isMaxBound lit = Just falseVal -mkRuleFn Le _ (Lit lit) | isMaxBound lit = Just trueVal -mkRuleFn _ _ _ = Nothing - -isMinBound :: Literal -> Bool -isMinBound (MachChar c) = c == minBound -isMinBound (MachInt i) = i == toInteger (minBound :: Int) -isMinBound (MachInt64 i) = i == toInteger (minBound :: Int64) -isMinBound (MachWord i) = i == toInteger (minBound :: Word) -isMinBound (MachWord64 i) = i == toInteger (minBound :: Word64) -isMinBound _ = False - -isMaxBound :: Literal -> Bool -isMaxBound (MachChar c) = c == maxBound -isMaxBound (MachInt i) = i == toInteger (maxBound :: Int) -isMaxBound (MachInt64 i) = i == toInteger (maxBound :: Int64) -isMaxBound (MachWord i) = i == toInteger (maxBound :: Word) -isMaxBound (MachWord64 i) = i == toInteger (maxBound :: Word64) -isMaxBound _ = False +mkRuleFn :: DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr +mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just falseVal +mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just trueVal +mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just trueVal +mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just falseVal +mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just trueVal +mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just falseVal +mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just falseVal +mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just trueVal +mkRuleFn _ _ _ _ = Nothing + +isMinBound :: DynFlags -> Literal -> Bool +isMinBound _ (MachChar c) = c == minBound +isMinBound dflags (MachInt i) = i == tARGET_MIN_INT dflags +isMinBound _ (MachInt64 i) = i == toInteger (minBound :: Int64) +isMinBound _ (MachWord i) = i == 0 +isMinBound _ (MachWord64 i) = i == 0 +isMinBound _ _ = False + +isMaxBound :: DynFlags -> Literal -> Bool +isMaxBound _ (MachChar c) = c == maxBound +isMaxBound dflags (MachInt i) = i == tARGET_MAX_INT dflags +isMaxBound _ (MachInt64 i) = i == toInteger (maxBound :: Int64) +isMaxBound dflags (MachWord i) = i == tARGET_MAX_WORD dflags +isMaxBound _ (MachWord64 i) = i == toInteger (maxBound :: Word64) +isMaxBound _ _ = False -- Note that we *don't* warn the user about overflow. It's not done at diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index c3fd407ff9..c232a89cd1 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -290,7 +290,11 @@ lookupInstDeclBndr cls what rdr -- In an instance decl you aren't allowed -- to use a qualified name for the method -- (Although it'd make perfect sense.) - ; lookupSubBndrOcc (ParentIs cls) doc rdr } + ; lookupSubBndrOcc False -- False => we don't give deprecated + -- warnings when a deprecated class + -- method is defined. We only warn + -- when it's used + (ParentIs cls) doc rdr } where doc = what <+> ptext (sLit "of class") <+> quotes (ppr cls) @@ -337,11 +341,12 @@ lookupConstructorFields con_name -- unambiguous because there is only one field id 'fld' in scope. -- But currently it's rejected. -lookupSubBndrOcc :: Parent -- NoParent => just look it up as usual +lookupSubBndrOcc :: Bool + -> Parent -- NoParent => just look it up as usual -- ParentIs p => use p to disambiguate -> SDoc -> RdrName -> RnM Name -lookupSubBndrOcc parent doc rdr_name +lookupSubBndrOcc warnIfDeprec parent doc rdr_name | Just n <- isExact_maybe rdr_name -- This happens in derived code = lookupExactOcc n @@ -355,7 +360,7 @@ lookupSubBndrOcc parent doc rdr_name -- NB: lookupGlobalRdrEnv, not lookupGRE_RdrName! -- The latter does pickGREs, but we want to allow 'x' -- even if only 'M.x' is in scope - [gre] -> do { addUsedRdrName gre (used_rdr_name gre) + [gre] -> do { addUsedRdrName warnIfDeprec gre (used_rdr_name gre) -- Add a usage; this is an *occurrence* site ; return (gre_name gre) } [] -> do { addErr (unknownSubordinateErr doc rdr_name) @@ -690,7 +695,7 @@ lookupGreRn_help rdr_name lookup = do { env <- getGlobalRdrEnv ; case lookup env of [] -> return Nothing - [gre] -> do { addUsedRdrName gre rdr_name + [gre] -> do { addUsedRdrName True gre rdr_name ; return (Just gre) } gres -> do { addNameClashErrRn rdr_name gres ; return (Just (head gres)) } } @@ -719,13 +724,13 @@ Note [Handling of deprecations] - the things exported by a module export 'module M' \begin{code} -addUsedRdrName :: GlobalRdrElt -> RdrName -> RnM () +addUsedRdrName :: Bool -> GlobalRdrElt -> RdrName -> RnM () -- Record usage of imported RdrNames -addUsedRdrName gre rdr +addUsedRdrName warnIfDeprec gre rdr | isLocalGRE gre = return () -- No call to warnIfDeprecated -- See Note [Handling of deprecations] | otherwise = do { env <- getGblEnv - ; warnIfDeprecated gre + ; when warnIfDeprec $ warnIfDeprecated gre ; updMutVar (tcg_used_rdrnames env) (\s -> Set.insert rdr s) } diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index e37860abb7..57f75fb50d 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -483,7 +483,7 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot } rn_fld pun_ok parent (HsRecField { hsRecFieldId = fld , hsRecFieldArg = arg , hsRecPun = pun }) - = do { fld'@(L loc fld_nm) <- wrapLocM (lookupSubBndrOcc parent doc) fld + = do { fld'@(L loc fld_nm) <- wrapLocM (lookupSubBndrOcc True parent doc) fld ; arg' <- if pun then do { checkErr pun_ok (badPun fld) ; return (L loc (mk_arg (mkRdrUnqual (nameOccName fld_nm)))) } diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 595f4653d3..e6abf7bd41 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -4,15 +4,8 @@ \section[RnSource]{Main pass of renamer} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module RnSource ( - rnSrcDecls, addTcgDUs, rnTyClDecls, findSplice +module RnSource ( + rnSrcDecls, addTcgDUs, rnTyClDecls, findSplice ) where #include "HsVersions.h" @@ -20,10 +13,10 @@ module RnSource ( import {-# SOURCE #-} RnExpr( rnLExpr ) #ifdef GHCI import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl ) -#endif /* GHCI */ +#endif /* GHCI */ import HsSyn -import RdrName +import RdrName import RnTypes import RnBinds import RnEnv @@ -31,10 +24,10 @@ import RnNames import RnHsDoc ( rnHsDoc, rnMbLHsDoc ) import TcRnMonad -import ForeignCall ( CCallTarget(..) ) +import ForeignCall ( CCallTarget(..) ) import Module -import HscTypes ( Warnings(..), plusWarns ) -import Class ( FunDep ) +import HscTypes ( Warnings(..), plusWarns ) +import Class ( FunDep ) import Name import NameSet import NameEnv @@ -45,9 +38,9 @@ import BasicTypes ( RuleName ) import FastString import SrcLoc import DynFlags -import HscTypes ( HscEnv, hsc_dflags ) +import HscTypes ( HscEnv, hsc_dflags ) import ListSetOps ( findDupsEq ) -import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices ) +import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices ) import Control.Monad import Data.List( partition ) @@ -65,7 +58,7 @@ for undefined tyvars, and tyvars in contexts that are ambiguous. since we don't have functional dependency information at this point.) \item Checks that all variable occurences are defined. -\item +\item Checks the @(..)@ etc constraints in the export list. \end{enumerate} @@ -142,7 +135,7 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls, traceRn (text "finish rnmono" <+> ppr rn_val_decls) ; -- (G) Rename Fixity and deprecations - + -- Rename fixity declarations and error if we try to -- fix something from another module (duplicates were checked in (A)) rn_fix_decls <- rnSrcFixityDecls all_bndrs fix_decls ; @@ -168,30 +161,30 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls, last_tcg_env <- getGblEnv ; -- (I) Compute the results and return - let {rn_group = HsGroup { hs_valds = rn_val_decls, - hs_tyclds = rn_tycl_decls, - hs_instds = rn_inst_decls, + let {rn_group = HsGroup { hs_valds = rn_val_decls, + hs_tyclds = rn_tycl_decls, + hs_instds = rn_inst_decls, hs_derivds = rn_deriv_decls, - hs_fixds = rn_fix_decls, - hs_warnds = [], -- warns are returned in the tcg_env - -- (see below) not in the HsGroup - hs_fords = rn_foreign_decls, - hs_annds = rn_ann_decls, - hs_defds = rn_default_decls, - hs_ruleds = rn_rule_decls, - hs_vects = rn_vect_decls, + hs_fixds = rn_fix_decls, + hs_warnds = [], -- warns are returned in the tcg_env + -- (see below) not in the HsGroup + hs_fords = rn_foreign_decls, + hs_annds = rn_ann_decls, + hs_defds = rn_default_decls, + hs_ruleds = rn_rule_decls, + hs_vects = rn_vect_decls, hs_docs = rn_docs } ; tycl_bndrs = hsTyClDeclsBinders rn_tycl_decls rn_inst_decls ; ford_bndrs = hsForeignDeclsBinders rn_foreign_decls ; - other_def = (Just (mkNameSet tycl_bndrs `unionNameSets` mkNameSet ford_bndrs), emptyNameSet) ; - other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, - src_fvs5, src_fvs6, src_fvs7, src_fvs8] ; - -- It is tiresome to gather the binders from type and class decls + other_def = (Just (mkNameSet tycl_bndrs `unionNameSets` mkNameSet ford_bndrs), emptyNameSet) ; + other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, + src_fvs5, src_fvs6, src_fvs7, src_fvs8] ; + -- It is tiresome to gather the binders from type and class decls - src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ; - -- Instance decls may have occurrences of things bound in bind_dus - -- so we must put other_fvs last + src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ; + -- Instance decls may have occurrences of things bound in bind_dus + -- so we must put other_fvs last final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus) in -- we return the deprecs in the env, not in the HsGroup above @@ -209,8 +202,8 @@ inNewEnv :: TcM TcGblEnv -> (TcGblEnv -> TcM a) -> TcM a inNewEnv env cont = do e <- env setGblEnv e $ cont e -addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv --- This function could be defined lower down in the module hierarchy, +addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv +-- This function could be defined lower down in the module hierarchy, -- but there doesn't seem anywhere very logical to put it. addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus } @@ -220,17 +213,17 @@ rnList f xs = mapFvRn (wrapLocFstM f) xs %********************************************************* -%* * - HsDoc stuff -%* * +%* * + HsDoc stuff +%* * %********************************************************* \begin{code} rnDocDecl :: DocDecl -> RnM DocDecl -rnDocDecl (DocCommentNext doc) = do +rnDocDecl (DocCommentNext doc) = do rn_doc <- rnHsDoc doc return (DocCommentNext rn_doc) -rnDocDecl (DocCommentPrev doc) = do +rnDocDecl (DocCommentPrev doc) = do rn_doc <- rnHsDoc doc return (DocCommentPrev rn_doc) rnDocDecl (DocCommentNamed str doc) = do @@ -243,9 +236,9 @@ rnDocDecl (DocGroup lev doc) = do %********************************************************* -%* * - Source-code fixity declarations -%* * +%* * + Source-code fixity declarations +%* * %********************************************************* \begin{code} @@ -260,14 +253,14 @@ rnSrcFixityDecls bndr_set fix_decls = do fix_decls <- mapM rn_decl fix_decls return (concat fix_decls) where - sig_ctxt = TopSigCtxt bndr_set True + sig_ctxt = TopSigCtxt bndr_set True -- True <=> can give fixity for class decls and record selectors rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name] - -- GHC extension: look up both the tycon and data con - -- for con-like things; hence returning a list - -- If neither are in scope, report an error; otherwise - -- return a fixity sig for each (slightly odd) + -- GHC extension: look up both the tycon and data con + -- for con-like things; hence returning a list + -- If neither are in scope, report an error; otherwise + -- return a fixity sig for each (slightly odd) rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity)) = setSrcSpan name_loc $ -- this lookup will fail if the definition isn't local @@ -279,9 +272,9 @@ rnSrcFixityDecls bndr_set fix_decls %********************************************************* -%* * - Source-code deprecations declarations -%* * +%* * + Source-code deprecations declarations +%* * %********************************************************* Check that the deprecated names are defined, are defined locally, and @@ -293,13 +286,13 @@ gather them together. \begin{code} -- checks that the deprecations are defined locally, and that there are no duplicates rnSrcWarnDecls :: NameSet -> [LWarnDecl RdrName] -> RnM Warnings -rnSrcWarnDecls _ [] +rnSrcWarnDecls _ [] = return NoWarnings -rnSrcWarnDecls bndr_set decls +rnSrcWarnDecls bndr_set decls = do { -- check for duplicates ; mapM_ (\ dups -> let (L loc rdr:lrdr':_) = dups - in addErrAt loc (dupWarnDecl lrdr' rdr)) + in addErrAt loc (dupWarnDecl lrdr' rdr)) warn_rdr_dups ; pairs_s <- mapM (addLocM rn_deprec) decls ; return (WarnSome ((concat pairs_s))) } @@ -311,7 +304,7 @@ rnSrcWarnDecls bndr_set decls -- ensures that the names are defined locally = do { names <- lookupLocalTcNames sig_ctxt what rdr_name ; return [(nameOccName name, txt) | name <- names] } - + what = ptext (sLit "deprecation") warn_rdr_dups = findDupRdrNames (map (\ (L loc (Warning rdr_name _)) -> L loc rdr_name) decls) @@ -322,7 +315,7 @@ findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc ( -- look for duplicates among the OccNames; -- we check that the names are defined above -- invt: the lists returned by findDupsEq always have at least two elements - + dupWarnDecl :: Located RdrName -> RdrName -> SDoc -- Located RdrName -> DeprecDecl RdrName -> SDoc dupWarnDecl (L loc _) rdr_name @@ -332,9 +325,9 @@ dupWarnDecl (L loc _) rdr_name \end{code} %********************************************************* -%* * +%* * \subsection{Annotation declarations} -%* * +%* * %********************************************************* \begin{code} @@ -351,9 +344,9 @@ rnAnnProvenance provenance = do \end{code} %********************************************************* -%* * +%* * \subsection{Default declarations} -%* * +%* * %********************************************************* \begin{code} @@ -366,9 +359,9 @@ rnDefaultDecl (DefaultDecl tys) \end{code} %********************************************************* -%* * +%* * \subsection{Foreign declarations} -%* * +%* * %********************************************************* \begin{code} @@ -380,7 +373,7 @@ rnHsForeignDecl (ForeignImport name ty _ spec) -- Mark any PackageTarget style imports as coming from the current package ; let packageId = thisPackage $ hsc_dflags topEnv - spec' = patchForeignImport packageId spec + spec' = patchForeignImport packageId spec ; return (ForeignImport name' ty' noForeignImportCoercionYet spec', fvs) } @@ -388,52 +381,50 @@ rnHsForeignDecl (ForeignExport name ty _ spec) = do { name' <- lookupLocatedOccRn name ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty ; return (ForeignExport name' ty' noForeignExportCoercionYet spec, fvs `addOneFV` unLoc name') } - -- NB: a foreign export is an *occurrence site* for name, so - -- we add it to the free-variable list. It might, for example, - -- be imported from another module + -- NB: a foreign export is an *occurrence site* for name, so + -- we add it to the free-variable list. It might, for example, + -- be imported from another module -- | For Windows DLLs we need to know what packages imported symbols are from --- to generate correct calls. Imported symbols are tagged with the current --- package, so if they get inlined across a package boundry we'll still --- know where they're from. +-- to generate correct calls. Imported symbols are tagged with the current +-- package, so if they get inlined across a package boundry we'll still +-- know where they're from. -- patchForeignImport :: PackageId -> ForeignImport -> ForeignImport patchForeignImport packageId (CImport cconv safety fs spec) - = CImport cconv safety fs (patchCImportSpec packageId spec) + = CImport cconv safety fs (patchCImportSpec packageId spec) patchCImportSpec :: PackageId -> CImportSpec -> CImportSpec patchCImportSpec packageId spec = case spec of - CFunction callTarget -> CFunction $ patchCCallTarget packageId callTarget - _ -> spec + CFunction callTarget -> CFunction $ patchCCallTarget packageId callTarget + _ -> spec patchCCallTarget :: PackageId -> CCallTarget -> CCallTarget -patchCCallTarget packageId callTarget - = case callTarget of - StaticTarget label Nothing isFun - -> StaticTarget label (Just packageId) isFun - - _ -> callTarget +patchCCallTarget packageId callTarget = + case callTarget of + StaticTarget label Nothing isFun -> StaticTarget label (Just packageId) isFun + _ -> callTarget \end{code} %********************************************************* -%* * +%* * \subsection{Instance declarations} -%* * +%* * %********************************************************* \begin{code} rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars) -rnSrcInstDecl (FamInstD { lid_inst = fi }) +rnSrcInstDecl (FamInstD { lid_inst = fi }) = do { (fi', fvs) <- rnFamInstDecl Nothing fi ; return (FamInstD { lid_inst = fi' }, fvs) } rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds , cid_sigs = uprags, cid_fam_insts = ats }) - -- Used for both source and interface file decls + -- Used for both source and interface file decls = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty ; case splitLHsInstDeclTy_maybe inst_ty' of { Nothing -> return (ClsInstD { cid_poly_ty = inst_ty', cid_binds = emptyLHsBinds @@ -447,48 +438,48 @@ rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds -- Rename the associated types, and type signatures -- Both need to have the instance type variables in scope ; traceRn (text "rnSrcInstDecl" <+> ppr inst_ty' $$ ppr inst_tyvars $$ ppr ktv_names) - ; ((ats', other_sigs'), more_fvs) + ; ((ats', other_sigs'), more_fvs) <- extendTyVarEnvFVRn ktv_names $ do { (ats', at_fvs) <- rnATInstDecls cls inst_tyvars ats ; (other_sigs', sig_fvs) <- renameSigs (InstDeclCtxt cls) other_sigs ; return ( (ats', other_sigs') , at_fvs `plusFV` sig_fvs) } - -- Rename the bindings - -- The typechecker (not the renamer) checks that all - -- the bindings are for the right class - -- (Slightly strangely) when scoped type variables are on, the + -- Rename the bindings + -- The typechecker (not the renamer) checks that all + -- the bindings are for the right class + -- (Slightly strangely) when scoped type variables are on, the -- forall-d tyvars scope over the method bindings too ; (mbinds', meth_fvs) <- extendTyVarEnvForMethodBinds ktv_names $ rnMethodBinds cls (mkSigTvFn other_sigs') - mbinds - - -- Rename the SPECIALISE instance pramas - -- Annoyingly the type variables are not in scope here, - -- so that instance Eq a => Eq (T a) where - -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-} - -- works OK. That's why we did the partition game above - -- + mbinds + + -- Rename the SPECIALISE instance pramas + -- Annoyingly the type variables are not in scope here, + -- so that instance Eq a => Eq (T a) where + -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-} + -- works OK. That's why we did the partition game above + -- ; (spec_inst_prags', spec_inst_fvs) - <- renameSigs (InstDeclCtxt cls) spec_inst_prags + <- renameSigs (InstDeclCtxt cls) spec_inst_prags ; let uprags' = spec_inst_prags' ++ other_sigs' all_fvs = meth_fvs `plusFV` more_fvs `plusFV` spec_inst_fvs - `plusFV` inst_fvs + `plusFV` inst_fvs ; return (ClsInstD { cid_poly_ty = inst_ty', cid_binds = mbinds' , cid_sigs = uprags', cid_fam_insts = ats' }, - all_fvs) } } } + all_fvs) } } } -- We return the renamed associated data type declarations so -- that they can be entered into the list of type declarations -- for the binding group, but we also keep a copy in the instance. -- The latter is needed for well-formedness checks in the type -- checker (eg, to ensure that all ATs of the instance actually - -- receive a declaration). - -- NB: Even the copies in the instance declaration carry copies of - -- the instance context after renaming. This is a bit - -- strange, but should not matter (and it would be more work - -- to remove the context). + -- receive a declaration). + -- NB: Even the copies in the instance declaration carry copies of + -- the instance context after renaming. This is a bit + -- strange, but should not matter (and it would be more work + -- to remove the context). rnFamInstDecl :: Maybe (Name, [Name]) -> FamInstDecl RdrName -> RnM (FamInstDecl Name, FreeVars) rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon @@ -505,15 +496,15 @@ rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon ; rdr_env <- getLocalRdrEnv ; kv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) kv_rdr_names ; tv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) tv_rdr_names - -- All the free vars of the family patterns + -- All the free vars of the family patterns -- with a sensible binding location - ; ((pats', defn'), fvs) - <- bindLocalNamesFV kv_names $ - bindLocalNamesFV tv_names $ - do { (pats', pat_fvs) <- rnLHsTypes (TyDataCtx tycon) pats - ; (defn', rhs_fvs) <- rnTyDefn tycon defn + ; ((pats', defn'), fvs) + <- bindLocalNamesFV kv_names $ + bindLocalNamesFV tv_names $ + do { (pats', pat_fvs) <- rnLHsTypes (TyDataCtx tycon) pats + ; (defn', rhs_fvs) <- rnTyDefn tycon defn - -- See Note [Renaming associated types] + -- See Note [Renaming associated types] ; let bad_tvs = case mb_cls of Nothing -> [] Just (_,cls_tvs) -> filter is_bad cls_tvs @@ -521,22 +512,22 @@ rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon ; unless (null bad_tvs) (badAssocRhs bad_tvs) ; return ((pats', defn'), rhs_fvs `plusFV` pat_fvs) } - + ; let all_fvs = fvs `addOneFV` unLoc tycon' ; return ( FamInstDecl { fid_tycon = tycon' , fid_pats = HsWB { hswb_cts = pats', hswb_kvs = kv_names, hswb_tvs = tv_names } , fid_defn = defn', fid_fvs = all_fvs } , all_fvs ) } - -- type instance => use, hence addOneFV + -- type instance => use, hence addOneFV \end{code} -Renaming of the associated types in instances. +Renaming of the associated types in instances. \begin{code} rnATDecls :: Name -- Class -> LHsTyVarBndrs Name - -> [LTyClDecl RdrName] + -> [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars) rnATDecls cls hs_tvs at_decls = rnList (rnTyClDecl (Just (cls, tv_ns))) at_decls @@ -547,12 +538,12 @@ rnATDecls cls hs_tvs at_decls rnATInstDecls :: Name -- Class -> LHsTyVarBndrs Name - -> [LFamInstDecl RdrName] + -> [LFamInstDecl RdrName] -> RnM ([LFamInstDecl Name], FreeVars) -- Used for the family declarations and defaults in a class decl -- and the family instance declarations in an instance --- --- NB: We allow duplicate associated-type decls; +-- +-- NB: We allow duplicate associated-type decls; -- See Note [Associated type instances] in TcInstDcls rnATInstDecls cls hs_tvs at_insts = rnList (rnFamInstDecl (Just (cls, tv_ns))) at_insts @@ -562,7 +553,7 @@ rnATInstDecls cls hs_tvs at_insts -- See Note [Renaming associated types] in RnTypes \end{code} -For the method bindings in class and instance decls, we extend the +For the method bindings in class and instance decls, we extend the type variable environment iff -fglasgow-exts \begin{code} @@ -570,17 +561,17 @@ extendTyVarEnvForMethodBinds :: [Name] -> RnM (Bag (LHsBind Name), FreeVars) -> RnM (Bag (LHsBind Name), FreeVars) extendTyVarEnvForMethodBinds ktv_names thing_inside - = do { scoped_tvs <- xoptM Opt_ScopedTypeVariables - ; if scoped_tvs then - extendTyVarEnvFVRn ktv_names thing_inside - else - thing_inside } + = do { scoped_tvs <- xoptM Opt_ScopedTypeVariables + ; if scoped_tvs then + extendTyVarEnvFVRn ktv_names thing_inside + else + thing_inside } \end{code} %********************************************************* -%* * +%* * \subsection{Stand-alone deriving declarations} -%* * +%* * %********************************************************* \begin{code} @@ -592,15 +583,15 @@ rnSrcDerivDecl (DerivDecl ty) ; return (DerivDecl ty', fvs) } standaloneDerivErr :: SDoc -standaloneDerivErr +standaloneDerivErr = hang (ptext (sLit "Illegal standalone deriving declaration")) 2 (ptext (sLit "Use -XStandaloneDeriving to enable this extension")) \end{code} %********************************************************* -%* * +%* * \subsection{Rules} -%* * +%* * %********************************************************* \begin{code} @@ -610,12 +601,12 @@ rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs) ; checkDupRdrNames rdr_names_w_loc ; checkShadowedRdrNames rdr_names_w_loc ; names <- newLocalBndrsRn rdr_names_w_loc - ; bindHsRuleVars rule_name vars names $ \ vars' -> + ; bindHsRuleVars rule_name vars names $ \ vars' -> do { (lhs', fv_lhs') <- rnLExpr lhs ; (rhs', fv_rhs') <- rnLExpr rhs ; checkValidRule rule_name names lhs' fv_lhs' ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs', - fv_lhs' `plusFV` fv_rhs') } } + fv_lhs' `plusFV` fv_rhs') } } where get_var (RuleBndrSig v _) = v get_var (RuleBndr v) = v @@ -646,7 +637,7 @@ Note [Rule LHS validity checking] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Check the shape of a transformation rule LHS. Currently we only allow LHSs of the form @(f e1 .. en)@, where @f@ is not one of the -@forall@'d variables. +@forall@'d variables. We used restrict the form of the 'ei' to prevent you writing rules with LHSs with a complicated desugaring (and hence unlikely to match); @@ -655,18 +646,18 @@ with LHSs with a complicated desugaring (and hence unlikely to match); But there are legitimate non-trivial args ei, like sections and lambdas. So it seems simmpler not to check at all, and that is why check_e is commented out. - + \begin{code} checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM () checkValidRule rule_name ids lhs' fv_lhs' - = do { -- Check for the form of the LHS - case (validRuleLhs ids lhs') of - Nothing -> return () - Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad) + = do { -- Check for the form of the LHS + case (validRuleLhs ids lhs') of + Nothing -> return () + Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad) - -- Check that LHS vars are all bound - ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')] - ; mapM_ (addErr . badRuleVar rule_name) bad_vars } + -- Check that LHS vars are all bound + ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')] + ; mapM_ (addErr . badRuleVar rule_name) bad_vars } validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name) -- Nothing => OK @@ -676,25 +667,25 @@ validRuleLhs foralls lhs where checkl (L _ e) = check e - check (OpApp e1 op _ e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2 - check (HsApp e1 e2) = checkl e1 `mplus` checkl_e e2 + check (OpApp e1 op _ e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2 + check (HsApp e1 e2) = checkl e1 `mplus` checkl_e e2 check (HsVar v) | v `notElem` foralls = Nothing - check other = Just other -- Failure + check other = Just other -- Failure - -- Check an argument - checkl_e (L _ _e) = Nothing -- Was (check_e e); see Note [Rule LHS validity checking] + -- Check an argument + checkl_e (L _ _e) = Nothing -- Was (check_e e); see Note [Rule LHS validity checking] -{- Commented out; see Note [Rule LHS validity checking] above +{- Commented out; see Note [Rule LHS validity checking] above check_e (HsVar v) = Nothing - check_e (HsPar e) = checkl_e e - check_e (HsLit e) = Nothing + check_e (HsPar e) = checkl_e e + check_e (HsLit e) = Nothing check_e (HsOverLit e) = Nothing - check_e (OpApp e1 op _ e2) = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2 - check_e (HsApp e1 e2) = checkl_e e1 `mplus` checkl_e e2 - check_e (NegApp e _) = checkl_e e - check_e (ExplicitList _ es) = checkl_es es - check_e other = Just other -- Fails + check_e (OpApp e1 op _ e2) = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2 + check_e (HsApp e1 e2) = checkl_e e1 `mplus` checkl_e e2 + check_e (NegApp e _) = checkl_e e + check_e (ExplicitList _ es) = checkl_es es + check_e other = Just other -- Fails checkl_es es = foldr (mplus . checkl_e) Nothing es -} @@ -702,14 +693,14 @@ validRuleLhs foralls lhs badRuleVar :: FastString -> Name -> SDoc badRuleVar name var = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon, - ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+> - ptext (sLit "does not appear on left hand side")] + ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+> + ptext (sLit "does not appear on left hand side")] badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc badRuleLhsErr name lhs bad_e = sep [ptext (sLit "Rule") <+> ftext name <> colon, - nest 4 (vcat [ptext (sLit "Illegal expression:") <+> ppr bad_e, - ptext (sLit "in left-hand side:") <+> ppr lhs])] + nest 4 (vcat [ptext (sLit "Illegal expression:") <+> ppr bad_e, + ptext (sLit "in left-hand side:") <+> ppr lhs])] $$ ptext (sLit "LHS must be of form (f e1 .. en) where f is not forall'd") \end{code} @@ -735,7 +726,7 @@ rnHsVectDecl (HsVect var (Just rhs@(L _ (HsVar _)))) ; return (HsVect var' (Just rhs'), fv_rhs `addOneFV` unLoc var') } rnHsVectDecl (HsVect _var (Just _rhs)) - = failWith $ vcat + = failWith $ vcat [ ptext (sLit "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma") , ptext (sLit "must be an identifier") ] @@ -796,7 +787,7 @@ Consider the following case: module A where import B data A1 = A1 B1 - + module B where import {-# SOURCE #-} A type DisguisedA1 = A1 @@ -849,19 +840,19 @@ rnTyClDecls extra_deps tycl_ds ; return (map flattenSCC sccs, all_fvs) } -rnTyClDecl :: Maybe (Name, [Name]) - -- Just (cls,tvs) => this TyClDecl is nested +rnTyClDecl :: Maybe (Name, [Name]) + -- Just (cls,tvs) => this TyClDecl is nested -- inside an *instance decl* for cls -- used for associated types - -> TyClDecl RdrName + -> TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars) rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name}) = do { name' <- lookupLocatedTopBndrRn name ; return (ForeignType {tcdLName = name', tcdExtName = ext_name}, - emptyFVs) } + emptyFVs) } -- All flavours of type family declarations ("type family", "newtype family", --- and "data family"), both top level and (for an associated type) +-- and "data family"), both top level and (for an associated type) -- in a class decl rnTyClDecl mb_cls (TyFamily { tcdLName = tycon, tcdTyVars = tyvars , tcdFlavour = flav, tcdKindSig = kind }) @@ -871,7 +862,7 @@ rnTyClDecl mb_cls (TyFamily { tcdLName = tycon, tcdTyVars = tyvars ; return ( TyFamily { tcdLName = tycon', tcdTyVars = tyvars' , tcdFlavour = flav, tcdKindSig = kind' } , fv_kind ) } - where + where fmly_doc = TyFamilyCtx tycon kvs = extractRdrKindSigVars kind @@ -887,110 +878,110 @@ rnTyClDecl mb_cls (TyDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdTyDefn = de ; return (TyDecl { tcdLName = tycon', tcdTyVars = tyvars' , tcdTyDefn = defn', tcdFVs = fvs }, fvs) } -rnTyClDecl mb_cls (ClassDecl {tcdCtxt = context, tcdLName = lcls, - tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, - tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs, +rnTyClDecl mb_cls (ClassDecl {tcdCtxt = context, tcdLName = lcls, + tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, + tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs}) - = do { lcls' <- lookupLocatedTopBndrRn lcls + = do { lcls' <- lookupLocatedTopBndrRn lcls ; let cls' = unLoc lcls' - kvs = [] -- No scoped kind vars except those in + kvs = [] -- No scoped kind vars except those in -- kind signatures on the tyvars - -- Tyvars scope over superclass context and method signatures - ; ((tyvars', context', fds', ats', at_defs', sigs'), stuff_fvs) - <- bindHsTyVars cls_doc mb_cls kvs tyvars $ \ tyvars' -> do - -- Checks for distinct tyvars - { (context', cxt_fvs) <- rnContext cls_doc context - ; fds' <- rnFds (docOfHsDocContext cls_doc) fds - -- The fundeps have no free variables + -- Tyvars scope over superclass context and method signatures + ; ((tyvars', context', fds', ats', at_defs', sigs'), stuff_fvs) + <- bindHsTyVars cls_doc mb_cls kvs tyvars $ \ tyvars' -> do + -- Checks for distinct tyvars + { (context', cxt_fvs) <- rnContext cls_doc context + ; fds' <- rnFds (docOfHsDocContext cls_doc) fds + -- The fundeps have no free variables ; (ats', fv_ats) <- rnATDecls cls' tyvars' ats ; (at_defs', fv_at_defs) <- rnATInstDecls cls' tyvars' at_defs - ; (sigs', sig_fvs) <- renameSigs (ClsDeclCtxt cls') sigs - ; let fvs = cxt_fvs `plusFV` - sig_fvs `plusFV` + ; (sigs', sig_fvs) <- renameSigs (ClsDeclCtxt cls') sigs + ; let fvs = cxt_fvs `plusFV` + sig_fvs `plusFV` fv_ats `plusFV` fv_at_defs - ; return ((tyvars', context', fds', ats', at_defs', sigs'), fvs) } - - -- No need to check for duplicate associated type decls - -- since that is done by RnNames.extendGlobalRdrEnvRn - - -- Check the signatures - -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). - ; let sig_rdr_names_w_locs = [op | L _ (TypeSig ops _) <- sigs, op <- ops] - ; checkDupRdrNames sig_rdr_names_w_locs - -- Typechecker is responsible for checking that we only - -- give default-method bindings for things in this class. - -- The renamer *could* check this for class decls, but can't - -- for instance decls. - - -- The newLocals call is tiresome: given a generic class decl - -- class C a where - -- op :: a -> a - -- op {| x+y |} (Inl a) = ... - -- op {| x+y |} (Inr b) = ... - -- op {| a*b |} (a*b) = ... - -- we want to name both "x" tyvars with the same unique, so that they are - -- easy to group together in the typechecker. - ; (mbinds', meth_fvs) - <- extendTyVarEnvForMethodBinds (hsLKiTyVarNames tyvars') $ - -- No need to check for duplicate method signatures - -- since that is done by RnNames.extendGlobalRdrEnvRn - -- and the methods are already in scope - rnMethodBinds cls' (mkSigTvFn sigs') mbinds - - -- Haddock docs - ; docs' <- mapM (wrapLocM rnDocDecl) docs + ; return ((tyvars', context', fds', ats', at_defs', sigs'), fvs) } + + -- No need to check for duplicate associated type decls + -- since that is done by RnNames.extendGlobalRdrEnvRn + + -- Check the signatures + -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). + ; let sig_rdr_names_w_locs = [op | L _ (TypeSig ops _) <- sigs, op <- ops] + ; checkDupRdrNames sig_rdr_names_w_locs + -- Typechecker is responsible for checking that we only + -- give default-method bindings for things in this class. + -- The renamer *could* check this for class decls, but can't + -- for instance decls. + + -- The newLocals call is tiresome: given a generic class decl + -- class C a where + -- op :: a -> a + -- op {| x+y |} (Inl a) = ... + -- op {| x+y |} (Inr b) = ... + -- op {| a*b |} (a*b) = ... + -- we want to name both "x" tyvars with the same unique, so that they are + -- easy to group together in the typechecker. + ; (mbinds', meth_fvs) + <- extendTyVarEnvForMethodBinds (hsLKiTyVarNames tyvars') $ + -- No need to check for duplicate method signatures + -- since that is done by RnNames.extendGlobalRdrEnvRn + -- and the methods are already in scope + rnMethodBinds cls' (mkSigTvFn sigs') mbinds + + -- Haddock docs + ; docs' <- mapM (wrapLocM rnDocDecl) docs ; let all_fvs = meth_fvs `plusFV` stuff_fvs - ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls', - tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs', - tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs', + ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls', + tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs', + tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs', tcdDocs = docs', tcdFVs = all_fvs }, - all_fvs ) } + all_fvs ) } where cls_doc = ClassDeclCtx lcls rnTyDefn :: Located RdrName -> HsTyDefn RdrName -> RnM (HsTyDefn Name, FreeVars) rnTyDefn tycon (TyData { td_ND = new_or_data, td_cType = cType - , td_ctxt = context, td_cons = condecls - , td_kindSig = sig, td_derivs = derivs }) - = do { checkTc (h98_style || null (unLoc context)) + , td_ctxt = context, td_cons = condecls + , td_kindSig = sig, td_derivs = derivs }) + = do { checkTc (h98_style || null (unLoc context)) (badGadtStupidTheta tycon) ; (sig', sig_fvs) <- rnLHsMaybeKind data_doc sig ; (context', fvs1) <- rnContext data_doc context ; (derivs', fvs3) <- rn_derivs derivs - -- For the constructor declarations, drop the LocalRdrEnv - -- in the GADT case, where the type variables in the declaration - -- do not scope over the constructor signatures - -- data T a where { T1 :: forall b. b-> b } + -- For the constructor declarations, drop the LocalRdrEnv + -- in the GADT case, where the type variables in the declaration + -- do not scope over the constructor signatures + -- data T a where { T1 :: forall b. b-> b } ; let { zap_lcl_env | h98_style = \ thing -> thing | otherwise = setLocalRdrEnv emptyLocalRdrEnv } - ; (condecls', con_fvs) <- zap_lcl_env $ + ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls -- No need to check for duplicate constructor decls - -- since that is done by RnNames.extendGlobalRdrEnvRn + -- since that is done by RnNames.extendGlobalRdrEnvRn ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV` con_fvs `plusFV` sig_fvs - ; return ( TyData { td_ND = new_or_data, td_cType = cType + ; return ( TyData { td_ND = new_or_data, td_cType = cType , td_ctxt = context', td_kindSig = sig' - , td_cons = condecls', td_derivs = derivs' } + , td_cons = condecls', td_derivs = derivs' } , all_fvs ) } where - h98_style = case condecls of -- Note [Stupid theta] - L _ (ConDecl { con_res = ResTyGADT {} }) : _ -> False - _ -> True + h98_style = case condecls of -- Note [Stupid theta] + L _ (ConDecl { con_res = ResTyGADT {} }) : _ -> False + _ -> True data_doc = TyDataCtx tycon rn_derivs Nothing = return (Nothing, emptyFVs) rn_derivs (Just ds) = do { (ds', fvs) <- rnLHsTypes data_doc ds - ; return (Just ds', fvs) } + ; return (Just ds', fvs) } -- "type" and "type instance" declarations rnTyDefn tycon (TySynonym { td_synRhs = ty }) @@ -1003,12 +994,12 @@ rnTyDefn tycon (TySynonym { td_synRhs = ty }) badGadtStupidTheta :: Located RdrName -> SDoc badGadtStupidTheta _ = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"), - ptext (sLit "(You can put a context on each contructor, though.)")] + ptext (sLit "(You can put a context on each contructor, though.)")] \end{code} Note [Stupid theta] ~~~~~~~~~~~~~~~~~~~ -Trac #3850 complains about a regression wrt 6.10 for +Trac #3850 complains about a regression wrt 6.10 for data Show a => T a There is no reason not to allow the stupid theta if there are no data constructors. It's still stupid, but does no harm, and I don't want @@ -1025,22 +1016,22 @@ depAnalTyClDecls ds_w_fvs edges = [ (d, tcdName (unLoc d), map get_parent (nameSetToList fvs)) | (d, fvs) <- ds_w_fvs ] - -- We also need to consider data constructor names since + -- We also need to consider data constructor names since -- they may appear in types because of promotion. get_parent n = lookupNameEnv assoc_env n `orElse` n - assoc_env :: NameEnv Name -- Maps a data constructor back + assoc_env :: NameEnv Name -- Maps a data constructor back -- to its parent type constructor assoc_env = mkNameEnv assoc_env_list assoc_env_list = do (L _ d, _) <- ds_w_fvs case d of ClassDecl { tcdLName = L _ cls_name - , tcdATs = ats } + , tcdATs = ats } -> do L _ assoc_decl <- ats return (tcdName assoc_decl, cls_name) TyDecl { tcdLName = L _ data_name - , tcdTyDefn = TyData { td_cons = cons } } + , tcdTyDefn = TyData { td_cons = cons } } -> do L _ dc <- cons return (unLoc (con_name dc), data_name) _ -> [] @@ -1061,17 +1052,17 @@ is jolly confusing. See Trac #4875 %********************************************************* -%* * +%* * \subsection{Support code for type/data declarations} -%* * +%* * %********************************************************* \begin{code} --------------- badAssocRhs :: [Name] -> RnM () badAssocRhs ns - = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions type variable") - <> plural ns + = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions type variable") + <> plural ns <+> pprWithCommas (quotes . ppr) ns) 2 (ptext (sLit "All such variables must be bound on the LHS"))) @@ -1081,36 +1072,36 @@ rnConDecls = mapFvRn (wrapLocFstM rnConDecl) rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars) rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs - , con_cxt = lcxt@(L loc cxt), con_details = details - , con_res = res_ty, con_doc = mb_doc - , con_old_rec = old_rec, con_explicit = expl }) - = do { addLocM checkConName name - ; when old_rec (addWarn (deprecRecSyntax decl)) - ; new_name <- lookupLocatedTopBndrRn name - - -- For H98 syntax, the tvs are the existential ones - -- For GADT syntax, the tvs are all the quantified tyvars - -- Hence the 'filter' in the ResTyH98 case only + , con_cxt = lcxt@(L loc cxt), con_details = details + , con_res = res_ty, con_doc = mb_doc + , con_old_rec = old_rec, con_explicit = expl }) + = do { addLocM checkConName name + ; when old_rec (addWarn (deprecRecSyntax decl)) + ; new_name <- lookupLocatedTopBndrRn name + + -- For H98 syntax, the tvs are the existential ones + -- For GADT syntax, the tvs are all the quantified tyvars + -- Hence the 'filter' in the ResTyH98 case only ; rdr_env <- getLocalRdrEnv ; let arg_tys = hsConDeclArgTys details - (free_kvs, free_tvs) = case res_ty of - ResTyH98 -> filterInScope rdr_env (get_rdr_tvs arg_tys) - ResTyGADT ty -> get_rdr_tvs (ty : arg_tys) + (free_kvs, free_tvs) = case res_ty of + ResTyH98 -> filterInScope rdr_env (get_rdr_tvs arg_tys) + ResTyGADT ty -> get_rdr_tvs (ty : arg_tys) -- With an Explicit forall, check for unused binders - -- With Implicit, find the mentioned ones, and use them as binders - ; new_tvs <- case expl of - Implicit -> return (mkHsQTvs (userHsTyVarBndrs loc free_tvs)) - Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs free_tvs + -- With Implicit, find the mentioned ones, and use them as binders + ; new_tvs <- case expl of + Implicit -> return (mkHsQTvs (userHsTyVarBndrs loc free_tvs)) + Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs free_tvs ; return tvs } - ; mb_doc' <- rnMbLHsDoc mb_doc + ; mb_doc' <- rnMbLHsDoc mb_doc ; bindHsTyVars doc Nothing free_kvs new_tvs $ \new_tyvars -> do - { (new_context, fvs1) <- rnContext doc lcxt - ; (new_details, fvs2) <- rnConDeclDetails doc details + { (new_context, fvs1) <- rnContext doc lcxt + ; (new_details, fvs2) <- rnConDeclDetails doc details ; (new_details', new_res_ty, fvs3) <- rnConResult doc (unLoc new_name) new_details res_ty - ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context + ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }, fvs1 `plusFV` fvs2 `plusFV` fvs3) }} where @@ -1126,22 +1117,22 @@ rnConResult _ _ details ResTyH98 = return (details, ResTyH98, emptyFVs) rnConResult doc con details (ResTyGADT ty) = do { (ty', fvs) <- rnLHsType doc ty ; let (arg_tys, res_ty) = splitHsFunType ty' - -- We can finally split it up, - -- now the renamer has dealt with fixities - -- See Note [Sorting out the result type] in RdrHsSyn + -- We can finally split it up, + -- now the renamer has dealt with fixities + -- See Note [Sorting out the result type] in RdrHsSyn ; case details of - InfixCon {} -> pprPanic "rnConResult" (ppr ty) - -- See Note [Sorting out the result type] in RdrHsSyn + InfixCon {} -> pprPanic "rnConResult" (ppr ty) + -- See Note [Sorting out the result type] in RdrHsSyn - RecCon {} -> do { unless (null arg_tys) + RecCon {} -> do { unless (null arg_tys) (addErr (badRecResTy (docOfHsDocContext doc))) ; return (details, ResTyGADT res_ty, fvs) } - PrefixCon {} | isSymOcc (getOccName con) -- See Note [Infix GADT cons] + PrefixCon {} | isSymOcc (getOccName con) -- See Note [Infix GADT cons] , [ty1,ty2] <- arg_tys -> do { fix_env <- getFixityEnv - ; return (if con `elemNameEnv` fix_env + ; return (if con `elemNameEnv` fix_env then InfixCon ty1 ty2 else PrefixCon arg_tys , ResTyGADT res_ty, fvs) } @@ -1161,30 +1152,30 @@ rnConDeclDetails doc (InfixCon ty1 ty2) ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) } rnConDeclDetails doc (RecCon fields) - = do { (new_fields, fvs) <- rnConDeclFields doc fields - -- No need to check for duplicate fields - -- since that is done by RnNames.extendGlobalRdrEnvRn - ; return (RecCon new_fields, fvs) } + = do { (new_fields, fvs) <- rnConDeclFields doc fields + -- No need to check for duplicate fields + -- since that is done by RnNames.extendGlobalRdrEnvRn + ; return (RecCon new_fields, fvs) } ------------------------------------------------- deprecRecSyntax :: ConDecl RdrName -> SDoc -deprecRecSyntax decl +deprecRecSyntax decl = vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_name decl)) - <+> ptext (sLit "uses deprecated syntax") + <+> ptext (sLit "uses deprecated syntax") , ptext (sLit "Instead, use the form") - , nest 2 (ppr decl) ] -- Pretty printer uses new form + , nest 2 (ppr decl) ] -- Pretty printer uses new form badRecResTy :: SDoc -> SDoc badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc -- This data decl will parse OK --- data T = a Int +-- data T = a Int -- treating "a" as the constructor. -- It is really hard to make the parser spot this malformation. -- So the renamer has to check that the constructor is legal -- -- We can get an operator as the constructor, even in the prefix form: --- data T = :% Int Int +-- data T = :% Int Int -- from interface files, which always print in prefix form checkConName :: RdrName -> TcRn () @@ -1204,14 +1195,14 @@ ad-hoc solution, we regard a GADT data constructor as infix if b) it has two arguments c) there is a fixity declaration for it For example: - infix 6 (:--:) + infix 6 (:--:) data T a where (:--:) :: t1 -> t2 -> T Int %********************************************************* -%* * +%* * \subsection{Support code for type/data declarations} -%* * +%* * %********************************************************* Get the mapping from constructors to fields for this module. @@ -1219,9 +1210,9 @@ It's convenient to do this after the data type decls have been renamed \begin{code} extendRecordFieldEnv :: [[LTyClDecl RdrName]] -> [LInstDecl RdrName] -> TcM TcGblEnv extendRecordFieldEnv tycl_decls inst_decls - = do { tcg_env <- getGblEnv - ; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons - ; return (tcg_env { tcg_field_env = field_env' }) } + = do { tcg_env <- getGblEnv + ; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons + ; return (tcg_env { tcg_field_env = field_env' }) } where -- we want to lookup: -- (a) a datatype constructor @@ -1234,24 +1225,24 @@ extendRecordFieldEnv tycl_decls inst_decls all_data_cons :: [ConDecl RdrName] all_data_cons = [con | TyData { td_cons = cons } <- all_ty_defs - , L _ con <- cons ] + , L _ con <- cons ] all_ty_defs = [ defn | L _ (TyDecl { tcdTyDefn = defn }) <- concat tycl_decls ] ++ map fid_defn (instDeclFamInsts inst_decls) -- Do not forget associated types! get_con (ConDecl { con_name = con, con_details = RecCon flds }) - (RecFields env fld_set) - = do { con' <- lookup con + (RecFields env fld_set) + = do { con' <- lookup con ; flds' <- mapM lookup (map cd_fld_name flds) - ; let env' = extendNameEnv env con' flds' - fld_set' = addListToNameSet fld_set flds' + ; let env' = extendNameEnv env con' flds' + fld_set' = addListToNameSet fld_set flds' ; return $ (RecFields env' fld_set') } get_con _ env = return env \end{code} %********************************************************* -%* * +%* * \subsection{Support code to rename types} -%* * +%* * %********************************************************* \begin{code} @@ -1261,9 +1252,9 @@ rnFds doc fds = mapM (wrapLocM rn_fds) fds where rn_fds (tys1, tys2) - = do { tys1' <- rnHsTyVars doc tys1 - ; tys2' <- rnHsTyVars doc tys2 - ; return (tys1', tys2') } + = do { tys1' <- rnHsTyVars doc tys1 + ; tys2' <- rnHsTyVars doc tys2 + ; return (tys1', tys2') } rnHsTyVars :: SDoc -> [RdrName] -> RnM [Name] rnHsTyVars doc tvs = mapM (rnHsTyVar doc) tvs @@ -1274,15 +1265,15 @@ rnHsTyVar _doc tyvar = lookupOccRn tyvar %********************************************************* -%* * - findSplice -%* * +%* * + findSplice +%* * %********************************************************* This code marches down the declarations, looking for the first Template Haskell splice. As it does so it - a) groups the declarations into a HsGroup - b) runs any top-level quasi-quotes + a) groups the declarations into a HsGroup + b) runs any top-level quasi-quotes \begin{code} findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName])) @@ -1291,15 +1282,15 @@ findSplice ds = addl emptyRdrGroup ds addl :: HsGroup RdrName -> [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName])) -- This stuff reverses the declarations (again) but it doesn't matter -addl gp [] = return (gp, Nothing) +addl gp [] = return (gp, Nothing) addl gp (L l d : ds) = add gp l d ds add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName])) -add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds - = do { -- We've found a top-level splice. If it is an *implicit* one +add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds + = do { -- We've found a top-level splice. If it is an *implicit* one -- (i.e. a naked top level expression) case flag of Explicit -> return () @@ -1315,7 +1306,7 @@ add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds add _ _ (QuasiQuoteD qq) _ = pprPanic "Can't do QuasiQuote declarations without GHCi" (ppr qq) #else -add gp _ (QuasiQuoteD qq) ds -- Expand quasiquotes +add gp _ (QuasiQuoteD qq) ds -- Expand quasiquotes = do { ds' <- runQuasiQuoteDecl qq ; addl gp (ds' ++ ds) } #endif @@ -1367,6 +1358,6 @@ add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind" add_sig :: LSig a -> HsValBinds a -> HsValBinds a -add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) +add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig" \end{code} diff --git a/compiler/simplStg/SRT.lhs b/compiler/simplStg/SRT.lhs deleted file mode 100644 index 92cfad3283..0000000000 --- a/compiler/simplStg/SRT.lhs +++ /dev/null @@ -1,166 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1998 -% - -Run through the STG code and compute the Static Reference Table for -each let-binding. At the same time, we figure out which top-level -bindings have no CAF references, and record the fact in their IdInfo. - -\begin{code} -module SRT( computeSRTs ) where - -#include "HsVersions.h" - -import StgSyn -import Id ( Id ) -import VarSet -import VarEnv -import Maybes ( orElse, expectJust ) -import Bitmap - -import DynFlags -import Outputable - -import Data.List -\end{code} - -\begin{code} -computeSRTs :: DynFlags -> [StgBinding] -> [(StgBinding,[(Id,[Id])])] - -- The incoming bindingd are filled with SRTEntries in their SRT slots - -- the outgoing ones have NoSRT/SRT values instead - -computeSRTs dflags binds = srtTopBinds dflags emptyVarEnv binds - --- -------------------------------------------------------------------------- --- Top-level Bindings - -srtTopBinds :: DynFlags -> IdEnv Id -> [StgBinding] -> [(StgBinding, [(Id,[Id])])] - -srtTopBinds _ _ [] = [] -srtTopBinds dflags env (StgNonRec b rhs : binds) = - (StgNonRec b rhs', [(b,srt')]) : srtTopBinds dflags env' binds - where - (rhs', srt) = srtTopRhs dflags b rhs - env' = maybeExtendEnv env b rhs - srt' = applyEnvList env srt -srtTopBinds dflags env (StgRec bs : binds) = - (StgRec (zip bndrs rhss), zip bndrs srts') : srtTopBinds dflags env binds - where - (rhss, srts) = unzip [ srtTopRhs dflags b r | (b,r) <- bs ] - bndrs = map fst bs - srts' = map (applyEnvList env) srts - --- Shorting out indirections in SRTs: if a binding has an SRT with a single --- element in it, we just inline it with that element everywhere it occurs --- in other SRTs. --- --- This is in a way a generalisation of the CafInfo. CafInfo says --- whether a top-level binding has *zero* CAF references, allowing us --- to omit it from SRTs. Here, we pick up bindings with *one* CAF --- reference, and inline its SRT everywhere it occurs. We could pass --- this information across module boundaries too, but we currently --- don't. - -maybeExtendEnv ::IdEnv Id -> Id -> StgRhs -> IdEnv Id -maybeExtendEnv env bndr (StgRhsClosure _ _ _ ReEntrant (SRTEntries cafs) _ _) - | [one] <- varSetElems cafs - = extendVarEnv env bndr (applyEnv env one) -maybeExtendEnv env _ _ = env - -applyEnvList :: IdEnv Id -> [Id] -> [Id] -applyEnvList env = map (applyEnv env) - -applyEnv :: IdEnv Id -> Id -> Id -applyEnv env id = lookupVarEnv env id `orElse` id - --- ---- Top-level right hand sides: - -srtTopRhs :: DynFlags -> Id -> StgRhs -> (StgRhs, [Id]) - -srtTopRhs _ _ rhs@(StgRhsCon _ _ _) = (rhs, []) -srtTopRhs dflags _ rhs@(StgRhsClosure _ _ _ _ (SRTEntries cafs) _ _) - = (srtRhs dflags table rhs, elems) - where - elems = varSetElems cafs - table = mkVarEnv (zip elems [0..]) -srtTopRhs _ _ (StgRhsClosure _ _ _ _ NoSRT _ _) = panic "srtTopRhs NoSRT" -srtTopRhs _ _ (StgRhsClosure _ _ _ _ (SRT _ _ _) _ _) = panic "srtTopRhs SRT" - --- ---- Binds: - -srtBind :: DynFlags -> IdEnv Int -> StgBinding -> StgBinding - -srtBind dflags table (StgNonRec binder rhs) = StgNonRec binder (srtRhs dflags table rhs) -srtBind dflags table (StgRec pairs) = StgRec [ (b, srtRhs dflags table r) | (b,r) <- pairs ] - --- ---- Right Hand Sides: - -srtRhs :: DynFlags -> IdEnv Int -> StgRhs -> StgRhs - -srtRhs _ _ e@(StgRhsCon _ _ _) = e -srtRhs dflags table (StgRhsClosure cc bi free_vars u srt args body) - = StgRhsClosure cc bi free_vars u (constructSRT dflags table srt) args - $! (srtExpr dflags table body) - --- --------------------------------------------------------------------------- --- Expressions - -srtExpr :: DynFlags -> IdEnv Int -> StgExpr -> StgExpr - -srtExpr _ _ e@(StgApp _ _) = e -srtExpr _ _ e@(StgLit _) = e -srtExpr _ _ e@(StgConApp _ _) = e -srtExpr _ _ e@(StgOpApp _ _ _) = e - -srtExpr dflags table (StgSCC cc tick push expr) = StgSCC cc tick push $! srtExpr dflags table expr - -srtExpr dflags table (StgTick m n expr) = StgTick m n $! srtExpr dflags table expr - -srtExpr dflags table (StgCase scrut live1 live2 uniq srt alt_type alts) - = StgCase expr' live1 live2 uniq srt' alt_type alts' - where - expr' = srtExpr dflags table scrut - srt' = constructSRT dflags table srt - alts' = map (srtAlt dflags table) alts - -srtExpr dflags table (StgLet bind body) - = srtBind dflags table bind =: \ bind' -> - srtExpr dflags table body =: \ body' -> - StgLet bind' body' - -srtExpr dflags table (StgLetNoEscape live1 live2 bind body) - = srtBind dflags table bind =: \ bind' -> - srtExpr dflags table body =: \ body' -> - StgLetNoEscape live1 live2 bind' body' - -srtExpr _ _table expr = pprPanic "srtExpr" (ppr expr) - -srtAlt :: DynFlags -> IdEnv Int -> StgAlt -> StgAlt -srtAlt dflags table (con,args,used,rhs) - = (,,,) con args used $! srtExpr dflags table rhs - ------------------------------------------------------------------------------ --- Construct an SRT bitmap. - -constructSRT :: DynFlags -> IdEnv Int -> SRT -> SRT -constructSRT dflags table (SRTEntries entries) - | isEmptyVarSet entries = NoSRT - | otherwise = seqBitmap bitmap $ SRT offset len bitmap - where - ints = map (expectJust "constructSRT" . lookupVarEnv table) - (varSetElems entries) - sorted_ints = sort ints - offset = head sorted_ints - bitmap_entries = map (subtract offset) sorted_ints - len = last bitmap_entries + 1 - bitmap = intsToBitmap dflags len bitmap_entries -constructSRT _ _ NoSRT = panic "constructSRT NoSRT" -constructSRT _ _ (SRT {}) = panic "constructSRT SRT" - --- --------------------------------------------------------------------------- --- Misc stuff - -(=:) :: a -> (a -> b) -> b -a =: k = k a - -\end{code} diff --git a/compiler/simplStg/SimplStg.lhs b/compiler/simplStg/SimplStg.lhs index 129d8c6423..871a5f4960 100644 --- a/compiler/simplStg/SimplStg.lhs +++ b/compiler/simplStg/SimplStg.lhs @@ -22,12 +22,10 @@ import SCCfinal ( stgMassageForProfiling ) import StgLint ( lintStgBindings ) import StgStats ( showStgStats ) import UnariseStg ( unarise ) -import SRT ( computeSRTs ) import DynFlags ( DynFlags(..), DynFlag(..), dopt, StgToDo(..), getStgToDo ) -import Id ( Id ) -import Module ( Module ) +import Module ( Module ) import ErrUtils import SrcLoc import UniqSupply ( mkSplitUniqSupply, splitUniqSupply ) @@ -38,7 +36,7 @@ import Outputable stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do -> Module -- module name (profiling only) -> [StgBinding] -- input... - -> IO ( [(StgBinding,[(Id,[Id])])] -- output program... + -> IO ( [StgBinding] -- output program... , CollectedCCs) -- cost centre information (declared and used) stg2stg dflags module_name binds @@ -56,14 +54,11 @@ stg2stg dflags module_name binds <- foldl_mn do_stg_pass (binds', us0, ccs) (getStgToDo dflags) ; let un_binds = unarise us1 processed_binds - ; let srt_binds - | dopt Opt_TryNewCodeGen dflags = zip un_binds (repeat []) - | otherwise = computeSRTs dflags un_binds ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" - (pprStgBindingsWithSRTs srt_binds) + (pprStgBindings un_binds) - ; return (srt_binds, cost_centres) + ; return (un_binds, cost_centres) } where diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.lhs index e5c525e4c3..8d00f94ead 100644 --- a/compiler/stgSyn/StgSyn.lhs +++ b/compiler/stgSyn/StgSyn.lhs @@ -38,7 +38,7 @@ module StgSyn ( isDllConApp, stgArgType, - pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs, + pprStgBinding, pprStgBindings, pprStgLVs ) where @@ -651,16 +651,6 @@ pprStgBinding bind = pprGenStgBinding bind pprStgBindings :: [StgBinding] -> SDoc pprStgBindings binds = vcat (map pprGenStgBinding binds) -pprGenStgBindingWithSRT :: (OutputableBndr bndr, Outputable bdee, Ord bdee) - => (GenStgBinding bndr bdee,[(Id,[Id])]) -> SDoc -pprGenStgBindingWithSRT (bind,srts) - = vcat $ pprGenStgBinding bind : map pprSRT srts - where pprSRT (id,srt) = - ptext (sLit "SRT") <> parens (ppr id) <> ptext (sLit ": ") <> ppr srt - -pprStgBindingsWithSRTs :: [(StgBinding,[(Id,[Id])])] -> SDoc -pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds) - instance (Outputable bdee) => Outputable (GenStgArg bdee) where ppr = pprStgArg diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs index 8745f8e612..fbb600c463 100644 --- a/compiler/typecheck/TcGenGenerics.lhs +++ b/compiler/typecheck/TcGenGenerics.lhs @@ -224,7 +224,7 @@ canDoGenerics tc tc_args (tc_name, tc_tys) = case tyConParent tc of FamInstTyCon _ ptc tys -> (ppr ptc, hsep (map ppr (tys ++ drop (length tys) tc_args))) - _ -> (ppr tc, hsep (map ppr tc_args)) + _ -> (ppr tc, hsep (map ppr (tyConTyVars tc))) -- If any of the constructor has an unboxed type as argument, -- then we can't build the embedding-projection pair, because diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 610ef45178..c40a9f725b 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -283,16 +283,16 @@ unsetWOptM flag = updEnv (\ env@(Env { env_top = top }) -> -- | Do it flag is true ifDOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -ifDOptM flag thing_inside = do { b <- doptM flag ; - if b then thing_inside else return () } +ifDOptM flag thing_inside = do b <- doptM flag + when b thing_inside ifWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -ifWOptM flag thing_inside = do { b <- woptM flag ; - if b then thing_inside else return () } +ifWOptM flag thing_inside = do b <- woptM flag + when b thing_inside ifXOptM :: ExtensionFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -ifXOptM flag thing_inside = do { b <- xoptM flag ; - if b then thing_inside else return () } +ifXOptM flag thing_inside = do b <- xoptM flag + when b thing_inside getGhcMode :: TcRnIf gbl lcl GhcMode getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) } diff --git a/compiler/utils/Bag.lhs b/compiler/utils/Bag.lhs index a32991b97d..a83397898e 100644 --- a/compiler/utils/Bag.lhs +++ b/compiler/utils/Bag.lhs @@ -268,5 +268,6 @@ instance Data a => Data (Bag a) where toConstr _ = abstractConstr $ "Bag("++show (typeOf (undefined::a))++")" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "Bag" + dataCast1 x = gcast1 x \end{code} diff --git a/compiler/utils/Serialized.hs b/compiler/utils/Serialized.hs index 26cca6c386..902d2feea0 100644 --- a/compiler/utils/Serialized.hs +++ b/compiler/utils/Serialized.hs @@ -95,16 +95,26 @@ deserializeConstr bytes k = deserializeWord8 bytes $ \constr_ix bytes -> x -> error $ "deserializeConstr: unrecognised serialized constructor type " ++ show x ++ " in context " ++ show bytes +#if __GLASGOW_HASKELL__ < 707 serializeFixedWidthNum :: forall a. (Num a, Integral a, Bits a) => a -> [Word8] -> [Word8] serializeFixedWidthNum what = go (bitSize what) what +#else +serializeFixedWidthNum :: forall a. (Num a, Integral a, FiniteBits a) => a -> [Word8] -> [Word8] +serializeFixedWidthNum what = go (finiteBitSize what) what +#endif where go :: Int -> a -> [Word8] -> [Word8] go size current rest | size <= 0 = rest | otherwise = fromIntegral (current .&. 255) : go (size - 8) (current `shiftR` 8) rest +#if __GLASGOW_HASKELL__ < 707 deserializeFixedWidthNum :: forall a b. (Num a, Integral a, Bits a) => [Word8] -> (a -> [Word8] -> b) -> b deserializeFixedWidthNum bytes k = go (bitSize (undefined :: a)) bytes k +#else +deserializeFixedWidthNum :: forall a b. (Num a, Integral a, FiniteBits a) => [Word8] -> (a -> [Word8] -> b) -> b +deserializeFixedWidthNum bytes k = go (finiteBitSize (undefined :: a)) bytes k +#endif where go :: Int -> [Word8] -> (a -> [Word8] -> b) -> b go size bytes k diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index a81ae34789..1c2e76ee08 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -8552,8 +8552,9 @@ Assertion failures can be caught, see the documentation for the </listitem> </itemizedlist> Warnings and deprecations are not reported for - (a) uses within the defining module, and - (b) uses in an export list. + (a) uses within the defining module, + (b) defining a method in a class instance, and + (c) uses in an export list. The latter reduces spurious complaints within a library in which one module gathers together and re-exports the exports of several others. diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml index 2c5217b40d..c3a1366f43 100644 --- a/docs/users_guide/using.xml +++ b/docs/users_guide/using.xml @@ -2332,6 +2332,24 @@ last (x : xs) = last' x xs </listitem> </varlistentry> + <varlistentry> + <term> + <option>-fomit-yields</option> + <indexterm><primary><option>-fomit-yields</option></primary></indexterm> + </term> + <listitem> + <para><emphasis>On by default.</emphasis> Tells GHC to omit + heap checks when no allocation is being performed. While this improves + binary sizes by about 5%, it also means that threads run in + tight non-allocating loops will not get preempted in a timely + fashion. If it is important to always be able to interrupt such + threads, you should turn this optimization off. Consider also + recompiling all libraries with this optimization turned off, if you + need to guarantee interruptibility. + </para> + </listitem> + </varlistentry> + </variablelist> </sect2> @@ -322,7 +322,8 @@ PKGS_THAT_ARE_DPH := \ # Packages that, if present, must be built by the stage2 compiler, # because they use TH and/or annotations, or depend on other stage2 # packages: -PKGS_THAT_BUILD_WITH_STAGE2 := $(PKGS_THAT_ARE_DPH) haskell98 haskell2010 +PKGS_THAT_BUILD_WITH_STAGE2 := \ + $(PKGS_THAT_ARE_DPH) old-time haskell98 haskell2010 # Packages that we shouldn't build if we don't have TH (e.g. because # we're building a profiled compiler): diff --git a/ghc/ghc.mk b/ghc/ghc.mk index e1545033be..e177b9274c 100644 --- a/ghc/ghc.mk +++ b/ghc/ghc.mk @@ -78,7 +78,7 @@ ghc_stage1_SHELL_WRAPPER_NAME = ghc/ghc.wrapper ghc_stage2_SHELL_WRAPPER_NAME = ghc/ghc.wrapper ghc_stage3_SHELL_WRAPPER_NAME = ghc/ghc.wrapper -ghc_stage$(INSTALL_GHC_STAGE)_INSTALL_SHELL_WRAPPER = YES +ghc_stage$(INSTALL_GHC_STAGE)_INSTALL = YES ghc_stage$(INSTALL_GHC_STAGE)_INSTALL_SHELL_WRAPPER_NAME = ghc-$(ProjectVersion) # We override the program name to be ghc, rather than ghc-stage2. diff --git a/includes/mkDerivedConstants.c b/includes/mkDerivedConstants.c index 62c5ae8f1f..199e2edeb6 100644 --- a/includes/mkDerivedConstants.c +++ b/includes/mkDerivedConstants.c @@ -79,10 +79,18 @@ enum Mode { Gen_Haskell_Type, Gen_Haskell_Value, Gen_Haskell_Wrappers, Gen_Haske and the names of the CmmTypes in the compiler b32 :: CmmType */ -#define field_type_(str, s_type, field) \ +#define field_type_(want_haskell, str, s_type, field) \ switch (mode) { \ case Gen_Haskell_Type: \ + if (want_haskell) { \ + printf(" , pc_REP_" str " :: Int\n"); \ + break; \ + } \ case Gen_Haskell_Value: \ + if (want_haskell) { \ + printf(" , pc_REP_" str " = %" PRIdPTR "\n", (intptr_t)(FIELD_SIZE(s_type, field))); \ + break; \ + } \ case Gen_Haskell_Wrappers: \ case Gen_Haskell_Exports: \ break; \ @@ -104,8 +112,8 @@ enum Mode { Gen_Haskell_Type, Gen_Haskell_Value, Gen_Haskell_Wrappers, Gen_Haske break; \ } -#define field_type(s_type, field) \ - field_type_(str(s_type,field),s_type,field); +#define field_type(want_haskell, s_type, field) \ + field_type_(want_haskell,str(s_type,field),s_type,field); #define field_offset_(str, s_type, field) \ def_offset(str, OFFSET(s_type,field)); @@ -127,14 +135,20 @@ enum Mode { Gen_Haskell_Type, Gen_Haskell_Value, Gen_Haskell_Wrappers, Gen_Haske } /* Outputs the byte offset and MachRep for a field */ -#define struct_field(s_type, field) \ - field_offset(s_type, field); \ - field_type(s_type, field); \ +#define struct_field_helper(want_haskell, s_type, field) \ + field_offset(s_type, field); \ + field_type(want_haskell, s_type, field); \ struct_field_macro(str(s_type,field)) +#define struct_field(s_type, field) \ + struct_field_helper(0, s_type, field) + +#define struct_field_h(s_type, field) \ + struct_field_helper(1, s_type, field) + #define struct_field_(str, s_type, field) \ field_offset_(str, s_type, field); \ - field_type_(str, s_type, field); \ + field_type_(0,str, s_type, field); \ struct_field_macro(str) #define def_size(str, size) \ @@ -222,7 +236,7 @@ enum Mode { Gen_Haskell_Type, Gen_Haskell_Value, Gen_Haskell_Wrappers, Gen_Haske /* Byte offset and MachRep for a closure field, minus the header */ #define closure_field_(str, s_type, field) \ closure_field_offset_(str,s_type,field) \ - field_type_(str, s_type, field); \ + field_type_(0, str, s_type, field); \ closure_field_macro(str) #define closure_field(s_type, field) \ @@ -270,9 +284,9 @@ enum Mode { Gen_Haskell_Type, Gen_Haskell_Value, Gen_Haskell_Wrappers, Gen_Haske break; \ } -#define tso_field(s_type, field) \ - field_type(s_type, field); \ - tso_field_offset(s_type,field); \ +#define tso_field(s_type, field) \ + field_type(0, s_type, field); \ + tso_field_offset(s_type,field); \ tso_field_macro(str(s_type,field)) #define opt_struct_size(s_type, option) \ @@ -422,7 +436,9 @@ main(int argc, char *argv[]) // Size of a storage manager block (in bytes). constantIntC("BLOCK_SIZE", "bLOCK_SIZE", BLOCK_SIZE); - constantIntC("MBLOCK_SIZE", "mBLOCK_SIZE", MBLOCK_SIZE); + if (mode == Gen_Header) { + constantIntC("MBLOCK_SIZE", "mBLOCK_SIZE", MBLOCK_SIZE); + } // blocks that fit in an MBlock, leaving space for the block descriptors constantIntC("BLOCKS_PER_MBLOCK", "bLOCKS_PER_MBLOCK", BLOCKS_PER_MBLOCK); // could be derived, but better to save doing the calculation twice @@ -453,217 +469,239 @@ main(int argc, char *argv[]) field_offset(StgRegTable, rCurrentTSO); field_offset(StgRegTable, rCurrentNursery); field_offset(StgRegTable, rHpAlloc); - struct_field(StgRegTable, rRet); - struct_field(StgRegTable, rNursery); + if (mode == Gen_Header) { + struct_field(StgRegTable, rRet); + struct_field(StgRegTable, rNursery); + } def_offset("stgEagerBlackholeInfo", FUN_OFFSET(stgEagerBlackholeInfo)); def_offset("stgGCEnter1", FUN_OFFSET(stgGCEnter1)); def_offset("stgGCFun", FUN_OFFSET(stgGCFun)); field_offset(Capability, r); - field_offset(Capability, lock); - struct_field(Capability, no); - struct_field(Capability, mut_lists); - struct_field(Capability, context_switch); - struct_field(Capability, interrupt); - struct_field(Capability, sparks); + if (mode == Gen_Header) { + field_offset(Capability, lock); + struct_field(Capability, no); + struct_field(Capability, mut_lists); + struct_field(Capability, context_switch); + struct_field(Capability, interrupt); + struct_field(Capability, sparks); + } struct_field(bdescr, start); struct_field(bdescr, free); struct_field(bdescr, blocks); - struct_field(bdescr, gen_no); - struct_field(bdescr, link); + if (mode == Gen_Header) { + struct_field(bdescr, gen_no); + struct_field(bdescr, link); - struct_size(generation); - struct_field(generation, n_new_large_words); + struct_size(generation); + struct_field(generation, n_new_large_words); + } struct_size(CostCentreStack); - struct_field(CostCentreStack, ccsID); - struct_field(CostCentreStack, mem_alloc); - struct_field(CostCentreStack, scc_count); - struct_field(CostCentreStack, prevStack); + if (mode == Gen_Header) { + struct_field(CostCentreStack, ccsID); + } + struct_field_h(CostCentreStack, mem_alloc); + struct_field_h(CostCentreStack, scc_count); + if (mode == Gen_Header) { + struct_field(CostCentreStack, prevStack); - struct_field(CostCentre, ccID); - struct_field(CostCentre, link); + struct_field(CostCentre, ccID); + struct_field(CostCentre, link); - struct_field(StgHeader, info); + struct_field(StgHeader, info); + } struct_field_("StgHeader_ccs", StgHeader, prof.ccs); struct_field_("StgHeader_ldvw", StgHeader, prof.hp.ldvw); struct_size(StgSMPThunkHeader); - closure_payload(StgClosure,payload); + if (mode == Gen_Header) { + closure_payload(StgClosure,payload); + } - struct_field(StgEntCounter, allocs); + struct_field_h(StgEntCounter, allocs); struct_field(StgEntCounter, registeredp); struct_field(StgEntCounter, link); struct_field(StgEntCounter, entry_count); closure_size(StgUpdateFrame); - closure_size(StgCatchFrame); - closure_size(StgStopFrame); + if (mode == Gen_Header) { + closure_size(StgCatchFrame); + closure_size(StgStopFrame); + } closure_size(StgMutArrPtrs); closure_field(StgMutArrPtrs, ptrs); closure_field(StgMutArrPtrs, size); closure_size(StgArrWords); - closure_field(StgArrWords, bytes); - closure_payload(StgArrWords, payload); - - closure_field(StgTSO, _link); - closure_field(StgTSO, global_link); - closure_field(StgTSO, what_next); - closure_field(StgTSO, why_blocked); - closure_field(StgTSO, block_info); - closure_field(StgTSO, blocked_exceptions); - closure_field(StgTSO, id); - closure_field(StgTSO, cap); - closure_field(StgTSO, saved_errno); - closure_field(StgTSO, trec); - closure_field(StgTSO, flags); - closure_field(StgTSO, dirty); - closure_field(StgTSO, bq); + if (mode == Gen_Header) { + closure_field(StgArrWords, bytes); + closure_payload(StgArrWords, payload); + + closure_field(StgTSO, _link); + closure_field(StgTSO, global_link); + closure_field(StgTSO, what_next); + closure_field(StgTSO, why_blocked); + closure_field(StgTSO, block_info); + closure_field(StgTSO, blocked_exceptions); + closure_field(StgTSO, id); + closure_field(StgTSO, cap); + closure_field(StgTSO, saved_errno); + closure_field(StgTSO, trec); + closure_field(StgTSO, flags); + closure_field(StgTSO, dirty); + closure_field(StgTSO, bq); + } closure_field_("StgTSO_cccs", StgTSO, prof.cccs); closure_field(StgTSO, stackobj); closure_field(StgStack, sp); closure_field_offset(StgStack, stack); + if (mode == Gen_Header) { closure_field(StgStack, stack_size); - closure_field(StgStack, dirty); + closure_field(StgStack, dirty); - struct_size(StgTSOProfInfo); + struct_size(StgTSOProfInfo); - opt_struct_size(StgTSOProfInfo,PROFILING); + opt_struct_size(StgTSOProfInfo,PROFILING); + } closure_field(StgUpdateFrame, updatee); - closure_field(StgCatchFrame, handler); - closure_field(StgCatchFrame, exceptions_blocked); - - closure_size(StgPAP); - closure_field(StgPAP, n_args); - closure_field_gcptr(StgPAP, fun); - closure_field(StgPAP, arity); - closure_payload(StgPAP, payload); - - thunk_size(StgAP); - closure_field(StgAP, n_args); - closure_field_gcptr(StgAP, fun); - closure_payload(StgAP, payload); - - thunk_size(StgAP_STACK); - closure_field(StgAP_STACK, size); - closure_field_gcptr(StgAP_STACK, fun); - closure_payload(StgAP_STACK, payload); - - thunk_size(StgSelector); - - closure_field_gcptr(StgInd, indirectee); - - closure_size(StgMutVar); - closure_field(StgMutVar, var); - - closure_size(StgAtomicallyFrame); - closure_field(StgAtomicallyFrame, code); - closure_field(StgAtomicallyFrame, next_invariant_to_check); - closure_field(StgAtomicallyFrame, result); - - closure_field(StgInvariantCheckQueue, invariant); - closure_field(StgInvariantCheckQueue, my_execution); - closure_field(StgInvariantCheckQueue, next_queue_entry); - - closure_field(StgAtomicInvariant, code); - - closure_field(StgTRecHeader, enclosing_trec); - - closure_size(StgCatchSTMFrame); - closure_field(StgCatchSTMFrame, handler); - closure_field(StgCatchSTMFrame, code); - - closure_size(StgCatchRetryFrame); - closure_field(StgCatchRetryFrame, running_alt_code); - closure_field(StgCatchRetryFrame, first_code); - closure_field(StgCatchRetryFrame, alt_code); - - closure_field(StgTVarWatchQueue, closure); - closure_field(StgTVarWatchQueue, next_queue_entry); - closure_field(StgTVarWatchQueue, prev_queue_entry); - - closure_field(StgTVar, current_value); - - closure_size(StgWeak); - closure_field(StgWeak,link); - closure_field(StgWeak,key); - closure_field(StgWeak,value); - closure_field(StgWeak,finalizer); - closure_field(StgWeak,cfinalizer); - - closure_size(StgDeadWeak); - closure_field(StgDeadWeak,link); - - closure_size(StgMVar); - closure_field(StgMVar,head); - closure_field(StgMVar,tail); - closure_field(StgMVar,value); - - closure_size(StgMVarTSOQueue); - closure_field(StgMVarTSOQueue, link); - closure_field(StgMVarTSOQueue, tso); - - closure_size(StgBCO); - closure_field(StgBCO, instrs); - closure_field(StgBCO, literals); - closure_field(StgBCO, ptrs); - closure_field(StgBCO, arity); - closure_field(StgBCO, size); - closure_payload(StgBCO, bitmap); - - closure_size(StgStableName); - closure_field(StgStableName,sn); - - closure_size(StgBlockingQueue); - closure_field(StgBlockingQueue, bh); - closure_field(StgBlockingQueue, owner); - closure_field(StgBlockingQueue, queue); - closure_field(StgBlockingQueue, link); - - closure_size(MessageBlackHole); - closure_field(MessageBlackHole, link); - closure_field(MessageBlackHole, tso); - closure_field(MessageBlackHole, bh); - - struct_field_("RtsFlags_ProfFlags_showCCSOnException", - RTS_FLAGS, ProfFlags.showCCSOnException); - struct_field_("RtsFlags_DebugFlags_apply", - RTS_FLAGS, DebugFlags.apply); - struct_field_("RtsFlags_DebugFlags_sanity", - RTS_FLAGS, DebugFlags.sanity); - struct_field_("RtsFlags_DebugFlags_weak", - RTS_FLAGS, DebugFlags.weak); - struct_field_("RtsFlags_GcFlags_initialStkSize", - RTS_FLAGS, GcFlags.initialStkSize); - struct_field_("RtsFlags_MiscFlags_tickInterval", - RTS_FLAGS, MiscFlags.tickInterval); - - struct_size(StgFunInfoExtraFwd); - struct_field(StgFunInfoExtraFwd, slow_apply); - struct_field(StgFunInfoExtraFwd, fun_type); - struct_field(StgFunInfoExtraFwd, arity); - struct_field_("StgFunInfoExtraFwd_bitmap", StgFunInfoExtraFwd, b.bitmap); + if (mode == Gen_Header) { + closure_field(StgCatchFrame, handler); + closure_field(StgCatchFrame, exceptions_blocked); + + closure_size(StgPAP); + closure_field(StgPAP, n_args); + closure_field_gcptr(StgPAP, fun); + closure_field(StgPAP, arity); + closure_payload(StgPAP, payload); + + thunk_size(StgAP); + closure_field(StgAP, n_args); + closure_field_gcptr(StgAP, fun); + closure_payload(StgAP, payload); + + thunk_size(StgAP_STACK); + closure_field(StgAP_STACK, size); + closure_field_gcptr(StgAP_STACK, fun); + closure_payload(StgAP_STACK, payload); + + thunk_size(StgSelector); + + closure_field_gcptr(StgInd, indirectee); + + closure_size(StgMutVar); + closure_field(StgMutVar, var); + + closure_size(StgAtomicallyFrame); + closure_field(StgAtomicallyFrame, code); + closure_field(StgAtomicallyFrame, next_invariant_to_check); + closure_field(StgAtomicallyFrame, result); + + closure_field(StgInvariantCheckQueue, invariant); + closure_field(StgInvariantCheckQueue, my_execution); + closure_field(StgInvariantCheckQueue, next_queue_entry); + + closure_field(StgAtomicInvariant, code); + + closure_field(StgTRecHeader, enclosing_trec); + + closure_size(StgCatchSTMFrame); + closure_field(StgCatchSTMFrame, handler); + closure_field(StgCatchSTMFrame, code); + + closure_size(StgCatchRetryFrame); + closure_field(StgCatchRetryFrame, running_alt_code); + closure_field(StgCatchRetryFrame, first_code); + closure_field(StgCatchRetryFrame, alt_code); + + closure_field(StgTVarWatchQueue, closure); + closure_field(StgTVarWatchQueue, next_queue_entry); + closure_field(StgTVarWatchQueue, prev_queue_entry); + + closure_field(StgTVar, current_value); + + closure_size(StgWeak); + closure_field(StgWeak,link); + closure_field(StgWeak,key); + closure_field(StgWeak,value); + closure_field(StgWeak,finalizer); + closure_field(StgWeak,cfinalizer); + + closure_size(StgDeadWeak); + closure_field(StgDeadWeak,link); + + closure_size(StgMVar); + closure_field(StgMVar,head); + closure_field(StgMVar,tail); + closure_field(StgMVar,value); + + closure_size(StgMVarTSOQueue); + closure_field(StgMVarTSOQueue, link); + closure_field(StgMVarTSOQueue, tso); + + closure_size(StgBCO); + closure_field(StgBCO, instrs); + closure_field(StgBCO, literals); + closure_field(StgBCO, ptrs); + closure_field(StgBCO, arity); + closure_field(StgBCO, size); + closure_payload(StgBCO, bitmap); + + closure_size(StgStableName); + closure_field(StgStableName,sn); + + closure_size(StgBlockingQueue); + closure_field(StgBlockingQueue, bh); + closure_field(StgBlockingQueue, owner); + closure_field(StgBlockingQueue, queue); + closure_field(StgBlockingQueue, link); + + closure_size(MessageBlackHole); + closure_field(MessageBlackHole, link); + closure_field(MessageBlackHole, tso); + closure_field(MessageBlackHole, bh); + + struct_field_("RtsFlags_ProfFlags_showCCSOnException", + RTS_FLAGS, ProfFlags.showCCSOnException); + struct_field_("RtsFlags_DebugFlags_apply", + RTS_FLAGS, DebugFlags.apply); + struct_field_("RtsFlags_DebugFlags_sanity", + RTS_FLAGS, DebugFlags.sanity); + struct_field_("RtsFlags_DebugFlags_weak", + RTS_FLAGS, DebugFlags.weak); + struct_field_("RtsFlags_GcFlags_initialStkSize", + RTS_FLAGS, GcFlags.initialStkSize); + struct_field_("RtsFlags_MiscFlags_tickInterval", + RTS_FLAGS, MiscFlags.tickInterval); + + struct_size(StgFunInfoExtraFwd); + struct_field(StgFunInfoExtraFwd, slow_apply); + struct_field(StgFunInfoExtraFwd, fun_type); + struct_field(StgFunInfoExtraFwd, arity); + struct_field_("StgFunInfoExtraFwd_bitmap", StgFunInfoExtraFwd, b.bitmap); + } struct_size(StgFunInfoExtraRev); - struct_field(StgFunInfoExtraRev, slow_apply_offset); - struct_field(StgFunInfoExtraRev, fun_type); - struct_field(StgFunInfoExtraRev, arity); - struct_field_("StgFunInfoExtraRev_bitmap", StgFunInfoExtraRev, b.bitmap); + if (mode == Gen_Header) { + struct_field(StgFunInfoExtraRev, slow_apply_offset); + struct_field(StgFunInfoExtraRev, fun_type); + struct_field(StgFunInfoExtraRev, arity); + struct_field_("StgFunInfoExtraRev_bitmap", StgFunInfoExtraRev, b.bitmap); - struct_field(StgLargeBitmap, size); - field_offset(StgLargeBitmap, bitmap); + struct_field(StgLargeBitmap, size); + field_offset(StgLargeBitmap, bitmap); - struct_size(snEntry); - struct_field(snEntry,sn_obj); - struct_field(snEntry,addr); + struct_size(snEntry); + struct_field(snEntry,sn_obj); + struct_field(snEntry,addr); + } #ifdef mingw32_HOST_OS /* Note that this conditional part only affects the C headers. @@ -745,7 +783,7 @@ main(int argc, char *argv[]) switch (mode) { case Gen_Haskell_Type: - printf(" } deriving (Read, Show)\n"); + printf(" } deriving Read\n"); break; case Gen_Haskell_Value: printf(" }\n"); diff --git a/includes/rts/Flags.h b/includes/rts/Flags.h index da71a4bf83..9ca7fb9f7e 100644 --- a/includes/rts/Flags.h +++ b/includes/rts/Flags.h @@ -53,6 +53,7 @@ struct GC_FLAGS { rtsBool frontpanel; Time idleGCDelayTime; /* units: TIME_RESOLUTION */ + rtsBool doIdleGC; StgWord heapBase; /* address to ask the OS for memory */ }; diff --git a/includes/rts/storage/ClosureMacros.h b/includes/rts/storage/ClosureMacros.h index 146564a17f..6fdd55727a 100644 --- a/includes/rts/storage/ClosureMacros.h +++ b/includes/rts/storage/ClosureMacros.h @@ -46,11 +46,14 @@ -------------------------------------------------------------------------- */ -#define SET_INFO(c,i) ((c)->header.info = (i)) -#define GET_INFO(c) ((c)->header.info) -#define GET_ENTRY(c) (ENTRY_CODE(GET_INFO(c))) +INLINE_HEADER void SET_INFO(StgClosure *c, const StgInfoTable *info) { + c->header.info = info; +} +INLINE_HEADER const StgInfoTable *GET_INFO(StgClosure *c) { + return c->header.info; +} -#define GET_TAG(con) (get_itbl(con)->srt_bitmap) +#define GET_ENTRY(c) (ENTRY_CODE(GET_INFO(c))) #ifdef TABLES_NEXT_TO_CODE EXTERN_INLINE StgInfoTable *INFO_PTR_TO_STRUCT(const StgInfoTable *info); @@ -90,6 +93,10 @@ INLINE_HEADER StgThunkInfoTable *get_thunk_itbl(const StgClosure *c) {return THU INLINE_HEADER StgConInfoTable *get_con_itbl(const StgClosure *c) {return CON_INFO_PTR_TO_STRUCT((c)->header.info);} +INLINE_HEADER StgHalfWord GET_TAG(const StgClosure *con) { + return get_itbl(con)->srt_bitmap; +} + /* ----------------------------------------------------------------------------- Macros for building closures -------------------------------------------------------------------------- */ @@ -142,7 +149,7 @@ INLINE_HEADER StgConInfoTable *get_con_itbl(const StgClosure *c) {return CON_INF // Use when changing a closure from one kind to another #define OVERWRITE_INFO(c, new_info) \ OVERWRITING_CLOSURE((StgClosure *)(c)); \ - SET_INFO((c), (new_info)); \ + SET_INFO((StgClosure *)(c), (new_info)); \ LDV_RECORD_CREATE(c); /* ----------------------------------------------------------------------------- @@ -170,16 +177,22 @@ STATIC_LINK(const StgInfoTable *info, StgClosure *p) } } -#define STATIC_LINK2(info,p) \ - (*(StgClosure**)(&((p)->payload[info->layout.payload.ptrs + \ - info->layout.payload.nptrs + 1]))) +INLINE_HEADER StgClosure *STATIC_LINK2(const StgInfoTable *info, + StgClosure *p) { + return (*(StgClosure**)(&((p)->payload[info->layout.payload.ptrs + + info->layout.payload.nptrs + 1]))); +} /* ----------------------------------------------------------------------------- INTLIKE and CHARLIKE closures. -------------------------------------------------------------------------- */ -#define CHARLIKE_CLOSURE(n) ((P_)&stg_CHARLIKE_closure[(n)-MIN_CHARLIKE]) -#define INTLIKE_CLOSURE(n) ((P_)&stg_INTLIKE_closure[(n)-MIN_INTLIKE]) +INLINE_HEADER P_ CHARLIKE_CLOSURE(int n) { + return (P_)&stg_CHARLIKE_closure[(n)-MIN_CHARLIKE]; +} +INLINE_HEADER P_ INTLIKE_CLOSURE(int n) { + return (P_)&stg_INTLIKE_closure[(n)-MIN_INTLIKE]; +} /* ---------------------------------------------------------------------------- Macros for untagging and retagging closure pointers @@ -492,7 +505,7 @@ EXTERN_INLINE void overwritingClosure (StgClosure *p) // For LDV profiling, we need to record the closure as dead #if defined(PROFILING) - LDV_recordDead((StgClosure *)(p), size); + LDV_recordDead(p, size); #endif for (i = 0; i < size - sizeofW(StgThunkHeader); i++) { diff --git a/includes/rts/storage/GC.h b/includes/rts/storage/GC.h index fadaa8c1a4..a5f4ed6f36 100644 --- a/includes/rts/storage/GC.h +++ b/includes/rts/storage/GC.h @@ -75,6 +75,7 @@ typedef struct generation_ { bdescr * large_objects; // large objects (doubly linked) memcount n_large_blocks; // no. of blocks used by large objs + memcount n_large_words; // no. of words used by large objs memcount n_new_large_words; // words of new large objects // (for allocation stats) diff --git a/mk/validate-settings.mk b/mk/validate-settings.mk index 08300b933f..a94d2b620b 100644 --- a/mk/validate-settings.mk +++ b/mk/validate-settings.mk @@ -71,6 +71,12 @@ libraries/containers_dist-install_EXTRA_HC_OPTS += -fno-warn-pointless-pragmas # bytestring has identities at the moment libraries/bytestring_dist-install_EXTRA_HC_OPTS += -fno-warn-identities +# bytestring uses bitSize at the moment +libraries/bytestring_dist-install_EXTRA_HC_OPTS += -fno-warn-deprecations + +# containers uses bitSize at the moment +libraries/containers_dist-install_EXTRA_HC_OPTS += -fno-warn-deprecations + # Temporarily turn off unused-do-bind warnings for the time package libraries/time_dist-install_EXTRA_HC_OPTS += -fno-warn-unused-do-bind # Temporary: mkTyCon is deprecated diff --git a/rts/Interpreter.c b/rts/Interpreter.c index f3e070000b..83973e8c9b 100644 --- a/rts/Interpreter.c +++ b/rts/Interpreter.c @@ -339,7 +339,7 @@ eval_obj: { StgUpdateFrame *__frame; __frame = (StgUpdateFrame *)Sp; - SET_INFO(__frame, (StgInfoTable *)&stg_upd_frame_info); + SET_INFO((StgClosure *)__frame, (StgInfoTable *)&stg_upd_frame_info); __frame->updatee = (StgClosure *)(ap); } diff --git a/rts/Printer.c b/rts/Printer.c index 02fbb09962..fb00401f59 100644 --- a/rts/Printer.c +++ b/rts/Printer.c @@ -259,7 +259,7 @@ printClosure( StgClosure *obj ) { StgUpdateFrame* u = (StgUpdateFrame*)obj; debugBelch("UPDATE_FRAME("); - printPtr((StgPtr)GET_INFO(u)); + printPtr((StgPtr)GET_INFO((StgClosure *)u)); debugBelch(","); printPtr((StgPtr)u->updatee); debugBelch(")\n"); @@ -270,7 +270,7 @@ printClosure( StgClosure *obj ) { StgCatchFrame* u = (StgCatchFrame*)obj; debugBelch("CATCH_FRAME("); - printPtr((StgPtr)GET_INFO(u)); + printPtr((StgPtr)GET_INFO((StgClosure *)u)); debugBelch(","); printPtr((StgPtr)u->handler); debugBelch(")\n"); @@ -290,7 +290,7 @@ printClosure( StgClosure *obj ) { StgStopFrame* u = (StgStopFrame*)obj; debugBelch("STOP_FRAME("); - printPtr((StgPtr)GET_INFO(u)); + printPtr((StgPtr)GET_INFO((StgClosure *)u)); debugBelch(")\n"); break; } diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c index 42c7ef717b..3f38c8ac1f 100644 --- a/rts/RtsFlags.c +++ b/rts/RtsFlags.c @@ -115,6 +115,11 @@ void initRtsFlagsDefaults(void) RtsFlags.GcFlags.frontpanel = rtsFalse; #endif RtsFlags.GcFlags.idleGCDelayTime = USToTime(300000); // 300ms +#ifdef THREADED_RTS + RtsFlags.GcFlags.doIdleGC = rtsTrue; +#else + RtsFlags.GcFlags.doIdleGC = rtsFalse; +#endif #if osf3_HOST_OS /* ToDo: Perhaps by adjusting this value we can make linking without @@ -547,6 +552,7 @@ void setupRtsFlags (int *argc, char *argv[], procRtsOpts(rts_argc0, rtsOptsEnabled); appendRtsArg((char *)0); + rts_argc--; // appendRtsArg will have bumped it for the NULL (#7227) normaliseRtsOpts(); @@ -914,8 +920,13 @@ error = rtsTrue; if (rts_argv[arg][2] == '\0') { /* use default */ } else { - RtsFlags.GcFlags.idleGCDelayTime = - fsecondsToTime(atof(rts_argv[arg]+2)); + Time t = fsecondsToTime(atof(rts_argv[arg]+2)); + if (t == 0) { + RtsFlags.GcFlags.doIdleGC = rtsFalse; + } else { + RtsFlags.GcFlags.doIdleGC = rtsTrue; + RtsFlags.GcFlags.idleGCDelayTime = t; + } } break; diff --git a/rts/Schedule.c b/rts/Schedule.c index 41f7f37f71..9bd0b6c3ec 100644 --- a/rts/Schedule.c +++ b/rts/Schedule.c @@ -452,23 +452,29 @@ run_thread: dirty_TSO(cap,t); dirty_STACK(cap,t->stackobj); -#if defined(THREADED_RTS) - if (recent_activity == ACTIVITY_DONE_GC) { + switch (recent_activity) + { + case ACTIVITY_DONE_GC: { // ACTIVITY_DONE_GC means we turned off the timer signal to // conserve power (see #1623). Re-enable it here. nat prev; prev = xchg((P_)&recent_activity, ACTIVITY_YES); +#ifndef PROFILING if (prev == ACTIVITY_DONE_GC) { startTimer(); } - } else if (recent_activity != ACTIVITY_INACTIVE) { +#endif + break; + } + case ACTIVITY_INACTIVE: // If we reached ACTIVITY_INACTIVE, then don't reset it until // we've done the GC. The thread running here might just be // the IO manager thread that handle_tick() woke up via // wakeUpRts(). + break; + default: recent_activity = ACTIVITY_YES; } -#endif traceEventRunThread(cap, t); @@ -1671,7 +1677,9 @@ delete_threads_and_gc: // fact that we've done a GC and turn off the timer signal; // it will get re-enabled if we run any threads after the GC. recent_activity = ACTIVITY_DONE_GC; +#ifndef PROFILING stopTimer(); +#endif break; } // fall through... diff --git a/rts/Schedule.h b/rts/Schedule.h index 4eb3830323..a44949ebb7 100644 --- a/rts/Schedule.h +++ b/rts/Schedule.h @@ -61,12 +61,30 @@ void scheduleWorker (Capability *cap, Task *task); extern volatile StgWord sched_state; /* - * flag that tracks whether we have done any execution in this time slice. + * flag that tracks whether we have done any execution in this time + * slice, and controls the disabling of the interval timer. + * + * The timer interrupt transitions ACTIVITY_YES into + * ACTIVITY_MAYBE_NO, waits for RtsFlags.GcFlags.idleGCDelayTime, + * and then: + * - if idle GC is no, set ACTIVITY_INACTIVE and wakeUpRts() + * - if idle GC is off, set ACTIVITY_DONE_GC and stopTimer() + * + * If the scheduler finds ACTIVITY_INACTIVE, then it sets + * ACTIVITY_DONE_GC, performs the GC and calls stopTimer(). + * + * If the scheduler finds ACTIVITY_DONE_GC and it has a thread to run, + * it enables the timer again with startTimer(). */ -#define ACTIVITY_YES 0 /* there has been activity in the current slice */ -#define ACTIVITY_MAYBE_NO 1 /* no activity in the current slice */ -#define ACTIVITY_INACTIVE 2 /* a complete slice has passed with no activity */ -#define ACTIVITY_DONE_GC 3 /* like 2, but we've done a GC too */ +#define ACTIVITY_YES 0 + // the RTS is active +#define ACTIVITY_MAYBE_NO 1 + // no activity since the last timer signal +#define ACTIVITY_INACTIVE 2 + // RtsFlags.GcFlags.idleGCDelayTime has passed with no activity +#define ACTIVITY_DONE_GC 3 + // like ACTIVITY_INACTIVE, but we've done a GC too (if idle GC is + // enabled) and the interval timer is now turned off. /* Recent activity flag. * Locks required : Transition from MAYBE_NO to INACTIVE diff --git a/rts/Timer.c b/rts/Timer.c index 3f9bc8ab0c..aa4b8d8fd7 100644 --- a/rts/Timer.c +++ b/rts/Timer.c @@ -28,10 +28,8 @@ /* ticks left before next pre-emptive context switch */ static int ticks_to_ctxt_switch = 0; -#if defined(THREADED_RTS) /* idle ticks left before we perform a GC */ static int ticks_to_gc = 0; -#endif /* * Function: handle_tick() @@ -52,8 +50,7 @@ handle_tick(int unused STG_UNUSED) } } -#if defined(THREADED_RTS) - /* + /* * If we've been inactive for idleGCDelayTime (set by +RTS * -I), tell the scheduler to wake up and do a GC, to check * for threads that are deadlocked. @@ -66,24 +63,28 @@ handle_tick(int unused STG_UNUSED) break; case ACTIVITY_MAYBE_NO: if (ticks_to_gc == 0) { - /* 0 ==> no idle GC */ - recent_activity = ACTIVITY_DONE_GC; - // disable timer signals (see #1623) - stopTimer(); - } else { - ticks_to_gc--; - if (ticks_to_gc == 0) { - ticks_to_gc = RtsFlags.GcFlags.idleGCDelayTime / - RtsFlags.MiscFlags.tickInterval; + if (RtsFlags.GcFlags.doIdleGC) { recent_activity = ACTIVITY_INACTIVE; +#ifdef THREADED_RTS wakeUpRts(); + // The scheduler will call stopTimer() when it has done + // the GC. +#endif + } else { + recent_activity = ACTIVITY_DONE_GC; + // disable timer signals (see #1623, #5991) + // but only if we're not profiling +#ifndef PROFILING + stopTimer(); +#endif } + } else { + ticks_to_gc--; } break; default: break; } -#endif } // This global counter is used to allow multiple threads to stop the diff --git a/rts/posix/Select.c b/rts/posix/Select.c index d638829fc9..3d92a4666a 100644 --- a/rts/posix/Select.c +++ b/rts/posix/Select.c @@ -221,19 +221,10 @@ awaitEvent(rtsBool wait) ptv = NULL; } - while (1) { // repeat the select on EINTR - - // Disable the timer signal while blocked in - // select(), to conserve power. (#1623, #5991) - if (wait) stopTimer(); - - numFound = select(maxfd+1, &rfd, &wfd, NULL, ptv); - - if (wait) startTimer(); - - if (numFound >= 0) break; - - if (errno != EINTR) { + /* Check for any interesting events */ + + while ((numFound = select(maxfd+1, &rfd, &wfd, NULL, ptv)) < 0) { + if (errno != EINTR) { /* Handle bad file descriptors by unblocking all the waiting threads. Why? Because a thread might have been a bit naughty and closed a file descriptor while another diff --git a/rts/sm/BlockAlloc.c b/rts/sm/BlockAlloc.c index f0f6fb551c..9f04c68a70 100644 --- a/rts/sm/BlockAlloc.c +++ b/rts/sm/BlockAlloc.c @@ -393,12 +393,18 @@ finish: // Allocate a chunk of blocks that is at least min and at most max // blocks in size. This API is used by the nursery allocator that // wants contiguous memory preferably, but doesn't require it. When -// memory is fragmented we might have lots of large chunks that are +// memory is fragmented we might have lots of chunks that are // less than a full megablock, so allowing the nursery allocator to // use these reduces fragmentation considerably. e.g. on a GHC build // with +RTS -H, I saw fragmentation go from 17MB down to 3MB on a // single compile. // +// Further to this: in #7257 there is a program that creates serious +// fragmentation such that the heap is full of tiny <4 block chains. +// The nursery allocator therefore has to use single blocks to avoid +// fragmentation, but we make sure that we allocate large blocks +// preferably if there are any. +// bdescr * allocLargeChunk (W_ min, W_ max) { diff --git a/rts/sm/Evac.c b/rts/sm/Evac.c index 867cef81fb..8be393b4bc 100644 --- a/rts/sm/Evac.c +++ b/rts/sm/Evac.c @@ -794,11 +794,11 @@ unchain_thunk_selectors(StgSelector *p, StgClosure *val) // entered, and should result in a NonTermination exception. ((StgThunk *)p)->payload[0] = val; write_barrier(); - SET_INFO(p, &stg_sel_0_upd_info); + SET_INFO((StgClosure *)p, &stg_sel_0_upd_info); } else { ((StgInd *)p)->indirectee = val; write_barrier(); - SET_INFO(p, &stg_IND_info); + SET_INFO((StgClosure *)p, &stg_IND_info); } // For the purposes of LDV profiling, we have created an @@ -885,7 +885,7 @@ selector_chain: // - if evac, we need to call evacuate(), because we // need the write-barrier stuff. // - undo the chain we've built to point to p. - SET_INFO(p, (const StgInfoTable *)info_ptr); + SET_INFO((StgClosure *)p, (const StgInfoTable *)info_ptr); *q = (StgClosure *)p; if (evac) evacuate(q); unchain_thunk_selectors(prev_thunk_selector, (StgClosure *)p); @@ -895,7 +895,7 @@ selector_chain: #else // Save the real info pointer (NOTE: not the same as get_itbl()). info_ptr = (StgWord)p->header.info; - SET_INFO(p,&stg_WHITEHOLE_info); + SET_INFO((StgClosure *)p,&stg_WHITEHOLE_info); #endif field = INFO_PTR_TO_STRUCT((StgInfoTable *)info_ptr)->layout.selector_offset; @@ -945,9 +945,9 @@ selector_loop: #ifdef PROFILING // For the purposes of LDV profiling, we have destroyed // the original selector thunk, p. - SET_INFO(p, (StgInfoTable *)info_ptr); + SET_INFO((StgClosure*)p, (StgInfoTable *)info_ptr); OVERWRITING_CLOSURE((StgClosure*)p); - SET_INFO(p, &stg_WHITEHOLE_info); + SET_INFO((StgClosure*)p, &stg_WHITEHOLE_info); #endif // the closure in val is now the "value" of the @@ -1073,7 +1073,7 @@ selector_loop: bale_out: // We didn't manage to evaluate this thunk; restore the old info // pointer. But don't forget: we still need to evacuate the thunk itself. - SET_INFO(p, (const StgInfoTable *)info_ptr); + SET_INFO((StgClosure *)p, (const StgInfoTable *)info_ptr); // THREADED_RTS: we just unlocked the thunk, so another thread // might get in and update it. copy() will lock it again and // check whether it was updated in the meantime. diff --git a/rts/sm/GC.c b/rts/sm/GC.c index 93606451cf..8b92ca82cb 100644 --- a/rts/sm/GC.c +++ b/rts/sm/GC.c @@ -290,7 +290,7 @@ GarbageCollect (nat collect_gen, // gather blocks allocated using allocatePinned() from each capability // and put them on the g0->large_object list. - collect_pinned_object_blocks(); + allocated += collect_pinned_object_blocks(); // Initialise all the generations/steps that we're collecting. for (g = 0; g <= N; g++) { @@ -578,6 +578,7 @@ GarbageCollect (nat collect_gen, freeChain(gen->large_objects); gen->large_objects = gen->scavenged_large_objects; gen->n_large_blocks = gen->n_scavenged_large_blocks; + gen->n_large_words = countOccupied(gen->large_objects); gen->n_new_large_words = 0; } else // for generations > N @@ -589,13 +590,15 @@ GarbageCollect (nat collect_gen, for (bd = gen->scavenged_large_objects; bd; bd = next) { next = bd->link; dbl_link_onto(bd, &gen->large_objects); - } + gen->n_large_words += bd->free - bd->start; + } // add the new blocks we promoted during this GC gen->n_large_blocks += gen->n_scavenged_large_blocks; } ASSERT(countBlocks(gen->large_objects) == gen->n_large_blocks); + ASSERT(countOccupied(gen->large_objects) == gen->n_large_words); gen->scavenged_large_objects = NULL; gen->n_scavenged_large_blocks = 0; diff --git a/rts/sm/GCAux.c b/rts/sm/GCAux.c index 12e106b0e0..3df36d7449 100644 --- a/rts/sm/GCAux.c +++ b/rts/sm/GCAux.c @@ -113,7 +113,7 @@ revertCAFs( void ) c != (StgIndStatic *)END_OF_STATIC_LIST; c = (StgIndStatic *)c->static_link) { - SET_INFO(c, c->saved_info); + SET_INFO((StgClosure *)c, c->saved_info); c->saved_info = NULL; // could, but not necessary: c->static_link = NULL; } diff --git a/rts/sm/Storage.c b/rts/sm/Storage.c index 541da5df1c..e5258c2517 100644 --- a/rts/sm/Storage.c +++ b/rts/sm/Storage.c @@ -78,6 +78,7 @@ initGeneration (generation *gen, int g) gen->n_old_blocks = 0; gen->large_objects = NULL; gen->n_large_blocks = 0; + gen->n_large_words = 0; gen->n_new_large_words = 0; gen->scavenged_large_objects = NULL; gen->n_scavenged_large_blocks = 0; @@ -437,16 +438,12 @@ allocNursery (bdescr *tail, W_ blocks) // tiny optimisation (~0.5%), but it's free. while (blocks > 0) { - if (blocks >= BLOCKS_PER_MBLOCK / 4) { - n = stg_min(BLOCKS_PER_MBLOCK, blocks); - bd = allocLargeChunk(16, n); // see comment with allocLargeChunk() - // NB. we want a nice power of 2 for the minimum here - n = bd->blocks; - } else { - bd = allocGroup(blocks); - n = blocks; - } - + n = stg_min(BLOCKS_PER_MBLOCK, blocks); + // allocLargeChunk will prefer large chunks, but will pick up + // small chunks if there are any available. We must allow + // single blocks here to avoid fragmentation (#7257) + bd = allocLargeChunk(1, n); + n = bd->blocks; blocks -= n; for (i = 0; i < n; i++) { @@ -767,6 +764,7 @@ allocatePinned (Capability *cap, W_ n) // g0->large_objects. if (bd != NULL) { dbl_link_onto(bd, &cap->pinned_object_blocks); + cap->total_allocated += bd->free - bd->start; } // We need to find another block. We could just allocate one, @@ -955,7 +953,7 @@ W_ countOccupied (bdescr *bd) W_ genLiveWords (generation *gen) { - return gen->n_words + countOccupied(gen->large_objects); + return gen->n_words + gen->n_large_words; } W_ genLiveBlocks (generation *gen) diff --git a/rules/build-prog.mk b/rules/build-prog.mk index 6e4bf5c18a..2a76943301 100644 --- a/rules/build-prog.mk +++ b/rules/build-prog.mk @@ -159,7 +159,7 @@ $1/$2/build/tmp/$$($1_$2_PROG) : $$($1_$2_v_HS_OBJS) $$($1_$2_v_C_OBJS) $$($1_$2 $$(call cmd,$1_$2_HC) -o $$@ $$($1_$2_v_ALL_HC_OPTS) $$(LD_OPTS) $$($1_$2_GHC_LD_OPTS) $$($1_$2_v_HS_OBJS) $$($1_$2_v_C_OBJS) $$($1_$2_v_S_OBJS) $$($1_$2_OTHER_OBJS) $$(addprefix -l,$$($1_$2_EXTRA_LIBRARIES)) else $1/$2/build/tmp/$$($1_$2_PROG) : $$($1_$2_v_HS_OBJS) $$($1_$2_v_C_OBJS) $$($1_$2_v_S_OBJS) $$($1_$2_OTHER_OBJS) | $$$$(dir $$$$@)/. - $$(call cmd,$1_$2_CC)" -o $$@ $$($1_$2_v_ALL_CC_OPTS) $$(LD_OPTS) $$($1_$2_v_HS_OBJS) $$($1_$2_v_C_OBJS) $$($1_$2_v_S_OBJS) $$($1_$2_OTHER_OBJS) $$($1_$2_v_EXTRA_CC_OPTS) $$(addprefix -l,$$($1_$2_EXTRA_LIBRARIES)) + $$(call cmd,$1_$2_CC) -o $$@ $$($1_$2_v_ALL_CC_OPTS) $$(LD_OPTS) $$($1_$2_v_HS_OBJS) $$($1_$2_v_C_OBJS) $$($1_$2_v_S_OBJS) $$($1_$2_OTHER_OBJS) $$($1_$2_v_EXTRA_CC_OPTS) $$(addprefix -l,$$($1_$2_EXTRA_LIBRARIES)) endif # Note [lib-depends] if this program is built with stage1 or greater, we @@ -184,10 +184,12 @@ endif $(call clean-target,$1,$2_inplace,$$($1_$2_INPLACE)) ifeq "$$($1_$2_INSTALL)" "YES" -ifeq "$$($1_$2_TOPDIR)" "YES" -INSTALL_TOPDIRS += $1/$2/build/tmp/$$($1_$2_PROG) +ifeq "$$($1_$2_SHELL_WRAPPER) $$(Windows)" "YES NO" +INSTALL_LIBEXECS += $1/$2/build/tmp/$$($1_$2_PROG) +else ifeq "$$($1_$2_TOPDIR)" "YES" +INSTALL_TOPDIRS += $1/$2/build/tmp/$$($1_$2_PROG) else -INSTALL_BINS += $1/$2/build/tmp/$$($1_$2_PROG) +INSTALL_BINS += $1/$2/build/tmp/$$($1_$2_PROG) endif endif diff --git a/rules/shell-wrapper.mk b/rules/shell-wrapper.mk index a291d852fe..1fab27f0c4 100644 --- a/rules/shell-wrapper.mk +++ b/rules/shell-wrapper.mk @@ -16,16 +16,7 @@ $(call profStart, shell-wrapper($1,$2)) # $1 = dir # $2 = distdir -ifeq "$$($1_$2_SHELL_WRAPPER)" "YES" - -ifeq "$$(Windows)" "YES" - -ifeq "$$($1_$2_INSTALL_SHELL_WRAPPER)" "YES" -# Just install the binary on Windows -$1_$2_INSTALL = YES -endif - -else +ifeq "$$($1_$2_SHELL_WRAPPER) $$(Windows)" "YES NO" ifeq "$$($1_$2_SHELL_WRAPPER_NAME)" "" $1_$2_SHELL_WRAPPER_NAME = $1/$$($1_$2_PROG).wrapper @@ -49,7 +40,7 @@ $$(INPLACE_BIN)/$$($1_$2_PROG): $$($1_$2_INPLACE) $$($1_$2_SHELL_WRAPPER_NAME) $$(EXECUTABLE_FILE) $$@ endif -ifeq "$$($1_$2_INSTALL_SHELL_WRAPPER)" "YES" +ifeq "$$($1_$2_INSTALL)" "YES" ifeq "$$($1_$2_INSTALL_SHELL_WRAPPER_NAME)" "" $1_$2_INSTALL_SHELL_WRAPPER_NAME = $$($1_$2_PROG) @@ -79,11 +70,9 @@ install_$1_$2_wrapper: cat $$($1_$2_SHELL_WRAPPER_NAME) >> "$$(WRAPPER)" $$(EXECUTABLE_FILE) "$$(WRAPPER)" -endif # $1_$2_INSTALL_SHELL_WRAPPER - -endif +endif # $1_$2_INSTALL -endif # $1_$2_SHELL_WRAPPER +endif # $1_$2_SHELL_WRAPPER && !Windows $(call profEnd, shell-wrapper($1,$2)) endef diff --git a/utils/ghc-pkg/ghc.mk b/utils/ghc-pkg/ghc.mk index ba553d29e9..68c63e2a1f 100644 --- a/utils/ghc-pkg/ghc.mk +++ b/utils/ghc-pkg/ghc.mk @@ -96,7 +96,7 @@ utils/ghc-pkg_PACKAGE = ghc-pkg utils/ghc-pkg_$(GHC_PKG_DISTDIR)_PROG = ghc-pkg utils/ghc-pkg_$(GHC_PKG_DISTDIR)_SHELL_WRAPPER = YES -utils/ghc-pkg_$(GHC_PKG_DISTDIR)_INSTALL_SHELL_WRAPPER = YES +utils/ghc-pkg_$(GHC_PKG_DISTDIR)_INSTALL = YES utils/ghc-pkg_$(GHC_PKG_DISTDIR)_INSTALL_SHELL_WRAPPER_NAME = ghc-pkg-$(ProjectVersion) utils/ghc-pkg_$(GHC_PKG_DISTDIR)_INSTALL_INPLACE = NO diff --git a/utils/runghc/ghc.mk b/utils/runghc/ghc.mk index 128987daf6..6ff84f0c62 100644 --- a/utils/runghc/ghc.mk +++ b/utils/runghc/ghc.mk @@ -14,7 +14,7 @@ utils/runghc_PACKAGE = runghc utils/runghc_dist-install_USES_CABAL = YES utils/runghc_dist-install_PROG = runghc$(exeext) utils/runghc_dist-install_SHELL_WRAPPER = YES -utils/runghc_dist-install_INSTALL_SHELL_WRAPPER = YES +utils/runghc_dist-install_INSTALL = YES utils/runghc_dist-install_INSTALL_SHELL_WRAPPER_NAME = runghc-$(ProjectVersion) utils/runghc_dist-install_EXTRA_HC_OPTS = -cpp -DVERSION="\"$(ProjectVersion)\"" |