diff options
Diffstat (limited to 'compiler')
133 files changed, 3323 insertions, 3206 deletions
diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 5c931d9d3a..a380b742f6 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -19,7 +19,9 @@ types that module BasicTypes( Version, bumpVersion, initialVersion, - Arity, + Arity, + + Alignment, FunctionOrData(..), @@ -96,6 +98,16 @@ type Arity = Int %************************************************************************ %* * +\subsection[Alignment]{Alignment} +%* * +%************************************************************************ + +\begin{code} +type Alignment = Int -- align to next N-byte boundary (N must be a power of 2). +\end{code} + +%************************************************************************ +%* * \subsection[FunctionOrData]{FunctionOrData} %* * %************************************************************************ diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 312ae943a8..6e02ed9f0a 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -56,6 +56,7 @@ import FastString import Module import qualified Data.Data as Data +import qualified Data.Typeable import Data.Char import Data.Word \end{code} @@ -374,6 +375,7 @@ data DataCon -- Used for Template Haskell and 'deriving' only -- The actual fixity is stored elsewhere } + deriving Data.Typeable.Typeable -- | Contains the Ids of the data constructor functions data DataConIds @@ -456,9 +458,6 @@ instance Outputable DataCon where instance Show DataCon where showsPrec p con = showsPrecSDoc p (ppr con) -instance Data.Typeable DataCon where - typeOf _ = Data.mkTyConApp (Data.mkTyCon "DataCon") [] - instance Data.Data DataCon where -- don't traverse? toConstr _ = abstractConstr "DataCon" diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index bf58c5ac19..7993b05deb 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -584,7 +584,7 @@ mkProductBox arg_ids ty result_expr | isNewTyCon tycon && not (isRecursiveTyCon tycon) = wrap (mkProductBox arg_ids (newTyConInstRhs tycon tycon_args)) - | otherwise = mkConApp pack_con (map Type tycon_args ++ map Var arg_ids) + | otherwise = mkConApp pack_con (map Type tycon_args ++ varsToCoreExprs arg_ids) wrap expr = wrapNewTypeBody tycon tycon_args expr diff --git a/compiler/basicTypes/NameSet.lhs b/compiler/basicTypes/NameSet.lhs index bef9e928fd..ebb5b9fd86 100644 --- a/compiler/basicTypes/NameSet.lhs +++ b/compiler/basicTypes/NameSet.lhs @@ -34,9 +34,6 @@ module NameSet ( import Name import UniqSet -import Util - -import Data.Data \end{code} %************************************************************************ @@ -48,20 +45,7 @@ import Data.Data \begin{code} type NameSet = UniqSet Name --- TODO: These Data/Typeable instances look very dubious. Surely either --- UniqFM should have the instances, or this should be a newtype? - -nameSetTc :: TyCon -nameSetTc = mkTyCon "NameSet" -instance Typeable NameSet where { typeOf _ = mkTyConApp nameSetTc [] } - -instance Data NameSet where - gfoldl k z s = z mkNameSet `k` nameSetToList s -- traverse abstractly - toConstr _ = abstractConstr "NameSet" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "NameSet" - -emptyNameSet :: NameSet +emptyNameSet :: NameSet unitNameSet :: Name -> NameSet addListToNameSet :: NameSet -> [Name] -> NameSet addOneToNameSet :: NameSet -> Name -> NameSet diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 3451c7d5a9..8828adb0d0 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -100,6 +100,7 @@ module CLabel ( hasCAF, infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl, + localiseLabel, needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel, isMathFun, isCFunctionLabel, isGcPtrLabel, labelDynamic, @@ -278,11 +279,14 @@ pprDebugCLabel lbl _ -> ppr lbl <> (parens $ text "other CLabel)") +-- True if a local IdLabel that we won't mark as exported +type IsLocal = Bool + data IdLabelInfo = Closure -- ^ Label for closure | SRT -- ^ Static reference table - | InfoTable -- ^ Info tables for closures; always read-only - | Entry -- ^ Entry point + | InfoTable IsLocal -- ^ Info tables for closures; always read-only + | Entry IsLocal -- ^ Entry point | Slow -- ^ Slow entry point | RednCounts -- ^ Label of place to keep Ticky-ticky info for this Id @@ -356,13 +360,13 @@ mkRednCountsLabel name c = IdLabel name c RednCounts -- These have local & (possibly) external variants: mkLocalClosureLabel name c = IdLabel name c Closure -mkLocalInfoTableLabel name c = IdLabel name c InfoTable -mkLocalEntryLabel name c = IdLabel name c Entry +mkLocalInfoTableLabel name c = IdLabel name c (InfoTable True) +mkLocalEntryLabel name c = IdLabel name c (Entry True) mkLocalClosureTableLabel name c = IdLabel name c ClosureTable mkClosureLabel name c = IdLabel name c Closure -mkInfoTableLabel name c = IdLabel name c InfoTable -mkEntryLabel name c = IdLabel name c Entry +mkInfoTableLabel name c = IdLabel name c (InfoTable False) +mkEntryLabel name c = IdLabel name c (Entry False) mkClosureTableLabel name c = IdLabel name c ClosureTable mkLocalConInfoTableLabel c con = IdLabel con c ConInfoTable mkLocalConEntryLabel c con = IdLabel con c ConEntry @@ -498,7 +502,7 @@ mkPlainModuleInitLabel mod = PlainModuleInitLabel mod -- Converting between info labels and entry/ret labels. infoLblToEntryLbl :: CLabel -> CLabel -infoLblToEntryLbl (IdLabel n c InfoTable) = IdLabel n c Entry +infoLblToEntryLbl (IdLabel n c (InfoTable lcl)) = IdLabel n c (Entry lcl) infoLblToEntryLbl (IdLabel n c ConInfoTable) = IdLabel n c ConEntry infoLblToEntryLbl (IdLabel n c StaticInfoTable) = IdLabel n c StaticConEntry infoLblToEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt @@ -509,7 +513,7 @@ infoLblToEntryLbl _ entryLblToInfoLbl :: CLabel -> CLabel -entryLblToInfoLbl (IdLabel n c Entry) = IdLabel n c InfoTable +entryLblToInfoLbl (IdLabel n c (Entry lcl)) = IdLabel n c (InfoTable lcl) entryLblToInfoLbl (IdLabel n c ConEntry) = IdLabel n c ConInfoTable entryLblToInfoLbl (IdLabel n c StaticConEntry) = IdLabel n c StaticInfoTable entryLblToInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo @@ -519,8 +523,8 @@ entryLblToInfoLbl l = pprPanic "CLabel.entryLblToInfoLbl" (pprCLabel l) -cvtToClosureLbl (IdLabel n c InfoTable) = IdLabel n c Closure -cvtToClosureLbl (IdLabel n c Entry) = IdLabel n c Closure +cvtToClosureLbl (IdLabel n c (InfoTable _)) = IdLabel n c Closure +cvtToClosureLbl (IdLabel n c (Entry _)) = IdLabel n c Closure cvtToClosureLbl (IdLabel n c ConEntry) = IdLabel n c Closure cvtToClosureLbl (IdLabel n c RednCounts) = IdLabel n c Closure cvtToClosureLbl l@(IdLabel n c Closure) = l @@ -528,13 +532,18 @@ cvtToClosureLbl l = pprPanic "cvtToClosureLbl" (pprCLabel l) -cvtToSRTLbl (IdLabel n c InfoTable) = mkSRTLabel n c -cvtToSRTLbl (IdLabel n c Entry) = mkSRTLabel n c +cvtToSRTLbl (IdLabel n c (InfoTable _)) = mkSRTLabel n c +cvtToSRTLbl (IdLabel n c (Entry _)) = mkSRTLabel n c cvtToSRTLbl (IdLabel n c ConEntry) = mkSRTLabel n c cvtToSRTLbl l@(IdLabel n c Closure) = mkSRTLabel n c cvtToSRTLbl l = pprPanic "cvtToSRTLbl" (pprCLabel l) +localiseLabel :: CLabel -> CLabel +localiseLabel (IdLabel n c (Entry _)) = IdLabel n c (Entry True) +localiseLabel (IdLabel n c (InfoTable _)) = IdLabel n c (InfoTable True) +localiseLabel l = l + -- ----------------------------------------------------------------------------- -- Does a CLabel refer to a CAF? @@ -691,7 +700,7 @@ externallyVisibleCLabel (PlainModuleInitLabel _)= True externallyVisibleCLabel (RtsLabel _) = True externallyVisibleCLabel (CmmLabel _ _ _) = True externallyVisibleCLabel (ForeignLabel{}) = True -externallyVisibleCLabel (IdLabel name _ _) = isExternalName name +externallyVisibleCLabel (IdLabel name _ info) = isExternalName name && externallyVisibleIdLabel info externallyVisibleCLabel (CC_Label _) = True externallyVisibleCLabel (CCS_Label _) = True externallyVisibleCLabel (DynamicLinkerLabel _ _) = False @@ -699,6 +708,12 @@ externallyVisibleCLabel (HpcTicksLabel _) = True externallyVisibleCLabel (LargeBitmapLabel _) = False externallyVisibleCLabel (LargeSRTLabel _) = False +externallyVisibleIdLabel :: IdLabelInfo -> Bool +externallyVisibleIdLabel SRT = False +externallyVisibleIdLabel (Entry lcl) = not lcl +externallyVisibleIdLabel (InfoTable lcl) = not lcl +externallyVisibleIdLabel _ = True + -- ----------------------------------------------------------------------------- -- Finding the "type" of a CLabel @@ -744,7 +759,7 @@ labelType _ = DataLabel idInfoLabelType info = case info of - InfoTable -> DataLabel + InfoTable _ -> DataLabel Closure -> GcPtrLabel ConInfoTable -> DataLabel StaticInfoTable -> DataLabel @@ -847,6 +862,8 @@ entry. instance Outputable CLabel where ppr = pprCLabel +instance PlatformOutputable CLabel where + pprPlatform _ = pprCLabel pprCLabel :: CLabel -> SDoc @@ -980,8 +997,8 @@ ppIdFlavor x = pp_cSEP <> (case x of Closure -> ptext (sLit "closure") SRT -> ptext (sLit "srt") - InfoTable -> ptext (sLit "info") - Entry -> ptext (sLit "entry") + InfoTable _ -> ptext (sLit "info") + Entry _ -> ptext (sLit "entry") Slow -> ptext (sLit "slow") RednCounts -> ptext (sLit "ct") ConEntry -> ptext (sLit "con_entry") diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index a6b215b38f..e49d960c17 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -53,8 +53,8 @@ type CmmBwdRewrite f = BwdRewrite FuelUniqSM CmmNode f data CmmStackInfo = StackInfo {arg_space :: ByteOff, updfr_space :: Maybe ByteOff} data CmmTopInfo = TopInfo {info_tbl :: CmmInfoTable, stack_info :: CmmStackInfo} -type Cmm = GenCmm CmmStatic CmmTopInfo CmmGraph -type CmmTop = GenCmmTop CmmStatic CmmTopInfo CmmGraph +type Cmm = GenCmm CmmStatics CmmTopInfo CmmGraph +type CmmTop = GenCmmTop CmmStatics CmmTopInfo CmmGraph ------------------------------------------------- -- Manipulating CmmGraphs diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index 3d0d6fb426..e74e502727 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -238,7 +238,7 @@ addCAF caf srt = where last = next_elt srt srtToData :: TopSRT -> Cmm -srtToData srt = Cmm [CmmData RelocatableReadOnlyData (CmmDataLabel (lbl srt) : tbl)] +srtToData srt = Cmm [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)] where tbl = map (CmmStaticLit . CmmLabel) (reverse (rev_elts srt)) -- Once we have found the CAFs, we need to do two things: @@ -317,7 +317,7 @@ to_SRT top_srt off len bmp = do id <- getUniqueM let srt_desc_lbl = mkLargeSRTLabel id tbl = CmmData RelocatableReadOnlyData $ - CmmDataLabel srt_desc_lbl : map CmmStaticLit + Statics srt_desc_lbl $ map CmmStaticLit ( cmmLabelOffW top_srt off : mkWordCLit (fromIntegral len) : map mkWordCLit bmp) @@ -336,7 +336,7 @@ localCAFInfo :: CAFEnv -> CmmTop -> Maybe (CLabel, CAFSet) localCAFInfo _ (CmmData _ _) = Nothing localCAFInfo cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) = case info_tbl top_info of - CmmInfoTable False _ _ _ -> + CmmInfoTable _ False _ _ _ -> Just (cvtToClosureLbl top_l, expectJust "maybeBindCAFs" $ mapLookup entry cafEnv) _ -> Nothing @@ -397,8 +397,8 @@ updInfo toVars toSrt (CmmProc top_info top_l g) = updInfo _ _ t = t updInfoTbl :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmInfoTable -> CmmInfoTable -updInfoTbl toVars toSrt (CmmInfoTable s p t typeinfo) - = CmmInfoTable s p t typeinfo' +updInfoTbl toVars toSrt (CmmInfoTable l s p t typeinfo) + = CmmInfoTable l s p t typeinfo' where typeinfo' = case typeinfo of t@(ConstrInfo _ _ _) -> t (FunInfo c s a d e) -> FunInfo c (toSrt s) a d e diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index 83d72b8f6e..fcb220d74c 100644 --- a/compiler/cmm/CmmCvt.hs +++ b/compiler/cmm/CmmCvt.hs @@ -13,6 +13,7 @@ import CmmExpr import MkGraph import qualified OldCmm as Old import OldPprCmm () +import Platform import Compiler.Hoopl hiding ((<*>), mkLabel, mkBranch) import Control.Monad @@ -21,23 +22,23 @@ import Maybes import Outputable import UniqSupply -cmmToZgraph :: Old.Cmm -> UniqSM Cmm -cmmOfZgraph :: Cmm -> Old.Cmm +cmmToZgraph :: Platform -> Old.Cmm -> UniqSM Cmm +cmmOfZgraph :: Cmm -> Old.Cmm -cmmToZgraph (Cmm tops) = liftM Cmm $ mapM mapTop tops +cmmToZgraph platform (Cmm tops) = liftM Cmm $ mapM mapTop tops where mapTop (CmmProc (Old.CmmInfo _ _ info_tbl) l g) = - do (stack_info, g) <- toZgraph (showSDoc $ ppr l) g + do (stack_info, g) <- toZgraph platform (showSDoc $ ppr l) g return $ CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) l g mapTop (CmmData s ds) = return $ CmmData s ds cmmOfZgraph (Cmm tops) = Cmm $ map mapTop tops where mapTop (CmmProc h l g) = CmmProc (Old.CmmInfo Nothing Nothing (info_tbl h)) l (ofZgraph g) mapTop (CmmData s ds) = CmmData s ds -toZgraph :: String -> Old.ListGraph Old.CmmStmt -> UniqSM (CmmStackInfo, CmmGraph) -toZgraph _ (Old.ListGraph []) = +toZgraph :: Platform -> String -> Old.ListGraph Old.CmmStmt -> UniqSM (CmmStackInfo, CmmGraph) +toZgraph _ _ (Old.ListGraph []) = do g <- lgraphOfAGraph emptyAGraph return (StackInfo {arg_space=0, updfr_space=Nothing}, g) -toZgraph fun_name g@(Old.ListGraph (Old.BasicBlock id ss : other_blocks)) = +toZgraph platform fun_name g@(Old.ListGraph (Old.BasicBlock id ss : other_blocks)) = let (offset, entry) = mkCallEntry NativeNodeCall [] in do g <- labelAGraph id $ entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks @@ -64,7 +65,7 @@ toZgraph fun_name g@(Old.ListGraph (Old.BasicBlock id ss : other_blocks)) = mkStmts (last : []) = mkLast last mkStmts [] = bad "fell off end" mkStmts (_ : _ : _) = bad "last node not at end" - bad msg = pprPanic (msg ++ " in function " ++ fun_name) (ppr g) + bad msg = pprPanic (msg ++ " in function " ++ fun_name) (pprPlatform platform g) mkLast (Old.CmmCall (Old.CmmCallee f conv) [] args _ Old.CmmNeverReturns) = mkFinalCall f conv (map Old.hintlessCmm args) updfr_sz mkLast (Old.CmmCall (Old.CmmPrim {}) _ _ _ Old.CmmNeverReturns) = diff --git a/compiler/cmm/CmmDecl.hs b/compiler/cmm/CmmDecl.hs index 542e390128..9bd2386776 100644 --- a/compiler/cmm/CmmDecl.hs +++ b/compiler/cmm/CmmDecl.hs @@ -11,7 +11,7 @@ module CmmDecl ( CmmInfoTable(..), HasStaticClosure, ClosureTypeInfo(..), ConstrDescription, ProfilingInfo(..), ClosureTypeTag, CmmActual, CmmFormal, ForeignHint(..), - CmmStatic(..), Section(..), + CmmStatics(..), CmmStatic(..), Section(..), ) where #include "HsVersions.h" @@ -55,12 +55,12 @@ newtype GenCmm d h g = Cmm [GenCmmTop d h g] data GenCmmTop d h g = CmmProc -- A procedure h -- Extra header such as the info table - CLabel -- Used to generate both info & entry labels + CLabel -- Used to generate both info & entry labels (though the info table label is in 'h' in RawCmmTop) g -- Control-flow graph for the procedure's code | CmmData -- Static data Section - [d] + d ----------------------------------------------------------------------------- @@ -70,12 +70,16 @@ data GenCmmTop d h g -- Info table as a haskell data type data CmmInfoTable = CmmInfoTable + LocalInfoTable HasStaticClosure ProfilingInfo ClosureTypeTag -- Int ClosureTypeInfo | CmmNonInfoTable -- Procedure doesn't need an info table +-- | If the table is local, we don't export its identifier even if the corresponding Id is exported. +-- It's always safe to say 'False' here, but it might save symbols to say 'True' +type LocalInfoTable = Bool type HasStaticClosure = Bool -- TODO: The GC target shouldn't really be part of CmmInfo @@ -132,10 +136,7 @@ data CmmStatic -- a literal value, size given by cmmLitRep of the literal. | CmmUninitialised Int -- uninitialised data, N bytes long - | CmmAlign Int - -- align to next N-byte boundary (N must be a power of 2). - | CmmDataLabel CLabel - -- label the current position in this section. | CmmString [Word8] -- string of 8-bit values only, not zero terminated. +data CmmStatics = Statics CLabel {- Label of statics -} [CmmStatic] {- The static data itself -} diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index a606da2aec..47d0c8b004 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -28,7 +28,7 @@ import Data.Bits -- When we split at proc points, we need an empty info table. emptyContInfoTable :: CmmInfoTable -emptyContInfoTable = CmmInfoTable False (ProfilingInfo zero zero) rET_SMALL +emptyContInfoTable = CmmInfoTable False False (ProfilingInfo zero zero) rET_SMALL (ContInfo [] NoC_SRT) where zero = CmmInt 0 wordWidth @@ -78,10 +78,10 @@ mkInfoTable _ (CmmData sec dat) = [CmmData sec dat] mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label blocks) = case info of -- Code without an info table. Easy. - CmmNonInfoTable -> [CmmProc [] entry_label blocks] + CmmNonInfoTable -> [CmmProc Nothing entry_label blocks] - CmmInfoTable _ (ProfilingInfo ty_prof cl_prof) type_tag type_info -> - let info_label = entryLblToInfoLbl entry_label + CmmInfoTable is_local _ (ProfilingInfo ty_prof cl_prof) type_tag type_info -> + let info_label = (if is_local then localiseLabel else id) $ entryLblToInfoLbl entry_label ty_prof' = makeRelativeRefTo info_label ty_prof cl_prof' = makeRelativeRefTo info_label cl_prof in case type_info of @@ -153,7 +153,7 @@ mkInfoTableAndCode :: CLabel -> [RawCmmTop] mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl blocks | tablesNextToCode -- Reverse the extra_bits; and emit the top-level proc - = [CmmProc (map CmmStaticLit (reverse extra_bits ++ std_info)) + = [CmmProc (Just (Statics info_lbl $ map CmmStaticLit (reverse extra_bits ++ std_info))) entry_lbl blocks] | ListGraph [] <- blocks -- No code; only the info table is significant @@ -163,7 +163,7 @@ mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl blocks | otherwise -- Separately emit info table (with the function entry = -- point as first entry) and the entry code - [CmmProc [] entry_lbl blocks, + [CmmProc Nothing entry_lbl blocks, mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits)] mkSRTLit :: CLabel diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 32fead337e..15357ecb94 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -23,6 +23,7 @@ import Outputable import OldPprCmm() import Constants import FastString +import Platform import Data.Maybe @@ -30,21 +31,22 @@ import Data.Maybe -- Exported entry points: cmmLint :: (Outputable d, Outputable h) - => GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc -cmmLint (Cmm tops) = runCmmLint (mapM_ lintCmmTop) tops + => Platform -> GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc +cmmLint platform (Cmm tops) = runCmmLint platform (mapM_ lintCmmTop) tops cmmLintTop :: (Outputable d, Outputable h) - => GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc -cmmLintTop top = runCmmLint lintCmmTop top + => Platform -> GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc +cmmLintTop platform top = runCmmLint platform lintCmmTop top -runCmmLint :: Outputable a => (a -> CmmLint b) -> a -> Maybe SDoc -runCmmLint l p = +runCmmLint :: PlatformOutputable a + => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc +runCmmLint platform l p = case unCL (l p) of - Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"), - nest 2 err, - ptext $ sLit ("Program was:"), - nest 2 (ppr p)]) - Right _ -> Nothing + Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"), + nest 2 err, + ptext $ sLit ("Program was:"), + nest 2 (pprPlatform platform p)]) + Right _ -> Nothing lintCmmTop :: (GenCmmTop h i (ListGraph CmmStmt)) -> CmmLint () lintCmmTop (CmmProc _ lbl (ListGraph blocks)) diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index 28f21e21f3..5480d9c597 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -673,12 +673,11 @@ exactLog2 x_ -} cmmLoopifyForC :: RawCmmTop -> RawCmmTop -cmmLoopifyForC p@(CmmProc info entry_lbl - (ListGraph blocks@(BasicBlock top_id _ : _))) - | null info = p -- only if there's an info table, ignore case alts - | otherwise = +cmmLoopifyForC p@(CmmProc Nothing _ _) = p -- only if there's an info table, ignore case alts +cmmLoopifyForC p@(CmmProc (Just info@(Statics info_lbl _)) entry_lbl + (ListGraph blocks@(BasicBlock top_id _ : _))) = -- pprTrace "jump_lbl" (ppr jump_lbl <+> ppr entry_lbl) $ - CmmProc info entry_lbl (ListGraph blocks') + CmmProc (Just info) entry_lbl (ListGraph blocks') where blocks' = [ BasicBlock id (map do_stmt stmts) | BasicBlock id stmts <- blocks ] @@ -686,7 +685,7 @@ cmmLoopifyForC p@(CmmProc info entry_lbl = CmmBranch top_id do_stmt stmt = stmt - jump_lbl | tablesNextToCode = entryLblToInfoLbl entry_lbl + jump_lbl | tablesNextToCode = info_lbl | otherwise = entry_lbl cmmLoopifyForC top = top diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 60f3bb5623..2d59fe751e 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -188,22 +188,24 @@ cmmtop :: { ExtCode } -- * we can derive closure and info table labels from a single NAME cmmdata :: { ExtCode } - : 'section' STRING '{' statics '}' - { do ss <- sequence $4; - code (emitData (section $2) (concat ss)) } + : 'section' STRING '{' data_label statics '}' + { do lbl <- $4; + ss <- sequence $5; + code (emitData (section $2) (Statics lbl $ concat ss)) } + +data_label :: { ExtFCode CLabel } + : NAME ':' + {% withThisPackage $ \pkg -> + return (mkCmmDataLabel pkg $1) } statics :: { [ExtFCode [CmmStatic]] } : {- empty -} { [] } | static statics { $1 : $2 } - + -- Strings aren't used much in the RTS HC code, so it doesn't seem -- worth allowing inline strings. C-- doesn't allow them anyway. static :: { ExtFCode [CmmStatic] } - : NAME ':' - {% withThisPackage $ \pkg -> - return [CmmDataLabel (mkCmmDataLabel pkg $1)] } - - | type expr ';' { do e <- $2; + : type expr ';' { do e <- $2; return [CmmStaticLit (getLit e)] } | type ';' { return [CmmUninitialised (widthInBytes (typeWidth $1))] } @@ -213,7 +215,6 @@ static :: { ExtFCode [CmmStatic] } | typenot8 '[' INT ']' ';' { return [CmmUninitialised (widthInBytes (typeWidth $1) * fromIntegral $3)] } - | 'align' INT ';' { return [CmmAlign (fromIntegral $2)] } | 'CLOSURE' '(' NAME lits ')' { do lits <- sequence $4; return $ map CmmStaticLit $ @@ -265,7 +266,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } {% withThisPackage $ \pkg -> do prof <- profilingInfo $11 $13 return (mkCmmEntryLabel pkg $3, - CmmInfoTable False prof (fromIntegral $9) + CmmInfoTable False False prof (fromIntegral $9) (ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT), []) } @@ -274,7 +275,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } {% withThisPackage $ \pkg -> do prof <- profilingInfo $11 $13 return (mkCmmEntryLabel pkg $3, - CmmInfoTable False prof (fromIntegral $9) + CmmInfoTable False False prof (fromIntegral $9) (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT 0 -- Arity zero (ArgSpec (fromIntegral $15)) @@ -289,7 +290,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } {% withThisPackage $ \pkg -> do prof <- profilingInfo $11 $13 return (mkCmmEntryLabel pkg $3, - CmmInfoTable False prof (fromIntegral $9) + CmmInfoTable False False prof (fromIntegral $9) (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $17) (ArgSpec (fromIntegral $15)) zeroCLit), @@ -305,7 +306,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } -- but that's the way the old code did it we can fix it some other time. desc_lit <- code $ mkStringCLit $13 return (mkCmmEntryLabel pkg $3, - CmmInfoTable False prof (fromIntegral $11) + CmmInfoTable False False prof (fromIntegral $11) (ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit), []) } @@ -314,7 +315,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } {% withThisPackage $ \pkg -> do prof <- profilingInfo $9 $11 return (mkCmmEntryLabel pkg $3, - CmmInfoTable False prof (fromIntegral $7) + CmmInfoTable False False prof (fromIntegral $7) (ThunkSelectorInfo (fromIntegral $5) NoC_SRT), []) } @@ -323,7 +324,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } {% withThisPackage $ \pkg -> do let infoLabel = mkCmmInfoLabel pkg $3 return (mkCmmRetLabel pkg $3, - CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) + CmmInfoTable False False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) (ContInfo [] NoC_SRT), []) } @@ -332,7 +333,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } {% withThisPackage $ \pkg -> do live <- sequence (map (liftM Just) $7) return (mkCmmRetLabel pkg $3, - CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) + CmmInfoTable False False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) (ContInfo live NoC_SRT), live) } @@ -873,9 +874,8 @@ foreignCall conv_string results_code expr_code args_code vols safety ret code (emitForeignCall' PlayRisky results (CmmCallee expr' convention) args vols NoC_SRT ret) CmmSafe srt -> - code (emitForeignCall' (PlaySafe unused) results + code (emitForeignCall' PlaySafe results (CmmCallee expr' convention) args vols NoC_SRT ret) where - unused = panic "not used by emitForeignCall'" CmmInterruptible -> code (emitForeignCall' PlayInterruptible results (CmmCallee expr' convention) args vols NoC_SRT ret) @@ -910,9 +910,8 @@ primCall results_code name args_code vols safety code (emitForeignCall' PlayRisky results (CmmPrim p) args vols NoC_SRT CmmMayReturn) CmmSafe srt -> - code (emitForeignCall' (PlaySafe unused) results + code (emitForeignCall' PlaySafe results (CmmPrim p) args vols NoC_SRT CmmMayReturn) where - unused = panic "not used by emitForeignCall'" CmmInterruptible -> code (emitForeignCall' PlayInterruptible results (CmmPrim p) args vols NoC_SRT CmmMayReturn) @@ -1076,7 +1075,7 @@ parseCmmFile dflags filename = do if (errorsFound dflags ms) then return (ms, Nothing) else do - dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm) + dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprPlatform (targetPlatform dflags) cmm) return (ms, Just cmm) where no_module = panic "parseCmmFile: no module" diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index 1e4809d2b2..5effa6ca77 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -65,7 +65,7 @@ cmmPipeline hsc_env (topSRT, rst) prog = let topCAFEnv = mkTopCAFInfo (concat cafEnvs) (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops let cmms = Cmm (reverse (concat tops)) - dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms) + dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (pprPlatform (targetPlatform dflags) cmms) -- SRT is not affected by control flow optimization pass let prog' = map runCmmContFlowOpts (cmms : rst) return (topSRT, prog') @@ -90,33 +90,33 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ----------- Eliminate common blocks ------------------- g <- return $ elimCommonBlocks g - dump Opt_D_dump_cmmz_cbe "Post common block elimination" g + dumpPlatform platform Opt_D_dump_cmmz_cbe "Post common block elimination" g -- Any work storing block Labels must be performed _after_ elimCommonBlocks ----------- Proc points ------------------- let callPPs = callProcPoints g - procPoints <- run $ minimalProcPointSet callPPs g + procPoints <- run $ minimalProcPointSet (targetPlatform dflags) callPPs g g <- run $ addProcPointProtocols callPPs procPoints g - dump Opt_D_dump_cmmz_proc "Post Proc Points Added" g + dumpPlatform platform Opt_D_dump_cmmz_proc "Post Proc Points Added" g ----------- Spills and reloads ------------------- g <- run $ dualLivenessWithInsertion procPoints g - dump Opt_D_dump_cmmz_spills "Post spills and reloads" g + dumpPlatform platform Opt_D_dump_cmmz_spills "Post spills and reloads" g ----------- Sink and inline assignments ------------------- g <- runOptimization $ rewriteAssignments g - dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g + dumpPlatform platform Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g ----------- Eliminate dead assignments ------------------- g <- runOptimization $ removeDeadAssignments g - dump Opt_D_dump_cmmz_dead "Post remove dead assignments" g + dumpPlatform platform Opt_D_dump_cmmz_dead "Post remove dead assignments" g ----------- Zero dead stack slots (Debug only) --------------- -- Debugging: stubbing slots on death can cause crashes early g <- if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g - dump Opt_D_dump_cmmz_stub "Post stub dead stack slots" g + dumpPlatform platform Opt_D_dump_cmmz_stub "Post stub dead stack slots" g --------------- Stack layout ---------------- slotEnv <- run $ liveSlotAnal g @@ -127,7 +127,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ------------ Manifest the stack pointer -------- g <- run $ manifestSP spEntryMap areaMap entry_off g - dump Opt_D_dump_cmmz_sp "Post manifestSP" g + dumpPlatform platform Opt_D_dump_cmmz_sp "Post manifestSP" g -- UGH... manifestSP can require updates to the procPointMap. -- We can probably do something quicker here for the update... @@ -136,7 +136,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) dump Opt_D_dump_cmmz_procmap "procpoint map" procPointMap gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap (CmmProc h l g) - mapM_ (dump Opt_D_dump_cmmz_split "Post splitting") gs + mapM_ (dumpPlatform platform Opt_D_dump_cmmz_split "Post splitting") gs ------------- More CAFs and foreign calls ------------ cafEnv <- run $ cafAnal g @@ -144,23 +144,26 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) mbpprTrace "localCAFs" (ppr localCAFs) $ return () gs <- run $ mapM (lowerSafeForeignCalls areaMap) gs - mapM_ (dump Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs + mapM_ (dumpPlatform platform Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES gs <- return $ map (setInfoTableStackMap slotEnv areaMap) gs - mapM_ (dump Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs + mapM_ (dumpPlatform platform Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs gs <- return $ map (bundleCAFs cafEnv) gs - mapM_ (dump Opt_D_dump_cmmz_cafs "after bundleCAFs") gs + mapM_ (dumpPlatform platform Opt_D_dump_cmmz_cafs "after bundleCAFs") gs return (localCAFs, gs) where dflags = hsc_dflags hsc_env + platform = targetPlatform dflags mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z - dump f txt g = do + dump f = dumpWith ppr f + dumpPlatform platform = dumpWith (pprPlatform platform) + dumpWith pprFun f txt g = do -- ToDo: No easy way of say "dump all the cmmz, *and* split -- them into files." Also, -ddump-cmmz doesn't play nicely -- with -ddump-to-file, since the headers get omitted. - dumpIfSet_dyn dflags f txt (ppr g) + dumpIfSet_dyn dflags f txt (pprFun g) when (not (dopt f dflags)) $ - dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g) + dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (pprFun g) -- Runs a required transformation/analysis run = runInfiniteFuelIO (hsc_OptFuel hsc_env) -- Runs an optional transformation/analysis (and should diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs index 0527b6eea0..b608b291d4 100644 --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -25,6 +25,7 @@ import MkGraph import Control.Monad import OptimizationFuel import Outputable +import Platform import UniqSet import UniqSupply @@ -139,10 +140,10 @@ callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g CmmForeignCall {succ=k} -> setInsert k set _ -> set -minimalProcPointSet :: ProcPointSet -> CmmGraph -> FuelUniqSM ProcPointSet +minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph -> FuelUniqSM ProcPointSet -- Given the set of successors of calls (which must be proc-points) -- figure out the minimal set of necessary proc-points -minimalProcPointSet callProcPoints g = extendPPSet g (postorderDfs g) callProcPoints +minimalProcPointSet platform callProcPoints g = extendPPSet platform g (postorderDfs g) callProcPoints procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelUniqSM (BlockEnv Status) -- Once you know what the proc-points are, figure out @@ -151,8 +152,8 @@ procPointAnalysis procPoints g = liftM snd $ dataflowPassFwd g initProcPoints $ analFwd lattice forward where initProcPoints = [(id, ProcPoint) | id <- setElems procPoints] -extendPPSet :: CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelUniqSM ProcPointSet -extendPPSet g blocks procPoints = +extendPPSet :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelUniqSM ProcPointSet +extendPPSet platform g blocks procPoints = do env <- procPointAnalysis procPoints g let add block pps = let id = entryLabel block in case mapLookup id env of @@ -163,7 +164,7 @@ extendPPSet g blocks procPoints = newPoint = listToMaybe newPoints ppSuccessor b = let nreached id = case mapLookup id env `orElse` - pprPanic "no ppt" (ppr id <+> ppr b) of + pprPanic "no ppt" (ppr id <+> pprPlatform platform b) of ProcPoint -> 1 ReachedBy ps -> setSize ps block_procpoints = nreached (entryLabel b) @@ -181,7 +182,7 @@ extendPPSet g blocks procPoints = -} case newPoint of Just id -> if setMember id procPoints' then panic "added old proc pt" - else extendPPSet g blocks (setInsert id procPoints') + else extendPPSet platform g blocks (setInsert id procPoints') Nothing -> return procPoints' diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs index de1a8e0dcb..f691183038 100644 --- a/compiler/cmm/OldCmm.hs +++ b/compiler/cmm/OldCmm.hs @@ -73,12 +73,15 @@ newtype ListGraph i = ListGraph [GenBasicBlock i] -- across a whole compilation unit. -- | Cmm with the info table as a data type -type Cmm = GenCmm CmmStatic CmmInfo (ListGraph CmmStmt) -type CmmTop = GenCmmTop CmmStatic CmmInfo (ListGraph CmmStmt) +type Cmm = GenCmm CmmStatics CmmInfo (ListGraph CmmStmt) +type CmmTop = GenCmmTop CmmStatics CmmInfo (ListGraph CmmStmt) --- | Cmm with the info tables converted to a list of 'CmmStatic' -type RawCmm = GenCmm CmmStatic [CmmStatic] (ListGraph CmmStmt) -type RawCmmTop = GenCmmTop CmmStatic [CmmStatic] (ListGraph CmmStmt) +-- | Cmm with the info tables converted to a list of 'CmmStatic' along with the info +-- table label. If we are building without tables-next-to-code there will be no statics +-- +-- INVARIANT: if there is an info table, it has at least one CmmStatic +type RawCmm = GenCmm CmmStatics (Maybe CmmStatics) (ListGraph CmmStmt) +type RawCmmTop = GenCmmTop CmmStatics (Maybe CmmStatics) (ListGraph CmmStmt) -- A basic block containing a single label, at the beginning. diff --git a/compiler/cmm/OldPprCmm.hs b/compiler/cmm/OldPprCmm.hs index 4b0db35bd8..4050359710 100644 --- a/compiler/cmm/OldPprCmm.hs +++ b/compiler/cmm/OldPprCmm.hs @@ -50,20 +50,23 @@ import PprCmmExpr import BasicTypes import ForeignCall import Outputable +import Platform import FastString import Data.List ----------------------------------------------------------------------------- -instance (Outputable instr) => Outputable (ListGraph instr) where - ppr (ListGraph blocks) = vcat (map ppr blocks) +instance PlatformOutputable instr => PlatformOutputable (ListGraph instr) where + pprPlatform platform (ListGraph blocks) = vcat (map (pprPlatform platform) blocks) -instance (Outputable instr) => Outputable (GenBasicBlock instr) where - ppr b = pprBBlock b +instance PlatformOutputable instr => PlatformOutputable (GenBasicBlock instr) where + pprPlatform platform b = pprBBlock platform b instance Outputable CmmStmt where ppr s = pprStmt s +instance PlatformOutputable CmmStmt where + pprPlatform _ = ppr instance Outputable CmmInfo where ppr e = pprInfo e @@ -88,7 +91,7 @@ pprInfo (CmmInfo _gc_target update_frame CmmNonInfoTable) = maybe (ptext (sLit "<none>")) ppr gc_target,-} ptext (sLit "update_frame: ") <> maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame] -pprInfo (CmmInfo _gc_target update_frame info_table@(CmmInfoTable _ _ _ _)) = +pprInfo (CmmInfo _gc_target update_frame info_table@(CmmInfoTable _ _ _ _ _)) = vcat [{-ptext (sLit "gc_target: ") <> maybe (ptext (sLit "<none>")) ppr gc_target,-} ptext (sLit "update_frame: ") <> @@ -99,9 +102,9 @@ pprInfo (CmmInfo _gc_target update_frame info_table@(CmmInfoTable _ _ _ _)) = -- -------------------------------------------------------------------------- -- Basic blocks look like assembly blocks. -- lbl: stmt ; stmt ; .. -pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc -pprBBlock (BasicBlock ident stmts) = - hang (ppr ident <> colon) 4 (vcat (map ppr stmts)) +pprBBlock :: PlatformOutputable stmt => Platform -> GenBasicBlock stmt -> SDoc +pprBBlock platform (BasicBlock ident stmts) = + hang (ppr ident <> colon) 4 (vcat (map (pprPlatform platform) stmts)) -- -------------------------------------------------------------------------- -- Statements. C-- usually, exceptions to this should be obvious. diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index c405b650a6..b48d2de3c8 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -83,11 +83,11 @@ pprC (Cmm tops) = vcat $ intersperse blankLine $ map pprTop tops -- top level procs -- pprTop :: RawCmmTop -> SDoc -pprTop (CmmProc info clbl (ListGraph blocks)) = - (if not (null info) - then pprDataExterns info $$ - pprWordArray (entryLblToInfoLbl clbl) info - else empty) $$ +pprTop (CmmProc mb_info clbl (ListGraph blocks)) = + (case mb_info of + Nothing -> empty + Just (Statics info_clbl info_dat) -> pprDataExterns info_dat $$ + pprWordArray info_clbl info_dat) $$ (vcat [ blankLine, extern_decls, @@ -112,31 +112,21 @@ pprTop (CmmProc info clbl (ListGraph blocks)) = -- We only handle (a) arrays of word-sized things and (b) strings. -pprTop (CmmData _section _ds@[CmmDataLabel lbl, CmmString str]) = +pprTop (CmmData _section (Statics lbl [CmmString str])) = hcat [ pprLocalness lbl, ptext (sLit "char "), pprCLabel lbl, ptext (sLit "[] = "), pprStringInCStyle str, semi ] -pprTop (CmmData _section _ds@[CmmDataLabel lbl, CmmUninitialised size]) = +pprTop (CmmData _section (Statics lbl [CmmUninitialised size])) = hcat [ pprLocalness lbl, ptext (sLit "char "), pprCLabel lbl, brackets (int size), semi ] -pprTop (CmmData _section (CmmDataLabel lbl : lits)) = +pprTop (CmmData _section (Statics lbl lits)) = pprDataExterns lits $$ - pprWordArray lbl lits - --- Floating info table for safe a foreign call. -pprTop (CmmData _section d@(_ : _)) - | CmmDataLabel lbl : lits <- reverse d = - let lits' = reverse lits - in pprDataExterns lits' $$ - pprWordArray lbl lits' - --- these shouldn't appear? -pprTop (CmmData _ _) = panic "PprC.pprTop: can't handle this data" + pprWordArray lbl lits -- -------------------------------------------------------------------------- -- BasicBlocks are self-contained entities: they always end in a jump. @@ -508,8 +498,6 @@ pprStatic :: CmmStatic -> SDoc pprStatic s = case s of CmmStaticLit lit -> nest 4 (pprLit lit) - CmmAlign i -> nest 4 (ptext (sLit "/* align */") <+> int i) - CmmDataLabel clbl -> pprCLabel clbl <> colon CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i)) -- these should be inlined, like the old .hc diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index cede69e06f..43e1c5bb2f 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -49,6 +49,7 @@ import PprCmmExpr import Util import BasicTypes +import Platform import Compiler.Hoopl import Data.List import Prelude hiding (succ) @@ -76,20 +77,20 @@ instance Outputable ForeignTarget where ppr = pprForeignTarget -instance Outputable (Block CmmNode C C) where - ppr = pprBlock -instance Outputable (Block CmmNode C O) where - ppr = pprBlock -instance Outputable (Block CmmNode O C) where - ppr = pprBlock -instance Outputable (Block CmmNode O O) where - ppr = pprBlock +instance PlatformOutputable (Block CmmNode C C) where + pprPlatform _ = pprBlock +instance PlatformOutputable (Block CmmNode C O) where + pprPlatform _ = pprBlock +instance PlatformOutputable (Block CmmNode O C) where + pprPlatform _ = pprBlock +instance PlatformOutputable (Block CmmNode O O) where + pprPlatform _ = pprBlock -instance Outputable (Graph CmmNode e x) where - ppr = pprGraph +instance PlatformOutputable (Graph CmmNode e x) where + pprPlatform = pprGraph -instance Outputable CmmGraph where - ppr = pprCmmGraph +instance PlatformOutputable CmmGraph where + pprPlatform platform = pprCmmGraph platform ---------------------------------------------------------- -- Outputting types Cmm contains @@ -107,7 +108,8 @@ pprTopInfo (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) = ---------------------------------------------------------- -- Outputting blocks and graphs -pprBlock :: IndexedCO x SDoc SDoc ~ SDoc => Block CmmNode e x -> IndexedCO e SDoc SDoc +pprBlock :: IndexedCO x SDoc SDoc ~ SDoc + => Block CmmNode e x -> IndexedCO e SDoc SDoc pprBlock block = foldBlockNodesB3 ( ($$) . ppr , ($$) . (nest 4) . ppr , ($$) . (nest 4) . ppr @@ -115,21 +117,22 @@ pprBlock block = foldBlockNodesB3 ( ($$) . ppr block empty -pprGraph :: Graph CmmNode e x -> SDoc -pprGraph GNil = empty -pprGraph (GUnit block) = ppr block -pprGraph (GMany entry body exit) +pprGraph :: Platform -> Graph CmmNode e x -> SDoc +pprGraph _ GNil = empty +pprGraph platform (GUnit block) = pprPlatform platform block +pprGraph platform (GMany entry body exit) = text "{" - $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit) + $$ nest 2 (pprMaybeO entry $$ (vcat $ map (pprPlatform platform) $ bodyToBlockList body) $$ pprMaybeO exit) $$ text "}" - where pprMaybeO :: Outputable (Block CmmNode e x) => MaybeO ex (Block CmmNode e x) -> SDoc + where pprMaybeO :: PlatformOutputable (Block CmmNode e x) + => MaybeO ex (Block CmmNode e x) -> SDoc pprMaybeO NothingO = empty - pprMaybeO (JustO block) = ppr block + pprMaybeO (JustO block) = pprPlatform platform block -pprCmmGraph :: CmmGraph -> SDoc -pprCmmGraph g +pprCmmGraph :: Platform -> CmmGraph -> SDoc +pprCmmGraph platform g = text "{" <> text "offset" - $$ nest 2 (vcat $ map ppr blocks) + $$ nest 2 (vcat $ map (pprPlatform platform) blocks) $$ text "}" where blocks = postorderDfs g diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs index 1f520bfc90..f688f211fb 100644 --- a/compiler/cmm/PprCmmDecl.hs +++ b/compiler/cmm/PprCmmDecl.hs @@ -43,6 +43,7 @@ import PprCmmExpr import Outputable +import Platform import FastString import Data.List @@ -54,23 +55,28 @@ import ClosureInfo #include "../includes/rts/storage/FunTypes.h" -pprCmms :: (Outputable info, Outputable g) => [GenCmm CmmStatic info g] -> SDoc -pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms)) +pprCmms :: (Outputable info, PlatformOutputable g) + => Platform -> [GenCmm CmmStatics info g] -> SDoc +pprCmms platform cmms = pprCode CStyle (vcat (intersperse separator $ map (pprPlatform platform) cmms)) where separator = space $$ ptext (sLit "-------------------") $$ space -writeCmms :: (Outputable info, Outputable g) => Handle -> [GenCmm CmmStatic info g] -> IO () -writeCmms handle cmms = printForC handle (pprCmms cmms) +writeCmms :: (Outputable info, PlatformOutputable g) + => Platform -> Handle -> [GenCmm CmmStatics info g] -> IO () +writeCmms platform handle cmms = printForC handle (pprCmms platform cmms) ----------------------------------------------------------------------------- -instance (Outputable d, Outputable info, Outputable g) - => Outputable (GenCmm d info g) where - ppr c = pprCmm c +instance (Outputable d, Outputable info, PlatformOutputable g) + => PlatformOutputable (GenCmm d info g) where + pprPlatform platform c = pprCmm platform c -instance (Outputable d, Outputable info, Outputable i) - => Outputable (GenCmmTop d info i) where - ppr t = pprTop t +instance (Outputable d, Outputable info, PlatformOutputable i) + => PlatformOutputable (GenCmmTop d info i) where + pprPlatform platform t = pprTop platform t + +instance Outputable CmmStatics where + ppr e = pprStatics e instance Outputable CmmStatic where ppr e = pprStatic e @@ -81,20 +87,22 @@ instance Outputable CmmInfoTable where ----------------------------------------------------------------------------- -pprCmm :: (Outputable d, Outputable info, Outputable g) => GenCmm d info g -> SDoc -pprCmm (Cmm tops) = vcat $ intersperse blankLine $ map pprTop tops +pprCmm :: (Outputable d, Outputable info, PlatformOutputable g) + => Platform -> GenCmm d info g -> SDoc +pprCmm platform (Cmm tops) + = vcat $ intersperse blankLine $ map (pprTop platform) tops -- -------------------------------------------------------------------------- -- Top level `procedure' blocks. -- -pprTop :: (Outputable d, Outputable info, Outputable i) - => GenCmmTop d info i -> SDoc +pprTop :: (Outputable d, Outputable info, PlatformOutputable i) + => Platform -> GenCmmTop d info i -> SDoc -pprTop (CmmProc info lbl graph) +pprTop platform (CmmProc info lbl graph) = vcat [ pprCLabel lbl <> lparen <> rparen , nest 8 $ lbrace <+> ppr info $$ rbrace - , nest 4 $ ppr graph + , nest 4 $ pprPlatform platform graph , rbrace ] -- -------------------------------------------------------------------------- @@ -102,8 +110,8 @@ pprTop (CmmProc info lbl graph) -- -- section "data" { ... } -- -pprTop (CmmData section ds) = - (hang (pprSection section <+> lbrace) 4 (vcat (map ppr ds))) +pprTop _ (CmmData section ds) = + (hang (pprSection section <+> lbrace) 4 (ppr ds)) $$ rbrace -- -------------------------------------------------------------------------- @@ -111,8 +119,9 @@ pprTop (CmmData section ds) = pprInfoTable :: CmmInfoTable -> SDoc pprInfoTable CmmNonInfoTable = empty -pprInfoTable (CmmInfoTable stat_clos (ProfilingInfo closure_type closure_desc) tag info) = - vcat [ptext (sLit "has static closure: ") <> ppr stat_clos <+> +pprInfoTable (CmmInfoTable is_local stat_clos (ProfilingInfo closure_type closure_desc) tag info) = + vcat [ptext (sLit "is local: ") <> ppr is_local <+> + ptext (sLit "has static closure: ") <> ppr stat_clos <+> ptext (sLit "type: ") <> pprLit closure_type, ptext (sLit "desc: ") <> pprLit closure_desc, ptext (sLit "tag: ") <> integer (toInteger tag), @@ -171,12 +180,13 @@ instance Outputable ForeignHint where -- Strings are printed as C strings, and we print them as I8[], -- following C-- -- +pprStatics :: CmmStatics -> SDoc +pprStatics (Statics lbl ds) = vcat ((pprCLabel lbl <> colon) : map ppr ds) + pprStatic :: CmmStatic -> SDoc pprStatic s = case s of CmmStaticLit lit -> nest 4 $ ptext (sLit "const") <+> pprLit lit <> semi CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i) - CmmAlign i -> nest 4 $ text "align" <+> int i - CmmDataLabel clbl -> pprCLabel clbl <> colon CmmString s' -> nest 4 $ text "I8[]" <+> text (show s') -- -------------------------------------------------------------------------- diff --git a/compiler/codeGen/CgHpc.hs b/compiler/codeGen/CgHpc.hs index 48756505c3..a134f00067 100644 --- a/compiler/codeGen/CgHpc.hs +++ b/compiler/codeGen/CgHpc.hs @@ -12,6 +12,7 @@ import OldCmm import CLabel import Module import OldCmmUtils +import CgUtils import CgMonad import HscTypes @@ -30,9 +31,8 @@ cgTickBox mod n = do hpcTable :: Module -> HpcInfo -> Code hpcTable this_mod (HpcInfo hpc_tickCount _) = do - emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod) - ] ++ - [ CmmStaticLit (CmmInt 0 W64) + emitDataLits (mkHpcTicksLabel this_mod) $ + [ CmmInt 0 W64 | _ <- take hpc_tickCount [0::Int ..] ] diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index 2745832227..093b9ffaab 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -84,12 +84,12 @@ mkCmmInfo cl_info = do info = ConstrInfo (ptrs, nptrs) (fromIntegral (dataConTagZ con)) conName - return $ CmmInfo gc_target Nothing (CmmInfoTable False prof cl_type info) + return $ CmmInfo gc_target Nothing (CmmInfoTable False False prof cl_type info) ClosureInfo { closureName = name, closureLFInfo = lf_info, closureSRT = srt } -> - return $ CmmInfo gc_target Nothing (CmmInfoTable False prof cl_type info) + return $ CmmInfo gc_target Nothing (CmmInfoTable (closureInfoLocal cl_info) False prof cl_type info) where info = case lf_info of @@ -142,7 +142,7 @@ emitReturnTarget name stmts ; let info = CmmInfo gc_target Nothing - (CmmInfoTable False + (CmmInfoTable False False (ProfilingInfo zeroCLit zeroCLit) rET_SMALL -- cmmToRawCmm may convert it to rET_BIG (ContInfo frame srt_info)) diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs index 9b195bfab2..273c1bf16e 100644 --- a/compiler/codeGen/CgMonad.lhs +++ b/compiler/codeGen/CgMonad.lhs @@ -736,7 +736,7 @@ emitCgStmt stmt ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt } } -emitData :: Section -> [CmmStatic] -> Code +emitData :: Section -> CmmStatics -> Code emitData sect lits = do { state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } } diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 63d99a629f..effa7a42d6 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -545,26 +545,26 @@ baseRegOffset _ = panic "baseRegOffset:other" emitDataLits :: CLabel -> [CmmLit] -> Code -- Emit a data-segment data block emitDataLits lbl lits - = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits) + = emitData Data (Statics lbl $ map CmmStaticLit lits) -mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph +mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatics info graph -- Emit a data-segment data block mkDataLits lbl lits - = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits) + = CmmData Data (Statics lbl $ map CmmStaticLit lits) emitRODataLits :: String -> CLabel -> [CmmLit] -> Code -- Emit a read-only data block emitRODataLits caller lbl lits - = emitData section (CmmDataLabel lbl : map CmmStaticLit lits) + = emitData section (Statics lbl $ map CmmStaticLit lits) where section | any needsRelocation lits = RelocatableReadOnlyData | otherwise = ReadOnlyData needsRelocation (CmmLabel _) = True needsRelocation (CmmLabelOff _ _) = True needsRelocation _ = False -mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph +mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatics info graph mkRODataLits lbl lits - = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits) + = CmmData section (Statics lbl $ map CmmStaticLit lits) where section | any needsRelocation lits = RelocatableReadOnlyData | otherwise = ReadOnlyData needsRelocation (CmmLabel _) = True @@ -580,7 +580,7 @@ mkByteStringCLit :: [Word8] -> FCode CmmLit mkByteStringCLit bytes = do { uniq <- newUnique ; let lbl = mkStringLitLabel uniq - ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes] + ; emitData ReadOnlyData $ Statics lbl [CmmString bytes] ; return (CmmLabel lbl) } ------------------------------------------------------------------------- diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index 4f59d95276..daf476adfc 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -50,7 +50,7 @@ module ClosureInfo ( isToplevClosure, closureValDescr, closureTypeDescr, -- profiling - isStaticClosure, + closureInfoLocal, isStaticClosure, cafBlackHoleClosureInfo, staticClosureNeedsLink, @@ -111,7 +111,8 @@ data ClosureInfo closureSMRep :: !SMRep, -- representation used by storage mgr closureSRT :: !C_SRT, -- What SRT applies to this closure closureType :: !Type, -- Type of closure (ToDo: remove) - closureDescr :: !String -- closure description (for profiling) + closureDescr :: !String, -- closure description (for profiling) + closureInfLcl :: Bool -- can the info pointer be a local symbol? } -- Constructor closures don't have a unique info table label (they use @@ -341,7 +342,12 @@ mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr closureSMRep = sm_rep, closureSRT = srt_info, closureType = idType id, - closureDescr = descr } + closureDescr = descr, + closureInfLcl = isDataConWorkId id } + -- Make the _info pointer for the implicit datacon worker binding + -- local. The reason we can do this is that importing code always + -- either uses the _closure or _con_info. By the invariants in CorePrep + -- anything else gets eta expanded. where name = idName id sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds @@ -842,6 +848,9 @@ staticClosureRequired _ _ _ = True %************************************************************************ \begin{code} +closureInfoLocal :: ClosureInfo -> Bool +closureInfoLocal ClosureInfo{ closureInfLcl = lcl } = lcl +closureInfoLocal ConInfo{} = False isStaticClosure :: ClosureInfo -> Bool isStaticClosure cl_info = isStaticRep (closureSMRep cl_info) @@ -927,9 +936,9 @@ infoTableLabelFromCI (ClosureInfo { closureName = name, LFThunk _ _ upd_flag (ApThunk arity) _ -> mkApInfoTableLabel upd_flag arity - LFThunk{} -> mkLocalInfoTableLabel name caf + LFThunk{} -> mkInfoTableLabel name caf - LFReEntrant _ _ _ _ -> mkLocalInfoTableLabel name caf + LFReEntrant _ _ _ _ -> mkInfoTableLabel name caf _ -> panic "infoTableLabelFromCI" @@ -1003,7 +1012,8 @@ cafBlackHoleClosureInfo (ClosureInfo { closureName = nm, closureSMRep = BlackHoleRep, closureSRT = NoC_SRT, closureType = ty, - closureDescr = "" } + closureDescr = "", + closureInfLcl = False } cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo" \end{code} diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs index 7a7bf48b92..42c4bd24fc 100644 --- a/compiler/codeGen/CodeGen.lhs +++ b/compiler/codeGen/CodeGen.lhs @@ -84,7 +84,7 @@ codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info -- initialisation routines; see Note -- [pipeline-split-init]. - ; dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms code_stuff) + ; dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms (targetPlatform dflags) code_stuff) ; return code_stuff } @@ -105,7 +105,7 @@ mkModuleInit dflags cost_centre_info this_mod hpc_info -- For backwards compatibility: user code may refer to this -- label for calling hs_add_root(). - ; emitData Data $ [ CmmDataLabel (mkPlainModuleInitLabel this_mod) ] + ; emitData Data $ Statics (mkPlainModuleInitLabel this_mod) [] ; whenC (this_mod == mainModIs dflags) $ emitSimpleProc (mkPlainModuleInitLabel rOOT_MAIN) $ return () diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 2bfe1876ba..29a254fafc 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -81,7 +81,7 @@ codeGen dflags this_mod data_tycons -- initialisation routines; see Note -- [pipeline-split-init]. - ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms code_stuff) + ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms (targetPlatform dflags) code_stuff) ; return code_stuff } @@ -182,7 +182,7 @@ mkModuleInit cost_centre_info this_mod hpc_info ; initCostCentres cost_centre_info -- For backwards compatibility: user code may refer to this -- label for calling hs_add_root(). - ; emitData Data $ [ CmmDataLabel (mkPlainModuleInitLabel this_mod) ] + ; emitData Data $ Statics (mkPlainModuleInitLabel this_mod) [] } --------------------------------------------------------------- diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index a8d91f58d6..7c4f8bc8b8 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -56,7 +56,7 @@ module StgCmmClosure ( isToplevClosure, closureValDescr, closureTypeDescr, -- profiling - isStaticClosure, + closureInfoLocal, isStaticClosure, cafBlackHoleClosureInfo, staticClosureNeedsLink, clHasCafRefs @@ -679,7 +679,8 @@ data ClosureInfo closureSRT :: !C_SRT, -- What SRT applies to this closure closureType :: !Type, -- Type of closure (ToDo: remove) closureDescr :: !String, -- closure description (for profiling) - closureCafs :: !CafInfo -- whether the closure may have CAFs + closureCafs :: !CafInfo, -- whether the closure may have CAFs + closureInfLcl :: Bool -- can the info pointer be a local symbol? } -- Constructor closures don't have a unique info table label (they use @@ -725,7 +726,12 @@ mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr closureSRT = srt_info, closureType = idType id, closureDescr = descr, - closureCafs = idCafInfo id } + closureCafs = idCafInfo id, + closureInfLcl = isDataConWorkId id } + -- Make the _info pointer for the implicit datacon worker binding + -- local. The reason we can do this is that importing code always + -- either uses the _closure or _con_info. By the invariants in CorePrep + -- anything else gets eta expanded. where name = idName id sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds @@ -756,7 +762,8 @@ cafBlackHoleClosureInfo (ClosureInfo { closureName = nm, closureSRT = NoC_SRT, closureType = ty, closureDescr = "", - closureCafs = cafs } + closureCafs = cafs, + closureInfLcl = False } cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo" @@ -931,6 +938,10 @@ staticClosureNeedsLink (ConInfo { closureSMRep = sm_rep, closureCon = con }) GenericRep _ _ _ ConstrNoCaf -> False _other -> True +closureInfoLocal :: ClosureInfo -> Bool +closureInfoLocal ClosureInfo{ closureInfLcl = lcl } = lcl +closureInfoLocal ConInfo{} = False + isStaticClosure :: ClosureInfo -> Bool isStaticClosure cl_info = isStaticRep (closureSMRep cl_info) @@ -997,9 +1008,9 @@ infoTableLabelFromCI cl@(ClosureInfo { closureName = name, LFThunk _ _ upd_flag (ApThunk arity) _ -> mkApInfoTableLabel upd_flag arity - LFThunk{} -> mkLocalInfoTableLabel name $ clHasCafRefs cl + LFThunk{} -> mkInfoTableLabel name $ clHasCafRefs cl - LFReEntrant _ _ _ _ -> mkLocalInfoTableLabel name $ clHasCafRefs cl + LFReEntrant _ _ _ _ -> mkInfoTableLabel name $ clHasCafRefs cl _other -> panic "infoTableLabelFromCI" diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index eee4a08bc7..fa16b2a7f5 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -53,6 +53,11 @@ import UniqSupply cgExpr :: StgExpr -> FCode () cgExpr (StgApp fun args) = cgIdApp fun args + +{- seq# a s ==> a -} +cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = + cgIdApp a [] + cgExpr (StgOpApp op args ty) = cgOpApp op args ty cgExpr (StgConApp con args) = cgConApp con args cgExpr (StgSCC cc expr) = do { emitSetCCC cc; cgExpr expr } @@ -322,6 +327,22 @@ cgCase scrut@(StgApp v []) _ _ (PrimAlt _) _ ; emit $ mkComment $ mkFastString "should be unreachable code" ; emit $ withFreshLabel "l" (\l -> mkLabel l <*> mkBranch l)} +{- +case seq# a s of v + (# s', a' #) -> e + +==> + +case a of v + (# s', a' #) -> e + +(taking advantage of the fact that the return convention for (# State#, a #) +is the same as the return convention for just 'a') +-} +cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr srt alt_type alts + = -- handle seq#, same return convention as vanilla 'a'. + cgCase (StgApp a []) bndr srt alt_type alts + cgCase scrut bndr srt alt_type alts = -- the general case do { up_hp_usg <- getVirtHp -- Upstream heap usage diff --git a/compiler/codeGen/StgCmmHpc.hs b/compiler/codeGen/StgCmmHpc.hs index fae3bef016..4465e30b04 100644 --- a/compiler/codeGen/StgCmmHpc.hs +++ b/compiler/codeGen/StgCmmHpc.hs @@ -11,11 +11,11 @@ module StgCmmHpc ( initHpc, mkTickBox ) where import StgCmmMonad import MkGraph -import CmmDecl import CmmExpr import CLabel import Module import CmmUtils +import StgCmmUtils import HscTypes import StaticFlags @@ -36,9 +36,8 @@ initHpc _ (NoHpcInfo {}) = return () initHpc this_mod (HpcInfo tickCount _hashNo) = whenC opt_Hpc $ - do { emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod) - ] ++ - [ CmmStaticLit (CmmInt 0 W64) - | _ <- take tickCount [0::Int ..] - ] + do { emitDataLits (mkHpcTicksLabel this_mod) + [ (CmmInt 0 W64) + | _ <- take tickCount [0::Int ..] + ] } diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index eddf257e5f..278c41aef2 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -496,7 +496,7 @@ mkCmmInfo cl_info ad_lit <- mkStringCLit (closureValDescr cl_info) return $ ProfilingInfo fd_lit ad_lit else return $ ProfilingInfo (mkIntCLit 0) (mkIntCLit 0) - ; return (CmmInfoTable (isStaticClosure cl_info) prof cl_type info) } + ; return (CmmInfoTable (closureInfoLocal cl_info) (isStaticClosure cl_info) prof cl_type info) } where k_with_con_name con_info con info_lbl = do cstr <- mkByteStringCLit $ dataConIdentity con diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index f92b3cde27..d06b581f26 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -593,7 +593,7 @@ emit ag = do { state <- getState ; setState $ state { cgs_stmts = cgs_stmts state <*> ag } } -emitData :: Section -> [CmmStatic] -> FCode () +emitData :: Section -> CmmStatics -> FCode () emitData sect lits = do { state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } } diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 1a6d05e6e6..c71d285735 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -210,6 +210,18 @@ emitPrimOp [res] ParOp [arg] (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))) [(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)] +emitPrimOp [res] SparkOp [arg] + = do + -- returns the value of arg in res. We're going to therefore + -- refer to arg twice (once to pass to newSpark(), and once to + -- assign to res), so put it in a temporary. + tmp <- assignTemp arg + emitCCall + [] + (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))) + [(CmmReg (CmmGlobal BaseReg), AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)] + emit (mkAssign (CmmLocal res) (CmmReg (CmmLocal tmp))) + emitPrimOp [res] ReadMutVarOp [mutv] = emit (mkAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord)) diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 558b7fdeaa..74da7317d4 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -508,26 +508,26 @@ baseRegOffset reg = pprPanic "baseRegOffset:" (ppr reg) emitDataLits :: CLabel -> [CmmLit] -> FCode () -- Emit a data-segment data block emitDataLits lbl lits - = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits) + = emitData Data (Statics lbl $ map CmmStaticLit lits) -mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt +mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatics info stmt -- Emit a data-segment data block mkDataLits lbl lits - = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits) + = CmmData Data (Statics lbl $ map CmmStaticLit lits) emitRODataLits :: CLabel -> [CmmLit] -> FCode () -- Emit a read-only data block emitRODataLits lbl lits - = emitData section (CmmDataLabel lbl : map CmmStaticLit lits) + = emitData section (Statics lbl $ map CmmStaticLit lits) where section | any needsRelocation lits = RelocatableReadOnlyData | otherwise = ReadOnlyData needsRelocation (CmmLabel _) = True needsRelocation (CmmLabelOff _ _) = True needsRelocation _ = False -mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt +mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatics info stmt mkRODataLits lbl lits - = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits) + = CmmData section (Statics lbl $ map CmmStaticLit lits) where section | any needsRelocation lits = RelocatableReadOnlyData | otherwise = ReadOnlyData needsRelocation (CmmLabel _) = True @@ -543,7 +543,7 @@ mkByteStringCLit :: [Word8] -> FCode CmmLit mkByteStringCLit bytes = do { uniq <- newUnique ; let lbl = mkStringLitLabel uniq - ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes] + ; emitData ReadOnlyData $ Statics lbl [CmmString bytes] ; return (CmmLabel lbl) } ------------------------------------------------------------------------- diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index bd6cdf4c7f..58a940c72a 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -271,38 +271,39 @@ instance OutputableBndr Var where pprCoreBinder :: BindingSite -> Var -> SDoc pprCoreBinder LetBind binder | isTyVar binder = pprKindedTyVarBndr binder - | otherwise = pprTypedBinder binder $$ + | otherwise = pprTypedLetBinder binder $$ ppIdInfo binder (idInfo binder) -- Lambda bound type variables are preceded by "@" pprCoreBinder bind_site bndr = getPprStyle $ \ sty -> - pprTypedLCBinder bind_site (debugStyle sty) bndr + pprTypedLamBinder bind_site (debugStyle sty) bndr pprUntypedBinder :: Var -> SDoc pprUntypedBinder binder | isTyVar binder = ptext (sLit "@") <+> ppr binder -- NB: don't print kind | otherwise = pprIdBndr binder -pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc +pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc -- For lambda and case binders, show the unfolding info (usually none) -pprTypedLCBinder bind_site debug_on var +pprTypedLamBinder bind_site debug_on var | not debug_on && isDeadBinder var = char '_' | not debug_on, CaseBind <- bind_site = pprUntypedBinder var -- No parens, no kind info + | opt_SuppressAll = pprUntypedBinder var -- Suppress the signature | isTyVar var = parens (pprKindedTyVarBndr var) | otherwise = parens (hang (pprIdBndr var) 2 (vcat [ dcolon <+> pprType (idType var), pp_unf])) - where - unf_info = unfoldingInfo (idInfo var) - pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info - | otherwise = empty + where + unf_info = unfoldingInfo (idInfo var) + pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info + | otherwise = empty -pprTypedBinder :: Var -> SDoc +pprTypedLetBinder :: Var -> SDoc -- Print binder with a type or kind signature (not paren'd) -pprTypedBinder binder - | isTyVar binder = pprKindedTyVarBndr binder - | opt_SuppressTypeSignatures = empty - | otherwise = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder)) +pprTypedLetBinder binder + | isTyVar binder = pprKindedTyVarBndr binder + | opt_SuppressTypeSignatures = pprIdBndr binder + | otherwise = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder)) pprKindedTyVarBndr :: TyVar -> SDoc -- Print a type variable binder with its kind (but not if *) @@ -459,7 +460,8 @@ pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn, ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs }) = hang (doubleQuotes (ftext name) <+> ppr act) - 4 (sep [ptext (sLit "forall") <+> braces (sep (map pprTypedBinder tpl_vars)), + 4 (sep [ptext (sLit "forall") <+> + sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot, nest 2 (ppr fn <+> sep (map pprArg tpl_args)), nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs) ]) diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 15d547eab0..5d045a80a9 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -346,8 +346,8 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs)) = putSrcSpanDs loc $ do { let bndrs' = [var | RuleBndr (L _ var) <- vars] - ; lhs' <- unsetOptM Opt_EnableRewriteRules $ - unsetOptM Opt_WarnIdentities $ + ; lhs' <- unsetDOptM Opt_EnableRewriteRules $ + unsetWOptM Opt_WarnIdentities $ dsLExpr lhs -- Note [Desugaring RULE left hand sides] ; rhs' <- dsLExpr rhs diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 11eedbe496..a68214d1b1 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -225,7 +225,7 @@ dsExpr (HsOverLit lit) = dsOverLit lit dsExpr (HsWrap co_fn e) = do { co_fn' <- dsHsWrapper co_fn ; e' <- dsExpr e - ; warn_id <- doptDs Opt_WarnIdentities + ; warn_id <- woptDs Opt_WarnIdentities ; when warn_id $ warnAboutIdentities e' co_fn' ; return (co_fn' e') } @@ -830,13 +830,13 @@ warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM () warnDiscardedDoBindings rhs rhs_ty | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty = do { -- Warn about discarding non-() things in 'monadic' binding - ; warn_unused <- doptDs Opt_WarnUnusedDoBind + ; warn_unused <- woptDs Opt_WarnUnusedDoBind ; if warn_unused && not (isUnitTy elt_ty) then warnDs (unusedMonadBind rhs elt_ty) else -- Warn about discarding m a things in 'monadic' binding of the same type, -- but only if we didn't already warn due to Opt_WarnUnusedDoBind - do { warn_wrong <- doptDs Opt_WarnWrongDoBind + do { warn_wrong <- woptDs Opt_WarnWrongDoBind ; case tcSplitAppTy_maybe elt_ty of Just (elt_m_ty, _) | warn_wrong, m_ty `eqType` elt_m_ty -> warnDs (wrongMonadBind rhs elt_ty) diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index b391b8f02a..6d73d1d2bb 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -40,6 +40,8 @@ import BasicTypes import SrcLoc import Outputable import FastString +import DynFlags +import Platform import Config import Constants import OrdList @@ -298,8 +300,9 @@ dsFExport fn_id ty ext_name cconv isDyn= do Nothing -> return (orig_res_ty, False) -- The function returns t + dflags <- getDOpts return $ - mkFExportCBits ext_name + mkFExportCBits dflags ext_name (if isDyn then Nothing else Just fn_id) fe_arg_tys res_ty is_IO_res_ty cconv \end{code} @@ -420,7 +423,8 @@ The C stub constructs the application of the exported Haskell function using the hugs/ghc rts invocation API. \begin{code} -mkFExportCBits :: FastString +mkFExportCBits :: DynFlags + -> FastString -> Maybe Id -- Just==static, Nothing==dynamic -> [Type] -> Type @@ -431,7 +435,7 @@ mkFExportCBits :: FastString String, -- the argument reps Int -- total size of arguments ) -mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc +mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc = (header_bits, c_bits, type_string, sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args -- NB. the calculation here isn't strictly speaking correct. @@ -474,7 +478,7 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc -- add some auxiliary args; the stable ptr in the wrapper case, and -- a slot for the dummy return address in the wrapper + ccall case aug_arg_info - | isNothing maybe_target = stable_ptr_arg : insertRetAddr cc arg_info + | isNothing maybe_target = stable_ptr_arg : insertRetAddr dflags cc arg_info | otherwise = arg_info stable_ptr_arg = @@ -627,26 +631,27 @@ typeTyCon ty = case tcSplitTyConApp_maybe (repType ty) of Just (tc,_) -> tc Nothing -> pprPanic "DsForeign.typeTyCon" (ppr ty) -insertRetAddr :: CCallConv -> [(SDoc, SDoc, Type, CmmType)] - -> [(SDoc, SDoc, Type, CmmType)] -#if !defined(x86_64_TARGET_ARCH) -insertRetAddr CCallConv args = ret_addr_arg : args -insertRetAddr _ args = args -#else --- On x86_64 we insert the return address after the 6th --- integer argument, because this is the point at which we --- need to flush a register argument to the stack (See rts/Adjustor.c for --- details). -insertRetAddr CCallConv args = go 0 args - where go :: Int -> [(SDoc, SDoc, Type, CmmType)] - -> [(SDoc, SDoc, Type, CmmType)] - go 6 args = ret_addr_arg : args - go n (arg@(_,_,_,rep):args) - | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args - | otherwise = arg : go n args - go _ [] = [] -insertRetAddr _ args = args -#endif +insertRetAddr :: DynFlags -> CCallConv + -> [(SDoc, SDoc, Type, CmmType)] + -> [(SDoc, SDoc, Type, CmmType)] +insertRetAddr dflags CCallConv args + = case platformArch (targetPlatform dflags) of + ArchX86_64 -> + -- On x86_64 we insert the return address after the 6th + -- integer argument, because this is the point at which we + -- need to flush a register argument to the stack (See + -- rts/Adjustor.c for details). + let go :: Int -> [(SDoc, SDoc, Type, CmmType)] + -> [(SDoc, SDoc, Type, CmmType)] + go 6 args = ret_addr_arg : args + go n (arg@(_,_,_,rep):args) + | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args + | otherwise = arg : go n args + go _ [] = [] + in go 0 args + _ -> + ret_addr_arg : args +insertRetAddr _ _ args = args ret_addr_arg :: (SDoc, SDoc, Type, CmmType) ret_addr_arg = (text "original_return_addr", text "void*", undefined, diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 7538e310ce..8d0082ad21 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -351,8 +351,7 @@ repCCallConv callConv = notHandled "repCCallConv" (ppr callConv) repSafety :: Safety -> DsM (Core TH.Safety) repSafety PlayRisky = rep2 unsafeName [] repSafety PlayInterruptible = rep2 interruptibleName [] -repSafety (PlaySafe False) = rep2 safeName [] -repSafety (PlaySafe True) = rep2 threadsafeName [] +repSafety PlaySafe = rep2 safeName [] ds_msg :: SDoc ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:") @@ -1798,7 +1797,6 @@ templateHaskellNames = [ -- Safety unsafeName, safeName, - threadsafeName, interruptibleName, -- InlineSpec inlineSpecNoPhaseName, inlineSpecPhaseName, @@ -2048,10 +2046,9 @@ cCallName = libFun (fsLit "cCall") cCallIdKey stdCallName = libFun (fsLit "stdCall") stdCallIdKey -- data Safety = ... -unsafeName, safeName, threadsafeName, interruptibleName :: Name +unsafeName, safeName, interruptibleName :: Name unsafeName = libFun (fsLit "unsafe") unsafeIdKey safeName = libFun (fsLit "safe") safeIdKey -threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey -- data InlineSpec = ... @@ -2331,10 +2328,9 @@ cCallIdKey = mkPreludeMiscIdUnique 394 stdCallIdKey = mkPreludeMiscIdUnique 395 -- data Safety = ... -unsafeIdKey, safeIdKey, threadsafeIdKey, interruptibleIdKey :: Unique +unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique unsafeIdKey = mkPreludeMiscIdUnique 400 safeIdKey = mkPreludeMiscIdUnique 401 -threadsafeIdKey = mkPreludeMiscIdUnique 402 interruptibleIdKey = mkPreludeMiscIdUnique 403 -- data InlineSpec = diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index 62e805334e..1dd347be98 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -9,7 +9,7 @@ module DsMonad ( DsM, mapM, mapAndUnzipM, initDs, initDsTc, fixDs, - foldlM, foldrM, ifDOptM, unsetOptM, + foldlM, foldrM, ifDOptM, unsetDOptM, unsetWOptM, Applicative(..),(<$>), newLocalName, @@ -20,7 +20,7 @@ module DsMonad ( mkPrintUnqualifiedDs, newUnique, UniqSupply, newUniqueSupply, - getDOptsDs, getGhcModeDs, doptDs, + getDOptsDs, getGhcModeDs, doptDs, woptDs, dsLookupGlobal, dsLookupGlobalId, dsLookupDPHId, dsLookupTyCon, dsLookupDataCon, dsLookupClass, @@ -257,6 +257,9 @@ getDOptsDs = getDOpts doptDs :: DynFlag -> TcRnIf gbl lcl Bool doptDs = doptM +woptDs :: WarningFlag -> TcRnIf gbl lcl Bool +woptDs = woptM + getGhcModeDs :: DsM GhcMode getGhcModeDs = getDOptsDs >>= return . ghcMode diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index 1a044d3471..25dab9370c 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -74,18 +74,18 @@ matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs where (pats, eqns_shadow) = check qs incomplete = incomplete_flag hs_ctx && (notNull pats) - shadow = dopt Opt_WarnOverlappingPatterns dflags + shadow = wopt Opt_WarnOverlappingPatterns dflags && notNull eqns_shadow incomplete_flag :: HsMatchContext id -> Bool - incomplete_flag (FunRhs {}) = dopt Opt_WarnIncompletePatterns dflags - incomplete_flag CaseAlt = dopt Opt_WarnIncompletePatterns dflags + incomplete_flag (FunRhs {}) = wopt Opt_WarnIncompletePatterns dflags + incomplete_flag CaseAlt = wopt Opt_WarnIncompletePatterns dflags - incomplete_flag LambdaExpr = dopt Opt_WarnIncompleteUniPatterns dflags - incomplete_flag PatBindRhs = dopt Opt_WarnIncompleteUniPatterns dflags - incomplete_flag ProcExpr = dopt Opt_WarnIncompleteUniPatterns dflags + incomplete_flag LambdaExpr = wopt Opt_WarnIncompleteUniPatterns dflags + incomplete_flag PatBindRhs = wopt Opt_WarnIncompleteUniPatterns dflags + incomplete_flag ProcExpr = wopt Opt_WarnIncompleteUniPatterns dflags - incomplete_flag RecUpd = dopt Opt_WarnIncompletePatternsRecUpd dflags + incomplete_flag RecUpd = wopt Opt_WarnIncompletePatternsRecUpd dflags incomplete_flag ThPatQuote = False incomplete_flag (StmtCtxt {}) = False -- Don't warn about incomplete patterns diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs index 0bd2538937..173bad999c 100644 --- a/compiler/deSugar/MatchLit.lhs +++ b/compiler/deSugar/MatchLit.lhs @@ -65,6 +65,8 @@ dsLit (HsStringPrim s) = return (Lit (MachStr s)) dsLit (HsCharPrim c) = return (Lit (MachChar c)) dsLit (HsIntPrim i) = return (Lit (MachInt i)) dsLit (HsWordPrim w) = return (Lit (MachWord w)) +dsLit (HsInt64Prim i) = return (Lit (MachInt64 i)) +dsLit (HsWord64Prim w) = return (Lit (MachWord64 w)) dsLit (HsFloatPrim f) = return (Lit (MachFloat (fl_value f))) dsLit (HsDoublePrim d) = return (Lit (MachDouble (fl_value d))) @@ -111,6 +113,8 @@ hsLitKey :: HsLit -> Literal -- 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) diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 2711c1b20e..8ac0eeae80 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -63,7 +63,7 @@ Library if flag(base3) || flag(base4) Build-Depends: directory >= 1 && < 1.2, - process >= 1 && < 1.1, + process >= 1 && < 1.2, bytestring >= 0.9 && < 0.10, old-time >= 1 && < 1.1, containers >= 0.1 && < 0.5, diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 90ec0b3a1f..8b56c4f3ae 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -1093,26 +1093,18 @@ linkPackage dflags pkg classifieds <- mapM (locateOneObj dirs) libs' -- Complication: all the .so's must be loaded before any of the .o's. - let dlls = [ dll | DLL dll <- classifieds ] - objs = [ obj | Object obj <- classifieds ] - archs = [ arch | Archive arch <- classifieds ] + let known_dlls = [ dll | DLLPath dll <- classifieds ] + dlls = [ dll | DLL dll <- classifieds ] + objs = [ obj | Object obj <- classifieds ] + archs = [ arch | Archive arch <- classifieds ] maybePutStr dflags ("Loading package " ++ display (sourcePackageId pkg) ++ " ... ") -- See comments with partOfGHCi when (packageName pkg `notElem` partOfGHCi) $ do loadFrameworks pkg - -- When a library A needs symbols from a library B, the order in - -- extra_libraries/extra_ld_opts is "-lA -lB", because that's the - -- way ld expects it for static linking. Dynamic linking is a - -- different story: When A has no dependency information for B, - -- dlopen-ing A with RTLD_NOW (see addDLL in Linker.c) will fail - -- when B has not been loaded before. In a nutshell: Reverse the - -- order of DLLs for dynamic linking. - -- This fixes a problem with the HOpenGL package (see "Compiling - -- HOpenGL under recent versions of GHC" on the HOpenGL list). - mapM_ (load_dyn dirs) (reverse dlls) - + mapM_ load_dyn (known_dlls ++ map mkSOName dlls) + -- After loading all the DLLs, we can load the static objects. -- Ordering isn't important here, because we do one final link -- step to resolve everything. @@ -1124,12 +1116,17 @@ linkPackage dflags pkg if succeeded ok then maybePutStrLn dflags "done." else ghcError (InstallationError ("unable to load package `" ++ display (sourcePackageId pkg) ++ "'")) -load_dyn :: [FilePath] -> FilePath -> IO () -load_dyn dirs dll = do r <- loadDynamic dirs dll - case r of - Nothing -> return () - Just err -> ghcError (CmdLineError ("can't load .so/.DLL for: " - ++ dll ++ " (" ++ err ++ ")" )) +-- we have already searched the filesystem; the strings passed to load_dyn +-- can be passed directly to loadDLL. They are either fully-qualified +-- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so"). In the latter case, +-- loadDLL is going to search the system paths to find the library. +-- +load_dyn :: FilePath -> IO () +load_dyn dll = do r <- loadDLL dll + case r of + Nothing -> return () + Just err -> ghcError (CmdLineError ("can't load .so/.DLL for: " + ++ dll ++ " (" ++ err ++ ")" )) loadFrameworks :: InstalledPackageInfo_ ModuleName -> IO () loadFrameworks pkg @@ -1168,7 +1165,7 @@ locateOneObj dirs lib mk_dyn_lib_path dir = dir </> mkSOName dyn_lib_name findObject = liftM (fmap Object) $ findFile mk_obj_path dirs findArchive = liftM (fmap Archive) $ findFile mk_arch_path dirs - findDll = liftM (fmap DLL) $ findFile mk_dyn_lib_path dirs + findDll = liftM (fmap DLLPath) $ findFile mk_dyn_lib_path dirs assumeDll = return (DLL lib) infixr `orElse` f `orElse` g = do m <- f diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 49cd0d3575..639cc39a59 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -375,8 +375,7 @@ cvtForD (ImportF callconv safety from nm ty) where safety' = case safety of Unsafe -> PlayRisky - Safe -> PlaySafe False - Threadsafe -> PlaySafe True + Safe -> PlaySafe Interruptible -> PlayInterruptible cvtForD (ExportF callconv as nm ty) diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 33cc2c503e..35bb17b10b 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -376,7 +376,7 @@ ppr_expr (OpApp e1 op _ e2) = hang (ppr op) 2 (sep [pp_e1, pp_e2]) pp_infixly v - = sep [nest 2 pp_e1, pprHsInfix v, nest 2 pp_e2] + = sep [pp_e1, sep [pprHsInfix v, nest 2 pp_e2]] ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e diff --git a/compiler/hsSyn/HsLit.lhs b/compiler/hsSyn/HsLit.lhs index 2cda103479..2b556ea7aa 100644 --- a/compiler/hsSyn/HsLit.lhs +++ b/compiler/hsSyn/HsLit.lhs @@ -37,8 +37,10 @@ data HsLit | HsStringPrim FastString -- Packed string | HsInt Integer -- Genuinely an Int; arises from TcGenDeriv, -- and from TRANSLATION - | HsIntPrim Integer -- Unboxed Int - | HsWordPrim Integer -- Unboxed Word + | HsIntPrim Integer -- literal Int# + | HsWordPrim Integer -- literal Word# + | HsInt64Prim Integer -- literal Int64# + | HsWord64Prim Integer -- literal Word64# | HsInteger Integer Type -- Genuinely an integer; arises only from TRANSLATION -- (overloaded literals are done with HsOverLit) | HsRat FractionalLit Type -- Genuinely a rational; arises only from TRANSLATION @@ -55,6 +57,8 @@ instance Eq HsLit where (HsInt x1) == (HsInt x2) = x1==x2 (HsIntPrim x1) == (HsIntPrim x2) = x1==x2 (HsWordPrim x1) == (HsWordPrim x2) = x1==x2 + (HsInt64Prim x1) == (HsInt64Prim x2) = x1==x2 + (HsWord64Prim x1) == (HsWord64Prim x2) = x1==x2 (HsInteger x1 _) == (HsInteger x2 _) = x1==x2 (HsRat x1 _) == (HsRat x2 _) = x1==x2 (HsFloatPrim x1) == (HsFloatPrim x2) = x1==x2 @@ -148,6 +152,8 @@ instance Outputable HsLit where ppr (HsDoublePrim d) = ppr d <> text "##" ppr (HsIntPrim i) = integer i <> char '#' ppr (HsWordPrim w) = integer w <> text "##" + ppr (HsInt64Prim i) = integer i <> text "L#" + ppr (HsWord64Prim w) = integer w <> text "L##" -- in debug mode, print the expression that it's resolved to, too instance OutputableBndr id => Outputable (HsOverLit id) where diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 95cf35e427..50406d2fac 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -289,8 +289,8 @@ mkIface_ hsc_env maybe_old_fingerprint intermediate_iface decls -- Warn about orphans - ; let warn_orphs = dopt Opt_WarnOrphans dflags - warn_auto_orphs = dopt Opt_WarnAutoOrphans dflags + ; let warn_orphs = wopt Opt_WarnOrphans dflags + warn_auto_orphs = wopt Opt_WarnAutoOrphans dflags orph_warnings --- Laziness means no work done unless -fwarn-orphans | warn_orphs || warn_auto_orphs = rule_warns `unionBags` inst_warns | otherwise = emptyBag @@ -474,7 +474,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls = do let hash_fn = mk_put_name local_env decl = abiDecl abi -- pprTrace "fingerprinting" (ppr (ifName decl) ) $ do - hash <- computeFingerprint dflags hash_fn abi + hash <- computeFingerprint hash_fn abi return (extend_hash_env (hash,decl) local_env, (hash,decl) : decls_w_hashes) @@ -486,7 +486,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do let stable_abis = sortBy cmp_abiNames abis -- put the cycle in a canonical order - hash <- computeFingerprint dflags hash_fn stable_abis + hash <- computeFingerprint hash_fn stable_abis let pairs = zip (repeat hash) decls return (foldr extend_hash_env local_env pairs, pairs ++ decls_w_hashes) @@ -520,12 +520,12 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls $ dep_orphs sorted_deps dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods - orphan_hash <- computeFingerprint dflags (mk_put_name local_env) + orphan_hash <- computeFingerprint (mk_put_name local_env) (map ifDFun orph_insts, orph_rules, fam_insts) -- the export list hash doesn't depend on the fingerprints of -- the Names it mentions, only the Names themselves, hence putNameLiterally. - export_hash <- computeFingerprint dflags putNameLiterally + export_hash <- computeFingerprint putNameLiterally (mi_exports iface0, orphan_hash, dep_orphan_hashes, @@ -545,7 +545,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- - orphans -- - deprecations -- - XXX vect info? - mod_hash <- computeFingerprint dflags putNameLiterally + mod_hash <- computeFingerprint putNameLiterally (map fst sorted_decls, export_hash, orphan_hash, @@ -556,7 +556,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- - usages -- - deps -- - hpc - iface_hash <- computeFingerprint dflags putNameLiterally + iface_hash <- computeFingerprint putNameLiterally (mod_hash, mi_usages iface0, sorted_deps, @@ -749,19 +749,6 @@ putNameLiterally bh name = ASSERT( isExternalName name ) do { put_ bh $! nameModule name ; put_ bh $! nameOccName name } -computeFingerprint :: Binary a - => DynFlags - -> (BinHandle -> Name -> IO ()) - -> a - -> IO Fingerprint - -computeFingerprint _dflags put_name a = do - bh <- openBinMem (3*1024) -- just less than a block - ud <- newWriteState put_name putFS - bh <- return $ setUserData bh ud - put_ bh a - fingerprintBinMem bh - {- -- for testing: use the md5sum command to generate fingerprints and -- compare the results against our built-in version. diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs index 82c6bfa65e..217d02debf 100644 --- a/compiler/llvmGen/Llvm/PpLlvm.hs +++ b/compiler/llvmGen/Llvm/PpLlvm.hs @@ -113,15 +113,18 @@ ppLlvmFunction (LlvmFunction dec args attrs sec body) = -- | Print out a function defenition header. ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> Doc ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args - = let varg' = if varg == VarArgs then text ", ..." else empty + = let varg' = case varg of + VarArgs | null p -> text "..." + | otherwise -> text ", ..." + _otherwise -> empty align = case a of - Just a' -> space <> text "align" <+> texts a' + Just a' -> text " align" <+> texts a' Nothing -> empty args' = map (\((ty,p),n) -> texts ty <+> ppSpaceJoin p <+> text "%" <> ftext n) (zip p args) in texts l <+> texts c <+> texts r <+> text "@" <> ftext n <> lparen <> - (hcat $ intersperse comma args') <> varg' <> rparen <> align + (hcat $ intersperse (comma <> space) args') <> varg' <> rparen <> align -- | Print out a list of function declaration. @@ -132,7 +135,18 @@ ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs -- Declarations define the function type but don't define the actual body of -- the function. ppLlvmFunctionDecl :: LlvmFunctionDecl -> Doc -ppLlvmFunctionDecl dec = text "declare" <+> texts dec +ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a) + = let varg' = case varg of + VarArgs | null p -> text "..." + | otherwise -> text ", ..." + _otherwise -> empty + align = case a of + Just a' -> text " align" <+> texts a' + Nothing -> empty + args = hcat $ intersperse (comma <> space) $ + map (\(t,a) -> texts t <+> ppSpaceJoin a) p + in text "declare" <+> texts l <+> texts c <+> texts r <+> text "@" <> + ftext n <> lparen <> args <> varg' <> rparen <> align -- | Print out a list of LLVM blocks. @@ -204,7 +218,7 @@ ppCall ct fptr vals attrs = case fptr of ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) = let tc = if ct == TailCall then text "tail " else empty ppValues = ppCommaJoin vals - ppParams = map (\(ty,p) -> texts ty <+> ppSpaceJoin p) params + ppParams = map (texts . fst) params ppArgTy = (hcat $ intersperse comma ppParams) <> (case argTy of VarArgs -> text ", ..." @@ -317,15 +331,14 @@ ppAsm asm constraints rty vars sideeffect alignstack = -- * Misc functions -------------------------------------------------------------------------------- ppCommaJoin :: (Show a) => [a] -> Doc -ppCommaJoin strs = hcat $ intersperse comma (map texts strs) +ppCommaJoin strs = hcat $ intersperse (comma <> space) (map texts strs) ppSpaceJoin :: (Show a) => [a] -> Doc ppSpaceJoin strs = hcat $ intersperse space (map texts strs) -- | Convert SDoc to Doc llvmSDoc :: Out.SDoc -> Doc -llvmSDoc d - = Out.withPprStyleDoc (Out.mkCodeStyle Out.CStyle) d +llvmSDoc d = Out.withPprStyleDoc (Out.mkCodeStyle Out.CStyle) d -- | Showable to Doc texts :: (Show a) => a -> Doc diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs index 3637c86467..101342606d 100644 --- a/compiler/llvmGen/Llvm/Types.hs +++ b/compiler/llvmGen/Llvm/Types.hs @@ -7,6 +7,7 @@ module Llvm.Types where #include "HsVersions.h" import Data.Char +import Data.List (intercalate) import Numeric import Constants @@ -59,12 +60,12 @@ instance Show LlvmType where show (LMStruct tys ) = "<{" ++ (commaCat tys) ++ "}>" show (LMFunction (LlvmFunctionDecl _ _ _ r varg p _)) - = let args = ((drop 1).concat) $ -- use drop since it can handle empty lists - map (\(t,a) -> "," ++ show t ++ " " ++ spaceCat a) p - varg' = case varg of - VarArgs | not (null args) -> ", ..." - | otherwise -> "..." - _otherwise -> "" + = let varg' = case varg of + VarArgs | null args -> "..." + | otherwise -> ", ..." + _otherwise -> "" + -- by default we don't print param attributes + args = intercalate ", " $ map (show . fst) p in show r ++ " (" ++ args ++ varg' ++ ")" show (LMAlias (s,_)) = "%" ++ unpackFS s @@ -135,29 +136,13 @@ instance Show LlvmStatic where show (LMStaticLit l ) = show l show (LMUninitType t) = show t ++ " undef" show (LMStaticStr s t) = show t ++ " c\"" ++ unpackFS s ++ "\\00\"" - - show (LMStaticArray d t) - = let struc = case d of - [] -> "[]" - ts -> "[" ++ show (head ts) ++ - concat (map (\x -> "," ++ show x) (tail ts)) ++ "]" - in show t ++ " " ++ struc - - show (LMStaticStruc d t) - = let struc = case d of - [] -> "<{}>" - ts -> "<{" ++ show (head ts) ++ - concat (map (\x -> "," ++ show x) (tail ts)) ++ "}>" - in show t ++ " " ++ struc - + show (LMStaticArray d t) = show t ++ " [" ++ commaCat d ++ "]" + show (LMStaticStruc d t) = show t ++ "<{" ++ commaCat d ++ "}>" show (LMStaticPointer v) = show v - show (LMBitc v t) = show t ++ " bitcast (" ++ show v ++ " to " ++ show t ++ ")" - show (LMPtoI v t) = show t ++ " ptrtoint (" ++ show v ++ " to " ++ show t ++ ")" - show (LMAdd s1 s2) = let ty1 = getStatType s1 op = if isFloat ty1 then " fadd (" else " add (" @@ -176,13 +161,7 @@ instance Show LlvmStatic where -- | Concatenate an array together, separated by commas commaCat :: Show a => [a] -> String -commaCat [] = "" -commaCat x = show (head x) ++ (concat $ map (\y -> "," ++ show y) (tail x)) - --- | Concatenate an array together, separated by commas -spaceCat :: Show a => [a] -> String -spaceCat [] = "" -spaceCat x = show (head x) ++ (concat $ map (\y -> " " ++ show y) (tail x)) +commaCat xs = intercalate ", " $ map show xs -- ----------------------------------------------------------------------------- -- ** Operations on LLVM Basic Types and Variables @@ -207,12 +186,12 @@ getPlainName (LMLitVar x ) = getLit x -- | Print a literal value. No type. getLit :: LlvmLit -> String -getLit (LMIntLit i _) = show ((fromInteger i)::Int) +getLit (LMIntLit i _ ) = show ((fromInteger i)::Int) getLit (LMFloatLit r LMFloat ) = fToStr $ realToFrac r getLit (LMFloatLit r LMDouble) = dToStr r getLit f@(LMFloatLit _ _) = error $ "Can't print this float literal!" ++ show f -getLit (LMNullLit _) = "null" -getLit (LMUndefLit _) = "undef" +getLit (LMNullLit _ ) = "null" +getLit (LMUndefLit _ ) = "undef" -- | Return the 'LlvmType' of the 'LlvmVar' getVarType :: LlvmVar -> LlvmType @@ -366,15 +345,15 @@ data LlvmFunctionDecl = LlvmFunctionDecl { instance Show LlvmFunctionDecl where show (LlvmFunctionDecl n l c r varg p a) - = let args = ((drop 1).concat) $ -- use drop since it can handle empty lists - map (\(t,a) -> "," ++ show t ++ " " ++ spaceCat a) p - varg' = case varg of - VarArgs | not (null args) -> ", ..." - | otherwise -> "..." - _otherwise -> "" + = let varg' = case varg of + VarArgs | null args -> "..." + | otherwise -> ", ..." + _otherwise -> "" align = case a of Just a' -> " align " ++ show a' Nothing -> "" + -- by default we don't print param attributes + args = intercalate ", " $ map (show . fst) p in show l ++ " " ++ show c ++ " " ++ show r ++ " @" ++ unpackFS n ++ "(" ++ args ++ varg' ++ ")" ++ align diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index 56d8386431..be5c79cf64 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -7,15 +7,12 @@ module LlvmCodeGen ( llvmCodeGen, llvmFixupAsm ) where #include "HsVersions.h" import Llvm - import LlvmCodeGen.Base import LlvmCodeGen.CodeGen import LlvmCodeGen.Data import LlvmCodeGen.Ppr - import LlvmMangler -import CLabel import CgUtils ( fixStgRegisters ) import OldCmm import OldPprCmm @@ -42,19 +39,17 @@ llvmCodeGen dflags h us cmms (cdata,env) = foldr split ([],initLlvmEnv) cmm split (CmmData s d' ) (d,e) = ((s,d'):d,e) split (CmmProc i l _) (d,e) = - let lbl = strCLabel_llvm $ if not (null i) - then entryLblToInfoLbl l - else l + let lbl = strCLabel_llvm $ case i of + Nothing -> l + Just (Statics info_lbl _) -> info_lbl env' = funInsert lbl llvmFunTy e in (d,env') in do bufh <- newBufHandle h Prt.bufLeftRender bufh $ pprLlvmHeader - ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags - + ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags env' <- cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata [] cmmProcLlvmGens dflags bufh us env' cmm 1 [] - bFlush bufh return () @@ -62,7 +57,7 @@ llvmCodeGen dflags h us cmms -- ----------------------------------------------------------------------------- -- | Do LLVM code generation on all these Cmms data sections. -- -cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,[CmmStatic])] +cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,CmmStatics)] -> [LlvmUnresData] -> IO ( LlvmEnv ) cmmDataLlvmGens dflags h env [] lmdata @@ -83,41 +78,44 @@ cmmDataLlvmGens dflags h env (cmm:cmms) lmdata -- | Do LLVM code generation on all these Cmms procs. -- cmmProcLlvmGens :: DynFlags -> BufHandle -> UniqSupply -> LlvmEnv -> [RawCmmTop] - -> Int -- ^ count, used for generating unique subsections - -> [LlvmVar] -- ^ info tables that need to be marked as 'used' + -> Int -- ^ count, used for generating unique subsections + -> [[LlvmVar]] -- ^ info tables that need to be marked as 'used' -> IO () cmmProcLlvmGens _ _ _ _ [] _ [] = return () cmmProcLlvmGens _ h _ _ [] _ ivars - = let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr - ty = (LMArray (length ivars) i8Ptr) - usedArray = LMStaticArray (map cast ivars) ty + = let ivars' = concat ivars + cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr + ty = (LMArray (length ivars') i8Ptr) + usedArray = LMStaticArray (map cast ivars') ty lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending (Just $ fsLit "llvm.metadata") Nothing False, Just usedArray) in Prt.bufLeftRender h $ pprLlvmData ([lmUsed], []) -cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars - = do - (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm +cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars + = cmmProcLlvmGens dflags h us env cmms count ivars +cmmProcLlvmGens dflags h us env ((CmmProc _ _ (ListGraph [])) : cmms) count ivars + = cmmProcLlvmGens dflags h us env cmms count ivars + +cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars = do + (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm let (docs, ivar) = mapAndUnzip (pprLlvmCmmTop env' count) llvm Prt.bufLeftRender h $ Prt.vcat docs - - cmmProcLlvmGens dflags h us' env' cmms (count + 2) (concat ivar ++ ivars) + cmmProcLlvmGens dflags h us' env' cmms (count + 2) (ivar ++ ivars) -- | Complete LLVM code generation phase for a single top-level chunk of Cmm. cmmLlvmGen :: DynFlags -> UniqSupply -> LlvmEnv -> RawCmmTop -> IO ( UniqSupply, LlvmEnv, [LlvmCmmTop] ) -cmmLlvmGen dflags us env cmm - = do +cmmLlvmGen dflags us env cmm = do -- rewrite assignments to global regs let fixed_cmm = fixStgRegisters cmm dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" - (pprCmm $ Cmm [fixed_cmm]) + (pprCmm (targetPlatform dflags) $ Cmm [fixed_cmm]) -- generate llvm code from cmm let ((env', llvmBC), usGen) = initUs us $ genLlvmProc env fixed_cmm diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index 59cdad4918..1c7592ad2d 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -41,7 +41,7 @@ import Unique -- * Some Data Types -- -type LlvmCmmTop = GenCmmTop LlvmData [CmmStatic] (ListGraph LlvmStatement) +type LlvmCmmTop = GenCmmTop [LlvmData] (Maybe CmmStatics) (ListGraph LlvmStatement) type LlvmBasicBlock = GenBasicBlock LlvmStatement -- | Unresolved code. diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index eb002742e1..c9ad76efd5 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -29,28 +29,19 @@ import Util import Data.List ( partition ) import Control.Monad ( liftM ) -type LlvmStatements = OrdList LlvmStatement +type LlvmStatements = OrdList LlvmStatement -- ----------------------------------------------------------------------------- -- | Top-level of the LLVM proc Code generator -- genLlvmProc :: LlvmEnv -> RawCmmTop -> UniqSM (LlvmEnv, [LlvmCmmTop]) -genLlvmProc env (CmmData _ _) - = return (env, []) - -genLlvmProc env (CmmProc _ _ (ListGraph [])) - = return (env, []) - -genLlvmProc env (CmmProc info lbl (ListGraph blocks)) - = do - (env', lmblocks, lmdata) <- basicBlocksCodeGen env blocks ([], []) - - let proc = CmmProc info lbl (ListGraph lmblocks) - let tops = lmdata ++ [proc] - - return (env', tops) +genLlvmProc env (CmmProc info lbl (ListGraph blocks)) = do + (env', lmblocks, lmdata) <- basicBlocksCodeGen env blocks ([], []) + let proc = CmmProc info lbl (ListGraph lmblocks) + return (env', proc:lmdata) +genLlvmProc _ _ = panic "genLlvmProc: case that shouldn't reach here!" -- ----------------------------------------------------------------------------- -- * Block code generation diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs index 3e486a544f..ef86abfd6f 100644 --- a/compiler/llvmGen/LlvmCodeGen/Data.hs +++ b/compiler/llvmGen/LlvmCodeGen/Data.hs @@ -37,8 +37,8 @@ structStr = fsLit "_struct" -- complete this completely though as we need to pass all CmmStatic -- sections before all references can be resolved. This last step is -- done by 'resolveLlvmData'. -genLlvmData :: (Section, [CmmStatic]) -> LlvmUnresData -genLlvmData (sec, CmmDataLabel lbl:xs) = +genLlvmData :: (Section, CmmStatics) -> LlvmUnresData +genLlvmData (sec, Statics lbl xs) = let static = map genData xs label = strCLabel_llvm lbl @@ -50,8 +50,6 @@ genLlvmData (sec, CmmDataLabel lbl:xs) = alias = LMAlias ((label `appendFS` structStr), strucTy) in (lbl, sec, alias, static) -genLlvmData _ = panic "genLlvmData: CmmData section doesn't start with label!" - resolveLlvmDatas :: LlvmEnv -> [LlvmUnresData] -> [LlvmData] -> (LlvmEnv, [LlvmData]) @@ -150,7 +148,6 @@ resData _ _ = panic "resData: Non CLabel expr as left type!" -- -- | Handle static data --- Don't handle 'CmmAlign' or a 'CmmDataLabel'. genData :: CmmStatic -> UnresStatic genData (CmmString str) = @@ -164,12 +161,6 @@ genData (CmmUninitialised bytes) genData (CmmStaticLit lit) = genStaticLit lit -genData (CmmAlign _) - = panic "genData: Can't handle CmmAlign!" - -genData (CmmDataLabel _) - = panic "genData: Can't handle data labels not at top of data!" - -- | Generate Llvm code for a static literal. -- diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index 9f25c08826..40f7ce05f1 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -82,16 +82,16 @@ pprLlvmCmmTop :: LlvmEnv -> Int -> LlvmCmmTop -> (Doc, [LlvmVar]) pprLlvmCmmTop _ _ (CmmData _ lmdata) = (vcat $ map pprLlvmData lmdata, []) -pprLlvmCmmTop env count (CmmProc info lbl (ListGraph blks)) - = let static = CmmDataLabel lbl : info - (idoc, ivar) = if not (null info) - then pprInfoTable env count lbl static - else (empty, []) +pprLlvmCmmTop env count (CmmProc mb_info entry_lbl (ListGraph blks)) + = let (idoc, ivar) = case mb_info of + Nothing -> (empty, []) + Just (Statics info_lbl dat) + -> pprInfoTable env count info_lbl (Statics entry_lbl dat) in (idoc $+$ ( let sec = mkLayoutSection (count + 1) - (lbl',sec') = if not (null info) - then (entryLblToInfoLbl lbl, sec) - else (lbl, Nothing) + (lbl',sec') = case mb_info of + Nothing -> (entry_lbl, Nothing) + Just (Statics info_lbl _) -> (info_lbl, sec) link = if externallyVisibleCLabel lbl' then ExternallyVisible else Internal @@ -103,14 +103,14 @@ pprLlvmCmmTop env count (CmmProc info lbl (ListGraph blks)) -- | Pretty print CmmStatic -pprInfoTable :: LlvmEnv -> Int -> CLabel -> [CmmStatic] -> (Doc, [LlvmVar]) -pprInfoTable env count lbl stat +pprInfoTable :: LlvmEnv -> Int -> CLabel -> CmmStatics -> (Doc, [LlvmVar]) +pprInfoTable env count info_lbl stat = let unres = genLlvmData (Text, stat) (_, (ldata, ltypes)) = resolveLlvmData env unres setSection ((LMGlobalVar _ ty l _ _ c), d) = let sec = mkLayoutSection count - ilabel = strCLabel_llvm (entryLblToInfoLbl lbl) + ilabel = strCLabel_llvm info_lbl `appendFS` fsLit iTableSuf gv = LMGlobalVar ilabel ty l sec llvmInfAlign c v = if l == Internal then [gv] else [] diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index b58b7cd395..3ff35b6b92 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -61,7 +61,7 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC do { when (dopt Opt_DoCmmLinting dflags) $ do { showPass dflags "CmmLint" - ; let lints = map cmmLint flat_abstractC + ; let lints = map (cmmLint (targetPlatform dflags)) flat_abstractC ; case firstJusts lints of Just err -> do { printDump err ; ghcExit dflags 1 diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index aa987d7327..746ea88979 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -1454,7 +1454,7 @@ mkExtraObjToLinkIntoBinary dflags dep_packages = do escape = concatMap (charToC.fromIntegral.ord) elfSectionNote :: String - elfSectionNote = case platformArch defaultTargetPlatform of + elfSectionNote = case platformArch (targetPlatform dflags) of ArchX86 -> "@note" ArchX86_64 -> "@note" ArchPPC -> "@note" @@ -1581,12 +1581,12 @@ linkBinary dflags o_files dep_packages = do pkg_lib_paths <- getPackageLibraryPath dflags dep_packages let pkg_lib_path_opts = concat (map get_pkg_lib_path_opts pkg_lib_paths) -#ifdef elf_OBJ_FORMAT - get_pkg_lib_path_opts l | (dynLibLoader dflags)==SystemDependent && not opt_Static = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l] - | otherwise = ["-L" ++ l] -#else - get_pkg_lib_path_opts l = ["-L" ++ l] -#endif + get_pkg_lib_path_opts l + | osElfTarget (platformOS (targetPlatform dflags)) && + dynLibLoader dflags == SystemDependent && + not opt_Static + = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l] + | otherwise = ["-L" ++ l] let lib_paths = libraryPaths dflags let lib_path_opts = map ("-L"++) lib_paths @@ -1706,58 +1706,55 @@ maybeCreateManifest :: DynFlags -> FilePath -- filename of executable -> IO [FilePath] -- extra objects to embed, maybe -#ifndef mingw32_TARGET_OS -maybeCreateManifest _ _ = do - return [] -#else -maybeCreateManifest dflags exe_filename = do - if not (dopt Opt_GenManifest dflags) then return [] else do - - let manifest_filename = exe_filename <.> "manifest" - - writeFile manifest_filename $ - "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++ - " <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++ - " <assemblyIdentity version=\"1.0.0.0\"\n"++ - " processorArchitecture=\"X86\"\n"++ - " name=\"" ++ dropExtension exe_filename ++ "\"\n"++ - " type=\"win32\"/>\n\n"++ - " <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++ - " <security>\n"++ - " <requestedPrivileges>\n"++ - " <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++ - " </requestedPrivileges>\n"++ - " </security>\n"++ - " </trustInfo>\n"++ - "</assembly>\n" - - -- Windows will find the manifest file if it is named foo.exe.manifest. - -- However, for extra robustness, and so that we can move the binary around, - -- we can embed the manifest in the binary itself using windres: - if not (dopt Opt_EmbedManifest dflags) then return [] else do - - rc_filename <- newTempName dflags "rc" - rc_obj_filename <- newTempName dflags (objectSuf dflags) - - writeFile rc_filename $ - "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n" - -- magic numbers :-) - -- show is a bit hackish above, but we need to escape the - -- backslashes in the path. - - let wr_opts = getOpts dflags opt_windres - runWindres dflags $ map SysTools.Option $ - ["--input="++rc_filename, - "--output="++rc_obj_filename, - "--output-format=coff"] - ++ wr_opts - -- no FileOptions here: windres doesn't like seeing - -- backslashes, apparently - - removeFile manifest_filename - - return [rc_obj_filename] -#endif +maybeCreateManifest dflags exe_filename + | platformOS (targetPlatform dflags) == OSMinGW32 && + dopt Opt_GenManifest dflags + = do let manifest_filename = exe_filename <.> "manifest" + + writeFile manifest_filename $ + "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++ + " <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++ + " <assemblyIdentity version=\"1.0.0.0\"\n"++ + " processorArchitecture=\"X86\"\n"++ + " name=\"" ++ dropExtension exe_filename ++ "\"\n"++ + " type=\"win32\"/>\n\n"++ + " <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++ + " <security>\n"++ + " <requestedPrivileges>\n"++ + " <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++ + " </requestedPrivileges>\n"++ + " </security>\n"++ + " </trustInfo>\n"++ + "</assembly>\n" + + -- Windows will find the manifest file if it is named + -- foo.exe.manifest. However, for extra robustness, and so that + -- we can move the binary around, we can embed the manifest in + -- the binary itself using windres: + if not (dopt Opt_EmbedManifest dflags) then return [] else do + + rc_filename <- newTempName dflags "rc" + rc_obj_filename <- newTempName dflags (objectSuf dflags) + + writeFile rc_filename $ + "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n" + -- magic numbers :-) + -- show is a bit hackish above, but we need to escape the + -- backslashes in the path. + + let wr_opts = getOpts dflags opt_windres + runWindres dflags $ map SysTools.Option $ + ["--input="++rc_filename, + "--output="++rc_obj_filename, + "--output-format=coff"] + ++ wr_opts + -- no FileOptions here: windres doesn't like seeing + -- backslashes, apparently + + removeFile manifest_filename + + return [rc_obj_filename] + | otherwise = return [] linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO () @@ -1769,12 +1766,12 @@ linkDynLib dflags o_files dep_packages = do let pkg_lib_paths = collectLibraryPaths pkgs let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths -#ifdef elf_OBJ_FORMAT - get_pkg_lib_path_opts l | (dynLibLoader dflags)==SystemDependent && not opt_Static = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l] - | otherwise = ["-L" ++ l] -#else - get_pkg_lib_path_opts l = ["-L" ++ l] -#endif + get_pkg_lib_path_opts l + | osElfTarget (platformOS (targetPlatform dflags)) && + dynLibLoader dflags == SystemDependent && + not opt_Static + = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l] + | otherwise = ["-L" ++ l] let lib_paths = libraryPaths dflags let lib_path_opts = map ("-L"++) lib_paths @@ -1786,11 +1783,11 @@ linkDynLib dflags o_files dep_packages = do -- not allow undefined symbols. -- The RTS library path is still added to the library search path -- above in case the RTS is being explicitly linked in (see #3807). -#if !defined(mingw32_HOST_OS) - let pkgs_no_rts = filter ((/= rtsPackageId) . packageConfigId) pkgs -#else - let pkgs_no_rts = pkgs -#endif + let pkgs_no_rts = case platformOS (targetPlatform dflags) of + OSMinGW32 -> + pkgs + _ -> + filter ((/= rtsPackageId) . packageConfigId) pkgs let pkg_link_opts = collectLinkOpts dflags pkgs_no_rts -- probably _stub.o files @@ -1983,7 +1980,15 @@ joinObjectFiles dflags o_files output_fn = do let ld_r args = SysTools.runLink dflags ([ SysTools.Option "-nostdlib", SysTools.Option "-nodefaultlibs", - SysTools.Option "-Wl,-r", + SysTools.Option "-Wl,-r" + ] + -- gcc on sparc sets -Wl,--relax implicitly, but + -- -r and --relax are incompatible for ld, so + -- disable --relax explicitly. + ++ (if platformArch (targetPlatform dflags) == ArchSPARC + then [SysTools.Option "-Wl,-no-relax"] + else []) + ++ [ SysTools.Option ld_build_id, SysTools.Option ld_x_flag, SysTools.Option "-o", diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 144d6d1fbe..68410cdb64 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -12,11 +12,16 @@ module DynFlags ( -- * Dynamic flags and associated configuration types DynFlag(..), + WarningFlag(..), ExtensionFlag(..), + LogAction, glasgowExtsFlags, dopt, dopt_set, dopt_unset, + wopt, + wopt_set, + wopt_unset, xopt, xopt_set, xopt_unset, @@ -28,7 +33,7 @@ module DynFlags ( PackageFlag(..), Option(..), showOpt, DynLibLoader(..), - fFlags, fLangFlags, xFlags, + fFlags, fWarningFlags, fLangFlags, xFlags, DPHBackend(..), dphPackageMaybe, wayNames, dynFlagDependencies, @@ -43,13 +48,14 @@ module DynFlags ( extraGccViaCFlags, systemPackageConfig, pgm_L, pgm_P, pgm_F, pgm_c, pgm_s, pgm_a, pgm_l, pgm_dll, pgm_T, pgm_sysman, pgm_windres, pgm_lo, pgm_lc, - opt_L, opt_P, opt_F, opt_c, opt_m, opt_a, opt_l, + opt_L, opt_P, opt_F, opt_c, opt_a, opt_l, opt_windres, opt_lo, opt_lc, -- ** Manipulating DynFlags defaultDynFlags, -- Settings -> DynFlags initDynFlags, -- DynFlags -> IO DynFlags + defaultLogAction, getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] getVerbFlags, @@ -212,38 +218,6 @@ data DynFlag | Opt_DoAsmLinting | Opt_WarnIsError -- -Werror; makes warnings fatal - | Opt_WarnDuplicateExports - | Opt_WarnHiShadows - | Opt_WarnImplicitPrelude - | Opt_WarnIncompletePatterns - | Opt_WarnIncompleteUniPatterns - | Opt_WarnIncompletePatternsRecUpd - | Opt_WarnMissingFields - | Opt_WarnMissingImportList - | Opt_WarnMissingMethods - | Opt_WarnMissingSigs - | Opt_WarnMissingLocalSigs - | Opt_WarnNameShadowing - | Opt_WarnOverlappingPatterns - | Opt_WarnTypeDefaults - | Opt_WarnMonomorphism - | Opt_WarnUnusedBinds - | Opt_WarnUnusedImports - | Opt_WarnUnusedMatches - | Opt_WarnWarningsDeprecations - | Opt_WarnDeprecatedFlags - | Opt_WarnDodgyExports - | Opt_WarnDodgyImports - | Opt_WarnOrphans - | Opt_WarnAutoOrphans - | Opt_WarnIdentities - | Opt_WarnTabs - | Opt_WarnUnrecognisedPragmas - | Opt_WarnDodgyForeignImports - | Opt_WarnLazyUnliftedBindings - | Opt_WarnUnusedDoBind - | Opt_WarnWrongDoBind - | Opt_WarnAlternativeLayoutRuleTransitional | Opt_PrintExplicitForalls @@ -261,7 +235,6 @@ data DynFlag | Opt_DoEtaReduction | Opt_CaseMerge | Opt_UnboxStrictFields - | Opt_MethodSharing -- Now a no-op; remove in GHC 7.2 | Opt_DictsCheap | Opt_EnableRewriteRules -- Apply rewrite rules during simplification | Opt_Vectorise @@ -324,24 +297,55 @@ data DynFlag deriving (Eq, Show) +data WarningFlag = + Opt_WarnDuplicateExports + | Opt_WarnHiShadows + | Opt_WarnImplicitPrelude + | Opt_WarnIncompletePatterns + | Opt_WarnIncompleteUniPatterns + | Opt_WarnIncompletePatternsRecUpd + | Opt_WarnMissingFields + | Opt_WarnMissingImportList + | Opt_WarnMissingMethods + | Opt_WarnMissingSigs + | Opt_WarnMissingLocalSigs + | Opt_WarnNameShadowing + | Opt_WarnOverlappingPatterns + | Opt_WarnTypeDefaults + | Opt_WarnMonomorphism + | Opt_WarnUnusedBinds + | Opt_WarnUnusedImports + | Opt_WarnUnusedMatches + | Opt_WarnWarningsDeprecations + | Opt_WarnDeprecatedFlags + | Opt_WarnDodgyExports + | Opt_WarnDodgyImports + | Opt_WarnOrphans + | Opt_WarnAutoOrphans + | Opt_WarnIdentities + | Opt_WarnTabs + | Opt_WarnUnrecognisedPragmas + | Opt_WarnDodgyForeignImports + | Opt_WarnLazyUnliftedBindings + | Opt_WarnUnusedDoBind + | Opt_WarnWrongDoBind + | Opt_WarnAlternativeLayoutRuleTransitional + deriving (Eq, Show) + data Language = Haskell98 | Haskell2010 -- | The various Safe Haskell modes data SafeHaskellMode = Sf_None | Sf_SafeImports - | Sf_SafeLanguage | Sf_Trustworthy - | Sf_TrustworthyWithSafeLanguage | Sf_Safe deriving (Eq) instance Outputable SafeHaskellMode where ppr Sf_None = ptext $ sLit "None" ppr Sf_SafeImports = ptext $ sLit "SafeImports" - ppr Sf_SafeLanguage = ptext $ sLit "SafeLanguage" ppr Sf_Trustworthy = ptext $ sLit "Trustworthy" - ppr Sf_TrustworthyWithSafeLanguage = ptext $ sLit "Trustworthy + SafeLanguage" ppr Sf_Safe = ptext $ sLit "Safe" data ExtensionFlag @@ -356,6 +360,7 @@ data ExtensionFlag | Opt_ExtendedDefaultRules -- Use GHC's extended rules for defaulting | Opt_ForeignFunctionInterface | Opt_UnliftedFFITypes + | Opt_InterruptibleFFI | Opt_GHCForeignImportPrim | Opt_ParallelArrays -- Syntactic support for parallel arrays | Opt_Arrows -- Arrow-notation syntax @@ -385,7 +390,6 @@ data ExtensionFlag | Opt_DeriveFoldable | Opt_DeriveGeneric -- Allow deriving Generic/1 | Opt_DefaultSignatures -- Allow extra signatures for defmeths - | Opt_Generics -- Old generic classes, now deprecated | Opt_TypeSynonymInstances | Opt_FlexibleContexts @@ -534,6 +538,7 @@ data DynFlags = DynFlags { -- hsc dynamic flags flags :: [DynFlag], + warningFlags :: [WarningFlag], -- Don't change this without updating extensionFlags: language :: Maybe Language, -- | Safe Haskell mode @@ -545,7 +550,7 @@ data DynFlags = DynFlags { extensionFlags :: [ExtensionFlag], -- | Message output action: use "ErrUtils" instead of this if you can - log_action :: Severity -> SrcSpan -> PprStyle -> Message -> IO (), + log_action :: LogAction, haddockOptions :: Maybe String } @@ -579,7 +584,6 @@ data Settings = Settings { sOpt_P :: [String], sOpt_F :: [String], sOpt_c :: [String], - sOpt_m :: [String], sOpt_a :: [String], sOpt_l :: [String], sOpt_windres :: [String], @@ -636,8 +640,6 @@ opt_F :: DynFlags -> [String] opt_F dflags = sOpt_F (settings dflags) opt_c :: DynFlags -> [String] opt_c dflags = sOpt_c (settings dflags) -opt_m :: DynFlags -> [String] -opt_m dflags = sOpt_m (settings dflags) opt_a :: DynFlags -> [String] opt_a dflags = sOpt_a (settings dflags) opt_l :: DynFlags -> [String] @@ -859,24 +861,28 @@ defaultDynFlags mySettings = generatedDumps = panic "defaultDynFlags: No generatedDumps", haddockOptions = Nothing, flags = defaultFlags, + warningFlags = standardWarnings, language = Nothing, safeHaskell = Sf_None, extensions = [], extensionFlags = flattenExtensionFlags Nothing [], - - log_action = \severity srcSpan style msg -> - case severity of - SevOutput -> printSDoc msg style - SevInfo -> printErrs msg style - SevFatal -> printErrs msg style - _ -> do - hPutChar stderr '\n' - printErrs (mkLocMessage srcSpan msg) style - -- careful (#2302): printErrs prints in UTF-8, whereas - -- converting to string first and using hPutStr would - -- just emit the low 8 bits of each unicode char. + log_action = defaultLogAction } +type LogAction = Severity -> SrcSpan -> PprStyle -> Message -> IO () + +defaultLogAction :: LogAction +defaultLogAction severity srcSpan style msg + = case severity of + SevOutput -> printSDoc msg style + SevInfo -> printErrs msg style + SevFatal -> printErrs msg style + _ -> do hPutChar stderr '\n' + printErrs (mkLocMessage srcSpan msg) style + -- careful (#2302): printErrs prints in UTF-8, whereas + -- converting to string first and using hPutStr would + -- just emit the low 8 bits of each unicode char. + {- Note [Verbosity levels] ~~~~~~~~~~~~~~~~~~~~~~~ @@ -952,6 +958,18 @@ dopt_set dfs f = dfs{ flags = f : flags dfs } dopt_unset :: DynFlags -> DynFlag -> DynFlags dopt_unset dfs f = dfs{ flags = filter (/= f) (flags dfs) } +-- | Test whether a 'WarningFlag' is set +wopt :: WarningFlag -> DynFlags -> Bool +wopt f dflags = f `elem` (warningFlags dflags) + +-- | Set a 'WarningFlag' +wopt_set :: DynFlags -> WarningFlag -> DynFlags +wopt_set dfs f = dfs{ warningFlags = f : warningFlags dfs } + +-- | Unset a 'WarningFlag' +wopt_unset :: DynFlags -> WarningFlag -> DynFlags +wopt_unset dfs f = dfs{ warningFlags = filter (/= f) (warningFlags dfs) } + -- | Test whether a 'ExtensionFlag' is set xopt :: ExtensionFlag -> DynFlags -> Bool xopt f dflags = f `elem` extensionFlags dflags @@ -986,10 +1004,7 @@ dynFlagDependencies = pluginModNames -- | Is the Safe Haskell safe language in use safeLanguageOn :: DynFlags -> Bool -safeLanguageOn dflags = s == Sf_SafeLanguage - || s == Sf_TrustworthyWithSafeLanguage - || s == Sf_Safe - where s = safeHaskell dflags +safeLanguageOn dflags = safeHaskell dflags == Sf_Safe -- | Test if Safe Haskell is on in some form safeHaskellOn :: DynFlags -> Bool @@ -1026,17 +1041,6 @@ combineSafeFlags a b = (Sf_SafeImports, sf) -> return sf (sf, Sf_SafeImports) -> return sf - (Sf_SafeLanguage, Sf_Safe) -> err - (Sf_Safe, Sf_SafeLanguage) -> err - - (Sf_SafeLanguage, Sf_Trustworthy) -> return Sf_TrustworthyWithSafeLanguage - (Sf_Trustworthy, Sf_SafeLanguage) -> return Sf_TrustworthyWithSafeLanguage - - (Sf_TrustworthyWithSafeLanguage, Sf_Trustworthy) -> return Sf_TrustworthyWithSafeLanguage - (Sf_TrustworthyWithSafeLanguage, Sf_SafeLanguage) -> return Sf_TrustworthyWithSafeLanguage - (Sf_Trustworthy, Sf_TrustworthyWithSafeLanguage) -> return Sf_TrustworthyWithSafeLanguage - (Sf_SafeLanguage, Sf_TrustworthyWithSafeLanguage) -> return Sf_TrustworthyWithSafeLanguage - (Sf_Trustworthy, Sf_Safe) -> err (Sf_Safe, Sf_Trustworthy) -> err @@ -1289,14 +1293,15 @@ shFlagsDisallowed dflags = foldl check_method (dflags, []) bad_flags allFlags :: [String] allFlags = map ('-':) $ [ flagName flag | flag <- dynamic_flags, ok (flagOptKind flag) ] ++ - map ("fno-"++) flags ++ - map ("f"++) flags ++ - map ("f"++) flags' ++ + map ("fno-"++) fflags ++ + map ("f"++) fflags ++ map ("X"++) supportedExtensions where ok (PrefixPred _ _) = False ok _ = True - flags = [ name | (name, _, _, _) <- fFlags ] - flags' = [ name | (name, _, _, _) <- fLangFlags ] + fflags = fflags0 ++ fflags1 ++ fflags2 + fflags0 = [ name | (name, _, _, _) <- fFlags ] + fflags1 = [ name | (name, _, _, _) <- fWarningFlags ] + fflags2 = [ name | (name, _, _, _) <- fLangFlags ] --------------- The main flags themselves ------------------ dynamic_flags :: [Flag (CmdLineP DynFlags)] @@ -1317,7 +1322,7 @@ dynamic_flags = [ , flagA "pgmP" (hasArg setPgmP) , flagA "pgmF" (hasArg (\f -> alterSettings (\s -> s { sPgm_F = f}))) , flagA "pgmc" (hasArg (\f -> alterSettings (\s -> s { sPgm_c = (f,[])}))) - , flagA "pgmm" (HasArg (\_ -> addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release")) + , flagA "pgmm" (HasArg (\_ -> addWarn "The -pgmm flag does nothing; it will be removed in a future GHC release")) , flagA "pgms" (hasArg (\f -> alterSettings (\s -> s { sPgm_s = (f,[])}))) , flagA "pgma" (hasArg (\f -> alterSettings (\s -> s { sPgm_a = (f,[])}))) , flagA "pgml" (hasArg (\f -> alterSettings (\s -> s { sPgm_l = (f,[])}))) @@ -1331,7 +1336,7 @@ dynamic_flags = [ , flagA "optP" (hasArg addOptP) , flagA "optF" (hasArg (\f -> alterSettings (\s -> s { sOpt_F = f : sOpt_F s}))) , flagA "optc" (hasArg (\f -> alterSettings (\s -> s { sOpt_c = f : sOpt_c s}))) - , flagA "optm" (hasArg (\f -> alterSettings (\s -> s { sOpt_m = f : sOpt_m s}))) + , flagA "optm" (HasArg (\_ -> addWarn "The -optm flag does nothing; it will be removed in a future GHC release")) , flagA "opta" (hasArg (\f -> alterSettings (\s -> s { sOpt_a = f : sOpt_a s}))) , flagA "optl" (hasArg addOptl) , flagA "optwindres" (hasArg (\f -> alterSettings (\s -> s { sOpt_windres = f : sOpt_windres s}))) @@ -1519,17 +1524,17 @@ dynamic_flags = [ , flagA "msse2" (NoArg (setDynFlag Opt_SSE2)) ------ Warning opts ------------------------------------------------- - , flagA "W" (NoArg (mapM_ setDynFlag minusWOpts)) - , flagA "Werror" (NoArg (setDynFlag Opt_WarnIsError)) - , flagA "Wwarn" (NoArg (unSetDynFlag Opt_WarnIsError)) - , flagA "Wall" (NoArg (mapM_ setDynFlag minusWallOpts)) - , flagA "Wnot" (NoArg (do { mapM_ unSetDynFlag minusWallOpts - ; deprecate "Use -w instead" })) - , flagA "w" (NoArg (mapM_ unSetDynFlag minuswRemovesOpts)) - + , flagA "W" (NoArg (mapM_ setWarningFlag minusWOpts)) + , flagA "Werror" (NoArg (setDynFlag Opt_WarnIsError)) + , flagA "Wwarn" (NoArg (unSetDynFlag Opt_WarnIsError)) + , flagA "Wall" (NoArg (mapM_ setWarningFlag minusWallOpts)) + , flagA "Wnot" (NoArg (do upd (\dfs -> dfs {warningFlags = []}) + deprecate "Use -w instead")) + , flagA "w" (NoArg (upd (\dfs -> dfs {warningFlags = []}))) + ------ Plugin flags ------------------------------------------------ - , flagA "fplugin" (sepArg addPluginModuleName) - , flagA "fplugin-opt" (sepArg addPluginModuleNameOption) + , flagA "fplugin-opt" (hasArg addPluginModuleNameOption) + , flagA "fplugin" (hasArg addPluginModuleName) ------ Optimisation flags ------------------------------------------ , flagA "O" (noArgM (setOptLevel 1)) @@ -1592,12 +1597,16 @@ dynamic_flags = [ ] ++ map (mkFlag turnOn "f" setDynFlag ) fFlags ++ map (mkFlag turnOff "fno-" unSetDynFlag) fFlags + ++ map (mkFlag turnOn "f" setWarningFlag ) fWarningFlags + ++ map (mkFlag turnOff "fno-" unSetWarningFlag) fWarningFlags ++ map (mkFlag turnOn "f" setExtensionFlag ) fLangFlags ++ map (mkFlag turnOff "fno-" unSetExtensionFlag) fLangFlags ++ map (mkFlag turnOn "X" setExtensionFlag ) xFlags ++ map (mkFlag turnOff "XNo" unSetExtensionFlag) xFlags ++ map (mkFlag turnOn "X" setLanguage) languageFlags ++ map (mkFlag turnOn "X" setSafeHaskell) safeHaskellFlags + ++ [ flagA "XGenerics" (NoArg (deprecate "it does nothing; look into -XDefaultSignatures and -XDeriveGeneric for generic programming support.")) + , flagA "XNoGenerics" (NoArg (deprecate "it does nothing; look into -XDefaultSignatures and -XDeriveGeneric for generic programming support.")) ] package_flags :: [Flag (CmdLineP DynFlags)] package_flags = [ @@ -1656,8 +1665,8 @@ nop :: TurnOnFlag -> DynP () nop _ = return () -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ -fFlags :: [FlagSpec DynFlag] -fFlags = [ +fWarningFlags :: [FlagSpec WarningFlag] +fWarningFlags = [ ( "warn-dodgy-foreign-imports", AlwaysAllowed, Opt_WarnDodgyForeignImports, nop ), ( "warn-dodgy-exports", AlwaysAllowed, Opt_WarnDodgyExports, nop ), ( "warn-dodgy-imports", AlwaysAllowed, Opt_WarnDodgyImports, nop ), @@ -1690,7 +1699,11 @@ fFlags = [ ( "warn-lazy-unlifted-bindings", AlwaysAllowed, Opt_WarnLazyUnliftedBindings, nop), ( "warn-unused-do-bind", AlwaysAllowed, Opt_WarnUnusedDoBind, nop ), ( "warn-wrong-do-bind", AlwaysAllowed, Opt_WarnWrongDoBind, nop ), - ( "warn-alternative-layout-rule-transitional", AlwaysAllowed, Opt_WarnAlternativeLayoutRuleTransitional, nop ), + ( "warn-alternative-layout-rule-transitional", AlwaysAllowed, Opt_WarnAlternativeLayoutRuleTransitional, nop )] + +-- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ +fFlags :: [FlagSpec DynFlag] +fFlags = [ ( "print-explicit-foralls", AlwaysAllowed, Opt_PrintExplicitForalls, nop ), ( "strictness", AlwaysAllowed, Opt_Strictness, nop ), ( "specialise", AlwaysAllowed, Opt_Specialise, nop ), @@ -1708,9 +1721,6 @@ fFlags = [ ( "do-eta-reduction", AlwaysAllowed, Opt_DoEtaReduction, nop ), ( "case-merge", AlwaysAllowed, Opt_CaseMerge, nop ), ( "unbox-strict-fields", AlwaysAllowed, Opt_UnboxStrictFields, nop ), - ( "method-sharing", AlwaysAllowed, Opt_MethodSharing, - \_ -> deprecate "doesn't do anything any more"), - -- Remove altogether in GHC 7.2 ( "dicts-cheap", AlwaysAllowed, Opt_DictsCheap, nop ), ( "excess-precision", AlwaysAllowed, Opt_ExcessPrecision, nop ), ( "eager-blackholing", AlwaysAllowed, Opt_EagerBlackHoling, nop ), @@ -1751,8 +1761,6 @@ fLangFlags = [ deprecatedForExtension "ForeignFunctionInterface" ), ( "arrows", AlwaysAllowed, Opt_Arrows, deprecatedForExtension "Arrows" ), - ( "generics", AlwaysAllowed, Opt_Generics, - deprecatedForExtension "Generics" ), ( "implicit-prelude", AlwaysAllowed, Opt_ImplicitPrelude, deprecatedForExtension "ImplicitPrelude" ), ( "bang-patterns", AlwaysAllowed, Opt_BangPatterns, @@ -1803,8 +1811,7 @@ languageFlags = [ -- They are used to place hard requirements on what GHC Haskell language -- features can be used. safeHaskellFlags :: [FlagSpec SafeHaskellMode] -safeHaskellFlags = [mkF Sf_SafeImports, mkF' Sf_SafeLanguage, - mkF Sf_Trustworthy, mkF' Sf_Safe] +safeHaskellFlags = [mkF Sf_SafeImports, mkF Sf_Trustworthy, mkF' Sf_Safe] where mkF flag = (showPpr flag, AlwaysAllowed, flag, nop) mkF' flag = (showPpr flag, EnablesSafe, flag, nop) @@ -1826,6 +1833,7 @@ xFlags = [ ( "MonadComprehensions", AlwaysAllowed, Opt_MonadComprehensions, nop), ( "ForeignFunctionInterface", RestrictedFunction, Opt_ForeignFunctionInterface, nop ), ( "UnliftedFFITypes", AlwaysAllowed, Opt_UnliftedFFITypes, nop ), + ( "InterruptibleFFI", AlwaysAllowed, Opt_InterruptibleFFI, nop ), ( "GHCForeignImportPrim", AlwaysAllowed, Opt_GHCForeignImportPrim, nop ), ( "LiberalTypeSynonyms", AlwaysAllowed, Opt_LiberalTypeSynonyms, nop ), ( "Rank2Types", AlwaysAllowed, Opt_Rank2Types, nop ), @@ -1839,8 +1847,6 @@ xFlags = [ ( "ParallelArrays", AlwaysAllowed, Opt_ParallelArrays, nop ), ( "TemplateHaskell", NeverAllowed, Opt_TemplateHaskell, checkTemplateHaskellOk ), ( "QuasiQuotes", AlwaysAllowed, Opt_QuasiQuotes, nop ), - ( "Generics", AlwaysAllowed, Opt_Generics, - \ _ -> deprecate "it does nothing; look into -XDefaultSignatures and -XDeriveGeneric for generic programming support." ), ( "ImplicitPrelude", AlwaysAllowed, Opt_ImplicitPrelude, nop ), ( "RecordWildCards", AlwaysAllowed, Opt_RecordWildCards, nop ), ( "NamedFieldPuns", AlwaysAllowed, Opt_RecordPuns, nop ), @@ -1919,8 +1925,6 @@ defaultFlags ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns] -- The default -O0 options - ++ standardWarnings - impliedFlags :: [(ExtensionFlag, TurnOnFlag, ExtensionFlag)] impliedFlags = [ (Opt_RankNTypes, turnOn, Opt_ExplicitForAll) @@ -1992,7 +1996,7 @@ optLevelFlags -- ----------------------------------------------------------------------------- -- Standard sets of warning options -standardWarnings :: [DynFlag] +standardWarnings :: [WarningFlag] standardWarnings = [ Opt_WarnWarningsDeprecations, Opt_WarnDeprecatedFlags, @@ -2007,7 +2011,7 @@ standardWarnings Opt_WarnAlternativeLayoutRuleTransitional ] -minusWOpts :: [DynFlag] +minusWOpts :: [WarningFlag] -- Things you get with -W minusWOpts = standardWarnings ++ @@ -2019,7 +2023,7 @@ minusWOpts Opt_WarnDodgyImports ] -minusWallOpts :: [DynFlag] +minusWallOpts :: [WarningFlag] -- Things you get with -Wall minusWallOpts = minusWOpts ++ @@ -2031,19 +2035,6 @@ minusWallOpts Opt_WarnUnusedDoBind ] -minuswRemovesOpts :: [DynFlag] --- minuswRemovesOpts should be every warning option -minuswRemovesOpts - = minusWallOpts ++ - [Opt_WarnTabs, - Opt_WarnIncompletePatternsRecUpd, - Opt_WarnIncompleteUniPatterns, - Opt_WarnMonomorphism, - Opt_WarnUnrecognisedPragmas, - Opt_WarnAutoOrphans, - Opt_WarnImplicitPrelude - ] - enableGlasgowExts :: DynP () enableGlasgowExts = do setDynFlag Opt_PrintExplicitForalls mapM_ setExtensionFlag glasgowExtsFlags @@ -2162,6 +2153,11 @@ setDynFlag f = upd (\dfs -> dopt_set dfs f) unSetDynFlag f = upd (\dfs -> dopt_unset dfs f) -------------------------- +setWarningFlag, unSetWarningFlag :: WarningFlag -> DynP () +setWarningFlag f = upd (\dfs -> wopt_set dfs f) +unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f) + +-------------------------- setExtensionFlag, unSetExtensionFlag :: ExtensionFlag -> DynP () setExtensionFlag f = do { upd (\dfs -> xopt_set dfs f) ; sequence_ deps } diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index a0a9f0e3b3..60e1376420 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -24,7 +24,7 @@ module ErrUtils ( -- * Messages during compilation putMsg, putMsgWith, errorMsg, - fatalErrorMsg, + fatalErrorMsg, fatalErrorMsg', compilationProgressMsg, showPass, debugTraceMsg, @@ -36,7 +36,7 @@ import Bag ( Bag, bagToList, isEmptyBag, emptyBag ) import Util ( sortLe ) import Outputable import SrcLoc -import DynFlags ( DynFlags(..), DynFlag(..), dopt ) +import DynFlags import StaticFlags ( opt_ErrorSpans ) import System.Exit ( ExitCode(..), exitWith ) @@ -296,7 +296,10 @@ errorMsg :: DynFlags -> Message -> IO () errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg fatalErrorMsg :: DynFlags -> Message -> IO () -fatalErrorMsg dflags msg = log_action dflags SevFatal noSrcSpan defaultErrStyle msg +fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) msg + +fatalErrorMsg' :: LogAction -> Message -> IO () +fatalErrorMsg' la msg = la SevFatal noSrcSpan defaultErrStyle msg compilationProgressMsg :: DynFlags -> String -> IO () compilationProgressMsg dflags msg diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 8f5c894ac2..b73df73fc1 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -319,23 +319,23 @@ import Prelude hiding (init) -- Unless you want to handle exceptions yourself, you should wrap this around -- the top level of your program. The default handlers output the error -- message(s) to stderr and exit cleanly. -defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => DynFlags -> m a -> m a -defaultErrorHandler dflags inner = +defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => LogAction -> m a -> m a +defaultErrorHandler la inner = -- top-level exception handler: any unrecognised exception is a compiler bug. ghandle (\exception -> liftIO $ do hFlush stdout case fromException exception of -- an IO exception probably isn't our fault, so don't panic Just (ioe :: IOException) -> - fatalErrorMsg dflags (text (show ioe)) + fatalErrorMsg' la (text (show ioe)) _ -> case fromException exception of Just UserInterrupt -> exitWith (ExitFailure 1) Just StackOverflow -> - fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it") + fatalErrorMsg' la (text "stack overflow: use +RTS -K<size> to increase it") _ -> case fromException exception of Just (ex :: ExitCode) -> throw ex _ -> - fatalErrorMsg dflags + fatalErrorMsg' la (text (show (Panic (show exception)))) exitWith (ExitFailure 1) ) $ @@ -347,7 +347,7 @@ defaultErrorHandler dflags inner = case ge of PhaseFailed _ code -> exitWith code Signal _ -> exitWith (ExitFailure 1) - _ -> do fatalErrorMsg dflags (text (show ge)) + _ -> do fatalErrorMsg' la (text (show ge)) exitWith (ExitFailure 1) ) $ inner diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 17bd230421..266395d0b1 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -925,8 +925,7 @@ checkSafeImports dflags hsc_env tcg_env let trust = getSafeMode $ mi_trust iface' trust_own_pkg = mi_trust_pkg iface' -- check module is trusted - safeM = trust `elem` [Sf_Safe, Sf_Trustworthy, - Sf_TrustworthyWithSafeLanguage] + safeM = trust `elem` [Sf_Safe, Sf_Trustworthy] -- check package is trusted safeP = packageTrusted trust trust_own_pkg m if safeM && safeP @@ -1055,6 +1054,7 @@ hscGenHardCode cgguts mod_summary cg_dep_pkgs = dependencies, cg_hpc_info = hpc_info } = cgguts dflags = hsc_dflags hsc_env + platform = targetPlatform dflags location = ms_location mod_summary data_tycons = filter isDataTyCon tycons -- cg_tycons includes newtypes, for the benefit of External Core, @@ -1090,7 +1090,7 @@ hscGenHardCode cgguts mod_summary -- unless certain dflags are on, the identity function ------------------ Code output ----------------------- rawcmms <- cmmToRawCmm cmms - dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" (ppr rawcmms) + dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" (pprPlatform platform rawcmms) (_stub_h_exists, stub_c_exists) <- codeOutput dflags this_mod location foreign_stubs dependencies rawcmms @@ -1161,10 +1161,11 @@ tryNewCodeGen :: HscEnv -> Module -> [TyCon] tryNewCodeGen hsc_env this_mod data_tycons cost_centre_info stg_binds hpc_info = do { let dflags = hsc_dflags hsc_env + platform = targetPlatform dflags ; prog <- StgCmm.codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen" - (pprCmms prog) + (pprCmms platform prog) -- We are building a single SRT for the entire module, so -- we must thread it through all the procedures as we cps-convert them. @@ -1173,7 +1174,7 @@ tryNewCodeGen hsc_env this_mod data_tycons ; (topSRT, prog) <- foldM (cmmPipeline hsc_env) (initTopSRT, []) prog ; let prog' = map cmmOfZgraph (srtToData topSRT : prog) - ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog') + ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (pprPlatform platform prog') ; return prog' } @@ -1190,11 +1191,12 @@ optionallyConvertAndOrCPS hsc_env cmms = testCmmConversion :: HscEnv -> Cmm -> IO Cmm testCmmConversion hsc_env cmm = do let dflags = hsc_dflags hsc_env + platform = targetPlatform dflags showPass dflags "CmmToCmm" - dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm) + dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (pprPlatform platform cmm) --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm us <- mkSplitUniqSupply 'C' - let zgraph = initUs_ us (cmmToZgraph cmm) + let zgraph = initUs_ us (cmmToZgraph platform cmm) chosen_graph <- if dopt Opt_RunCPSZ dflags then do us <- mkSplitUniqSupply 'S' @@ -1202,10 +1204,10 @@ testCmmConversion hsc_env cmm = (_, [zgraph]) <- cmmPipeline hsc_env (topSRT, []) zgraph return zgraph else return (runCmmContFlowOpts zgraph) - dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph) + dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (pprPlatform platform chosen_graph) showPass dflags "Convert from Z back to Cmm" let cvt = cmmOfZgraph chosen_graph - dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt) + dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (pprPlatform platform cvt) return cvt myCoreToStg :: DynFlags -> Module -> [CoreBind] diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 7f43414111..f6494beff3 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -130,8 +130,7 @@ import TyCon import DataCon ( DataCon, dataConImplicitIds, dataConWrapId ) import PrelNames ( gHC_PRIM ) import Packages hiding ( Version(..) ) -import DynFlags ( DynFlags(..), isOneShot, HscTarget (..), dopt, - DynFlag(..), SafeHaskellMode(..), dynFlagDependencies ) +import DynFlags import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) import BasicTypes ( IPName, defaultFixity, WarningTxt(..) ) import OptimizationFuel ( OptFuelState ) @@ -147,8 +146,6 @@ import FastString import StringBuffer ( StringBuffer ) import Fingerprint import MonadUtils -import Data.Dynamic ( Typeable ) -import qualified Data.Dynamic as Dyn import Bag import ErrUtils @@ -161,6 +158,7 @@ import Data.Map (Map) import Data.Word import Control.Monad ( mplus, guard, liftM, when ) import Exception +import Data.Typeable ( Typeable ) -- ----------------------------------------------------------------------------- -- Source Errors @@ -191,18 +189,13 @@ throwOneError err = liftIO $ throwIO $ mkSrcErr $ unitBag err -- -- See 'printExceptionAndWarnings' for more information on what to take care -- of when writing a custom error handler. -data SourceError = SourceError ErrorMessages +newtype SourceError = SourceError ErrorMessages + deriving Typeable instance Show SourceError where show (SourceError msgs) = unlines . map show . bagToList $ msgs -- ToDo: is there some nicer way to print this? -sourceErrorTc :: Dyn.TyCon -sourceErrorTc = Dyn.mkTyCon "SourceError" -{-# NOINLINE sourceErrorTc #-} -instance Typeable SourceError where - typeOf _ = Dyn.mkTyConApp sourceErrorTc [] - instance Exception SourceError mkSrcErr = SourceError @@ -219,17 +212,12 @@ handleSourceError handler act = srcErrorMessages (SourceError msgs) = msgs -- | XXX: what exactly is an API error? -data GhcApiError = GhcApiError SDoc +newtype GhcApiError = GhcApiError SDoc + deriving Typeable instance Show GhcApiError where show (GhcApiError msg) = showSDoc msg -ghcApiErrorTc :: Dyn.TyCon -ghcApiErrorTc = Dyn.mkTyCon "GhcApiError" -{-# NOINLINE ghcApiErrorTc #-} -instance Typeable GhcApiError where - typeOf _ = Dyn.mkTyConApp ghcApiErrorTc [] - instance Exception GhcApiError mkApiErr = GhcApiError @@ -246,7 +234,7 @@ printOrThrowWarnings dflags warns handleFlagWarnings :: DynFlags -> [Located String] -> IO () handleFlagWarnings dflags warns - = when (dopt Opt_WarnDeprecatedFlags dflags) $ do + = when (wopt Opt_WarnDeprecatedFlags dflags) $ do -- It would be nicer if warns :: [Located Message], but that -- has circular import problems. let bag = listToBag [ mkPlainWarnMsg loc (text warn) @@ -1867,27 +1855,20 @@ trustInfoToNum it = case getSafeMode it of Sf_None -> 0 Sf_SafeImports -> 1 - Sf_SafeLanguage -> 2 - Sf_Trustworthy -> 3 - Sf_TrustworthyWithSafeLanguage -> 4 - Sf_Safe -> 5 + Sf_Trustworthy -> 2 + Sf_Safe -> 3 numToTrustInfo :: Word8 -> IfaceTrustInfo numToTrustInfo 0 = setSafeMode Sf_None numToTrustInfo 1 = setSafeMode Sf_SafeImports -numToTrustInfo 2 = setSafeMode Sf_SafeLanguage -numToTrustInfo 3 = setSafeMode Sf_Trustworthy -numToTrustInfo 4 = setSafeMode Sf_TrustworthyWithSafeLanguage -numToTrustInfo 5 = setSafeMode Sf_Safe +numToTrustInfo 2 = setSafeMode Sf_Trustworthy +numToTrustInfo 3 = setSafeMode Sf_Safe numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")" instance Outputable IfaceTrustInfo where ppr (TrustInfo Sf_None) = ptext $ sLit "none" ppr (TrustInfo Sf_SafeImports) = ptext $ sLit "safe-imports" - ppr (TrustInfo Sf_SafeLanguage) = ptext $ sLit "safe-language" ppr (TrustInfo Sf_Trustworthy) = ptext $ sLit "trustworthy" - ppr (TrustInfo Sf_TrustworthyWithSafeLanguage) - = ptext $ sLit "trustworthy + safe-language" ppr (TrustInfo Sf_Safe) = ptext $ sLit "safe" \end{code} diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 1df5255dbe..0386273de8 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -197,7 +197,7 @@ runStmtWithLocation source linenumber expr step = -- Turn off -fwarn-unused-bindings when running a statement, to hide -- warnings about the implicit bindings we introduce. - let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds + let dflags' = wopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds hsc_env' = hsc_env{ hsc_dflags = dflags' } r <- liftIO $ hscStmtWithLocation hsc_env' expr source linenumber diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index d8e63aba8c..c542d761f0 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -231,7 +231,7 @@ opt_SuppressIdInfo = lookUp (fsLit "-dsuppress-all") || lookUp (fsLit "-dsuppress-idinfo") --- | Suppress seprate type signatures in core, but leave types on lambda bound vars +-- | Suppress separate type signatures in core, but leave types on lambda bound vars opt_SuppressTypeSignatures :: Bool opt_SuppressTypeSignatures = lookUp (fsLit "-dsuppress-all") diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index cf91fb9ecd..ea11a20db8 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -269,7 +269,6 @@ initSysTools mbMinusB sOpt_F = [], sOpt_c = [], sOpt_a = [], - sOpt_m = [], sOpt_l = [], sOpt_windres = [], sOpt_lo = [], diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index ff18615b1a..94b0258f57 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -62,6 +62,7 @@ import DynFlags import StaticFlags import Util +import BasicTypes ( Alignment ) import Digraph import Pretty (Doc) import qualified Pretty @@ -131,31 +132,32 @@ The machine-dependent bits break down as follows: -- ----------------------------------------------------------------------------- -- Top-level of the native codegen -data NcgImpl instr jumpDest = NcgImpl { - cmmTopCodeGen :: RawCmmTop -> NatM [NatCmmTop instr], - generateJumpTableForInstr :: instr -> Maybe (NatCmmTop instr), +data NcgImpl statics instr jumpDest = NcgImpl { + cmmTopCodeGen :: RawCmmTop -> NatM [NatCmmTop statics instr], + generateJumpTableForInstr :: instr -> Maybe (NatCmmTop statics instr), getJumpDestBlockId :: jumpDest -> Maybe BlockId, canShortcut :: instr -> Maybe jumpDest, - shortcutStatic :: (BlockId -> Maybe jumpDest) -> CmmStatic -> CmmStatic, + shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics, shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr, - pprNatCmmTop :: NatCmmTop instr -> Doc, + pprNatCmmTop :: Platform -> NatCmmTop statics instr -> Doc, maxSpillSlots :: Int, allocatableRegs :: [RealReg], - ncg_x86fp_kludge :: [NatCmmTop instr] -> [NatCmmTop instr], - ncgExpandTop :: [NatCmmTop instr] -> [NatCmmTop instr], + ncg_x86fp_kludge :: [NatCmmTop statics instr] -> [NatCmmTop statics instr], + ncgExpandTop :: [NatCmmTop statics instr] -> [NatCmmTop statics instr], ncgMakeFarBranches :: [NatBasicBlock instr] -> [NatBasicBlock instr] } -------------------- nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO () nativeCodeGen dflags h us cmms - = let nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms + = let nCG' :: (Outputable statics, PlatformOutputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO () + nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms x86NcgImpl = NcgImpl { cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr ,getJumpDestBlockId = X86.Instr.getJumpDestBlockId ,canShortcut = X86.Instr.canShortcut - ,shortcutStatic = X86.Instr.shortcutStatic + ,shortcutStatics = X86.Instr.shortcutStatics ,shortcutJump = X86.Instr.shortcutJump ,pprNatCmmTop = X86.Ppr.pprNatCmmTop ,maxSpillSlots = X86.Instr.maxSpillSlots @@ -173,7 +175,7 @@ nativeCodeGen dflags h us cmms ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr ,getJumpDestBlockId = PPC.RegInfo.getJumpDestBlockId ,canShortcut = PPC.RegInfo.canShortcut - ,shortcutStatic = PPC.RegInfo.shortcutStatic + ,shortcutStatics = PPC.RegInfo.shortcutStatics ,shortcutJump = PPC.RegInfo.shortcutJump ,pprNatCmmTop = PPC.Ppr.pprNatCmmTop ,maxSpillSlots = PPC.Instr.maxSpillSlots @@ -188,7 +190,7 @@ nativeCodeGen dflags h us cmms ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr ,getJumpDestBlockId = SPARC.ShortcutJump.getJumpDestBlockId ,canShortcut = SPARC.ShortcutJump.canShortcut - ,shortcutStatic = SPARC.ShortcutJump.shortcutStatic + ,shortcutStatics = SPARC.ShortcutJump.shortcutStatics ,shortcutJump = SPARC.ShortcutJump.shortcutJump ,pprNatCmmTop = SPARC.Ppr.pprNatCmmTop ,maxSpillSlots = SPARC.Instr.maxSpillSlots @@ -204,13 +206,14 @@ nativeCodeGen dflags h us cmms ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch" -nativeCodeGen' :: (Instruction instr, Outputable instr) +nativeCodeGen' :: (Outputable statics, PlatformOutputable instr, Instruction instr) => DynFlags - -> NcgImpl instr jumpDest + -> NcgImpl statics instr jumpDest -> Handle -> UniqSupply -> [RawCmm] -> IO () nativeCodeGen' dflags ncgImpl h us cmms = do - let split_cmms = concat $ map add_split cmms + let platform = targetPlatform dflags + split_cmms = concat $ map add_split cmms -- BufHandle is a performance hack. We could hide it inside -- Pretty if it weren't for the fact that we do lots of little -- printDocs here (in order to do codegen in constant space). @@ -224,7 +227,7 @@ nativeCodeGen' dflags ncgImpl h us cmms -- dump native code dumpIfSet_dyn dflags Opt_D_dump_asm "Asm code" - (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) $ concat native) + (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) $ concat native) -- dump global NCG stats for graph coloring allocator (case concat $ catMaybes colorStats of @@ -242,10 +245,10 @@ nativeCodeGen' dflags ncgImpl h us cmms dumpIfSet_dyn dflags Opt_D_dump_asm_conflicts "Register conflict graph" $ Color.dotGraph - targetRegDotColor - (Color.trivColorable - targetVirtualRegSqueeze - targetRealRegSqueeze) + (targetRegDotColor platform) + (Color.trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) $ graphGlobal) @@ -265,25 +268,25 @@ nativeCodeGen' dflags ncgImpl h us cmms | dopt Opt_SplitObjs dflags = split_marker : tops | otherwise = tops - split_marker = CmmProc [] mkSplitMarkerLabel (ListGraph []) + split_marker = CmmProc Nothing mkSplitMarkerLabel (ListGraph []) -- | Do native code generation on all these cmms. -- -cmmNativeGens :: (Instruction instr, Outputable instr) +cmmNativeGens :: (Outputable statics, PlatformOutputable instr, Instruction instr) => DynFlags - -> NcgImpl instr jumpDest + -> NcgImpl statics instr jumpDest -> BufHandle -> UniqSupply -> [RawCmmTop] -> [[CLabel]] - -> [ ([NatCmmTop instr], - Maybe [Color.RegAllocStats instr], + -> [ ([NatCmmTop statics instr], + Maybe [Color.RegAllocStats statics instr], Maybe [Linear.RegAllocStats]) ] -> Int -> IO ( [[CLabel]], - [([NatCmmTop instr], - Maybe [Color.RegAllocStats instr], + [([NatCmmTop statics instr], + Maybe [Color.RegAllocStats statics instr], Maybe [Linear.RegAllocStats])] ) cmmNativeGens _ _ _ _ [] impAcc profAcc _ @@ -295,7 +298,7 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count <- cmmNativeGen dflags ncgImpl us cmm count Pretty.bufLeftRender h - $ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map (pprNatCmmTop ncgImpl) native + $ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map (pprNatCmmTop ncgImpl (targetPlatform dflags)) native -- carefully evaluate this strictly. Binding it with 'let' -- and then using 'seq' doesn't work, because the let @@ -325,20 +328,21 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count -- Dumping the output of each stage along the way. -- Global conflict graph and NGC stats cmmNativeGen - :: (Instruction instr, Outputable instr) + :: (Outputable statics, PlatformOutputable instr, Instruction instr) => DynFlags - -> NcgImpl instr jumpDest + -> NcgImpl statics instr jumpDest -> UniqSupply -> RawCmmTop -- ^ the cmm to generate code for -> Int -- ^ sequence number of this top thing -> IO ( UniqSupply - , [NatCmmTop instr] -- native code - , [CLabel] -- things imported by this cmm - , Maybe [Color.RegAllocStats instr] -- stats for the coloring register allocator - , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators + , [NatCmmTop statics instr] -- native code + , [CLabel] -- things imported by this cmm + , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator + , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators cmmNativeGen dflags ncgImpl us cmm count = do + let platform = targetPlatform dflags -- rewrite assignments to global regs let fixed_cmm = @@ -352,7 +356,7 @@ cmmNativeGen dflags ncgImpl us cmm count dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" - (pprCmm $ Cmm [opt_cmm]) + (pprCmm platform $ Cmm [opt_cmm]) -- generate native code from cmm let ((native, lastMinuteImports), usGen) = @@ -361,18 +365,18 @@ cmmNativeGen dflags ncgImpl us cmm count dumpIfSet_dyn dflags Opt_D_dump_asm_native "Native code" - (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) native) + (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) native) -- tag instructions with register liveness information let (withLiveness, usLive) = {-# SCC "regLiveness" #-} initUs usGen - $ mapUs regLiveness + $ mapUs (regLiveness platform) $ map natCmmTopToLive native dumpIfSet_dyn dflags Opt_D_dump_asm_liveness "Liveness annotations added" - (vcat $ map ppr withLiveness) + (vcat $ map (pprPlatform platform) withLiveness) -- allocate registers (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <- @@ -382,7 +386,7 @@ cmmNativeGen dflags ncgImpl us cmm count -- the regs usable for allocation let (alloc_regs :: UniqFM (UniqSet RealReg)) = foldr (\r -> plusUFM_C unionUniqSets - $ unitUFM (targetClassOfRealReg r) (unitUniqSet r)) + $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r)) emptyUFM $ allocatableRegs ncgImpl @@ -399,14 +403,14 @@ cmmNativeGen dflags ncgImpl us cmm count -- dump out what happened during register allocation dumpIfSet_dyn dflags Opt_D_dump_asm_regalloc "Registers allocated" - (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) alloced) + (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) alloced) dumpIfSet_dyn dflags Opt_D_dump_asm_regalloc_stages "Build/spill stages" (vcat $ map (\(stage, stats) -> text "# --------------------------" $$ text "# cmm " <> int count <> text " Stage " <> int stage - $$ ppr stats) + $$ pprPlatform platform stats) $ zip [0..] regAllocStats) let mPprStats = @@ -430,7 +434,7 @@ cmmNativeGen dflags ncgImpl us cmm count dumpIfSet_dyn dflags Opt_D_dump_asm_regalloc "Registers allocated" - (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) alloced) + (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) alloced) let mPprStats = if dopt Opt_D_dump_asm_stats dflags @@ -474,7 +478,7 @@ cmmNativeGen dflags ncgImpl us cmm count dumpIfSet_dyn dflags Opt_D_dump_asm_expanded "Synthetic instructions expanded" - (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) expanded) + (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) expanded) return ( usAlloc , expanded @@ -483,7 +487,7 @@ cmmNativeGen dflags ncgImpl us cmm count , ppr_raStatsLinear) -x86fp_kludge :: NatCmmTop X86.Instr.Instr -> NatCmmTop X86.Instr.Instr +x86fp_kludge :: NatCmmTop (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmTop (Alignment, CmmStatics) X86.Instr.Instr x86fp_kludge top@(CmmData _ _) = top x86fp_kludge (CmmProc info lbl (ListGraph code)) = CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code) @@ -556,7 +560,7 @@ makeImportsDoc dflags imports sequenceTop :: Instruction instr - => NcgImpl instr jumpDest -> NatCmmTop instr -> NatCmmTop instr + => NcgImpl statics instr jumpDest -> NatCmmTop statics instr -> NatCmmTop statics instr sequenceTop _ top@(CmmData _ _) = top sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) = @@ -670,8 +674,8 @@ makeFarBranches blocks -- Analyzes all native code and generates data sections for all jump -- table instructions. generateJumpTables - :: NcgImpl instr jumpDest - -> [NatCmmTop instr] -> [NatCmmTop instr] + :: NcgImpl statics instr jumpDest + -> [NatCmmTop statics instr] -> [NatCmmTop statics instr] generateJumpTables ncgImpl xs = concatMap f xs where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs f p = [p] @@ -682,9 +686,9 @@ generateJumpTables ncgImpl xs = concatMap f xs shortcutBranches :: DynFlags - -> NcgImpl instr jumpDest - -> [NatCmmTop instr] - -> [NatCmmTop instr] + -> NcgImpl statics instr jumpDest + -> [NatCmmTop statics instr] + -> [NatCmmTop statics instr] shortcutBranches dflags ncgImpl tops | optLevel dflags < 1 = tops -- only with -O or higher @@ -693,7 +697,7 @@ shortcutBranches dflags ncgImpl tops (tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops mapping = foldr plusUFM emptyUFM mappings -build_mapping :: NcgImpl instr jumpDest +build_mapping :: NcgImpl statics instr jumpDest -> GenCmmTop d t (ListGraph instr) -> (GenCmmTop d t (ListGraph instr), UniqFM jumpDest) build_mapping _ top@(CmmData _ _) = (top, emptyUFM) @@ -723,14 +727,12 @@ build_mapping ncgImpl (CmmProc info lbl (ListGraph (head:blocks))) mapping = foldl add emptyUFM shortcut_blocks add ufm (id,dest) = addToUFM ufm id dest -apply_mapping :: NcgImpl instr jumpDest +apply_mapping :: NcgImpl statics instr jumpDest -> UniqFM jumpDest - -> GenCmmTop CmmStatic h (ListGraph instr) - -> GenCmmTop CmmStatic h (ListGraph instr) + -> GenCmmTop statics h (ListGraph instr) + -> GenCmmTop statics h (ListGraph instr) apply_mapping ncgImpl ufm (CmmData sec statics) - = CmmData sec (map (shortcutStatic ncgImpl (lookupUFM ufm)) statics) - -- we need to get the jump tables, so apply the mapping to the entries - -- of a CmmData too. + = CmmData sec (shortcutStatics ncgImpl (lookupUFM ufm) statics) apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks)) = CmmProc info lbl (ListGraph $ map short_bb blocks) where @@ -761,10 +763,10 @@ apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks)) genMachCode :: DynFlags - -> (RawCmmTop -> NatM [NatCmmTop instr]) + -> (RawCmmTop -> NatM [NatCmmTop statics instr]) -> RawCmmTop -> UniqSM - ( [NatCmmTop instr] + ( [NatCmmTop statics instr] , [CLabel]) genMachCode dflags cmmTopCodeGen cmm_top diff --git a/compiler/nativeGen/Instruction.hs b/compiler/nativeGen/Instruction.hs index 918198cb9c..b2db2ef206 100644 --- a/compiler/nativeGen/Instruction.hs +++ b/compiler/nativeGen/Instruction.hs @@ -1,11 +1,11 @@ module Instruction ( - RegUsage(..), - noUsage, - NatCmm, - NatCmmTop, - NatBasicBlock, - Instruction(..) + RegUsage(..), + noUsage, + NatCmm, + NatCmmTop, + NatBasicBlock, + Instruction(..) ) where @@ -14,19 +14,20 @@ import Reg import BlockId import OldCmm +import Platform -- | Holds a list of source and destination registers used by a --- particular instruction. +-- particular instruction. -- -- Machine registers that are pre-allocated to stgRegs are filtered --- out, because they are uninteresting from a register allocation --- standpoint. (We wouldn't want them to end up on the free list!) +-- out, because they are uninteresting from a register allocation +-- standpoint. (We wouldn't want them to end up on the free list!) -- -- As far as we are concerned, the fixed registers simply don't exist --- (for allocation purposes, anyway). +-- (for allocation purposes, anyway). -- -data RegUsage - = RU [Reg] [Reg] +data RegUsage + = RU [Reg] [Reg] -- | No regs read or written to. noUsage :: RegUsage @@ -36,124 +37,127 @@ noUsage = RU [] [] -- Our flavours of the Cmm types -- Type synonyms for Cmm populated with native code type NatCmm instr - = GenCmm - CmmStatic - [CmmStatic] - (ListGraph instr) + = GenCmm + CmmStatics + (Maybe CmmStatics) + (ListGraph instr) -type NatCmmTop instr - = GenCmmTop - CmmStatic - [CmmStatic] - (ListGraph instr) +type NatCmmTop statics instr + = GenCmmTop + statics + (Maybe CmmStatics) + (ListGraph instr) type NatBasicBlock instr - = GenBasicBlock instr + = GenBasicBlock instr -- | Common things that we can do with instructions, on all architectures. --- These are used by the shared parts of the native code generator, --- specifically the register allocators. +-- These are used by the shared parts of the native code generator, +-- specifically the register allocators. -- -class Instruction instr where - - -- | Get the registers that are being used by this instruction. - -- regUsage doesn't need to do any trickery for jumps and such. - -- Just state precisely the regs read and written by that insn. - -- The consequences of control flow transfers, as far as register - -- allocation goes, are taken care of by the register allocator. - -- - regUsageOfInstr - :: instr - -> RegUsage - - - -- | Apply a given mapping to all the register references in this - -- instruction. - patchRegsOfInstr - :: instr - -> (Reg -> Reg) - -> instr - - - -- | Checks whether this instruction is a jump/branch instruction. - -- One that can change the flow of control in a way that the - -- register allocator needs to worry about. - isJumpishInstr - :: instr -> Bool - - - -- | Give the possible destinations of this jump instruction. - -- Must be defined for all jumpish instructions. - jumpDestsOfInstr - :: instr -> [BlockId] - - - -- | Change the destination of this jump instruction. - -- Used in the linear allocator when adding fixup blocks for join - -- points. - patchJumpInstr - :: instr - -> (BlockId -> BlockId) - -> instr - - - -- | An instruction to spill a register into a spill slot. - mkSpillInstr - :: Reg -- ^ the reg to spill - -> Int -- ^ the current stack delta - -> Int -- ^ spill slot to use - -> instr - - - -- | An instruction to reload a register from a spill slot. - mkLoadInstr - :: Reg -- ^ the reg to reload. - -> Int -- ^ the current stack delta - -> Int -- ^ the spill slot to use - -> instr - - -- | See if this instruction is telling us the current C stack delta - takeDeltaInstr - :: instr - -> Maybe Int - - -- | Check whether this instruction is some meta thing inserted into - -- the instruction stream for other purposes. - -- - -- Not something that has to be treated as a real machine instruction - -- and have its registers allocated. - -- - -- eg, comments, delta, ldata, etc. - isMetaInstr - :: instr - -> Bool - - - - -- | Copy the value in a register to another one. - -- Must work for all register classes. - mkRegRegMoveInstr - :: Reg -- ^ source register - -> Reg -- ^ destination register - -> instr - - -- | Take the source and destination from this reg -> reg move instruction - -- or Nothing if it's not one - takeRegRegMoveInstr - :: instr - -> Maybe (Reg, Reg) - - -- | Make an unconditional jump instruction. - -- For architectures with branch delay slots, its ok to put - -- a NOP after the jump. Don't fill the delay slot with an - -- instruction that references regs or you'll confuse the - -- linear allocator. - mkJumpInstr - :: BlockId - -> [instr] - - +class Instruction instr where + + -- | Get the registers that are being used by this instruction. + -- regUsage doesn't need to do any trickery for jumps and such. + -- Just state precisely the regs read and written by that insn. + -- The consequences of control flow transfers, as far as register + -- allocation goes, are taken care of by the register allocator. + -- + regUsageOfInstr + :: instr + -> RegUsage + + + -- | Apply a given mapping to all the register references in this + -- instruction. + patchRegsOfInstr + :: instr + -> (Reg -> Reg) + -> instr + + + -- | Checks whether this instruction is a jump/branch instruction. + -- One that can change the flow of control in a way that the + -- register allocator needs to worry about. + isJumpishInstr + :: instr -> Bool + + + -- | Give the possible destinations of this jump instruction. + -- Must be defined for all jumpish instructions. + jumpDestsOfInstr + :: instr -> [BlockId] + + + -- | Change the destination of this jump instruction. + -- Used in the linear allocator when adding fixup blocks for join + -- points. + patchJumpInstr + :: instr + -> (BlockId -> BlockId) + -> instr + + + -- | An instruction to spill a register into a spill slot. + mkSpillInstr + :: Platform + -> Reg -- ^ the reg to spill + -> Int -- ^ the current stack delta + -> Int -- ^ spill slot to use + -> instr + + + -- | An instruction to reload a register from a spill slot. + mkLoadInstr + :: Platform + -> Reg -- ^ the reg to reload. + -> Int -- ^ the current stack delta + -> Int -- ^ the spill slot to use + -> instr + + -- | See if this instruction is telling us the current C stack delta + takeDeltaInstr + :: instr + -> Maybe Int + + -- | Check whether this instruction is some meta thing inserted into + -- the instruction stream for other purposes. + -- + -- Not something that has to be treated as a real machine instruction + -- and have its registers allocated. + -- + -- eg, comments, delta, ldata, etc. + isMetaInstr + :: instr + -> Bool + + + + -- | Copy the value in a register to another one. + -- Must work for all register classes. + mkRegRegMoveInstr + :: Platform + -> Reg -- ^ source register + -> Reg -- ^ destination register + -> instr + + -- | Take the source and destination from this reg -> reg move instruction + -- or Nothing if it's not one + takeRegRegMoveInstr + :: instr + -> Maybe (Reg, Reg) + + -- | Make an unconditional jump instruction. + -- For architectures with branch delay slots, its ok to put + -- a NOP after the jump. Don't fill the delay slot with an + -- instruction that references regs or you'll confuse the + -- linear allocator. + mkJumpInstr + :: BlockId + -> [instr] + + diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs index 2a7376838a..57d2adf9b8 100644 --- a/compiler/nativeGen/NCGMonad.hs +++ b/compiler/nativeGen/NCGMonad.hs @@ -130,18 +130,20 @@ getNewLabelNat getNewRegNat :: Size -> NatM Reg -getNewRegNat rep - = do u <- getUniqueNat - return (RegVirtual $ targetMkVirtualReg u rep) +getNewRegNat rep + = do u <- getUniqueNat + dflags <- getDynFlagsNat + return (RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep) getNewRegPairNat :: Size -> NatM (Reg,Reg) -getNewRegPairNat rep - = do u <- getUniqueNat - let vLo = targetMkVirtualReg u rep - let lo = RegVirtual $ targetMkVirtualReg u rep - let hi = RegVirtual $ getHiVirtualRegFromLo vLo - return (lo, hi) +getNewRegPairNat rep + = do u <- getUniqueNat + dflags <- getDynFlagsNat + let vLo = targetMkVirtualReg (targetPlatform dflags) u rep + let lo = RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep + let hi = RegVirtual $ getHiVirtualRegFromLo vLo + return (lo, hi) getPicBaseMaybeNat :: NatM (Maybe Reg) diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs index c375ab4707..7f59fd6fc9 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -709,8 +709,8 @@ pprImportedSymbol _ _ _ initializePicBase_ppc :: Arch -> OS -> Reg - -> [NatCmmTop PPC.Instr] - -> NatM [NatCmmTop PPC.Instr] + -> [NatCmmTop CmmStatics PPC.Instr] + -> NatM [NatCmmTop CmmStatics PPC.Instr] initializePicBase_ppc ArchPPC os picReg (CmmProc info lab (ListGraph blocks) : statics) @@ -719,8 +719,7 @@ initializePicBase_ppc ArchPPC os picReg gotOffLabel <- getNewLabelNat tmp <- getNewRegNat $ intSize wordWidth let - gotOffset = CmmData Text [ - CmmDataLabel gotOffLabel, + gotOffset = CmmData Text $ Statics gotOffLabel [ CmmStaticLit (CmmLabelDiffOff gotLabel mkPicBaseLabel 0) @@ -762,8 +761,8 @@ initializePicBase_ppc _ _ _ _ initializePicBase_x86 :: Arch -> OS -> Reg - -> [NatCmmTop X86.Instr] - -> NatM [NatCmmTop X86.Instr] + -> [NatCmmTop (Alignment, CmmStatics) X86.Instr] + -> NatM [NatCmmTop (Alignment, CmmStatics) X86.Instr] initializePicBase_x86 ArchX86 os picReg (CmmProc info lab (ListGraph blocks) : statics) diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index f4c972e4b0..a0e3ae92b5 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -67,7 +67,7 @@ import FastString cmmTopCodeGen :: RawCmmTop - -> NatM [NatCmmTop Instr] + -> NatM [NatCmmTop CmmStatics Instr] cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks @@ -86,7 +86,7 @@ cmmTopCodeGen (CmmData sec dat) = do basicBlockCodeGen :: CmmBasicBlock -> NatM ( [NatBasicBlock Instr] - , [NatCmmTop Instr]) + , [NatCmmTop CmmStatics Instr]) basicBlockCodeGen (BasicBlock id stmts) = do instrs <- stmtsToInstrs stmts @@ -403,11 +403,12 @@ getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32) [x]) ChildCode64 code rlo <- iselExpr64 x return $ Fixed II32 rlo code -getRegister' _ (CmmLoad mem pk) +getRegister' dflags (CmmLoad mem pk) | not (isWord64 pk) = do + let platform = targetPlatform dflags Amode addr addr_code <- getAmode mem - let code dst = ASSERT((targetClassOfReg dst == RcDouble) == isFloatType pk) + let code dst = ASSERT((targetClassOfReg platform dst == RcDouble) == isFloatType pk) addr_code `snocOL` LD size dst addr return (Any size code) where size = cmmTypeSize pk @@ -557,8 +558,8 @@ getRegister' _ (CmmLit (CmmFloat f frep)) = do Amode addr addr_code <- getAmode dynRef let size = floatSize frep code dst = - LDATA ReadOnlyData [CmmDataLabel lbl, - CmmStaticLit (CmmFloat f frep)] + LDATA ReadOnlyData (Statics lbl + [CmmStaticLit (CmmFloat f frep)]) `consOL` (addr_code `snocOL` LD size dst addr) return (Any size code) @@ -903,7 +904,7 @@ genCCall' _ (CmmPrim MO_WriteBarrier) _ _ = return $ unitOL LWSYNC genCCall' gcp target dest_regs argsAndHints - = ASSERT (not $ any (`elem` [II8,II16]) $ map cmmTypeSize argReps) + = ASSERT (not $ any (`elem` [II16]) $ map cmmTypeSize argReps) -- we rely on argument promotion in the codeGen do (finalStack,passArgumentsCode,usedRegs) <- passArguments @@ -1058,23 +1059,23 @@ genCCall' gcp target dest_regs argsAndHints = case gcp of GCPDarwin -> case cmmTypeSize rep of + II8 -> (1, 0, 4, gprs) II32 -> (1, 0, 4, gprs) -- The Darwin ABI requires that we skip a -- corresponding number of GPRs when we use -- the FPRs. FF32 -> (1, 1, 4, fprs) FF64 -> (2, 1, 8, fprs) - II8 -> panic "genCCall' passArguments II8" II16 -> panic "genCCall' passArguments II16" II64 -> panic "genCCall' passArguments II64" FF80 -> panic "genCCall' passArguments FF80" GCPLinux -> case cmmTypeSize rep of + II8 -> (1, 0, 4, gprs) II32 -> (1, 0, 4, gprs) -- ... the SysV ABI doesn't. FF32 -> (0, 1, 4, fprs) FF64 -> (0, 1, 8, fprs) - II8 -> panic "genCCall' passArguments II8" II16 -> panic "genCCall' passArguments II16" II64 -> panic "genCCall' passArguments II64" FF80 -> panic "genCCall' passArguments FF80" @@ -1180,7 +1181,7 @@ genSwitch expr ids ] return code -generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr) +generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop CmmStatics Instr) generateJumpTableForInstr (BCTR ids (Just lbl)) = let jumpTable | opt_PIC = map jumpTableEntryRel ids @@ -1190,7 +1191,7 @@ generateJumpTableForInstr (BCTR ids (Just lbl)) = jumpTableEntryRel (Just blockid) = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) where blockLabel = mkAsmTempLabel (getUnique blockid) - in Just (CmmData ReadOnlyData (CmmDataLabel lbl : jumpTable)) + in Just (CmmData ReadOnlyData (Statics lbl jumpTable)) generateJumpTableForInstr _ = Nothing -- ----------------------------------------------------------------------------- @@ -1362,10 +1363,9 @@ coerceInt2FP fromRep toRep x = do Amode addr addr_code <- getAmode dynRef let code' dst = code `appOL` maybe_exts `appOL` toOL [ - LDATA ReadOnlyData - [CmmDataLabel lbl, - CmmStaticLit (CmmInt 0x43300000 W32), - CmmStaticLit (CmmInt 0x80000000 W32)], + LDATA ReadOnlyData $ Statics lbl + [CmmStaticLit (CmmInt 0x43300000 W32), + CmmStaticLit (CmmInt 0x80000000 W32)], XORIS itmp src (ImmInt 0x8000), ST II32 itmp (spRel 3), LIS itmp (ImmInt 0x4330), diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs index 0288f1bf02..ffe5408033 100644 --- a/compiler/nativeGen/PPC/Instr.hs +++ b/compiler/nativeGen/PPC/Instr.hs @@ -32,6 +32,7 @@ import OldCmm import FastString import CLabel import Outputable +import Platform import FastBool -------------------------------------------------------------------------------- @@ -43,18 +44,18 @@ archWordSize = II32 -- | Instruction instance for powerpc instance Instruction Instr where - regUsageOfInstr = ppc_regUsageOfInstr - patchRegsOfInstr = ppc_patchRegsOfInstr - isJumpishInstr = ppc_isJumpishInstr - jumpDestsOfInstr = ppc_jumpDestsOfInstr - patchJumpInstr = ppc_patchJumpInstr - mkSpillInstr = ppc_mkSpillInstr - mkLoadInstr = ppc_mkLoadInstr - takeDeltaInstr = ppc_takeDeltaInstr - isMetaInstr = ppc_isMetaInstr - mkRegRegMoveInstr = ppc_mkRegRegMoveInstr - takeRegRegMoveInstr = ppc_takeRegRegMoveInstr - mkJumpInstr = ppc_mkJumpInstr + regUsageOfInstr = ppc_regUsageOfInstr + patchRegsOfInstr = ppc_patchRegsOfInstr + isJumpishInstr = ppc_isJumpishInstr + jumpDestsOfInstr = ppc_jumpDestsOfInstr + patchJumpInstr = ppc_patchJumpInstr + mkSpillInstr = ppc_mkSpillInstr + mkLoadInstr = ppc_mkLoadInstr + takeDeltaInstr = ppc_takeDeltaInstr + isMetaInstr = ppc_isMetaInstr + mkRegRegMoveInstr _ = ppc_mkRegRegMoveInstr + takeRegRegMoveInstr = ppc_takeRegRegMoveInstr + mkJumpInstr = ppc_mkJumpInstr -- ----------------------------------------------------------------------------- @@ -75,7 +76,7 @@ data Instr -- some static data spat out during code -- generation. Will be extracted before -- pretty-printing. - | LDATA Section [CmmStatic] + | LDATA Section CmmStatics -- start a new basic block. Useful during -- codegen, removed later. Preceding @@ -346,15 +347,16 @@ ppc_patchJumpInstr insn patchF -- | An instruction to spill a register into a spill slot. ppc_mkSpillInstr - :: Reg -- register to spill - -> Int -- current stack delta - -> Int -- spill slot to use + :: Platform + -> Reg -- register to spill + -> Int -- current stack delta + -> Int -- spill slot to use -> Instr -ppc_mkSpillInstr reg delta slot +ppc_mkSpillInstr platform reg delta slot = let off = spillSlotToOffset slot in - let sz = case targetClassOfReg reg of + let sz = case targetClassOfReg platform reg of RcInteger -> II32 RcDouble -> FF64 _ -> panic "PPC.Instr.mkSpillInstr: no match" @@ -362,15 +364,16 @@ ppc_mkSpillInstr reg delta slot ppc_mkLoadInstr - :: Reg -- register to load - -> Int -- current stack delta - -> Int -- spill slot to use + :: Platform + -> Reg -- register to load + -> Int -- current stack delta + -> Int -- spill slot to use -> Instr -ppc_mkLoadInstr reg delta slot +ppc_mkLoadInstr platform reg delta slot = let off = spillSlotToOffset slot in - let sz = case targetClassOfReg reg of + let sz = case targetClassOfReg platform reg of RcInteger -> II32 RcDouble -> FF64 _ -> panic "PPC.Instr.mkLoadInstr: no match" diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index bd12a8188c..54056c9e4d 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -37,10 +37,11 @@ import OldCmm import CLabel import Unique ( pprUnique, Uniquable(..) ) +import Platform import Pretty import FastString import qualified Outputable -import Outputable ( Outputable, panic ) +import Outputable ( PlatformOutputable, panic ) import Data.Word import Data.Bits @@ -49,26 +50,30 @@ import Data.Bits -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmTop :: NatCmmTop Instr -> Doc -pprNatCmmTop (CmmData section dats) = - pprSectionHeader section $$ vcat (map pprData dats) +pprNatCmmTop :: Platform -> NatCmmTop CmmStatics Instr -> Doc +pprNatCmmTop _ (CmmData section dats) = + pprSectionHeader section $$ pprDatas dats -- special case for split markers: -pprNatCmmTop (CmmProc [] lbl (ListGraph [])) = pprLabel lbl +pprNatCmmTop _ (CmmProc Nothing lbl (ListGraph [])) = pprLabel lbl -pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) = + -- special case for code without an info table: +pprNatCmmTop platform (CmmProc Nothing lbl (ListGraph blocks)) = pprSectionHeader Text $$ - (if null info then -- blocks guaranteed not null, so label needed - pprLabel lbl - else + pprLabel lbl $$ -- blocks guaranteed not null, so label needed + vcat (map (pprBasicBlock platform) blocks) + +pprNatCmmTop platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) = + pprSectionHeader Text $$ + ( #if HAVE_SUBSECTIONS_VIA_SYMBOLS - pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) - <> char ':' $$ + pprCLabel_asm (mkDeadStripPreventer info_lbl) + <> char ':' $$ #endif vcat (map pprData info) $$ - pprLabel (entryLblToInfoLbl lbl) + pprLabel info_lbl ) $$ - vcat (map pprBasicBlock blocks) + vcat (map (pprBasicBlock platform) blocks) -- above: Even the first block gets a label, because with branch-chain -- elimination, it might be the target of a goto. #if HAVE_SUBSECTIONS_VIA_SYMBOLS @@ -78,24 +83,24 @@ pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) = -- from the entry code to a label on the _top_ of of the info table, -- so that the linker will not think it is unreferenced and dead-strip -- it. That's why the label is called a DeadStripPreventer (_dsp). - $$ if not (null info) - then text "\t.long " - <+> pprCLabel_asm (entryLblToInfoLbl lbl) - <+> char '-' - <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) - else empty + $$ text "\t.long " + <+> pprCLabel_asm info_lbl + <+> char '-' + <+> pprCLabel_asm (mkDeadStripPreventer info_lbl) #endif -pprBasicBlock :: NatBasicBlock Instr -> Doc -pprBasicBlock (BasicBlock blockid instrs) = +pprBasicBlock :: Platform -> NatBasicBlock Instr -> Doc +pprBasicBlock platform (BasicBlock blockid instrs) = pprLabel (mkAsmTempLabel (getUnique blockid)) $$ - vcat (map pprInstr instrs) + vcat (map (pprInstr platform) instrs) + +pprDatas :: CmmStatics -> Doc +pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats) + pprData :: CmmStatic -> Doc -pprData (CmmAlign bytes) = pprAlign bytes -pprData (CmmDataLabel lbl) = pprLabel lbl pprData (CmmString str) = pprASCII str #if darwin_TARGET_OS @@ -133,25 +138,12 @@ pprASCII str do1 :: Word8 -> Doc do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w) -pprAlign :: Int -> Doc -pprAlign bytes = - ptext (sLit ".align ") <> int pow2 - where - pow2 = log2 bytes - - log2 :: Int -> Int -- cache the common ones - log2 1 = 0 - log2 2 = 1 - log2 4 = 2 - log2 8 = 3 - log2 n = 1 + log2 (n `quot` 2) - -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -instance Outputable Instr where - ppr instr = Outputable.docToSDoc $ pprInstr instr +instance PlatformOutputable Instr where + pprPlatform platform instr = Outputable.docToSDoc $ pprInstr platform instr pprReg :: Reg -> Doc @@ -345,26 +337,26 @@ pprDataItem lit = panic "PPC.Ppr.pprDataItem: no match" -pprInstr :: Instr -> Doc +pprInstr :: Platform -> Instr -> Doc -pprInstr (COMMENT _) = empty -- nuke 'em +pprInstr _ (COMMENT _) = empty -- nuke 'em {- -pprInstr (COMMENT s) +pprInstr _ (COMMENT s) IF_OS_linux( ((<>) (ptext (sLit "# ")) (ftext s)), ((<>) (ptext (sLit "; ")) (ftext s))) -} -pprInstr (DELTA d) - = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d))) +pprInstr platform (DELTA d) + = pprInstr platform (COMMENT (mkFastString ("\tdelta = " ++ show d))) -pprInstr (NEWBLOCK _) +pprInstr _ (NEWBLOCK _) = panic "PprMach.pprInstr: NEWBLOCK" -pprInstr (LDATA _ _) +pprInstr _ (LDATA _ _) = panic "PprMach.pprInstr: LDATA" {- -pprInstr (SPILL reg slot) +pprInstr _ (SPILL reg slot) = hcat [ ptext (sLit "\tSPILL"), char '\t', @@ -372,7 +364,7 @@ pprInstr (SPILL reg slot) comma, ptext (sLit "SLOT") <> parens (int slot)] -pprInstr (RELOAD slot reg) +pprInstr _ (RELOAD slot reg) = hcat [ ptext (sLit "\tRELOAD"), char '\t', @@ -381,7 +373,7 @@ pprInstr (RELOAD slot reg) pprReg reg] -} -pprInstr (LD sz reg addr) = hcat [ +pprInstr _ (LD sz reg addr) = hcat [ char '\t', ptext (sLit "l"), ptext (case sz of @@ -399,7 +391,7 @@ pprInstr (LD sz reg addr) = hcat [ ptext (sLit ", "), pprAddr addr ] -pprInstr (LA sz reg addr) = hcat [ +pprInstr _ (LA sz reg addr) = hcat [ char '\t', ptext (sLit "l"), ptext (case sz of @@ -417,7 +409,7 @@ pprInstr (LA sz reg addr) = hcat [ ptext (sLit ", "), pprAddr addr ] -pprInstr (ST sz reg addr) = hcat [ +pprInstr _ (ST sz reg addr) = hcat [ char '\t', ptext (sLit "st"), pprSize sz, @@ -428,7 +420,7 @@ pprInstr (ST sz reg addr) = hcat [ ptext (sLit ", "), pprAddr addr ] -pprInstr (STU sz reg addr) = hcat [ +pprInstr _ (STU sz reg addr) = hcat [ char '\t', ptext (sLit "st"), pprSize sz, @@ -439,7 +431,7 @@ pprInstr (STU sz reg addr) = hcat [ ptext (sLit ", "), pprAddr addr ] -pprInstr (LIS reg imm) = hcat [ +pprInstr _ (LIS reg imm) = hcat [ char '\t', ptext (sLit "lis"), char '\t', @@ -447,7 +439,7 @@ pprInstr (LIS reg imm) = hcat [ ptext (sLit ", "), pprImm imm ] -pprInstr (LI reg imm) = hcat [ +pprInstr _ (LI reg imm) = hcat [ char '\t', ptext (sLit "li"), char '\t', @@ -455,11 +447,11 @@ pprInstr (LI reg imm) = hcat [ ptext (sLit ", "), pprImm imm ] -pprInstr (MR reg1 reg2) +pprInstr platform (MR reg1 reg2) | reg1 == reg2 = empty | otherwise = hcat [ char '\t', - case targetClassOfReg reg1 of + case targetClassOfReg platform reg1 of RcInteger -> ptext (sLit "mr") _ -> ptext (sLit "fmr"), char '\t', @@ -467,7 +459,7 @@ pprInstr (MR reg1 reg2) ptext (sLit ", "), pprReg reg2 ] -pprInstr (CMP sz reg ri) = hcat [ +pprInstr _ (CMP sz reg ri) = hcat [ char '\t', op, char '\t', @@ -483,7 +475,7 @@ pprInstr (CMP sz reg ri) = hcat [ RIReg _ -> empty RIImm _ -> char 'i' ] -pprInstr (CMPL sz reg ri) = hcat [ +pprInstr _ (CMPL sz reg ri) = hcat [ char '\t', op, char '\t', @@ -499,7 +491,7 @@ pprInstr (CMPL sz reg ri) = hcat [ RIReg _ -> empty RIImm _ -> char 'i' ] -pprInstr (BCC cond blockid) = hcat [ +pprInstr _ (BCC cond blockid) = hcat [ char '\t', ptext (sLit "b"), pprCond cond, @@ -508,7 +500,7 @@ pprInstr (BCC cond blockid) = hcat [ ] where lbl = mkAsmTempLabel (getUnique blockid) -pprInstr (BCCFAR cond blockid) = vcat [ +pprInstr _ (BCCFAR cond blockid) = vcat [ hcat [ ptext (sLit "\tb"), pprCond (condNegate cond), @@ -521,33 +513,33 @@ pprInstr (BCCFAR cond blockid) = vcat [ ] where lbl = mkAsmTempLabel (getUnique blockid) -pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel +pprInstr _ (JMP lbl) = hcat [ -- an alias for b that takes a CLabel char '\t', ptext (sLit "b"), char '\t', pprCLabel_asm lbl ] -pprInstr (MTCTR reg) = hcat [ +pprInstr _ (MTCTR reg) = hcat [ char '\t', ptext (sLit "mtctr"), char '\t', pprReg reg ] -pprInstr (BCTR _ _) = hcat [ +pprInstr _ (BCTR _ _) = hcat [ char '\t', ptext (sLit "bctr") ] -pprInstr (BL lbl _) = hcat [ +pprInstr _ (BL lbl _) = hcat [ ptext (sLit "\tbl\t"), pprCLabel_asm lbl ] -pprInstr (BCTRL _) = hcat [ +pprInstr _ (BCTRL _) = hcat [ char '\t', ptext (sLit "bctrl") ] -pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri -pprInstr (ADDIS reg1 reg2 imm) = hcat [ +pprInstr _ (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri +pprInstr _ (ADDIS reg1 reg2 imm) = hcat [ char '\t', ptext (sLit "addis"), char '\t', @@ -558,15 +550,15 @@ pprInstr (ADDIS reg1 reg2 imm) = hcat [ pprImm imm ] -pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3) -pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3) -pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3) -pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mullw") reg1 reg2 ri -pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri -pprInstr (DIVW reg1 reg2 reg3) = pprLogic (sLit "divw") reg1 reg2 (RIReg reg3) -pprInstr (DIVWU reg1 reg2 reg3) = pprLogic (sLit "divwu") reg1 reg2 (RIReg reg3) +pprInstr _ (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3) +pprInstr _ (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3) +pprInstr _ (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3) +pprInstr _ (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mullw") reg1 reg2 ri +pprInstr _ (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri +pprInstr _ (DIVW reg1 reg2 reg3) = pprLogic (sLit "divw") reg1 reg2 (RIReg reg3) +pprInstr _ (DIVWU reg1 reg2 reg3) = pprLogic (sLit "divwu") reg1 reg2 (RIReg reg3) -pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [ +pprInstr _ (MULLW_MayOflo reg1 reg2 reg3) = vcat [ hcat [ ptext (sLit "\tmullwo\t"), pprReg reg1, ptext (sLit ", "), pprReg reg2, ptext (sLit ", "), pprReg reg3 ], @@ -578,7 +570,7 @@ pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [ -- for some reason, "andi" doesn't exist. -- we'll use "andi." instead. -pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [ +pprInstr _ (AND reg1 reg2 (RIImm imm)) = hcat [ char '\t', ptext (sLit "andi."), char '\t', @@ -588,12 +580,12 @@ pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [ ptext (sLit ", "), pprImm imm ] -pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri +pprInstr _ (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri -pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri -pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri +pprInstr _ (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri +pprInstr _ (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri -pprInstr (XORIS reg1 reg2 imm) = hcat [ +pprInstr _ (XORIS reg1 reg2 imm) = hcat [ char '\t', ptext (sLit "xoris"), char '\t', @@ -604,7 +596,7 @@ pprInstr (XORIS reg1 reg2 imm) = hcat [ pprImm imm ] -pprInstr (EXTS sz reg1 reg2) = hcat [ +pprInstr _ (EXTS sz reg1 reg2) = hcat [ char '\t', ptext (sLit "exts"), pprSize sz, @@ -614,13 +606,13 @@ pprInstr (EXTS sz reg1 reg2) = hcat [ pprReg reg2 ] -pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2 -pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2 +pprInstr _ (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2 +pprInstr _ (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2 -pprInstr (SLW reg1 reg2 ri) = pprLogic (sLit "slw") reg1 reg2 (limitShiftRI ri) -pprInstr (SRW reg1 reg2 ri) = pprLogic (sLit "srw") reg1 reg2 (limitShiftRI ri) -pprInstr (SRAW reg1 reg2 ri) = pprLogic (sLit "sraw") reg1 reg2 (limitShiftRI ri) -pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [ +pprInstr _ (SLW reg1 reg2 ri) = pprLogic (sLit "slw") reg1 reg2 (limitShiftRI ri) +pprInstr _ (SRW reg1 reg2 ri) = pprLogic (sLit "srw") reg1 reg2 (limitShiftRI ri) +pprInstr _ (SRAW reg1 reg2 ri) = pprLogic (sLit "sraw") reg1 reg2 (limitShiftRI ri) +pprInstr _ (RLWINM reg1 reg2 sh mb me) = hcat [ ptext (sLit "\trlwinm\t"), pprReg reg1, ptext (sLit ", "), @@ -633,13 +625,13 @@ pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [ int me ] -pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF (sLit "fadd") sz reg1 reg2 reg3 -pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF (sLit "fsub") sz reg1 reg2 reg3 -pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF (sLit "fmul") sz reg1 reg2 reg3 -pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") sz reg1 reg2 reg3 -pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2 +pprInstr _ (FADD sz reg1 reg2 reg3) = pprBinaryF (sLit "fadd") sz reg1 reg2 reg3 +pprInstr _ (FSUB sz reg1 reg2 reg3) = pprBinaryF (sLit "fsub") sz reg1 reg2 reg3 +pprInstr _ (FMUL sz reg1 reg2 reg3) = pprBinaryF (sLit "fmul") sz reg1 reg2 reg3 +pprInstr _ (FDIV sz reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") sz reg1 reg2 reg3 +pprInstr _ (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2 -pprInstr (FCMP reg1 reg2) = hcat [ +pprInstr _ (FCMP reg1 reg2) = hcat [ char '\t', ptext (sLit "fcmpu\tcr0, "), -- Note: we're using fcmpu, not fcmpo @@ -650,10 +642,10 @@ pprInstr (FCMP reg1 reg2) = hcat [ pprReg reg2 ] -pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2 -pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2 +pprInstr _ (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2 +pprInstr _ (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2 -pprInstr (CRNOR dst src1 src2) = hcat [ +pprInstr _ (CRNOR dst src1 src2) = hcat [ ptext (sLit "\tcrnor\t"), int dst, ptext (sLit ", "), @@ -662,28 +654,28 @@ pprInstr (CRNOR dst src1 src2) = hcat [ int src2 ] -pprInstr (MFCR reg) = hcat [ +pprInstr _ (MFCR reg) = hcat [ char '\t', ptext (sLit "mfcr"), char '\t', pprReg reg ] -pprInstr (MFLR reg) = hcat [ +pprInstr _ (MFLR reg) = hcat [ char '\t', ptext (sLit "mflr"), char '\t', pprReg reg ] -pprInstr (FETCHPC reg) = vcat [ +pprInstr _ (FETCHPC reg) = vcat [ ptext (sLit "\tbcl\t20,31,1f"), hcat [ ptext (sLit "1:\tmflr\t"), pprReg reg ] ] -pprInstr LWSYNC = ptext (sLit "\tlwsync") +pprInstr _ LWSYNC = ptext (sLit "\tlwsync") --- pprInstr _ = panic "pprInstr (ppc)" +-- pprInstr _ _ = panic "pprInstr (ppc)" pprLogic :: LitString -> Reg -> Reg -> RI -> Doc diff --git a/compiler/nativeGen/PPC/RegInfo.hs b/compiler/nativeGen/PPC/RegInfo.hs index bfc712af86..2a30087ab7 100644 --- a/compiler/nativeGen/PPC/RegInfo.hs +++ b/compiler/nativeGen/PPC/RegInfo.hs @@ -11,7 +11,7 @@ module PPC.RegInfo ( canShortcut, shortcutJump, - shortcutStatic + shortcutStatics ) where @@ -43,18 +43,24 @@ shortcutJump _ other = other -- Here because it knows about JumpDest -shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic +shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics +shortcutStatics fn (Statics lbl statics) + = Statics lbl $ map (shortcutStatic fn) statics + -- we need to get the jump tables, so apply the mapping to the entries + -- of a CmmData too. -shortcutStatic fn (CmmStaticLit (CmmLabel lab)) - | Just uq <- maybeAsmTemp lab - = CmmStaticLit (CmmLabel (shortBlockId fn (mkBlockId uq))) +shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel +shortcutLabel fn lab + | Just uq <- maybeAsmTemp lab = shortBlockId fn (mkBlockId uq) + | otherwise = lab +shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic +shortcutStatic fn (CmmStaticLit (CmmLabel lab)) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) - | Just uq <- maybeAsmTemp lbl1 - = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn (mkBlockId uq)) lbl2 off) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) -- slightly dodgy, we're ignoring the second label, but this -- works with the way we use CmmLabelDiffOff for jump tables now. - shortcutStatic _ other_static = other_static diff --git a/compiler/nativeGen/PprInstruction.hs b/compiler/nativeGen/PprInstruction.hs new file mode 100644 index 0000000000..6c19160e35 --- /dev/null +++ b/compiler/nativeGen/PprInstruction.hs @@ -0,0 +1,2 @@ + + pprInstruction :: Platform -> instr -> SDoc diff --git a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs index 1eaf00f3a2..a499e1d562 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs @@ -27,8 +27,8 @@ import Data.List -- the same and the move instruction safely erased. regCoalesce :: Instruction instr - => [LiveCmmTop instr] - -> UniqSM [LiveCmmTop instr] + => [LiveCmmTop statics instr] + -> UniqSM [LiveCmmTop statics instr] regCoalesce code = do @@ -61,7 +61,7 @@ sinkReg fm r -- then we can rename the two regs to the same thing and eliminate the move. slurpJoinMovs :: Instruction instr - => LiveCmmTop instr + => LiveCmmTop statics instr -> Bag (Reg, Reg) slurpJoinMovs live diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs index cdbe98755a..5321a34695 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Main.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs @@ -28,6 +28,7 @@ import UniqSet import UniqFM import Bag import Outputable +import Platform import DynFlags import Data.List @@ -44,12 +45,12 @@ maxSpinCount = 10 -- | The top level of the graph coloring register allocator. regAlloc - :: (Outputable instr, Instruction instr) + :: (Outputable statics, PlatformOutputable instr, Instruction instr) => DynFlags -> UniqFM (UniqSet RealReg) -- ^ the registers we can use for allocation -> UniqSet Int -- ^ the set of available spill slots. - -> [LiveCmmTop instr] -- ^ code annotated with liveness information. - -> UniqSM ( [NatCmmTop instr], [RegAllocStats instr] ) + -> [LiveCmmTop statics instr] -- ^ code annotated with liveness information. + -> UniqSM ( [NatCmmTop statics instr], [RegAllocStats statics instr] ) -- ^ code with registers allocated and stats for each stage of -- allocation @@ -58,9 +59,10 @@ regAlloc dflags regsFree slotsFree code -- TODO: the regClass function is currently hard coded to the default target -- architecture. Would prefer to determine this from dflags. -- There are other uses of targetRegClass later in this module. - let triv = trivColorable - targetVirtualRegSqueeze - targetRealRegSqueeze + let platform = targetPlatform dflags + triv = trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform) (code_final, debug_codeGraphs, _) <- regAlloc_spin dflags 0 @@ -79,6 +81,7 @@ regAlloc_spin debug_codeGraphs code = do + let platform = targetPlatform dflags -- if any of these dump flags are turned on we want to hang on to -- intermediate structures in the allocator - otherwise tell the -- allocator to ditch them early so we don't end up creating space leaks. @@ -111,7 +114,7 @@ regAlloc_spin -- build a map of the cost of spilling each instruction -- this will only actually be computed if we have to spill something. let spillCosts = foldl' plusSpillCostInfo zeroSpillCostInfo - $ map slurpSpillCostInfo code + $ map (slurpSpillCostInfo platform) code -- the function to choose regs to leave uncolored let spill = chooseSpill spillCosts @@ -159,14 +162,14 @@ regAlloc_spin else graph_colored -- patch the registers using the info in the graph - let code_patched = map (patchRegsFromGraph graph_colored_lint) code_coalesced + let code_patched = map (patchRegsFromGraph platform graph_colored_lint) code_coalesced -- clean out unneeded SPILL/RELOADs - let code_spillclean = map cleanSpills code_patched + let code_spillclean = map (cleanSpills platform) code_patched -- strip off liveness information, -- and rewrite SPILL/RELOAD pseudos into real instructions along the way - let code_final = map stripLive code_spillclean + let code_final = map (stripLive platform) code_spillclean -- record what happened in this stage for debugging let stat = @@ -211,7 +214,7 @@ regAlloc_spin -- NOTE: we have to reverse the SCCs here to get them back into the reverse-dependency -- order required by computeLiveness. If they're not in the correct order -- that function will panic. - code_relive <- mapM (regLiveness . reverseBlocksInTops) code_spilled + code_relive <- mapM (regLiveness platform . reverseBlocksInTops) code_spilled -- record what happened in this stage for debugging let stat = @@ -239,7 +242,7 @@ regAlloc_spin -- | Build a graph from the liveness and coalesce information in this code. buildGraph :: Instruction instr - => [LiveCmmTop instr] + => [LiveCmmTop statics instr] -> UniqSM (Color.Graph VirtualReg RegClass RealReg) buildGraph code @@ -320,11 +323,11 @@ graphAddCoalesce _ _ -- | Patch registers in code using the reg -> reg mapping in this graph. patchRegsFromGraph - :: (Outputable instr, Instruction instr) - => Color.Graph VirtualReg RegClass RealReg - -> LiveCmmTop instr -> LiveCmmTop instr + :: (Outputable statics, PlatformOutputable instr, Instruction instr) + => Platform -> Color.Graph VirtualReg RegClass RealReg + -> LiveCmmTop statics instr -> LiveCmmTop statics instr -patchRegsFromGraph graph code +patchRegsFromGraph platform graph code = let -- a function to lookup the hardreg for a virtual reg from the graph. patchF reg @@ -343,12 +346,12 @@ patchRegsFromGraph graph code | otherwise = pprPanic "patchRegsFromGraph: register mapping failed." ( text "There is no node in the graph for register " <> ppr reg - $$ ppr code + $$ pprPlatform platform code $$ Color.dotGraph (\_ -> text "white") - (trivColorable - targetVirtualRegSqueeze - targetRealRegSqueeze) + (trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) graph) in patchEraseLive patchF code diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs index 4eabb3b0b4..c4fb783688 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs @@ -41,13 +41,13 @@ import qualified Data.Set as Set -- regSpill :: Instruction instr - => [LiveCmmTop instr] -- ^ the code + => [LiveCmmTop statics instr] -- ^ the code -> UniqSet Int -- ^ available stack slots -> UniqSet VirtualReg -- ^ the regs to spill -> UniqSM - ([LiveCmmTop instr] -- code with SPILL and RELOAD meta instructions added. - , UniqSet Int -- left over slots - , SpillStats ) -- stats about what happened during spilling + ([LiveCmmTop statics instr] -- code with SPILL and RELOAD meta instructions added. + , UniqSet Int -- left over slots + , SpillStats ) -- stats about what happened during spilling regSpill code slotsFree regs @@ -81,8 +81,8 @@ regSpill code slotsFree regs regSpill_top :: Instruction instr => RegMap Int -- ^ map of vregs to slots they're being spilled to. - -> LiveCmmTop instr -- ^ the top level thing. - -> SpillM (LiveCmmTop instr) + -> LiveCmmTop statics instr -- ^ the top level thing. + -> SpillM (LiveCmmTop statics instr) regSpill_top regSlotMap cmm = case cmm of diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs index 38c33b708a..da13eab045 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs @@ -39,6 +39,7 @@ import UniqFM import Unique import State import Outputable +import Platform import Data.List import Data.Maybe @@ -52,22 +53,23 @@ type Slot = Int -- | Clean out unneeded spill\/reloads from this top level thing. -cleanSpills - :: Instruction instr - => LiveCmmTop instr -> LiveCmmTop instr +cleanSpills + :: Instruction instr + => Platform -> LiveCmmTop statics instr -> LiveCmmTop statics instr -cleanSpills cmm - = evalState (cleanSpin 0 cmm) initCleanS +cleanSpills platform cmm + = evalState (cleanSpin platform 0 cmm) initCleanS -- | do one pass of cleaning -cleanSpin - :: Instruction instr - => Int - -> LiveCmmTop instr - -> CleanM (LiveCmmTop instr) +cleanSpin + :: Instruction instr + => Platform + -> Int + -> LiveCmmTop statics instr + -> CleanM (LiveCmmTop statics instr) {- -cleanSpin spinCount code +cleanSpin _ spinCount code = do jumpValid <- gets sJumpValid pprTrace "cleanSpin" ( int spinCount @@ -78,7 +80,7 @@ cleanSpin spinCount code $ cleanSpin' spinCount code -} -cleanSpin spinCount code +cleanSpin platform spinCount code = do -- init count of cleaned spills\/reloads modify $ \s -> s @@ -86,7 +88,7 @@ cleanSpin spinCount code , sCleanedReloadsAcc = 0 , sReloadedBy = emptyUFM } - code_forward <- mapBlockTopM cleanBlockForward code + code_forward <- mapBlockTopM (cleanBlockForward platform) code code_backward <- cleanTopBackward code_forward -- During the cleaning of each block we collected information about what regs @@ -107,16 +109,17 @@ cleanSpin spinCount code then return code -- otherwise go around again - else cleanSpin (spinCount + 1) code_backward + else cleanSpin platform (spinCount + 1) code_backward -- | Clean one basic block -cleanBlockForward - :: Instruction instr - => LiveBasicBlock instr - -> CleanM (LiveBasicBlock instr) +cleanBlockForward + :: Instruction instr + => Platform + -> LiveBasicBlock instr + -> CleanM (LiveBasicBlock instr) -cleanBlockForward (BasicBlock blockId instrs) +cleanBlockForward platform (BasicBlock blockId instrs) = do -- see if we have a valid association for the entry to this block jumpValid <- gets sJumpValid @@ -124,7 +127,7 @@ cleanBlockForward (BasicBlock blockId instrs) Just assoc -> assoc Nothing -> emptyAssoc - instrs_reload <- cleanForward blockId assoc [] instrs + instrs_reload <- cleanForward platform blockId assoc [] instrs return $ BasicBlock blockId instrs_reload @@ -135,37 +138,38 @@ cleanBlockForward (BasicBlock blockId instrs) -- then we don't need to do the reload. -- cleanForward - :: Instruction instr - => BlockId -- ^ the block that we're currently in - -> Assoc Store -- ^ two store locations are associated if they have the same value - -> [LiveInstr instr] -- ^ acc - -> [LiveInstr instr] -- ^ instrs to clean (in backwards order) - -> CleanM [LiveInstr instr] -- ^ cleaned instrs (in forward order) - -cleanForward _ _ acc [] + :: Instruction instr + => Platform + -> BlockId -- ^ the block that we're currently in + -> Assoc Store -- ^ two store locations are associated if they have the same value + -> [LiveInstr instr] -- ^ acc + -> [LiveInstr instr] -- ^ instrs to clean (in backwards order) + -> CleanM [LiveInstr instr] -- ^ cleaned instrs (in forward order) + +cleanForward _ _ _ acc [] = return acc -- write out live range joins via spill slots to just a spill and a reg-reg move -- hopefully the spill will be also be cleaned in the next pass -- -cleanForward blockId assoc acc (li1 : li2 : instrs) +cleanForward platform blockId assoc acc (li1 : li2 : instrs) | LiveInstr (SPILL reg1 slot1) _ <- li1 , LiveInstr (RELOAD slot2 reg2) _ <- li2 , slot1 == slot2 = do modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 } - cleanForward blockId assoc acc - (li1 : LiveInstr (mkRegRegMoveInstr reg1 reg2) Nothing : instrs) + cleanForward platform blockId assoc acc + (li1 : LiveInstr (mkRegRegMoveInstr platform reg1 reg2) Nothing : instrs) -cleanForward blockId assoc acc (li@(LiveInstr i1 _) : instrs) +cleanForward platform blockId assoc acc (li@(LiveInstr i1 _) : instrs) | Just (r1, r2) <- takeRegRegMoveInstr i1 = if r1 == r2 -- erase any left over nop reg reg moves while we're here -- this will also catch any nop moves that the "write out live range joins" case above -- happens to add - then cleanForward blockId assoc acc instrs + then cleanForward platform blockId assoc acc instrs -- if r1 has the same value as some slots and we copy r1 to r2, -- then r2 is now associated with those slots instead @@ -173,50 +177,51 @@ cleanForward blockId assoc acc (li@(LiveInstr i1 _) : instrs) $ delAssoc (SReg r2) $ assoc - cleanForward blockId assoc' (li : acc) instrs + cleanForward platform blockId assoc' (li : acc) instrs -cleanForward blockId assoc acc (li : instrs) +cleanForward platform blockId assoc acc (li : instrs) -- update association due to the spill | LiveInstr (SPILL reg slot) _ <- li = let assoc' = addAssoc (SReg reg) (SSlot slot) $ delAssoc (SSlot slot) $ assoc - in cleanForward blockId assoc' (li : acc) instrs + in cleanForward platform blockId assoc' (li : acc) instrs -- clean a reload instr | LiveInstr (RELOAD{}) _ <- li - = do (assoc', mli) <- cleanReload blockId assoc li + = do (assoc', mli) <- cleanReload platform blockId assoc li case mli of - Nothing -> cleanForward blockId assoc' acc instrs - Just li' -> cleanForward blockId assoc' (li' : acc) instrs + Nothing -> cleanForward platform blockId assoc' acc instrs + Just li' -> cleanForward platform blockId assoc' (li' : acc) instrs -- remember the association over a jump | LiveInstr instr _ <- li , targets <- jumpDestsOfInstr instr , not $ null targets = do mapM_ (accJumpValid assoc) targets - cleanForward blockId assoc (li : acc) instrs + cleanForward platform blockId assoc (li : acc) instrs -- writing to a reg changes its value. | LiveInstr instr _ <- li , RU _ written <- regUsageOfInstr instr = let assoc' = foldr delAssoc assoc (map SReg $ nub written) - in cleanForward blockId assoc' (li : acc) instrs + in cleanForward platform blockId assoc' (li : acc) instrs -- | Try and rewrite a reload instruction to something more pleasing -- -cleanReload - :: Instruction instr - => BlockId - -> Assoc Store - -> LiveInstr instr - -> CleanM (Assoc Store, Maybe (LiveInstr instr)) +cleanReload + :: Instruction instr + => Platform + -> BlockId + -> Assoc Store + -> LiveInstr instr + -> CleanM (Assoc Store, Maybe (LiveInstr instr)) -cleanReload blockId assoc li@(LiveInstr (RELOAD slot reg) _) +cleanReload platform blockId assoc li@(LiveInstr (RELOAD slot reg) _) -- if the reg we're reloading already has the same value as the slot -- then we can erase the instruction outright @@ -233,7 +238,7 @@ cleanReload blockId assoc li@(LiveInstr (RELOAD slot reg) _) $ delAssoc (SReg reg) $ assoc - return (assoc', Just $ LiveInstr (mkRegRegMoveInstr reg2 reg) Nothing) + return (assoc', Just $ LiveInstr (mkRegRegMoveInstr platform reg2 reg) Nothing) -- gotta keep this instr | otherwise @@ -247,7 +252,7 @@ cleanReload blockId assoc li@(LiveInstr (RELOAD slot reg) _) return (assoc', Just li) -cleanReload _ _ _ +cleanReload _ _ _ _ = panic "RegSpillClean.cleanReload: unhandled instr" @@ -282,8 +287,8 @@ cleanReload _ _ _ -- cleanTopBackward :: Instruction instr - => LiveCmmTop instr - -> CleanM (LiveCmmTop instr) + => LiveCmmTop statics instr + -> CleanM (LiveCmmTop statics instr) cleanTopBackward cmm = case cmm of diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs index 330a410312..3ea150a3df 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs @@ -29,6 +29,7 @@ import UniqFM import UniqSet import Digraph (flattenSCCs) import Outputable +import Platform import State import Data.List (nub, minimumBy) @@ -62,12 +63,12 @@ plusSpillCostRecord (r1, a1, b1, c1) (r2, a2, b2, c2) -- for each vreg, the number of times it was written to, read from, -- and the number of instructions it was live on entry to (lifetime) -- -slurpSpillCostInfo - :: (Outputable instr, Instruction instr) - => LiveCmmTop instr - -> SpillCostInfo +slurpSpillCostInfo :: (PlatformOutputable instr, Instruction instr) + => Platform + -> LiveCmmTop statics instr + -> SpillCostInfo -slurpSpillCostInfo cmm +slurpSpillCostInfo platform cmm = execState (countCmm cmm) zeroSpillCostInfo where countCmm CmmData{} = return () @@ -96,7 +97,7 @@ slurpSpillCostInfo cmm | otherwise = pprPanic "RegSpillCost.slurpSpillCostInfo" - (text "no liveness information on instruction " <> ppr instr) + (text "no liveness information on instruction " <> pprPlatform platform instr) countLIs rsLiveEntry (LiveInstr instr (Just live) : lis) = do diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs index 5ff7bff91a..15ec6e7f87 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs @@ -36,56 +36,56 @@ import State import Data.List -data RegAllocStats instr +data RegAllocStats statics instr -- initial graph = RegAllocStatsStart - { raLiveCmm :: [LiveCmmTop instr] -- ^ initial code, with liveness + { raLiveCmm :: [LiveCmmTop 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 :: [LiveCmmTop instr] -- ^ the code we tried to allocate registers for + { raCode :: [LiveCmmTop 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 :: [LiveCmmTop instr] } -- ^ code with spill instructions added + , raSpilled :: [LiveCmmTop statics instr] } -- ^ code with spill instructions added -- a successful coloring | RegAllocStatsColored - { raCode :: [LiveCmmTop instr] -- ^ the code we tried to allocate registers for + { raCode :: [LiveCmmTop 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 :: [LiveCmmTop instr] -- ^ code with coalescings applied - , raPatched :: [LiveCmmTop instr] -- ^ code with vregs replaced by hregs - , raSpillClean :: [LiveCmmTop instr] -- ^ code with unneeded spill\/reloads cleaned out - , raFinal :: [NatCmmTop instr] -- ^ final code + , raCodeCoalesced :: [LiveCmmTop statics instr] -- ^ code with coalescings applied + , raPatched :: [LiveCmmTop statics instr] -- ^ code with vregs replaced by hregs + , raSpillClean :: [LiveCmmTop statics instr] -- ^ code with unneeded spill\/reloads cleaned out + , raFinal :: [NatCmmTop statics instr] -- ^ final code , raSRMs :: (Int, Int, Int) } -- ^ spill\/reload\/reg-reg moves present in this code -instance Outputable instr => Outputable (RegAllocStats instr) where +instance (Outputable statics, PlatformOutputable instr) => PlatformOutputable (RegAllocStats statics instr) where - ppr (s@RegAllocStatsStart{}) + pprPlatform platform (s@RegAllocStatsStart{}) = text "# Start" $$ text "# Native code with liveness information." - $$ ppr (raLiveCmm s) + $$ pprPlatform platform (raLiveCmm s) $$ text "" $$ text "# Initial register conflict graph." $$ Color.dotGraph - targetRegDotColor - (trivColorable - targetVirtualRegSqueeze - targetRealRegSqueeze) + (targetRegDotColor platform) + (trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) (raGraph s) - ppr (s@RegAllocStatsSpill{}) + pprPlatform platform (s@RegAllocStatsSpill{}) = text "# Spill" $$ text "# Code with liveness information." - $$ (ppr (raCode s)) + $$ pprPlatform platform (raCode s) $$ text "" $$ (if (not $ isNullUFM $ raCoalesced s) @@ -99,22 +99,22 @@ instance Outputable instr => Outputable (RegAllocStats instr) where $$ text "" $$ text "# Code with spills inserted." - $$ (ppr (raSpilled s)) + $$ pprPlatform platform (raSpilled s) - ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) + pprPlatform platform (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) = text "# Colored" $$ text "# Code with liveness information." - $$ (ppr (raCode s)) + $$ pprPlatform platform (raCode s) $$ text "" $$ text "# Register conflict graph (colored)." $$ Color.dotGraph - targetRegDotColor - (trivColorable - targetVirtualRegSqueeze - targetRealRegSqueeze) + (targetRegDotColor platform) + (trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) (raGraphColored s) $$ text "" @@ -125,19 +125,19 @@ instance Outputable instr => Outputable (RegAllocStats instr) where else empty) $$ text "# Native code after coalescings applied." - $$ ppr (raCodeCoalesced s) + $$ pprPlatform platform (raCodeCoalesced s) $$ text "" $$ text "# Native code after register allocation." - $$ ppr (raPatched s) + $$ pprPlatform platform (raPatched s) $$ text "" $$ text "# Clean out unneeded spill/reloads." - $$ ppr (raSpillClean s) + $$ pprPlatform platform (raSpillClean s) $$ text "" $$ text "# Final code, after rewriting spill/rewrite pseudo instrs." - $$ ppr (raFinal s) + $$ pprPlatform platform (raFinal s) $$ text "" $$ text "# Score:" $$ (text "# spills inserted: " <> int spills) @@ -147,7 +147,7 @@ instance Outputable instr => Outputable (RegAllocStats instr) where -- | Do all the different analysis on this list of RegAllocStats pprStats - :: [RegAllocStats instr] + :: [RegAllocStats statics instr] -> Color.Graph VirtualReg RegClass RealReg -> SDoc @@ -162,7 +162,7 @@ pprStats stats graph -- | Dump a table of how many spill loads \/ stores were inserted for each vreg. pprStatsSpills - :: [RegAllocStats instr] -> SDoc + :: [RegAllocStats statics instr] -> SDoc pprStatsSpills stats = let @@ -180,7 +180,7 @@ pprStatsSpills stats -- | Dump a table of how long vregs tend to live for in the initial code. pprStatsLifetimes - :: [RegAllocStats instr] -> SDoc + :: [RegAllocStats statics instr] -> SDoc pprStatsLifetimes stats = let info = foldl' plusSpillCostInfo zeroSpillCostInfo @@ -208,7 +208,7 @@ binLifetimeCount fm -- | Dump a table of how many conflicts vregs tend to have in the initial code. pprStatsConflict - :: [RegAllocStats instr] -> SDoc + :: [RegAllocStats statics instr] -> SDoc pprStatsConflict stats = let confMap = foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2))) @@ -225,7 +225,7 @@ pprStatsConflict stats -- | For every vreg, dump it's how many conflicts it has and its lifetime -- good for making a scatter plot. pprStatsLifeConflict - :: [RegAllocStats instr] + :: [RegAllocStats statics instr] -> Color.Graph VirtualReg RegClass RealReg -- ^ global register conflict graph -> SDoc @@ -256,7 +256,7 @@ pprStatsLifeConflict stats graph -- Lets us see how well the register allocator has done. countSRMs :: Instruction instr - => LiveCmmTop instr -> (Int, Int, Int) + => LiveCmmTop statics instr -> (Int, Int, Int) countSRMs cmm = execState (mapBlockTopM countSRM_block cmm) (0, 0, 0) diff --git a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs index 802f847f11..e62b4a9abb 100644 --- a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs +++ b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs @@ -98,18 +98,15 @@ the most efficient variant tried. Benchmark compiling 10-times SHA1.lhs follows. 100.00% 166.23% 94.18% 100.95% -} --- TODO: We shouldn't be using defaultTargetPlatform here. --- We should be passing DynFlags in instead, and looking at --- its targetPlatform. - trivColorable - :: (RegClass -> VirtualReg -> FastInt) + :: Platform + -> (RegClass -> VirtualReg -> FastInt) -> (RegClass -> RealReg -> FastInt) -> Triv VirtualReg RegClass RealReg -trivColorable virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions +trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions | let !cALLOCATABLE_REGS_INTEGER - = iUnbox (case platformArch defaultTargetPlatform of + = iUnbox (case platformArch platform of ArchX86 -> 3 ArchX86_64 -> 5 ArchPPC -> 16 @@ -127,9 +124,9 @@ trivColorable virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions = count3 <# cALLOCATABLE_REGS_INTEGER -trivColorable virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions +trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions | let !cALLOCATABLE_REGS_FLOAT - = iUnbox (case platformArch defaultTargetPlatform of + = iUnbox (case platformArch platform of ArchX86 -> 0 ArchX86_64 -> 0 ArchPPC -> 0 @@ -147,9 +144,9 @@ trivColorable virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions = count3 <# cALLOCATABLE_REGS_FLOAT -trivColorable virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions +trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions | let !cALLOCATABLE_REGS_DOUBLE - = iUnbox (case platformArch defaultTargetPlatform of + = iUnbox (case platformArch platform of ArchX86 -> 6 ArchX86_64 -> 0 ArchPPC -> 26 @@ -167,9 +164,9 @@ trivColorable virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions = count3 <# cALLOCATABLE_REGS_DOUBLE -trivColorable virtualRegSqueeze realRegSqueeze RcDoubleSSE conflicts exclusions +trivColorable platform virtualRegSqueeze realRegSqueeze RcDoubleSSE conflicts exclusions | let !cALLOCATABLE_REGS_SSE - = iUnbox (case platformArch defaultTargetPlatform of + = iUnbox (case platformArch platform of ArchX86 -> 8 ArchX86_64 -> 10 ArchPPC -> 0 diff --git a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs index 07cfc0f825..5a413d341e 100644 --- a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs @@ -58,12 +58,9 @@ instance FR SPARC.FreeRegs where frInitFreeRegs = SPARC.initFreeRegs frReleaseReg = SPARC.releaseReg --- TODO: We shouldn't be using defaultTargetPlatform here. --- We should be passing DynFlags in instead, and looking at --- its targetPlatform. - -maxSpillSlots :: Int -maxSpillSlots = case platformArch defaultTargetPlatform of +maxSpillSlots :: Platform -> Int +maxSpillSlots platform + = case platformArch platform of ArchX86 -> X86.Instr.maxSpillSlots ArchX86_64 -> X86.Instr.maxSpillSlots ArchPPC -> PPC.Instr.maxSpillSlots diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs index e6a078a05e..ba07e61871 100644 --- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs +++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs @@ -24,6 +24,7 @@ import BlockId import OldCmm hiding (RegSet) import Digraph import Outputable +import Platform import Unique import UniqFM import UniqSet @@ -34,7 +35,8 @@ import UniqSet -- joinToTargets :: (FR freeRegs, Instruction instr) - => BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs + => Platform + -> BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs -- that are known to be live on the entry to each block. -> BlockId -- ^ id of the current block @@ -44,19 +46,20 @@ joinToTargets , instr) -- the original branch instruction, but maybe patched to jump -- to a fixup block first. -joinToTargets block_live id instr +joinToTargets platform block_live id instr -- we only need to worry about jump instructions. | not $ isJumpishInstr instr = return ([], instr) | otherwise - = joinToTargets' block_live [] id instr (jumpDestsOfInstr instr) + = joinToTargets' platform block_live [] id instr (jumpDestsOfInstr instr) ----- joinToTargets' :: (FR freeRegs, Instruction instr) - => BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs + => Platform + -> BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs -- that are known to be live on the entry to each block. -> [NatBasicBlock instr] -- ^ acc blocks of fixup code. @@ -70,11 +73,11 @@ joinToTargets' , instr) -- no more targets to consider. all done. -joinToTargets' _ new_blocks _ instr [] +joinToTargets' _ _ new_blocks _ instr [] = return (new_blocks, instr) -- handle a branch target. -joinToTargets' block_live new_blocks block_id instr (dest:dests) +joinToTargets' platform block_live new_blocks block_id instr (dest:dests) = do -- get the map of where the vregs are stored on entry to each basic block. block_assig <- getBlockAssigR @@ -97,18 +100,19 @@ joinToTargets' block_live new_blocks block_id instr (dest:dests) case mapLookup dest block_assig of Nothing -> joinToTargets_first - block_live new_blocks block_id instr dest dests + platform block_live new_blocks block_id instr dest dests block_assig adjusted_assig to_free Just (_, dest_assig) -> joinToTargets_again - block_live new_blocks block_id instr dest dests + platform block_live new_blocks block_id instr dest dests adjusted_assig dest_assig -- this is the first time we jumped to this block. joinToTargets_first :: (FR freeRegs, Instruction instr) - => BlockMap RegSet + => Platform + -> BlockMap RegSet -> [NatBasicBlock instr] -> BlockId -> instr @@ -118,7 +122,7 @@ joinToTargets_first :: (FR freeRegs, Instruction instr) -> RegMap Loc -> [RealReg] -> RegM freeRegs ([NatBasicBlock instr], instr) -joinToTargets_first block_live new_blocks block_id instr dest dests +joinToTargets_first platform block_live new_blocks block_id instr dest dests block_assig src_assig to_free @@ -129,12 +133,13 @@ joinToTargets_first block_live new_blocks block_id instr dest dests -- remember the current assignment on entry to this block. setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig) - joinToTargets' block_live new_blocks block_id instr dests + joinToTargets' platform block_live new_blocks block_id instr dests -- we've jumped to this block before joinToTargets_again :: (Instruction instr, FR freeRegs) - => BlockMap RegSet + => Platform + -> BlockMap RegSet -> [NatBasicBlock instr] -> BlockId -> instr @@ -143,13 +148,13 @@ joinToTargets_again :: (Instruction instr, FR freeRegs) -> UniqFM Loc -> UniqFM Loc -> RegM freeRegs ([NatBasicBlock instr], instr) -joinToTargets_again - block_live new_blocks block_id instr dest dests - src_assig dest_assig +joinToTargets_again + platform block_live new_blocks block_id instr dest dests + src_assig dest_assig -- the assignments already match, no problem. | ufmToList dest_assig == ufmToList src_assig - = joinToTargets' block_live new_blocks block_id instr dests + = joinToTargets' platform block_live new_blocks block_id instr dests -- assignments don't match, need fixup code | otherwise @@ -184,7 +189,7 @@ joinToTargets_again (return ()) -} delta <- getDeltaR - fixUpInstrs_ <- mapM (handleComponent delta instr) sccs + fixUpInstrs_ <- mapM (handleComponent platform delta instr) sccs let fixUpInstrs = concat fixUpInstrs_ -- make a new basic block containing the fixup code. @@ -202,7 +207,7 @@ joinToTargets_again -} -- if we didn't need any fixups, then don't include the block case fixUpInstrs of - [] -> joinToTargets' block_live new_blocks block_id instr dests + [] -> joinToTargets' platform block_live new_blocks block_id instr dests -- patch the original branch instruction so it goes to our -- fixup block instead. @@ -211,7 +216,7 @@ joinToTargets_again then mkBlockId fixup_block_id else bid) -- no change! - in joinToTargets' block_live (block : new_blocks) block_id instr' dests + in joinToTargets' platform block_live (block : new_blocks) block_id instr' dests -- | Construct a graph of register\/spill movements. @@ -281,14 +286,14 @@ expandNode vreg src dst -- handleComponent :: Instruction instr - => Int -> instr -> SCC (Unique, Loc, [Loc]) -> RegM freeRegs [instr] + => Platform -> Int -> instr -> SCC (Unique, Loc, [Loc]) -> RegM freeRegs [instr] -- If the graph is acyclic then we won't get the swapping problem below. -- In this case we can just do the moves directly, and avoid having to -- go via a spill slot. -- -handleComponent delta _ (AcyclicSCC (vreg, src, dsts)) - = mapM (makeMove delta vreg src) dsts +handleComponent platform delta _ (AcyclicSCC (vreg, src, dsts)) + = mapM (makeMove platform delta vreg src) dsts -- Handle some cyclic moves. @@ -306,53 +311,54 @@ handleComponent delta _ (AcyclicSCC (vreg, src, dsts)) -- are allocated exclusively for a virtual register and therefore can not -- require a fixup. -- -handleComponent delta instr +handleComponent platform delta instr (CyclicSCC ( (vreg, InReg sreg, (InReg dreg: _)) : rest)) -- dest list may have more than one element, if the reg is also InMem. = do -- spill the source into its slot (instrSpill, slot) - <- spillR (RegReal sreg) vreg + <- spillR platform (RegReal sreg) vreg -- reload into destination reg - instrLoad <- loadR (RegReal dreg) slot + instrLoad <- loadR platform (RegReal dreg) slot - remainingFixUps <- mapM (handleComponent delta instr) + remainingFixUps <- mapM (handleComponent platform delta instr) (stronglyConnCompFromEdgedVerticesR rest) -- make sure to do all the reloads after all the spills, -- so we don't end up clobbering the source values. return ([instrSpill] ++ concat remainingFixUps ++ [instrLoad]) -handleComponent _ _ (CyclicSCC _) +handleComponent _ _ _ (CyclicSCC _) = panic "Register Allocator: handleComponent cyclic" -- | Move a vreg between these two locations. -- -makeMove - :: Instruction instr - => Int -- ^ current C stack delta. - -> Unique -- ^ unique of the vreg that we're moving. - -> Loc -- ^ source location. - -> Loc -- ^ destination location. - -> RegM freeRegs instr -- ^ move instruction. - -makeMove _ vreg (InReg src) (InReg dst) - = do recordSpill (SpillJoinRR vreg) - return $ mkRegRegMoveInstr (RegReal src) (RegReal dst) - -makeMove delta vreg (InMem src) (InReg dst) - = do recordSpill (SpillJoinRM vreg) - return $ mkLoadInstr (RegReal dst) delta src - -makeMove delta vreg (InReg src) (InMem dst) - = do recordSpill (SpillJoinRM vreg) - return $ mkSpillInstr (RegReal src) delta dst +makeMove + :: Instruction instr + => Platform + -> Int -- ^ current C stack delta. + -> Unique -- ^ unique of the vreg that we're moving. + -> Loc -- ^ source location. + -> Loc -- ^ destination location. + -> RegM freeRegs instr -- ^ move instruction. + +makeMove platform _ vreg (InReg src) (InReg dst) + = do recordSpill (SpillJoinRR vreg) + return $ mkRegRegMoveInstr platform (RegReal src) (RegReal dst) + +makeMove platform delta vreg (InMem src) (InReg dst) + = do recordSpill (SpillJoinRM vreg) + return $ mkLoadInstr platform (RegReal dst) delta src + +makeMove platform delta vreg (InReg src) (InMem dst) + = do recordSpill (SpillJoinRM vreg) + return $ mkSpillInstr platform (RegReal src) delta dst -- we don't handle memory to memory moves. -- they shouldn't happen because we don't share stack slots between vregs. -makeMove _ vreg src dst +makeMove _ _ vreg src dst = panic $ "makeMove " ++ show vreg ++ " (" ++ show src ++ ") (" ++ show dst ++ ")" ++ " we don't handle mem->mem moves." diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index 3682ffbe1d..8fa758d063 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -127,10 +127,10 @@ import Control.Monad -- Allocate registers regAlloc - :: (Outputable instr, Instruction instr) + :: (PlatformOutputable instr, Instruction instr) => DynFlags - -> LiveCmmTop instr - -> UniqSM (NatCmmTop instr, Maybe RegAllocStats) + -> LiveCmmTop statics instr + -> UniqSM (NatCmmTop statics instr, Maybe RegAllocStats) regAlloc _ (CmmData sec d) = return @@ -170,7 +170,7 @@ regAlloc _ (CmmProc _ _ _) -- an entry in the block map or it is the first block. -- linearRegAlloc - :: (Outputable instr, Instruction instr) + :: (PlatformOutputable instr, Instruction instr) => DynFlags -> BlockId -- ^ the first block -> BlockMap RegSet -- ^ live regs on entry to each basic block @@ -178,51 +178,54 @@ linearRegAlloc -> UniqSM ([NatBasicBlock instr], RegAllocStats) linearRegAlloc dflags first_id block_live sccs - = case platformArch $ targetPlatform dflags of - ArchX86 -> linearRegAlloc' (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs - ArchX86_64 -> linearRegAlloc' (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs - ArchSPARC -> linearRegAlloc' (frInitFreeRegs :: SPARC.FreeRegs) first_id block_live sccs - ArchPPC -> linearRegAlloc' (frInitFreeRegs :: PPC.FreeRegs) first_id block_live sccs - ArchARM -> panic "linearRegAlloc ArchARM" - ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64" - ArchUnknown -> panic "linearRegAlloc ArchUnknown" + = let platform = targetPlatform dflags + in case platformArch platform of + ArchX86 -> linearRegAlloc' platform (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs + ArchX86_64 -> linearRegAlloc' platform (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs + ArchSPARC -> linearRegAlloc' platform (frInitFreeRegs :: SPARC.FreeRegs) first_id block_live sccs + ArchPPC -> linearRegAlloc' platform (frInitFreeRegs :: PPC.FreeRegs) first_id block_live sccs + ArchARM -> panic "linearRegAlloc ArchARM" + ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64" + ArchUnknown -> panic "linearRegAlloc ArchUnknown" linearRegAlloc' - :: (FR freeRegs, Outputable instr, Instruction instr) - => freeRegs + :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + => Platform + -> freeRegs -> 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) -linearRegAlloc' initFreeRegs first_id block_live sccs +linearRegAlloc' platform initFreeRegs first_id block_live sccs = do us <- getUs let (_, _, stats, blocks) = - runR emptyBlockMap initFreeRegs emptyRegMap emptyStackMap us - $ linearRA_SCCs first_id block_live [] sccs + runR emptyBlockMap initFreeRegs emptyRegMap (emptyStackMap platform) us + $ linearRA_SCCs platform first_id block_live [] sccs return (blocks, stats) -linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr) - => BlockId +linearRA_SCCs :: (FR freeRegs, Instruction instr, PlatformOutputable instr) + => Platform + -> BlockId -> BlockMap RegSet -> [NatBasicBlock instr] -> [SCC (LiveBasicBlock instr)] -> RegM freeRegs [NatBasicBlock instr] -linearRA_SCCs _ _ blocksAcc [] +linearRA_SCCs _ _ _ blocksAcc [] = return $ reverse blocksAcc -linearRA_SCCs first_id block_live blocksAcc (AcyclicSCC block : sccs) - = do blocks' <- processBlock block_live block - linearRA_SCCs first_id block_live +linearRA_SCCs platform first_id block_live blocksAcc (AcyclicSCC block : sccs) + = do blocks' <- processBlock platform block_live block + linearRA_SCCs platform first_id block_live ((reverse blocks') ++ blocksAcc) sccs -linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs) +linearRA_SCCs platform first_id block_live blocksAcc (CyclicSCC blocks : sccs) = do - blockss' <- process first_id block_live blocks [] (return []) False - linearRA_SCCs first_id block_live + blockss' <- process platform first_id block_live blocks [] (return []) False + linearRA_SCCs platform first_id block_live (reverse (concat blockss') ++ blocksAcc) sccs @@ -238,8 +241,9 @@ linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs) more sanity checking to guard against this eventuality. -} -process :: (FR freeRegs, Instruction instr, Outputable instr) - => BlockId +process :: (FR freeRegs, Instruction instr, PlatformOutputable instr) + => Platform + -> BlockId -> BlockMap RegSet -> [GenBasicBlock (LiveInstr instr)] -> [GenBasicBlock (LiveInstr instr)] @@ -247,10 +251,10 @@ process :: (FR freeRegs, Instruction instr, Outputable instr) -> Bool -> RegM freeRegs [[NatBasicBlock instr]] -process _ _ [] [] accum _ +process _ _ _ [] [] accum _ = return $ reverse accum -process first_id block_live [] next_round accum madeProgress +process platform first_id block_live [] next_round accum madeProgress | not madeProgress {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming. @@ -260,10 +264,10 @@ process first_id block_live [] next_round accum madeProgress = return $ reverse accum | otherwise - = process first_id block_live + = process platform first_id block_live next_round [] accum False -process first_id block_live (b@(BasicBlock id _) : blocks) +process platform first_id block_live (b@(BasicBlock id _) : blocks) next_round accum madeProgress = do block_assig <- getBlockAssigR @@ -271,26 +275,27 @@ process first_id block_live (b@(BasicBlock id _) : blocks) if isJust (mapLookup id block_assig) || id == first_id then do - b' <- processBlock block_live b - process first_id block_live blocks + b' <- processBlock platform block_live b + process platform first_id block_live blocks next_round (b' : accum) True - else process first_id block_live blocks + else process platform first_id block_live blocks (b : next_round) accum madeProgress -- | Do register allocation on this basic block -- processBlock - :: (FR freeRegs, Outputable instr, Instruction instr) - => BlockMap RegSet -- ^ live regs on entry to each basic block + :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + => Platform + -> BlockMap RegSet -- ^ live regs on entry to each basic block -> LiveBasicBlock instr -- ^ block to do register allocation on -> RegM freeRegs [NatBasicBlock instr] -- ^ block with registers allocated -processBlock block_live (BasicBlock id instrs) +processBlock platform block_live (BasicBlock id instrs) = do initBlock id (instrs', fixups) - <- linearRA block_live [] [] id instrs + <- linearRA platform block_live [] [] id instrs return $ BasicBlock id instrs' : fixups @@ -316,8 +321,9 @@ initBlock id -- | Do allocation for a sequence of instructions. linearRA - :: (FR freeRegs, Outputable instr, Instruction instr) - => BlockMap RegSet -- ^ map of what vregs are live on entry to each block. + :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + => Platform + -> BlockMap RegSet -- ^ map of what vregs are live on entry to each block. -> [instr] -- ^ accumulator for instructions already processed. -> [NatBasicBlock instr] -- ^ accumulator for blocks of fixup code. -> BlockId -- ^ id of the current block, for debugging. @@ -328,24 +334,25 @@ linearRA , [NatBasicBlock instr]) -- fresh blocks of fixup code. -linearRA _ accInstr accFixup _ [] +linearRA _ _ accInstr accFixup _ [] = return ( reverse accInstr -- instrs need to be returned in the correct order. , accFixup) -- it doesn't matter what order the fixup blocks are returned in. -linearRA block_live accInstr accFixups id (instr:instrs) +linearRA platform block_live accInstr accFixups id (instr:instrs) = do (accInstr', new_fixups) - <- raInsn block_live accInstr id instr + <- raInsn platform block_live accInstr id instr - linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs + linearRA platform block_live accInstr' (new_fixups ++ accFixups) id instrs -- | Do allocation for a single instruction. raInsn - :: (FR freeRegs, Outputable instr, Instruction instr) - => BlockMap RegSet -- ^ map of what vregs are love on entry to each block. + :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + => Platform + -> BlockMap RegSet -- ^ map of what vregs are love on entry to each block. -> [instr] -- ^ accumulator for instructions already processed. -> BlockId -- ^ the id of the current block, for debugging -> LiveInstr instr -- ^ the instr to have its regs allocated, with liveness info. @@ -353,17 +360,17 @@ raInsn ( [instr] -- new instructions , [NatBasicBlock instr]) -- extra fixup blocks -raInsn _ new_instrs _ (LiveInstr ii Nothing) +raInsn _ _ new_instrs _ (LiveInstr ii Nothing) | Just n <- takeDeltaInstr ii = do setDeltaR n return (new_instrs, []) -raInsn _ new_instrs _ (LiveInstr ii Nothing) +raInsn _ _ new_instrs _ (LiveInstr ii Nothing) | isMetaInstr ii = return (new_instrs, []) -raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) +raInsn platform block_live new_instrs id (LiveInstr (Instr instr) (Just live)) = do assig <- getAssigR @@ -398,17 +405,18 @@ raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) -} return (new_instrs, []) - _ -> genRaInsn block_live new_instrs id instr + _ -> genRaInsn platform block_live new_instrs id instr (uniqSetToList $ liveDieRead live) (uniqSetToList $ liveDieWrite live) -raInsn _ _ _ instr - = pprPanic "raInsn" (text "no match for:" <> ppr instr) +raInsn platform _ _ _ instr + = pprPanic "raInsn" (text "no match for:" <> pprPlatform platform instr) -genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr) - => BlockMap RegSet +genRaInsn :: (FR freeRegs, Instruction instr, PlatformOutputable instr) + => Platform + -> BlockMap RegSet -> [instr] -> BlockId -> instr @@ -416,7 +424,7 @@ genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr) -> [Reg] -> RegM freeRegs ([instr], [NatBasicBlock instr]) -genRaInsn block_live new_instrs block_id instr r_dying w_dying = +genRaInsn platform block_live new_instrs block_id instr r_dying w_dying = case regUsageOfInstr instr of { RU read written -> do let real_written = [ rr | (RegReal rr) <- written ] @@ -428,7 +436,7 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = let virt_read = nub [ vr | (RegVirtual vr) <- read ] -- (a) save any temporaries which will be clobbered by this instruction - clobber_saves <- saveClobberedTemps real_written r_dying + clobber_saves <- saveClobberedTemps platform real_written r_dying -- debugging {- freeregs <- getFreeRegsR @@ -446,14 +454,14 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = -- (b), (c) allocate real regs for all regs read by this instruction. (r_spills, r_allocd) <- - allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read + allocateRegsAndSpill platform True{-reading-} virt_read [] [] virt_read -- (d) Update block map for new destinations -- NB. do this before removing dead regs from the assignment, because -- these dead regs might in fact be live in the jump targets (they're -- only dead in the code that follows in the current basic block). (fixup_blocks, adjusted_instr) - <- joinToTargets block_live block_id instr + <- joinToTargets platform block_live block_id instr -- (e) Delete all register assignments for temps which are read -- (only) and die here. Update the free register list. @@ -464,7 +472,7 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = -- (g) Allocate registers for temporaries *written* (only) (w_spills, w_allocd) <- - allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written + allocateRegsAndSpill platform False{-writing-} virt_written [] [] virt_written -- (h) Release registers for temps which are written here and not -- used again. @@ -546,16 +554,17 @@ releaseRegs regs = do saveClobberedTemps - :: (Outputable instr, Instruction instr) - => [RealReg] -- real registers clobbered by this instruction + :: (PlatformOutputable instr, Instruction instr) + => Platform + -> [RealReg] -- real registers clobbered by this instruction -> [Reg] -- registers which are no longer live after this insn -> RegM freeRegs [instr] -- return: instructions to spill any temps that will -- be clobbered. -saveClobberedTemps [] _ +saveClobberedTemps _ [] _ = return [] -saveClobberedTemps clobbered dying +saveClobberedTemps platform clobbered dying = do assig <- getAssigR let to_spill @@ -574,7 +583,7 @@ saveClobberedTemps clobbered dying clobber assig instrs ((temp, reg) : rest) = do - (spill, slot) <- spillR (RegReal reg) temp + (spill, slot) <- spillR platform (RegReal reg) temp -- record why this reg was spilled for profiling recordSpill (SpillClobber temp) @@ -638,24 +647,25 @@ data SpillLoc = ReadMem StackSlot -- reading from register only in memory -- the list of free registers and free stack slots. allocateRegsAndSpill - :: (FR freeRegs, Outputable instr, Instruction instr) - => Bool -- True <=> reading (load up spilled regs) + :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + => Platform + -> Bool -- True <=> reading (load up spilled regs) -> [VirtualReg] -- don't push these out -> [instr] -- spill insns -> [RealReg] -- real registers allocated (accum.) -> [VirtualReg] -- temps to allocate -> RegM freeRegs ( [instr] , [RealReg]) -allocateRegsAndSpill _ _ spills alloc [] +allocateRegsAndSpill _ _ _ spills alloc [] = return (spills, reverse alloc) -allocateRegsAndSpill reading keep spills alloc (r:rs) +allocateRegsAndSpill platform reading keep spills alloc (r:rs) = do assig <- getAssigR - let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig + let doSpill = allocRegsAndSpill_spill platform reading keep spills alloc r rs assig case lookupUFM assig r of -- case (1a): already in a register Just (InReg my_reg) -> - allocateRegsAndSpill reading keep spills (my_reg:alloc) rs + allocateRegsAndSpill platform reading keep spills (my_reg:alloc) rs -- case (1b): already in a register (and memory) -- NB1. if we're writing this register, update its assignment to be @@ -664,7 +674,7 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) -- are also read by the same instruction. Just (InBoth my_reg _) -> do when (not reading) (setAssigR (addToUFM assig r (InReg my_reg))) - allocateRegsAndSpill reading keep spills (my_reg:alloc) rs + allocateRegsAndSpill platform reading keep spills (my_reg:alloc) rs -- Not already in a register, so we need to find a free one... Just (InMem slot) | reading -> doSpill (ReadMem slot) @@ -682,8 +692,9 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) -- reading is redundant with reason, but we keep it around because it's -- convenient and it maintains the recursive structure of the allocator. -- EZY -allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr) - => Bool +allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, PlatformOutputable instr) + => Platform + -> Bool -> [VirtualReg] -> [instr] -> [RealReg] @@ -692,7 +703,7 @@ allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr) -> UniqFM Loc -> SpillLoc -> RegM freeRegs ([instr], [RealReg]) -allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc +allocRegsAndSpill_spill platform reading keep spills alloc r rs assig spill_loc = do freeRegs <- getFreeRegsR let freeRegs_thisClass = frGetFreeRegs (classOfVirtualReg r) freeRegs @@ -701,12 +712,12 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc -- case (2): we have a free register (my_reg : _) -> - do spills' <- loadTemp r spill_loc my_reg spills + do spills' <- loadTemp platform r spill_loc my_reg spills setAssigR (addToUFM assig r $! newLocation spill_loc my_reg) setFreeRegsR $ frAllocateReg my_reg freeRegs - allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs + allocateRegsAndSpill platform reading keep spills' (my_reg : alloc) rs -- case (3): we need to push something out to free up a register @@ -718,7 +729,7 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc = [ (temp, reg, mem) | (temp, InBoth reg mem) <- ufmToList assig , temp `notElem` keep' - , targetClassOfRealReg reg == classOfVirtualReg r ] + , targetClassOfRealReg platform reg == classOfVirtualReg r ] -- the vregs we could kick out that are only in a reg -- this would require writing the reg to a new slot before using it. @@ -726,26 +737,26 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc = [ (temp, reg) | (temp, InReg reg) <- ufmToList assig , temp `notElem` keep' - , targetClassOfRealReg reg == classOfVirtualReg r ] + , targetClassOfRealReg platform reg == classOfVirtualReg r ] let result -- we have a temporary that is in both register and mem, -- just free up its register for use. | (temp, my_reg, slot) : _ <- candidates_inBoth - = do spills' <- loadTemp r spill_loc my_reg spills + = do spills' <- loadTemp platform r spill_loc my_reg spills let assig1 = addToUFM assig temp (InMem slot) let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg setAssigR assig2 - allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs + allocateRegsAndSpill platform reading keep spills' (my_reg:alloc) rs -- otherwise, we need to spill a temporary that currently -- resides in a register. | (temp_to_push_out, (my_reg :: RealReg)) : _ <- candidates_inReg = do - (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out + (spill_insn, slot) <- spillR platform (RegReal my_reg) temp_to_push_out let spill_store = (if reading then id else reverse) [ -- COMMENT (fsLit "spill alloc") spill_insn ] @@ -759,9 +770,9 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc setAssigR assig2 -- if need be, load up a spilled temp into the reg we've just freed up. - spills' <- loadTemp r spill_loc my_reg spills + spills' <- loadTemp platform r spill_loc my_reg spills - allocateRegsAndSpill reading keep + allocateRegsAndSpill platform reading keep (spill_store ++ spills') (my_reg:alloc) rs @@ -787,19 +798,20 @@ newLocation _ my_reg = InReg my_reg -- | Load up a spilled temporary if we need to (read from memory). loadTemp - :: (Outputable instr, Instruction instr) - => VirtualReg -- the temp being loaded + :: (PlatformOutputable instr, Instruction instr) + => Platform + -> VirtualReg -- the temp being loaded -> SpillLoc -- the current location of this temp -> RealReg -- the hreg to load the temp into -> [instr] -> RegM freeRegs [instr] -loadTemp vreg (ReadMem slot) hreg spills +loadTemp platform vreg (ReadMem slot) hreg spills = do - insn <- loadR (RegReal hreg) slot + insn <- loadR platform (RegReal hreg) slot recordSpill (SpillLoad $ getUnique vreg) return $ {- COMMENT (fsLit "spill load") : -} insn : spills -loadTemp _ _ _ spills = +loadTemp _ _ _ _ spills = return spills diff --git a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs index 62bf6adb2a..1dd410aa46 100644 --- a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs +++ b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs @@ -22,6 +22,7 @@ where import RegAlloc.Linear.FreeRegs import Outputable +import Platform import UniqFM import Unique @@ -39,8 +40,8 @@ data StackMap -- | An empty stack map, with all slots available. -emptyStackMap :: StackMap -emptyStackMap = StackMap [0..maxSpillSlots] emptyUFM +emptyStackMap :: Platform -> StackMap +emptyStackMap platform = StackMap [0 .. maxSpillSlots platform] emptyUFM -- | If this vreg unique already has a stack assignment then return the slot number, diff --git a/compiler/nativeGen/RegAlloc/Linear/State.hs b/compiler/nativeGen/RegAlloc/Linear/State.hs index 05db9de350..9999a1e2e4 100644 --- a/compiler/nativeGen/RegAlloc/Linear/State.hs +++ b/compiler/nativeGen/RegAlloc/Linear/State.hs @@ -36,6 +36,7 @@ import RegAlloc.Liveness import Instruction import Reg +import Platform import Unique import UniqSupply @@ -81,21 +82,21 @@ makeRAStats state { ra_spillInstrs = binSpillReasons (ra_spills state) } -spillR :: Instruction instr - => Reg -> Unique -> RegM freeRegs (instr, Int) +spillR :: Instruction instr + => Platform -> Reg -> Unique -> RegM freeRegs (instr, Int) -spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} -> +spillR platform reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} -> let (stack',slot) = getStackSlotFor stack temp - instr = mkSpillInstr reg delta slot + instr = mkSpillInstr platform reg delta slot in (# s{ra_stack=stack'}, (instr,slot) #) -loadR :: Instruction instr - => Reg -> Int -> RegM freeRegs instr +loadR :: Instruction instr + => Platform -> Reg -> Int -> RegM freeRegs instr -loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} -> - (# s, mkLoadInstr reg delta slot #) +loadR platform reg slot = RegM $ \ s@RA_State{ra_delta=delta} -> + (# s, mkLoadInstr platform reg delta slot #) getFreeRegsR :: RegM freeRegs freeRegs getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} -> diff --git a/compiler/nativeGen/RegAlloc/Linear/Stats.hs b/compiler/nativeGen/RegAlloc/Linear/Stats.hs index c80f77f893..0c059eac27 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Stats.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Stats.hs @@ -37,7 +37,7 @@ binSpillReasons reasons -- | Count reg-reg moves remaining in this code. countRegRegMovesNat :: Instruction instr - => NatCmmTop instr -> Int + => NatCmmTop statics instr -> Int countRegRegMovesNat cmm = execState (mapGenBlockTopM countBlock cmm) 0 @@ -58,7 +58,7 @@ countRegRegMovesNat cmm -- | Pretty print some RegAllocStats pprStats :: Instruction instr - => [NatCmmTop instr] -> [RegAllocStats] -> SDoc + => [NatCmmTop statics instr] -> [RegAllocStats] -> SDoc pprStats code statss = let -- sum up all the instrs inserted by the spiller diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index a2030fafa9..2b7975dcb4 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -8,28 +8,28 @@ {-# OPTIONS -Wall -fno-warn-name-shadowing #-} module RegAlloc.Liveness ( - RegSet, - RegMap, emptyRegMap, - BlockMap, emptyBlockMap, - LiveCmmTop, - InstrSR (..), - LiveInstr (..), - Liveness (..), - LiveInfo (..), - LiveBasicBlock, - - mapBlockTop, mapBlockTopM, mapSCCM, - mapGenBlockTop, mapGenBlockTopM, - stripLive, - stripLiveBlock, - slurpConflicts, - slurpReloadCoalesce, - eraseDeltasLive, - patchEraseLive, - patchRegsLiveInstr, - reverseBlocksInTops, - regLiveness, - natCmmTopToLive + RegSet, + RegMap, emptyRegMap, + BlockMap, emptyBlockMap, + LiveCmmTop, + InstrSR (..), + LiveInstr (..), + Liveness (..), + LiveInfo (..), + LiveBasicBlock, + + mapBlockTop, mapBlockTopM, mapSCCM, + mapGenBlockTop, mapGenBlockTopM, + stripLive, + stripLiveBlock, + slurpConflicts, + slurpReloadCoalesce, + eraseDeltasLive, + patchEraseLive, + patchRegsLiveInstr, + reverseBlocksInTops, + regLiveness, + natCmmTopToLive ) where import Reg import Instruction @@ -40,6 +40,7 @@ import OldPprCmm() import Digraph import Outputable +import Platform import Unique import UniqSet import UniqFM @@ -50,9 +51,9 @@ import FastString import Data.List import Data.Maybe -import Data.Map (Map) -import Data.Set (Set) -import qualified Data.Map as Map +import Data.Map (Map) +import Data.Set (Set) +import qualified Data.Map as Map ----------------------------------------------------------------------------- type RegSet = UniqSet Reg @@ -66,869 +67,873 @@ type BlockMap a = BlockEnv a -- | A top level thing which carries liveness information. -type LiveCmmTop instr - = GenCmmTop - CmmStatic - LiveInfo - [SCC (LiveBasicBlock instr)] +type LiveCmmTop statics instr + = GenCmmTop + statics + LiveInfo + [SCC (LiveBasicBlock instr)] -- | The register allocator also wants to use SPILL/RELOAD meta instructions, --- so we'll keep those here. +-- so we'll keep those here. data InstrSR instr - -- | A real machine instruction - = Instr instr + -- | A real machine instruction + = Instr instr - -- | spill this reg to a stack slot - | SPILL Reg Int + -- | spill this reg to a stack slot + | SPILL Reg Int - -- | reload this reg from a stack slot - | RELOAD Int Reg + -- | reload this reg from a stack slot + | RELOAD Int Reg instance Instruction instr => Instruction (InstrSR instr) where - regUsageOfInstr i - = case i of - Instr instr -> regUsageOfInstr instr - SPILL reg _ -> RU [reg] [] - RELOAD _ reg -> RU [] [reg] + regUsageOfInstr i + = case i of + Instr instr -> regUsageOfInstr instr + SPILL reg _ -> RU [reg] [] + RELOAD _ reg -> RU [] [reg] - patchRegsOfInstr i f - = case i of - Instr instr -> Instr (patchRegsOfInstr instr f) - SPILL reg slot -> SPILL (f reg) slot - RELOAD slot reg -> RELOAD slot (f reg) + patchRegsOfInstr i f + = case i of + Instr instr -> Instr (patchRegsOfInstr instr f) + SPILL reg slot -> SPILL (f reg) slot + RELOAD slot reg -> RELOAD slot (f reg) - isJumpishInstr i - = case i of - Instr instr -> isJumpishInstr instr - _ -> False + isJumpishInstr i + = case i of + Instr instr -> isJumpishInstr instr + _ -> False - jumpDestsOfInstr i - = case i of - Instr instr -> jumpDestsOfInstr instr - _ -> [] + jumpDestsOfInstr i + = case i of + Instr instr -> jumpDestsOfInstr instr + _ -> [] - patchJumpInstr i f - = case i of - Instr instr -> Instr (patchJumpInstr instr f) - _ -> i + patchJumpInstr i f + = case i of + Instr instr -> Instr (patchJumpInstr instr f) + _ -> i - mkSpillInstr = error "mkSpillInstr[InstrSR]: Not making SPILL meta-instr" - mkLoadInstr = error "mkLoadInstr[InstrSR]: Not making LOAD meta-instr" + mkSpillInstr = error "mkSpillInstr[InstrSR]: Not making SPILL meta-instr" + mkLoadInstr = error "mkLoadInstr[InstrSR]: Not making LOAD meta-instr" - takeDeltaInstr i - = case i of - Instr instr -> takeDeltaInstr instr - _ -> Nothing + takeDeltaInstr i + = case i of + Instr instr -> takeDeltaInstr instr + _ -> Nothing - isMetaInstr i - = case i of - Instr instr -> isMetaInstr instr - _ -> False + isMetaInstr i + = case i of + Instr instr -> isMetaInstr instr + _ -> False - mkRegRegMoveInstr r1 r2 = Instr (mkRegRegMoveInstr r1 r2) + mkRegRegMoveInstr platform r1 r2 + = Instr (mkRegRegMoveInstr platform r1 r2) - takeRegRegMoveInstr i - = case i of - Instr instr -> takeRegRegMoveInstr instr - _ -> Nothing + takeRegRegMoveInstr i + = case i of + Instr instr -> takeRegRegMoveInstr instr + _ -> Nothing + + mkJumpInstr target = map Instr (mkJumpInstr target) - mkJumpInstr target = map Instr (mkJumpInstr target) - -- | An instruction with liveness information. data LiveInstr instr - = LiveInstr (InstrSR instr) (Maybe Liveness) + = LiveInstr (InstrSR instr) (Maybe Liveness) -- | Liveness information. --- The regs which die are ones which are no longer live in the *next* instruction --- in this sequence. --- (NB. if the instruction is a jump, these registers might still be live --- at the jump target(s) - you have to check the liveness at the destination --- block to find out). +-- The regs which die are ones which are no longer live in the *next* instruction +-- in this sequence. +-- (NB. if the instruction is a jump, these registers might still be live +-- at the jump target(s) - you have to check the liveness at the destination +-- block to find out). data Liveness - = Liveness - { liveBorn :: RegSet -- ^ registers born in this instruction (written to for first time). - , liveDieRead :: RegSet -- ^ registers that died because they were read for the last time. - , liveDieWrite :: RegSet } -- ^ registers that died because they were clobbered by something. + = Liveness + { liveBorn :: RegSet -- ^ registers born in this instruction (written to for first time). + , liveDieRead :: RegSet -- ^ registers that died because they were read for the last time. + , liveDieWrite :: RegSet } -- ^ registers that died because they were clobbered by something. -- | Stash regs live on entry to each basic block in the info part of the cmm code. data LiveInfo - = LiveInfo - [CmmStatic] -- cmm static stuff - (Maybe BlockId) -- id of the first block - (Maybe (BlockMap RegSet)) -- argument locals live on entry to this block - (Map BlockId (Set Int)) -- stack slots live on entry to this block + = LiveInfo + (Maybe CmmStatics) -- cmm info table static stuff + (Maybe BlockId) -- id of the first block + (Maybe (BlockMap RegSet)) -- argument locals live on entry to this block + (Map BlockId (Set Int)) -- stack slots live on entry to this block -- | A basic block with liveness information. type LiveBasicBlock instr - = GenBasicBlock (LiveInstr instr) - - -instance Outputable instr - => Outputable (InstrSR instr) where - - ppr (Instr realInstr) - = ppr realInstr - - ppr (SPILL reg slot) - = hcat [ - ptext (sLit "\tSPILL"), - char ' ', - ppr reg, - comma, - ptext (sLit "SLOT") <> parens (int slot)] - - ppr (RELOAD slot reg) - = hcat [ - ptext (sLit "\tRELOAD"), - char ' ', - ptext (sLit "SLOT") <> parens (int slot), - comma, - ppr reg] - -instance Outputable instr - => Outputable (LiveInstr instr) where - - ppr (LiveInstr instr Nothing) - = ppr instr - - ppr (LiveInstr instr (Just live)) - = ppr instr - $$ (nest 8 - $ vcat - [ pprRegs (ptext (sLit "# born: ")) (liveBorn live) - , pprRegs (ptext (sLit "# r_dying: ")) (liveDieRead live) - , pprRegs (ptext (sLit "# w_dying: ")) (liveDieWrite live) ] - $+$ space) - - where pprRegs :: SDoc -> RegSet -> SDoc - pprRegs name regs - | isEmptyUniqSet regs = empty - | otherwise = name <> (hcat $ punctuate space $ map ppr $ uniqSetToList regs) + = GenBasicBlock (LiveInstr instr) + + +instance PlatformOutputable instr + => PlatformOutputable (InstrSR instr) where + + pprPlatform platform (Instr realInstr) + = pprPlatform platform realInstr + + pprPlatform _ (SPILL reg slot) + = hcat [ + ptext (sLit "\tSPILL"), + char ' ', + ppr reg, + comma, + ptext (sLit "SLOT") <> parens (int slot)] + + pprPlatform _ (RELOAD slot reg) + = hcat [ + ptext (sLit "\tRELOAD"), + char ' ', + ptext (sLit "SLOT") <> parens (int slot), + comma, + ppr reg] + +instance PlatformOutputable instr + => PlatformOutputable (LiveInstr instr) where + + pprPlatform platform (LiveInstr instr Nothing) + = pprPlatform platform instr + + pprPlatform platform (LiveInstr instr (Just live)) + = pprPlatform platform instr + $$ (nest 8 + $ vcat + [ pprRegs (ptext (sLit "# born: ")) (liveBorn live) + , pprRegs (ptext (sLit "# r_dying: ")) (liveDieRead live) + , pprRegs (ptext (sLit "# w_dying: ")) (liveDieWrite live) ] + $+$ space) + + where pprRegs :: SDoc -> RegSet -> SDoc + pprRegs name regs + | isEmptyUniqSet regs = empty + | otherwise = name <> (hcat $ punctuate space $ map ppr $ uniqSetToList regs) instance Outputable LiveInfo where - ppr (LiveInfo static firstId liveVRegsOnEntry liveSlotsOnEntry) - = (vcat $ map ppr static) - $$ text "# firstId = " <> ppr firstId - $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry - $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry) + ppr (LiveInfo mb_static firstId liveVRegsOnEntry liveSlotsOnEntry) + = (maybe empty ppr mb_static) + $$ text "# firstId = " <> ppr firstId + $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry + $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry) -- | map a function across all the basic blocks in this code -- mapBlockTop - :: (LiveBasicBlock instr -> LiveBasicBlock instr) - -> LiveCmmTop instr -> LiveCmmTop instr + :: (LiveBasicBlock instr -> LiveBasicBlock instr) + -> LiveCmmTop statics instr -> LiveCmmTop statics instr mapBlockTop f cmm - = evalState (mapBlockTopM (\x -> return $ f x) cmm) () + = evalState (mapBlockTopM (\x -> return $ f x) cmm) () -- | map a function across all the basic blocks in this code (monadic version) -- mapBlockTopM - :: Monad m - => (LiveBasicBlock instr -> m (LiveBasicBlock instr)) - -> LiveCmmTop instr -> m (LiveCmmTop instr) + :: Monad m + => (LiveBasicBlock instr -> m (LiveBasicBlock instr)) + -> LiveCmmTop statics instr -> m (LiveCmmTop statics instr) mapBlockTopM _ cmm@(CmmData{}) - = return cmm + = return cmm mapBlockTopM f (CmmProc header label sccs) - = do sccs' <- mapM (mapSCCM f) sccs - return $ CmmProc header label sccs' + = do sccs' <- mapM (mapSCCM f) sccs + return $ CmmProc header label sccs' mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b) -mapSCCM f (AcyclicSCC x) - = do x' <- f x - return $ AcyclicSCC x' +mapSCCM f (AcyclicSCC x) + = do x' <- f x + return $ AcyclicSCC x' mapSCCM f (CyclicSCC xs) - = do xs' <- mapM f xs - return $ CyclicSCC xs' + = do xs' <- mapM f xs + return $ CyclicSCC xs' -- map a function across all the basic blocks in this code mapGenBlockTop - :: (GenBasicBlock i -> GenBasicBlock i) - -> (GenCmmTop d h (ListGraph i) -> GenCmmTop d h (ListGraph i)) + :: (GenBasicBlock i -> GenBasicBlock i) + -> (GenCmmTop d h (ListGraph i) -> GenCmmTop d h (ListGraph i)) mapGenBlockTop f cmm - = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) () + = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) () -- | map a function across all the basic blocks in this code (monadic version) mapGenBlockTopM - :: Monad m - => (GenBasicBlock i -> m (GenBasicBlock i)) - -> (GenCmmTop d h (ListGraph i) -> m (GenCmmTop d h (ListGraph i))) + :: Monad m + => (GenBasicBlock i -> m (GenBasicBlock i)) + -> (GenCmmTop d h (ListGraph i) -> m (GenCmmTop d h (ListGraph i))) mapGenBlockTopM _ cmm@(CmmData{}) - = return cmm + = return cmm mapGenBlockTopM f (CmmProc header label (ListGraph blocks)) - = do blocks' <- mapM f blocks - return $ CmmProc header label (ListGraph blocks') + = do blocks' <- mapM f blocks + return $ CmmProc header label (ListGraph blocks') -- | Slurp out the list of register conflicts and reg-reg moves from this top level thing. --- Slurping of conflicts and moves is wrapped up together so we don't have --- to make two passes over the same code when we want to build the graph. +-- Slurping of conflicts and moves is wrapped up together so we don't have +-- to make two passes over the same code when we want to build the graph. -- -slurpConflicts - :: Instruction instr - => LiveCmmTop instr - -> (Bag (UniqSet Reg), Bag (Reg, Reg)) +slurpConflicts + :: Instruction instr + => LiveCmmTop statics instr + -> (Bag (UniqSet Reg), Bag (Reg, Reg)) slurpConflicts live - = slurpCmm (emptyBag, emptyBag) live + = slurpCmm (emptyBag, emptyBag) live + + where slurpCmm rs CmmData{} = rs + slurpCmm rs (CmmProc info _ sccs) + = foldl' (slurpSCC info) rs sccs - where slurpCmm rs CmmData{} = rs - slurpCmm rs (CmmProc info _ sccs) - = foldl' (slurpSCC info) rs sccs + slurpSCC info rs (AcyclicSCC b) + = slurpBlock info rs b - slurpSCC info rs (AcyclicSCC b) - = slurpBlock info rs b + slurpSCC info rs (CyclicSCC bs) + = foldl' (slurpBlock info) rs bs - slurpSCC info rs (CyclicSCC bs) - = foldl' (slurpBlock info) rs bs + slurpBlock info rs (BasicBlock blockId instrs) + | LiveInfo _ _ (Just blockLive) _ <- info + , Just rsLiveEntry <- mapLookup blockId blockLive + , (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs + = (consBag rsLiveEntry conflicts, moves) - slurpBlock info rs (BasicBlock blockId instrs) - | LiveInfo _ _ (Just blockLive) _ <- info - , Just rsLiveEntry <- mapLookup blockId blockLive - , (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs - = (consBag rsLiveEntry conflicts, moves) + | otherwise + = panic "Liveness.slurpConflicts: bad block" - | otherwise - = panic "Liveness.slurpConflicts: bad block" + slurpLIs rsLive (conflicts, moves) [] + = (consBag rsLive conflicts, moves) - slurpLIs rsLive (conflicts, moves) [] - = (consBag rsLive conflicts, moves) + slurpLIs rsLive rs (LiveInstr _ Nothing : lis) + = slurpLIs rsLive rs lis - slurpLIs rsLive rs (LiveInstr _ Nothing : lis) - = slurpLIs rsLive rs lis - - slurpLIs rsLiveEntry (conflicts, moves) (LiveInstr instr (Just live) : lis) - = let - -- regs that die because they are read for the last time at the start of an instruction - -- are not live across it. - rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live) + slurpLIs rsLiveEntry (conflicts, moves) (LiveInstr instr (Just live) : lis) + = let + -- regs that die because they are read for the last time at the start of an instruction + -- are not live across it. + rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live) - -- regs live on entry to the next instruction. - -- be careful of orphans, make sure to delete dying regs _after_ unioning - -- in the ones that are born here. - rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live)) - `minusUniqSet` (liveDieWrite live) + -- regs live on entry to the next instruction. + -- be careful of orphans, make sure to delete dying regs _after_ unioning + -- in the ones that are born here. + rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live)) + `minusUniqSet` (liveDieWrite live) - -- orphan vregs are the ones that die in the same instruction they are born in. - -- these are likely to be results that are never used, but we still - -- need to assign a hreg to them.. - rsOrphans = intersectUniqSets - (liveBorn live) - (unionUniqSets (liveDieWrite live) (liveDieRead live)) + -- orphan vregs are the ones that die in the same instruction they are born in. + -- these are likely to be results that are never used, but we still + -- need to assign a hreg to them.. + rsOrphans = intersectUniqSets + (liveBorn live) + (unionUniqSets (liveDieWrite live) (liveDieRead live)) - -- - rsConflicts = unionUniqSets rsLiveNext rsOrphans + -- + rsConflicts = unionUniqSets rsLiveNext rsOrphans - in case takeRegRegMoveInstr instr of - Just rr -> slurpLIs rsLiveNext - ( consBag rsConflicts conflicts - , consBag rr moves) lis + in case takeRegRegMoveInstr instr of + Just rr -> slurpLIs rsLiveNext + ( consBag rsConflicts conflicts + , consBag rr moves) lis - Nothing -> slurpLIs rsLiveNext - ( consBag rsConflicts conflicts - , moves) lis + Nothing -> slurpLIs rsLiveNext + ( consBag rsConflicts conflicts + , moves) lis -- | For spill\/reloads -- --- SPILL v1, slot1 --- ... --- RELOAD slot1, v2 +-- SPILL v1, slot1 +-- ... +-- RELOAD slot1, v2 -- --- If we can arrange that v1 and v2 are allocated to the same hreg it's more likely --- the spill\/reload instrs can be cleaned and replaced by a nop reg-reg move. +-- If we can arrange that v1 and v2 are allocated to the same hreg it's more likely +-- the spill\/reload instrs can be cleaned and replaced by a nop reg-reg move. -- -- -slurpReloadCoalesce - :: forall instr. Instruction instr - => LiveCmmTop instr - -> Bag (Reg, Reg) +slurpReloadCoalesce + :: forall statics instr. Instruction instr + => LiveCmmTop statics instr + -> Bag (Reg, Reg) slurpReloadCoalesce live - = slurpCmm emptyBag live + = slurpCmm emptyBag live - where + where slurpCmm :: Bag (Reg, Reg) -> GenCmmTop t t1 [SCC (LiveBasicBlock instr)] -> Bag (Reg, Reg) - slurpCmm cs CmmData{} = cs - slurpCmm cs (CmmProc _ _ sccs) - = slurpComp cs (flattenSCCs sccs) + slurpCmm cs CmmData{} = cs + slurpCmm cs (CmmProc _ _ sccs) + = slurpComp cs (flattenSCCs sccs) slurpComp :: Bag (Reg, Reg) -> [LiveBasicBlock instr] -> Bag (Reg, Reg) - slurpComp cs blocks - = let (moveBags, _) = runState (slurpCompM blocks) emptyUFM - in unionManyBags (cs : moveBags) + slurpComp cs blocks + = let (moveBags, _) = runState (slurpCompM blocks) emptyUFM + in unionManyBags (cs : moveBags) slurpCompM :: [LiveBasicBlock instr] -> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)] - slurpCompM blocks - = do -- run the analysis once to record the mapping across jumps. - mapM_ (slurpBlock False) blocks + slurpCompM blocks + = do -- run the analysis once to record the mapping across jumps. + mapM_ (slurpBlock False) blocks - -- run it a second time while using the information from the last pass. - -- We /could/ run this many more times to deal with graphical control - -- flow and propagating info across multiple jumps, but it's probably - -- not worth the trouble. - mapM (slurpBlock True) blocks + -- run it a second time while using the information from the last pass. + -- We /could/ run this many more times to deal with graphical control + -- flow and propagating info across multiple jumps, but it's probably + -- not worth the trouble. + mapM (slurpBlock True) blocks slurpBlock :: Bool -> LiveBasicBlock instr -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg)) - slurpBlock propagate (BasicBlock blockId instrs) - = do -- grab the slot map for entry to this block - slotMap <- if propagate - then getSlotMap blockId - else return emptyUFM - - (_, mMoves) <- mapAccumLM slurpLI slotMap instrs - return $ listToBag $ catMaybes mMoves - - slurpLI :: UniqFM Reg -- current slotMap - -> LiveInstr instr - -> State (UniqFM [UniqFM Reg]) -- blockId -> [slot -> reg] - -- for tracking slotMaps across jumps - - ( UniqFM Reg -- new slotMap - , Maybe (Reg, Reg)) -- maybe a new coalesce edge - - slurpLI slotMap li - - -- remember what reg was stored into the slot - | LiveInstr (SPILL reg slot) _ <- li - , slotMap' <- addToUFM slotMap slot reg - = return (slotMap', Nothing) - - -- add an edge betwen the this reg and the last one stored into the slot - | LiveInstr (RELOAD slot reg) _ <- li - = case lookupUFM slotMap slot of - Just reg2 - | reg /= reg2 -> return (slotMap, Just (reg, reg2)) - | otherwise -> return (slotMap, Nothing) - - Nothing -> return (slotMap, Nothing) - - -- if we hit a jump, remember the current slotMap - | LiveInstr (Instr instr) _ <- li - , targets <- jumpDestsOfInstr instr - , not $ null targets - = do mapM_ (accSlotMap slotMap) targets - return (slotMap, Nothing) - - | otherwise - = return (slotMap, Nothing) - - -- record a slotmap for an in edge to this block - accSlotMap slotMap blockId - = modify (\s -> addToUFM_C (++) s blockId [slotMap]) - - -- work out the slot map on entry to this block - -- if we have slot maps for multiple in-edges then we need to merge them. - getSlotMap blockId - = do map <- get - let slotMaps = fromMaybe [] (lookupUFM map blockId) - return $ foldr mergeSlotMaps emptyUFM slotMaps - - mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg - mergeSlotMaps map1 map2 - = listToUFM - $ [ (k, r1) | (k, r1) <- ufmToList map1 - , case lookupUFM map2 k of - Nothing -> False - Just r2 -> r1 == r2 ] + slurpBlock propagate (BasicBlock blockId instrs) + = do -- grab the slot map for entry to this block + slotMap <- if propagate + then getSlotMap blockId + else return emptyUFM + + (_, mMoves) <- mapAccumLM slurpLI slotMap instrs + return $ listToBag $ catMaybes mMoves + + slurpLI :: UniqFM Reg -- current slotMap + -> LiveInstr instr + -> State (UniqFM [UniqFM Reg]) -- blockId -> [slot -> reg] + -- for tracking slotMaps across jumps + + ( UniqFM Reg -- new slotMap + , Maybe (Reg, Reg)) -- maybe a new coalesce edge + + slurpLI slotMap li + + -- remember what reg was stored into the slot + | LiveInstr (SPILL reg slot) _ <- li + , slotMap' <- addToUFM slotMap slot reg + = return (slotMap', Nothing) + + -- add an edge betwen the this reg and the last one stored into the slot + | LiveInstr (RELOAD slot reg) _ <- li + = case lookupUFM slotMap slot of + Just reg2 + | reg /= reg2 -> return (slotMap, Just (reg, reg2)) + | otherwise -> return (slotMap, Nothing) + + Nothing -> return (slotMap, Nothing) + + -- if we hit a jump, remember the current slotMap + | LiveInstr (Instr instr) _ <- li + , targets <- jumpDestsOfInstr instr + , not $ null targets + = do mapM_ (accSlotMap slotMap) targets + return (slotMap, Nothing) + + | otherwise + = return (slotMap, Nothing) + + -- record a slotmap for an in edge to this block + accSlotMap slotMap blockId + = modify (\s -> addToUFM_C (++) s blockId [slotMap]) + + -- work out the slot map on entry to this block + -- if we have slot maps for multiple in-edges then we need to merge them. + getSlotMap blockId + = do map <- get + let slotMaps = fromMaybe [] (lookupUFM map blockId) + return $ foldr mergeSlotMaps emptyUFM slotMaps + + mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg + mergeSlotMaps map1 map2 + = listToUFM + $ [ (k, r1) | (k, r1) <- ufmToList map1 + , case lookupUFM map2 k of + Nothing -> False + Just r2 -> r1 == r2 ] -- | Strip away liveness information, yielding NatCmmTop -stripLive - :: (Outputable instr, Instruction instr) - => LiveCmmTop instr - -> NatCmmTop instr +stripLive + :: (Outputable statics, PlatformOutputable instr, Instruction instr) + => Platform + -> LiveCmmTop statics instr + -> NatCmmTop statics instr -stripLive live - = stripCmm live +stripLive platform live + = stripCmm live - where stripCmm (CmmData sec ds) = CmmData sec ds - stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label sccs) - = let final_blocks = flattenSCCs sccs - - -- make sure the block that was first in the input list - -- stays at the front of the output. This is the entry point - -- of the proc, and it needs to come first. - ((first':_), rest') - = partition ((== first_id) . blockId) final_blocks + where stripCmm (CmmData sec ds) = CmmData sec ds + stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label sccs) + = let final_blocks = flattenSCCs sccs - in CmmProc info label - (ListGraph $ map stripLiveBlock $ first' : rest') + -- make sure the block that was first in the input list + -- stays at the front of the output. This is the entry point + -- of the proc, and it needs to come first. + ((first':_), rest') + = partition ((== first_id) . blockId) final_blocks - -- procs used for stg_split_markers don't contain any blocks, and have no first_id. - stripCmm (CmmProc (LiveInfo info Nothing _ _) label []) - = CmmProc info label (ListGraph []) + in CmmProc info label + (ListGraph $ map (stripLiveBlock platform) $ first' : rest') - -- If the proc has blocks but we don't know what the first one was, then we're dead. - stripCmm proc - = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc) + -- procs used for stg_split_markers don't contain any blocks, and have no first_id. + stripCmm (CmmProc (LiveInfo info Nothing _ _) label []) + = CmmProc info label (ListGraph []) + -- If the proc has blocks but we don't know what the first one was, then we're dead. + stripCmm proc + = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (pprPlatform platform proc) -- | Strip away liveness information from a basic block, --- and make real spill instructions out of SPILL, RELOAD pseudos along the way. +-- and make real spill instructions out of SPILL, RELOAD pseudos along the way. stripLiveBlock - :: Instruction instr - => LiveBasicBlock instr - -> NatBasicBlock instr + :: Instruction instr + => Platform + -> LiveBasicBlock instr + -> NatBasicBlock instr -stripLiveBlock (BasicBlock i lis) - = BasicBlock i instrs' +stripLiveBlock platform (BasicBlock i lis) + = BasicBlock i instrs' - where (instrs', _) - = runState (spillNat [] lis) 0 + where (instrs', _) + = runState (spillNat [] lis) 0 - spillNat acc [] - = return (reverse acc) + spillNat acc [] + = return (reverse acc) - spillNat acc (LiveInstr (SPILL reg slot) _ : instrs) - = do delta <- get - spillNat (mkSpillInstr reg delta slot : acc) instrs + spillNat acc (LiveInstr (SPILL reg slot) _ : instrs) + = do delta <- get + spillNat (mkSpillInstr platform reg delta slot : acc) instrs - spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs) - = do delta <- get - spillNat (mkLoadInstr reg delta slot : acc) instrs + spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs) + = do delta <- get + spillNat (mkLoadInstr platform reg delta slot : acc) instrs - spillNat acc (LiveInstr (Instr instr) _ : instrs) - | Just i <- takeDeltaInstr instr - = do put i - spillNat acc instrs + spillNat acc (LiveInstr (Instr instr) _ : instrs) + | Just i <- takeDeltaInstr instr + = do put i + spillNat acc instrs - spillNat acc (LiveInstr (Instr instr) _ : instrs) - = spillNat (instr : acc) instrs + spillNat acc (LiveInstr (Instr instr) _ : instrs) + = spillNat (instr : acc) instrs -- | Erase Delta instructions. -eraseDeltasLive - :: Instruction instr - => LiveCmmTop instr - -> LiveCmmTop instr +eraseDeltasLive + :: Instruction instr + => LiveCmmTop statics instr + -> LiveCmmTop statics instr eraseDeltasLive cmm - = mapBlockTop eraseBlock cmm + = mapBlockTop eraseBlock cmm where - eraseBlock (BasicBlock id lis) - = BasicBlock id - $ filter (\(LiveInstr i _) -> not $ isJust $ takeDeltaInstr i) - $ lis + eraseBlock (BasicBlock id lis) + = BasicBlock id + $ filter (\(LiveInstr i _) -> not $ isJust $ takeDeltaInstr i) + $ lis -- | Patch the registers in this code according to this register mapping. --- also erase reg -> reg moves when the reg is the same. --- also erase reg -> reg moves when the destination dies in this instr. +-- also erase reg -> reg moves when the reg is the same. +-- also erase reg -> reg moves when the destination dies in this instr. patchEraseLive - :: Instruction instr - => (Reg -> Reg) - -> LiveCmmTop instr -> LiveCmmTop instr + :: Instruction instr + => (Reg -> Reg) + -> LiveCmmTop statics instr -> LiveCmmTop statics instr patchEraseLive patchF cmm - = patchCmm cmm + = patchCmm cmm where - patchCmm cmm@CmmData{} = cmm + patchCmm cmm@CmmData{} = cmm - patchCmm (CmmProc info label sccs) - | LiveInfo static id (Just blockMap) mLiveSlots <- info - = let - patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set - blockMap' = mapMap patchRegSet blockMap + patchCmm (CmmProc info label sccs) + | LiveInfo static id (Just blockMap) mLiveSlots <- info + = let + patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set + blockMap' = mapMap patchRegSet blockMap - info' = LiveInfo static id (Just blockMap') mLiveSlots - in CmmProc info' label $ map patchSCC sccs + info' = LiveInfo static id (Just blockMap') mLiveSlots + in CmmProc info' label $ map patchSCC sccs - | otherwise - = panic "RegAlloc.Liveness.patchEraseLive: no blockMap" + | otherwise + = panic "RegAlloc.Liveness.patchEraseLive: no blockMap" - patchSCC (AcyclicSCC b) = AcyclicSCC (patchBlock b) - patchSCC (CyclicSCC bs) = CyclicSCC (map patchBlock bs) + patchSCC (AcyclicSCC b) = AcyclicSCC (patchBlock b) + patchSCC (CyclicSCC bs) = CyclicSCC (map patchBlock bs) - patchBlock (BasicBlock id lis) - = BasicBlock id $ patchInstrs lis + patchBlock (BasicBlock id lis) + = BasicBlock id $ patchInstrs lis - patchInstrs [] = [] - patchInstrs (li : lis) + patchInstrs [] = [] + patchInstrs (li : lis) - | LiveInstr i (Just live) <- li' - , Just (r1, r2) <- takeRegRegMoveInstr i - , eatMe r1 r2 live - = patchInstrs lis + | LiveInstr i (Just live) <- li' + , Just (r1, r2) <- takeRegRegMoveInstr i + , eatMe r1 r2 live + = patchInstrs lis - | otherwise - = li' : patchInstrs lis + | otherwise + = li' : patchInstrs lis - where li' = patchRegsLiveInstr patchF li + where li' = patchRegsLiveInstr patchF li - eatMe r1 r2 live - -- source and destination regs are the same - | r1 == r2 = True + eatMe r1 r2 live + -- source and destination regs are the same + | r1 == r2 = True - -- desination reg is never used - | elementOfUniqSet r2 (liveBorn live) - , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live) - = True + -- desination reg is never used + | elementOfUniqSet r2 (liveBorn live) + , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live) + = True - | otherwise = False + | otherwise = False -- | Patch registers in this LiveInstr, including the liveness information. -- patchRegsLiveInstr - :: Instruction instr - => (Reg -> Reg) - -> LiveInstr instr -> LiveInstr instr + :: Instruction instr + => (Reg -> Reg) + -> LiveInstr instr -> LiveInstr instr patchRegsLiveInstr patchF li = case li of - LiveInstr instr Nothing - -> LiveInstr (patchRegsOfInstr instr patchF) Nothing + LiveInstr instr Nothing + -> LiveInstr (patchRegsOfInstr instr patchF) Nothing - LiveInstr instr (Just live) - -> LiveInstr - (patchRegsOfInstr instr patchF) - (Just live - { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg - liveBorn = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live - , liveDieRead = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live - , liveDieWrite = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live }) + LiveInstr instr (Just live) + -> LiveInstr + (patchRegsOfInstr instr patchF) + (Just live + { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg + liveBorn = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live + , liveDieRead = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live + , liveDieWrite = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live }) -------------------------------------------------------------------------------- -- | Convert a NatCmmTop to a LiveCmmTop, with empty liveness information -natCmmTopToLive - :: Instruction instr - => NatCmmTop instr - -> LiveCmmTop instr +natCmmTopToLive + :: Instruction instr + => NatCmmTop statics instr + -> LiveCmmTop statics instr natCmmTopToLive (CmmData i d) - = CmmData i d + = CmmData i d natCmmTopToLive (CmmProc info lbl (ListGraph [])) - = CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl [] + = CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl [] natCmmTopToLive (CmmProc info lbl (ListGraph blocks@(first : _))) - = let first_id = blockId first - sccs = sccBlocks blocks - sccsLive = map (fmap (\(BasicBlock l instrs) -> - BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs))) - $ sccs - - in CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) lbl sccsLive + = let first_id = blockId first + sccs = sccBlocks blocks + sccsLive = map (fmap (\(BasicBlock l instrs) -> + BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs))) + $ sccs + in CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) lbl sccsLive -sccBlocks - :: Instruction instr - => [NatBasicBlock instr] - -> [SCC (NatBasicBlock instr)] + +sccBlocks + :: Instruction instr + => [NatBasicBlock instr] + -> [SCC (NatBasicBlock instr)] sccBlocks blocks = stronglyConnCompFromEdgedVertices graph where - getOutEdges :: Instruction instr => [instr] -> [BlockId] - getOutEdges instrs = concat $ map jumpDestsOfInstr instrs + getOutEdges :: Instruction instr => [instr] -> [BlockId] + getOutEdges instrs = concat $ map jumpDestsOfInstr instrs - graph = [ (block, getUnique id, map getUnique (getOutEdges instrs)) - | block@(BasicBlock id instrs) <- blocks ] + graph = [ (block, getUnique id, map getUnique (getOutEdges instrs)) + | block@(BasicBlock id instrs) <- blocks ] --------------------------------------------------------------------------------- -- Annotate code with register liveness information -- regLiveness - :: (Outputable instr, Instruction instr) - => LiveCmmTop instr - -> UniqSM (LiveCmmTop instr) + :: (PlatformOutputable instr, Instruction instr) + => Platform + -> LiveCmmTop statics instr + -> UniqSM (LiveCmmTop statics instr) -regLiveness (CmmData i d) - = returnUs $ CmmData i d +regLiveness _ (CmmData i d) + = returnUs $ CmmData i d -regLiveness (CmmProc info lbl []) - | LiveInfo static mFirst _ _ <- info - = returnUs $ CmmProc - (LiveInfo static mFirst (Just mapEmpty) Map.empty) - lbl [] +regLiveness _ (CmmProc info lbl []) + | LiveInfo static mFirst _ _ <- info + = returnUs $ CmmProc + (LiveInfo static mFirst (Just mapEmpty) Map.empty) + lbl [] -regLiveness (CmmProc info lbl sccs) - | LiveInfo static mFirst _ liveSlotsOnEntry <- info - = let (ann_sccs, block_live) = computeLiveness sccs +regLiveness platform (CmmProc info lbl sccs) + | LiveInfo static mFirst _ liveSlotsOnEntry <- info + = let (ann_sccs, block_live) = computeLiveness platform sccs - in returnUs $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry) - lbl ann_sccs + in returnUs $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry) + lbl ann_sccs -- ----------------------------------------------------------------------------- -- | Check ordering of Blocks --- The computeLiveness function requires SCCs to be in reverse dependent order. --- If they're not the liveness information will be wrong, and we'll get a bad allocation. --- Better to check for this precondition explicitly or some other poor sucker will --- waste a day staring at bad assembly code.. --- +-- The computeLiveness function requires SCCs to be in reverse dependent order. +-- If they're not the liveness information will be wrong, and we'll get a bad allocation. +-- Better to check for this precondition explicitly or some other poor sucker will +-- waste a day staring at bad assembly code.. +-- checkIsReverseDependent - :: Instruction instr - => [SCC (LiveBasicBlock instr)] -- ^ SCCs of blocks that we're about to run the liveness determinator on. - -> Maybe BlockId -- ^ BlockIds that fail the test (if any) - + :: Instruction instr + => [SCC (LiveBasicBlock instr)] -- ^ SCCs of blocks that we're about to run the liveness determinator on. + -> Maybe BlockId -- ^ BlockIds that fail the test (if any) + checkIsReverseDependent sccs' = go emptyUniqSet sccs' - where go _ [] - = Nothing - - go blocksSeen (AcyclicSCC block : sccs) - = let dests = slurpJumpDestsOfBlock block - blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet [blockId block] - badDests = dests `minusUniqSet` blocksSeen' - in case uniqSetToList badDests of - [] -> go blocksSeen' sccs - bad : _ -> Just bad - - go blocksSeen (CyclicSCC blocks : sccs) - = let dests = unionManyUniqSets $ map slurpJumpDestsOfBlock blocks - blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet $ map blockId blocks - badDests = dests `minusUniqSet` blocksSeen' - in case uniqSetToList badDests of - [] -> go blocksSeen' sccs - bad : _ -> Just bad - - slurpJumpDestsOfBlock (BasicBlock _ instrs) - = unionManyUniqSets - $ map (mkUniqSet . jumpDestsOfInstr) - [ i | LiveInstr i _ <- instrs] + where go _ [] + = Nothing + + go blocksSeen (AcyclicSCC block : sccs) + = let dests = slurpJumpDestsOfBlock block + blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet [blockId block] + badDests = dests `minusUniqSet` blocksSeen' + in case uniqSetToList badDests of + [] -> go blocksSeen' sccs + bad : _ -> Just bad + + go blocksSeen (CyclicSCC blocks : sccs) + = let dests = unionManyUniqSets $ map slurpJumpDestsOfBlock blocks + blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet $ map blockId blocks + badDests = dests `minusUniqSet` blocksSeen' + in case uniqSetToList badDests of + [] -> go blocksSeen' sccs + bad : _ -> Just bad + + slurpJumpDestsOfBlock (BasicBlock _ instrs) + = unionManyUniqSets + $ map (mkUniqSet . jumpDestsOfInstr) + [ i | LiveInstr i _ <- instrs] -- | If we've compute liveness info for this code already we have to reverse -- the SCCs in each top to get them back to the right order so we can do it again. -reverseBlocksInTops :: LiveCmmTop instr -> LiveCmmTop instr +reverseBlocksInTops :: LiveCmmTop statics instr -> LiveCmmTop statics instr reverseBlocksInTops top = case top of - CmmData{} -> top - CmmProc info lbl sccs -> CmmProc info lbl (reverse sccs) + CmmData{} -> top + CmmProc info lbl sccs -> CmmProc info lbl (reverse sccs) + - -- | Computing liveness --- +-- -- On entry, the SCCs must be in "reverse" order: later blocks may transfer -- control to earlier ones only, else `panic`. --- +-- -- The SCCs returned are in the *opposite* order, which is exactly what we -- want for the next pass. -- computeLiveness - :: (Outputable instr, Instruction instr) - => [SCC (LiveBasicBlock instr)] - -> ([SCC (LiveBasicBlock instr)], -- instructions annotated with list of registers - -- which are "dead after this instruction". - BlockMap RegSet) -- blocks annontated with set of live registers - -- on entry to the block. - -computeLiveness sccs + :: (PlatformOutputable instr, Instruction instr) + => Platform + -> [SCC (LiveBasicBlock instr)] + -> ([SCC (LiveBasicBlock instr)], -- instructions annotated with list of registers + -- which are "dead after this instruction". + BlockMap RegSet) -- blocks annontated with set of live registers + -- on entry to the block. + +computeLiveness platform sccs = case checkIsReverseDependent sccs of - Nothing -> livenessSCCs emptyBlockMap [] sccs - Just bad -> pprPanic "RegAlloc.Liveness.computeLivenss" - (vcat [ text "SCCs aren't in reverse dependent order" - , text "bad blockId" <+> ppr bad - , ppr sccs]) + Nothing -> livenessSCCs emptyBlockMap [] sccs + Just bad -> pprPanic "RegAlloc.Liveness.computeLivenss" + (vcat [ text "SCCs aren't in reverse dependent order" + , text "bad blockId" <+> ppr bad + , pprPlatform platform sccs]) livenessSCCs :: Instruction instr => BlockMap RegSet - -> [SCC (LiveBasicBlock instr)] -- accum + -> [SCC (LiveBasicBlock instr)] -- accum -> [SCC (LiveBasicBlock instr)] -> ( [SCC (LiveBasicBlock instr)] - , BlockMap RegSet) + , BlockMap RegSet) -livenessSCCs blockmap done [] - = (done, blockmap) +livenessSCCs blockmap done [] + = (done, blockmap) livenessSCCs blockmap done (AcyclicSCC block : sccs) - = let (blockmap', block') = livenessBlock blockmap block - in livenessSCCs blockmap' (AcyclicSCC block' : done) sccs + = let (blockmap', block') = livenessBlock blockmap block + in livenessSCCs blockmap' (AcyclicSCC block' : done) sccs livenessSCCs blockmap done - (CyclicSCC blocks : sccs) = - livenessSCCs blockmap' (CyclicSCC blocks':done) sccs + (CyclicSCC blocks : sccs) = + livenessSCCs blockmap' (CyclicSCC blocks':done) sccs where (blockmap', blocks') - = iterateUntilUnchanged linearLiveness equalBlockMaps - blockmap blocks + = iterateUntilUnchanged linearLiveness equalBlockMaps + blockmap blocks iterateUntilUnchanged :: (a -> b -> (a,c)) -> (a -> a -> Bool) -> a -> b -> (a,c) - iterateUntilUnchanged f eq a b - = head $ - concatMap tail $ - groupBy (\(a1, _) (a2, _) -> eq a1 a2) $ - iterate (\(a, _) -> f a b) $ - (a, panic "RegLiveness.livenessSCCs") + iterateUntilUnchanged f eq a b + = head $ + concatMap tail $ + groupBy (\(a1, _) (a2, _) -> eq a1 a2) $ + iterate (\(a, _) -> f a b) $ + (a, panic "RegLiveness.livenessSCCs") - linearLiveness - :: Instruction instr - => BlockMap RegSet -> [LiveBasicBlock instr] - -> (BlockMap RegSet, [LiveBasicBlock instr]) + linearLiveness + :: Instruction instr + => BlockMap RegSet -> [LiveBasicBlock instr] + -> (BlockMap RegSet, [LiveBasicBlock instr]) linearLiveness = mapAccumL livenessBlock -- probably the least efficient way to compare two -- BlockMaps for equality. - equalBlockMaps a b - = a' == b' - where a' = map f $ mapToList a - b' = map f $ mapToList b - f (key,elt) = (key, uniqSetToList elt) + equalBlockMaps a b + = a' == b' + where a' = map f $ mapToList a + b' = map f $ mapToList b + f (key,elt) = (key, uniqSetToList elt) -- | Annotate a basic block with register liveness information. -- livenessBlock - :: Instruction instr - => BlockMap RegSet - -> LiveBasicBlock instr - -> (BlockMap RegSet, LiveBasicBlock instr) + :: Instruction instr + => BlockMap RegSet + -> LiveBasicBlock instr + -> (BlockMap RegSet, LiveBasicBlock instr) livenessBlock blockmap (BasicBlock block_id instrs) = let - (regsLiveOnEntry, instrs1) - = livenessBack emptyUniqSet blockmap [] (reverse instrs) - blockmap' = mapInsert block_id regsLiveOnEntry blockmap + (regsLiveOnEntry, instrs1) + = livenessBack emptyUniqSet blockmap [] (reverse instrs) + blockmap' = mapInsert block_id regsLiveOnEntry blockmap - instrs2 = livenessForward regsLiveOnEntry instrs1 + instrs2 = livenessForward regsLiveOnEntry instrs1 - output = BasicBlock block_id instrs2 + output = BasicBlock block_id instrs2 - in ( blockmap', output) + in ( blockmap', output) -- | Calculate liveness going forwards, --- filling in when regs are born +-- filling in when regs are born livenessForward - :: Instruction instr - => RegSet -- regs live on this instr - -> [LiveInstr instr] -> [LiveInstr instr] + :: Instruction instr + => RegSet -- regs live on this instr + -> [LiveInstr instr] -> [LiveInstr instr] -livenessForward _ [] = [] +livenessForward _ [] = [] livenessForward rsLiveEntry (li@(LiveInstr instr mLive) : lis) - | Nothing <- mLive - = li : livenessForward rsLiveEntry lis + | Nothing <- mLive + = li : livenessForward rsLiveEntry lis - | Just live <- mLive - , RU _ written <- regUsageOfInstr instr - = let - -- Regs that are written to but weren't live on entry to this instruction - -- are recorded as being born here. - rsBorn = mkUniqSet - $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written + | Just live <- mLive + , RU _ written <- regUsageOfInstr instr + = let + -- Regs that are written to but weren't live on entry to this instruction + -- are recorded as being born here. + rsBorn = mkUniqSet + $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written - rsLiveNext = (rsLiveEntry `unionUniqSets` rsBorn) - `minusUniqSet` (liveDieRead live) - `minusUniqSet` (liveDieWrite live) + rsLiveNext = (rsLiveEntry `unionUniqSets` rsBorn) + `minusUniqSet` (liveDieRead live) + `minusUniqSet` (liveDieWrite live) - in LiveInstr instr (Just live { liveBorn = rsBorn }) - : livenessForward rsLiveNext lis + in LiveInstr instr (Just live { liveBorn = rsBorn }) + : livenessForward rsLiveNext lis -livenessForward _ _ = panic "RegLiveness.livenessForward: no match" +livenessForward _ _ = panic "RegLiveness.livenessForward: no match" -- | Calculate liveness going backwards, --- filling in when regs die, and what regs are live across each instruction +-- filling in when regs die, and what regs are live across each instruction livenessBack - :: Instruction instr - => RegSet -- regs live on this instr - -> BlockMap RegSet -- regs live on entry to other BBs - -> [LiveInstr instr] -- instructions (accum) - -> [LiveInstr instr] -- instructions - -> (RegSet, [LiveInstr instr]) + :: Instruction instr + => RegSet -- regs live on this instr + -> BlockMap RegSet -- regs live on entry to other BBs + -> [LiveInstr instr] -- instructions (accum) + -> [LiveInstr instr] -- instructions + -> (RegSet, [LiveInstr instr]) livenessBack liveregs _ done [] = (liveregs, done) livenessBack liveregs blockmap acc (instr : instrs) - = let (liveregs', instr') = liveness1 liveregs blockmap instr - in livenessBack liveregs' blockmap (instr' : acc) instrs + = let (liveregs', instr') = liveness1 liveregs blockmap instr + in livenessBack liveregs' blockmap (instr' : acc) instrs -- don't bother tagging comments or deltas with liveness -liveness1 - :: Instruction instr - => RegSet - -> BlockMap RegSet - -> LiveInstr instr - -> (RegSet, LiveInstr instr) +liveness1 + :: Instruction instr + => RegSet + -> BlockMap RegSet + -> LiveInstr instr + -> (RegSet, LiveInstr instr) liveness1 liveregs _ (LiveInstr instr _) - | isMetaInstr instr - = (liveregs, LiveInstr instr Nothing) + | isMetaInstr instr + = (liveregs, LiveInstr instr Nothing) liveness1 liveregs blockmap (LiveInstr instr _) - | not_a_branch - = (liveregs1, LiveInstr instr - (Just $ Liveness - { liveBorn = emptyUniqSet - , liveDieRead = mkUniqSet r_dying - , liveDieWrite = mkUniqSet w_dying })) - - | otherwise - = (liveregs_br, LiveInstr instr - (Just $ Liveness - { liveBorn = emptyUniqSet - , liveDieRead = mkUniqSet r_dying_br - , liveDieWrite = mkUniqSet w_dying })) - - where - RU read written = regUsageOfInstr instr - - -- registers that were written here are dead going backwards. - -- registers that were read here are live going backwards. - liveregs1 = (liveregs `delListFromUniqSet` written) - `addListToUniqSet` read - - -- registers that are not live beyond this point, are recorded - -- as dying here. - r_dying = [ reg | reg <- read, reg `notElem` written, - not (elementOfUniqSet reg liveregs) ] - - w_dying = [ reg | reg <- written, - not (elementOfUniqSet reg liveregs) ] - - -- union in the live regs from all the jump destinations of this - -- instruction. - targets = jumpDestsOfInstr instr -- where we go from here - not_a_branch = null targets - - targetLiveRegs target + | not_a_branch + = (liveregs1, LiveInstr instr + (Just $ Liveness + { liveBorn = emptyUniqSet + , liveDieRead = mkUniqSet r_dying + , liveDieWrite = mkUniqSet w_dying })) + + | otherwise + = (liveregs_br, LiveInstr instr + (Just $ Liveness + { liveBorn = emptyUniqSet + , liveDieRead = mkUniqSet r_dying_br + , liveDieWrite = mkUniqSet w_dying })) + + where + RU read written = regUsageOfInstr instr + + -- registers that were written here are dead going backwards. + -- registers that were read here are live going backwards. + liveregs1 = (liveregs `delListFromUniqSet` written) + `addListToUniqSet` read + + -- registers that are not live beyond this point, are recorded + -- as dying here. + r_dying = [ reg | reg <- read, reg `notElem` written, + not (elementOfUniqSet reg liveregs) ] + + w_dying = [ reg | reg <- written, + not (elementOfUniqSet reg liveregs) ] + + -- union in the live regs from all the jump destinations of this + -- instruction. + targets = jumpDestsOfInstr instr -- where we go from here + not_a_branch = null targets + + targetLiveRegs target = case mapLookup target blockmap of Just ra -> ra Nothing -> emptyRegMap live_from_branch = unionManyUniqSets (map targetLiveRegs targets) - liveregs_br = liveregs1 `unionUniqSets` live_from_branch + liveregs_br = liveregs1 `unionUniqSets` live_from_branch -- registers that are live only in the branch targets should -- be listed as dying here. diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index a4dbbe8771..6f454a3733 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -41,28 +41,30 @@ import OldCmm import CLabel -- The rest: +import DynFlags import StaticFlags ( opt_PIC ) import OrdList import Outputable +import Platform import Unique import Control.Monad ( mapAndUnzipM ) -- | Top level code generation -cmmTopCodeGen - :: RawCmmTop - -> NatM [NatCmmTop Instr] +cmmTopCodeGen :: RawCmmTop + -> NatM [NatCmmTop CmmStatics Instr] -cmmTopCodeGen - (CmmProc info lab (ListGraph blocks)) - = do - (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks +cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) + = do + dflags <- getDynFlagsNat + let platform = targetPlatform dflags + (nat_blocks,statics) <- mapAndUnzipM (basicBlockCodeGen platform) blocks - let proc = CmmProc info lab (ListGraph $ concat nat_blocks) - let tops = proc : concat statics + let proc = CmmProc info lab (ListGraph $ concat nat_blocks) + let tops = proc : concat statics + + return tops - return tops - cmmTopCodeGen (CmmData sec dat) = do return [CmmData sec dat] -- no translation, we just use CmmStatic @@ -72,12 +74,12 @@ cmmTopCodeGen (CmmData sec dat) = do -- are indicated by the NEWBLOCK instruction. We must split up the -- instruction stream into basic blocks again. Also, we extract -- LDATAs here too. -basicBlockCodeGen - :: CmmBasicBlock - -> NatM ( [NatBasicBlock Instr] - , [NatCmmTop Instr]) +basicBlockCodeGen :: Platform + -> CmmBasicBlock + -> NatM ( [NatBasicBlock Instr] + , [NatCmmTop CmmStatics Instr]) -basicBlockCodeGen cmm@(BasicBlock id stmts) = do +basicBlockCodeGen platform cmm@(BasicBlock id stmts) = do instrs <- stmtsToInstrs stmts let (top,other_blocks,statics) @@ -94,7 +96,7 @@ basicBlockCodeGen cmm@(BasicBlock id stmts) = do -- do intra-block sanity checking blocksChecked - = map (checkBlock cmm) + = map (checkBlock platform cmm) $ BasicBlock id top : other_blocks return (blocksChecked, statics) @@ -313,8 +315,8 @@ genSwitch expr ids , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label , NOP ] -generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr) +generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop CmmStatics Instr) generateJumpTableForInstr (JMP_TBL _ ids label) = let jumpTable = map jumpTableEntry ids - in Just (CmmData ReadOnlyData (CmmDataLabel label : jumpTable)) + in Just (CmmData ReadOnlyData (Statics label jumpTable)) generateJumpTableForInstr _ = Nothing diff --git a/compiler/nativeGen/SPARC/CodeGen/CCall.hs b/compiler/nativeGen/SPARC/CodeGen/CCall.hs index 7445f7168e..3e629c47f5 100644 --- a/compiler/nativeGen/SPARC/CodeGen/CCall.hs +++ b/compiler/nativeGen/SPARC/CodeGen/CCall.hs @@ -24,8 +24,10 @@ import CLabel import BasicTypes import OrdList +import DynFlags import FastString import Outputable +import Platform {- Now the biggest nightmare---calls. Most of the nastiness is buried in @@ -137,6 +139,7 @@ genCCall target dest_regs argsAndHints let transfer_code = toOL (move_final vregs allArgRegs extraStackArgsHere) + dflags <- getDynFlagsNat return $ argcode `appOL` move_sp_down `appOL` @@ -144,7 +147,7 @@ genCCall target dest_regs argsAndHints callinsns `appOL` unitOL NOP `appOL` move_sp_up `appOL` - assign_code dest_regs + assign_code (targetPlatform dflags) dest_regs -- | Generate code to calculate an argument, and move it into one @@ -224,11 +227,11 @@ move_final (v:vs) (a:az) offset -- | Assign results returned from the call into their -- desination regs. -- -assign_code :: [CmmHinted LocalReg] -> OrdList Instr +assign_code :: Platform -> [CmmHinted LocalReg] -> OrdList Instr -assign_code [] = nilOL +assign_code _ [] = nilOL -assign_code [CmmHinted dest _hint] +assign_code platform [CmmHinted dest _hint] = let rep = localRegType dest width = typeWidth rep r_dest = getRegisterReg (CmmLocal dest) @@ -244,20 +247,20 @@ assign_code [CmmHinted dest _hint] | not $ isFloatType rep , W32 <- width - = unitOL $ mkRegRegMoveInstr (regSingle $ oReg 0) r_dest + = unitOL $ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest | not $ isFloatType rep , W64 <- width , r_dest_hi <- getHiVRegFromLo r_dest - = toOL [ mkRegRegMoveInstr (regSingle $ oReg 0) r_dest_hi - , mkRegRegMoveInstr (regSingle $ oReg 1) r_dest] + = toOL [ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest_hi + , mkRegRegMoveInstr platform (regSingle $ oReg 1) r_dest] | otherwise = panic "SPARC.CodeGen.GenCCall: no match" in result -assign_code _ +assign_code _ _ = panic "SPARC.CodeGen.GenCCall: no match" diff --git a/compiler/nativeGen/SPARC/CodeGen/Expand.hs b/compiler/nativeGen/SPARC/CodeGen/Expand.hs index d4500e8a8e..3e49f5c025 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Expand.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Expand.hs @@ -21,7 +21,7 @@ import Outputable import OrdList -- | Expand out synthetic instructions in this top level thing -expandTop :: NatCmmTop Instr -> NatCmmTop Instr +expandTop :: NatCmmTop CmmStatics Instr -> NatCmmTop CmmStatics Instr expandTop top@(CmmData{}) = top diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs index 9d6aa5e646..ddeed0508b 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs @@ -83,9 +83,8 @@ getRegister (CmmLit (CmmFloat f W32)) = do let code dst = toOL [ -- the data area - LDATA ReadOnlyData - [CmmDataLabel lbl, - CmmStaticLit (CmmFloat f W32)], + LDATA ReadOnlyData $ Statics lbl + [CmmStaticLit (CmmFloat f W32)], -- load the literal SETHI (HI (ImmCLbl lbl)) tmp, @@ -97,9 +96,8 @@ getRegister (CmmLit (CmmFloat d W64)) = do lbl <- getNewLabelNat tmp <- getNewRegNat II32 let code dst = toOL [ - LDATA ReadOnlyData - [CmmDataLabel lbl, - CmmStaticLit (CmmFloat d W64)], + LDATA ReadOnlyData $ Statics lbl + [CmmStaticLit (CmmFloat d W64)], SETHI (HI (ImmCLbl lbl)) tmp, LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] return (Any FF64 code) diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs index 180ec315ee..6bf2a8f32d 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs @@ -23,6 +23,7 @@ import Reg import OldCmm +import DynFlags import OrdList import Outputable @@ -182,10 +183,12 @@ iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) -- compute expr and load it into r_dst_lo (a_reg, a_code) <- getSomeReg expr - let code = a_code + dflags <- getDynFlagsNat + let platform = targetPlatform dflags + code = a_code `appOL` toOL - [ mkRegRegMoveInstr g0 r_dst_hi -- clear high 32 bits - , mkRegRegMoveInstr a_reg r_dst_lo ] + [ mkRegRegMoveInstr platform g0 r_dst_hi -- clear high 32 bits + , mkRegRegMoveInstr platform a_reg r_dst_lo ] return $ ChildCode64 code r_dst_lo diff --git a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs index ca4c8e4994..a3053cbae8 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs @@ -15,15 +15,17 @@ import Instruction import OldCmm import Outputable +import Platform -- | Enforce intra-block invariants. -- -checkBlock - :: CmmBasicBlock - -> NatBasicBlock Instr -> NatBasicBlock Instr +checkBlock :: Platform + -> CmmBasicBlock + -> NatBasicBlock Instr + -> NatBasicBlock Instr -checkBlock cmm block@(BasicBlock _ instrs) +checkBlock platform cmm block@(BasicBlock _ instrs) | checkBlockInstrs instrs = block @@ -31,9 +33,9 @@ checkBlock cmm block@(BasicBlock _ instrs) = pprPanic ("SPARC.CodeGen: bad block\n") ( vcat [ text " -- cmm -----------------\n" - , ppr cmm + , pprPlatform platform cmm , text " -- native code ---------\n" - , ppr block ]) + , pprPlatform platform block ]) checkBlockInstrs :: [Instr] -> Bool diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs index 93f4d27444..61090e05c8 100644 --- a/compiler/nativeGen/SPARC/Instr.hs +++ b/compiler/nativeGen/SPARC/Instr.hs @@ -43,6 +43,7 @@ import OldCmm import FastString import FastBool import Outputable +import Platform -- | Register or immediate @@ -112,7 +113,7 @@ data Instr -- some static data spat out during code generation. -- Will be extracted before pretty-printing. - | LDATA Section [CmmStatic] + | LDATA Section CmmStatics -- Start a new basic block. Useful during codegen, removed later. -- Preceding instruction should be a jump, as per the invariants @@ -363,15 +364,16 @@ sparc_patchJumpInstr insn patchF -- | Make a spill instruction. -- On SPARC we spill below frame pointer leaving 2 words/spill sparc_mkSpillInstr - :: Reg -- ^ register to spill - -> Int -- ^ current stack delta - -> Int -- ^ spill slot to use - -> Instr + :: Platform + -> Reg -- ^ register to spill + -> Int -- ^ current stack delta + -> Int -- ^ spill slot to use + -> Instr -sparc_mkSpillInstr reg _ slot +sparc_mkSpillInstr platform reg _ slot = let off = spillSlotToOffset slot off_w = 1 + (off `div` 4) - sz = case targetClassOfReg reg of + sz = case targetClassOfReg platform reg of RcInteger -> II32 RcFloat -> FF32 RcDouble -> FF64 @@ -382,15 +384,16 @@ sparc_mkSpillInstr reg _ slot -- | Make a spill reload instruction. sparc_mkLoadInstr - :: Reg -- ^ register to load into - -> Int -- ^ current stack delta - -> Int -- ^ spill slot to use - -> Instr + :: Platform + -> Reg -- ^ register to load into + -> Int -- ^ current stack delta + -> Int -- ^ spill slot to use + -> Instr -sparc_mkLoadInstr reg _ slot +sparc_mkLoadInstr platform reg _ slot = let off = spillSlotToOffset slot off_w = 1 + (off `div` 4) - sz = case targetClassOfReg reg of + sz = case targetClassOfReg platform reg of RcInteger -> II32 RcFloat -> FF32 RcDouble -> FF64 @@ -430,13 +433,14 @@ sparc_isMetaInstr instr -- have to go via memory. -- sparc_mkRegRegMoveInstr - :: Reg - -> Reg - -> Instr - -sparc_mkRegRegMoveInstr src dst - | srcClass <- targetClassOfReg src - , dstClass <- targetClassOfReg dst + :: Platform + -> Reg + -> Reg + -> Instr + +sparc_mkRegRegMoveInstr platform src dst + | srcClass <- targetClassOfReg platform src + , dstClass <- targetClassOfReg platform dst , srcClass == dstClass = case srcClass of RcInteger -> ADD False False src (RIReg g0) dst diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs index d78d1a760e..bf3fd3c303 100644 --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -39,7 +39,8 @@ import CLabel import Unique ( Uniquable(..), pprUnique ) import qualified Outputable -import Outputable (Outputable, panic) +import Outputable (PlatformOutputable, panic) +import Platform import Pretty import FastString import Data.Word @@ -47,24 +48,28 @@ import Data.Word -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmTop :: NatCmmTop Instr -> Doc -pprNatCmmTop (CmmData section dats) = - pprSectionHeader section $$ vcat (map pprData dats) +pprNatCmmTop :: Platform -> NatCmmTop CmmStatics Instr -> Doc +pprNatCmmTop _ (CmmData section dats) = + pprSectionHeader section $$ pprDatas dats -- special case for split markers: -pprNatCmmTop (CmmProc [] lbl (ListGraph [])) = pprLabel lbl +pprNatCmmTop _ (CmmProc Nothing lbl (ListGraph [])) = pprLabel lbl -pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) = + -- special case for code without info table: +pprNatCmmTop _ (CmmProc Nothing lbl (ListGraph blocks)) = pprSectionHeader Text $$ - (if null info then -- blocks guaranteed not null, so label needed - pprLabel lbl - else + pprLabel lbl $$ -- blocks guaranteed not null, so label needed + vcat (map pprBasicBlock blocks) + +pprNatCmmTop _ (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) = + pprSectionHeader Text $$ + ( #if HAVE_SUBSECTIONS_VIA_SYMBOLS - pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) - <> char ':' $$ + pprCLabel_asm (mkDeadStripPreventer info_lbl) + <> char ':' $$ #endif vcat (map pprData info) $$ - pprLabel (entryLblToInfoLbl lbl) + pprLabel info_lbl ) $$ vcat (map pprBasicBlock blocks) -- above: Even the first block gets a label, because with branch-chain @@ -76,12 +81,10 @@ pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) = -- from the entry code to a label on the _top_ of of the info table, -- so that the linker will not think it is unreferenced and dead-strip -- it. That's why the label is called a DeadStripPreventer (_dsp). - $$ if not (null info) - then text "\t.long " - <+> pprCLabel_asm (entryLblToInfoLbl lbl) - <+> char '-' - <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) - else empty + $$ text "\t.long " + <+> pprCLabel_asm info_lbl + <+> char '-' + <+> pprCLabel_asm (mkDeadStripPreventer info_lbl) #endif @@ -91,9 +94,10 @@ pprBasicBlock (BasicBlock blockid instrs) = vcat (map pprInstr instrs) +pprDatas :: CmmStatics -> Doc +pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats) + pprData :: CmmStatic -> Doc -pprData (CmmAlign bytes) = pprAlign bytes -pprData (CmmDataLabel lbl) = pprLabel lbl pprData (CmmString str) = pprASCII str pprData (CmmUninitialised bytes) = ptext (sLit ".skip ") <> int bytes pprData (CmmStaticLit lit) = pprDataItem lit @@ -125,16 +129,12 @@ pprASCII str do1 :: Word8 -> Doc do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w) -pprAlign :: Int -> Doc -pprAlign bytes = - ptext (sLit ".align ") <> int bytes - -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -instance Outputable Instr where - ppr instr = Outputable.docToSDoc $ pprInstr instr +instance PlatformOutputable Instr where + pprPlatform _ instr = Outputable.docToSDoc $ pprInstr instr -- | Pretty print a register. diff --git a/compiler/nativeGen/SPARC/ShortcutJump.hs b/compiler/nativeGen/SPARC/ShortcutJump.hs index 30e48bb377..10e2e9fbaa 100644 --- a/compiler/nativeGen/SPARC/ShortcutJump.hs +++ b/compiler/nativeGen/SPARC/ShortcutJump.hs @@ -3,7 +3,7 @@ module SPARC.ShortcutJump ( JumpDest(..), getJumpDestBlockId, canShortcut, shortcutJump, - shortcutStatic, + shortcutStatics, shortBlockId ) @@ -38,16 +38,23 @@ shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr shortcutJump _ other = other -shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic -shortcutStatic fn (CmmStaticLit (CmmLabel lab)) - | Just uq <- maybeAsmTemp lab - = CmmStaticLit (CmmLabel (shortBlockId fn (mkBlockId uq))) +shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics +shortcutStatics fn (Statics lbl statics) + = Statics lbl $ map (shortcutStatic fn) statics + -- we need to get the jump tables, so apply the mapping to the entries + -- of a CmmData too. -shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) - | Just uq <- maybeAsmTemp lbl1 - = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn (mkBlockId uq)) lbl2 off) +shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel +shortcutLabel fn lab + | Just uq <- maybeAsmTemp lab = shortBlockId fn (mkBlockId uq) + | otherwise = lab +shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic +shortcutStatic fn (CmmStaticLit (CmmLabel lab)) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) +shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) -- slightly dodgy, we're ignoring the second label, but this -- works with the way we use CmmLabelDiffOff for jump tables now. shortcutStatic _ other_static diff --git a/compiler/nativeGen/TargetReg.hs b/compiler/nativeGen/TargetReg.hs index e6427ed499..089269785c 100644 --- a/compiler/nativeGen/TargetReg.hs +++ b/compiler/nativeGen/TargetReg.hs @@ -40,13 +40,9 @@ import qualified PPC.Regs as PPC import qualified SPARC.Regs as SPARC --- TODO: We shouldn't be using defaultTargetPlatform here. --- We should be passing DynFlags in instead, and looking at --- its targetPlatform. - -targetVirtualRegSqueeze :: RegClass -> VirtualReg -> FastInt -targetVirtualRegSqueeze - = case platformArch defaultTargetPlatform of +targetVirtualRegSqueeze :: Platform -> RegClass -> VirtualReg -> FastInt +targetVirtualRegSqueeze platform + = case platformArch platform of ArchX86 -> X86.virtualRegSqueeze ArchX86_64 -> X86.virtualRegSqueeze ArchPPC -> PPC.virtualRegSqueeze @@ -55,9 +51,9 @@ targetVirtualRegSqueeze ArchARM -> panic "targetVirtualRegSqueeze ArchARM" ArchUnknown -> panic "targetVirtualRegSqueeze ArchUnknown" -targetRealRegSqueeze :: RegClass -> RealReg -> FastInt -targetRealRegSqueeze - = case platformArch defaultTargetPlatform of +targetRealRegSqueeze :: Platform -> RegClass -> RealReg -> FastInt +targetRealRegSqueeze platform + = case platformArch platform of ArchX86 -> X86.realRegSqueeze ArchX86_64 -> X86.realRegSqueeze ArchPPC -> PPC.realRegSqueeze @@ -66,9 +62,9 @@ targetRealRegSqueeze ArchARM -> panic "targetRealRegSqueeze ArchARM" ArchUnknown -> panic "targetRealRegSqueeze ArchUnknown" -targetClassOfRealReg :: RealReg -> RegClass -targetClassOfRealReg - = case platformArch defaultTargetPlatform of +targetClassOfRealReg :: Platform -> RealReg -> RegClass +targetClassOfRealReg platform + = case platformArch platform of ArchX86 -> X86.classOfRealReg ArchX86_64 -> X86.classOfRealReg ArchPPC -> PPC.classOfRealReg @@ -81,9 +77,9 @@ targetClassOfRealReg targetWordSize :: Size targetWordSize = intSize wordWidth -targetMkVirtualReg :: Unique -> Size -> VirtualReg -targetMkVirtualReg - = case platformArch defaultTargetPlatform of +targetMkVirtualReg :: Platform -> Unique -> Size -> VirtualReg +targetMkVirtualReg platform + = case platformArch platform of ArchX86 -> X86.mkVirtualReg ArchX86_64 -> X86.mkVirtualReg ArchPPC -> PPC.mkVirtualReg @@ -92,11 +88,11 @@ targetMkVirtualReg ArchARM -> panic "targetMkVirtualReg ArchARM" ArchUnknown -> panic "targetMkVirtualReg ArchUnknown" -targetRegDotColor :: RealReg -> SDoc -targetRegDotColor - = case platformArch defaultTargetPlatform of - ArchX86 -> X86.regDotColor - ArchX86_64 -> X86.regDotColor +targetRegDotColor :: Platform -> RealReg -> SDoc +targetRegDotColor platform + = case platformArch platform of + ArchX86 -> X86.regDotColor platform + ArchX86_64 -> X86.regDotColor platform ArchPPC -> PPC.regDotColor ArchSPARC -> SPARC.regDotColor ArchPPC_64 -> panic "targetRegDotColor ArchPPC_64" @@ -104,10 +100,10 @@ targetRegDotColor ArchUnknown -> panic "targetRegDotColor ArchUnknown" -targetClassOfReg :: Reg -> RegClass -targetClassOfReg reg +targetClassOfReg :: Platform -> Reg -> RegClass +targetClassOfReg platform reg = case reg of - RegVirtual vr -> classOfVirtualReg vr - RegReal rr -> targetClassOfRealReg rr + RegVirtual vr -> classOfVirtualReg vr + RegReal rr -> targetClassOfRealReg platform rr diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index d191733af1..49ac543e65 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -80,7 +80,7 @@ if_sse2 sse2 x87 = do cmmTopCodeGen :: RawCmmTop - -> NatM [NatCmmTop Instr] + -> NatM [NatCmmTop (Alignment, CmmStatics) Instr] cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks @@ -95,13 +95,13 @@ cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do Nothing -> return tops cmmTopCodeGen (CmmData sec dat) = do - return [CmmData sec dat] -- no translation, we just use CmmStatic + return [CmmData sec (1, dat)] -- no translation, we just use CmmStatic basicBlockCodeGen :: CmmBasicBlock -> NatM ( [NatBasicBlock Instr] - , [NatCmmTop Instr]) + , [NatCmmTop (Alignment, CmmStatics) Instr]) basicBlockCodeGen (BasicBlock id stmts) = do instrs <- stmtsToInstrs stmts @@ -1123,10 +1123,7 @@ memConstant align lit = do return (addr, addr_code) else return (ripRel (ImmCLbl lbl), nilOL) let code = - LDATA ReadOnlyData - [CmmAlign align, - CmmDataLabel lbl, - CmmStaticLit lit] + LDATA ReadOnlyData (align, Statics lbl [CmmStaticLit lit]) `consOL` addr_code return (Amode addr code) @@ -2041,11 +2038,11 @@ genSwitch expr ids -- in return code -generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr) +generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop (Alignment, CmmStatics) Instr) generateJumpTableForInstr (JMP_TBL _ ids section lbl) = Just (createJumpTable ids section lbl) generateJumpTableForInstr _ = Nothing -createJumpTable :: [Maybe BlockId] -> Section -> CLabel -> GenCmmTop CmmStatic h g +createJumpTable :: [Maybe BlockId] -> Section -> CLabel -> GenCmmTop (Alignment, CmmStatics) h g createJumpTable ids section lbl = let jumpTable | opt_PIC = @@ -2056,7 +2053,7 @@ createJumpTable ids section lbl where blockLabel = mkAsmTempLabel (getUnique blockid) in map jumpTableEntryRel ids | otherwise = map jumpTableEntry ids - in CmmData section (CmmDataLabel lbl : jumpTable) + in CmmData section (1, Statics lbl jumpTable) -- ----------------------------------------------------------------------------- -- 'condIntReg' and 'condFltReg': condition codes into registers diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index b9c851a859..0e292ac21f 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -25,8 +25,10 @@ import OldCmm import FastString import FastBool import Outputable +import Platform import Constants (rESERVED_C_STACK_BYTES) +import BasicTypes (Alignment) import CLabel import UniqSet import Unique @@ -151,7 +153,6 @@ bit precision. --SDM 1/2003 -} - data Instr -- comment pseudo-op = COMMENT FastString @@ -159,7 +160,7 @@ data Instr -- some static data spat out during code -- generation. Will be extracted before -- pretty-printing. - | LDATA Section [CmmStatic] + | LDATA Section (Alignment, CmmStatics) -- start a new basic block. Useful during -- codegen, removed later. Preceding @@ -603,16 +604,17 @@ x86_patchJumpInstr insn patchF -- ----------------------------------------------------------------------------- -- | Make a spill instruction. x86_mkSpillInstr - :: Reg -- register to spill - -> Int -- current stack delta - -> Int -- spill slot to use - -> Instr + :: Platform + -> Reg -- register to spill + -> Int -- current stack delta + -> Int -- spill slot to use + -> Instr -x86_mkSpillInstr reg delta slot +x86_mkSpillInstr platform reg delta slot = let off = spillSlotToOffset slot in let off_w = (off-delta) `div` IF_ARCH_i386(4,8) - in case targetClassOfReg reg of + in case targetClassOfReg platform reg of RcInteger -> MOV IF_ARCH_i386(II32,II64) (OpReg reg) (OpAddr (spRel off_w)) RcDouble -> GST FF80 reg (spRel off_w) {- RcFloat/RcDouble -} @@ -622,16 +624,17 @@ x86_mkSpillInstr reg delta slot -- | Make a spill reload instruction. x86_mkLoadInstr - :: Reg -- register to load - -> Int -- current stack delta - -> Int -- spill slot to use - -> Instr + :: Platform + -> Reg -- register to load + -> Int -- current stack delta + -> Int -- spill slot to use + -> Instr -x86_mkLoadInstr reg delta slot +x86_mkLoadInstr platform reg delta slot = let off = spillSlotToOffset slot in let off_w = (off-delta) `div` IF_ARCH_i386(4,8) - in case targetClassOfReg reg of + in case targetClassOfReg platform reg of RcInteger -> MOV IF_ARCH_i386(II32,II64) (OpAddr (spRel off_w)) (OpReg reg) RcDouble -> GLD FF80 (spRel off_w) reg {- RcFloat/RcDouble -} @@ -689,12 +692,13 @@ x86_isMetaInstr instr -- have to go via memory. -- x86_mkRegRegMoveInstr - :: Reg - -> Reg - -> Instr + :: Platform + -> Reg + -> Reg + -> Instr -x86_mkRegRegMoveInstr src dst - = case targetClassOfReg src of +x86_mkRegRegMoveInstr platform src dst + = case targetClassOfReg platform src of #if i386_TARGET_ARCH RcInteger -> MOV II32 (OpReg src) (OpReg dst) #else @@ -805,16 +809,24 @@ shortcutJump fn insn = shortcutJump' fn (setEmpty :: BlockSet) insn shortcutJump' _ _ other = other -- Here because it knows about JumpDest +shortcutStatics :: (BlockId -> Maybe JumpDest) -> (Alignment, CmmStatics) -> (Alignment, CmmStatics) +shortcutStatics fn (align, Statics lbl statics) + = (align, Statics lbl $ map (shortcutStatic fn) statics) + -- we need to get the jump tables, so apply the mapping to the entries + -- of a CmmData too. + +shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel +shortcutLabel fn lab + | Just uq <- maybeAsmTemp lab = shortBlockId fn emptyUniqSet (mkBlockId uq) + | otherwise = lab + shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic shortcutStatic fn (CmmStaticLit (CmmLabel lab)) - | Just uq <- maybeAsmTemp lab - = CmmStaticLit (CmmLabel (shortBlockId fn emptyUniqSet (mkBlockId uq))) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) - | Just uq <- maybeAsmTemp lbl1 - = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn emptyUniqSet (mkBlockId uq)) lbl2 off) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) -- slightly dodgy, we're ignoring the second label, but this -- works with the way we use CmmLabelDiffOff for jump tables now. - shortcutStatic _ other_static = other_static diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index 769057ae02..a755d839fb 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -31,13 +31,15 @@ import Reg import PprBase +import BasicTypes (Alignment) import OldCmm import CLabel import Unique ( pprUnique, Uniquable(..) ) +import Platform import Pretty import FastString import qualified Outputable -import Outputable (panic, Outputable) +import Outputable (panic, PlatformOutputable) import Data.Word @@ -48,26 +50,31 @@ import Data.Bits -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmTop :: NatCmmTop Instr -> Doc -pprNatCmmTop (CmmData section dats) = - pprSectionHeader section $$ vcat (map pprData dats) +pprNatCmmTop :: Platform -> NatCmmTop (Alignment, CmmStatics) Instr -> Doc +pprNatCmmTop platform (CmmData section dats) = + pprSectionHeader section $$ pprDatas platform dats -- special case for split markers: -pprNatCmmTop (CmmProc [] lbl (ListGraph [])) = pprLabel lbl +pprNatCmmTop platform (CmmProc Nothing lbl (ListGraph [])) = pprLabel platform lbl -pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) = + -- special case for code without info table: +pprNatCmmTop platform (CmmProc Nothing lbl (ListGraph blocks)) = pprSectionHeader Text $$ - (if null info then -- blocks guaranteed not null, so label needed - pprLabel lbl - else + pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed + vcat (map (pprBasicBlock platform) blocks) $$ + pprSizeDecl platform lbl + +pprNatCmmTop platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) = + pprSectionHeader Text $$ + ( #if HAVE_SUBSECTIONS_VIA_SYMBOLS - pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) - <> char ':' $$ + pprCLabel_asm (mkDeadStripPreventer info_lbl) + <> char ':' $$ #endif - vcat (map pprData info) $$ - pprLabel (entryLblToInfoLbl lbl) + vcat (map (pprData platform) info) $$ + pprLabel platform info_lbl ) $$ - vcat (map pprBasicBlock blocks) + vcat (map (pprBasicBlock platform) blocks) -- above: Even the first block gets a label, because with branch-chain -- elimination, it might be the target of a goto. #if HAVE_SUBSECTIONS_VIA_SYMBOLS @@ -77,62 +84,57 @@ pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) = -- from the entry code to a label on the _top_ of of the info table, -- so that the linker will not think it is unreferenced and dead-strip -- it. That's why the label is called a DeadStripPreventer (_dsp). - $$ if not (null info) - then text "\t.long " - <+> pprCLabel_asm (entryLblToInfoLbl lbl) - <+> char '-' - <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) - else empty + $$ text "\t.long " + <+> pprCLabel_asm info_lbl + <+> char '-' + <+> pprCLabel_asm (mkDeadStripPreventer info_lbl) #endif - $$ pprSizeDecl (if null info then lbl else entryLblToInfoLbl lbl) + $$ pprSizeDecl platform info_lbl -- | Output the ELF .size directive. -pprSizeDecl :: CLabel -> Doc -#if elf_OBJ_FORMAT -pprSizeDecl lbl = +pprSizeDecl :: Platform -> CLabel -> Doc +pprSizeDecl platform lbl + | osElfTarget (platformOS platform) = ptext (sLit "\t.size") <+> pprCLabel_asm lbl <> ptext (sLit ", .-") <> pprCLabel_asm lbl -#else -pprSizeDecl _ = empty -#endif + | otherwise = empty -pprBasicBlock :: NatBasicBlock Instr -> Doc -pprBasicBlock (BasicBlock blockid instrs) = - pprLabel (mkAsmTempLabel (getUnique blockid)) $$ - vcat (map pprInstr instrs) +pprBasicBlock :: Platform -> NatBasicBlock Instr -> Doc +pprBasicBlock platform (BasicBlock blockid instrs) = + pprLabel platform (mkAsmTempLabel (getUnique blockid)) $$ + vcat (map (pprInstr platform) instrs) -pprData :: CmmStatic -> Doc -pprData (CmmAlign bytes) = pprAlign bytes -pprData (CmmDataLabel lbl) = pprLabel lbl -pprData (CmmString str) = pprASCII str +pprDatas :: Platform -> (Alignment, CmmStatics) -> Doc +pprDatas platform (align, (Statics lbl dats)) + = vcat (pprAlign platform align : pprLabel platform lbl : map (pprData platform) dats) + -- TODO: could remove if align == 1 -#if darwin_TARGET_OS -pprData (CmmUninitialised bytes) = ptext (sLit ".space ") <> int bytes -#else -pprData (CmmUninitialised bytes) = ptext (sLit ".skip ") <> int bytes -#endif +pprData :: Platform -> CmmStatic -> Doc +pprData _ (CmmString str) = pprASCII str -pprData (CmmStaticLit lit) = pprDataItem lit +pprData platform (CmmUninitialised bytes) + | platformOS platform == OSDarwin = ptext (sLit ".space ") <> int bytes + | otherwise = ptext (sLit ".skip ") <> int bytes + +pprData _ (CmmStaticLit lit) = pprDataItem lit pprGloblDecl :: CLabel -> Doc pprGloblDecl lbl | not (externallyVisibleCLabel lbl) = empty | otherwise = ptext (sLit ".globl ") <> pprCLabel_asm lbl -pprTypeAndSizeDecl :: CLabel -> Doc -#if elf_OBJ_FORMAT -pprTypeAndSizeDecl lbl - | not (externallyVisibleCLabel lbl) = empty - | otherwise = ptext (sLit ".type ") <> - pprCLabel_asm lbl <> ptext (sLit ", @object") -#else -pprTypeAndSizeDecl _ - = empty -#endif +pprTypeAndSizeDecl :: Platform -> CLabel -> Doc +pprTypeAndSizeDecl platform lbl + | osElfTarget (platformOS platform) && externallyVisibleCLabel lbl + = ptext (sLit ".type ") <> + pprCLabel_asm lbl <> ptext (sLit ", @object") + | otherwise = empty -pprLabel :: CLabel -> Doc -pprLabel lbl = pprGloblDecl lbl $$ pprTypeAndSizeDecl lbl $$ (pprCLabel_asm lbl <> char ':') +pprLabel :: Platform -> CLabel -> Doc +pprLabel platform lbl = pprGloblDecl lbl + $$ pprTypeAndSizeDecl platform lbl + $$ (pprCLabel_asm lbl <> char ':') pprASCII :: [Word8] -> Doc @@ -142,15 +144,13 @@ pprASCII str do1 :: Word8 -> Doc do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w) -pprAlign :: Int -> Doc - - -pprAlign bytes - = ptext (sLit ".align ") <> int IF_OS_darwin(pow2, bytes) +pprAlign :: Platform -> Int -> Doc +pprAlign platform bytes + = ptext (sLit ".align ") <> int alignment where - -#if darwin_TARGET_OS - pow2 = log2 bytes + alignment = if platformOS platform == OSDarwin + then log2 bytes + else bytes log2 :: Int -> Int -- cache the common ones log2 1 = 0 @@ -158,18 +158,16 @@ pprAlign bytes log2 4 = 2 log2 8 = 3 log2 n = 1 + log2 (n `quot` 2) -#endif -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -instance Outputable Instr where - ppr instr = Outputable.docToSDoc $ pprInstr instr - +instance PlatformOutputable Instr where + pprPlatform platform instr = Outputable.docToSDoc $ pprInstr platform instr -pprReg :: Size -> Reg -> Doc -pprReg s r +pprReg :: Platform -> Size -> Reg -> Doc +pprReg _ s r = case r of RegReal (RealRegSingle i) -> ppr_reg_no s i RegReal (RealRegPair _ _) -> panic "X86.Ppr: no reg pairs on this arch" @@ -338,8 +336,8 @@ pprImm (ImmConstantDiff a b) = pprImm a <> char '-' -pprAddr :: AddrMode -> Doc -pprAddr (ImmAddr imm off) +pprAddr :: Platform -> AddrMode -> Doc +pprAddr _ (ImmAddr imm off) = let pp_imm = pprImm imm in if (off == 0) then @@ -349,11 +347,11 @@ pprAddr (ImmAddr imm off) else pp_imm <> char '+' <> int off -pprAddr (AddrBaseIndex base index displacement) +pprAddr platform (AddrBaseIndex base index displacement) = let pp_disp = ppr_disp displacement pp_off p = pp_disp <> char '(' <> p <> char ')' - pp_reg r = pprReg archWordSize r + pp_reg r = pprReg platform archWordSize r in case (base, index) of (EABaseNone, EAIndexNone) -> pp_disp @@ -486,23 +484,23 @@ pprDataItem lit -pprInstr :: Instr -> Doc +pprInstr :: Platform -> Instr -> Doc -pprInstr (COMMENT _) = empty -- nuke 'em +pprInstr _ (COMMENT _) = empty -- nuke 'em {- -pprInstr (COMMENT s) = ptext (sLit "# ") <> ftext s +pprInstr _ (COMMENT s) = ptext (sLit "# ") <> ftext s -} -pprInstr (DELTA d) - = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d))) +pprInstr platform (DELTA d) + = pprInstr platform (COMMENT (mkFastString ("\tdelta = " ++ show d))) -pprInstr (NEWBLOCK _) +pprInstr _ (NEWBLOCK _) = panic "PprMach.pprInstr: NEWBLOCK" -pprInstr (LDATA _ _) +pprInstr _ (LDATA _ _) = panic "PprMach.pprInstr: LDATA" {- -pprInstr (SPILL reg slot) +pprInstr _ (SPILL reg slot) = hcat [ ptext (sLit "\tSPILL"), char ' ', @@ -510,7 +508,7 @@ pprInstr (SPILL reg slot) comma, ptext (sLit "SLOT") <> parens (int slot)] -pprInstr (RELOAD slot reg) +pprInstr _ (RELOAD slot reg) = hcat [ ptext (sLit "\tRELOAD"), char ' ', @@ -519,48 +517,48 @@ pprInstr (RELOAD slot reg) pprUserReg reg] -} -pprInstr (MOV size src dst) - = pprSizeOpOp (sLit "mov") size src dst +pprInstr platform (MOV size src dst) + = pprSizeOpOp platform (sLit "mov") size src dst -pprInstr (MOVZxL II32 src dst) = pprSizeOpOp (sLit "mov") II32 src dst +pprInstr platform (MOVZxL II32 src dst) = pprSizeOpOp platform (sLit "mov") II32 src dst -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple -- movl. But we represent it as a MOVZxL instruction, because -- the reg alloc would tend to throw away a plain reg-to-reg -- move, and we still want it to do that. -pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce (sLit "movz") sizes II32 src dst +pprInstr platform (MOVZxL sizes src dst) = pprSizeOpOpCoerce platform (sLit "movz") sizes II32 src dst -- zero-extension only needs to extend to 32 bits: on x86_64, -- the remaining zero-extension to 64 bits is automatic, and the 32-bit -- instruction is shorter. -pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce (sLit "movs") sizes archWordSize src dst +pprInstr platform (MOVSxL sizes src dst) = pprSizeOpOpCoerce platform (sLit "movs") sizes archWordSize src dst -- here we do some patching, since the physical registers are only set late -- in the code generation. -pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)) +pprInstr platform (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)) | reg1 == reg3 - = pprSizeOpOp (sLit "add") size (OpReg reg2) dst + = pprSizeOpOp platform (sLit "add") size (OpReg reg2) dst -pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)) +pprInstr platform (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)) | reg2 == reg3 - = pprSizeOpOp (sLit "add") size (OpReg reg1) dst + = pprSizeOpOp platform (sLit "add") size (OpReg reg1) dst -pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3)) +pprInstr platform (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3)) | reg1 == reg3 - = pprInstr (ADD size (OpImm displ) dst) + = pprInstr platform (ADD size (OpImm displ) dst) -pprInstr (LEA size src dst) = pprSizeOpOp (sLit "lea") size src dst +pprInstr platform (LEA size src dst) = pprSizeOpOp platform (sLit "lea") size src dst -pprInstr (ADD size (OpImm (ImmInt (-1))) dst) - = pprSizeOp (sLit "dec") size dst -pprInstr (ADD size (OpImm (ImmInt 1)) dst) - = pprSizeOp (sLit "inc") size dst -pprInstr (ADD size src dst) - = pprSizeOpOp (sLit "add") size src dst -pprInstr (ADC size src dst) - = pprSizeOpOp (sLit "adc") size src dst -pprInstr (SUB size src dst) = pprSizeOpOp (sLit "sub") size src dst -pprInstr (IMUL size op1 op2) = pprSizeOpOp (sLit "imul") size op1 op2 +pprInstr platform (ADD size (OpImm (ImmInt (-1))) dst) + = pprSizeOp platform (sLit "dec") size dst +pprInstr platform (ADD size (OpImm (ImmInt 1)) dst) + = pprSizeOp platform (sLit "inc") size dst +pprInstr platform (ADD size src dst) + = pprSizeOpOp platform (sLit "add") size src dst +pprInstr platform (ADC size src dst) + = pprSizeOpOp platform (sLit "adc") size src dst +pprInstr platform (SUB size src dst) = pprSizeOpOp platform (sLit "sub") size src dst +pprInstr platform (IMUL size op1 op2) = pprSizeOpOp platform (sLit "imul") size op1 op2 {- A hack. The Intel documentation says that "The two and three operand forms [of IMUL] may also be used with unsigned operands @@ -569,25 +567,25 @@ pprInstr (IMUL size op1 op2) = pprSizeOpOp (sLit "imul") size op1 op2 however, cannot be used to determine if the upper half of the result is non-zero." So there. -} -pprInstr (AND size src dst) = pprSizeOpOp (sLit "and") size src dst -pprInstr (OR size src dst) = pprSizeOpOp (sLit "or") size src dst +pprInstr platform (AND size src dst) = pprSizeOpOp platform (sLit "and") size src dst +pprInstr platform (OR size src dst) = pprSizeOpOp platform (sLit "or") size src dst -pprInstr (XOR FF32 src dst) = pprOpOp (sLit "xorps") FF32 src dst -pprInstr (XOR FF64 src dst) = pprOpOp (sLit "xorpd") FF64 src dst -pprInstr (XOR size src dst) = pprSizeOpOp (sLit "xor") size src dst +pprInstr platform (XOR FF32 src dst) = pprOpOp platform (sLit "xorps") FF32 src dst +pprInstr platform (XOR FF64 src dst) = pprOpOp platform (sLit "xorpd") FF64 src dst +pprInstr platform (XOR size src dst) = pprSizeOpOp platform (sLit "xor") size src dst -pprInstr (NOT size op) = pprSizeOp (sLit "not") size op -pprInstr (NEGI size op) = pprSizeOp (sLit "neg") size op +pprInstr platform (NOT size op) = pprSizeOp platform (sLit "not") size op +pprInstr platform (NEGI size op) = pprSizeOp platform (sLit "neg") size op -pprInstr (SHL size src dst) = pprShift (sLit "shl") size src dst -pprInstr (SAR size src dst) = pprShift (sLit "sar") size src dst -pprInstr (SHR size src dst) = pprShift (sLit "shr") size src dst +pprInstr platform (SHL size src dst) = pprShift platform (sLit "shl") size src dst +pprInstr platform (SAR size src dst) = pprShift platform (sLit "sar") size src dst +pprInstr platform (SHR size src dst) = pprShift platform (sLit "shr") size src dst -pprInstr (BT size imm src) = pprSizeImmOp (sLit "bt") size imm src +pprInstr platform (BT size imm src) = pprSizeImmOp platform (sLit "bt") size imm src -pprInstr (CMP size src dst) - | is_float size = pprSizeOpOp (sLit "ucomi") size src dst -- SSE2 - | otherwise = pprSizeOpOp (sLit "cmp") size src dst +pprInstr platform (CMP size src dst) + | is_float size = pprSizeOpOp platform (sLit "ucomi") size src dst -- SSE2 + | otherwise = pprSizeOpOp platform (sLit "cmp") size src dst where -- This predicate is needed here and nowhere else is_float FF32 = True @@ -595,63 +593,63 @@ pprInstr (CMP size src dst) is_float FF80 = True is_float _ = False -pprInstr (TEST size src dst) = pprSizeOpOp (sLit "test") size src dst -pprInstr (PUSH size op) = pprSizeOp (sLit "push") size op -pprInstr (POP size op) = pprSizeOp (sLit "pop") size op +pprInstr platform (TEST size src dst) = pprSizeOpOp platform (sLit "test") size src dst +pprInstr platform (PUSH size op) = pprSizeOp platform (sLit "push") size op +pprInstr platform (POP size op) = pprSizeOp platform (sLit "pop") size op -- both unused (SDM): -- pprInstr PUSHA = ptext (sLit "\tpushal") -- pprInstr POPA = ptext (sLit "\tpopal") -pprInstr NOP = ptext (sLit "\tnop") -pprInstr (CLTD II32) = ptext (sLit "\tcltd") -pprInstr (CLTD II64) = ptext (sLit "\tcqto") +pprInstr _ NOP = ptext (sLit "\tnop") +pprInstr _ (CLTD II32) = ptext (sLit "\tcltd") +pprInstr _ (CLTD II64) = ptext (sLit "\tcqto") -pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op) +pprInstr platform (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand platform II8 op) -pprInstr (JXX cond blockid) +pprInstr _ (JXX cond blockid) = pprCondInstr (sLit "j") cond (pprCLabel_asm lab) where lab = mkAsmTempLabel (getUnique blockid) -pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm) +pprInstr _ (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm) -pprInstr (JMP (OpImm imm)) = (<>) (ptext (sLit "\tjmp ")) (pprImm imm) -pprInstr (JMP op) = (<>) (ptext (sLit "\tjmp *")) (pprOperand archWordSize op) -pprInstr (JMP_TBL op _ _ _) = pprInstr (JMP op) -pprInstr (CALL (Left imm) _) = (<>) (ptext (sLit "\tcall ")) (pprImm imm) -pprInstr (CALL (Right reg) _) = (<>) (ptext (sLit "\tcall *")) (pprReg archWordSize reg) +pprInstr _ (JMP (OpImm imm)) = (<>) (ptext (sLit "\tjmp ")) (pprImm imm) +pprInstr platform (JMP op) = (<>) (ptext (sLit "\tjmp *")) (pprOperand platform archWordSize op) +pprInstr platform (JMP_TBL op _ _ _) = pprInstr platform (JMP op) +pprInstr _ (CALL (Left imm) _) = (<>) (ptext (sLit "\tcall ")) (pprImm imm) +pprInstr platform (CALL (Right reg) _) = (<>) (ptext (sLit "\tcall *")) (pprReg platform archWordSize reg) -pprInstr (IDIV sz op) = pprSizeOp (sLit "idiv") sz op -pprInstr (DIV sz op) = pprSizeOp (sLit "div") sz op -pprInstr (IMUL2 sz op) = pprSizeOp (sLit "imul") sz op +pprInstr platform (IDIV sz op) = pprSizeOp platform (sLit "idiv") sz op +pprInstr platform (DIV sz op) = pprSizeOp platform (sLit "div") sz op +pprInstr platform (IMUL2 sz op) = pprSizeOp platform (sLit "imul") sz op -- x86_64 only -pprInstr (MUL size op1 op2) = pprSizeOpOp (sLit "mul") size op1 op2 +pprInstr platform (MUL size op1 op2) = pprSizeOpOp platform (sLit "mul") size op1 op2 -pprInstr (FDIV size op1 op2) = pprSizeOpOp (sLit "div") size op1 op2 +pprInstr platform (FDIV size op1 op2) = pprSizeOpOp platform (sLit "div") size op1 op2 -pprInstr (CVTSS2SD from to) = pprRegReg (sLit "cvtss2sd") from to -pprInstr (CVTSD2SS from to) = pprRegReg (sLit "cvtsd2ss") from to -pprInstr (CVTTSS2SIQ sz from to) = pprSizeSizeOpReg (sLit "cvttss2si") FF32 sz from to -pprInstr (CVTTSD2SIQ sz from to) = pprSizeSizeOpReg (sLit "cvttsd2si") FF64 sz from to -pprInstr (CVTSI2SS sz from to) = pprSizeOpReg (sLit "cvtsi2ss") sz from to -pprInstr (CVTSI2SD sz from to) = pprSizeOpReg (sLit "cvtsi2sd") sz from to +pprInstr platform (CVTSS2SD from to) = pprRegReg platform (sLit "cvtss2sd") from to +pprInstr platform (CVTSD2SS from to) = pprRegReg platform (sLit "cvtsd2ss") from to +pprInstr platform (CVTTSS2SIQ sz from to) = pprSizeSizeOpReg platform (sLit "cvttss2si") FF32 sz from to +pprInstr platform (CVTTSD2SIQ sz from to) = pprSizeSizeOpReg platform (sLit "cvttsd2si") FF64 sz from to +pprInstr platform (CVTSI2SS sz from to) = pprSizeOpReg platform (sLit "cvtsi2ss") sz from to +pprInstr platform (CVTSI2SD sz from to) = pprSizeOpReg platform (sLit "cvtsi2sd") sz from to -- FETCHGOT for PIC on ELF platforms -pprInstr (FETCHGOT reg) +pprInstr platform (FETCHGOT reg) = vcat [ ptext (sLit "\tcall 1f"), - hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ], + hcat [ ptext (sLit "1:\tpopl\t"), pprReg platform II32 reg ], hcat [ ptext (sLit "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "), - pprReg II32 reg ] + pprReg platform II32 reg ] ] -- FETCHPC for PIC on Darwin/x86 -- get the instruction pointer into a register -- (Terminology note: the IP is called Program Counter on PPC, -- and it's a good thing to use the same name on both platforms) -pprInstr (FETCHPC reg) +pprInstr platform (FETCHPC reg) = vcat [ ptext (sLit "\tcall 1f"), - hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ] + hcat [ ptext (sLit "1:\tpopl\t"), pprReg platform II32 reg ] ] @@ -661,36 +659,36 @@ pprInstr (FETCHPC reg) -- Simulating a flat register set on the x86 FP stack is tricky. -- you have to free %st(7) before pushing anything on the FP reg stack -- so as to preclude the possibility of a FP stack overflow exception. -pprInstr g@(GMOV src dst) +pprInstr platform g@(GMOV src dst) | src == dst = empty | otherwise - = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1]) + = pprG platform g (hcat [gtab, gpush src 0, gsemi, gpop dst 1]) -- GLD sz addr dst ==> FLDsz addr ; FSTP (dst+1) -pprInstr g@(GLD sz addr dst) - = pprG g (hcat [gtab, text "fld", pprSize_x87 sz, gsp, - pprAddr addr, gsemi, gpop dst 1]) +pprInstr platform g@(GLD sz addr dst) + = pprG platform g (hcat [gtab, text "fld", pprSize_x87 sz, gsp, + pprAddr platform addr, gsemi, gpop dst 1]) -- GST sz src addr ==> FLD dst ; FSTPsz addr -pprInstr g@(GST sz src addr) +pprInstr platform g@(GST sz src addr) | src == fake0 && sz /= FF80 -- fstt instruction doesn't exist - = pprG g (hcat [gtab, - text "fst", pprSize_x87 sz, gsp, pprAddr addr]) + = pprG platform g (hcat [gtab, + text "fst", pprSize_x87 sz, gsp, pprAddr platform addr]) | otherwise - = pprG g (hcat [gtab, gpush src 0, gsemi, - text "fstp", pprSize_x87 sz, gsp, pprAddr addr]) + = pprG platform g (hcat [gtab, gpush src 0, gsemi, + text "fstp", pprSize_x87 sz, gsp, pprAddr platform addr]) -pprInstr g@(GLDZ dst) - = pprG g (hcat [gtab, text "fldz ; ", gpop dst 1]) -pprInstr g@(GLD1 dst) - = pprG g (hcat [gtab, text "fld1 ; ", gpop dst 1]) +pprInstr platform g@(GLDZ dst) + = pprG platform g (hcat [gtab, text "fldz ; ", gpop dst 1]) +pprInstr platform g@(GLD1 dst) + = pprG platform g (hcat [gtab, text "fld1 ; ", gpop dst 1]) -pprInstr (GFTOI src dst) - = pprInstr (GDTOI src dst) +pprInstr platform (GFTOI src dst) + = pprInstr platform (GDTOI src dst) -pprInstr g@(GDTOI src dst) - = pprG g (vcat [ +pprInstr platform g@(GDTOI src dst) + = pprG platform g (vcat [ hcat [gtab, text "subl $8, %esp ; fnstcw 4(%esp)"], hcat [gtab, gpush src 0], hcat [gtab, text "movzwl 4(%esp), ", reg, @@ -701,20 +699,20 @@ pprInstr g@(GDTOI src dst) hcat [gtab, text "addl $8, %esp"] ]) where - reg = pprReg II32 dst + reg = pprReg platform II32 dst -pprInstr (GITOF src dst) - = pprInstr (GITOD src dst) +pprInstr platform (GITOF src dst) + = pprInstr platform (GITOD src dst) -pprInstr g@(GITOD src dst) - = pprG g (hcat [gtab, text "pushl ", pprReg II32 src, - text " ; fildl (%esp) ; ", - gpop dst 1, text " ; addl $4,%esp"]) +pprInstr platform g@(GITOD src dst) + = pprG platform g (hcat [gtab, text "pushl ", pprReg platform II32 src, + text " ; fildl (%esp) ; ", + gpop dst 1, text " ; addl $4,%esp"]) -pprInstr g@(GDTOF src dst) - = pprG g (vcat [gtab <> gpush src 0, - gtab <> text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ;", - gtab <> gpop dst 1]) +pprInstr platform g@(GDTOF src dst) + = pprG platform g (vcat [gtab <> gpush src 0, + gtab <> text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ;", + gtab <> gpop dst 1]) {- Gruesome swamp follows. If you're unfortunate enough to have ventured this far into the jungle AND you give a Rat's Ass (tm) what's going @@ -754,9 +752,9 @@ pprInstr g@(GDTOF src dst) decb %al -- if (incomparable || different) then (%al == 0, ZF=1) else (%al == 0xFF, ZF=0) -} -pprInstr g@(GCMP cond src1 src2) +pprInstr platform g@(GCMP cond src1 src2) | case cond of { NE -> True; _ -> False } - = pprG g (vcat [ + = pprG platform g (vcat [ hcat [gtab, text "pushl %eax ; ",gpush src1 0], hcat [gtab, text "fcomp ", greg src2 1, text "; fstsw %ax ; sahf ; setpe %ah"], @@ -764,7 +762,7 @@ pprInstr g@(GCMP cond src1 src2) text "orb %ah,%al ; decb %al ; popl %eax"] ]) | otherwise - = pprG g (vcat [ + = pprG platform g (vcat [ hcat [gtab, text "pushl %eax ; ",gpush src1 0], hcat [gtab, text "fcomp ", greg src2 1, text "; fstsw %ax ; sahf ; setpo %ah"], @@ -786,95 +784,95 @@ pprInstr g@(GCMP cond src1 src2) -- there should be no others -pprInstr g@(GABS _ src dst) - = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1]) +pprInstr platform g@(GABS _ src dst) + = pprG platform g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1]) -pprInstr g@(GNEG _ src dst) - = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1]) +pprInstr platform g@(GNEG _ src dst) + = pprG platform g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1]) -pprInstr g@(GSQRT sz src dst) - = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$ - hcat [gtab, gcoerceto sz, gpop dst 1]) +pprInstr platform g@(GSQRT sz src dst) + = pprG platform g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$ + hcat [gtab, gcoerceto sz, gpop dst 1]) -pprInstr g@(GSIN sz l1 l2 src dst) - = pprG g (pprTrigOp "fsin" False l1 l2 src dst sz) +pprInstr platform g@(GSIN sz l1 l2 src dst) + = pprG platform g (pprTrigOp "fsin" False l1 l2 src dst sz) -pprInstr g@(GCOS sz l1 l2 src dst) - = pprG g (pprTrigOp "fcos" False l1 l2 src dst sz) +pprInstr platform g@(GCOS sz l1 l2 src dst) + = pprG platform g (pprTrigOp "fcos" False l1 l2 src dst sz) -pprInstr g@(GTAN sz l1 l2 src dst) - = pprG g (pprTrigOp "fptan" True l1 l2 src dst sz) +pprInstr platform g@(GTAN sz l1 l2 src dst) + = pprG platform g (pprTrigOp "fptan" True l1 l2 src dst sz) -- In the translations for GADD, GMUL, GSUB and GDIV, -- the first two cases are mere optimisations. The otherwise clause -- generates correct code under all circumstances. -pprInstr g@(GADD _ src1 src2 dst) +pprInstr platform g@(GADD _ src1 src2 dst) | src1 == dst - = pprG g (text "\t#GADD-xxxcase1" $$ - hcat [gtab, gpush src2 0, - text " ; faddp %st(0),", greg src1 1]) + = pprG platform g (text "\t#GADD-xxxcase1" $$ + hcat [gtab, gpush src2 0, + text " ; faddp %st(0),", greg src1 1]) | src2 == dst - = pprG g (text "\t#GADD-xxxcase2" $$ - hcat [gtab, gpush src1 0, - text " ; faddp %st(0),", greg src2 1]) + = pprG platform g (text "\t#GADD-xxxcase2" $$ + hcat [gtab, gpush src1 0, + text " ; faddp %st(0),", greg src2 1]) | otherwise - = pprG g (hcat [gtab, gpush src1 0, - text " ; fadd ", greg src2 1, text ",%st(0)", - gsemi, gpop dst 1]) + = pprG platform g (hcat [gtab, gpush src1 0, + text " ; fadd ", greg src2 1, text ",%st(0)", + gsemi, gpop dst 1]) -pprInstr g@(GMUL _ src1 src2 dst) +pprInstr platform g@(GMUL _ src1 src2 dst) | src1 == dst - = pprG g (text "\t#GMUL-xxxcase1" $$ - hcat [gtab, gpush src2 0, - text " ; fmulp %st(0),", greg src1 1]) + = pprG platform g (text "\t#GMUL-xxxcase1" $$ + hcat [gtab, gpush src2 0, + text " ; fmulp %st(0),", greg src1 1]) | src2 == dst - = pprG g (text "\t#GMUL-xxxcase2" $$ - hcat [gtab, gpush src1 0, - text " ; fmulp %st(0),", greg src2 1]) + = pprG platform g (text "\t#GMUL-xxxcase2" $$ + hcat [gtab, gpush src1 0, + text " ; fmulp %st(0),", greg src2 1]) | otherwise - = pprG g (hcat [gtab, gpush src1 0, - text " ; fmul ", greg src2 1, text ",%st(0)", - gsemi, gpop dst 1]) + = pprG platform g (hcat [gtab, gpush src1 0, + text " ; fmul ", greg src2 1, text ",%st(0)", + gsemi, gpop dst 1]) -pprInstr g@(GSUB _ src1 src2 dst) +pprInstr platform g@(GSUB _ src1 src2 dst) | src1 == dst - = pprG g (text "\t#GSUB-xxxcase1" $$ - hcat [gtab, gpush src2 0, - text " ; fsubrp %st(0),", greg src1 1]) + = pprG platform g (text "\t#GSUB-xxxcase1" $$ + hcat [gtab, gpush src2 0, + text " ; fsubrp %st(0),", greg src1 1]) | src2 == dst - = pprG g (text "\t#GSUB-xxxcase2" $$ - hcat [gtab, gpush src1 0, - text " ; fsubp %st(0),", greg src2 1]) + = pprG platform g (text "\t#GSUB-xxxcase2" $$ + hcat [gtab, gpush src1 0, + text " ; fsubp %st(0),", greg src2 1]) | otherwise - = pprG g (hcat [gtab, gpush src1 0, - text " ; fsub ", greg src2 1, text ",%st(0)", - gsemi, gpop dst 1]) + = pprG platform g (hcat [gtab, gpush src1 0, + text " ; fsub ", greg src2 1, text ",%st(0)", + gsemi, gpop dst 1]) -pprInstr g@(GDIV _ src1 src2 dst) +pprInstr platform g@(GDIV _ src1 src2 dst) | src1 == dst - = pprG g (text "\t#GDIV-xxxcase1" $$ - hcat [gtab, gpush src2 0, - text " ; fdivrp %st(0),", greg src1 1]) + = pprG platform g (text "\t#GDIV-xxxcase1" $$ + hcat [gtab, gpush src2 0, + text " ; fdivrp %st(0),", greg src1 1]) | src2 == dst - = pprG g (text "\t#GDIV-xxxcase2" $$ - hcat [gtab, gpush src1 0, - text " ; fdivp %st(0),", greg src2 1]) + = pprG platform g (text "\t#GDIV-xxxcase2" $$ + hcat [gtab, gpush src1 0, + text " ; fdivp %st(0),", greg src2 1]) | otherwise - = pprG g (hcat [gtab, gpush src1 0, - text " ; fdiv ", greg src2 1, text ",%st(0)", - gsemi, gpop dst 1]) + = pprG platform g (hcat [gtab, gpush src1 0, + text " ; fdiv ", greg src2 1, text ",%st(0)", + gsemi, gpop dst 1]) -pprInstr GFREE +pprInstr _ GFREE = vcat [ ptext (sLit "\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"), ptext (sLit "\tffree %st(4) ;ffree %st(5)") ] -pprInstr _ +pprInstr _ _ = panic "X86.Ppr.pprInstr: no match" @@ -953,49 +951,49 @@ gregno (RegReal (RealRegSingle i)) = i gregno _ = --pprPanic "gregno" (ppr other) 999 -- bogus; only needed for debug printing -pprG :: Instr -> Doc -> Doc -pprG fake actual - = (char '#' <> pprGInstr fake) $$ actual +pprG :: Platform -> Instr -> Doc -> Doc +pprG platform fake actual + = (char '#' <> pprGInstr platform fake) $$ actual -pprGInstr :: Instr -> Doc -pprGInstr (GMOV src dst) = pprSizeRegReg (sLit "gmov") FF64 src dst -pprGInstr (GLD sz src dst) = pprSizeAddrReg (sLit "gld") sz src dst -pprGInstr (GST sz src dst) = pprSizeRegAddr (sLit "gst") sz src dst +pprGInstr :: Platform -> Instr -> Doc +pprGInstr platform (GMOV src dst) = pprSizeRegReg platform (sLit "gmov") FF64 src dst +pprGInstr platform (GLD sz src dst) = pprSizeAddrReg platform (sLit "gld") sz src dst +pprGInstr platform (GST sz src dst) = pprSizeRegAddr platform (sLit "gst") sz src dst -pprGInstr (GLDZ dst) = pprSizeReg (sLit "gldz") FF64 dst -pprGInstr (GLD1 dst) = pprSizeReg (sLit "gld1") FF64 dst +pprGInstr platform (GLDZ dst) = pprSizeReg platform (sLit "gldz") FF64 dst +pprGInstr platform (GLD1 dst) = pprSizeReg platform (sLit "gld1") FF64 dst -pprGInstr (GFTOI src dst) = pprSizeSizeRegReg (sLit "gftoi") FF32 II32 src dst -pprGInstr (GDTOI src dst) = pprSizeSizeRegReg (sLit "gdtoi") FF64 II32 src dst +pprGInstr platform (GFTOI src dst) = pprSizeSizeRegReg platform (sLit "gftoi") FF32 II32 src dst +pprGInstr platform (GDTOI src dst) = pprSizeSizeRegReg platform (sLit "gdtoi") FF64 II32 src dst -pprGInstr (GITOF src dst) = pprSizeSizeRegReg (sLit "gitof") II32 FF32 src dst -pprGInstr (GITOD src dst) = pprSizeSizeRegReg (sLit "gitod") II32 FF64 src dst -pprGInstr (GDTOF src dst) = pprSizeSizeRegReg (sLit "gdtof") FF64 FF32 src dst +pprGInstr platform (GITOF src dst) = pprSizeSizeRegReg platform (sLit "gitof") II32 FF32 src dst +pprGInstr platform (GITOD src dst) = pprSizeSizeRegReg platform (sLit "gitod") II32 FF64 src dst +pprGInstr platform (GDTOF src dst) = pprSizeSizeRegReg platform (sLit "gdtof") FF64 FF32 src dst -pprGInstr (GCMP co src dst) = pprCondRegReg (sLit "gcmp_") FF64 co src dst -pprGInstr (GABS sz src dst) = pprSizeRegReg (sLit "gabs") sz src dst -pprGInstr (GNEG sz src dst) = pprSizeRegReg (sLit "gneg") sz src dst -pprGInstr (GSQRT sz src dst) = pprSizeRegReg (sLit "gsqrt") sz src dst -pprGInstr (GSIN sz _ _ src dst) = pprSizeRegReg (sLit "gsin") sz src dst -pprGInstr (GCOS sz _ _ src dst) = pprSizeRegReg (sLit "gcos") sz src dst -pprGInstr (GTAN sz _ _ src dst) = pprSizeRegReg (sLit "gtan") sz src dst +pprGInstr platform (GCMP co src dst) = pprCondRegReg platform (sLit "gcmp_") FF64 co src dst +pprGInstr platform (GABS sz src dst) = pprSizeRegReg platform (sLit "gabs") sz src dst +pprGInstr platform (GNEG sz src dst) = pprSizeRegReg platform (sLit "gneg") sz src dst +pprGInstr platform (GSQRT sz src dst) = pprSizeRegReg platform (sLit "gsqrt") sz src dst +pprGInstr platform (GSIN sz _ _ src dst) = pprSizeRegReg platform (sLit "gsin") sz src dst +pprGInstr platform (GCOS sz _ _ src dst) = pprSizeRegReg platform (sLit "gcos") sz src dst +pprGInstr platform (GTAN sz _ _ src dst) = pprSizeRegReg platform (sLit "gtan") sz src dst -pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg (sLit "gadd") sz src1 src2 dst -pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg (sLit "gsub") sz src1 src2 dst -pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg (sLit "gmul") sz src1 src2 dst -pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg (sLit "gdiv") sz src1 src2 dst +pprGInstr platform (GADD sz src1 src2 dst) = pprSizeRegRegReg platform (sLit "gadd") sz src1 src2 dst +pprGInstr platform (GSUB sz src1 src2 dst) = pprSizeRegRegReg platform (sLit "gsub") sz src1 src2 dst +pprGInstr platform (GMUL sz src1 src2 dst) = pprSizeRegRegReg platform (sLit "gmul") sz src1 src2 dst +pprGInstr platform (GDIV sz src1 src2 dst) = pprSizeRegRegReg platform (sLit "gdiv") sz src1 src2 dst -pprGInstr _ = panic "X86.Ppr.pprGInstr: no match" +pprGInstr _ _ = panic "X86.Ppr.pprGInstr: no match" pprDollImm :: Imm -> Doc pprDollImm i = ptext (sLit "$") <> pprImm i -pprOperand :: Size -> Operand -> Doc -pprOperand s (OpReg r) = pprReg s r -pprOperand _ (OpImm i) = pprDollImm i -pprOperand _ (OpAddr ea) = pprAddr ea +pprOperand :: Platform -> Size -> Operand -> Doc +pprOperand platform s (OpReg r) = pprReg platform s r +pprOperand _ _ (OpImm i) = pprDollImm i +pprOperand platform _ (OpAddr ea) = pprAddr platform ea pprMnemonic_ :: LitString -> Doc @@ -1008,164 +1006,164 @@ pprMnemonic name size = char '\t' <> ptext name <> pprSize size <> space -pprSizeImmOp :: LitString -> Size -> Imm -> Operand -> Doc -pprSizeImmOp name size imm op1 +pprSizeImmOp :: Platform -> LitString -> Size -> Imm -> Operand -> Doc +pprSizeImmOp platform name size imm op1 = hcat [ pprMnemonic name size, char '$', pprImm imm, comma, - pprOperand size op1 + pprOperand platform size op1 ] -pprSizeOp :: LitString -> Size -> Operand -> Doc -pprSizeOp name size op1 +pprSizeOp :: Platform -> LitString -> Size -> Operand -> Doc +pprSizeOp platform name size op1 = hcat [ pprMnemonic name size, - pprOperand size op1 + pprOperand platform size op1 ] -pprSizeOpOp :: LitString -> Size -> Operand -> Operand -> Doc -pprSizeOpOp name size op1 op2 +pprSizeOpOp :: Platform -> LitString -> Size -> Operand -> Operand -> Doc +pprSizeOpOp platform name size op1 op2 = hcat [ pprMnemonic name size, - pprOperand size op1, + pprOperand platform size op1, comma, - pprOperand size op2 + pprOperand platform size op2 ] -pprOpOp :: LitString -> Size -> Operand -> Operand -> Doc -pprOpOp name size op1 op2 +pprOpOp :: Platform -> LitString -> Size -> Operand -> Operand -> Doc +pprOpOp platform name size op1 op2 = hcat [ pprMnemonic_ name, - pprOperand size op1, + pprOperand platform size op1, comma, - pprOperand size op2 + pprOperand platform size op2 ] -pprSizeReg :: LitString -> Size -> Reg -> Doc -pprSizeReg name size reg1 +pprSizeReg :: Platform -> LitString -> Size -> Reg -> Doc +pprSizeReg platform name size reg1 = hcat [ pprMnemonic name size, - pprReg size reg1 + pprReg platform size reg1 ] -pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc -pprSizeRegReg name size reg1 reg2 +pprSizeRegReg :: Platform -> LitString -> Size -> Reg -> Reg -> Doc +pprSizeRegReg platform name size reg1 reg2 = hcat [ pprMnemonic name size, - pprReg size reg1, + pprReg platform size reg1, comma, - pprReg size reg2 + pprReg platform size reg2 ] -pprRegReg :: LitString -> Reg -> Reg -> Doc -pprRegReg name reg1 reg2 +pprRegReg :: Platform -> LitString -> Reg -> Reg -> Doc +pprRegReg platform name reg1 reg2 = hcat [ pprMnemonic_ name, - pprReg archWordSize reg1, + pprReg platform archWordSize reg1, comma, - pprReg archWordSize reg2 + pprReg platform archWordSize reg2 ] -pprSizeOpReg :: LitString -> Size -> Operand -> Reg -> Doc -pprSizeOpReg name size op1 reg2 +pprSizeOpReg :: Platform -> LitString -> Size -> Operand -> Reg -> Doc +pprSizeOpReg platform name size op1 reg2 = hcat [ pprMnemonic name size, - pprOperand size op1, + pprOperand platform size op1, comma, - pprReg archWordSize reg2 + pprReg platform archWordSize reg2 ] -pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> Doc -pprCondRegReg name size cond reg1 reg2 +pprCondRegReg :: Platform -> LitString -> Size -> Cond -> Reg -> Reg -> Doc +pprCondRegReg platform name size cond reg1 reg2 = hcat [ char '\t', ptext name, pprCond cond, space, - pprReg size reg1, + pprReg platform size reg1, comma, - pprReg size reg2 + pprReg platform size reg2 ] -pprSizeSizeRegReg :: LitString -> Size -> Size -> Reg -> Reg -> Doc -pprSizeSizeRegReg name size1 size2 reg1 reg2 +pprSizeSizeRegReg :: Platform -> LitString -> Size -> Size -> Reg -> Reg -> Doc +pprSizeSizeRegReg platform name size1 size2 reg1 reg2 = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space, - pprReg size1 reg1, + pprReg platform size1 reg1, comma, - pprReg size2 reg2 + pprReg platform size2 reg2 ] -pprSizeSizeOpReg :: LitString -> Size -> Size -> Operand -> Reg -> Doc -pprSizeSizeOpReg name size1 size2 op1 reg2 +pprSizeSizeOpReg :: Platform -> LitString -> Size -> Size -> Operand -> Reg -> Doc +pprSizeSizeOpReg platform name size1 size2 op1 reg2 = hcat [ pprMnemonic name size2, - pprOperand size1 op1, + pprOperand platform size1 op1, comma, - pprReg size2 reg2 + pprReg platform size2 reg2 ] -pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc -pprSizeRegRegReg name size reg1 reg2 reg3 +pprSizeRegRegReg :: Platform -> LitString -> Size -> Reg -> Reg -> Reg -> Doc +pprSizeRegRegReg platform name size reg1 reg2 reg3 = hcat [ pprMnemonic name size, - pprReg size reg1, + pprReg platform size reg1, comma, - pprReg size reg2, + pprReg platform size reg2, comma, - pprReg size reg3 + pprReg platform size reg3 ] -pprSizeAddrReg :: LitString -> Size -> AddrMode -> Reg -> Doc -pprSizeAddrReg name size op dst +pprSizeAddrReg :: Platform -> LitString -> Size -> AddrMode -> Reg -> Doc +pprSizeAddrReg platform name size op dst = hcat [ pprMnemonic name size, - pprAddr op, + pprAddr platform op, comma, - pprReg size dst + pprReg platform size dst ] -pprSizeRegAddr :: LitString -> Size -> Reg -> AddrMode -> Doc -pprSizeRegAddr name size src op +pprSizeRegAddr :: Platform -> LitString -> Size -> Reg -> AddrMode -> Doc +pprSizeRegAddr platform name size src op = hcat [ pprMnemonic name size, - pprReg size src, + pprReg platform size src, comma, - pprAddr op + pprAddr platform op ] -pprShift :: LitString -> Size -> Operand -> Operand -> Doc -pprShift name size src dest +pprShift :: Platform -> LitString -> Size -> Operand -> Operand -> Doc +pprShift platform name size src dest = hcat [ pprMnemonic name size, - pprOperand II8 src, -- src is 8-bit sized + pprOperand platform II8 src, -- src is 8-bit sized comma, - pprOperand size dest + pprOperand platform size dest ] -pprSizeOpOpCoerce :: LitString -> Size -> Size -> Operand -> Operand -> Doc -pprSizeOpOpCoerce name size1 size2 op1 op2 +pprSizeOpOpCoerce :: Platform -> LitString -> Size -> Size -> Operand -> Operand -> Doc +pprSizeOpOpCoerce platform name size1 size2 op1 op2 = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space, - pprOperand size1 op1, + pprOperand platform size1 op1, comma, - pprOperand size2 op2 + pprOperand platform size2 op2 ] diff --git a/compiler/nativeGen/X86/RegInfo.hs b/compiler/nativeGen/X86/RegInfo.hs index 0f6613d00d..c09ebc5b15 100644 --- a/compiler/nativeGen/X86/RegInfo.hs +++ b/compiler/nativeGen/X86/RegInfo.hs @@ -28,20 +28,17 @@ mkVirtualReg u size FF80 -> VirtualRegD u _other -> VirtualRegI u -regDotColor :: RealReg -> SDoc -regDotColor reg - = let Just str = lookupUFM regColors reg - in text str +regDotColor :: Platform -> RealReg -> SDoc +regDotColor platform reg + = let Just str = lookupUFM (regColors platform) reg + in text str -regColors :: UniqFM [Char] -regColors = listToUFM (normalRegColors ++ fpRegColors) +regColors :: Platform -> UniqFM [Char] +regColors platform = listToUFM (normalRegColors platform ++ fpRegColors) --- TODO: We shouldn't be using defaultTargetPlatform here. --- We should be passing DynFlags in instead, and looking at --- its targetPlatform. - -normalRegColors :: [(Reg,String)] -normalRegColors = case platformArch defaultTargetPlatform of +normalRegColors :: Platform -> [(Reg,String)] +normalRegColors platform + = case platformArch platform of ArchX86 -> [ (eax, "#00ff00") , (ebx, "#0000ff") , (ecx, "#00ffff") diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 736ab0967b..fd1e1afa05 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -21,7 +21,7 @@ -- - pragma-end should be only valid in a pragma -- qualified operator NOTES. --- +-- -- - If M.(+) is a single lexeme, then.. -- - Probably (+) should be a single lexeme too, for consistency. -- Otherwise ( + ) would be a prefix operator, but M.( + ) would not be. @@ -47,10 +47,10 @@ module Lexer ( Token(..), lexer, pragState, mkPState, PState(..), - P(..), ParseResult(..), getSrcLoc, + P(..), ParseResult(..), getSrcLoc, getPState, getDynFlags, withThisPackage, failLocMsgP, failSpanMsgP, srcParseFail, - getMessages, + getMessages, popContext, pushCurrentContext, setLastToken, setSrcLoc, activeContext, nextIsEOF, getLexState, popLexState, pushLexState, @@ -69,8 +69,8 @@ import UniqFM import DynFlags import Module import Ctype -import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) ) -import Util ( readRational ) +import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) ) +import Util ( readRational ) import Control.Monad import Data.Bits @@ -108,7 +108,7 @@ $small = [$ascsmall $unismall \_] $unigraphic = \x06 -- Trick Alex into handling Unicode. See alexGetChar. $graphic = [$small $large $symbol $digit $special $unigraphic \:\"\'] -$octit = 0-7 +$octit = 0-7 $hexit = [$decdigit A-F a-f] $symchar = [$symbol \:] $nl = [\n\r] @@ -142,7 +142,7 @@ $docsym = [\| \^ \* \$] haskell :- -- everywhere: skip whitespace and comments -$white_no_nl+ ; +$white_no_nl+ ; $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } -- Everywhere: deal with nested comments. We explicitly rule out @@ -159,7 +159,7 @@ $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } -- have to exclude those. -- Since Haddock comments aren't valid in every state, we need to rule them --- out here. +-- out here. -- The following two rules match comments that begin with two dashes, but -- continue with a different character. The rules test that this character @@ -202,53 +202,53 @@ $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } -- as a nested comment. We don't bother with this: if the line begins -- with {-#, then we'll assume it's a pragma we know about and go for do_bol. <bol> { - \n ; - ^\# (line)? { begin line_prag1 } - ^\# pragma .* \n ; -- GCC 3.3 CPP generated, apparently - ^\# \! .* \n ; -- #!, for scripts - () { do_bol } + \n ; + ^\# (line)? { begin line_prag1 } + ^\# pragma .* \n ; -- GCC 3.3 CPP generated, apparently + ^\# \! .* \n ; -- #!, for scripts + () { do_bol } } -- after a layout keyword (let, where, do, of), we begin a new layout -- context if the curly brace is missing. -- Careful! This stuff is quite delicate. <layout, layout_do> { - \{ / { notFollowedBy '-' } { hopefully_open_brace } - -- we might encounter {-# here, but {- has been handled already - \n ; - ^\# (line)? { begin line_prag1 } + \{ / { notFollowedBy '-' } { hopefully_open_brace } + -- we might encounter {-# here, but {- has been handled already + \n ; + ^\# (line)? { begin line_prag1 } } -- do is treated in a subtly different way, see new_layout_context -<layout> () { new_layout_context True } -<layout_do> () { new_layout_context False } +<layout> () { new_layout_context True } +<layout_do> () { new_layout_context False } -- after a new layout context which was found to be to the left of the -- previous context, we have generated a '{' token, and we now need to -- generate a matching '}' token. -<layout_left> () { do_layout_left } +<layout_left> () { do_layout_left } -<0,option_prags> \n { begin bol } +<0,option_prags> \n { begin bol } "{-#" $whitechar* $pragmachar+ / { known_pragma linePrags } { dispatch_pragmas linePrags } -- single-line line pragmas, of the form -- # <line> "<file>" <extra-stuff> \n -<line_prag1> $decdigit+ { setLine line_prag1a } -<line_prag1a> \" [$graphic \ ]* \" { setFile line_prag1b } -<line_prag1b> .* { pop } +<line_prag1> $decdigit+ { setLine line_prag1a } +<line_prag1a> \" [$graphic \ ]* \" { setFile line_prag1b } +<line_prag1b> .* { pop } -- Haskell-style line pragmas, of the form -- {-# LINE <line> "<file>" #-} -<line_prag2> $decdigit+ { setLine line_prag2a } -<line_prag2a> \" [$graphic \ ]* \" { setFile line_prag2b } -<line_prag2b> "#-}"|"-}" { pop } +<line_prag2> $decdigit+ { setLine line_prag2a } +<line_prag2a> \" [$graphic \ ]* \" { setFile line_prag2b } +<line_prag2b> "#-}"|"-}" { pop } -- NOTE: accept -} at the end of a LINE pragma, for compatibility -- with older versions of GHC which generated these. <0,option_prags> { - "{-#" $whitechar* $pragmachar+ + "{-#" $whitechar* $pragmachar+ $whitechar+ $pragmachar+ / { known_pragma twoWordPrags } { dispatch_pragmas twoWordPrags } @@ -260,14 +260,14 @@ $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } { dispatch_pragmas ignoredPrags } -- ToDo: should only be valid inside a pragma: - "#-}" { endPrag } + "#-}" { endPrag } } <option_prags> { "{-#" $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags } { dispatch_pragmas fileHeaderPrags } - "-- #" { multiline_doc_comment } + "-- #" { multiline_doc_comment } } <0> { @@ -297,19 +297,19 @@ $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } -- "special" symbols <0> { - "[:" / { ifExtension parrEnabled } { token ITopabrack } - ":]" / { ifExtension parrEnabled } { token ITcpabrack } + "[:" / { ifExtension parrEnabled } { token ITopabrack } + ":]" / { ifExtension parrEnabled } { token ITcpabrack } } - + <0> { - "[|" / { ifExtension thEnabled } { token ITopenExpQuote } - "[e|" / { ifExtension thEnabled } { token ITopenExpQuote } - "[p|" / { ifExtension thEnabled } { token ITopenPatQuote } - "[d|" / { ifExtension thEnabled } { layout_token ITopenDecQuote } - "[t|" / { ifExtension thEnabled } { token ITopenTypQuote } - "|]" / { ifExtension thEnabled } { token ITcloseQuote } - \$ @varid / { ifExtension thEnabled } { skip_one_varid ITidEscape } - "$(" / { ifExtension thEnabled } { token ITparenEscape } + "[|" / { ifExtension thEnabled } { token ITopenExpQuote } + "[e|" / { ifExtension thEnabled } { token ITopenExpQuote } + "[p|" / { ifExtension thEnabled } { token ITopenPatQuote } + "[d|" / { ifExtension thEnabled } { layout_token ITopenDecQuote } + "[t|" / { ifExtension thEnabled } { token ITopenTypQuote } + "|]" / { ifExtension thEnabled } { token ITcloseQuote } + \$ @varid / { ifExtension thEnabled } { skip_one_varid ITidEscape } + "$(" / { ifExtension thEnabled } { token ITparenEscape } -- For backward compatibility, accept the old dollar syntax "[$" @varid "|" / { ifExtension qqEnabled } @@ -321,12 +321,12 @@ $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } <0> { "(|" / { ifExtension arrowsEnabled `alexAndPred` notFollowedBySymbol } - { special IToparenbar } + { special IToparenbar } "|)" / { ifExtension arrowsEnabled } { special ITcparenbar } } <0> { - \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid } + \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid } } <0> { @@ -337,23 +337,23 @@ $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } } <0,option_prags> { - \( { special IToparen } - \) { special ITcparen } - \[ { special ITobrack } - \] { special ITcbrack } - \, { special ITcomma } - \; { special ITsemi } - \` { special ITbackquote } - - \{ { open_brace } - \} { close_brace } + \( { special IToparen } + \) { special ITcparen } + \[ { special ITobrack } + \] { special ITcbrack } + \, { special ITcomma } + \; { special ITsemi } + \` { special ITbackquote } + + \{ { open_brace } + \} { close_brace } } <0,option_prags> { - @qual @varid { idtoken qvarid } - @qual @conid { idtoken qconid } - @varid { varid } - @conid { idtoken conid } + @qual @varid { idtoken qvarid } + @qual @conid { idtoken qconid } + @varid { varid } + @conid { idtoken conid } } <0> { @@ -410,8 +410,8 @@ $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } -- lexer, we would still have to parse the string afterward in order -- to convert it to a String. <0> { - \' { lex_char_tok } - \" { lex_string_tok } + \' { lex_char_tok } + \" { lex_string_tok } } { @@ -419,7 +419,7 @@ $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } -- The token type data Token - = ITas -- Haskell keywords + = ITas -- Haskell keywords | ITcase | ITclass | ITdata @@ -443,15 +443,14 @@ data Token | ITthen | ITtype | ITwhere - | ITscc -- ToDo: remove (we use {-# SCC "..." #-} now) + | ITscc -- ToDo: remove (we use {-# SCC "..." #-} now) - | ITforall -- GHC extension keywords + | ITforall -- GHC extension keywords | ITforeign | ITexport | ITlabel | ITdynamic | ITsafe - | ITthreadsafe | ITinterruptible | ITunsafe | ITstdcallconv @@ -463,10 +462,10 @@ data Token | ITby | ITusing - -- Pragmas + -- Pragmas | ITinline_prag InlineSpec RuleMatchInfo - | ITspec_prag -- SPECIALISE - | ITspec_inline_prag Bool -- SPECIALISE INLINE (or NOINLINE) + | ITspec_prag -- SPECIALISE + | ITspec_inline_prag Bool -- SPECIALISE INLINE (or NOINLINE) | ITsource_prag | ITrules_prag | ITwarning_prag @@ -485,7 +484,7 @@ data Token | ITvect_scalar_prag | ITnovect_prag - | ITdotdot -- reserved symbols + | ITdotdot -- reserved symbols | ITcolon | ITdcolon | ITequal @@ -501,17 +500,17 @@ data Token | ITstar | ITdot - | ITbiglam -- GHC-extension symbols + | ITbiglam -- GHC-extension symbols - | ITocurly -- special symbols + | ITocurly -- special symbols | ITccurly | ITocurlybar -- {|, for type applications | ITccurlybar -- |}, for type applications | ITvocurly | ITvccurly | ITobrack - | ITopabrack -- [:, for parallel arrays with -XParallelArrays - | ITcpabrack -- :], for parallel arrays with -XParallelArrays + | ITopabrack -- [:, for parallel arrays with -XParallelArrays + | ITcpabrack -- :], for parallel arrays with -XParallelArrays | ITcbrack | IToparen | ITcparen @@ -522,7 +521,7 @@ data Token | ITunderscore | ITbackquote - | ITvarid FastString -- identifiers + | ITvarid FastString -- identifiers | ITconid FastString | ITvarsym FastString | ITconsym FastString @@ -533,7 +532,7 @@ data Token | ITprefixqvarsym (FastString,FastString) | ITprefixqconsym (FastString,FastString) - | ITdupipvarid FastString -- GHC extension: implicit param: ?x + | ITdupipvarid FastString -- GHC extension: implicit param: ?x | ITchar Char | ITstring FastString @@ -548,29 +547,29 @@ data Token | ITprimdouble FractionalLit -- Template Haskell extension tokens - | ITopenExpQuote -- [| or [e| - | ITopenPatQuote -- [p| - | ITopenDecQuote -- [d| - | ITopenTypQuote -- [t| - | ITcloseQuote -- |] - | ITidEscape FastString -- $x - | ITparenEscape -- $( - | ITvarQuote -- ' - | ITtyQuote -- '' + | ITopenExpQuote -- [| or [e| + | ITopenPatQuote -- [p| + | ITopenDecQuote -- [d| + | ITopenTypQuote -- [t| + | ITcloseQuote -- |] + | ITidEscape FastString -- $x + | ITparenEscape -- $( + | ITvarQuote -- ' + | ITtyQuote -- '' | ITquasiQuote (FastString,FastString,RealSrcSpan) -- [:...|...|] -- Arrow notation extension | ITproc | ITrec - | IToparenbar -- (| - | ITcparenbar -- |) - | ITlarrowtail -- -< - | ITrarrowtail -- >- - | ITLarrowtail -- -<< - | ITRarrowtail -- >>- + | IToparenbar -- (| + | ITcparenbar -- |) + | ITlarrowtail -- -< + | ITrarrowtail -- >- + | ITLarrowtail -- -<< + | ITRarrowtail -- >>- - | ITunknown String -- Used when the lexer can't make sense of it - | ITeof -- end of file token + | ITunknown String -- Used when the lexer can't make sense of it + | ITeof -- end of file token -- Documentation annotations | ITdocCommentNext String -- something beginning '-- |' @@ -586,33 +585,6 @@ data Token deriving Show -- debugging #endif -{- -isSpecial :: Token -> Bool --- If we see M.x, where x is a keyword, but --- is special, we treat is as just plain M.x, --- not as a keyword. -isSpecial ITas = True -isSpecial IThiding = True -isSpecial ITqualified = True -isSpecial ITforall = True -isSpecial ITexport = True -isSpecial ITlabel = True -isSpecial ITdynamic = True -isSpecial ITsafe = True -isSpecial ITthreadsafe = True -isSpecial ITinterruptible = True -isSpecial ITunsafe = True -isSpecial ITccallconv = True -isSpecial ITstdcallconv = True -isSpecial ITprimcallconv = True -isSpecial ITmdo = True -isSpecial ITfamily = True -isSpecial ITgroup = True -isSpecial ITby = True -isSpecial ITusing = True -isSpecial _ = False --} - -- the bitmap provided as the third component indicates whether the -- corresponding extension keyword is valid under the extension options -- provided to the compiler; if the extension corresponding to *any* of the @@ -622,55 +594,56 @@ isSpecial _ = False -- reservedWordsFM :: UniqFM (Token, Int) reservedWordsFM = listToUFM $ - map (\(x, y, z) -> (mkFastString x, (y, z))) - [( "_", ITunderscore, 0 ), - ( "as", ITas, 0 ), - ( "case", ITcase, 0 ), - ( "class", ITclass, 0 ), - ( "data", ITdata, 0 ), - ( "default", ITdefault, 0 ), - ( "deriving", ITderiving, 0 ), - ( "do", ITdo, 0 ), - ( "else", ITelse, 0 ), - ( "hiding", IThiding, 0 ), - ( "if", ITif, 0 ), - ( "import", ITimport, 0 ), - ( "in", ITin, 0 ), - ( "infix", ITinfix, 0 ), - ( "infixl", ITinfixl, 0 ), - ( "infixr", ITinfixr, 0 ), - ( "instance", ITinstance, 0 ), - ( "let", ITlet, 0 ), - ( "module", ITmodule, 0 ), - ( "newtype", ITnewtype, 0 ), - ( "of", ITof, 0 ), - ( "qualified", ITqualified, 0 ), - ( "then", ITthen, 0 ), - ( "type", ITtype, 0 ), - ( "where", ITwhere, 0 ), - ( "_scc_", ITscc, 0 ), -- ToDo: remove - - ( "forall", ITforall, bit explicitForallBit .|. bit inRulePragBit), - ( "mdo", ITmdo, bit recursiveDoBit), - ( "family", ITfamily, bit tyFamBit), - ( "group", ITgroup, bit transformComprehensionsBit), - ( "by", ITby, bit transformComprehensionsBit), - ( "using", ITusing, bit transformComprehensionsBit), - - ( "foreign", ITforeign, bit ffiBit), - ( "export", ITexport, bit ffiBit), - ( "label", ITlabel, bit ffiBit), - ( "dynamic", ITdynamic, bit ffiBit), - ( "safe", ITsafe, bit ffiBit .|. bit safeHaskellBit), - ( "threadsafe", ITthreadsafe, bit ffiBit), -- ToDo: remove - ( "interruptible", ITinterruptible, bit ffiBit), - ( "unsafe", ITunsafe, bit ffiBit), - ( "stdcall", ITstdcallconv, bit ffiBit), - ( "ccall", ITccallconv, bit ffiBit), - ( "prim", ITprimcallconv, bit ffiBit), - - ( "rec", ITrec, bit recBit), - ( "proc", ITproc, bit arrowsBit) + map (\(x, y, z) -> (mkFastString x, (y, z))) + [( "_", ITunderscore, 0 ), + ( "as", ITas, 0 ), + ( "case", ITcase, 0 ), + ( "class", ITclass, 0 ), + ( "data", ITdata, 0 ), + ( "default", ITdefault, 0 ), + ( "deriving", ITderiving, 0 ), + ( "do", ITdo, 0 ), + ( "else", ITelse, 0 ), + ( "hiding", IThiding, 0 ), + ( "if", ITif, 0 ), + ( "import", ITimport, 0 ), + ( "in", ITin, 0 ), + ( "infix", ITinfix, 0 ), + ( "infixl", ITinfixl, 0 ), + ( "infixr", ITinfixr, 0 ), + ( "instance", ITinstance, 0 ), + ( "let", ITlet, 0 ), + ( "module", ITmodule, 0 ), + ( "newtype", ITnewtype, 0 ), + ( "of", ITof, 0 ), + ( "qualified", ITqualified, 0 ), + ( "then", ITthen, 0 ), + ( "type", ITtype, 0 ), + ( "where", ITwhere, 0 ), + ( "_scc_", ITscc, 0 ), -- ToDo: remove + + ( "forall", ITforall, bit explicitForallBit .|. + bit inRulePragBit), + ( "mdo", ITmdo, bit recursiveDoBit), + ( "family", ITfamily, bit tyFamBit), + ( "group", ITgroup, bit transformComprehensionsBit), + ( "by", ITby, bit transformComprehensionsBit), + ( "using", ITusing, bit transformComprehensionsBit), + + ( "foreign", ITforeign, bit ffiBit), + ( "export", ITexport, bit ffiBit), + ( "label", ITlabel, bit ffiBit), + ( "dynamic", ITdynamic, bit ffiBit), + ( "safe", ITsafe, bit ffiBit .|. + bit safeHaskellBit), + ( "interruptible", ITinterruptible, bit interruptibleFfiBit), + ( "unsafe", ITunsafe, bit ffiBit), + ( "stdcall", ITstdcallconv, bit ffiBit), + ( "ccall", ITccallconv, bit ffiBit), + ( "prim", ITprimcallconv, bit ffiBit), + + ( "rec", ITrec, bit recBit), + ( "proc", ITproc, bit arrowsBit) ] reservedSymsFM :: UniqFM (Token, Int -> Bool) @@ -736,16 +709,16 @@ idtoken :: (StringBuffer -> Int -> Token) -> Action idtoken f span buf len = return (L span $! (f buf len)) skip_one_varid :: (FastString -> Token) -> Action -skip_one_varid f span buf len +skip_one_varid f span buf len = return (L span $! f (lexemeToFastString (stepOn buf) (len-1))) strtoken :: (String -> Token) -> Action -strtoken f span buf len = +strtoken f span buf len = return (L span $! (f $! lexemeToString buf len)) init_strtoken :: Int -> (String -> Token) -> Action -- like strtoken, but drops the last N character(s) -init_strtoken drop f span buf len = +init_strtoken drop f span buf len = return (L span $! (f $! lexemeToString buf (len-drop))) begin :: Int -> Action @@ -777,7 +750,7 @@ nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool nextCharIs buf p = not (atEnd buf) && p (currentChar buf) notFollowedBy :: Char -> AlexAccPred Int -notFollowedBy char _ _ _ (AI _ buf) +notFollowedBy char _ _ _ (AI _ buf) = nextCharIs buf (/=char) notFollowedBySymbol :: AlexAccPred Int @@ -800,11 +773,6 @@ isNormalComment bits _ _ (AI _ buf) spaceAndP :: StringBuffer -> (StringBuffer -> Bool) -> Bool spaceAndP buf p = p buf || nextCharIs buf (==' ') && p (snd (nextChar buf)) -{- -haddockDisabledAnd p bits _ _ (AI _ buf) - = if haddockEnabled bits then False else (p buf) --} - atEOL :: AlexAccPred Int atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n' @@ -815,14 +783,14 @@ multiline_doc_comment :: Action multiline_doc_comment span buf _len = withLexedDocType (worker "") where worker commentAcc input docType oneLine = case alexGetChar input of - Just ('\n', input') + Just ('\n', input') | oneLine -> docCommentEnd input commentAcc docType buf span | otherwise -> case checkIfCommentLine input' of Just input -> worker ('\n':commentAcc) input docType False Nothing -> docCommentEnd input commentAcc docType buf span Just (c, input) -> worker (c:commentAcc) input docType oneLine Nothing -> docCommentEnd input commentAcc docType buf span - + checkIfCommentLine input = check (dropNonNewlineSpace input) where check input = case alexGetChar input of @@ -834,7 +802,7 @@ multiline_doc_comment span buf _len = withLexedDocType (worker "") _ -> Nothing dropNonNewlineSpace input = case alexGetChar input of - Just (c, input') + Just (c, input') | isSpace c && c /= '\n' -> dropNonNewlineSpace input' | otherwise -> input Nothing -> input @@ -900,8 +868,8 @@ withLexedDocType lexDocComment = do '*' -> lexDocSection 1 input '#' -> lexDocComment input ITdocOptionsOld False _ -> panic "withLexedDocType: Bad doc type" - where - lexDocSection n input = case alexGetChar input of + where + lexDocSection n input = case alexGetChar input of Just ('*', input) -> lexDocSection (n+1) input Just (_, _) -> lexDocComment input (ITdocSection n) True Nothing -> do setInput input; lexToken -- eof reached, lex it normally @@ -922,31 +890,31 @@ endPrag span _buf _len = do ------------------------------------------------------------------------------- -- This function is quite tricky. We can't just return a new token, we also -- need to update the state of the parser. Why? Because the token is longer --- than what was lexed by Alex, and the lexToken function doesn't know this, so +-- than what was lexed by Alex, and the lexToken function doesn't know this, so -- it writes the wrong token length to the parser state. This function is --- called afterwards, so it can just update the state. +-- called afterwards, so it can just update the state. docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer -> - RealSrcSpan -> P (RealLocated Token) + RealSrcSpan -> P (RealLocated Token) docCommentEnd input commentAcc docType buf span = do setInput input let (AI loc nextBuf) = input comment = reverse commentAcc span' = mkRealSrcSpan (realSrcSpanStart span) loc last_len = byteDiff buf nextBuf - + span `seq` setLastToken span' last_len return (L span' (docType comment)) - + errBrace :: AlexInput -> RealSrcSpan -> P a errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) end "unterminated `{-'" open_brace, close_brace :: Action -open_brace span _str _len = do +open_brace span _str _len = do ctx <- getContext setContext (NoLayout:ctx) return (L span ITocurly) -close_brace span _str _len = do +close_brace span _str _len = do popContext return (L span ITccurly) @@ -961,44 +929,44 @@ splitQualName :: StringBuffer -> Int -> Bool -> (FastString,FastString) splitQualName orig_buf len parens = split orig_buf orig_buf where split buf dot_buf - | orig_buf `byteDiff` buf >= len = done dot_buf - | c == '.' = found_dot buf' - | otherwise = split buf' dot_buf + | orig_buf `byteDiff` buf >= len = done dot_buf + | c == '.' = found_dot buf' + | otherwise = split buf' dot_buf where (c,buf') = nextChar buf - + -- careful, we might get names like M.... -- so, if the character after the dot is not upper-case, this is -- the end of the qualifier part. found_dot buf -- buf points after the '.' - | isUpper c = split buf' buf - | otherwise = done buf + | isUpper c = split buf' buf + | otherwise = done buf where (c,buf') = nextChar buf done dot_buf = - (lexemeToFastString orig_buf (qual_size - 1), - if parens -- Prelude.(+) + (lexemeToFastString orig_buf (qual_size - 1), + if parens -- Prelude.(+) then lexemeToFastString (stepOn dot_buf) (len - qual_size - 2) else lexemeToFastString dot_buf (len - qual_size)) where - qual_size = orig_buf `byteDiff` dot_buf + qual_size = orig_buf `byteDiff` dot_buf varid :: Action varid span buf len = fs `seq` case lookupUFM reservedWordsFM fs of - Just (keyword,0) -> do - maybe_layout keyword - return (L span keyword) - Just (keyword,exts) -> do - b <- extension (\i -> exts .&. i /= 0) - if b then do maybe_layout keyword - return (L span keyword) - else return (L span (ITvarid fs)) - _other -> return (L span (ITvarid fs)) + Just (keyword,0) -> do + maybe_layout keyword + return (L span keyword) + Just (keyword,exts) -> do + b <- extension (\i -> exts .&. i /= 0) + if b then do maybe_layout keyword + return (L span keyword) + else return (L span (ITvarid fs)) + _other -> return (L span (ITvarid fs)) where - fs = lexemeToFastString buf len + fs = lexemeToFastString buf len conid :: StringBuffer -> Int -> Token conid buf len = ITconid fs @@ -1016,25 +984,25 @@ consym = sym ITconsym sym :: (FastString -> Token) -> RealSrcSpan -> StringBuffer -> Int -> P (RealLocated Token) -sym con span buf len = +sym con span buf len = case lookupUFM reservedSymsFM fs of - Just (keyword,exts) -> do - b <- extension exts - if b then return (L span keyword) - else return (L span $! con fs) - _other -> return (L span $! con fs) + Just (keyword,exts) -> do + b <- extension exts + if b then return (L span keyword) + else return (L span $! con fs) + _other -> return (L span $! con fs) where - fs = lexemeToFastString buf len + fs = lexemeToFastString buf len -- Variations on the integral numeric literal. tok_integral :: (Integer -> Token) - -> (Integer -> Integer) - -- -> (StringBuffer -> StringBuffer) -> (Int -> Int) - -> Int -> Int - -> (Integer, (Char->Int)) -> Action -tok_integral itint transint transbuf translen (radix,char_to_int) span buf len = - return $ L span $ itint $! transint $ parseUnsignedInteger - (offsetBytes transbuf buf) (subtract translen len) radix char_to_int + -> (Integer -> Integer) + -> Int -> Int + -> (Integer, (Char -> Int)) + -> Action +tok_integral itint transint transbuf translen (radix,char_to_int) span buf len + = return $ L span $ itint $! transint $ parseUnsignedInteger + (offsetBytes transbuf buf) (subtract translen len) radix char_to_int -- some conveniences for use with tok_integral tok_num :: (Integer -> Integer) @@ -1071,20 +1039,20 @@ readFractionalLit str = (FL $! str) $! readRational str -- we're at the first token on a line, insert layout tokens if necessary do_bol :: Action do_bol span _str _len = do - pos <- getOffside - case pos of - LT -> do + pos <- getOffside + case pos of + LT -> do --trace "layout: inserting '}'" $ do - popContext - -- do NOT pop the lex state, we might have a ';' to insert - return (L span ITvccurly) - EQ -> do + popContext + -- do NOT pop the lex state, we might have a ';' to insert + return (L span ITvccurly) + EQ -> do --trace "layout: inserting ';'" $ do - _ <- popLexState - return (L span ITsemi) - GT -> do - _ <- popLexState - lexToken + _ <- popLexState + return (L span ITsemi) + GT -> do + _ <- popLexState + lexToken -- certain keywords put us in the "layout" state, where we might -- add an opening curly brace. @@ -1124,16 +1092,16 @@ new_layout_context strict span _buf _len = do nondecreasing <- extension nondecreasingIndentation let strict' = strict || not nondecreasing case ctx of - Layout prev_off : _ | - (strict' && prev_off >= offset || - not strict' && prev_off > offset) -> do - -- token is indented to the left of the previous context. - -- we must generate a {} sequence now. - pushLexState layout_left - return (L span ITvocurly) - _ -> do - setContext (Layout offset : ctx) - return (L span ITvocurly) + Layout prev_off : _ | + (strict' && prev_off >= offset || + not strict' && prev_off > offset) -> do + -- token is indented to the left of the previous context. + -- we must generate a {} sequence now. + pushLexState layout_left + return (L span ITvocurly) + _ -> do + setContext (Layout offset : ctx) + return (L span ITvocurly) do_layout_left :: Action do_layout_left span _buf _len = do @@ -1148,7 +1116,7 @@ setLine :: Int -> Action setLine code span buf len = do let line = parseUnsignedInteger buf len 10 octDecDigit setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) - -- subtract one: the line number refers to the *following* line + -- subtract one: the line number refers to the *following* line _ <- popLexState pushLexState code lexToken @@ -1201,7 +1169,7 @@ lex_string_prag mkTok span _buf _len lex_string_tok :: Action lex_string_tok span _buf _len = do tok <- lex_string "" - end <- getSrcLoc + end <- getSrcLoc return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok) lex_string :: String -> P Token @@ -1211,32 +1179,32 @@ lex_string s = do Nothing -> lit_error i Just ('"',i) -> do - setInput i - magicHash <- extension magicHashEnabled - if magicHash - then do - i <- getInput - case alexGetChar' i of - Just ('#',i) -> do - setInput i - if any (> '\xFF') s + setInput i + magicHash <- extension magicHashEnabled + if magicHash + then do + i <- getInput + case alexGetChar' i of + Just ('#',i) -> do + setInput i + if any (> '\xFF') s then failMsgP "primitive string literal must contain only characters <= \'\\xFF\'" else let s' = mkZFastString (reverse s) in - return (ITprimstring s') - -- mkZFastString is a hack to avoid encoding the - -- string in UTF-8. We just want the exact bytes. - _other -> - return (ITstring (mkFastString (reverse s))) - else - return (ITstring (mkFastString (reverse s))) + return (ITprimstring s') + -- mkZFastString is a hack to avoid encoding the + -- string in UTF-8. We just want the exact bytes. + _other -> + return (ITstring (mkFastString (reverse s))) + else + return (ITstring (mkFastString (reverse s))) Just ('\\',i) - | Just ('&',i) <- next -> do - setInput i; lex_string s - | Just (c,i) <- next, c <= '\x7f' && is_space c -> do + | Just ('&',i) <- next -> do + setInput i; lex_string s + | Just (c,i) <- next, c <= '\x7f' && is_space c -> do -- is_space only works for <= '\x7f' (#3751) - setInput i; lex_stringgap s - where next = alexGetChar' i + setInput i; lex_stringgap s + where next = alexGetChar' i Just (c, i1) -> do case c of @@ -1257,172 +1225,172 @@ lex_stringgap s = do lex_char_tok :: Action -- Here we are basically parsing character literals, such as 'x' or '\n' -- but, when Template Haskell is on, we additionally spot --- 'x and ''T, returning ITvarQuote and ITtyQuote respectively, +-- 'x and ''T, returning ITvarQuote and ITtyQuote respectively, -- but WITHOUT CONSUMING the x or T part (the parser does that). -- So we have to do two characters of lookahead: when we see 'x we need to -- see if there's a trailing quote -lex_char_tok span _buf _len = do -- We've seen ' - i1 <- getInput -- Look ahead to first character +lex_char_tok span _buf _len = do -- We've seen ' + i1 <- getInput -- Look ahead to first character let loc = realSrcSpanStart span case alexGetChar' i1 of - Nothing -> lit_error i1 - - Just ('\'', i2@(AI end2 _)) -> do -- We've seen '' - th_exts <- extension thEnabled - if th_exts then do - setInput i2 - return (L (mkRealSrcSpan loc end2) ITtyQuote) - else lit_error i1 - - Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash - setInput i2 - lit_ch <- lex_escape + Nothing -> lit_error i1 + + Just ('\'', i2@(AI end2 _)) -> do -- We've seen '' + th_exts <- extension thEnabled + if th_exts then do + setInput i2 + return (L (mkRealSrcSpan loc end2) ITtyQuote) + else lit_error i1 + + Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash + setInput i2 + lit_ch <- lex_escape i3 <- getInput - mc <- getCharOrFail i3 -- Trailing quote - if mc == '\'' then finish_char_tok loc lit_ch - else lit_error i3 + mc <- getCharOrFail i3 -- Trailing quote + if mc == '\'' then finish_char_tok loc lit_ch + else lit_error i3 Just (c, i2@(AI _end2 _)) - | not (isAny c) -> lit_error i1 - | otherwise -> - - -- We've seen 'x, where x is a valid character - -- (i.e. not newline etc) but not a quote or backslash - case alexGetChar' i2 of -- Look ahead one more character - Just ('\'', i3) -> do -- We've seen 'x' - setInput i3 - finish_char_tok loc c - _other -> do -- We've seen 'x not followed by quote - -- (including the possibility of EOF) - -- If TH is on, just parse the quote only - th_exts <- extension thEnabled - let (AI end _) = i1 - if th_exts then return (L (mkRealSrcSpan loc end) ITvarQuote) - else lit_error i2 + | not (isAny c) -> lit_error i1 + | otherwise -> + + -- We've seen 'x, where x is a valid character + -- (i.e. not newline etc) but not a quote or backslash + case alexGetChar' i2 of -- Look ahead one more character + Just ('\'', i3) -> do -- We've seen 'x' + setInput i3 + finish_char_tok loc c + _other -> do -- We've seen 'x not followed by quote + -- (including the possibility of EOF) + -- If TH is on, just parse the quote only + th_exts <- extension thEnabled + let (AI end _) = i1 + if th_exts then return (L (mkRealSrcSpan loc end) ITvarQuote) + else lit_error i2 finish_char_tok :: RealSrcLoc -> Char -> P (RealLocated Token) -finish_char_tok loc ch -- We've already seen the closing quote - -- Just need to check for trailing # - = do magicHash <- extension magicHashEnabled - i@(AI end _) <- getInput - if magicHash then do - case alexGetChar' i of - Just ('#',i@(AI end _)) -> do - setInput i - return (L (mkRealSrcSpan loc end) (ITprimchar ch)) - _other -> - return (L (mkRealSrcSpan loc end) (ITchar ch)) - else do - return (L (mkRealSrcSpan loc end) (ITchar ch)) +finish_char_tok loc ch -- We've already seen the closing quote + -- Just need to check for trailing # + = do magicHash <- extension magicHashEnabled + i@(AI end _) <- getInput + if magicHash then do + case alexGetChar' i of + Just ('#',i@(AI end _)) -> do + setInput i + return (L (mkRealSrcSpan loc end) (ITprimchar ch)) + _other -> + return (L (mkRealSrcSpan loc end) (ITchar ch)) + else do + return (L (mkRealSrcSpan loc end) (ITchar ch)) isAny :: Char -> Bool isAny c | c > '\x7f' = isPrint c - | otherwise = is_any c + | otherwise = is_any c lex_escape :: P Char lex_escape = do i0 <- getInput c <- getCharOrFail i0 case c of - 'a' -> return '\a' - 'b' -> return '\b' - 'f' -> return '\f' - 'n' -> return '\n' - 'r' -> return '\r' - 't' -> return '\t' - 'v' -> return '\v' - '\\' -> return '\\' - '"' -> return '\"' - '\'' -> return '\'' - '^' -> do i1 <- getInput + 'a' -> return '\a' + 'b' -> return '\b' + 'f' -> return '\f' + 'n' -> return '\n' + 'r' -> return '\r' + 't' -> return '\t' + 'v' -> return '\v' + '\\' -> return '\\' + '"' -> return '\"' + '\'' -> return '\'' + '^' -> do i1 <- getInput c <- getCharOrFail i1 - if c >= '@' && c <= '_' - then return (chr (ord c - ord '@')) - else lit_error i1 - - 'x' -> readNum is_hexdigit 16 hexDigit - 'o' -> readNum is_octdigit 8 octDecDigit - x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x) - - c1 -> do - i <- getInput - case alexGetChar' i of - Nothing -> lit_error i0 - Just (c2,i2) -> + if c >= '@' && c <= '_' + then return (chr (ord c - ord '@')) + else lit_error i1 + + 'x' -> readNum is_hexdigit 16 hexDigit + 'o' -> readNum is_octdigit 8 octDecDigit + x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x) + + c1 -> do + i <- getInput + case alexGetChar' i of + Nothing -> lit_error i0 + Just (c2,i2) -> case alexGetChar' i2 of - Nothing -> do lit_error i0 - Just (c3,i3) -> - let str = [c1,c2,c3] in - case [ (c,rest) | (p,c) <- silly_escape_chars, - Just rest <- [stripPrefix p str] ] of - (escape_char,[]):_ -> do - setInput i3 - return escape_char - (escape_char,_:_):_ -> do - setInput i2 - return escape_char - [] -> lit_error i0 + Nothing -> do lit_error i0 + Just (c3,i3) -> + let str = [c1,c2,c3] in + case [ (c,rest) | (p,c) <- silly_escape_chars, + Just rest <- [stripPrefix p str] ] of + (escape_char,[]):_ -> do + setInput i3 + return escape_char + (escape_char,_:_):_ -> do + setInput i2 + return escape_char + [] -> lit_error i0 readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char readNum is_digit base conv = do i <- getInput c <- getCharOrFail i - if is_digit c - then readNum2 is_digit base conv (conv c) - else lit_error i + if is_digit c + then readNum2 is_digit base conv (conv c) + else lit_error i readNum2 :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> P Char readNum2 is_digit base conv i = do input <- getInput read i input where read i input = do - case alexGetChar' input of - Just (c,input') | is_digit c -> do + case alexGetChar' input of + Just (c,input') | is_digit c -> do let i' = i*base + conv c if i' > 0x10ffff then setInput input >> lexError "numeric escape sequence out of range" else read i' input' - _other -> do + _other -> do setInput input; return (chr i) silly_escape_chars :: [(String, Char)] silly_escape_chars = [ - ("NUL", '\NUL'), - ("SOH", '\SOH'), - ("STX", '\STX'), - ("ETX", '\ETX'), - ("EOT", '\EOT'), - ("ENQ", '\ENQ'), - ("ACK", '\ACK'), - ("BEL", '\BEL'), - ("BS", '\BS'), - ("HT", '\HT'), - ("LF", '\LF'), - ("VT", '\VT'), - ("FF", '\FF'), - ("CR", '\CR'), - ("SO", '\SO'), - ("SI", '\SI'), - ("DLE", '\DLE'), - ("DC1", '\DC1'), - ("DC2", '\DC2'), - ("DC3", '\DC3'), - ("DC4", '\DC4'), - ("NAK", '\NAK'), - ("SYN", '\SYN'), - ("ETB", '\ETB'), - ("CAN", '\CAN'), - ("EM", '\EM'), - ("SUB", '\SUB'), - ("ESC", '\ESC'), - ("FS", '\FS'), - ("GS", '\GS'), - ("RS", '\RS'), - ("US", '\US'), - ("SP", '\SP'), - ("DEL", '\DEL') - ] + ("NUL", '\NUL'), + ("SOH", '\SOH'), + ("STX", '\STX'), + ("ETX", '\ETX'), + ("EOT", '\EOT'), + ("ENQ", '\ENQ'), + ("ACK", '\ACK'), + ("BEL", '\BEL'), + ("BS", '\BS'), + ("HT", '\HT'), + ("LF", '\LF'), + ("VT", '\VT'), + ("FF", '\FF'), + ("CR", '\CR'), + ("SO", '\SO'), + ("SI", '\SI'), + ("DLE", '\DLE'), + ("DC1", '\DC1'), + ("DC2", '\DC2'), + ("DC3", '\DC3'), + ("DC4", '\DC4'), + ("NAK", '\NAK'), + ("SYN", '\SYN'), + ("ETB", '\ETB'), + ("CAN", '\CAN'), + ("EM", '\EM'), + ("SUB", '\SUB'), + ("ESC", '\ESC'), + ("FS", '\FS'), + ("GS", '\GS'), + ("RS", '\RS'), + ("US", '\US'), + ("SP", '\SP'), + ("DEL", '\DEL') + ] -- before calling lit_error, ensure that the current input is pointing to -- the position of the error in the buffer. This is so that we can report @@ -1434,8 +1402,8 @@ lit_error i = do setInput i; lexError "lexical error in string/character literal getCharOrFail :: AlexInput -> P Char getCharOrFail i = do case alexGetChar' i of - Nothing -> lexError "unexpected end-of-file in string/character literal" - Just (c,i) -> do setInput i; return c + Nothing -> lexError "unexpected end-of-file in string/character literal" + Just (c,i) -> do setInput i; return c -- ----------------------------------------------------------------------------- -- QuasiQuote @@ -1443,11 +1411,11 @@ getCharOrFail i = do lex_quasiquote_tok :: Action lex_quasiquote_tok span buf len = do let quoter = tail (lexemeToString buf (len - 1)) - -- 'tail' drops the initial '[', - -- while the -1 drops the trailing '|' - quoteStart <- getSrcLoc + -- 'tail' drops the initial '[', + -- while the -1 drops the trailing '|' + quoteStart <- getSrcLoc quote <- lex_quasiquote "" - end <- getSrcLoc + end <- getSrcLoc return (L (mkRealSrcSpan (realSrcSpanStart span) end) (ITquasiQuote (mkFastString quoter, mkFastString (reverse quote), @@ -1460,29 +1428,29 @@ lex_quasiquote s = do Nothing -> lit_error i Just ('\\',i) - | Just ('|',i) <- next -> do - setInput i; lex_quasiquote ('|' : s) - | Just (']',i) <- next -> do - setInput i; lex_quasiquote (']' : s) - where next = alexGetChar' i + | Just ('|',i) <- next -> do + setInput i; lex_quasiquote ('|' : s) + | Just (']',i) <- next -> do + setInput i; lex_quasiquote (']' : s) + where next = alexGetChar' i Just ('|',i) - | Just (']',i) <- next -> do - setInput i; return s - where next = alexGetChar' i + | Just (']',i) <- next -> do + setInput i; return s + where next = alexGetChar' i Just (c, i) -> do - setInput i; lex_quasiquote (c : s) + setInput i; lex_quasiquote (c : s) -- ----------------------------------------------------------------------------- -- Warnings -warn :: DynFlag -> SDoc -> Action +warn :: WarningFlag -> SDoc -> Action warn option warning srcspan _buf _len = do addWarning option (RealSrcSpan srcspan) warning lexToken -warnThen :: DynFlag -> SDoc -> Action -> Action +warnThen :: WarningFlag -> SDoc -> Action -> Action warnThen option warning action srcspan buf len = do addWarning option (RealSrcSpan srcspan) warning action srcspan buf len @@ -1497,22 +1465,23 @@ data LayoutContext data ParseResult a = POk PState a - | PFailed - SrcSpan -- The start and end of the text span related to - -- the error. Might be used in environments which can - -- show this span, e.g. by highlighting it. - Message -- The error message - -data PState = PState { - buffer :: StringBuffer, + | PFailed + SrcSpan -- The start and end of the text span related to + -- the error. Might be used in environments which can + -- show this span, e.g. by highlighting it. + Message -- The error message + +data PState = PState { + buffer :: StringBuffer, dflags :: DynFlags, messages :: Messages, - last_loc :: RealSrcSpan, -- pos of previous token - last_len :: !Int, -- len of previous token - loc :: RealSrcLoc, -- current loc (end of prev token + 1) - extsBitmap :: !Int, -- bitmap that determines permitted extensions - context :: [LayoutContext], - lex_state :: [Int], + last_loc :: RealSrcSpan, -- pos of previous token + last_len :: !Int, -- len of previous token + loc :: RealSrcLoc, -- current loc (end of prev token + 1) + extsBitmap :: !Int, -- bitmap that determines permitted + -- extensions + context :: [LayoutContext], + lex_state :: [Int], -- Used in the alternative layout rule: -- These tokens are the next ones to be sent out. They are -- just blindly emitted, without the rule looking at them again: @@ -1532,11 +1501,11 @@ data PState = PState { -- token doesn't need to close anything: alr_justClosedExplicitLetBlock :: Bool } - -- last_loc and last_len are used when generating error messages, - -- and in pushCurrentContext only. Sigh, if only Happy passed the - -- current token to happyError, we could at least get rid of last_len. - -- Getting rid of last_loc would require finding another way to - -- implement pushCurrentContext (which is only called from one place). + -- last_loc and last_len are used when generating error messages, + -- and in pushCurrentContext only. Sigh, if only Happy passed the + -- current token to happyError, we could at least get rid of last_len. + -- Getting rid of last_loc would require finding another way to + -- implement pushCurrentContext (which is only called from one place). data ALRContext = ALRNoLayout Bool{- does it contain commas? -} Bool{- is it a 'let' block? -} @@ -1558,9 +1527,9 @@ returnP a = a `seq` (P $ \s -> POk s a) thenP :: P a -> (a -> P b) -> P b (P m) `thenP` k = P $ \ s -> - case m s of - POk s1 a -> (unP (k a)) s1 - PFailed span err -> PFailed span err + case m s of + POk s1 a -> (unP (k a)) s1 + PFailed span err -> PFailed span err failP :: String -> P a failP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg) @@ -1582,8 +1551,8 @@ getDynFlags = P $ \s -> POk s (dflags s) withThisPackage :: (PackageId -> a) -> P a withThisPackage f - = do pkg <- liftM thisPackage getDynFlags - return $ f pkg + = do pkg <- liftM thisPackage getDynFlags + return $ f pkg extension :: (Int -> Bool) -> P Bool extension p = P $ \s -> POk s (p $! extsBitmap s) @@ -1601,8 +1570,8 @@ getSrcLoc :: P RealSrcLoc getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc setLastToken :: RealSrcSpan -> Int -> P () -setLastToken loc len = P $ \s -> POk s { - last_loc=loc, +setLastToken loc len = P $ \s -> POk s { + last_loc=loc, last_len=len } () @@ -1612,63 +1581,63 @@ alexInputPrevChar :: AlexInput -> Char alexInputPrevChar (AI _ buf) = prevChar buf '\n' alexGetChar :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar (AI loc s) +alexGetChar (AI loc s) | atEnd s = Nothing - | otherwise = adj_c `seq` loc' `seq` s' `seq` - --trace (show (ord c)) $ - Just (adj_c, (AI loc' s')) + | otherwise = adj_c `seq` loc' `seq` s' `seq` + --trace (show (ord c)) $ + Just (adj_c, (AI loc' s')) where (c,s') = nextChar s loc' = advanceSrcLoc loc c - non_graphic = '\x0' - upper = '\x1' - lower = '\x2' - digit = '\x3' - symbol = '\x4' - space = '\x5' - other_graphic = '\x6' - - adj_c - | c <= '\x06' = non_graphic - | c <= '\x7f' = c + non_graphic = '\x0' + upper = '\x1' + lower = '\x2' + digit = '\x3' + symbol = '\x4' + space = '\x5' + other_graphic = '\x6' + + adj_c + | c <= '\x06' = non_graphic + | c <= '\x7f' = c -- Alex doesn't handle Unicode, so when Unicode -- character is encountered we output these values -- with the actual character value hidden in the state. - | otherwise = - case generalCategory c of - UppercaseLetter -> upper - LowercaseLetter -> lower - TitlecaseLetter -> upper - ModifierLetter -> other_graphic - OtherLetter -> lower -- see #1103 - NonSpacingMark -> other_graphic - SpacingCombiningMark -> other_graphic - EnclosingMark -> other_graphic - DecimalNumber -> digit - LetterNumber -> other_graphic + | otherwise = + case generalCategory c of + UppercaseLetter -> upper + LowercaseLetter -> lower + TitlecaseLetter -> upper + ModifierLetter -> other_graphic + OtherLetter -> lower -- see #1103 + NonSpacingMark -> other_graphic + SpacingCombiningMark -> other_graphic + EnclosingMark -> other_graphic + DecimalNumber -> digit + LetterNumber -> other_graphic OtherNumber -> digit -- see #4373 - ConnectorPunctuation -> symbol - DashPunctuation -> symbol - OpenPunctuation -> other_graphic - ClosePunctuation -> other_graphic - InitialQuote -> other_graphic - FinalQuote -> other_graphic - OtherPunctuation -> symbol - MathSymbol -> symbol - CurrencySymbol -> symbol - ModifierSymbol -> symbol - OtherSymbol -> symbol - Space -> space - _other -> non_graphic + ConnectorPunctuation -> symbol + DashPunctuation -> symbol + OpenPunctuation -> other_graphic + ClosePunctuation -> other_graphic + InitialQuote -> other_graphic + FinalQuote -> other_graphic + OtherPunctuation -> symbol + MathSymbol -> symbol + CurrencySymbol -> symbol + ModifierSymbol -> symbol + OtherSymbol -> symbol + Space -> space + _other -> non_graphic -- This version does not squash unicode characters, it is used when -- lexing strings. alexGetChar' :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar' (AI loc s) +alexGetChar' (AI loc s) | atEnd s = Nothing - | otherwise = c `seq` loc' `seq` s' `seq` - --trace (show (ord c)) $ - Just (c, (AI loc' s')) + | otherwise = c `seq` loc' `seq` s' `seq` + --trace (show (ord c)) $ + Just (c, (AI loc' s')) where (c,s') = nextChar s loc' = advanceSrcLoc loc c @@ -1753,30 +1722,28 @@ setAlrExpectingOCurly :: Maybe ALRLayout -> P () setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) () -- for reasons of efficiency, flags indicating language extensions (eg, --- -fglasgow-exts or -XParallelArrays) are represented by a bitmap stored in an unboxed --- integer - --- The "genericsBit" is now unused, available for others --- genericsBit :: Int --- genericsBit = 0 -- {|, |} and "generic" +-- -fglasgow-exts or -XParallelArrays) are represented by a bitmap +-- stored in an unboxed Int ffiBit :: Int -ffiBit = 1 +ffiBit= 0 +interruptibleFfiBit :: Int +interruptibleFfiBit = 1 parrBit :: Int -parrBit = 2 +parrBit = 3 arrowsBit :: Int arrowsBit = 4 thBit :: Int -thBit = 5 +thBit = 5 ipBit :: Int -ipBit = 6 +ipBit = 6 explicitForallBit :: Int explicitForallBit = 7 -- the 'forall' keyword and '.' symbol bangPatBit :: Int -bangPatBit = 8 -- Tells the parser to understand bang-patterns - -- (doesn't affect the lexer) +bangPatBit = 8 -- Tells the parser to understand bang-patterns + -- (doesn't affect the lexer) tyFamBit :: Int -tyFamBit = 9 -- indexed type families: 'family' keyword and kind sigs +tyFamBit = 9 -- indexed type families: 'family' keyword and kind sigs haddockBit :: Int haddockBit = 10 -- Lex and parse Haddock comments magicHashBit :: Int @@ -1794,7 +1761,7 @@ datatypeContextsBit = 16 transformComprehensionsBit :: Int transformComprehensionsBit = 17 qqBit :: Int -qqBit = 18 -- enable quasiquoting +qqBit = 18 -- enable quasiquoting inRulePragBit :: Int inRulePragBit = 19 rawTokenStreamBit :: Int @@ -1880,41 +1847,42 @@ mkPState flags buf loc = alr_justClosedExplicitLetBlock = False } where - bitmap = ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags - .|. parrBit `setBitIf` xopt Opt_ParallelArrays flags - .|. arrowsBit `setBitIf` xopt Opt_Arrows flags - .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags - .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags - .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags - .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags - .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags - .|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags - .|. haddockBit `setBitIf` dopt Opt_Haddock flags - .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags - .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags - .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags - .|. recBit `setBitIf` xopt Opt_DoRec flags - .|. recBit `setBitIf` xopt Opt_Arrows flags - .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags - .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags - .|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags - .|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags - .|. transformComprehensionsBit `setBitIf` xopt Opt_MonadComprehensions flags - .|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags - .|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags - .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags + bitmap = ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags + .|. interruptibleFfiBit `setBitIf` xopt Opt_InterruptibleFFI flags + .|. parrBit `setBitIf` xopt Opt_ParallelArrays flags + .|. arrowsBit `setBitIf` xopt Opt_Arrows flags + .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags + .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags + .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags + .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags + .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags + .|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags + .|. haddockBit `setBitIf` dopt Opt_Haddock flags + .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags + .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags + .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags + .|. recBit `setBitIf` xopt Opt_DoRec flags + .|. recBit `setBitIf` xopt Opt_Arrows flags + .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags + .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags + .|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags + .|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags + .|. transformComprehensionsBit `setBitIf` xopt Opt_MonadComprehensions flags + .|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags + .|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags + .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags .|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags - .|. safeHaskellBit `setBitIf` safeHaskellOn flags + .|. safeHaskellBit `setBitIf` safeHaskellOn flags -- setBitIf :: Int -> Bool -> Int b `setBitIf` cond | cond = bit b | otherwise = 0 -addWarning :: DynFlag -> SrcSpan -> SDoc -> P () +addWarning :: WarningFlag -> SrcSpan -> SDoc -> P () addWarning option srcspan warning = P $ \s@PState{messages=(ws,es), dflags=d} -> let warning' = mkWarnMsg srcspan alwaysQualify warning - ws' = if dopt option d then ws `snocBag` warning' else ws + ws' = if wopt option d then ws `snocBag` warning' else ws in POk s{messages=(ws', es)} () getMessages :: PState -> Messages @@ -1927,40 +1895,40 @@ setContext :: [LayoutContext] -> P () setContext ctx = P $ \s -> POk s{context=ctx} () popContext :: P () -popContext = P $ \ s@(PState{ buffer = buf, context = ctx, +popContext = P $ \ s@(PState{ buffer = buf, context = ctx, last_len = len, last_loc = last_loc }) -> case ctx of - (_:tl) -> POk s{ context = tl } () - [] -> PFailed (RealSrcSpan last_loc) (srcParseErr buf len) + (_:tl) -> POk s{ context = tl } () + [] -> PFailed (RealSrcSpan last_loc) (srcParseErr buf len) -- Push a new layout context at the indentation of the last token read. -- This is only used at the outer level of a module when the 'module' -- keyword is missing. pushCurrentContext :: P () -pushCurrentContext = P $ \ s@PState{ last_loc=loc, context=ctx } -> +pushCurrentContext = P $ \ s@PState{ last_loc=loc, context=ctx } -> POk s{context = Layout (srcSpanStartCol loc) : ctx} () getOffside :: P Ordering getOffside = P $ \s@PState{last_loc=loc, context=stk} -> let offs = srcSpanStartCol loc in - let ord = case stk of - (Layout n:_) -> --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $ + let ord = case stk of + (Layout n:_) -> --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $ compare offs n - _ -> GT - in POk s ord + _ -> GT + in POk s ord -- --------------------------------------------------------------------------- -- Construct a parse error srcParseErr - :: StringBuffer -- current buffer (placed just after the last token) - -> Int -- length of the previous token + :: StringBuffer -- current buffer (placed just after the last token) + -> Int -- length of the previous token -> Message srcParseErr buf len - = hcat [ if null token - then ptext (sLit "parse error (possibly incorrect indentation)") - else hcat [ptext (sLit "parse error on input "), - char '`', text token, char '\''] + = hcat [ if null token + then ptext (sLit "parse error (possibly incorrect indentation)") + else hcat [ptext (sLit "parse error on input "), + char '`', text token, char '\''] ] where token = lexemeToString (offsetBytes (-len) buf) len @@ -1968,8 +1936,8 @@ srcParseErr buf len -- the location of the error. This is the entry point for errors -- detected during parsing. srcParseFail :: P a -srcParseFail = P $ \PState{ buffer = buf, last_len = len, - last_loc = last_loc } -> +srcParseFail = P $ \PState{ buffer = buf, last_len = len, + last_loc = last_loc } -> PFailed (RealSrcSpan last_loc) (srcParseErr buf len) -- A lexical error is reported at a particular position in the source file, @@ -2238,12 +2206,10 @@ reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a reportLexError loc1 loc2 buf str | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input") | otherwise = - let - c = fst (nextChar buf) - in - if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar# - then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)") - else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c) + let c = fst (nextChar buf) + in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar# + then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)") + else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c) lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token] lexTokenStream buf loc dflags = unP go initState @@ -2274,7 +2240,7 @@ oneWordPrags = Map.fromList([("rules", rulePrag), ("inline", token (ITinline_prag Inline FunLike)), ("inlinable", token (ITinline_prag Inlinable FunLike)), ("inlineable", token (ITinline_prag Inlinable FunLike)), - -- Spelling variant + -- Spelling variant ("notinline", token (ITinline_prag NoInline FunLike)), ("specialize", token ITspec_prag), ("source", token ITsource_prag), diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index bb82aaa2d1..05e0222182 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -238,7 +238,6 @@ incorrect. 'label' { L _ ITlabel } 'dynamic' { L _ ITdynamic } 'safe' { L _ ITsafe } - 'threadsafe' { L _ ITthreadsafe } -- ToDo: remove deprecated alias 'interruptible' { L _ ITinterruptible } 'unsafe' { L _ ITunsafe } 'mdo' { L _ ITmdo } @@ -427,14 +426,18 @@ header :: { Located (HsModule RdrName) } {% fileSrcSpan >>= \ loc -> return (L loc (HsModule (Just $3) $5 $7 [] $4 $1 ))} - | missing_module_keyword importdecls + | header_body2 {% fileSrcSpan >>= \ loc -> - return (L loc (HsModule Nothing Nothing $2 [] Nothing + return (L loc (HsModule Nothing Nothing $1 [] Nothing Nothing)) } header_body :: { [LImportDecl RdrName] } : '{' importdecls { $2 } - | vocurly importdecls { $2 } + | vocurly importdecls { $2 } + +header_body2 :: { [LImportDecl RdrName] } + : '{' importdecls { $2 } + | missing_module_keyword importdecls { $2 } ----------------------------------------------------------------------------- -- The Export List @@ -890,7 +893,7 @@ fdecl :: { LHsDecl RdrName } fdecl : 'import' callconv safety fspec {% mkImport $2 $3 (unLoc $4) >>= return.LL } | 'import' callconv fspec - {% do { d <- mkImport $2 (PlaySafe False) (unLoc $3); + {% do { d <- mkImport $2 PlaySafe (unLoc $3); return (LL d) } } | 'export' callconv fspec {% mkExport $2 (unLoc $3) >>= return.LL } @@ -902,9 +905,8 @@ callconv :: { CCallConv } safety :: { Safety } : 'unsafe' { PlayRisky } - | 'safe' { PlaySafe False } + | 'safe' { PlaySafe } | 'interruptible' { PlayInterruptible } - | 'threadsafe' { PlaySafe True } -- deprecated alias fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) } : STRING var '::' sigtypedoc { LL (L (getLoc $1) (getSTRING $1), $2, $4) } @@ -1804,7 +1806,6 @@ tyvarid :: { Located RdrName } | 'unsafe' { L1 $! mkUnqual tvName (fsLit "unsafe") } | 'safe' { L1 $! mkUnqual tvName (fsLit "safe") } | 'interruptible' { L1 $! mkUnqual tvName (fsLit "interruptible") } - | 'threadsafe' { L1 $! mkUnqual tvName (fsLit "threadsafe") } tyvarsym :: { Located RdrName } -- Does not include "!", because that is used for strictness marks @@ -1838,7 +1839,6 @@ varid :: { Located RdrName } | 'unsafe' { L1 $! mkUnqual varName (fsLit "unsafe") } | 'safe' { L1 $! mkUnqual varName (fsLit "safe") } | 'interruptible' { L1 $! mkUnqual varName (fsLit "interruptible") } - | 'threadsafe' { L1 $! mkUnqual varName (fsLit "threadsafe") } | 'forall' { L1 $! mkUnqual varName (fsLit "forall") } | 'family' { L1 $! mkUnqual varName (fsLit "family") } diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index 3f2b32a8b3..c99fcb6695 100644 --- a/compiler/parser/ParserCore.y +++ b/compiler/parser/ParserCore.y @@ -279,7 +279,7 @@ exp :: { IfaceExpr } -- } | '%external' STRING aty { IfaceFCall (ForeignCall.CCall (CCallSpec (StaticTarget (mkFastString $2) Nothing) - CCallConv (PlaySafe False))) + CCallConv PlaySafe)) $3 } alts1 :: { [IfaceAlt] } diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs index 87bb94a148..ac19974976 100644 --- a/compiler/prelude/ForeignCall.lhs +++ b/compiler/prelude/ForeignCall.lhs @@ -62,10 +62,6 @@ data Safety -- by a separate OS thread, i.e., _concurrently_ to the -- execution of other Haskell threads. - Bool -- Indicates the deprecated "threadsafe" annotation - -- which is now an alias for "safe". This information - -- is never used except to emit a deprecation warning. - | PlayInterruptible -- Like PlaySafe, but additionally -- the worker thread running this foreign call may -- be unceremoniously killed, so it must be scheduled @@ -78,15 +74,14 @@ data Safety {-! derive: Binary !-} instance Outputable Safety where - ppr (PlaySafe False) = ptext (sLit "safe") - ppr (PlaySafe True) = ptext (sLit "threadsafe") + ppr PlaySafe = ptext (sLit "safe") ppr PlayInterruptible = ptext (sLit "interruptible") ppr PlayRisky = ptext (sLit "unsafe") playSafe :: Safety -> Bool -playSafe PlaySafe{} = True +playSafe PlaySafe = True playSafe PlayInterruptible = True -playSafe PlayRisky = False +playSafe PlayRisky = False playInterruptible :: Safety -> Bool playInterruptible PlayInterruptible = True @@ -244,9 +239,8 @@ instance Binary ForeignCall where get bh = do aa <- get bh; return (CCall aa) instance Binary Safety where - put_ bh (PlaySafe aa) = do + put_ bh PlaySafe = do putByte bh 0 - put_ bh aa put_ bh PlayInterruptible = do putByte bh 1 put_ bh PlayRisky = do @@ -254,8 +248,7 @@ instance Binary Safety where get bh = do h <- getByte bh case h of - 0 -> do aa <- get bh - return (PlaySafe aa) + 0 -> do return PlaySafe 1 -> do return PlayInterruptible _ -> do return PlayRisky diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 95bc2d6014..c9fa8eab20 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -282,7 +282,7 @@ gHC_PRIM, gHC_TYPES, gHC_UNIT, gHC_ORDERING, gHC_GENERICS, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, gHC_CONC, gHC_IO, gHC_IO_Exception, gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL, - gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, gENERICS, + gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, tYPEABLE_INTERNAL, gENERICS, dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_GROUP, mONAD_ZIP, aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS, cONTROL_EXCEPTION_BASE :: Module @@ -323,7 +323,8 @@ gHC_FLOAT = mkBaseModule (fsLit "GHC.Float") gHC_TOP_HANDLER = mkBaseModule (fsLit "GHC.TopHandler") sYSTEM_IO = mkBaseModule (fsLit "System.IO") dYNAMIC = mkBaseModule (fsLit "Data.Dynamic") -tYPEABLE = mkBaseModule (fsLit "Data.Typeable") +tYPEABLE = mkBaseModule (fsLit "Data.Typeable") +tYPEABLE_INTERNAL = mkBaseModule (fsLit "Data.Typeable.Internal") gENERICS = mkBaseModule (fsLit "Data.Data") dOTNET = mkBaseModule (fsLit "GHC.Dotnet") rEAD_PREC = mkBaseModule (fsLit "Text.ParserCombinators.ReadPrec") @@ -546,10 +547,10 @@ showString_RDR = varQual_RDR gHC_SHOW (fsLit "showString") showSpace_RDR = varQual_RDR gHC_SHOW (fsLit "showSpace") showParen_RDR = varQual_RDR gHC_SHOW (fsLit "showParen") -typeOf_RDR, mkTypeRep_RDR, mkTyConRep_RDR :: RdrName -typeOf_RDR = varQual_RDR tYPEABLE (fsLit "typeOf") -mkTypeRep_RDR = varQual_RDR tYPEABLE (fsLit "mkTyConApp") -mkTyConRep_RDR = varQual_RDR tYPEABLE (fsLit "mkTyCon") +typeOf_RDR, mkTyCon_RDR, mkTyConApp_RDR :: RdrName +typeOf_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "typeOf") +mkTyCon_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "mkTyCon") +mkTyConApp_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "mkTyConApp") undefined_RDR :: RdrName undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined") @@ -819,14 +820,14 @@ ixClassName = clsQual gHC_ARR (fsLit "Ix") ixClassKey typeableClassName, typeable1ClassName, typeable2ClassName, typeable3ClassName, typeable4ClassName, typeable5ClassName, typeable6ClassName, typeable7ClassName :: Name -typeableClassName = clsQual tYPEABLE (fsLit "Typeable") typeableClassKey -typeable1ClassName = clsQual tYPEABLE (fsLit "Typeable1") typeable1ClassKey -typeable2ClassName = clsQual tYPEABLE (fsLit "Typeable2") typeable2ClassKey -typeable3ClassName = clsQual tYPEABLE (fsLit "Typeable3") typeable3ClassKey -typeable4ClassName = clsQual tYPEABLE (fsLit "Typeable4") typeable4ClassKey -typeable5ClassName = clsQual tYPEABLE (fsLit "Typeable5") typeable5ClassKey -typeable6ClassName = clsQual tYPEABLE (fsLit "Typeable6") typeable6ClassKey -typeable7ClassName = clsQual tYPEABLE (fsLit "Typeable7") typeable7ClassKey +typeableClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable") typeableClassKey +typeable1ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable1") typeable1ClassKey +typeable2ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable2") typeable2ClassKey +typeable3ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable3") typeable3ClassKey +typeable4ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable4") typeable4ClassKey +typeable5ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable5") typeable5ClassKey +typeable6ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable6") typeable6ClassKey +typeable7ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable7") typeable7ClassKey typeableClassNames :: [Name] typeableClassNames = [ typeableClassName, typeable1ClassName, typeable2ClassName diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 58df462532..e14f6a8d1b 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -980,7 +980,7 @@ checkDupAndShadowedNames envs names ------------------------------------- checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv) -> [(SrcSpan,OccName)] -> RnM () checkShadowedOccs (global_env,local_env) loc_occs - = ifDOptM Opt_WarnNameShadowing $ + = ifWOptM Opt_WarnNameShadowing $ do { traceRn (text "shadow" <+> ppr loc_occs) ; mapM_ check_shadow loc_occs } where @@ -1214,7 +1214,7 @@ mapFvRnCPS f (x:xs) cont = f x $ \ x' -> \begin{code} warnUnusedTopBinds :: [GlobalRdrElt] -> RnM () warnUnusedTopBinds gres - = ifDOptM Opt_WarnUnusedBinds + = ifWOptM Opt_WarnUnusedBinds $ do isBoot <- tcIsHsBoot let noParent gre = case gre_par gre of NoParent -> True @@ -1230,9 +1230,9 @@ warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> FreeVars -> RnM () warnUnusedLocalBinds = check_unused Opt_WarnUnusedBinds warnUnusedMatches = check_unused Opt_WarnUnusedMatches -check_unused :: DynFlag -> [Name] -> FreeVars -> RnM () +check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM () check_unused flag bound_names used_names - = ifDOptM flag (warnUnusedLocals (filterOut (`elemNameSet` used_names) bound_names)) + = ifWOptM flag (warnUnusedLocals (filterOut (`elemNameSet` used_names) bound_names)) ------------------------- -- Helpers diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index afec7f59b5..1a70068210 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -146,7 +146,7 @@ rnImports imports (source, ordinary) = partition is_source_import imports is_source_import (L _ (ImportDecl _ _ is_boot _ _ _ _)) = is_boot - ifDOptM Opt_WarnImplicitPrelude $ + ifWOptM Opt_WarnImplicitPrelude $ when (notNull prel_imports) $ addWarn (implicitPreludeWarn) stuff1 <- mapM (rnImportDecl this_mod True) prel_imports @@ -197,7 +197,7 @@ rnImportDecl this_mod implicit_prelude Just (False, _) -> return () -- Explicit import list _ | implicit_prelude -> return () | qual_only -> return () - | otherwise -> ifDOptM Opt_WarnMissingImportList $ + | otherwise -> ifWOptM Opt_WarnMissingImportList $ addWarn (missingImportListWarn imp_mod_name) iface <- loadSrcInterface doc imp_mod_name want_boot mb_pkg @@ -277,9 +277,7 @@ rnImportDecl this_mod implicit_prelude -- Does this import mean we now require our own pkg -- to be trusted? See Note [Trust Own Package] - ptrust = trust == Sf_Trustworthy - || trust == Sf_TrustworthyWithSafeLanguage - || trust_pkg + ptrust = trust == Sf_Trustworthy || trust_pkg (dependent_mods, dependent_pkgs, pkg_trust_req) | pkg == thisPackage dflags = @@ -335,7 +333,7 @@ rnImportDecl this_mod implicit_prelude } -- Complain if we import a deprecated module - ifDOptM Opt_WarnWarningsDeprecations ( + ifWOptM Opt_WarnWarningsDeprecations ( case warns of WarnAll txt -> addWarn (moduleWarn imp_mod_name txt) _ -> return () @@ -692,11 +690,11 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) all_avails -- Warn when importing T(..) if T was exported abstractly checkDodgyImport stuff | IEThingAll n <- ieRdr, (_, AvailTC _ [_]):_ <- stuff - = ifDOptM Opt_WarnDodgyImports (addWarn (dodgyImportWarn n)) + = ifWOptM Opt_WarnDodgyImports (addWarn (dodgyImportWarn n)) -- NB. use the RdrName for reporting the warning | IEThingAll {} <- ieRdr , not (is_qual decl_spec) - = ifDOptM Opt_WarnMissingImportList $ + = ifWOptM Opt_WarnMissingImportList $ addWarn (missingImportListItem ieRdr) checkDodgyImport _ = return () @@ -1023,13 +1021,13 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod (L loc (IEModuleContents mod)) | let earlier_mods = [ mod | (L _ (IEModuleContents mod)) <- ie_names ] , mod `elem` earlier_mods -- Duplicate export of M - = do { warn_dup_exports <- doptM Opt_WarnDuplicateExports ; + = do { warn_dup_exports <- woptM Opt_WarnDuplicateExports ; warnIf warn_dup_exports (dupModuleExport mod) ; return acc } | otherwise = do { implicit_prelude <- xoptM Opt_ImplicitPrelude - ; warnDodgyExports <- doptM Opt_WarnDodgyExports + ; warnDodgyExports <- woptM Opt_WarnDodgyExports ; let { exportValid = (mod `elem` imported_modules) || (moduleName this_mod == mod) ; gres = filter (isModuleExported implicit_prelude mod) @@ -1092,7 +1090,7 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod Nothing -> mkRdrUnqual Just (modName, _) -> mkRdrQual modName addUsedRdrNames $ map (mkKidRdrName . nameOccName) kids - warnDodgyExports <- doptM Opt_WarnDodgyExports + warnDodgyExports <- woptM Opt_WarnDodgyExports when (null kids) $ if isTyConName name then when warnDodgyExports $ addWarn (dodgyExportWarn name) @@ -1175,7 +1173,7 @@ check_occs ie occs names -- 'names' are the entities specifed by 'ie' -- But we don't want to warn if the same thing is exported -- by two different module exports. See ticket #4478. -> do unless (dupExport_ok name ie ie') $ do - warn_dup_exports <- doptM Opt_WarnDuplicateExports + warn_dup_exports <- woptM Opt_WarnDuplicateExports warnIf warn_dup_exports (dupExportWarn name_occ ie ie') return occs @@ -1241,7 +1239,7 @@ finishWarnings :: DynFlags -> Maybe WarningTxt -- All this happens only once per module finishWarnings dflags mod_warn tcg_env = do { (eps,hpt) <- getEpsAndHpt - ; ifDOptM Opt_WarnWarningsDeprecations $ + ; ifWOptM Opt_WarnWarningsDeprecations $ mapM_ (check hpt (eps_PIT eps)) all_gres -- By this time, typechecking is complete, -- so the PIT is fully populated @@ -1396,7 +1394,7 @@ warnUnusedImportDecls gbl_env usage = findImportUsage imports rdr_env (Set.elems uses) ; traceRn (ptext (sLit "Import usage") <+> ppr usage) - ; ifDOptM Opt_WarnUnusedImports $ + ; ifWOptM Opt_WarnUnusedImports $ mapM_ warnUnusedImport usage ; ifDOptM Opt_D_dump_minimal_imports $ diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 12d4375606..18c2048b6a 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -169,7 +169,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, -- (H) Rename Everything else (rn_inst_decls, src_fvs2) <- rnList rnSrcInstDecl inst_decls ; - (rn_rule_decls, src_fvs3) <- setOptM Opt_ScopedTypeVariables $ + (rn_rule_decls, src_fvs3) <- setXOptM Opt_ScopedTypeVariables $ rnList rnHsRuleDecl rule_decls ; -- Inside RULES, scoped type variables are on (rn_vect_decls, src_fvs4) <- rnList rnHsVectDecl vect_decls ; diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index be90d7d0a9..dd55f6f6a5 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -563,7 +563,7 @@ ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) forAllWarn :: SDoc -> LHsType RdrName -> Located RdrName -> TcRnIf TcGblEnv TcLclEnv () forAllWarn doc ty (L loc tyvar) - = ifDOptM Opt_WarnUnusedMatches $ + = ifWOptM Opt_WarnUnusedMatches $ addWarnAt loc (sep [ptext (sLit "The universally quantified type variable") <+> quotes (ppr tyvar), nest 4 (ptext (sLit "does not appear in the type") <+> quotes (ppr ty))] $$ diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index a1cae1c5dd..5202bef5e6 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -876,7 +876,15 @@ simplExprF :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplEnv, OutExpr) simplExprF env e cont - = -- pprTrace "simplExprF" (ppr e $$ ppr cont $$ ppr (seTvSubst env) $$ ppr (seIdSubst env) {- $$ ppr (seFloats env) -} ) $ + = {- pprTrace "simplExprF" (vcat + [ ppr e + , text "cont =" <+> ppr cont + , text "inscope =" <+> ppr (seInScope env) + , text "tvsubst =" <+> ppr (seTvSubst env) + , text "idsubst =" <+> ppr (seIdSubst env) + , text "cvsubst =" <+> ppr (seCvSubst env) + {- , ppr (seFloats env) -} + ]) $ -} simplExprF1 env e cont simplExprF1 :: SimplEnv -> InExpr -> SimplCont @@ -1009,7 +1017,8 @@ simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont -> SimplM (SimplEnv, OutExpr) simplCast env body co0 cont0 = do { co1 <- simplCoercion env co0 - ; simplExprF env body (addCoerce co1 cont0) } + ; -- pprTrace "simplCast" (ppr co1) $ + simplExprF env body (addCoerce co1 cont0) } where addCoerce co cont = add_coerce co (coercionKind co) cont @@ -1082,7 +1091,8 @@ simplCast env body co0 cont0 -- (->) t1 t2 ~ (->) s1 s2 [co1, co2] = decomposeCo 2 co new_arg = mkCoerce (mkSymCo co1) arg' - arg' = substExpr (text "move-cast") (arg_se `setInScope` env) arg + arg' = substExpr (text "move-cast") arg_se' arg + arg_se' = arg_se `setInScope` env add_coerce co _ cont = CoerceIt co cont \end{code} diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs index 391c07c089..1b8b270024 100644 --- a/compiler/stranal/WwLib.lhs +++ b/compiler/stranal/WwLib.lhs @@ -449,7 +449,7 @@ mkWWcpr body_ty RetCPR uniqs <- getUniquesM let (wrap_wild : work_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : body_ty : con_arg_tys) - arg_vars = map Var args + arg_vars = varsToCoreExprs args ubx_tup_con = tupleCon Unboxed n_con_args ubx_tup_ty = exprType ubx_tup_app ubx_tup_app = mkConApp ubx_tup_con (map Type con_arg_tys ++ arg_vars) diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 33254c1b5a..ce40f56e24 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -1216,7 +1216,7 @@ checkStrictBinds top_lvl rec_group binds poly_ids -- This should be a checkTc, not a warnTc, but as of GHC 6.11 -- the versions of alex and happy available have non-conforming -- templates, so the GHC build fails if it's an error: - ; warnUnlifted <- doptM Opt_WarnLazyUnliftedBindings + ; warnUnlifted <- woptM Opt_WarnLazyUnliftedBindings ; warnTc (warnUnlifted && not bang_pat && lifted_pat) -- No outer bang, but it's a compound pattern -- E.g (I# x#) = blah diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 45d54123ef..d2c4c7da9e 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -374,7 +374,7 @@ renameDeriv is_boot gen_binds insts | otherwise = discardWarnings $ -- Discard warnings about unused bindings etc - do { (rn_gen, dus_gen) <- setOptM Opt_ScopedTypeVariables $ -- Type signatures in patterns + do { (rn_gen, dus_gen) <- setXOptM Opt_ScopedTypeVariables $ -- Type signatures in patterns -- are used in the generic binds rnTopBinds (ValBindsIn gen_binds []) ; keepAliveSetTc (duDefs dus_gen) -- Mark these guys to be kept alive diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index d298a10f19..277d94941e 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -29,6 +29,7 @@ import VarEnv import SrcLoc import Bag import ListSetOps( equivClasses ) +import Maybes( mapCatMaybes ) import Util import FastString import Outputable @@ -555,13 +556,8 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys) ; case lookupInstEnv inst_envs clas tys_flat of ([], _, _) -> return (Just pred) -- No match - -- The case of exactly one match and no unifiers means a - -- successful lookup. That can't happen here, because dicts - -- only end up here if they didn't match in Inst.lookupInst - ([_],[], _) - | debugIsOn -> pprPanic "check_overlap" (ppr pred) - res -> do { addErrorReport ctxt (mk_overlap_msg res) - ; return Nothing } } + res -> do { addErrorReport ctxt (mk_overlap_msg res) + ; return Nothing } } where -- Normal overlap error mk_overlap_msg (matches, unifiers, False) @@ -571,25 +567,29 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys) , sep [ptext (sLit "Matching instances") <> colon, nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])] - , if not (null overlapping_givens) then - sep [ptext (sLit "Matching givens (or their superclasses)") <> colon, nest 2 (vcat overlapping_givens)] + , if not (null matching_givens) then + sep [ptext (sLit "Matching givens (or their superclasses)") <> colon + , nest 2 (vcat matching_givens)] else empty - , if null overlapping_givens && isSingleton matches && null unifiers then - -- Intuitively, some given matched the wanted in their flattened or rewritten (from given equalities) - -- form but the matcher can't figure that out because the constraints are non-flat and non-rewritten - -- so we simply report back the whole given context. Accelerate Smart.hs showed this problem. - sep [ptext (sLit "There exists a (perhaps superclass) match") <> colon, nest 2 (vcat (pp_givens givens))] + , if null matching_givens && isSingleton matches && null unifiers then + -- Intuitively, some given matched the wanted in their + -- flattened or rewritten (from given equalities) form + -- but the matcher can't figure that out because the + -- constraints are non-flat and non-rewritten so we + -- simply report back the whole given + -- context. Accelerate Smart.hs showed this problem. + sep [ ptext (sLit "There exists a (perhaps superclass) match") <> colon + , nest 2 (vcat (pp_givens givens))] else empty , if not (isSingleton matches) then -- Two or more matches empty - else -- One match, plus some unifiers - ASSERT( not (null unifiers) ) + else -- One match parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+> quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))), - if null (overlapping_givens) then + if null (matching_givens) then vcat [ ptext (sLit "To pick the first instance above, use -XIncoherentInstances"), ptext (sLit "when compiling the other instance declarations")] else empty])] @@ -597,15 +597,8 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys) ispecs = [ispec | (ispec, _) <- matches] givens = getUserGivens ctxt - overlapping_givens = unifiable_givens givens - - unifiable_givens [] = [] - unifiable_givens (gg:ggs) - | Just ggdoc <- matchable gg - = ggdoc : unifiable_givens ggs - | otherwise - = unifiable_givens ggs - + matching_givens = mapCatMaybes matchable givens + matchable (evvars,gloc) = case ev_vars_matching of [] -> Nothing @@ -818,7 +811,7 @@ find_thing _ _ thing = pprPanic "find_thing" (ppr thing) warnDefaulting :: [FlavoredEvVar] -> Type -> TcM () warnDefaulting wanteds default_ty - = do { warn_default <- doptM Opt_WarnTypeDefaults + = do { warn_default <- woptM Opt_WarnTypeDefaults ; env0 <- tcInitTidyEnv ; let wanted_bag = listToBag wanteds tidy_env = tidyFreeTyVars env0 $ diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index ee6a34ac06..29a4756171 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -1050,22 +1050,6 @@ Here's a concrete example that does this (test tc200): Current solution: only do the "method sharing" thing for the first type/dict application, not for the iterated ones. A horribly subtle point. -Note [No method sharing] -~~~~~~~~~~~~~~~~~~~~~~~~ -The -fno-method-sharing flag controls what happens so far as the LIE -is concerned. The default case is that for an overloaded function we -generate a "method" Id, and add the Method Inst to the LIE. So you get -something like - f :: Num a => a -> a - f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x -If you specify -fno-method-sharing, the dictionary application -isn't shared, so we get - f :: Num a => a -> a - f = /\a (d:Num a) (x:a) -> (+) a d x x -This gets a bit less sharing, but - a) it's better for RULEs involving overloaded functions - b) perhaps fewer separated lambdas - \begin{code} doStupidChecks :: TcId -> [TcType] @@ -1337,7 +1321,7 @@ checkMissingFields data_con rbinds unless (null missing_s_fields) (addErrTc (missingStrictFields data_con missing_s_fields)) - warn <- doptM Opt_WarnMissingFields + warn <- woptM Opt_WarnMissingFields unless (not (warn && notNull missing_ns_fields)) (warnTc True (missingFields data_con missing_ns_fields)) diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index a24eb47b9d..ba3feef2f0 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -88,15 +88,14 @@ tcFImport d = pprPanic "tcFImport" (ppr d) \begin{code} tcCheckFIType :: Type -> [Type] -> Type -> ForeignImport -> TcM ForeignImport -tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ (CLabel _)) +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ (CLabel _)) = ASSERT( null arg_tys ) do { checkCg checkCOrAsmOrLlvmOrInterp - ; checkSafety safety ; check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty) ; return idecl } -- NB check res_ty not sig_ty! -- In case sig_ty is (forall a. ForeignPtr a) -tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ CWrapper) = do +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ CWrapper) = do -- Foreign wrapper (former f.e.d.) -- The type must be of the form ft -> IO (FunPtr ft), where ft is a -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well @@ -104,7 +103,6 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ CWrapper) = do -- is DEPRECATED, though. checkCg checkCOrAsmOrLlvmOrInterp checkCConv cconv - checkSafety safety case arg_tys of [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys checkForeignRes nonIOok False isFFIExportResultTy res1_ty @@ -118,7 +116,6 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar | isDynamicTarget target = do -- Foreign import dynamic checkCg checkCOrAsmOrLlvmOrInterp checkCConv cconv - checkSafety safety case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr [] -> do check False (illegalForeignTyErr empty sig_ty) @@ -149,7 +146,6 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar | otherwise = do -- Normal foreign import checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp) checkCConv cconv - checkSafety safety checkCTarget target dflags <- getDOpts checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys @@ -173,7 +169,7 @@ checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget" checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM () checkMissingAmpersand dflags arg_tys res_ty | null arg_tys && isFunPtrTy res_ty && - dopt Opt_WarnDodgyForeignImports dflags + wopt Opt_WarnDodgyForeignImports dflags = addWarn (ptext (sLit "possible missing & in foreign import of FunPtr")) | otherwise = return () @@ -323,14 +319,6 @@ checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only checkCConv CmmCallConv = panic "checkCConv CmmCallConv" \end{code} -Deprecated "threadsafe" calls - -\begin{code} -checkSafety :: Safety -> TcM () -checkSafety (PlaySafe True) = addWarn (text "The `threadsafe' foreign import style is deprecated. Use `safe' instead.") -checkSafety _ = return () -\end{code} - Warnings \begin{code} diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index e4129103fe..4ab3523b3f 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -52,13 +52,19 @@ import TysWiredIn import Type import TypeRep import VarSet +import Module import State import Util import MonadUtils import Outputable import FastString import Bag -import Data.List ( partition, intersperse ) +import Binary hiding (get,put) +import Fingerprint +import Constants + +import System.IO.Unsafe ( unsafePerformIO ) +import Data.List ( partition, intersperse ) \end{code} \begin{code} @@ -1161,8 +1167,9 @@ From the data type we generate - instance Typeable2 T where - typeOf2 _ = mkTyConApp (mkTyConRep "T") [] + instance Typeable2 T where + typeOf2 _ = mkTyConApp (mkTyCon <hash-high> <hash-low> + <pkg> <module> "T") [] We are passed the Typeable2 class as well as T @@ -1173,13 +1180,37 @@ gen_Typeable_binds loc tycon mk_easy_FunBind loc (mk_typeOf_RDR tycon) -- Name of appropriate type0f function [nlWildPat] - (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []]) + (nlHsApps mkTyConApp_RDR [tycon_rep, nlList []]) where - tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon))) + tycon_name = tyConName tycon + modl = nameModule tycon_name + pkg = modulePackageId modl + + modl_fs = moduleNameFS (moduleName modl) + pkg_fs = packageIdFS pkg + name_fs = occNameFS (nameOccName tycon_name) + + tycon_rep = nlHsApps mkTyCon_RDR + (map nlHsLit [int64 high, + int64 low, + HsString pkg_fs, + HsString modl_fs, + HsString name_fs]) + + Fingerprint high low = unsafePerformIO $ -- ugh + computeFingerprint (error "gen_typeable_binds") + (unpackFS pkg_fs ++ + unpackFS modl_fs ++ + unpackFS name_fs) + + int64 + | wORD_SIZE == 4 = HsWord64Prim . fromIntegral + | otherwise = HsWordPrim . fromIntegral + mk_typeOf_RDR :: TyCon -> RdrName -- Use the arity of the TyCon to make the right typeOfn function -mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix)) +mk_typeOf_RDR tycon = varQual_RDR tYPEABLE_INTERNAL (mkFastString ("typeOf" ++ suffix)) where arity = tyConArity tycon suffix | arity == 0 = "" diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 3b4afaea48..5887fb57e2 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -44,7 +44,7 @@ import NameSet import Var import VarSet import VarEnv -import DynFlags( DynFlag(..) ) +import DynFlags import Literal import BasicTypes import Maybes @@ -107,6 +107,8 @@ hsLitType (HsStringPrim _) = addrPrimTy hsLitType (HsInt _) = intTy hsLitType (HsIntPrim _) = intPrimTy hsLitType (HsWordPrim _) = wordPrimTy +hsLitType (HsInt64Prim _) = int64PrimTy +hsLitType (HsWord64Prim _) = word64PrimTy hsLitType (HsInteger _ ty) = ty hsLitType (HsRat _ ty) = ty hsLitType (HsFloatPrim _) = floatPrimTy @@ -284,7 +286,7 @@ zonkTopDecls ev_binds binds sig_ns rules vects imp_specs fords -- Warn about missing signatures -- Do this only when we we have a type to offer - ; warn_missing_sigs <- doptM Opt_WarnMissingSigs + ; warn_missing_sigs <- woptM Opt_WarnMissingSigs ; let sig_warn | warn_missing_sigs = topSigWarn sig_ns | otherwise = noSigWarn @@ -305,7 +307,7 @@ zonkLocalBinds _ (HsValBinds (ValBindsIn {})) = panic "zonkLocalBinds" -- Not in typechecker output zonkLocalBinds env (HsValBinds vb@(ValBindsOut binds sigs)) - = do { warn_missing_sigs <- doptM Opt_WarnMissingLocalSigs + = do { warn_missing_sigs <- woptM Opt_WarnMissingLocalSigs ; let sig_warn | not warn_missing_sigs = noSigWarn | otherwise = localSigWarn sig_ns sig_ns = getTypeSigNames vb diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 528bb0e4ec..b28c8a5345 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -33,8 +33,9 @@ import TyCon import DataCon import Class import Var +import VarEnv( mkInScopeSet ) +import VarSet( mkVarSet ) import Pair ---import VarSet import CoreUtils ( mkPiTypes ) import CoreUnfold ( mkDFunUnfolding ) import CoreSyn ( Expr(Var), CoreExpr, varToCoreExpr ) @@ -473,7 +474,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) ; let class_ats = map tyConName (classATs clas) defined_ats = listToNameSet . map (tcdName.unLoc.fst) $ ats omitted = filterOut (`elemNameSet` defined_ats) class_ats - ; warn <- doptM Opt_WarnMissingMethods + ; warn <- woptM Opt_WarnMissingMethods ; mapM_ (warnTc warn . omittedATWarn) omitted -- Ensure that all AT indexes that correspond to class parameters @@ -1186,7 +1187,8 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys rep_pred = mkClassPred clas (init_inst_tys ++ [rep_ty]) -- co : [p] ~ T p - co = substCoWithTys inst_tvs (mkTyVarTys tyvars) $ + co = substCoWithTys (mkInScopeSet (mkVarSet tyvars)) + inst_tvs (mkTyVarTys tyvars) $ mkSymCo coi ---------------- @@ -1250,7 +1252,7 @@ derivBindCtxt sel_id clas tys _bind warnMissingMethod :: Id -> TcM () warnMissingMethod sel_id - = do { warn <- doptM Opt_WarnMissingMethods + = do { warn <- woptM Opt_WarnMissingMethods ; warnTc (warn -- Warn only if -fwarn-missing-methods && not (startsWithUnderscore (getOccName sel_id))) -- Don't warn about _foo methods diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index bd5cf8d0f5..2b78ab3f79 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -248,21 +248,30 @@ xoptM flag = do { dflags <- getDOpts; return (xopt flag dflags) } doptM :: DynFlag -> TcRnIf gbl lcl Bool doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) } --- XXX setOptM and unsetOptM operate on different types. One should be renamed. +woptM :: WarningFlag -> TcRnIf gbl lcl Bool +woptM flag = do { dflags <- getDOpts; return (wopt flag dflags) } -setOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -setOptM flag = updEnv (\ env@(Env { env_top = top }) -> - env { env_top = top { hsc_dflags = xopt_set (hsc_dflags top) flag}} ) +setXOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +setXOptM flag = updEnv (\ env@(Env { env_top = top }) -> + env { env_top = top { hsc_dflags = xopt_set (hsc_dflags top) flag}} ) -unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -unsetOptM flag = updEnv (\ env@(Env { env_top = top }) -> - env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} ) +unsetDOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +unsetDOptM flag = updEnv (\ env@(Env { env_top = top }) -> + env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} ) + +unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +unsetWOptM flag = updEnv (\ env@(Env { env_top = top }) -> + env { env_top = top { hsc_dflags = wopt_unset (hsc_dflags top) flag}} ) -- | 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 () } +ifWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +ifWOptM flag thing_inside = do { b <- woptM flag; + if b then thing_inside else return () } + ifXOptM :: ExtensionFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () ifXOptM flag thing_inside = do { b <- xoptM flag; if b then thing_inside else return () } diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs index 8f8ff3bd5a..6489a2fdac 100644 --- a/compiler/types/Class.lhs +++ b/compiler/types/Class.lhs @@ -33,6 +33,7 @@ import Util import Outputable import FastString +import Data.Typeable hiding (TyCon) import qualified Data.Data as Data \end{code} @@ -69,6 +70,7 @@ data Class classTyCon :: TyCon -- The data type constructor for -- dictionaries of this class } + deriving Typeable type FunDep a = ([a],[a]) -- e.g. class C a b c | a b -> c, a c -> b where... -- Here fun-deps are [([a,b],[c]), ([a,c],[b])] @@ -214,9 +216,6 @@ pprFundeps fds = hsep (ptext (sLit "|") : punctuate comma (map pprFunDep fds)) pprFunDep :: Outputable a => FunDep a -> SDoc pprFunDep (us, vs) = hsep [interppSP us, ptext (sLit "->"), interppSP vs] -instance Data.Typeable Class where - typeOf _ = Data.mkTyConApp (Data.mkTyCon "Class") [] - instance Data.Data Class where -- don't traverse? toConstr _ = abstractConstr "Class" diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index 7df5b8e38f..a462cc0d35 100644 --- a/compiler/types/Coercion.lhs +++ b/compiler/types/Coercion.lhs @@ -593,11 +593,9 @@ mkNthCo :: Int -> Coercion -> Coercion mkNthCo n (Refl ty) = Refl (getNth n ty) mkNthCo n co = NthCo n co --- | Instantiates a 'Coercion' with a 'Type' argument. If possible, it immediately performs --- the resulting beta-reduction, otherwise it creates a suspended instantiation. +-- | Instantiates a 'Coercion' with a 'Type' argument. mkInstCo :: Coercion -> Type -> Coercion -mkInstCo (ForAllCo tv co) ty = substCoWithTy tv ty co -mkInstCo co ty = InstCo co ty +mkInstCo co ty = InstCo co ty -- | Manufacture a coercion from thin air. Needless to say, this is -- not usually safe, but it is used when we know we are dealing with @@ -817,18 +815,16 @@ zipOpenCvSubst vs cos mkTopCvSubst :: [(Var,Coercion)] -> CvSubst mkTopCvSubst prs = CvSubst emptyInScopeSet emptyTvSubstEnv (mkVarEnv prs) -substCoWithTy :: TyVar -> Type -> Coercion -> Coercion -substCoWithTy tv ty = substCoWithTys [tv] [ty] +substCoWithTy :: InScopeSet -> TyVar -> Type -> Coercion -> Coercion +substCoWithTy in_scope tv ty = substCoWithTys in_scope [tv] [ty] -substCoWithTys :: [TyVar] -> [Type] -> Coercion -> Coercion -substCoWithTys tvs tys co +substCoWithTys :: InScopeSet -> [TyVar] -> [Type] -> Coercion -> Coercion +substCoWithTys in_scope tvs tys co | debugIsOn && (length tvs /= length tys) = pprTrace "substCoWithTys" (ppr tvs $$ ppr tys) co | otherwise = ASSERT( length tvs == length tys ) substCo (CvSubst in_scope (zipVarEnv tvs tys) emptyVarEnv) co - where - in_scope = mkInScopeSet (tyVarsOfTypes tys) -- | Substitute within a 'Coercion' substCo :: CvSubst -> Coercion -> Coercion @@ -870,7 +866,7 @@ substCoVar :: CvSubst -> CoVar -> Coercion substCoVar (CvSubst in_scope _ cenv) cv | Just co <- lookupVarEnv cenv cv = co | Just cv1 <- lookupInScope in_scope cv = ASSERT( isCoVar cv1 ) CoVarCo cv1 - | otherwise = WARN( True, ptext (sLit "substCoVar not in scope") <+> ppr cv ) + | otherwise = WARN( True, ptext (sLit "substCoVar not in scope") <+> ppr cv $$ ppr in_scope) ASSERT( isCoVar cv ) CoVarCo cv substCoVars :: CvSubst -> [CoVar] -> [Coercion] diff --git a/compiler/types/OptCoercion.lhs b/compiler/types/OptCoercion.lhs index eef1ccf672..d6784b9020 100644 --- a/compiler/types/OptCoercion.lhs +++ b/compiler/types/OptCoercion.lhs @@ -127,11 +127,12 @@ opt_co' env sym (UnsafeCo ty1 ty2) ty2' = substTy env ty2 opt_co' env sym (TransCo co1 co2) - | sym = opt_trans opt_co2 opt_co1 -- sym (g `o` h) = sym h `o` sym g - | otherwise = opt_trans opt_co1 opt_co2 + | sym = opt_trans in_scope opt_co2 opt_co1 -- sym (g `o` h) = sym h `o` sym g + | otherwise = opt_trans in_scope opt_co1 opt_co2 where opt_co1 = opt_co env sym co1 opt_co2 = opt_co env sym co2 + in_scope = getCvInScope env opt_co' env sym (NthCo n co) | TyConAppCo tc cos <- co' @@ -149,9 +150,10 @@ opt_co' env sym (InstCo co ty) | Just (tv, co_body) <- splitForAllCo_maybe co = opt_co (extendTvSubst env tv ty') sym co_body - -- See if it is a forall after optimization + -- See if it is a forall after optimization + -- If so, do an inefficient one-variable substitution | Just (tv, co'_body) <- splitForAllCo_maybe co' - = substCoWithTy tv ty' co'_body -- An inefficient one-variable substitution + = substCoWithTy (getCvInScope env) tv ty' co'_body | otherwise = InstCo co' ty' @@ -160,111 +162,111 @@ opt_co' env sym (InstCo co ty) ty' = substTy env ty ------------- -opt_transList :: [NormalCo] -> [NormalCo] -> [NormalCo] -opt_transList = zipWith opt_trans +opt_transList :: InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo] +opt_transList is = zipWith (opt_trans is) -opt_trans :: NormalCo -> NormalCo -> NormalCo -opt_trans co1 co2 +opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo +opt_trans is co1 co2 | isReflCo co1 = co2 - | otherwise = opt_trans1 co1 co2 + | otherwise = opt_trans1 is co1 co2 -opt_trans1 :: NormalNonIdCo -> NormalCo -> NormalCo +opt_trans1 :: InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo -- First arg is not the identity -opt_trans1 co1 co2 +opt_trans1 is co1 co2 | isReflCo co2 = co1 - | otherwise = opt_trans2 co1 co2 + | otherwise = opt_trans2 is co1 co2 -opt_trans2 :: NormalNonIdCo -> NormalNonIdCo -> NormalCo +opt_trans2 :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo -- Neither arg is the identity -opt_trans2 (TransCo co1a co1b) co2 +opt_trans2 is (TransCo co1a co1b) co2 -- Don't know whether the sub-coercions are the identity - = opt_trans co1a (opt_trans co1b co2) + = opt_trans is co1a (opt_trans is co1b co2) -opt_trans2 co1 co2 - | Just co <- opt_trans_rule co1 co2 +opt_trans2 is co1 co2 + | Just co <- opt_trans_rule is co1 co2 = co -opt_trans2 co1 (TransCo co2a co2b) - | Just co1_2a <- opt_trans_rule co1 co2a +opt_trans2 is co1 (TransCo co2a co2b) + | Just co1_2a <- opt_trans_rule is co1 co2a = if isReflCo co1_2a then co2b - else opt_trans1 co1_2a co2b + else opt_trans1 is co1_2a co2b -opt_trans2 co1 co2 +opt_trans2 _ co1 co2 = mkTransCo co1 co2 ------ -- Optimize coercions with a top-level use of transitivity. -opt_trans_rule :: NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo +opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo -- push transitivity down through matching top-level constructors. -opt_trans_rule in_co1@(TyConAppCo tc1 cos1) in_co2@(TyConAppCo tc2 cos2) +opt_trans_rule is in_co1@(TyConAppCo tc1 cos1) in_co2@(TyConAppCo tc2 cos2) | tc1 == tc2 = fireTransRule "PushTyConApp" in_co1 in_co2 $ - TyConAppCo tc1 (opt_transList cos1 cos2) + TyConAppCo tc1 (opt_transList is cos1 cos2) -- push transitivity through matching destructors -opt_trans_rule in_co1@(NthCo d1 co1) in_co2@(NthCo d2 co2) +opt_trans_rule is in_co1@(NthCo d1 co1) in_co2@(NthCo d2 co2) | d1 == d2 , co1 `compatible_co` co2 = fireTransRule "PushNth" in_co1 in_co2 $ - mkNthCo d1 (opt_trans co1 co2) + mkNthCo d1 (opt_trans is co1 co2) -- Push transitivity inside instantiation -opt_trans_rule in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2) +opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2) | ty1 `eqType` ty2 , co1 `compatible_co` co2 = fireTransRule "TrPushInst" in_co1 in_co2 $ - mkInstCo (opt_trans co1 co2) ty1 + mkInstCo (opt_trans is co1 co2) ty1 -- Push transitivity inside apply -opt_trans_rule in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b) +opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b) = fireTransRule "TrPushApp" in_co1 in_co2 $ - mkAppCo (opt_trans co1a co2a) (opt_trans co1b co2b) + mkAppCo (opt_trans is co1a co2a) (opt_trans is co1b co2b) -opt_trans_rule co1@(TyConAppCo tc cos1) co2 +opt_trans_rule is co1@(TyConAppCo tc cos1) co2 | Just cos2 <- etaTyConAppCo_maybe tc co2 = ASSERT( length cos1 == length cos2 ) fireTransRule "EtaCompL" co1 co2 $ - TyConAppCo tc (zipWith opt_trans cos1 cos2) + TyConAppCo tc (opt_transList is cos1 cos2) -opt_trans_rule co1 co2@(TyConAppCo tc cos2) +opt_trans_rule is co1 co2@(TyConAppCo tc cos2) | Just cos1 <- etaTyConAppCo_maybe tc co1 = ASSERT( length cos1 == length cos2 ) fireTransRule "EtaCompR" co1 co2 $ - TyConAppCo tc (zipWith opt_trans cos1 cos2) + TyConAppCo tc (opt_transList is cos1 cos2) -- Push transitivity inside forall -opt_trans_rule co1 co2 +opt_trans_rule is co1 co2 | Just (tv1,r1) <- splitForAllCo_maybe co1 , Just (tv2,r2) <- etaForAllCo_maybe co2 - , let r2' = substCoWithTy tv2 (mkTyVarTy tv1) r2 + , let r2' = substCoWithTy is tv2 (mkTyVarTy tv1) r2 = fireTransRule "EtaAllL" co1 co2 $ - mkForAllCo tv1 (opt_trans2 r1 r2') + mkForAllCo tv1 (opt_trans2 (extendInScopeSet is tv1) r1 r2') | Just (tv2,r2) <- splitForAllCo_maybe co2 , Just (tv1,r1) <- etaForAllCo_maybe co1 - , let r1' = substCoWithTy tv1 (mkTyVarTy tv2) r1 + , let r1' = substCoWithTy is tv1 (mkTyVarTy tv2) r1 = fireTransRule "EtaAllR" co1 co2 $ - mkForAllCo tv1 (opt_trans2 r1' r2) + mkForAllCo tv1 (opt_trans2 (extendInScopeSet is tv2) r1' r2) -- Push transitivity inside axioms -opt_trans_rule co1 co2 +opt_trans_rule is co1 co2 -- TrPushAxR/TrPushSymAxR | Just (sym, con, cos1) <- co1_is_axiom_maybe , Just cos2 <- matchAxiom sym con co2 = fireTransRule "TrPushAxR" co1 co2 $ if sym - then SymCo $ AxiomInstCo con (opt_transList (map mkSymCo cos2) cos1) - else AxiomInstCo con (opt_transList cos1 cos2) + then SymCo $ AxiomInstCo con (opt_transList is (map mkSymCo cos2) cos1) + else AxiomInstCo con (opt_transList is cos1 cos2) -- TrPushAxL/TrPushSymAxL | Just (sym, con, cos2) <- co2_is_axiom_maybe , Just cos1 <- matchAxiom (not sym) con co1 = fireTransRule "TrPushAxL" co1 co2 $ if sym - then SymCo $ AxiomInstCo con (opt_transList cos2 (map mkSymCo cos1)) - else AxiomInstCo con (opt_transList cos1 cos2) + then SymCo $ AxiomInstCo con (opt_transList is cos2 (map mkSymCo cos1)) + else AxiomInstCo con (opt_transList is cos1 cos2) -- TrPushAxSym/TrPushSymAx | Just (sym1, con1, cos1) <- co1_is_axiom_maybe @@ -278,20 +280,20 @@ opt_trans_rule co1 co2 , all (`elemVarSet` pivot_tvs) qtvs = fireTransRule "TrPushAxSym" co1 co2 $ if sym2 - then liftCoSubstWith qtvs (opt_transList cos1 (map mkSymCo cos2)) lhs -- TrPushAxSym - else liftCoSubstWith qtvs (opt_transList (map mkSymCo cos1) cos2) rhs -- TrPushSymAx + then liftCoSubstWith qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs -- TrPushAxSym + else liftCoSubstWith qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs -- TrPushSymAx where co1_is_axiom_maybe = isAxiom_maybe co1 co2_is_axiom_maybe = isAxiom_maybe co2 -opt_trans_rule co1 co2 -- Identity rule +opt_trans_rule _ co1 co2 -- Identity rule | Pair ty1 _ <- coercionKind co1 , Pair _ ty2 <- coercionKind co2 , ty1 `eqType` ty2 = fireTransRule "RedTypeDirRefl" co1 co2 $ Refl ty2 -opt_trans_rule _ _ = Nothing +opt_trans_rule _ _ _ = Nothing fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion fireTransRule _rule _co1 _co2 res diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 915207621f..895dd3a7f3 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -96,6 +96,7 @@ import FastString import Constants import Util import qualified Data.Data as Data +import Data.Typeable hiding (TyCon) \end{code} ----------------------------------------------- @@ -416,6 +417,7 @@ data TyCon tyConUnique :: Unique, tyConName :: Name } + deriving Typeable -- | Names of the fields in an algebraic record type type FieldLabel = Name @@ -685,6 +687,7 @@ data CoAxiom , co_ax_lhs :: Type -- left-hand side of the equality , co_ax_rhs :: Type -- right-hand side of the equality } + deriving Typeable coAxiomArity :: CoAxiom -> Arity coAxiomArity ax = length (co_ax_tvs ax) @@ -1380,9 +1383,6 @@ instance Outputable TyCon where instance NamedThing TyCon where getName = tyConName -instance Data.Typeable TyCon where - typeOf _ = Data.mkTyConApp (Data.mkTyCon "TyCon") [] - instance Data.Data TyCon where -- don't traverse? toConstr _ = abstractConstr "TyCon" @@ -1410,9 +1410,6 @@ instance Outputable CoAxiom where instance NamedThing CoAxiom where getName = co_ax_name -instance Data.Typeable CoAxiom where - typeOf _ = Data.mkTyConApp (Data.mkTyCon "CoAxiom") [] - instance Data.Data CoAxiom where -- don't traverse? toConstr _ = abstractConstr "CoAxiom" diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index c5a2c8f4fd..b61b2838ee 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -30,7 +30,9 @@ module Binary writeBinMem, readBinMem, + fingerprintBinMem, + computeFingerprint, isEOFBin, @@ -74,6 +76,9 @@ import Data.Array import Data.IORef import Data.Char ( ord, chr ) import Data.Typeable +#if __GLASGOW_HASKELL__ >= 701 +import Data.Typeable.Internal +#endif import Control.Monad ( when ) import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) @@ -237,6 +242,18 @@ fingerprintBinMem (BinMem _ ix_r _ arr_r) = do ix <- readFastMutInt ix_r withForeignPtr arr $ \p -> fingerprintData p ix +computeFingerprint :: Binary a + => (BinHandle -> Name -> IO ()) + -> a + -> IO Fingerprint + +computeFingerprint put_name a = do + bh <- openBinMem (3*1024) -- just less than a block + ud <- newWriteState put_name putFS + bh <- return $ setUserData bh ud + put_ bh a + fingerprintBinMem bh + -- expand the size of the array to include a specified offset expandBin :: BinHandle -> Int -> IO () expandBin (BinMem _ _ sz_r arr_r) off = do @@ -562,6 +579,14 @@ instance Binary (Bin a) where -- ----------------------------------------------------------------------------- -- Instances for Data.Typeable stuff +#if __GLASGOW_HASKELL__ >= 701 +instance Binary TyCon where + put_ bh (TyCon _ p m n) = do + put_ bh (p,m,n) + get bh = do + (p,m,n) <- get bh + return (mkTyCon3 p m n) +#else instance Binary TyCon where put_ bh ty_con = do let s = tyConString ty_con @@ -569,6 +594,7 @@ instance Binary TyCon where get bh = do s <- get bh return (mkTyCon s) +#endif instance Binary TypeRep where put_ bh type_rep = do diff --git a/compiler/utils/Digraph.lhs b/compiler/utils/Digraph.lhs index a341bdecbc..ec65cded94 100644 --- a/compiler/utils/Digraph.lhs +++ b/compiler/utils/Digraph.lhs @@ -164,6 +164,9 @@ flattenSCC (CyclicSCC vs) = vs instance Outputable a => Outputable (SCC a) where ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v)) ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs))) +instance PlatformOutputable a => PlatformOutputable (SCC a) where + pprPlatform platform (AcyclicSCC v) = text "NONREC" $$ (nest 3 (pprPlatform platform v)) + pprPlatform platform (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map (pprPlatform platform) vs))) \end{code} %************************************************************************ diff --git a/compiler/utils/Fingerprint.hsc b/compiler/utils/Fingerprint.hsc index 20b3ee9da4..8c487f665e 100644 --- a/compiler/utils/Fingerprint.hsc +++ b/compiler/utils/Fingerprint.hsc @@ -19,11 +19,18 @@ module Fingerprint ( import Outputable -import Foreign -import Foreign.C import Text.Printf import Numeric ( readHex ) +##if __GLASGOW_HASKELL__ >= 701 +-- The MD5 implementation is now in base, to support Typeable +import GHC.Fingerprint +##endif + +##if __GLASGOW_HASKELL__ < 701 +import Foreign +import Foreign.C + -- Using 128-bit MD5 fingerprints for now. data Fingerprint = Fingerprint {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 @@ -33,19 +40,6 @@ data Fingerprint = Fingerprint {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 fingerprint0 :: Fingerprint fingerprint0 = Fingerprint 0 0 -instance Outputable Fingerprint where - ppr (Fingerprint w1 w2) = text (printf "%016x%016x" i1 i2) - where i1 = fromIntegral w1 :: Integer - i2 = fromIntegral w2 :: Integer - -- printf in GHC 6.4.2 didn't have Word64 instances - --- useful for parsing the output of 'md5sum', should we want to do that. -readHexFingerprint :: String -> Fingerprint -readHexFingerprint s = Fingerprint w1 w2 - where (s1,s2) = splitAt 16 s - [(w1,"")] = readHex s1 - [(w2,"")] = readHex (take 16 s2) - peekFingerprint :: Ptr Word8 -> IO Fingerprint peekFingerprint p = do let peekW64 :: Ptr Word8 -> Int -> Word64 -> IO Word64 @@ -77,3 +71,18 @@ foreign import ccall unsafe "MD5Update" c_MD5Update :: Ptr MD5Context -> Ptr Word8 -> CInt -> IO () foreign import ccall unsafe "MD5Final" c_MD5Final :: Ptr Word8 -> Ptr MD5Context -> IO () +##endif + +instance Outputable Fingerprint where + ppr (Fingerprint w1 w2) = text (printf "%016x%016x" i1 i2) + where i1 = fromIntegral w1 :: Integer + i2 = fromIntegral w2 :: Integer + -- printf in GHC 6.4.2 didn't have Word64 instances + +-- useful for parsing the output of 'md5sum', should we want to do that. +readHexFingerprint :: String -> Fingerprint +readHexFingerprint s = Fingerprint w1 w2 + where (s1,s2) = splitAt 16 s + [(w1,"")] = readHex s1 + [(w2,"")] = readHex (take 16 s2) + diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index 8a0c62a2ed..7f8a3a67ff 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -13,6 +13,7 @@ module Outputable ( -- * Type classes Outputable(..), OutputableBndr(..), + PlatformOutputable(..), -- * Pretty printing combinators SDoc, runSDoc, initSDocContext, @@ -74,6 +75,7 @@ import {-# SOURCE #-} OccName( OccName ) import StaticFlags import FastString import FastTypes +import Platform import qualified Pretty import Pretty ( Doc, Mode(..) ) import Panic @@ -600,6 +602,13 @@ class Outputable a where ppr = pprPrec 0 pprPrec _ = ppr + +class PlatformOutputable a where + pprPlatform :: Platform -> a -> SDoc + pprPlatformPrec :: Platform -> Rational -> a -> SDoc + + pprPlatform platform = pprPlatformPrec platform 0 + pprPlatformPrec platform _ = pprPlatform platform \end{code} \begin{code} @@ -621,12 +630,19 @@ instance Outputable Word where instance Outputable () where ppr _ = text "()" +instance PlatformOutputable () where + pprPlatform _ _ = text "()" instance (Outputable a) => Outputable [a] where ppr xs = brackets (fsep (punctuate comma (map ppr xs))) +instance (PlatformOutputable a) => PlatformOutputable [a] where + pprPlatform platform xs = brackets (fsep (punctuate comma (map (pprPlatform platform) xs))) instance (Outputable a, Outputable b) => Outputable (a, b) where ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) +instance (PlatformOutputable a, PlatformOutputable b) => PlatformOutputable (a, b) where + pprPlatform platform (x,y) + = parens (sep [pprPlatform platform x <> comma, pprPlatform platform y]) instance Outputable a => Outputable (Maybe a) where ppr Nothing = ptext (sLit "Nothing") @@ -687,6 +703,8 @@ instance Outputable FastString where instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where ppr m = ppr (M.toList m) +instance (PlatformOutputable key, PlatformOutputable elt) => PlatformOutputable (M.Map key elt) where + pprPlatform platform m = pprPlatform platform (M.toList m) instance (Outputable elt) => Outputable (IM.IntMap elt) where ppr m = ppr (IM.toList m) \end{code} diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs index d430df695e..1fd815604c 100644 --- a/compiler/utils/Panic.lhs +++ b/compiler/utils/Panic.lhs @@ -78,7 +78,7 @@ data GhcException -- | An error in the user's code, probably. | ProgramError String - deriving Eq + deriving (Typeable, Eq) instance Exception GhcException @@ -87,9 +87,6 @@ instance Show GhcException where showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcException e showsPrec _ e = showString progName . showString ": " . showGhcException e -instance Typeable GhcException where - typeOf _ = mkTyConApp ghcExceptionTc [] - -- | The name of this GHC. progName :: String @@ -154,11 +151,6 @@ handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a handleGhcException = ghandle -ghcExceptionTc :: TyCon -ghcExceptionTc = mkTyCon "GhcException" -{-# NOINLINE ghcExceptionTc #-} - - -- | Panics and asserts. panic, sorry, pgmError :: String -> a panic x = throwGhcException (Panic x) diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs index 9c9fdc9bc4..7cbc3dbcfb 100644 --- a/compiler/utils/UniqFM.lhs +++ b/compiler/utils/UniqFM.lhs @@ -67,6 +67,8 @@ import Compiler.Hoopl hiding (Unique) import Data.Function (on) import qualified Data.IntMap as M import qualified Data.Foldable as Foldable +import Data.Typeable +import Data.Data \end{code} %************************************************************************ @@ -164,6 +166,7 @@ ufmToList :: UniqFM elt -> [(Unique, elt)] \begin{code} newtype UniqFM ele = UFM { unUFM :: M.IntMap ele } + deriving (Typeable,Data) instance Eq ele => Eq (UniqFM ele) where (==) = (==) `on` unUFM diff --git a/compiler/utils/md5.c b/compiler/utils/md5.c index 0570cbbdf1..06c2d37738 100644 --- a/compiler/utils/md5.c +++ b/compiler/utils/md5.c @@ -15,6 +15,8 @@ * will fill a supplied 16-byte array with the digest. */ +#if __GLASGOW_HASKELL__ < 701 + #include "HsFFI.h" #include "md5.h" #include <string.h> @@ -236,3 +238,4 @@ MD5Transform(word32 buf[4], word32 const in[16]) buf[3] += d; } +#endif |