diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2012-10-02 15:18:44 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2012-10-02 15:18:44 +0100 |
| commit | 74d65116e7c047215f79deb410029ba727c6df5e (patch) | |
| tree | 385ff0b5a0c0d24068b5f8b6d51e619c26756355 | |
| parent | ad0139ab1432663ce54324546162ec6edfc960a9 (diff) | |
| parent | 2d96202a780ed16219337416fd0ebc07123909ae (diff) | |
| download | haskell-74d65116e7c047215f79deb410029ba727c6df5e.tar.gz | |
Merge remote-tracking branch 'origin/master'
122 files changed, 2338 insertions, 2586 deletions
diff --git a/compiler/basicTypes/Literal.lhs b/compiler/basicTypes/Literal.lhs index 8fbcbb7a88..a590eae1b2 100644 --- a/compiler/basicTypes/Literal.lhs +++ b/compiler/basicTypes/Literal.lhs @@ -52,6 +52,7 @@ import FastString import BasicTypes import Binary import Constants +import DynFlags import UniqFM import Util @@ -216,14 +217,14 @@ instance Ord Literal where ~~~~~~~~~~~~ \begin{code} -- | Creates a 'Literal' of type @Int#@ -mkMachInt :: Integer -> Literal -mkMachInt x = ASSERT2( inIntRange x, integer x ) - MachInt x +mkMachInt :: DynFlags -> Integer -> Literal +mkMachInt dflags x = ASSERT2( inIntRange dflags x, integer x ) + MachInt x -- | Creates a 'Literal' of type @Word#@ -mkMachWord :: Integer -> Literal -mkMachWord x = ASSERT2( inWordRange x, integer x ) - MachWord x +mkMachWord :: DynFlags -> Integer -> Literal +mkMachWord dflags x = ASSERT2( inWordRange dflags x, integer x ) + MachWord x -- | Creates a 'Literal' of type @Int64#@ mkMachInt64 :: Integer -> Literal @@ -254,9 +255,9 @@ mkMachString s = MachStr (fastStringToFastBytes $ mkFastString s) mkLitInteger :: Integer -> Type -> Literal mkLitInteger = LitInteger -inIntRange, inWordRange :: Integer -> Bool -inIntRange x = x >= tARGET_MIN_INT && x <= tARGET_MAX_INT -inWordRange x = x >= 0 && x <= tARGET_MAX_WORD +inIntRange, inWordRange :: DynFlags -> Integer -> Bool +inIntRange dflags x = x >= tARGET_MIN_INT dflags && x <= tARGET_MAX_INT dflags +inWordRange dflags x = x >= 0 && x <= tARGET_MAX_WORD dflags inCharRange :: Char -> Bool inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR @@ -275,23 +276,23 @@ isZeroLit _ = False Coercions ~~~~~~~~~ \begin{code} -word2IntLit, int2WordLit, - narrow8IntLit, narrow16IntLit, narrow32IntLit, +narrow8IntLit, narrow16IntLit, narrow32IntLit, narrow8WordLit, narrow16WordLit, narrow32WordLit, char2IntLit, int2CharLit, float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit, float2DoubleLit, double2FloatLit :: Literal -> Literal -word2IntLit (MachWord w) - | w > tARGET_MAX_INT = MachInt (w - tARGET_MAX_WORD - 1) - | otherwise = MachInt w -word2IntLit l = pprPanic "word2IntLit" (ppr l) +word2IntLit, int2WordLit :: DynFlags -> Literal -> Literal +word2IntLit dflags (MachWord w) + | w > tARGET_MAX_INT dflags = MachInt (w - tARGET_MAX_WORD dflags - 1) + | otherwise = MachInt w +word2IntLit _ l = pprPanic "word2IntLit" (ppr l) -int2WordLit (MachInt i) - | i < 0 = MachWord (1 + tARGET_MAX_WORD + i) -- (-1) ---> tARGET_MAX_WORD +int2WordLit dflags (MachInt i) + | i < 0 = MachWord (1 + tARGET_MAX_WORD dflags + i) -- (-1) ---> tARGET_MAX_WORD | otherwise = MachWord i -int2WordLit l = pprPanic "int2WordLit" (ppr l) +int2WordLit _ l = pprPanic "int2WordLit" (ppr l) narrow8IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int8)) narrow8IntLit l = pprPanic "narrow8IntLit" (ppr l) @@ -343,17 +344,16 @@ litIsTrivial _ = True -- | True if code space does not go bad if we duplicate this literal -- Currently we treat it just like 'litIsTrivial' -litIsDupable :: Literal -> Bool +litIsDupable :: DynFlags -> Literal -> Bool -- c.f. CoreUtils.exprIsDupable -litIsDupable (MachStr _) = False -litIsDupable (LitInteger i _) = inIntRange i -litIsDupable _ = True +litIsDupable _ (MachStr _) = False +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/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 7bb5d160b9..1805ccd25e 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -505,14 +505,14 @@ mkDictSelId no_unf name clas -- varToCoreExpr needed for equality superclass selectors -- sel a b d = case x of { MkC _ (g:a~b) _ -> CO g } -dictSelRule :: Int -> Arity - -> Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr +dictSelRule :: Int -> Arity + -> DynFlags -> Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr -- Tries to persuade the argument to look like a constructor -- application, using exprIsConApp_maybe, and then selects -- from it -- sel_i t1..tk (D t1..tk op1 ... opm) = opi -- -dictSelRule val_index n_ty_args _ id_unf args +dictSelRule val_index n_ty_args _ _ id_unf args | (dict_arg : _) <- drop n_ty_args args , Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg = Just (con_args !! val_index) @@ -935,12 +935,13 @@ seqId = pcMiscPrelId seqName ty info , ru_try = match_seq_of_cast } -match_seq_of_cast :: Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr +match_seq_of_cast :: DynFlags -> Id -> IdUnfoldingFun -> [CoreExpr] + -> Maybe CoreExpr -- See Note [Built-in RULES for seq] -match_seq_of_cast _ _ [Type _, Type res_ty, Cast scrut co, expr] +match_seq_of_cast _ _ _ [Type _, Type res_ty, Cast scrut co, expr] = Just (Var seqId `mkApps` [Type (pFst (coercionKind co)), Type res_ty, scrut, expr]) -match_seq_of_cast _ _ _ = Nothing +match_seq_of_cast _ _ _ _ = Nothing ------------------------------------------------ lazyId :: Id -- See Note [lazyId magic] diff --git a/compiler/cmm/Bitmap.hs b/compiler/cmm/Bitmap.hs index 93217d5192..d48ab93093 100644 --- a/compiler/cmm/Bitmap.hs +++ b/compiler/cmm/Bitmap.hs @@ -39,12 +39,12 @@ type Bitmap = [StgWord] -- | Make a bitmap from a sequence of bits mkBitmap :: DynFlags -> [Bool] -> Bitmap mkBitmap _ [] = [] -mkBitmap dflags stuff = chunkToBitmap chunk : mkBitmap dflags rest +mkBitmap dflags stuff = chunkToBitmap dflags chunk : mkBitmap dflags rest where (chunk, rest) = splitAt (wORD_SIZE_IN_BITS dflags) stuff -chunkToBitmap :: [Bool] -> StgWord -chunkToBitmap chunk = - foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ] +chunkToBitmap :: DynFlags -> [Bool] -> StgWord +chunkToBitmap dflags chunk = + foldr (.|.) (toStgWord dflags 0) [ toStgWord dflags 1 `shiftL` n | (True,n) <- zip chunk [0..] ] -- | Make a bitmap where the slots specified are the /ones/ in the bitmap. -- eg. @[0,1,3], size 4 ==> 0xb@. @@ -54,7 +54,7 @@ intsToBitmap :: DynFlags -> Int -> [Int] -> Bitmap intsToBitmap dflags size slots{- must be sorted -} | size <= 0 = [] | otherwise = - (foldr (.|.) 0 (map (1 `shiftL`) these)) : + (foldr (.|.) (toStgWord dflags 0) (map (toStgWord dflags 1 `shiftL`) these)) : intsToBitmap dflags (size - wORD_SIZE_IN_BITS dflags) (map (\x -> x - wORD_SIZE_IN_BITS dflags) rest) where (these,rest) = span (< wORD_SIZE_IN_BITS dflags) slots @@ -68,12 +68,12 @@ intsToReverseBitmap :: DynFlags -> Int -> [Int] -> Bitmap intsToReverseBitmap dflags size slots{- must be sorted -} | size <= 0 = [] | otherwise = - (foldr xor init (map (1 `shiftL`) these)) : + (foldr xor (toStgWord dflags init) (map (toStgWord dflags 1 `shiftL`) these)) : intsToReverseBitmap dflags (size - wORD_SIZE_IN_BITS dflags) (map (\x -> x - wORD_SIZE_IN_BITS dflags) rest) where (these,rest) = span (< wORD_SIZE_IN_BITS dflags) slots init - | size >= wORD_SIZE_IN_BITS dflags = complement 0 + | size >= wORD_SIZE_IN_BITS dflags = -1 | otherwise = (1 `shiftL` size) - 1 {- | diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 907f8521e1..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 @@ -590,9 +588,9 @@ hasCAF _ = False needsCDecl :: CLabel -> Bool -- False <=> it's pre-declared; don't bother - -- don't bother declaring SRT & Bitmap labels, we always make sure + -- don't bother declaring Bitmap labels, we always make sure -- they are defined before use. -needsCDecl (SRTLabel _ _) = False +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 _ _) = CodeLabel +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 30e0addbdc..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,17 +229,17 @@ 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 == [fromIntegral srt_escape] + | len > maxBmpSize dflags || bmp == [toStgWord dflags (fromStgHalfWord (srtEscape dflags))] = do id <- getUniqueM let srt_desc_lbl = mkLargeSRTLabel id tbl = CmmData RelocatableReadOnlyData $ Statics srt_desc_lbl $ map CmmStaticLit ( cmmLabelOffW dflags top_srt off - : mkWordCLit dflags (fromIntegral len) + : mkWordCLit dflags (toStgWord dflags (fromIntegral len)) : map (mkWordCLit dflags) bmp) - return (Just tbl, C_SRT srt_desc_lbl 0 srt_escape) + return (Just tbl, C_SRT srt_desc_lbl 0 (srtEscape dflags)) | otherwise - = return (Nothing, C_SRT top_srt off (fromIntegral (head bmp))) + = return (Nothing, C_SRT top_srt off (toStgHalfWord dflags (fromStgWord (head bmp)))) -- The fromIntegral converts to StgHalfWord -- Gather CAF info for a procedure, but only if the procedure diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index 0735937754..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" @@ -177,19 +178,22 @@ mkInfoTableContents dflags ; let std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit rts_tag | Just tag <- mb_rts_tag = tag - | null liveness_data = rET_SMALL -- Fits in extra_bits - | otherwise = rET_BIG -- Does not; extra_bits is - -- a label + | null liveness_data = rET_SMALL dflags -- Fits in extra_bits + | otherwise = rET_BIG dflags -- Does not; extra_bits is + -- a label ; return (prof_data ++ liveness_data, (std_info, srt_label)) } | HeapRep _ ptrs nonptrs closure_type <- smrep - = do { let layout = packHalfWordsCLit dflags ptrs nonptrs + = do { let layout = packHalfWordsCLit + dflags + (toStgHalfWord dflags (toInteger ptrs)) + (toStgHalfWord dflags (toInteger nonptrs)) ; (prof_lits, prof_data) <- mkProfLits dflags prof ; let (srt_label, srt_bitmap) = mkSRTLit dflags srt ; (mb_srt_field, mb_layout, extra_bits, ct_data) <- mk_pieces closure_type srt_label ; let std_info = mkStdInfoTable dflags prof_lits - (mb_rts_tag `orElse` rtsClosureType smrep) + (mb_rts_tag `orElse` rtsClosureType dflags smrep) (mb_srt_field `orElse` srt_bitmap) (mb_layout `orElse` layout) ; return (prof_data ++ ct_data, (std_info, extra_bits)) } @@ -207,7 +211,7 @@ mkInfoTableContents dflags = return (Nothing, Nothing, srt_label, []) mk_pieces (ThunkSelector offset) _no_srt - = return (Just 0, Just (mkWordCLit dflags offset), [], []) + = return (Just (toStgHalfWord dflags 0), Just (mkWordCLit dflags offset), [], []) -- Layout known (one free var); we use the layout field for offset mk_pieces (Fun arity (ArgSpec fun_type)) srt_label @@ -216,8 +220,8 @@ mkInfoTableContents dflags mk_pieces (Fun arity (ArgGen arg_bits)) srt_label = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits - ; let fun_type | null liveness_data = aRG_GEN - | otherwise = aRG_GEN_BIG + ; let fun_type | null liveness_data = aRG_GEN dflags + | otherwise = aRG_GEN_BIG dflags extra_bits = [ packHalfWordsCLit dflags fun_type arity , srt_lit, liveness_lit, slow_entry ] ; return (Nothing, Nothing, extra_bits, liveness_data) } @@ -236,7 +240,7 @@ mkSRTLit :: DynFlags -> C_SRT -> ([CmmLit], -- srt_label, if any StgHalfWord) -- srt_bitmap -mkSRTLit _ NoC_SRT = ([], 0) +mkSRTLit dflags NoC_SRT = ([], toStgHalfWord dflags 0) mkSRTLit dflags (C_SRT lbl off bitmap) = ([cmmLabelOffW dflags lbl off], bitmap) @@ -318,13 +322,13 @@ mkLivenessBits dflags liveness bitmap = mkBitmap dflags liveness small_bitmap = case bitmap of - [] -> 0 + [] -> toStgWord dflags 0 [b] -> b _ -> panic "mkLiveness" - bitmap_word = fromIntegral n_bits + bitmap_word = toStgWord dflags (fromIntegral n_bits) .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags) - lits = mkWordCLit dflags (fromIntegral n_bits) : map (mkWordCLit dflags) bitmap + lits = mkWordCLit dflags (toStgWord dflags (fromIntegral n_bits)) : map (mkWordCLit dflags) bitmap -- The first word is the size. The structure must match -- StgLargeBitmap in includes/rts/storage/InfoTable.h @@ -381,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/CmmParse.y b/compiler/cmm/CmmParse.y index 3061062a4c..8c3559b774 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -259,12 +259,12 @@ cmmproc :: { ExtCode } code (emitProc Nothing (mkCmmCodeLabel pkg $1) formals blks) } info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } - : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' + : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' stgHalfWord ',' STRING ',' STRING ')' -- ptrs, nptrs, closure type, description, type {% withThisPackage $ \pkg -> do dflags <- getDynFlags let prof = profilingInfo dflags $11 $13 - rep = mkRTSRep (fromIntegral $9) $ + rep = mkRTSRep $9 $ mkHeapRep dflags False (fromIntegral $5) (fromIntegral $7) Thunk -- not really Thunk, but that makes the info table @@ -275,14 +275,14 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } , cit_prof = prof, cit_srt = NoC_SRT }, []) } - | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')' + | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' stgHalfWord ',' STRING ',' STRING ',' stgHalfWord ')' -- ptrs, nptrs, closure type, description, type, fun type {% withThisPackage $ \pkg -> do dflags <- getDynFlags let prof = profilingInfo dflags $11 $13 - ty = Fun 0 (ArgSpec (fromIntegral $15)) + ty = Fun (toStgHalfWord dflags 0) (ArgSpec $15) -- Arity zero, arg_type $15 - rep = mkRTSRep (fromIntegral $9) $ + rep = mkRTSRep $9 $ mkHeapRep dflags False (fromIntegral $5) (fromIntegral $7) ty return (mkCmmEntryLabel pkg $3, @@ -293,14 +293,14 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } -- we leave most of the fields zero here. This is only used -- to generate the BCO info table in the RTS at the moment. - | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' + | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' stgHalfWord ',' stgHalfWord ',' STRING ',' STRING ')' -- ptrs, nptrs, tag, closure type, description, type {% withThisPackage $ \pkg -> do dflags <- getDynFlags let prof = profilingInfo dflags $13 $15 - ty = Constr (fromIntegral $9) -- Tag + ty = Constr $9 -- Tag (stringToWord8s $13) - rep = mkRTSRep (fromIntegral $11) $ + rep = mkRTSRep $11 $ mkHeapRep dflags False (fromIntegral $5) (fromIntegral $7) ty return (mkCmmEntryLabel pkg $3, @@ -312,13 +312,13 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } -- If profiling is on, this string gets duplicated, -- but that's the way the old code did it we can fix it some other time. - | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')' + | 'INFO_TABLE_SELECTOR' '(' NAME ',' stgWord ',' stgHalfWord ',' STRING ',' STRING ')' -- selector, closure type, description, type {% withThisPackage $ \pkg -> do dflags <- getDynFlags let prof = profilingInfo dflags $9 $11 - ty = ThunkSelector (fromIntegral $5) - rep = mkRTSRep (fromIntegral $7) $ + ty = ThunkSelector $5 + rep = mkRTSRep $7 $ mkHeapRep dflags False 0 0 ty return (mkCmmEntryLabel pkg $3, CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 @@ -326,25 +326,25 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } , cit_prof = prof, cit_srt = NoC_SRT }, []) } - | 'INFO_TABLE_RET' '(' NAME ',' INT ')' + | 'INFO_TABLE_RET' '(' NAME ',' stgHalfWord ')' -- closure type (no live regs) {% withThisPackage $ \pkg -> do let prof = NoProfilingInfo - rep = mkRTSRep (fromIntegral $5) $ mkStackRep [] + rep = mkRTSRep $5 $ mkStackRep [] return (mkCmmRetLabel pkg $3, CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 , cit_rep = rep , cit_prof = prof, cit_srt = NoC_SRT }, []) } - | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals_without_hints0 ')' + | 'INFO_TABLE_RET' '(' NAME ',' stgHalfWord ',' formals_without_hints0 ')' -- closure type, live regs {% withThisPackage $ \pkg -> do dflags <- getDynFlags live <- sequence (map (liftM Just) $7) let prof = NoProfilingInfo bitmap = mkLiveness dflags live - rep = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap + rep = mkRTSRep $5 $ mkStackRep bitmap return (mkCmmRetLabel pkg $3, CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 , cit_rep = rep @@ -613,6 +613,13 @@ typenot8 :: { CmmType } | 'float32' { f32 } | 'float64' { f64 } | 'gcptr' {% do dflags <- getDynFlags; return $ gcWord dflags } + +stgWord :: { StgWord } + : INT {% do dflags <- getDynFlags; return $ toStgWord dflags $1 } + +stgHalfWord :: { StgHalfWord } + : INT {% do dflags <- getDynFlags; return $ toStgHalfWord dflags $1 } + { section :: String -> Section section "text" = Text diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index 76927266ad..5fca9e7164 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -82,7 +82,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) return call_pps let noncall_pps = proc_points `setDifference` call_pps - when (not (setNull noncall_pps)) $ + when (not (setNull noncall_pps) && dopt Opt_D_dump_cmmz dflags) $ pprTrace "Non-call proc points: " (ppr noncall_pps) $ return () ----------- Sink and inline assignments *before* stack layout ----------- @@ -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 c0ce9e3d88..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 @@ -104,9 +107,9 @@ bHalfWord dflags = cmmBits (halfWordWidth dflags) gcWord :: DynFlags -> CmmType gcWord dflags = CmmType GcPtrCat (wordWidth dflags) -cInt, cLong :: CmmType -cInt = cmmBits cIntWidth -cLong = cmmBits cLongWidth +cInt, cLong :: DynFlags -> CmmType +cInt dflags = cmmBits (cIntWidth dflags) +cLong dflags = cmmBits (cLongWidth dflags) ------------ Predicates ---------------- @@ -178,18 +181,15 @@ halfWordMask dflags | otherwise = panic "MachOp.halfWordMask: Unknown word size" -- cIntRep is the Width for a C-language 'int' -cIntWidth, cLongWidth :: Width -#if SIZEOF_INT == 4 -cIntWidth = W32 -#elif SIZEOF_INT == 8 -cIntWidth = W64 -#endif - -#if SIZEOF_LONG == 4 -cLongWidth = W32 -#elif SIZEOF_LONG == 8 -cLongWidth = W64 -#endif +cIntWidth, cLongWidth :: DynFlags -> Width +cIntWidth dflags = case cINT_SIZE dflags of + 4 -> W32 + 8 -> W64 + s -> panic ("cIntWidth: Unknown cINT_SIZE: " ++ show s) +cLongWidth dflags = case cLONG_SIZE dflags of + 4 -> W32 + 8 -> W64 + s -> panic ("cIntWidth: Unknown cLONG_SIZE: " ++ show s) widthInBits :: Width -> Int widthInBits W8 = 8 @@ -242,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/CmmUtils.hs b/compiler/cmm/CmmUtils.hs index bff4804fc2..bf93a2f6ff 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -156,22 +156,20 @@ mkRODataLits lbl lits needsRelocation _ = False mkWordCLit :: DynFlags -> StgWord -> CmmLit -mkWordCLit dflags wd = CmmInt (fromIntegral wd) (wordWidth dflags) +mkWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags) -packHalfWordsCLit :: (Integral a, Integral b) => DynFlags -> a -> b -> CmmLit +packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit -- Make a single word literal in which the lower_half_word is -- at the lower address, and the upper_half_word is at the -- higher address -- ToDo: consider using half-word lits instead -- but be careful: that's vulnerable when reversed packHalfWordsCLit dflags lower_half_word upper_half_word -#ifdef WORDS_BIGENDIAN - = mkWordCLit dflags ((fromIntegral lower_half_word `shiftL` hALF_WORD_SIZE_IN_BITS) - .|. fromIntegral upper_half_word) -#else - = mkWordCLit dflags ((fromIntegral lower_half_word) - .|. (fromIntegral upper_half_word `shiftL` hALF_WORD_SIZE_IN_BITS)) -#endif + = if wORDS_BIGENDIAN dflags + then mkWordCLit dflags ((l `shiftL` hALF_WORD_SIZE_IN_BITS dflags) .|. u) + else mkWordCLit dflags (l .|. (u `shiftL` hALF_WORD_SIZE_IN_BITS dflags)) + where l = toStgWord dflags (fromStgHalfWord lower_half_word) + u = toStgWord dflags (fromStgHalfWord upper_half_word) --------------------------------------------------- -- 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/PprC.hs b/compiler/cmm/PprC.hs index bb2f189e14..1a3eb0d716 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -492,13 +492,11 @@ pprStatics dflags (CmmStaticLit (CmmFloat f W64) : rest) = map pprLit1 (doubleToWords dflags f) ++ pprStatics dflags rest pprStatics dflags (CmmStaticLit (CmmInt i W64) : rest) | wordWidth dflags == W32 -#ifdef WORDS_BIGENDIAN - = pprStatics dflags (CmmStaticLit (CmmInt q W32) : - CmmStaticLit (CmmInt r W32) : rest) -#else - = pprStatics dflags (CmmStaticLit (CmmInt r W32) : - CmmStaticLit (CmmInt q W32) : rest) -#endif + = if wORDS_BIGENDIAN dflags + then pprStatics dflags (CmmStaticLit (CmmInt q W32) : + CmmStaticLit (CmmInt r W32) : rest) + else pprStatics dflags (CmmStaticLit (CmmInt r W32) : + CmmStaticLit (CmmInt q W32) : rest) where r = i .&. 0xffffffff q = i `shiftR` 32 pprStatics dflags (CmmStaticLit (CmmInt _ w) : _) diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs index ab320b4100..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 @@ -127,7 +125,7 @@ pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep instance Outputable C_SRT where ppr NoC_SRT = ptext (sLit "_no_srt_") ppr (C_SRT label off bitmap) - = parens (ppr label <> comma <> ppr off <> comma <> text (show bitmap)) + = parens (ppr label <> comma <> ppr off <> comma <> ppr bitmap) instance Outputable ForeignHint where ppr NoHint = empty @@ -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/cmm/SMRep.lhs b/compiler/cmm/SMRep.lhs index 2c9cb32ec0..d9644488fc 100644 --- a/compiler/cmm/SMRep.lhs +++ b/compiler/cmm/SMRep.lhs @@ -9,9 +9,12 @@ This is here, rather than in ClosureInfo, just to keep nhc happy. Other modules should access this info through ClosureInfo. \begin{code} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module SMRep ( -- * Words and bytes - StgWord, StgHalfWord, + StgWord, fromStgWord, toStgWord, + StgHalfWord, fromStgHalfWord, toStgHalfWord, hALF_WORD_SIZE, hALF_WORD_SIZE_IN_BITS, WordOff, ByteOff, roundUpToWords, @@ -46,8 +49,10 @@ module SMRep ( import DynFlags import Outputable +import Platform import FastString +import Data.Array.Base import Data.Char( ord ) import Data.Word import Data.Bits @@ -71,23 +76,55 @@ roundUpToWords dflags n = (n + (wORD_SIZE dflags - 1)) .&. (complement (wORD_SIZ StgWord is a type representing an StgWord on the target platform. \begin{code} -#if SIZEOF_HSWORD == 4 -type StgWord = Word32 -type StgHalfWord = Word16 -hALF_WORD_SIZE :: ByteOff -hALF_WORD_SIZE = 2 -hALF_WORD_SIZE_IN_BITS :: Int -hALF_WORD_SIZE_IN_BITS = 16 -#elif SIZEOF_HSWORD == 8 -type StgWord = Word64 -type StgHalfWord = Word32 -hALF_WORD_SIZE :: ByteOff -hALF_WORD_SIZE = 4 -hALF_WORD_SIZE_IN_BITS :: Int -hALF_WORD_SIZE_IN_BITS = 32 -#else -#error unknown SIZEOF_HSWORD +-- A Word64 is large enough to hold a Word for either a 32bit or 64bit platform +newtype StgWord = StgWord Word64 + deriving (Eq, +#if __GLASGOW_HASKELL__ < 706 + Num, #endif + Bits, IArray UArray) + +fromStgWord :: StgWord -> Integer +fromStgWord (StgWord i) = toInteger i + +toStgWord :: DynFlags -> Integer -> StgWord +toStgWord dflags i + = case platformWordSize (targetPlatform dflags) of + -- These conversions mean that things like toStgWord (-1) + -- do the right thing + 4 -> StgWord (fromIntegral (fromInteger i :: Word32)) + 8 -> StgWord (fromInteger i :: Word64) + w -> panic ("toStgWord: Unknown platformWordSize: " ++ show w) + +instance Outputable StgWord where + ppr (StgWord i) = integer (toInteger i) + +-- + +-- A Word32 is large enough to hold half a Word for either a 32bit or +-- 64bit platform +newtype StgHalfWord = StgHalfWord Word32 + deriving Eq + +fromStgHalfWord :: StgHalfWord -> Integer +fromStgHalfWord (StgHalfWord w) = toInteger w + +toStgHalfWord :: DynFlags -> Integer -> StgHalfWord +toStgHalfWord dflags i + = case platformWordSize (targetPlatform dflags) of + -- These conversions mean that things like toStgHalfWord (-1) + -- do the right thing + 4 -> StgHalfWord (fromIntegral (fromInteger i :: Word16)) + 8 -> StgHalfWord (fromInteger i :: Word32) + w -> panic ("toStgHalfWord: Unknown platformWordSize: " ++ show w) + +instance Outputable StgHalfWord where + ppr (StgHalfWord w) = integer (toInteger w) + +hALF_WORD_SIZE :: DynFlags -> ByteOff +hALF_WORD_SIZE dflags = platformWordSize (targetPlatform dflags) `shiftR` 1 +hALF_WORD_SIZE_IN_BITS :: DynFlags -> Int +hALF_WORD_SIZE_IN_BITS dflags = platformWordSize (targetPlatform dflags) `shiftL` 2 \end{code} @@ -277,49 +314,52 @@ closureTypeHdrSize dflags ty = case ty of -- Defines CONSTR, CONSTR_1_0 etc -- | Derives the RTS closure type from an 'SMRep' -rtsClosureType :: SMRep -> StgHalfWord -rtsClosureType (RTSRep ty _) = ty - -rtsClosureType (HeapRep False 1 0 Constr{}) = CONSTR_1_0 -rtsClosureType (HeapRep False 0 1 Constr{}) = CONSTR_0_1 -rtsClosureType (HeapRep False 2 0 Constr{}) = CONSTR_2_0 -rtsClosureType (HeapRep False 1 1 Constr{}) = CONSTR_1_1 -rtsClosureType (HeapRep False 0 2 Constr{}) = CONSTR_0_2 -rtsClosureType (HeapRep False _ _ Constr{}) = CONSTR - -rtsClosureType (HeapRep False 1 0 Fun{}) = FUN_1_0 -rtsClosureType (HeapRep False 0 1 Fun{}) = FUN_0_1 -rtsClosureType (HeapRep False 2 0 Fun{}) = FUN_2_0 -rtsClosureType (HeapRep False 1 1 Fun{}) = FUN_1_1 -rtsClosureType (HeapRep False 0 2 Fun{}) = FUN_0_2 -rtsClosureType (HeapRep False _ _ Fun{}) = FUN - -rtsClosureType (HeapRep False 1 0 Thunk{}) = THUNK_1_0 -rtsClosureType (HeapRep False 0 1 Thunk{}) = THUNK_0_1 -rtsClosureType (HeapRep False 2 0 Thunk{}) = THUNK_2_0 -rtsClosureType (HeapRep False 1 1 Thunk{}) = THUNK_1_1 -rtsClosureType (HeapRep False 0 2 Thunk{}) = THUNK_0_2 -rtsClosureType (HeapRep False _ _ Thunk{}) = THUNK - -rtsClosureType (HeapRep False _ _ ThunkSelector{}) = THUNK_SELECTOR - --- Approximation: we use the CONSTR_NOCAF_STATIC type for static constructors --- that have no pointer words only. -rtsClosureType (HeapRep True 0 _ Constr{}) = CONSTR_NOCAF_STATIC -- See isStaticNoCafCon below -rtsClosureType (HeapRep True _ _ Constr{}) = CONSTR_STATIC -rtsClosureType (HeapRep True _ _ Fun{}) = FUN_STATIC -rtsClosureType (HeapRep True _ _ Thunk{}) = THUNK_STATIC - -rtsClosureType (HeapRep False _ _ BlackHole{}) = BLACKHOLE - -rtsClosureType _ = panic "rtsClosureType" +rtsClosureType :: DynFlags -> SMRep -> StgHalfWord +rtsClosureType dflags rep + = toStgHalfWord dflags + $ case rep of + RTSRep ty _ -> fromStgHalfWord ty + + HeapRep False 1 0 Constr{} -> CONSTR_1_0 + HeapRep False 0 1 Constr{} -> CONSTR_0_1 + HeapRep False 2 0 Constr{} -> CONSTR_2_0 + HeapRep False 1 1 Constr{} -> CONSTR_1_1 + HeapRep False 0 2 Constr{} -> CONSTR_0_2 + HeapRep False _ _ Constr{} -> CONSTR + + HeapRep False 1 0 Fun{} -> FUN_1_0 + HeapRep False 0 1 Fun{} -> FUN_0_1 + HeapRep False 2 0 Fun{} -> FUN_2_0 + HeapRep False 1 1 Fun{} -> FUN_1_1 + HeapRep False 0 2 Fun{} -> FUN_0_2 + HeapRep False _ _ Fun{} -> FUN + + HeapRep False 1 0 Thunk{} -> THUNK_1_0 + HeapRep False 0 1 Thunk{} -> THUNK_0_1 + HeapRep False 2 0 Thunk{} -> THUNK_2_0 + HeapRep False 1 1 Thunk{} -> THUNK_1_1 + HeapRep False 0 2 Thunk{} -> THUNK_0_2 + HeapRep False _ _ Thunk{} -> THUNK + + HeapRep False _ _ ThunkSelector{} -> THUNK_SELECTOR + + -- Approximation: we use the CONSTR_NOCAF_STATIC type for static + -- constructors -- that have no pointer words only. + HeapRep True 0 _ Constr{} -> CONSTR_NOCAF_STATIC -- See isStaticNoCafCon below + HeapRep True _ _ Constr{} -> CONSTR_STATIC + HeapRep True _ _ Fun{} -> FUN_STATIC + HeapRep True _ _ Thunk{} -> THUNK_STATIC + + HeapRep False _ _ BlackHole{} -> BLACKHOLE + + _ -> panic "rtsClosureType" -- We export these ones -rET_SMALL, rET_BIG, aRG_GEN, aRG_GEN_BIG :: StgHalfWord -rET_SMALL = RET_SMALL -rET_BIG = RET_BIG -aRG_GEN = ARG_GEN -aRG_GEN_BIG = ARG_GEN_BIG +rET_SMALL, rET_BIG, aRG_GEN, aRG_GEN_BIG :: DynFlags -> StgHalfWord +rET_SMALL dflags = toStgHalfWord dflags RET_SMALL +rET_BIG dflags = toStgHalfWord dflags RET_BIG +aRG_GEN dflags = toStgHalfWord dflags ARG_GEN +aRG_GEN_BIG dflags = toStgHalfWord dflags ARG_GEN_BIG \end{code} Note [Static NoCaf constructors] @@ -360,22 +400,22 @@ instance Outputable SMRep where ppr (RTSRep ty rep) = ptext (sLit "tag:") <> ppr ty <+> ppr rep instance Outputable ArgDescr where - ppr (ArgSpec n) = ptext (sLit "ArgSpec") <+> integer (toInteger n) + ppr (ArgSpec n) = ptext (sLit "ArgSpec") <+> ppr n ppr (ArgGen ls) = ptext (sLit "ArgGen") <+> ppr ls pprTypeInfo :: ClosureTypeInfo -> SDoc pprTypeInfo (Constr tag descr) = ptext (sLit "Con") <+> - braces (sep [ ptext (sLit "tag:") <+> integer (toInteger tag) + braces (sep [ ptext (sLit "tag:") <+> ppr tag , ptext (sLit "descr:") <> text (show descr) ]) pprTypeInfo (Fun arity args) = ptext (sLit "Fun") <+> - braces (sep [ ptext (sLit "arity:") <+> integer (toInteger arity) + braces (sep [ ptext (sLit "arity:") <+> ppr arity , ptext (sLit ("fun_type:")) <+> ppr args ]) pprTypeInfo (ThunkSelector offset) - = ptext (sLit "ThunkSel") <+> integer (toInteger offset) + = ptext (sLit "ThunkSel") <+> ppr offset pprTypeInfo Thunk = ptext (sLit "Thunk") pprTypeInfo BlackHole = ptext (sLit "BlackHole") diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs index 45edd64666..1f5b711d86 100644 --- a/compiler/codeGen/CgCallConv.hs +++ b/compiler/codeGen/CgCallConv.hs @@ -70,7 +70,7 @@ mkArgDescr _nm args let arg_bits = argBits dflags arg_reps arg_reps = filter nonVoidArg (map idCgRep args) -- Getting rid of voids eases matching of standard patterns - case stdPattern arg_reps of + case stdPattern dflags arg_reps of Just spec_id -> return (ArgSpec spec_id) Nothing -> return (ArgGen arg_bits) @@ -79,33 +79,36 @@ argBits _ [] = [] argBits dflags (PtrArg : args) = False : argBits dflags args argBits dflags (arg : args) = take (cgRepSizeW dflags arg) (repeat True) ++ argBits dflags args -stdPattern :: [CgRep] -> Maybe StgHalfWord -stdPattern [] = Just ARG_NONE -- just void args, probably - -stdPattern [PtrArg] = Just ARG_P -stdPattern [FloatArg] = Just ARG_F -stdPattern [DoubleArg] = Just ARG_D -stdPattern [LongArg] = Just ARG_L -stdPattern [NonPtrArg] = Just ARG_N - -stdPattern [NonPtrArg,NonPtrArg] = Just ARG_NN -stdPattern [NonPtrArg,PtrArg] = Just ARG_NP -stdPattern [PtrArg,NonPtrArg] = Just ARG_PN -stdPattern [PtrArg,PtrArg] = Just ARG_PP - -stdPattern [NonPtrArg,NonPtrArg,NonPtrArg] = Just ARG_NNN -stdPattern [NonPtrArg,NonPtrArg,PtrArg] = Just ARG_NNP -stdPattern [NonPtrArg,PtrArg,NonPtrArg] = Just ARG_NPN -stdPattern [NonPtrArg,PtrArg,PtrArg] = Just ARG_NPP -stdPattern [PtrArg,NonPtrArg,NonPtrArg] = Just ARG_PNN -stdPattern [PtrArg,NonPtrArg,PtrArg] = Just ARG_PNP -stdPattern [PtrArg,PtrArg,NonPtrArg] = Just ARG_PPN -stdPattern [PtrArg,PtrArg,PtrArg] = Just ARG_PPP - -stdPattern [PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPP -stdPattern [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPPP -stdPattern [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPPPP -stdPattern _ = Nothing +stdPattern :: DynFlags -> [CgRep] -> Maybe StgHalfWord +stdPattern dflags reps + = fmap (toStgHalfWord dflags) + $ case reps of + [] -> Just ARG_NONE -- just void args, probably + + [PtrArg] -> Just ARG_P + [FloatArg] -> Just ARG_F + [DoubleArg] -> Just ARG_D + [LongArg] -> Just ARG_L + [NonPtrArg] -> Just ARG_N + + [NonPtrArg,NonPtrArg] -> Just ARG_NN + [NonPtrArg,PtrArg] -> Just ARG_NP + [PtrArg,NonPtrArg] -> Just ARG_PN + [PtrArg,PtrArg] -> Just ARG_PP + + [NonPtrArg,NonPtrArg,NonPtrArg] -> Just ARG_NNN + [NonPtrArg,NonPtrArg,PtrArg] -> Just ARG_NNP + [NonPtrArg,PtrArg,NonPtrArg] -> Just ARG_NPN + [NonPtrArg,PtrArg,PtrArg] -> Just ARG_NPP + [PtrArg,NonPtrArg,NonPtrArg] -> Just ARG_PNN + [PtrArg,NonPtrArg,PtrArg] -> Just ARG_PNP + [PtrArg,PtrArg,NonPtrArg] -> Just ARG_PPN + [PtrArg,PtrArg,PtrArg] -> Just ARG_PPP + + [PtrArg,PtrArg,PtrArg,PtrArg] -> Just ARG_PPPP + [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] -> Just ARG_PPPPP + [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] -> Just ARG_PPPPPP + _ -> Nothing ------------------------------------------------------------------------- @@ -118,13 +121,13 @@ stdPattern _ = Nothing -- GET_NON_PTRS(), GET_PTRS(), GET_LIVENESS(). ------------------------------------------------------------------------- -mkRegLiveness :: [(Id, GlobalReg)] -> Int -> Int -> StgWord -mkRegLiveness regs ptrs nptrs - = (fromIntegral nptrs `shiftL` 16) .|. - (fromIntegral ptrs `shiftL` 24) .|. - all_non_ptrs `xor` reg_bits regs +mkRegLiveness :: DynFlags -> [(Id, GlobalReg)] -> Int -> Int -> StgWord +mkRegLiveness dflags regs ptrs nptrs + = (toStgWord dflags (toInteger nptrs) `shiftL` 16) .|. + (toStgWord dflags (toInteger ptrs) `shiftL` 24) .|. + all_non_ptrs `xor` toStgWord dflags (reg_bits regs) where - all_non_ptrs = 0xff + all_non_ptrs = toStgWord dflags 0xff reg_bits [] = 0 reg_bits ((id, VanillaReg i _) : regs) | isFollowableArg (idCgRep id) diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs index c7f6f294ce..965abf0db8 100644 --- a/compiler/codeGen/CgHeapery.lhs +++ b/compiler/codeGen/CgHeapery.lhs @@ -416,7 +416,7 @@ unbxTupleHeapCheck regs ptrs nptrs fail_code code ; let full_fail_code = fail_code `plusStmts` oneStmt assign_liveness assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9 VNonGcPtr)) -- Ho ho ho! (CmmLit (mkWordCLit dflags liveness)) - liveness = mkRegLiveness regs ptrs nptrs + liveness = mkRegLiveness dflags regs ptrs nptrs live = Just $ map snd regs rts_label = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_ut"))) ; codeOnly $ do { do_checks 0 {- no stack check -} hpHw diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index e2a3aa2efd..94301af6ef 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -263,7 +263,7 @@ stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags stdSrtBitmapOffset :: DynFlags -> ByteOff -- Byte offset of the SRT bitmap half-word which is -- in the *higher-addressed* part of the type_lit -stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE +stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE dflags stdClosureTypeOffset :: DynFlags -> ByteOff -- Byte offset of the closure type half-word @@ -271,7 +271,7 @@ stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags -stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE +stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE dflags ------------------------------------------------------------------------- -- diff --git a/compiler/codeGen/CgParallel.hs b/compiler/codeGen/CgParallel.hs index c86ef9e34a..fdc9846694 100644 --- a/compiler/codeGen/CgParallel.hs +++ b/compiler/codeGen/CgParallel.hs @@ -51,12 +51,11 @@ granFetchAndReschedule :: [(Id,GlobalReg)] -- Live registers -- Emit code for simulating a fetch and then reschedule. granFetchAndReschedule regs node_reqd = do dflags <- getDynFlags + let liveness = mkRegLiveness dflags regs 0 0 when (dopt Opt_GranMacros dflags && (node `elem` map snd regs || node_reqd)) $ do fetch reschedule liveness node_reqd - where - liveness = mkRegLiveness regs 0 0 fetch :: FCode () fetch = panic "granFetch" @@ -90,9 +89,8 @@ granYield :: [(Id,GlobalReg)] -- Live registers granYield regs node_reqd = do dflags <- getDynFlags + let liveness = mkRegLiveness dflags regs 0 0 when (dopt Opt_GranMacros dflags && node_reqd) $ yield liveness - where - liveness = mkRegLiveness regs 0 0 yield :: StgWord -> Code yield _liveness = panic "granYield" diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs index 6d87ee7127..c124b5f68a 100644 --- a/compiler/codeGen/CgProf.hs +++ b/compiler/codeGen/CgProf.hs @@ -23,13 +23,6 @@ module CgProf ( ) where #include "HsVersions.h" -#include "../includes/MachDeps.h" - -- For WORD_SIZE_IN_BITS only. -#include "../includes/rts/Constants.h" - -- For LDV_CREATE_MASK, LDV_STATE_USE - -- which are StgWords -#include "../includes/dist-derivedconstants/header/DerivedConstants.h" - -- For REP_xxx constants, which are MachReps import ClosureInfo import CgUtils @@ -115,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) $ @@ -122,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 @@ -220,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 @@ -244,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 ----------------------------------------------------------------------------- @@ -265,8 +257,8 @@ staticLdvInit = zeroCLit dynLdvInit :: DynFlags -> CmmExpr dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE CmmMachOp (mo_wordOr dflags) [ - CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags lDV_SHIFT ], - CmmLit (mkWordCLit dflags lDV_STATE_CREATE) + CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)], + CmmLit (mkWordCLit dflags (lDV_STATE_CREATE dflags)) ] -- @@ -297,8 +289,8 @@ ldvEnter cl_ptr = do -- don't forget to substract node's tag ldv_wd = ldvWord dflags cl_ptr new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags)) - (CmmLit (mkWordCLit dflags lDV_CREATE_MASK))) - (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags lDV_STATE_USE))) + (CmmLit (mkWordCLit dflags (lDV_CREATE_MASK dflags)))) + (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (lDV_STATE_USE dflags)))) ifProfiling $ -- if (era > 0) { -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) | @@ -307,8 +299,8 @@ ldvEnter cl_ptr = do (stmtC (CmmStore ldv_wd new_ldv_wd)) loadEra :: DynFlags -> CmmExpr -loadEra dflags = CmmMachOp (MO_UU_Conv cIntWidth (wordWidth dflags)) - [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId $ fsLit("era"))) cInt] +loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags)) + [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId $ fsLit("era"))) (cInt dflags)] ldvWord :: DynFlags -> CmmExpr -> CmmExpr -- Takes the address of a closure, and returns @@ -316,17 +308,10 @@ ldvWord :: DynFlags -> CmmExpr -> CmmExpr ldvWord dflags closure_ptr = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags) --- LDV constants, from ghc/includes/Constants.h -lDV_SHIFT :: Int -lDV_SHIFT = LDV_SHIFT ---lDV_STATE_MASK :: StgWord ---lDV_STATE_MASK = LDV_STATE_MASK -lDV_CREATE_MASK :: StgWord -lDV_CREATE_MASK = LDV_CREATE_MASK ---lDV_LAST_MASK :: StgWord ---lDV_LAST_MASK = LDV_LAST_MASK -lDV_STATE_CREATE :: StgWord -lDV_STATE_CREATE = LDV_STATE_CREATE -lDV_STATE_USE :: StgWord -lDV_STATE_USE = LDV_STATE_USE +lDV_CREATE_MASK :: DynFlags -> StgWord +lDV_CREATE_MASK dflags = toStgWord dflags (iLDV_CREATE_MASK dflags) +lDV_STATE_CREATE :: DynFlags -> StgWord +lDV_STATE_CREATE dflags = toStgWord dflags (iLDV_STATE_CREATE dflags) +lDV_STATE_USE :: DynFlags -> StgWord +lDV_STATE_USE dflags = toStgWord dflags (iLDV_STATE_USE dflags) diff --git a/compiler/codeGen/CgTicky.hs b/compiler/codeGen/CgTicky.hs index 9e981755be..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,13 +295,13 @@ 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 - addToMemLbl cLongWidth (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_ctr") 1, + addToMemLbl (cLongWidth dflags) (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_ctr") 1, -- Bump ALLOC_HEAP_tot - addToMemLbl cLongWidth (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_tot") hp] } + addToMemLbl (cLongWidth dflags) (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_tot") hp] } -- ----------------------------------------------------------------------------- -- Ticky utils @@ -323,7 +320,8 @@ bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkCmmDataLabel rtsPackag bumpTickyCounter' :: CmmLit -> Code -- krc: note that we're incrementing the _entry_count_ field of the ticky counter -bumpTickyCounter' lhs = stmtC (addToMemLong (CmmLit lhs) 1) +bumpTickyCounter' lhs = do dflags <- getDynFlags + stmtC (addToMemLong dflags (CmmLit lhs) 1) bumpHistogram :: FastString -> Int -> Code bumpHistogram _lbl _n @@ -346,8 +344,8 @@ bumpHistogramE lbl n -} ------------------------------------------------------------------ -addToMemLong :: CmmExpr -> Int -> CmmStmt -addToMemLong = addToMem cLongWidth +addToMemLong :: DynFlags -> CmmExpr -> Int -> CmmStmt +addToMemLong dflags = addToMem (cLongWidth dflags) ------------------------------------------------------------------ -- Showing the "type category" for ticky-ticky profiling diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index c52c8a8c99..3a106abfb4 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -795,21 +795,21 @@ getSRTInfo = do NoSRT -> return NoC_SRT SRTEntries {} -> panic "getSRTInfo: SRTEntries. Perhaps you forgot to run SimplStg?" SRT off len bmp - | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape] + | len > hALF_WORD_SIZE_IN_BITS dflags || bmp == [toStgWord dflags (fromStgHalfWord (srt_escape dflags))] -> do id <- newUnique let srt_desc_lbl = mkLargeSRTLabel id emitRODataLits "getSRTInfo" srt_desc_lbl ( cmmLabelOffW dflags srt_lbl off - : mkWordCLit dflags (fromIntegral len) + : mkWordCLit dflags (toStgWord dflags (toInteger len)) : map (mkWordCLit dflags) bmp) - return (C_SRT srt_desc_lbl 0 srt_escape) + return (C_SRT srt_desc_lbl 0 (srt_escape dflags)) | otherwise - -> return (C_SRT srt_lbl off (fromIntegral (head bmp))) + -> return (C_SRT srt_lbl off (toStgHalfWord dflags (fromStgWord (head bmp)))) -- The fromIntegral converts to StgHalfWord -srt_escape :: StgHalfWord -srt_escape = -1 +srt_escape :: DynFlags -> StgHalfWord +srt_escape dflags = toStgHalfWord dflags (-1) -- ----------------------------------------------------------------------------- -- diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index 7a72a00602..740bfab845 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -480,7 +480,7 @@ mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds srt_info descr -- anything else gets eta expanded. where name = idName id - sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info) + sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType dflags lf_info) nonptr_wds = tot_wds - ptr_wds mkConInfo :: DynFlags @@ -492,7 +492,7 @@ mkConInfo dflags is_static data_con tot_wds ptr_wds = ConInfo { closureSMRep = sm_rep, closureCon = data_con } where - sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info) + sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType dflags lf_info) lf_info = mkConLFInfo data_con nonptr_wds = tot_wds - ptr_wds \end{code} @@ -526,16 +526,16 @@ closureNeedsUpdSpace cl_info = closureUpdReqd cl_info %************************************************************************ \begin{code} -lfClosureType :: LambdaFormInfo -> ClosureTypeInfo -lfClosureType (LFReEntrant _ arity _ argd) = Fun (fromIntegral arity) argd -lfClosureType (LFCon con) = Constr (fromIntegral (dataConTagZ con)) - (dataConIdentity con) -lfClosureType (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel -lfClosureType _ = panic "lfClosureType" - -thunkClosureType :: StandardFormInfo -> ClosureTypeInfo -thunkClosureType (SelectorThunk off) = ThunkSelector (fromIntegral off) -thunkClosureType _ = Thunk +lfClosureType :: DynFlags -> LambdaFormInfo -> ClosureTypeInfo +lfClosureType dflags (LFReEntrant _ arity _ argd) = Fun (toStgHalfWord dflags (toInteger arity)) argd +lfClosureType dflags (LFCon con) = Constr (toStgHalfWord dflags (toInteger (dataConTagZ con))) + (dataConIdentity con) +lfClosureType dflags (LFThunk _ _ _ is_sel _) = thunkClosureType dflags is_sel +lfClosureType _ _ = panic "lfClosureType" + +thunkClosureType :: DynFlags -> StandardFormInfo -> ClosureTypeInfo +thunkClosureType dflags (SelectorThunk off) = ThunkSelector (toStgWord dflags (toInteger off)) +thunkClosureType _ _ = Thunk -- We *do* get non-updatable top-level thunks sometimes. eg. f = g -- gets compiled to a jump to g (if g has non-zero arity), instead of 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/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index 85346da205..4be5bd3d0c 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -353,16 +353,16 @@ isLFReEntrant _ = False -- Choosing SM reps ----------------------------------------------------------------------------- -lfClosureType :: LambdaFormInfo -> ClosureTypeInfo -lfClosureType (LFReEntrant _ arity _ argd) = Fun (fromIntegral arity) argd -lfClosureType (LFCon con) = Constr (fromIntegral (dataConTagZ con)) - (dataConIdentity con) -lfClosureType (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel -lfClosureType _ = panic "lfClosureType" +lfClosureType :: DynFlags -> LambdaFormInfo -> ClosureTypeInfo +lfClosureType dflags (LFReEntrant _ arity _ argd) = Fun (toStgHalfWord dflags (toInteger arity)) argd +lfClosureType dflags (LFCon con) = Constr (toStgHalfWord dflags (toInteger (dataConTagZ con))) + (dataConIdentity con) +lfClosureType dflags (LFThunk _ _ _ is_sel _) = thunkClosureType dflags is_sel +lfClosureType _ _ = panic "lfClosureType" -thunkClosureType :: StandardFormInfo -> ClosureTypeInfo -thunkClosureType (SelectorThunk off) = ThunkSelector (fromIntegral off) -thunkClosureType _ = Thunk +thunkClosureType :: DynFlags -> StandardFormInfo -> ClosureTypeInfo +thunkClosureType dflags (SelectorThunk off) = ThunkSelector (toStgWord dflags (toInteger off)) +thunkClosureType _ _ = Thunk -- We *do* get non-updatable top-level thunks sometimes. eg. f = g -- gets compiled to a jump to g (if g has non-zero arity), instead of @@ -687,7 +687,7 @@ mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr closureProf = prof } -- (we don't have an SRT yet) where name = idName id - sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info) + sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType dflags lf_info) prof = mkProfilingInfo dflags id val_descr nonptr_wds = tot_wds - ptr_wds @@ -899,8 +899,8 @@ mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type - cl_type = Constr (fromIntegral (dataConTagZ data_con)) - (dataConIdentity data_con) + cl_type = Constr (toStgHalfWord dflags (toInteger (dataConTagZ data_con))) + (dataConIdentity data_con) prof | not (dopt Opt_SccProfilingOn dflags) = NoProfilingInfo | otherwise = ProfilingInfo ty_descr val_descr 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 142100e109..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 } @@ -469,7 +472,7 @@ mkArgDescr _nm args let arg_bits = argBits dflags arg_reps arg_reps = filter isNonV (map idArgRep args) -- Getting rid of voids eases matching of standard patterns - case stdPattern arg_reps of + case stdPattern dflags arg_reps of Just spec_id -> return (ArgSpec spec_id) Nothing -> return (ArgGen arg_bits) @@ -480,9 +483,10 @@ argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True) ++ argBits dflags args ---------------------- -stdPattern :: [ArgRep] -> Maybe StgHalfWord -stdPattern reps - = case reps of +stdPattern :: DynFlags -> [ArgRep] -> Maybe StgHalfWord +stdPattern dflags reps + = fmap (toStgHalfWord dflags) + $ case reps of [] -> Just ARG_NONE -- just void args, probably [N] -> Just ARG_N [P] -> Just ARG_P @@ -578,7 +582,7 @@ stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags stdSrtBitmapOffset :: DynFlags -> ByteOff -- Byte offset of the SRT bitmap half-word which is -- in the *higher-addressed* part of the type_lit -stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE +stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE dflags stdClosureTypeOffset :: DynFlags -> ByteOff -- Byte offset of the closure type half-word @@ -586,7 +590,7 @@ stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags -stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE +stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE dflags ------------------------------------------------------------------------- -- diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index e6e9899040..b666554403 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -31,13 +31,6 @@ module StgCmmProf ( ) where #include "HsVersions.h" -#include "../includes/MachDeps.h" - -- For WORD_SIZE_IN_BITS only. -#include "../includes/rts/Constants.h" - -- For LDV_CREATE_MASK, LDV_STATE_USE - -- which are StgWords -#include "../includes/dist-derivedconstants/header/DerivedConstants.h" - -- For REP_xxx constants, which are MachReps import StgCmmClosure import StgCmmUtils @@ -174,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)) $ @@ -181,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 @@ -282,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 @@ -307,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 ----------------------------------------------------------------------------- @@ -328,8 +320,8 @@ staticLdvInit = zeroCLit dynLdvInit :: DynFlags -> CmmExpr dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE CmmMachOp (mo_wordOr dflags) [ - CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags lDV_SHIFT ], - CmmLit (mkWordCLit dflags lDV_STATE_CREATE) + CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)], + CmmLit (mkWordCLit dflags (lDV_STATE_CREATE dflags)) ] -- @@ -358,8 +350,8 @@ ldvEnter cl_ptr = do let -- don't forget to substract node's tag ldv_wd = ldvWord dflags cl_ptr new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags)) - (CmmLit (mkWordCLit dflags lDV_CREATE_MASK))) - (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags lDV_STATE_USE))) + (CmmLit (mkWordCLit dflags (lDV_CREATE_MASK dflags)))) + (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (lDV_STATE_USE dflags)))) ifProfiling $ -- if (era > 0) { -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) | @@ -369,8 +361,9 @@ ldvEnter cl_ptr = do mkNop loadEra :: DynFlags -> CmmExpr -loadEra dflags = CmmMachOp (MO_UU_Conv cIntWidth (wordWidth dflags)) - [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "era"))) cInt] +loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags)) + [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "era"))) + (cInt dflags)] ldvWord :: DynFlags -> CmmExpr -> CmmExpr -- Takes the address of a closure, and returns @@ -378,17 +371,10 @@ ldvWord :: DynFlags -> CmmExpr -> CmmExpr ldvWord dflags closure_ptr = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags) --- LDV constants, from ghc/includes/Constants.h -lDV_SHIFT :: Int -lDV_SHIFT = LDV_SHIFT ---lDV_STATE_MASK :: StgWord ---lDV_STATE_MASK = LDV_STATE_MASK -lDV_CREATE_MASK :: StgWord -lDV_CREATE_MASK = LDV_CREATE_MASK ---lDV_LAST_MASK :: StgWord ---lDV_LAST_MASK = LDV_LAST_MASK -lDV_STATE_CREATE :: StgWord -lDV_STATE_CREATE = LDV_STATE_CREATE -lDV_STATE_USE :: StgWord -lDV_STATE_USE = LDV_STATE_USE +lDV_CREATE_MASK :: DynFlags -> StgWord +lDV_CREATE_MASK dflags = toStgWord dflags (iLDV_CREATE_MASK dflags) +lDV_STATE_CREATE :: DynFlags -> StgWord +lDV_STATE_CREATE dflags = toStgWord dflags (iLDV_STATE_CREATE dflags) +lDV_STATE_USE :: DynFlags -> StgWord +lDV_STATE_USE dflags = toStgWord dflags (iLDV_STATE_USE dflags) diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index 137764db3d..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,13 +319,13 @@ 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 - addToMemLbl cLong (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_ctr")) 1, + addToMemLbl (cLong dflags) (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_ctr")) 1, -- Bump ALLOC_HEAP_tot - addToMemLbl cLong (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_tot")) hp] } + addToMemLbl (cLong dflags) (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_tot")) hp] } -- ----------------------------------------------------------------------------- -- Ticky utils @@ -343,7 +341,8 @@ bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkCmmDataLabel rtsPackag bumpTickyCounter' :: CmmLit -> FCode () -- krc: note that we're incrementing the _entry_count_ field of the ticky counter -bumpTickyCounter' lhs = emit (addToMem cLong (CmmLit lhs) 1) +bumpTickyCounter' lhs = do dflags <- getDynFlags + emit (addToMem (cLong dflags) (CmmLit lhs) 1) bumpHistogram :: FastString -> Int -> FCode () bumpHistogram _lbl _n diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 4471b78151..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 :: StgHalfWord -srt_escape = -1 diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index 0bd199ff18..fda2bccf9a 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -471,7 +471,7 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr) cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr) cpeRhsE env (Lit (LitInteger i _)) - = cpeRhsE env (cvtLitInteger (getMkIntegerId env) i) + = cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env) i) cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr) cpeRhsE env expr@(Var {}) = cpeApp env expr @@ -521,16 +521,16 @@ cpeRhsE env (Case scrut bndr ty alts) ; rhs' <- cpeBodyNF env2 rhs ; return (con, bs', rhs') } -cvtLitInteger :: Id -> Integer -> CoreExpr +cvtLitInteger :: DynFlags -> Id -> Integer -> CoreExpr -- Here we convert a literal Integer to the low-level -- represenation. Exactly how we do this depends on the -- library that implements Integer. If it's GMP we -- use the S# data constructor for small literals. -- See Note [Integer literals] in Literal -cvtLitInteger mk_integer i +cvtLitInteger dflags mk_integer i | cIntegerLibraryType == IntegerGMP - , inIntRange i -- Special case for small integers in GMP - = mkConApp integerGmpSDataCon [Lit (mkMachInt i)] + , inIntRange dflags i -- Special case for small integers in GMP + = mkConApp integerGmpSDataCon [Lit (mkMachInt dflags i)] | otherwise = mkApps (Var mk_integer) [isNonNegative, ints] @@ -540,7 +540,7 @@ cvtLitInteger mk_integer i f 0 = [] f x = let low = x .&. mask high = x `shiftR` bits - in mkConApp intDataCon [Lit (mkMachInt low)] : f high + in mkConApp intDataCon [Lit (mkMachInt dflags low)] : f high bits = 31 mask = 2 ^ bits - 1 diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index f972fc706d..2fb5aafd61 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -101,6 +101,7 @@ import DataCon import Module import TyCon import BasicTypes +import DynFlags import FastString import Outputable import Util @@ -561,7 +562,7 @@ data CoreRule ru_fn :: Name, -- ^ As above ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes, -- if it fires, including type arguments - ru_try :: Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr + ru_try :: DynFlags -> Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr -- ^ This function does the rewrite. It given too many -- arguments, it simply discards them; the returned 'CoreExpr' -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args @@ -1117,23 +1118,23 @@ mkConApp con args = mkApps (Var (dataConWorkId con)) args -- | Create a machine integer literal expression of type @Int#@ from an @Integer@. -- If you want an expression of type @Int@ use 'MkCore.mkIntExpr' -mkIntLit :: Integer -> Expr b +mkIntLit :: DynFlags -> Integer -> Expr b -- | Create a machine integer literal expression of type @Int#@ from an @Int@. -- If you want an expression of type @Int@ use 'MkCore.mkIntExpr' -mkIntLitInt :: Int -> Expr b +mkIntLitInt :: DynFlags -> Int -> Expr b -mkIntLit n = Lit (mkMachInt n) -mkIntLitInt n = Lit (mkMachInt (toInteger n)) +mkIntLit dflags n = Lit (mkMachInt dflags n) +mkIntLitInt dflags n = Lit (mkMachInt dflags (toInteger n)) -- | Create a machine word literal expression of type @Word#@ from an @Integer@. -- If you want an expression of type @Word@ use 'MkCore.mkWordExpr' -mkWordLit :: Integer -> Expr b +mkWordLit :: DynFlags -> Integer -> Expr b -- | Create a machine word literal expression of type @Word#@ from a @Word@. -- If you want an expression of type @Word@ use 'MkCore.mkWordExpr' -mkWordLitWord :: Word -> Expr b +mkWordLitWord :: DynFlags -> Word -> Expr b -mkWordLit w = Lit (mkMachWord w) -mkWordLitWord w = Lit (mkMachWord (toInteger w)) +mkWordLit dflags w = Lit (mkMachWord dflags w) +mkWordLitWord dflags w = Lit (mkMachWord dflags (toInteger w)) mkWord64LitWord64 :: Word64 -> Expr b mkWord64LitWord64 w = Lit (mkMachWord64 (toInteger w)) diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index f15c648694..cad80128b9 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -64,6 +64,7 @@ import TyCon import Unique import Outputable import TysPrim +import DynFlags import FastString import Maybes import Platform @@ -602,8 +603,8 @@ Note [exprIsDupable] \begin{code} -exprIsDupable :: CoreExpr -> Bool -exprIsDupable e +exprIsDupable :: DynFlags -> CoreExpr -> Bool +exprIsDupable dflags e = isJust (go dupAppSize e) where go :: Int -> CoreExpr -> Maybe Int @@ -613,7 +614,7 @@ exprIsDupable e go n (Tick _ e) = go n e go n (Cast e _) = go n e go n (App f a) | Just n' <- go n a = go n' f - go n (Lit lit) | litIsDupable lit = decrement n + go n (Lit lit) | litIsDupable dflags lit = decrement n go _ _ = Nothing decrement :: Int -> Maybe Int diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs index 0857cd556e..e903ab2084 100644 --- a/compiler/coreSyn/MkCore.lhs +++ b/compiler/coreSyn/MkCore.lhs @@ -84,6 +84,7 @@ import BasicTypes import Util import Pair import Constants +import DynFlags import Data.Char ( ord ) import Data.List @@ -233,20 +234,20 @@ mkCoreLams = mkLams \begin{code} -- | Create a 'CoreExpr' which will evaluate to the given @Int@ -mkIntExpr :: Integer -> CoreExpr -- Result = I# i :: Int -mkIntExpr i = mkConApp intDataCon [mkIntLit i] +mkIntExpr :: DynFlags -> Integer -> CoreExpr -- Result = I# i :: Int +mkIntExpr dflags i = mkConApp intDataCon [mkIntLit dflags i] -- | Create a 'CoreExpr' which will evaluate to the given @Int@ -mkIntExprInt :: Int -> CoreExpr -- Result = I# i :: Int -mkIntExprInt i = mkConApp intDataCon [mkIntLitInt i] +mkIntExprInt :: DynFlags -> Int -> CoreExpr -- Result = I# i :: Int +mkIntExprInt dflags i = mkConApp intDataCon [mkIntLitInt dflags i] -- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value -mkWordExpr :: Integer -> CoreExpr -mkWordExpr w = mkConApp wordDataCon [mkWordLit w] +mkWordExpr :: DynFlags -> Integer -> CoreExpr +mkWordExpr dflags w = mkConApp wordDataCon [mkWordLit dflags w] -- | Create a 'CoreExpr' which will evaluate to the given @Word@ -mkWordExprWord :: Word -> CoreExpr -mkWordExprWord w = mkConApp wordDataCon [mkWordLitWord w] +mkWordExprWord :: DynFlags -> Word -> CoreExpr +mkWordExprWord dflags w = mkConApp wordDataCon [mkWordLitWord dflags w] -- | Create a 'CoreExpr' which will evaluate to the given @Integer@ mkIntegerExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Integer diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs index e02ef7b385..b5e38c8af2 100644 --- a/compiler/deSugar/DsCCall.lhs +++ b/compiler/deSugar/DsCCall.lhs @@ -149,11 +149,12 @@ unboxArg arg -- Booleans | Just tc <- tyConAppTyCon_maybe arg_ty, tc `hasKey` boolTyConKey - = do prim_arg <- newSysLocalDs intPrimTy + = do dflags <- getDynFlags + prim_arg <- newSysLocalDs intPrimTy return (Var prim_arg, \ body -> Case (mkWildCase arg arg_ty intPrimTy - [(DataAlt falseDataCon,[],mkIntLit 0), - (DataAlt trueDataCon, [],mkIntLit 1)]) + [(DataAlt falseDataCon,[],mkIntLit dflags 0), + (DataAlt trueDataCon, [],mkIntLit dflags 1)]) -- In increasing tag order! prim_arg (exprType body) @@ -335,11 +336,13 @@ resultWrapper result_ty -- Base case 3: the boolean type | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey - = return + = do + dflags <- getDynFlags + return (Just intPrimTy, \e -> mkWildCase e intPrimTy boolTy - [(DEFAULT ,[],Var trueDataConId ), - (LitAlt (mkMachInt 0),[],Var falseDataConId)]) + [(DEFAULT ,[],Var trueDataConId ), + (LitAlt (mkMachInt dflags 0),[],Var falseDataConId)]) -- Recursive newtypes | Just (rep_ty, co) <- splitNewTypeRepCo_maybe result_ty diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index cc6b6afada..0cf4b97159 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -430,7 +430,7 @@ dsFExportDynamic id co0 cconv = do to be entered using an external calling convention (stdcall, ccall). -} - adj_args = [ mkIntLitInt (ccallConvToInt cconv) + adj_args = [ mkIntLitInt dflags (ccallConvToInt cconv) , Var stbl_value , Lit (MachLabel fe_nm mb_sz_args IsFunction) , Lit (mkMachString typestring) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 874f8b0f41..15dab47ca1 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -62,6 +62,7 @@ import Unique import BasicTypes import Outputable import Bag +import DynFlags import FastString import ForeignCall import MonadUtils @@ -798,7 +799,8 @@ repTy (HsTyLit lit) = do repTy ty = notHandled "Exotic form of type" (ppr ty) repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ) -repTyLit (HsNumTy i) = rep2 numTyLitName [mkIntExpr i] +repTyLit (HsNumTy i) = do dflags <- getDynFlags + rep2 numTyLitName [mkIntExpr dflags i] repTyLit (HsStrTy s) = do { s' <- mkStringExprFS s ; rep2 strTyLitName [s'] } @@ -1730,11 +1732,13 @@ repNamedTyCon (MkC s) = rep2 conTName [s] repTupleTyCon :: Int -> DsM (Core TH.TypeQ) -- Note: not Core Int; it's easier to be direct here -repTupleTyCon i = rep2 tupleTName [mkIntExprInt i] +repTupleTyCon i = do dflags <- getDynFlags + rep2 tupleTName [mkIntExprInt dflags i] repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ) -- Note: not Core Int; it's easier to be direct here -repUnboxedTupleTyCon i = rep2 unboxedTupleTName [mkIntExprInt i] +repUnboxedTupleTyCon i = do dflags <- getDynFlags + rep2 unboxedTupleTName [mkIntExprInt dflags i] repArrowTyCon :: DsM (Core TH.TypeQ) repArrowTyCon = rep2 arrowTName [] @@ -1746,7 +1750,8 @@ repPromotedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ) repPromotedTyCon (MkC s) = rep2 promotedTName [s] repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ) -repPromotedTupleTyCon i = rep2 promotedTupleTName [mkIntExprInt i] +repPromotedTupleTyCon i = do dflags <- getDynFlags + rep2 promotedTupleTName [mkIntExprInt dflags i] repPromotedNilTyCon :: DsM (Core TH.TypeQ) repPromotedNilTyCon = rep2 promotedNilTName [] @@ -1769,7 +1774,8 @@ repKCon :: Core TH.Name -> DsM (Core TH.Kind) repKCon (MkC s) = rep2 conKName [s] repKTuple :: Int -> DsM (Core TH.Kind) -repKTuple i = rep2 tupleKName [mkIntExprInt i] +repKTuple i = do dflags <- getDynFlags + rep2 tupleKName [mkIntExprInt dflags i] repKArrow :: DsM (Core TH.Kind) repKArrow = rep2 arrowKName [] @@ -1878,7 +1884,8 @@ coreStringLit s = do { z <- mkStringExpr s; return(MkC z) } ------------ Literals & Variables ------------------- coreIntLit :: Int -> DsM (Core Int) -coreIntLit i = return (MkC (mkIntExprInt i)) +coreIntLit i = do dflags <- getDynFlags + return (MkC (mkIntExprInt dflags i)) coreVar :: Id -> Core TH.Name -- The Id has type Name coreVar id = MkC (Var id) diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 52944e8347..0053484b13 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -308,11 +308,12 @@ mkCoPrimCaseMatchResult var ty match_alts mkCoAlgCaseMatchResult - :: Id -- Scrutinee + :: DynFlags + -> Id -- Scrutinee -> Type -- Type of exp -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives (bndrs *include* tyvars, dicts) -> MatchResult -mkCoAlgCaseMatchResult var ty match_alts +mkCoAlgCaseMatchResult dflags var ty match_alts | isNewTyCon tycon -- Newtype case; use a let = ASSERT( null (tail match_alts) && null (tail arg_ids1) ) mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1 @@ -423,7 +424,7 @@ mkCoAlgCaseMatchResult var ty match_alts lit = MachInt $ toInteger (dataConSourceArity con) binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args] -- - indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr i] + indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr dflags i] \end{code} %************************************************************************ diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index 8fd3a203f3..adb9099c14 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -292,12 +292,13 @@ match [] ty eqns match vars@(v:_) ty eqns = ASSERT( not (null eqns ) ) - do { -- Tidy the first pattern, generating + do { dflags <- getDynFlags + ; -- Tidy the first pattern, generating -- auxiliary bindings if necessary (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns -- Group the equations and match each group in turn - ; let grouped = groupEquations tidy_eqns + ; let grouped = groupEquations dflags tidy_eqns -- print the view patterns that are commoned up to help debug ; ifDOptM Opt_D_dump_view_pattern_commoning (debug grouped) @@ -787,13 +788,13 @@ data PatGroup -- the LHsExpr is the expression e Type -- the Type is the type of p (equivalently, the result type of e) -groupEquations :: [EquationInfo] -> [[(PatGroup, EquationInfo)]] +groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]] -- If the result is of form [g1, g2, g3], -- (a) all the (pg,eq) pairs in g1 have the same pg -- (b) none of the gi are empty -- The ordering of equations is unchanged -groupEquations eqns - = runs same_gp [(patGroup (firstPat eqn), eqn) | eqn <- eqns] +groupEquations dflags eqns + = runs same_gp [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns] where same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2 @@ -948,16 +949,16 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 eq_co (TcTyConAppCo tc1 cos1) (TcTyConAppCo tc2 cos2) = tc1==tc2 && eq_list eq_co cos1 cos2 eq_co _ _ = False -patGroup :: Pat Id -> PatGroup -patGroup (WildPat {}) = PgAny -patGroup (BangPat {}) = PgBang -patGroup (ConPatOut { pat_con = dc }) = PgCon (unLoc dc) -patGroup (LitPat lit) = PgLit (hsLitKey lit) -patGroup (NPat olit mb_neg _) = PgN (hsOverLitKey olit (isJust mb_neg)) -patGroup (NPlusKPat _ olit _ _) = PgNpK (hsOverLitKey olit False) -patGroup (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern -patGroup (ViewPat expr p _) = PgView expr (hsPatType (unLoc p)) -patGroup pat = pprPanic "patGroup" (ppr pat) +patGroup :: DynFlags -> Pat Id -> PatGroup +patGroup _ (WildPat {}) = PgAny +patGroup _ (BangPat {}) = PgBang +patGroup _ (ConPatOut { pat_con = dc }) = PgCon (unLoc dc) +patGroup dflags (LitPat lit) = PgLit (hsLitKey dflags lit) +patGroup _ (NPat olit mb_neg _) = PgN (hsOverLitKey olit (isJust mb_neg)) +patGroup _ (NPlusKPat _ olit _ _) = PgNpK (hsOverLitKey olit False) +patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern +patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p)) +patGroup _ pat = pprPanic "patGroup" (ppr pat) \end{code} Note [Grouping overloaded literal patterns] diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs index e1b2ef83df..10270e50ca 100644 --- a/compiler/deSugar/MatchCon.lhs +++ b/compiler/deSugar/MatchCon.lhs @@ -31,6 +31,7 @@ import ListSetOps ( runs ) import Id import NameEnv import SrcLoc +import DynFlags import Outputable import Control.Monad(liftM) \end{code} @@ -92,8 +93,9 @@ matchConFamily :: [Id] -> DsM MatchResult -- Each group of eqns is for a single constructor matchConFamily (var:vars) ty groups - = do { alts <- mapM (matchOneCon vars ty) groups - ; return (mkCoAlgCaseMatchResult var ty alts) } + = do dflags <- getDynFlags + alts <- mapM (matchOneCon vars ty) groups + return (mkCoAlgCaseMatchResult dflags var ty alts) matchConFamily [] _ _ = panic "matchConFamily []" type ConArgPats = HsConDetails (LPat Id) (HsRecFields Id (LPat Id)) diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs index 4032093541..69d46c2096 100644 --- a/compiler/deSugar/MatchLit.lhs +++ b/compiler/deSugar/MatchLit.lhs @@ -42,6 +42,7 @@ import Data.Ratio import MonadUtils import Outputable import BasicTypes +import DynFlags import Util import FastString \end{code} @@ -81,7 +82,8 @@ dsLit (HsDoublePrim d) = return (Lit (MachDouble (fl_value d))) dsLit (HsChar c) = return (mkCharExpr c) dsLit (HsString str) = mkStringExprFS str dsLit (HsInteger i _) = mkIntegerExpr i -dsLit (HsInt i) = return (mkIntExpr i) +dsLit (HsInt i) = do dflags <- getDynFlags + return (mkIntExpr dflags i) dsLit (HsRat r ty) = do num <- mkIntegerExpr (numerator (fl_value r)) @@ -95,12 +97,16 @@ dsLit (HsRat r ty) = do x -> pprPanic "dsLit" (ppr x) dsOverLit :: HsOverLit Id -> DsM CoreExpr +dsOverLit lit = do dflags <- getDynFlags + dsOverLit' dflags lit + +dsOverLit' :: DynFlags -> HsOverLit Id -> DsM CoreExpr -- Post-typechecker, the SyntaxExpr field of an OverLit contains -- (an expression for) the literal value itself -dsOverLit (OverLit { ol_val = val, ol_rebindable = rebindable - , ol_witness = witness, ol_type = ty }) +dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable + , ol_witness = witness, ol_type = ty }) | not rebindable - , Just expr <- shortCutLit val ty = dsExpr expr -- Note [Literal short cut] + , Just expr <- shortCutLit dflags val ty = dsExpr expr -- Note [Literal short cut] | otherwise = dsExpr witness \end{code} @@ -113,22 +119,22 @@ much better do do so. \begin{code} -hsLitKey :: HsLit -> Literal +hsLitKey :: DynFlags -> HsLit -> Literal -- Get a Core literal to use (only) a grouping key -- Hence its type doesn't need to match the type of the original literal -- (and doesn't for strings) -- It only works for primitive types and strings; -- others have been removed by tidy -hsLitKey (HsIntPrim i) = mkMachInt i -hsLitKey (HsWordPrim w) = mkMachWord w -hsLitKey (HsInt64Prim i) = mkMachInt64 i -hsLitKey (HsWord64Prim w) = mkMachWord64 w -hsLitKey (HsCharPrim c) = MachChar c -hsLitKey (HsStringPrim s) = MachStr s -hsLitKey (HsFloatPrim f) = MachFloat (fl_value f) -hsLitKey (HsDoublePrim d) = MachDouble (fl_value d) -hsLitKey (HsString s) = MachStr (fastStringToFastBytes s) -hsLitKey l = pprPanic "hsLitKey" (ppr l) +hsLitKey dflags (HsIntPrim i) = mkMachInt dflags i +hsLitKey dflags (HsWordPrim w) = mkMachWord dflags w +hsLitKey _ (HsInt64Prim i) = mkMachInt64 i +hsLitKey _ (HsWord64Prim w) = mkMachWord64 w +hsLitKey _ (HsCharPrim c) = MachChar c +hsLitKey _ (HsStringPrim s) = MachStr s +hsLitKey _ (HsFloatPrim f) = MachFloat (fl_value f) +hsLitKey _ (HsDoublePrim d) = MachDouble (fl_value d) +hsLitKey _ (HsString s) = MachStr (fastStringToFastBytes s) +hsLitKey _ l = pprPanic "hsLitKey" (ppr l) hsOverLitKey :: OutputableBndr a => HsOverLit a -> Bool -> Literal -- Ditto for HsOverLit; the boolean indicates to negate @@ -247,9 +253,10 @@ matchLiterals (var:vars) ty sub_groups where match_group :: [EquationInfo] -> DsM (Literal, MatchResult) match_group eqns - = do { let LitPat hs_lit = firstPat (head eqns) - ; match_result <- match vars ty (shiftEqns eqns) - ; return (hsLitKey hs_lit, match_result) } + = do dflags <- getDynFlags + let LitPat hs_lit = firstPat (head eqns) + match_result <- match vars ty (shiftEqns eqns) + return (hsLitKey dflags hs_lit, match_result) wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult -- Equality check for string literals 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/ghc.mk b/compiler/ghc.mk index f65813dd94..a0754af5c2 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -474,16 +474,12 @@ $(compiler_stage1_depfile_haskell) : $(COMPILER_INCLUDES_DEPS) $(compiler_stage2_depfile_haskell) : $(COMPILER_INCLUDES_DEPS) $(compiler_stage3_depfile_haskell) : $(COMPILER_INCLUDES_DEPS) -# Every Constants.o object file depends on includes/GHCConstants.h: -$(eval $(call compiler-hs-dependency,Constants,$(includes_GHCCONSTANTS) includes/HaskellConstants.hs)) - # Every PrimOp.o object file depends on $(PRIMOP_BITS): $(eval $(call compiler-hs-dependency,PrimOp,$(PRIMOP_BITS))) # GHC itself doesn't know about the above dependencies, so we have to -# switch off the recompilation checker for those modules: +# switch off the recompilation checker for that module: compiler/prelude/PrimOp_HC_OPTS += -fforce-recomp -compiler/main/Constants_HC_OPTS += -fforce-recomp # LibFFI.hs #includes ffi.h compiler/stage2/build/LibFFI.hs : $(libffi_HEADERS) diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index 15c41d044e..f00e45c6b6 100644 --- a/compiler/ghci/ByteCodeAsm.lhs +++ b/compiler/ghci/ByteCodeAsm.lhs @@ -166,7 +166,7 @@ assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = d insns_arr = listArray (0, n_insns - 1) asm_insns !insns_barr = barr insns_arr - bitmap_arr = mkBitmapArray bsize bitmap + bitmap_arr = mkBitmapArray dflags bsize bitmap !bitmap_barr = barr bitmap_arr ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits final_ptrs @@ -178,9 +178,9 @@ assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = d return ul_bco -mkBitmapArray :: Word16 -> [StgWord] -> UArray Int StgWord -mkBitmapArray bsize bitmap - = listArray (0, length bitmap) (fromIntegral bsize : bitmap) +mkBitmapArray :: DynFlags -> Word16 -> [StgWord] -> UArray Int StgWord +mkBitmapArray dflags bsize bitmap + = listArray (0, length bitmap) (toStgWord dflags (toInteger bsize) : bitmap) -- instrs nonptrs ptrs type AsmState = (SizedSeq Word16, diff --git a/compiler/ghci/ByteCodeInstr.lhs b/compiler/ghci/ByteCodeInstr.lhs index ada0be6f0f..ed49960709 100644 --- a/compiler/ghci/ByteCodeInstr.lhs +++ b/compiler/ghci/ByteCodeInstr.lhs @@ -178,7 +178,7 @@ instance Outputable a => Outputable (ProtoBCO a) where Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';')) (map (pprCoreAltShort.deAnnAlt) alts)) <+> char '}' Right rhs -> pprCoreExprShort (deAnnotate rhs)) - $$ nest 3 (text "bitmap: " <+> text (show bsize) <+> text (show bitmap)) + $$ nest 3 (text "bitmap: " <+> text (show bsize) <+> ppr bitmap) $$ nest 3 (vcat (map ppr instrs)) -- Print enough of the Core expression to enable the reader to find diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs index cd46ec311e..b1688d85f8 100644 --- a/compiler/ghci/DebuggerUtils.hs +++ b/compiler/ghci/DebuggerUtils.hs @@ -9,12 +9,11 @@ import TcRnTypes import TcRnMonad import IfaceEnv import CgInfoTbls -import SMRep import Module import OccName import Name import Outputable -import MonadUtils () +import Platform import Util import Data.Char @@ -94,8 +93,17 @@ dataConInfoPtrToName x = do getConDescAddress :: DynFlags -> Ptr StgInfoTable -> IO (Ptr Word8) getConDescAddress dflags ptr | ghciTablesNextToCode = do - offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE dflags) - return $ (ptr `plusPtr` stdInfoTableSizeB dflags) `plusPtr` (fromIntegral (offsetToString :: StgWord)) + let ptr' = ptr `plusPtr` (- wORD_SIZE dflags) + -- offsetToString is really an StgWord, but we have to jump + -- through some hoops due to the way that our StgWord Haskell + -- type is the same on 32 and 64bit platforms + offsetToString <- case platformWordSize (targetPlatform dflags) of + 4 -> do w <- peek ptr' + return (fromIntegral (w :: Word32)) + 8 -> do w <- peek ptr' + return (fromIntegral (w :: Word64)) + w -> panic ("getConDescAddress: Unknown platformWordSize: " ++ show w) + return $ (ptr `plusPtr` stdInfoTableSizeB dflags) `plusPtr` offsetToString | otherwise = peek $ intPtrToPtr $ ptrToIntPtr ptr + fromIntegral (stdInfoTableSizeB dflags) -- parsing names is a little bit fiddly because we have a string in the form: diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 565cf0b8a8..6b47db3965 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -772,7 +772,7 @@ dynLinkObjs dflags pls objs = do mapM_ loadObj (map nameOfObject unlinkeds) - -- Link the all together + -- Link them all together ok <- resolveObjs -- If resolving failed, unload all our diff --git a/compiler/main/Constants.lhs b/compiler/main/Constants.lhs index 0cecb82f1a..497bae500e 100644 --- a/compiler/main/Constants.lhs +++ b/compiler/main/Constants.lhs @@ -4,21 +4,26 @@ \section[Constants]{Info about this compilation} \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 Constants (module Constants) where import Config -#include "ghc_boot_platform.h" - -#include "../includes/HaskellConstants.hs" - hiVersion :: Integer hiVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer + +-- All pretty arbitrary: + +mAX_TUPLE_SIZE :: Int +mAX_TUPLE_SIZE = 62 -- Should really match the number + -- of decls in Data.Tuple + +mAX_CONTEXT_REDUCTION_DEPTH :: Int +mAX_CONTEXT_REDUCTION_DEPTH = 200 + -- Increase to 200; see Trac #5395 + +wORD64_SIZE :: Int +wORD64_SIZE = 8 + +tARGET_MAX_CHAR :: Int +tARGET_MAX_CHAR = 0x10ffff \end{code} diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index d4c3d535d6..b412fc1166 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -122,6 +122,7 @@ module DynFlags ( wORD_SIZE_IN_BITS, tAG_MASK, mAX_PTR_TAG, + tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD, ) where #include "HsVersions.h" @@ -155,11 +156,13 @@ import Control.Monad import Data.Bits import Data.Char +import Data.Int import Data.List import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set +import Data.Word import System.FilePath import System.IO @@ -290,6 +293,7 @@ data DynFlag | Opt_IrrefutableTuples | Opt_CmmSink | Opt_CmmElimCommonBlocks + | Opt_OmitYields -- Interface files | Opt_IgnoreInterfacePragmas @@ -345,7 +349,6 @@ data DynFlag | Opt_RunCPSZ | Opt_AutoLinkPackages | Opt_ImplicitImportQualified - | Opt_TryNewCodeGen -- keeping stuff | Opt_KeepHiDiffs @@ -2264,7 +2267,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 ), @@ -2274,6 +2276,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 ), @@ -2421,9 +2424,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 ), @@ -2459,7 +2461,7 @@ defaultFlags platform Opt_SharedImplib, - Opt_TryNewCodeGen, + Opt_OmitYields, Opt_GenManifest, Opt_EmbedManifest, @@ -3162,3 +3164,21 @@ tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1 mAX_PTR_TAG :: DynFlags -> Int mAX_PTR_TAG = tAG_MASK +-- Might be worth caching these in targetPlatform? +tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD :: DynFlags -> Integer +tARGET_MIN_INT dflags + = case platformWordSize (targetPlatform dflags) of + 4 -> toInteger (minBound :: Int32) + 8 -> toInteger (minBound :: Int64) + w -> panic ("tARGET_MIN_INT: Unknown platformWordSize: " ++ show w) +tARGET_MAX_INT dflags + = case platformWordSize (targetPlatform dflags) of + 4 -> toInteger (maxBound :: Int32) + 8 -> toInteger (maxBound :: Int64) + w -> panic ("tARGET_MAX_INT: Unknown platformWordSize: " ++ show w) +tARGET_MAX_WORD dflags + = case platformWordSize (targetPlatform dflags) of + 4 -> toInteger (maxBound :: Word32) + 8 -> toInteger (maxBound :: Word64) + w -> panic ("tARGET_MAX_WORD: Unknown platformWordSize: " ++ show w) + 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/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs index 36b32fa45f..56f2d48f61 100644 --- a/compiler/main/StaticFlagParser.hs +++ b/compiler/main/StaticFlagParser.hs @@ -134,8 +134,7 @@ isStaticFlag f = "fexcess-precision", "fhardwire-lib-paths", "fcpr-off", - "ferror-spans", - "fhpc" + "ferror-spans" ] || any (`isPrefixOf` f) [ "fliberate-case-threshold", diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index ffd5de809d..309f2e2d9b 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -1238,7 +1238,7 @@ hasCafRefs dflags this_pkg p arity expr | is_caf || mentions_cafs = MayHaveCafRefs | otherwise = NoCafRefs where - mentions_cafs = isFastTrue (cafRefsE p expr) + mentions_cafs = isFastTrue (cafRefsE dflags p expr) is_dynamic_name = isDllName dflags this_pkg is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name expr) @@ -1248,28 +1248,28 @@ hasCafRefs dflags this_pkg p arity expr -- CorePrep later on, and we don't want to duplicate that -- knowledge in rhsIsStatic below. -cafRefsE :: (Id, VarEnv Id) -> Expr a -> FastBool -cafRefsE p (Var id) = cafRefsV p id -cafRefsE p (Lit lit) = cafRefsL p lit -cafRefsE p (App f a) = fastOr (cafRefsE p f) (cafRefsE p) a -cafRefsE p (Lam _ e) = cafRefsE p e -cafRefsE p (Let b e) = fastOr (cafRefsEs p (rhssOfBind b)) (cafRefsE p) e -cafRefsE p (Case e _bndr _ alts) = fastOr (cafRefsE p e) (cafRefsEs p) (rhssOfAlts alts) -cafRefsE p (Tick _n e) = cafRefsE p e -cafRefsE p (Cast e _co) = cafRefsE p e -cafRefsE _ (Type _) = fastBool False -cafRefsE _ (Coercion _) = fastBool False - -cafRefsEs :: (Id, VarEnv Id) -> [Expr a] -> FastBool -cafRefsEs _ [] = fastBool False -cafRefsEs p (e:es) = fastOr (cafRefsE p e) (cafRefsEs p) es - -cafRefsL :: (Id, VarEnv Id) -> Literal -> FastBool +cafRefsE :: DynFlags -> (Id, VarEnv Id) -> Expr a -> FastBool +cafRefsE _ p (Var id) = cafRefsV p id +cafRefsE dflags p (Lit lit) = cafRefsL dflags p lit +cafRefsE dflags p (App f a) = fastOr (cafRefsE dflags p f) (cafRefsE dflags p) a +cafRefsE dflags p (Lam _ e) = cafRefsE dflags p e +cafRefsE dflags p (Let b e) = fastOr (cafRefsEs dflags p (rhssOfBind b)) (cafRefsE dflags p) e +cafRefsE dflags p (Case e _bndr _ alts) = fastOr (cafRefsE dflags p e) (cafRefsEs dflags p) (rhssOfAlts alts) +cafRefsE dflags p (Tick _n e) = cafRefsE dflags p e +cafRefsE dflags p (Cast e _co) = cafRefsE dflags p e +cafRefsE _ _ (Type _) = fastBool False +cafRefsE _ _ (Coercion _) = fastBool False + +cafRefsEs :: DynFlags -> (Id, VarEnv Id) -> [Expr a] -> FastBool +cafRefsEs _ _ [] = fastBool False +cafRefsEs dflags p (e:es) = fastOr (cafRefsE dflags p e) (cafRefsEs dflags p) es + +cafRefsL :: DynFlags -> (Id, VarEnv Id) -> Literal -> FastBool -- Don't forget that mk_integer id might have Caf refs! -- We first need to convert the Integer into its final form, to -- see whether mkInteger is used. -cafRefsL p@(mk_integer, _) (LitInteger i _) = cafRefsE p (cvtLitInteger mk_integer i) -cafRefsL _ _ = fastBool False +cafRefsL dflags p@(mk_integer, _) (LitInteger i _) = cafRefsE dflags p (cvtLitInteger dflags mk_integer i) +cafRefsL _ _ _ = fastBool False cafRefsV :: (Id, VarEnv Id) -> Id -> FastBool cafRefsV (_, p) id 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 b5b350b9d9..aa4156bfdb 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -43,14 +43,15 @@ import Name ( Name, nameOccName ) import Outputable import FastString import StaticFlags ( opt_SimplExcessPrecision ) -import Constants import BasicTypes +import DynFlags +import Platform import Util import Control.Monad import Data.Bits as Bits -import Data.Int ( Int64 ) -import Data.Word ( Word, Word64 ) +import Data.Int +import Data.Word \end{code} @@ -79,60 +80,61 @@ primOpRules nm DataToTagOp = mkPrimOpRule nm 2 [ dataToTagRule ] -- Int operations primOpRules nm IntAddOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (+)) - , identity zeroi ] + , identityDynFlags zeroi ] primOpRules nm IntSubOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (-)) - , rightIdentity zeroi - , equalArgs >> return (Lit zeroi) ] + , rightIdentityDynFlags zeroi + , equalArgs >> retLit zeroi ] primOpRules nm IntMulOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (*)) , zeroElem zeroi - , identity onei ] + , identityDynFlags onei ] primOpRules nm IntQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot) , leftZero zeroi - , rightIdentity onei - , equalArgs >> return (Lit onei) ] + , rightIdentityDynFlags onei + , equalArgs >> retLit onei ] primOpRules nm IntRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem) , leftZero zeroi , do l <- getLiteral 1 - guard (l == onei) - return (Lit zeroi) - , equalArgs >> return (Lit zeroi) - , equalArgs >> return (Lit zeroi) ] + dflags <- getDynFlags + guard (l == onei dflags) + retLit zeroi + , equalArgs >> retLit zeroi + , equalArgs >> retLit zeroi ] primOpRules nm IntNegOp = mkPrimOpRule nm 1 [ unaryLit negOp ] primOpRules nm ISllOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftL) - , rightIdentity zeroi ] + , rightIdentityDynFlags zeroi ] primOpRules nm ISraOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftR) - , rightIdentity zeroi ] + , rightIdentityDynFlags zeroi ] primOpRules nm ISrlOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 shiftRightLogical) - , rightIdentity zeroi ] + , rightIdentityDynFlags zeroi ] -- Word operations primOpRules nm WordAddOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+)) - , identity zerow ] + , identityDynFlags zerow ] primOpRules nm WordSubOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-)) - , rightIdentity zerow - , equalArgs >> return (Lit zerow) ] + , rightIdentityDynFlags zerow + , equalArgs >> retLit zerow ] primOpRules nm WordMulOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*)) - , identity onew ] + , identityDynFlags onew ] primOpRules nm WordQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot) - , rightIdentity onew ] + , rightIdentityDynFlags onew ] primOpRules nm WordRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem) - , rightIdentity onew ] + , rightIdentityDynFlags onew ] primOpRules nm AndOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.)) , zeroElem zerow ] primOpRules nm OrOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.)) - , identity zerow ] + , identityDynFlags zerow ] primOpRules nm XorOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor) - , identity zerow - , equalArgs >> return (Lit zerow) ] + , identityDynFlags zerow + , equalArgs >> retLit zerow ] primOpRules nm SllOp = mkPrimOpRule nm 2 [ binaryLit (wordShiftOp2 Bits.shiftL) - , rightIdentity zeroi ] + , rightIdentityDynFlags zeroi ] primOpRules nm SrlOp = mkPrimOpRule nm 2 [ binaryLit (wordShiftOp2 shiftRightLogical) - , rightIdentity zeroi ] + , rightIdentityDynFlags zeroi ] -- coercions -primOpRules nm Word2IntOp = mkPrimOpRule nm 1 [ liftLit word2IntLit +primOpRules nm Word2IntOp = mkPrimOpRule nm 1 [ liftLitDynFlags word2IntLit , inversePrimOp Int2WordOp ] -primOpRules nm Int2WordOp = mkPrimOpRule nm 1 [ liftLit int2WordLit +primOpRules nm Int2WordOp = mkPrimOpRule nm 1 [ liftLitDynFlags int2WordLit , inversePrimOp Word2IntOp ] primOpRules nm Narrow8IntOp = mkPrimOpRule nm 1 [ liftLit narrow8IntLit ] primOpRules nm Narrow16IntOp = mkPrimOpRule nm 1 [ liftLit narrow16IntLit ] @@ -239,7 +241,7 @@ mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool) mkRelOpRule nm cmp extra = mkPrimOpRule nm 2 $ rules ++ extra where - rules = [ binaryLit (cmpOp cmp) + rules = [ binaryLit (\_ -> cmpOp cmp) , equalArgs >> -- x `cmp` x does not depend on x, so -- compute it for the arbitrary value 'True' @@ -249,11 +251,13 @@ mkRelOpRule nm cmp extra else falseVal) ] -- common constants -zeroi, onei, zerow, onew, zerof, onef, zerod, oned :: Literal -zeroi = mkMachInt 0 -onei = mkMachInt 1 -zerow = mkMachWord 0 -onew = mkMachWord 1 +zeroi, onei, zerow, onew :: DynFlags -> Literal +zeroi dflags = mkMachInt dflags 0 +onei dflags = mkMachInt dflags 1 +zerow dflags = mkMachWord dflags 0 +onew dflags = mkMachWord dflags 1 + +zerof, onef, zerod, oned :: Literal zerof = mkMachFloat 0.0 onef = mkMachFloat 1.0 zerod = mkMachDouble 0.0 @@ -278,20 +282,20 @@ cmpOp cmp = go -------------------------- -negOp :: Literal -> Maybe CoreExpr -- Negate -negOp (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational -negOp (MachFloat f) = Just (mkFloatVal (-f)) -negOp (MachDouble 0.0) = Nothing -negOp (MachDouble d) = Just (mkDoubleVal (-d)) -negOp (MachInt i) = intResult (-i) -negOp _ = Nothing +negOp :: DynFlags -> Literal -> Maybe CoreExpr -- Negate +negOp _ (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational +negOp _ (MachFloat f) = Just (mkFloatVal (-f)) +negOp _ (MachDouble 0.0) = Nothing +negOp _ (MachDouble d) = Just (mkDoubleVal (-d)) +negOp dflags (MachInt i) = intResult dflags (-i) +negOp _ _ = Nothing -------------------------- intOp2 :: (Integral a, Integral b) => (a -> b -> Integer) - -> Literal -> Literal -> Maybe CoreExpr -intOp2 op (MachInt i1) (MachInt i2) = intResult (fromInteger i1 `op` fromInteger i2) -intOp2 _ _ _ = Nothing -- Could find LitLit + -> DynFlags -> Literal -> Literal -> Maybe CoreExpr +intOp2 op dflags (MachInt i1) (MachInt i2) = intResult dflags (fromInteger i1 `op` fromInteger i2) +intOp2 _ _ _ _ = Nothing -- Could find LitLit shiftRightLogical :: Integer -> Int -> Integer -- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do @@ -301,32 +305,41 @@ shiftRightLogical x n = fromIntegral (fromInteger x `shiftR` n :: Word) -------------------------- +retLit :: (DynFlags -> Literal) -> RuleM CoreExpr +retLit l = do dflags <- getDynFlags + return $ Lit $ l dflags + wordOp2 :: (Integral a, Integral b) => (a -> b -> Integer) - -> Literal -> Literal -> Maybe CoreExpr -wordOp2 op (MachWord w1) (MachWord w2) = wordResult (fromInteger w1 `op` fromInteger w2) -wordOp2 _ _ _ = Nothing -- Could find LitLit - -wordShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr + -> DynFlags -> Literal -> Literal -> Maybe CoreExpr +wordOp2 op dflags (MachWord w1) (MachWord w2) + = wordResult dflags (fromInteger w1 `op` fromInteger w2) +wordOp2 _ _ _ _ = Nothing -- Could find LitLit + +wordShiftOp2 :: (Integer -> Int -> Integer) + -> DynFlags -> Literal -> Literal + -> Maybe CoreExpr -- Shifts take an Int; hence second arg of op is Int -wordShiftOp2 op (MachWord x) (MachInt n) - = wordResult (x `op` fromInteger n) +wordShiftOp2 op dflags (MachWord x) (MachInt n) + = wordResult dflags (x `op` fromInteger n) -- Do the shift at type Integer -wordShiftOp2 _ _ _ = Nothing +wordShiftOp2 _ _ _ _ = Nothing -------------------------- -floatOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal +floatOp2 :: (Rational -> Rational -> Rational) + -> DynFlags -> Literal -> Literal -> Maybe (Expr CoreBndr) -floatOp2 op (MachFloat f1) (MachFloat f2) +floatOp2 op _ (MachFloat f1) (MachFloat f2) = Just (mkFloatVal (f1 `op` f2)) -floatOp2 _ _ _ = Nothing +floatOp2 _ _ _ _ = Nothing -------------------------- -doubleOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal +doubleOp2 :: (Rational -> Rational -> Rational) + -> DynFlags -> Literal -> Literal -> Maybe (Expr CoreBndr) -doubleOp2 op (MachDouble f1) (MachDouble f2) +doubleOp2 op _ (MachDouble f1) (MachDouble f2) = Just (mkDoubleVal (f1 `op` f2)) -doubleOp2 _ _ _ = Nothing +doubleOp2 _ _ _ _ = Nothing -------------------------- -- This stuff turns @@ -372,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 @@ -410,13 +424,19 @@ isMaxBound _ = False -- ((124076834 :: Word32) + (2147483647 :: Word32)) -- would yield a warning. Instead we simply squash the value into the -- *target* Int/Word range. -intResult :: Integer -> Maybe CoreExpr -intResult result - = Just (mkIntVal (toInteger (fromInteger result :: TargetInt))) - -wordResult :: Integer -> Maybe CoreExpr -wordResult result - = Just (mkWordVal (toInteger (fromInteger result :: TargetWord))) +intResult :: DynFlags -> Integer -> Maybe CoreExpr +intResult dflags result = Just (mkIntVal dflags result') + where result' = case platformWordSize (targetPlatform dflags) of + 4 -> toInteger (fromInteger result :: Int32) + 8 -> toInteger (fromInteger result :: Int64) + w -> panic ("intResult: Unknown platformWordSize: " ++ show w) + +wordResult :: DynFlags -> Integer -> Maybe CoreExpr +wordResult dflags result = Just (mkWordVal dflags result') + where result' = case platformWordSize (targetPlatform dflags) of + 4 -> toInteger (fromInteger result :: Word32) + 8 -> toInteger (fromInteger result :: Word64) + w -> panic ("wordResult: Unknown platformWordSize: " ++ show w) inversePrimOp :: PrimOp -> RuleM CoreExpr inversePrimOp primop = do @@ -439,31 +459,38 @@ mkBasicRule op_name n_args rm = BuiltinRule { ru_name = occNameFS (nameOccName op_name), ru_fn = op_name, ru_nargs = n_args, - ru_try = \_ -> runRuleM rm } + ru_try = \dflags _ -> runRuleM rm dflags } newtype RuleM r = RuleM - { runRuleM :: IdUnfoldingFun -> [CoreExpr] -> Maybe r } + { runRuleM :: DynFlags -> IdUnfoldingFun -> [CoreExpr] -> Maybe r } instance Monad RuleM where - return x = RuleM $ \_ _ -> Just x - RuleM f >>= g = RuleM $ \iu e -> case f iu e of + return x = RuleM $ \_ _ _ -> Just x + RuleM f >>= g = RuleM $ \dflags iu e -> case f dflags iu e of Nothing -> Nothing - Just r -> runRuleM (g r) iu e + Just r -> runRuleM (g r) dflags iu e fail _ = mzero instance MonadPlus RuleM where - mzero = RuleM $ \_ _ -> Nothing - mplus (RuleM f1) (RuleM f2) = RuleM $ \iu args -> - f1 iu args `mplus` f2 iu args + mzero = RuleM $ \_ _ _ -> Nothing + mplus (RuleM f1) (RuleM f2) = RuleM $ \dflags iu args -> + f1 dflags iu args `mplus` f2 dflags iu args + +instance HasDynFlags RuleM where + getDynFlags = RuleM $ \dflags _ _ -> Just dflags liftMaybe :: Maybe a -> RuleM a liftMaybe Nothing = mzero liftMaybe (Just x) = return x liftLit :: (Literal -> Literal) -> RuleM CoreExpr -liftLit f = do +liftLit f = liftLitDynFlags (const f) + +liftLitDynFlags :: (DynFlags -> Literal -> Literal) -> RuleM CoreExpr +liftLitDynFlags f = do + dflags <- getDynFlags [Lit lit] <- getArgs - return $ Lit (f lit) + return $ Lit (f dflags lit) removeOp32 :: RuleM CoreExpr #if WORD_SIZE_IN_BITS == 32 @@ -475,56 +502,71 @@ removeOp32 = mzero #endif getArgs :: RuleM [CoreExpr] -getArgs = RuleM $ \_ args -> Just args +getArgs = RuleM $ \_ _ args -> Just args getIdUnfoldingFun :: RuleM IdUnfoldingFun -getIdUnfoldingFun = RuleM $ \iu _ -> Just iu +getIdUnfoldingFun = RuleM $ \_ iu _ -> Just iu -- return the n-th argument of this rule, if it is a literal -- argument indices start from 0 getLiteral :: Int -> RuleM Literal -getLiteral n = RuleM $ \_ exprs -> case drop n exprs of +getLiteral n = RuleM $ \_ _ exprs -> case drop n exprs of (Lit l:_) -> Just l _ -> Nothing -unaryLit :: (Literal -> Maybe CoreExpr) -> RuleM CoreExpr +unaryLit :: (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr unaryLit op = do + dflags <- getDynFlags [Lit l] <- getArgs - liftMaybe $ op (convFloating l) + liftMaybe $ op dflags (convFloating l) -binaryLit :: (Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr +binaryLit :: (DynFlags -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr binaryLit op = do + dflags <- getDynFlags [Lit l1, Lit l2] <- getArgs - liftMaybe $ convFloating l1 `op` convFloating l2 + liftMaybe $ op dflags (convFloating l1) (convFloating l2) leftIdentity :: Literal -> RuleM CoreExpr -leftIdentity id_lit = do +leftIdentity id_lit = leftIdentityDynFlags (const id_lit) + +rightIdentity :: Literal -> RuleM CoreExpr +rightIdentity id_lit = rightIdentityDynFlags (const id_lit) + +identity :: Literal -> RuleM CoreExpr +identity lit = leftIdentity lit `mplus` rightIdentity lit + +leftIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr +leftIdentityDynFlags id_lit = do + dflags <- getDynFlags [Lit l1, e2] <- getArgs - guard $ l1 == id_lit + guard $ l1 == id_lit dflags return e2 -rightIdentity :: Literal -> RuleM CoreExpr -rightIdentity id_lit = do +rightIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr +rightIdentityDynFlags id_lit = do + dflags <- getDynFlags [e1, Lit l2] <- getArgs - guard $ l2 == id_lit + guard $ l2 == id_lit dflags return e1 -identity :: Literal -> RuleM CoreExpr -identity lit = leftIdentity lit `mplus` rightIdentity lit +identityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr +identityDynFlags lit = leftIdentityDynFlags lit `mplus` rightIdentityDynFlags lit -leftZero :: Literal -> RuleM CoreExpr +leftZero :: (DynFlags -> Literal) -> RuleM CoreExpr leftZero zero = do + dflags <- getDynFlags [Lit l1, _] <- getArgs - guard $ l1 == zero - return $ Lit zero + guard $ l1 == zero dflags + return $ Lit l1 -rightZero :: Literal -> RuleM CoreExpr +rightZero :: (DynFlags -> Literal) -> RuleM CoreExpr rightZero zero = do + dflags <- getDynFlags [_, Lit l2] <- getArgs - guard $ l2 == zero - return $ Lit zero + guard $ l2 == zero dflags + return $ Lit l2 -zeroElem :: Literal -> RuleM CoreExpr +zeroElem :: (DynFlags -> Literal) -> RuleM CoreExpr zeroElem lit = leftZero lit `mplus` rightZero lit equalArgs :: RuleM () @@ -570,10 +612,10 @@ ltVal = Var ltDataConId eqVal = Var eqDataConId gtVal = Var gtDataConId -mkIntVal :: Integer -> Expr CoreBndr -mkIntVal i = Lit (mkMachInt i) -mkWordVal :: Integer -> Expr CoreBndr -mkWordVal w = Lit (mkMachWord w) +mkIntVal :: DynFlags -> Integer -> Expr CoreBndr +mkIntVal dflags i = Lit (mkMachInt dflags i) +mkWordVal :: DynFlags -> Integer -> Expr CoreBndr +mkWordVal dflags w = Lit (mkMachWord dflags w) mkFloatVal :: Rational -> Expr CoreBndr mkFloatVal f = Lit (convFloating (MachFloat f)) mkDoubleVal :: Rational -> Expr CoreBndr @@ -648,11 +690,12 @@ dataToTagRule = a `mplus` b guard $ ty1 `eqType` ty2 return tag -- dataToTag (tagToEnum x) ==> x b = do + dflags <- getDynFlags [_, val_arg] <- getArgs id_unf <- getIdUnfoldingFun (dc,_,_) <- liftMaybe $ exprIsConApp_maybe id_unf val_arg ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return () - return $ mkIntVal (toInteger (dataConTag dc - fIRST_TAG)) + return $ mkIntVal dflags (toInteger (dataConTag dc - fIRST_TAG)) \end{code} %************************************************************************ @@ -716,11 +759,11 @@ builtinRules :: [CoreRule] builtinRules = [BuiltinRule { ru_name = fsLit "AppendLitString", ru_fn = unpackCStringFoldrName, - ru_nargs = 4, ru_try = \_ -> match_append_lit }, + ru_nargs = 4, ru_try = \_ _ -> match_append_lit }, BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName, - ru_nargs = 2, ru_try = \_ -> match_eq_string }, + ru_nargs = 2, ru_try = \_ _ -> match_eq_string }, BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName, - ru_nargs = 2, ru_try = \_ -> match_inline }] + ru_nargs = 2, ru_try = \_ _ -> match_inline }] ++ builtinIntegerRules builtinIntegerRules :: [CoreRule] @@ -731,8 +774,8 @@ builtinIntegerRules = rule_Word64ToInteger "word64ToInteger" word64ToIntegerName, rule_convert "integerToWord" integerToWordName mkWordLitWord, rule_convert "integerToInt" integerToIntName mkIntLitInt, - rule_convert "integerToWord64" integerToWord64Name mkWord64LitWord64, - rule_convert "integerToInt64" integerToInt64Name mkInt64LitInt64, + rule_convert "integerToWord64" integerToWord64Name (\_ -> mkWord64LitWord64), + rule_convert "integerToInt64" integerToInt64Name (\_ -> mkInt64LitInt64), rule_binop "plusInteger" plusIntegerName (+), rule_binop "minusInteger" minusIntegerName (-), rule_binop "timesInteger" timesIntegerName (*), @@ -751,10 +794,10 @@ builtinIntegerRules = rule_divop_one "quotInteger" quotIntegerName quot, rule_divop_one "remInteger" remIntegerName rem, rule_encodeFloat "encodeFloatInteger" encodeFloatIntegerName mkFloatLitFloat, - rule_convert "floatFromInteger" floatFromIntegerName mkFloatLitFloat, + rule_convert "floatFromInteger" floatFromIntegerName (\_ -> mkFloatLitFloat), rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble, rule_decodeDouble "decodeDoubleInteger" decodeDoubleIntegerName, - rule_convert "doubleFromInteger" doubleFromIntegerName mkDoubleLitDouble, + rule_convert "doubleFromInteger" doubleFromIntegerName (\_ -> mkDoubleLitDouble), rule_binop "gcdInteger" gcdIntegerName gcd, rule_binop "lcmInteger" lcmIntegerName lcm, rule_binop "andInteger" andIntegerName (.&.), @@ -889,98 +932,106 @@ match_inline _ _ = Nothing -- wordToInteger (79::Word#) = 79::Integer -- Similarly Int64, Word64 -match_IntToInteger :: Id +match_IntToInteger :: DynFlags + -> Id -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_IntToInteger id id_unf [xl] +match_IntToInteger _ id id_unf [xl] | Just (MachInt x) <- exprIsLiteral_maybe id_unf xl = case idType id of FunTy _ integerTy -> Just (Lit (LitInteger x integerTy)) _ -> panic "match_IntToInteger: Id has the wrong type" -match_IntToInteger _ _ _ = Nothing +match_IntToInteger _ _ _ _ = Nothing -match_WordToInteger :: Id +match_WordToInteger :: DynFlags + -> Id -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_WordToInteger id id_unf [xl] +match_WordToInteger _ id id_unf [xl] | Just (MachWord x) <- exprIsLiteral_maybe id_unf xl = case idType id of FunTy _ integerTy -> Just (Lit (LitInteger x integerTy)) _ -> panic "match_WordToInteger: Id has the wrong type" -match_WordToInteger _ _ _ = Nothing +match_WordToInteger _ _ _ _ = Nothing -match_Int64ToInteger :: Id +match_Int64ToInteger :: DynFlags + -> Id -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_Int64ToInteger id id_unf [xl] +match_Int64ToInteger _ id id_unf [xl] | Just (MachInt64 x) <- exprIsLiteral_maybe id_unf xl = case idType id of FunTy _ integerTy -> Just (Lit (LitInteger x integerTy)) _ -> panic "match_Int64ToInteger: Id has the wrong type" -match_Int64ToInteger _ _ _ = Nothing +match_Int64ToInteger _ _ _ _ = Nothing -match_Word64ToInteger :: Id +match_Word64ToInteger :: DynFlags + -> Id -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_Word64ToInteger id id_unf [xl] +match_Word64ToInteger _ id id_unf [xl] | Just (MachWord64 x) <- exprIsLiteral_maybe id_unf xl = case idType id of FunTy _ integerTy -> Just (Lit (LitInteger x integerTy)) _ -> panic "match_Word64ToInteger: Id has the wrong type" -match_Word64ToInteger _ _ _ = Nothing +match_Word64ToInteger _ _ _ _ = Nothing ------------------------------------------------- match_Integer_convert :: Num a - => (a -> Expr CoreBndr) + => (DynFlags -> a -> Expr CoreBndr) + -> DynFlags -> Id -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_Integer_convert convert _ id_unf [xl] +match_Integer_convert convert dflags _ id_unf [xl] | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl - = Just (convert (fromInteger x)) -match_Integer_convert _ _ _ _ = Nothing + = Just (convert dflags (fromInteger x)) +match_Integer_convert _ _ _ _ _ = Nothing match_Integer_unop :: (Integer -> Integer) + -> DynFlags -> Id -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_Integer_unop unop _ id_unf [xl] +match_Integer_unop unop _ _ id_unf [xl] | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl = Just (Lit (LitInteger (unop x) i)) -match_Integer_unop _ _ _ _ = Nothing +match_Integer_unop _ _ _ _ _ = Nothing match_Integer_binop :: (Integer -> Integer -> Integer) + -> DynFlags -> Id -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_Integer_binop binop _ id_unf [xl,yl] +match_Integer_binop binop _ _ id_unf [xl,yl] | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl = Just (Lit (LitInteger (x `binop` y) i)) -match_Integer_binop _ _ _ _ = Nothing +match_Integer_binop _ _ _ _ _ = Nothing -- This helper is used for the quotRem and divMod functions match_Integer_divop_both :: (Integer -> Integer -> (Integer, Integer)) + -> DynFlags -> Id -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_Integer_divop_both divop _ id_unf [xl,yl] +match_Integer_divop_both divop _ _ id_unf [xl,yl] | Just (LitInteger x t) <- exprIsLiteral_maybe id_unf xl , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl , y /= 0 @@ -990,74 +1041,80 @@ match_Integer_divop_both divop _ id_unf [xl,yl] Type t, Lit (LitInteger r t), Lit (LitInteger s t)] -match_Integer_divop_both _ _ _ _ = Nothing +match_Integer_divop_both _ _ _ _ _ = Nothing -- This helper is used for the quotRem and divMod functions match_Integer_divop_one :: (Integer -> Integer -> Integer) + -> DynFlags -> Id -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_Integer_divop_one divop _ id_unf [xl,yl] +match_Integer_divop_one divop _ _ id_unf [xl,yl] | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl , y /= 0 = Just (Lit (LitInteger (x `divop` y) i)) -match_Integer_divop_one _ _ _ _ = Nothing +match_Integer_divop_one _ _ _ _ _ = Nothing match_Integer_Int_binop :: (Integer -> Int -> Integer) + -> DynFlags -> Id -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_Integer_Int_binop binop _ id_unf [xl,yl] +match_Integer_Int_binop binop _ _ id_unf [xl,yl] | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl , Just (MachInt y) <- exprIsLiteral_maybe id_unf yl = Just (Lit (LitInteger (x `binop` fromIntegral y) i)) -match_Integer_Int_binop _ _ _ _ = Nothing +match_Integer_Int_binop _ _ _ _ _ = Nothing match_Integer_binop_Bool :: (Integer -> Integer -> Bool) + -> DynFlags -> Id -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_Integer_binop_Bool binop _ id_unf [xl, yl] +match_Integer_binop_Bool binop _ _ id_unf [xl, yl] | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl = Just (if x `binop` y then trueVal else falseVal) -match_Integer_binop_Bool _ _ _ _ = Nothing +match_Integer_binop_Bool _ _ _ _ _ = Nothing match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) + -> DynFlags -> Id -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_Integer_binop_Ordering binop _ id_unf [xl, yl] +match_Integer_binop_Ordering binop _ _ id_unf [xl, yl] | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl = Just $ case x `binop` y of LT -> ltVal EQ -> eqVal GT -> gtVal -match_Integer_binop_Ordering _ _ _ _ = Nothing +match_Integer_binop_Ordering _ _ _ _ _ = Nothing match_Integer_Int_encodeFloat :: RealFloat a => (a -> Expr CoreBndr) + -> DynFlags -> Id -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_Integer_Int_encodeFloat mkLit _ id_unf [xl,yl] +match_Integer_Int_encodeFloat mkLit _ _ id_unf [xl,yl] | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl , Just (MachInt y) <- exprIsLiteral_maybe id_unf yl = Just (mkLit $ encodeFloat x (fromInteger y)) -match_Integer_Int_encodeFloat _ _ _ _ = Nothing +match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing -match_decodeDouble :: Id +match_decodeDouble :: DynFlags + -> Id -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_decodeDouble fn id_unf [xl] +match_decodeDouble _ fn id_unf [xl] | Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl = case idType fn of FunTy _ (TyConApp _ [integerTy, intHashTy]) -> @@ -1070,25 +1127,27 @@ match_decodeDouble fn id_unf [xl] Lit (MachInt (toInteger z))] _ -> panic "match_decodeDouble: Id has the wrong type" -match_decodeDouble _ _ _ = Nothing +match_decodeDouble _ _ _ _ = Nothing match_XToIntegerToX :: Name + -> DynFlags -> Id -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_XToIntegerToX n _ _ [App (Var x) y] +match_XToIntegerToX n _ _ _ [App (Var x) y] | idName x == n = Just y -match_XToIntegerToX _ _ _ _ = Nothing +match_XToIntegerToX _ _ _ _ _ = Nothing match_smallIntegerTo :: PrimOp + -> DynFlags -> Id -> IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_smallIntegerTo primOp _ _ [App (Var x) y] +match_smallIntegerTo primOp _ _ _ [App (Var x) y] | idName x == smallIntegerName = Just $ App (Var (mkPrimOpId primOp)) y -match_smallIntegerTo _ _ _ _ = Nothing +match_smallIntegerTo _ _ _ _ _ = Nothing \end{code} 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/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs index ab3df0dfd0..681c183132 100644 --- a/compiler/simplCore/FloatIn.lhs +++ b/compiler/simplCore/FloatIn.lhs @@ -33,6 +33,7 @@ import Type ( isUnLiftedType ) import VarSet import Util import UniqFM +import DynFlags import Outputable \end{code} @@ -40,13 +41,13 @@ Top-level interface function, @floatInwards@. Note that we do not actually float any bindings downwards from the top-level. \begin{code} -floatInwards :: CoreProgram -> CoreProgram -floatInwards = map fi_top_bind +floatInwards :: DynFlags -> CoreProgram -> CoreProgram +floatInwards dflags = map fi_top_bind where fi_top_bind (NonRec binder rhs) - = NonRec binder (fiExpr [] (freeVars rhs)) + = NonRec binder (fiExpr dflags [] (freeVars rhs)) fi_top_bind (Rec pairs) - = Rec [ (b, fiExpr [] (freeVars rhs)) | (b, rhs) <- pairs ] + = Rec [ (b, fiExpr dflags [] (freeVars rhs)) | (b, rhs) <- pairs ] \end{code} %************************************************************************ @@ -131,20 +132,21 @@ data FloatInBind = FB BoundVarSet FreeVarSet FloatBind type FloatInBinds = [FloatInBind] -- In reverse dependency order (innermost binder first) -fiExpr :: FloatInBinds -- Binds we're trying to drop - -- as far "inwards" as possible - -> CoreExprWithFVs -- Input expr - -> CoreExpr -- Result - -fiExpr to_drop (_, AnnLit lit) = ASSERT( null to_drop ) Lit lit -fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop ) Type ty -fiExpr to_drop (_, AnnVar v) = wrapFloats to_drop (Var v) -fiExpr to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co) -fiExpr to_drop (_, AnnCast expr (fvs_co, co)) +fiExpr :: DynFlags + -> FloatInBinds -- Binds we're trying to drop + -- as far "inwards" as possible + -> CoreExprWithFVs -- Input expr + -> CoreExpr -- Result + +fiExpr _ to_drop (_, AnnLit lit) = ASSERT( null to_drop ) Lit lit +fiExpr _ to_drop (_, AnnType ty) = ASSERT( null to_drop ) Type ty +fiExpr _ to_drop (_, AnnVar v) = wrapFloats to_drop (Var v) +fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co) +fiExpr dflags to_drop (_, AnnCast expr (fvs_co, co)) = wrapFloats (drop_here ++ co_drop) $ - Cast (fiExpr e_drop expr) co + Cast (fiExpr dflags e_drop expr) co where - [drop_here, e_drop, co_drop] = sepBindsByDropPoint False [freeVarsOf expr, fvs_co] to_drop + [drop_here, e_drop, co_drop] = sepBindsByDropPoint dflags False [freeVarsOf expr, fvs_co] to_drop \end{code} Applications: we do float inside applications, mainly because we @@ -152,16 +154,16 @@ need to get at all the arguments. The next simplifier run will pull out any silly ones. \begin{code} -fiExpr to_drop (_,AnnApp fun arg@(arg_fvs, ann_arg)) +fiExpr dflags to_drop (_,AnnApp fun arg@(arg_fvs, ann_arg)) | noFloatIntoRhs ann_arg = wrapFloats drop_here $ wrapFloats arg_drop $ - App (fiExpr fun_drop fun) (fiExpr [] arg) + App (fiExpr dflags fun_drop fun) (fiExpr dflags [] arg) -- It's inconvenient to test for an unlifted arg here, -- and it really doesn't matter if we float into one | otherwise = wrapFloats drop_here $ - App (fiExpr fun_drop fun) (fiExpr arg_drop arg) + App (fiExpr dflags fun_drop fun) (fiExpr dflags arg_drop arg) where [drop_here, fun_drop, arg_drop] - = sepBindsByDropPoint False [freeVarsOf fun, arg_fvs] to_drop + = sepBindsByDropPoint dflags False [freeVarsOf fun, arg_fvs] to_drop \end{code} Note [Floating in past a lambda group] @@ -203,13 +205,13 @@ Urk! if all are tyvars, and we don't float in, we may miss an opportunity to float inside a nested case branch \begin{code} -fiExpr to_drop lam@(_, AnnLam _ _) +fiExpr dflags to_drop lam@(_, AnnLam _ _) | okToFloatInside bndrs -- Float in -- NB: Must line up with noFloatIntoRhs (AnnLam...); see Trac #7088 - = mkLams bndrs (fiExpr to_drop body) + = mkLams bndrs (fiExpr dflags to_drop body) | otherwise -- Dump it all here - = wrapFloats to_drop (mkLams bndrs (fiExpr [] body)) + = wrapFloats to_drop (mkLams bndrs (fiExpr dflags [] body)) where (bndrs, body) = collectAnnBndrs lam @@ -221,13 +223,13 @@ We don't float lets inwards past an SCC. cc, change current cc to the new one and float binds into expr. \begin{code} -fiExpr to_drop (_, AnnTick tickish expr) +fiExpr dflags to_drop (_, AnnTick tickish expr) | tickishScoped tickish = -- Wimp out for now - we could push values in - wrapFloats to_drop (Tick tickish (fiExpr [] expr)) + wrapFloats to_drop (Tick tickish (fiExpr dflags [] expr)) | otherwise - = Tick tickish (fiExpr to_drop expr) + = Tick tickish (fiExpr dflags to_drop expr) \end{code} For @Lets@, the possible ``drop points'' for the \tr{to_drop} @@ -281,8 +283,8 @@ idFreeVars. \begin{code} -fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body) - = fiExpr new_to_drop body +fiExpr dflags to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body) + = fiExpr dflags new_to_drop body where body_fvs = freeVarsOf body `delVarSet` id @@ -295,7 +297,7 @@ fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body) -- Ditto ok-for-speculation unlifted RHSs [shared_binds, extra_binds, rhs_binds, body_binds] - = sepBindsByDropPoint False [extra_fvs, rhs_fvs, body_fvs] to_drop + = sepBindsByDropPoint dflags False [extra_fvs, rhs_fvs, body_fvs] to_drop new_to_drop = body_binds ++ -- the bindings used only in the body [FB (unitVarSet id) rhs_fvs' @@ -304,12 +306,12 @@ fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body) shared_binds -- the bindings used both in rhs and body -- Push rhs_binds into the right hand side of the binding - rhs' = fiExpr rhs_binds rhs + rhs' = fiExpr dflags rhs_binds rhs rhs_fvs' = rhs_fvs `unionVarSet` floatedBindsFVs rhs_binds `unionVarSet` rule_fvs -- Don't forget the rule_fvs; the binding mentions them! -fiExpr to_drop (_,AnnLet (AnnRec bindings) body) - = fiExpr new_to_drop body +fiExpr dflags to_drop (_,AnnLet (AnnRec bindings) body) + = fiExpr dflags new_to_drop body where (ids, rhss) = unzip bindings rhss_fvs = map freeVarsOf rhss @@ -322,7 +324,7 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body) , noFloatIntoRhs rhs ] (shared_binds:extra_binds:body_binds:rhss_binds) - = sepBindsByDropPoint False (extra_fvs:body_fvs:rhss_fvs) to_drop + = sepBindsByDropPoint dflags False (extra_fvs:body_fvs:rhss_fvs) to_drop new_to_drop = body_binds ++ -- the bindings used only in the body [FB (mkVarSet ids) rhs_fvs' @@ -341,7 +343,7 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body) -> [(Id, CoreExpr)] fi_bind to_drops pairs - = [ (binder, fiExpr to_drop rhs) + = [ (binder, fiExpr dflags to_drop rhs) | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ] \end{code} @@ -358,32 +360,32 @@ alternative that binds the elements of the tuple. We now therefore also support floating in cases with a single alternative that may bind values. \begin{code} -fiExpr to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)]) +fiExpr dflags to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)]) | isUnLiftedType (idType case_bndr) , exprOkForSideEffects (deAnnotate scrut) = wrapFloats shared_binds $ - fiExpr (case_float : rhs_binds) rhs + fiExpr dflags (case_float : rhs_binds) rhs where case_float = FB (mkVarSet (case_bndr : alt_bndrs)) scrut_fvs (FloatCase scrut' case_bndr con alt_bndrs) - scrut' = fiExpr scrut_binds scrut + scrut' = fiExpr dflags scrut_binds scrut [shared_binds, scrut_binds, rhs_binds] - = sepBindsByDropPoint False [freeVarsOf scrut, rhs_fvs] to_drop + = sepBindsByDropPoint dflags False [freeVarsOf scrut, rhs_fvs] to_drop rhs_fvs = freeVarsOf rhs `delVarSetList` (case_bndr : alt_bndrs) scrut_fvs = freeVarsOf scrut -fiExpr to_drop (_, AnnCase scrut case_bndr ty alts) +fiExpr dflags to_drop (_, AnnCase scrut case_bndr ty alts) = wrapFloats drop_here1 $ wrapFloats drop_here2 $ - Case (fiExpr scrut_drops scrut) case_bndr ty + Case (fiExpr dflags scrut_drops scrut) case_bndr ty (zipWith fi_alt alts_drops_s alts) where -- Float into the scrut and alts-considered-together just like App [drop_here1, scrut_drops, alts_drops] - = sepBindsByDropPoint False [scrut_fvs, all_alts_fvs] to_drop + = sepBindsByDropPoint dflags False [scrut_fvs, all_alts_fvs] to_drop -- Float into the alts with the is_case flag set - (drop_here2 : alts_drops_s) = sepBindsByDropPoint True alts_fvs alts_drops + (drop_here2 : alts_drops_s) = sepBindsByDropPoint dflags True alts_fvs alts_drops scrut_fvs = freeVarsOf scrut alts_fvs = map alt_fvs alts @@ -392,7 +394,7 @@ fiExpr to_drop (_, AnnCase scrut case_bndr ty alts) -- Delete case_bndr and args from free vars of rhs -- to get free vars of alt - fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs) + fi_alt to_drop (con, args, rhs) = (con, args, fiExpr dflags to_drop rhs) okToFloatInside :: [Var] -> Bool okToFloatInside bndrs = all ok bndrs @@ -444,7 +446,8 @@ We have to maintain the order on these drop-point-related lists. \begin{code} sepBindsByDropPoint - :: Bool -- True <=> is case expression + :: DynFlags + -> Bool -- True <=> is case expression -> [FreeVarSet] -- One set of FVs per drop point -> FloatInBinds -- Candidate floaters -> [FloatInBinds] -- FIRST one is bindings which must not be floated @@ -459,10 +462,10 @@ sepBindsByDropPoint type DropBox = (FreeVarSet, FloatInBinds) -sepBindsByDropPoint _is_case drop_pts [] +sepBindsByDropPoint _ _is_case drop_pts [] = [] : [[] | _ <- drop_pts] -- cut to the chase scene; it happens -sepBindsByDropPoint is_case drop_pts floaters +sepBindsByDropPoint dflags is_case drop_pts floaters = go floaters (map (\fvs -> (fvs, [])) (emptyVarSet : drop_pts)) where go :: FloatInBinds -> [DropBox] -> [FloatInBinds] @@ -498,7 +501,7 @@ sepBindsByDropPoint is_case drop_pts floaters || (is_case && -- We are looking at case alternatives n_used_alts > 1 && -- It's used in more than one n_used_alts < n_alts && -- ...but not all - floatIsDupable bind) -- and we can duplicate the binding + floatIsDupable dflags bind) -- and we can duplicate the binding new_boxes | drop_here = (insert here_box : fork_boxes) | otherwise = (here_box : new_fork_boxes) @@ -525,8 +528,8 @@ wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr wrapFloats [] e = e wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e) -floatIsDupable :: FloatBind -> Bool -floatIsDupable (FloatCase scrut _ _ _) = exprIsDupable scrut -floatIsDupable (FloatLet (Rec prs)) = all (exprIsDupable . snd) prs -floatIsDupable (FloatLet (NonRec _ r)) = exprIsDupable r +floatIsDupable :: DynFlags -> FloatBind -> Bool +floatIsDupable dflags (FloatCase scrut _ _ _) = exprIsDupable dflags scrut +floatIsDupable dflags (FloatLet (Rec prs)) = all (exprIsDupable dflags . snd) prs +floatIsDupable dflags (FloatLet (NonRec _ r)) = exprIsDupable dflags r \end{code} diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 731f55128c..268a918e37 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -378,8 +378,8 @@ doCorePass _ CoreCSE = {-# SCC "CommonSubExpr" #-} doCorePass _ CoreLiberateCase = {-# SCC "LiberateCase" #-} doPassD liberateCase -doCorePass _ CoreDoFloatInwards = {-# SCC "FloatInwards" #-} - doPass floatInwards +doCorePass dflags CoreDoFloatInwards = {-# SCC "FloatInwards" #-} + doPass (floatInwards dflags) doCorePass _ (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-} doPassDUM (floatOutwards f) diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index bc991b3bf1..f76fec1033 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -1553,7 +1553,8 @@ tryRules env rules fn args call_cont | null rules = return Nothing | otherwise - = do { case lookupRule (activeRule env) (getUnfoldingInRuleMatch env) + = do { dflags <- getDynFlags + ; case lookupRule dflags (activeRule env) (getUnfoldingInRuleMatch env) (getInScope env) fn args rules of { Nothing -> return Nothing ; -- No rule matches Just (rule, rule_rhs) -> @@ -2337,11 +2338,12 @@ mkDupableAlts env case_bndr' the_alts mkDupableAlt :: SimplEnv -> OutId -> (AltCon, [CoreBndr], CoreExpr) -> SimplM (SimplEnv, (AltCon, [CoreBndr], CoreExpr)) -mkDupableAlt env case_bndr (con, bndrs', rhs') - | exprIsDupable rhs' -- Note [Small alternative rhs] - = return (env, (con, bndrs', rhs')) - | otherwise - = do { let rhs_ty' = exprType rhs' +mkDupableAlt env case_bndr (con, bndrs', rhs') = do + dflags <- getDynFlags + if exprIsDupable dflags rhs' -- Note [Small alternative rhs] + then return (env, (con, bndrs', rhs')) + else + do { let rhs_ty' = exprType rhs' scrut_ty = idType case_bndr case_bndr_w_unf = case con of 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/specialise/Rules.lhs b/compiler/specialise/Rules.lhs index 231fd27ac6..9c473e5a3a 100644 --- a/compiler/specialise/Rules.lhs +++ b/compiler/specialise/Rules.lhs @@ -47,6 +47,7 @@ import Name ( Name, NamedThing(..) ) import NameEnv import Unify ( ruleMatchTyX, MatchEnv(..) ) import BasicTypes ( Activation, CompilerPhase, isActive ) +import DynFlags ( DynFlags ) import StaticFlags ( opt_PprStyle_Debug ) import Outputable import FastString @@ -350,7 +351,8 @@ pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs) -- supplied rules to this instance of an application in a given -- context, returning the rule applied and the resulting expression if -- successful. -lookupRule :: (Activation -> Bool) -- When rule is active +lookupRule :: DynFlags + -> (Activation -> Bool) -- When rule is active -> IdUnfoldingFun -- When Id can be unfolded -> InScopeSet -> Id -> [CoreExpr] @@ -358,7 +360,7 @@ lookupRule :: (Activation -> Bool) -- When rule is active -- See Note [Extra args in rule matching] -- See comments on matchRule -lookupRule is_active id_unf in_scope fn args rules +lookupRule dflags is_active id_unf in_scope fn args rules = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $ case go [] rules of [] -> Nothing @@ -368,7 +370,7 @@ lookupRule is_active id_unf in_scope fn args rules go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)] go ms [] = ms - go ms (r:rs) = case (matchRule fn is_active id_unf in_scope args rough_args r) of + go ms (r:rs) = case (matchRule dflags fn is_active id_unf in_scope args rough_args r) of Just e -> go ((r,e):ms) rs Nothing -> -- pprTrace "match failed" (ppr r $$ ppr args $$ -- ppr [ (arg_id, unfoldingTemplate unf) @@ -445,7 +447,7 @@ to lookupRule are the result of a lazy substitution \begin{code} ------------------------------------ -matchRule :: Id -> (Activation -> Bool) -> IdUnfoldingFun +matchRule :: DynFlags -> Id -> (Activation -> Bool) -> IdUnfoldingFun -> InScopeSet -> [CoreExpr] -> [Maybe Name] -> CoreRule -> Maybe CoreExpr @@ -472,14 +474,14 @@ matchRule :: Id -> (Activation -> Bool) -> IdUnfoldingFun -- Any 'surplus' arguments in the input are simply put on the end -- of the output. -matchRule fn _is_active id_unf _in_scope args _rough_args +matchRule dflags fn _is_active id_unf _in_scope args _rough_args (BuiltinRule { ru_try = match_fn }) -- Built-in rules can't be switched off, it seems - = case match_fn fn id_unf args of + = case match_fn dflags fn id_unf args of Just expr -> Just expr Nothing -> Nothing -matchRule _ is_active id_unf in_scope args rough_args +matchRule _ _ is_active id_unf in_scope args rough_args (Rule { ru_act = act, ru_rough = tpl_tops, ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs }) @@ -1085,21 +1087,22 @@ ruleAppCheck_help env fn args rules i_args = args `zip` [1::Int ..] rough_args = map roughTopName args - check_rule rule = rule_herald rule <> colon <+> rule_info rule + check_rule rule = sdocWithDynFlags $ \dflags -> + rule_herald rule <> colon <+> rule_info dflags rule rule_herald (BuiltinRule { ru_name = name }) = ptext (sLit "Builtin rule") <+> doubleQuotes (ftext name) rule_herald (Rule { ru_name = name }) = ptext (sLit "Rule") <+> doubleQuotes (ftext name) - rule_info rule - | Just _ <- matchRule fn noBlackList (rc_id_unf env) emptyInScopeSet args rough_args rule + rule_info dflags rule + | Just _ <- matchRule dflags fn noBlackList (rc_id_unf env) emptyInScopeSet args rough_args rule = text "matches (which is very peculiar!)" - rule_info (BuiltinRule {}) = text "does not match" + rule_info _ (BuiltinRule {}) = text "does not match" - rule_info (Rule { ru_act = act, - ru_bndrs = rule_bndrs, ru_args = rule_args}) + rule_info _ (Rule { ru_act = act, + ru_bndrs = rule_bndrs, ru_args = rule_args}) | not (rc_is_active env act) = text "active only in later phase" | n_args < n_rule_args = text "too few arguments" | n_mismatches == n_rule_args = text "no arguments match" diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index 4307ff75df..083d1502bb 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -1063,9 +1063,9 @@ specCalls subst rules_for_me calls_for_me fn rhs body = mkLams (drop n_dicts rhs_ids) rhs_body -- Glue back on the non-dict lambdas - already_covered :: [CoreExpr] -> Bool - already_covered args -- Note [Specialisations already covered] - = isJust (lookupRule (const True) realIdUnfolding + already_covered :: DynFlags -> [CoreExpr] -> Bool + already_covered dflags args -- Note [Specialisations already covered] + = isJust (lookupRule dflags (const True) realIdUnfolding (substInScope subst) fn args rules_for_me) @@ -1119,7 +1119,8 @@ specCalls subst rules_for_me calls_for_me fn rhs ty_args = mk_ty_args call_ts poly_tyvars inst_args = ty_args ++ map Var inst_dict_ids - ; if already_covered inst_args then + ; dflags <- getDynFlags + ; if already_covered dflags inst_args then return Nothing else do { -- Figure out the type of the specialised function 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/Inst.lhs b/compiler/typecheck/Inst.lhs index bbad59ec6e..2de781578d 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -251,15 +251,24 @@ cases (the rest are caught in lookupInst). \begin{code} newOverloadedLit :: CtOrigin - -> HsOverLit Name - -> TcRhoType - -> TcM (HsOverLit TcId) -newOverloadedLit orig + -> HsOverLit Name + -> TcRhoType + -> TcM (HsOverLit TcId) +newOverloadedLit orig lit res_ty + = do dflags <- getDynFlags + newOverloadedLit' dflags orig lit res_ty + +newOverloadedLit' :: DynFlags + -> CtOrigin + -> HsOverLit Name + -> TcRhoType + -> TcM (HsOverLit TcId) +newOverloadedLit' dflags orig lit@(OverLit { ol_val = val, ol_rebindable = rebindable , ol_witness = meth_name }) res_ty | not rebindable - , Just expr <- shortCutLit val res_ty + , Just expr <- shortCutLit dflags val res_ty -- Do not generate a LitInst for rebindable syntax. -- Reason: If we do, tcSimplify will call lookupInst, which -- will call tcSyntaxName, which does unification, 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/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 1ddcd316c1..84907fb306 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -126,24 +126,24 @@ hsLitType (HsDoublePrim _) = doublePrimTy Overloaded literals. Here mainly becuase it uses isIntTy etc \begin{code} -shortCutLit :: OverLitVal -> TcType -> Maybe (HsExpr TcId) -shortCutLit (HsIntegral i) ty - | isIntTy ty && inIntRange i = Just (HsLit (HsInt i)) - | isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i)) - | isIntegerTy ty = Just (HsLit (HsInteger i ty)) - | otherwise = shortCutLit (HsFractional (integralFractionalLit i)) ty +shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr TcId) +shortCutLit dflags (HsIntegral i) ty + | isIntTy ty && inIntRange dflags i = Just (HsLit (HsInt i)) + | isWordTy ty && inWordRange dflags i = Just (mkLit wordDataCon (HsWordPrim i)) + | isIntegerTy ty = Just (HsLit (HsInteger i ty)) + | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit i)) ty -- The 'otherwise' case is important -- Consider (3 :: Float). Syntactically it looks like an IntLit, -- so we'll call shortCutIntLit, but of course it's a float -- This can make a big difference for programs with a lot of -- literals, compiled without -O -shortCutLit (HsFractional f) ty +shortCutLit _ (HsFractional f) ty | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim f)) | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f)) | otherwise = Nothing -shortCutLit (HsIsString s) ty +shortCutLit _ (HsIsString s) ty | isStringTy ty = Just (HsLit (HsString s)) | otherwise = Nothing diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 8b84d552f1..3cfc7044c6 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -285,16 +285,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/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 40ed8983c1..e25ddc7580 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -1042,7 +1042,9 @@ tcConArg new_or_data bty = do { traceTc "tcConArg 1" (ppr bty) ; arg_ty <- tcHsConArgType new_or_data bty ; traceTc "tcConArg 2" (ppr bty) - ; strict_mark <- chooseBoxingStrategy arg_ty (getBangStrictness bty) + ; dflags <- getDynFlags + ; let strict_mark = chooseBoxingStrategy dflags arg_ty (getBangStrictness bty) + -- Must be computed lazily ; return (arg_ty, strict_mark) } tcConRes :: ResType (LHsType Name) -> TcM (ResType Type) @@ -1178,10 +1180,20 @@ conRepresentibleWithH98Syntax -- -- We have turned off unboxing of newtypes because coercions make unboxing -- and reboxing more complicated -chooseBoxingStrategy :: TcType -> HsBang -> TcM HsBang -chooseBoxingStrategy arg_ty bang - = do { dflags <- getDynFlags - ; let choice = case bang of +chooseBoxingStrategy :: DynFlags -> TcType -> HsBang -> HsBang +chooseBoxingStrategy dflags arg_ty bang + = case initial_choice of + HsUnpack | dopt Opt_OmitInterfacePragmas dflags + -> HsStrict + _other -> initial_choice + -- Do not respect UNPACK pragmas if OmitInterfacePragmas is on + -- See Trac #5252: unpacking means we must not conceal the + -- representation of the argument type + -- However: even when OmitInterfacePragmas is on, we still want + -- to know if we have HsUnpackFailed, because we omit a + -- warning in that case (#3966) + where + initial_choice = case bang of HsNoBang -> HsNoBang HsStrict | dopt Opt_UnboxStrictFields dflags -> can_unbox HsStrict arg_ty @@ -1191,18 +1203,6 @@ chooseBoxingStrategy arg_ty bang HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty) -- Source code never has HsUnpackFailed - ; case choice of - HsUnpack | dopt Opt_OmitInterfacePragmas dflags - -> return HsStrict - _other -> return choice - -- Do not respect UNPACK pragmas if OmitInterfacePragmas is on - -- See Trac #5252: unpacking means we must not conceal the - -- representation of the argument type - -- However: even when OmitInterfacePragmas is on, we still want - -- to know if we have HsUnpackFailed, because we omit a - -- warning in that case (#3966) - } - where can_unbox :: HsBang -> TcType -> HsBang -- Returns HsUnpack if we can unpack arg_ty -- fail_bang if we know what arg_ty is but we can't unpack it 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/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs index 8c5ef0045d..527cbfcb4d 100644 --- a/compiler/vectorise/Vectorise/Exp.hs +++ b/compiler/vectorise/Vectorise/Exp.hs @@ -728,11 +728,12 @@ vectLam inline loop_breaker expr@(fvs, AnnLam _ _) vi -- in Figure 6 of HtM. break_loop lc ty (ve, le) | loop_breaker - = do { empty <- emptyPD ty + = do { dflags <- getDynFlags + ; empty <- emptyPD ty ; lty <- mkPDataType ty ; return (ve, mkWildCase (Var lc) intPrimTy lty [(DEFAULT, [], le), - (LitAlt (mkMachInt 0), [], empty)]) + (LitAlt (mkMachInt dflags 0), [], empty)]) } | otherwise = return (ve, le) vectLam _ _ _ _ = panic "vectLam" @@ -844,9 +845,10 @@ vectAlgCase tycon _ty_args scrut bndr ty alts (VITNode _ (scrutVit : altVits)) proc_alt arity sel _ lty ((DataAlt dc, bndrs, body), vi) = do + dflags <- getDynFlags vect_dc <- maybeV dataConErr (lookupDataCon dc) let ntag = dataConTagZ vect_dc - tag = mkDataConTag vect_dc + tag = mkDataConTag dflags vect_dc fvs = freeVarsOf body `delVarSetList` bndrs sel_tags <- liftM (`App` sel) (builtin (selTags arity)) diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs index 0051d072a4..5dfbaa5555 100644 --- a/compiler/vectorise/Vectorise/Type/Env.hs +++ b/compiler/vectorise/Vectorise/Type/Env.hs @@ -36,6 +36,7 @@ import OccName import Util import Outputable +import DynFlags import FastString import MonadUtils @@ -375,8 +376,9 @@ vectDataConWorkers orig_tc vect_tc arr_tc rep_tys = map dataConRepArgTys $ tyConDataCons vect_tc mk_data_con con tys pre post - = liftM2 (,) (vect_data_con con) - (lift_data_con tys pre post (mkDataConTag con)) + = do dflags <- getDynFlags + liftM2 (,) (vect_data_con con) + (lift_data_con tys pre post (mkDataConTag dflags con)) sel_replicate len tag | arity > 1 = do diff --git a/compiler/vectorise/Vectorise/Utils/Base.hs b/compiler/vectorise/Vectorise/Utils/Base.hs index 9ed4e2c60e..a03875f116 100644 --- a/compiler/vectorise/Vectorise/Utils/Base.hs +++ b/compiler/vectorise/Vectorise/Utils/Base.hs @@ -37,6 +37,7 @@ import Type import TyCon import DataCon import MkId +import DynFlags import FastString -- Simple Types --------------------------------------------------------------- @@ -58,8 +59,8 @@ newLocalVVar fs vty -- Constructors --------------------------------------------------------------- -mkDataConTag :: DataCon -> CoreExpr -mkDataConTag = mkIntLitInt . dataConTagZ +mkDataConTag :: DynFlags -> DataCon -> CoreExpr +mkDataConTag dflags = mkIntLitInt dflags . dataConTagZ dataConTagZ :: DataCon -> Int dataConTagZ con = dataConTag con - fIRST_TAG diff --git a/docs/users_guide/ffi-chap.xml b/docs/users_guide/ffi-chap.xml index 2425d822c9..e778c034d0 100644 --- a/docs/users_guide/ffi-chap.xml +++ b/docs/users_guide/ffi-chap.xml @@ -164,7 +164,7 @@ foreign import ccall interruptible <sect2 id="ffi-capi"> <title>The CAPI calling convention</title> <para> - The <literal>CAPI</literal> extension allows a calling + The <literal>CApiFFI</literal> extension allows a calling convention of <literal>capi</literal> to be used in foreign declarations, e.g. 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/HaskellConstants.hs b/includes/HaskellConstants.hs deleted file mode 100644 index 4ad7deef19..0000000000 --- a/includes/HaskellConstants.hs +++ /dev/null @@ -1,58 +0,0 @@ - -import Data.Word -import Data.Int - --- This magical #include brings in all the everybody-knows-these magic --- constants unfortunately, we need to be *explicit* about which one --- we want; if we just hope a -I... will get the right one, we could --- be in trouble. - -{- -Pull in the autoconf defines (HAVE_FOO), but don't include -ghcconfig.h, because that will include ghcplatform.h which has the -wrong platform settings for the compiler (it has the platform -settings for the target plat instead). --} -#include "../includes/ghcautoconf.h" - -#include "stg/HaskellMachRegs.h" - -#include "rts/Constants.h" -#include "MachDeps.h" -#include "../includes/dist-derivedconstants/header/DerivedConstants.h" - --- import Util - --- All pretty arbitrary: - -mAX_TUPLE_SIZE :: Int -mAX_TUPLE_SIZE = 62 -- Should really match the number - -- of decls in Data.Tuple - -mAX_CONTEXT_REDUCTION_DEPTH :: Int -mAX_CONTEXT_REDUCTION_DEPTH = 200 - -- Increase to 200; see Trac #5395 - -wORD64_SIZE :: Int -wORD64_SIZE = 8 - --- Define a fixed-range integral type equivalent to the target Int/Word - -#if SIZEOF_HSWORD == 4 -type TargetInt = Int32 -type TargetWord = Word32 -#elif SIZEOF_HSWORD == 8 -type TargetInt = Int64 -type TargetWord = Word64 -#else -#error unknown SIZEOF_HSWORD -#endif - -tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD :: Integer -tARGET_MIN_INT = fromIntegral (minBound :: TargetInt) -tARGET_MAX_INT = fromIntegral (maxBound :: TargetInt) -tARGET_MAX_WORD = fromIntegral (maxBound :: TargetWord) - -tARGET_MAX_CHAR :: Int -tARGET_MAX_CHAR = 0x10ffff - diff --git a/includes/mkDerivedConstants.c b/includes/mkDerivedConstants.c index 558d709f94..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) \ @@ -293,30 +307,38 @@ enum Mode { Gen_Haskell_Type, Gen_Haskell_Value, Gen_Haskell_Wrappers, Gen_Haske #define FUN_OFFSET(sym) (OFFSET(Capability,f.sym) - OFFSET(Capability,r)) -void constantIntC(char *cName, char *haskellName, intptr_t val) { - /* If the value is larger than 2^28 or smaller than -2^28, then fail. - This test is a bit conservative, but if any constants are roughly - maxBoun or minBound then we probably need them to be Integer - rather than Int so that cross-compiling between 32bit and 64bit - platforms works. */ - if (val > 268435456) { - printf("Value too large for constantInt: %" PRIdPTR "\n", val); - exit(1); - } - if (val < -268435456) { - printf("Value too small for constantInt: %" PRIdPTR "\n", val); - exit(1); +void constantBool(char *haskellName, int val) { + switch (mode) { + case Gen_Haskell_Type: + printf(" , pc_%s :: Bool\n", haskellName); + break; + case Gen_Haskell_Value: + printf(" , pc_%s = %s\n", haskellName, val ? "True" : "False"); + break; + case Gen_Haskell_Wrappers: + printf("%s :: DynFlags -> Bool\n", haskellName); + printf("%s dflags = pc_%s (sPlatformConstants (settings dflags))\n", + haskellName, haskellName); + break; + case Gen_Haskell_Exports: + printf(" %s,\n", haskellName); + break; + case Gen_Header: + break; } +} +void constantIntegralC(char *haskellType, char *cName, char *haskellName, + intptr_t val) { switch (mode) { case Gen_Haskell_Type: - printf(" , pc_%s :: Int\n", haskellName); + printf(" , pc_%s :: %s\n", haskellName, haskellType); break; case Gen_Haskell_Value: printf(" , pc_%s = %" PRIdPTR "\n", haskellName, val); break; case Gen_Haskell_Wrappers: - printf("%s :: DynFlags -> Int\n", haskellName); + printf("%s :: DynFlags -> %s\n", haskellName, haskellType); printf("%s dflags = pc_%s (sPlatformConstants (settings dflags))\n", haskellName, haskellName); break; @@ -331,8 +353,30 @@ void constantIntC(char *cName, char *haskellName, intptr_t val) { } } +void constantIntC(char *cName, char *haskellName, intptr_t val) { + /* If the value is larger than 2^28 or smaller than -2^28, then fail. + This test is a bit conservative, but if any constants are roughly + maxBoun or minBound then we probably need them to be Integer + rather than Int so that cross-compiling between 32bit and 64bit + platforms works. */ + if (val > 268435456) { + printf("Value too large for constantInt: %" PRIdPTR "\n", val); + exit(1); + } + if (val < -268435456) { + printf("Value too small for constantInt: %" PRIdPTR "\n", val); + exit(1); + } + + constantIntegralC("Int", cName, haskellName, val); +} + void constantInt(char *name, intptr_t val) { - constantIntC (NULL, name, val); + constantIntC(NULL, name, val); +} + +void constantInteger(char *name, intptr_t val) { + constantIntegralC("Integer", NULL, name, val); } int @@ -392,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 @@ -423,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. @@ -700,9 +768,22 @@ main(int argc, char *argv[]) // Amount of pointer bits used for semi-tagging constructor closures constantInt("tAG_BITS", TAG_BITS); + constantBool("wORDS_BIGENDIAN", +#ifdef WORDS_BIGENDIAN + 1 +#else + 0 +#endif + ); + + constantInt("lDV_SHIFT", LDV_SHIFT); + constantInteger("iLDV_CREATE_MASK", LDV_CREATE_MASK); + constantInteger("iLDV_STATE_CREATE", LDV_STATE_CREATE); + constantInteger("iLDV_STATE_USE", LDV_STATE_USE); + 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 7bdaef5868..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++) { @@ -404,6 +404,10 @@ GarbageCollect (nat collect_gen, break; } + if (n_gc_threads != 1) { + gct->allocated = clearNursery(cap); + } + shutdown_gc_threads(gct->thread_index); // Now see which stable names are still alive. @@ -574,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 @@ -585,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; @@ -636,9 +643,15 @@ GarbageCollect (nat collect_gen, allocated += clearNursery(&capabilities[n]); } } else { - gct->allocated = clearNursery(cap); + // When doing parallel GC, clearNursery() is called by the + // worker threads, and the value returned is stored in + // gct->allocated. for (n = 0; n < n_capabilities; n++) { - allocated += gc_threads[n]->allocated; + if (gc_threads[n]->idle) { + allocated += clearNursery(&capabilities[n]); + } else { + allocated += gc_threads[n]->allocated; + } } } 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)\"" |