diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2011-07-18 23:11:02 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2011-07-18 23:11:02 +0100 |
| commit | 5c9dfadd979ca3ccb8dd7c21ddb9fb0fe9cdb3fe (patch) | |
| tree | aedac951e211cd35fa93140fbb7640cac555784a | |
| parent | 72883e48d93528acf44e3ba67c66a66833fe61f3 (diff) | |
| parent | 8f4f29f655fdda443861152a24588fcaba29b168 (diff) | |
| download | haskell-5c9dfadd979ca3ccb8dd7c21ddb9fb0fe9cdb3fe.tar.gz | |
Merge branch 'master' of http://darcs.haskell.org/ghc
185 files changed, 4994 insertions, 9709 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 diff --git a/configure.ac b/configure.ac index 277f399b59..2ab11c9914 100644 --- a/configure.ac +++ b/configure.ac @@ -13,7 +13,7 @@ dnl # see what flags are available. (Better yet, read the documentation!) # -AC_INIT([The Glorious Glasgow Haskell Compilation System], [7.1], [glasgow-haskell-bugs@haskell.org], [ghc]) +AC_INIT([The Glorious Glasgow Haskell Compilation System], [7.3], [glasgow-haskell-bugs@haskell.org], [ghc]) # Set this to YES for a released version, otherwise NO : ${RELEASE=NO} diff --git a/distrib/MacOS/mkinstaller b/distrib/MacOS/mkinstaller index feb3db080b..c4f132be02 100755 --- a/distrib/MacOS/mkinstaller +++ b/distrib/MacOS/mkinstaller @@ -14,7 +14,7 @@ fi if [ "$#" -ne 1 ] then - die "Must be given on argument (the bindist)" + die "Must be given one argument (the bindist)" fi BINDIST="$1" diff --git a/docs/users_guide/6.10.1-notes.xml b/docs/users_guide/6.10.1-notes.xml deleted file mode 100644 index bd3656c684..0000000000 --- a/docs/users_guide/6.10.1-notes.xml +++ /dev/null @@ -1,1255 +0,0 @@ -<?xml version="1.0" encoding="iso-8859-1"?> -<sect1 id="release-6-10-1"> - <title>Release notes for version 6.10.1</title> - - <para> - The significant changes to the various parts of the compiler are - listed in the following sections. - </para> - - <sect2> - <title>User-visible compiler changes</title> - <itemizedlist> - <listitem> - <para> - The new QuasiQuotes language extension adds - general quasi-quotation, as described in - "Nice to be Quoted: Quasiquoting for Haskell" - (Geoffrey Mainland, Haskell Workshop 2007). - See <xref linkend="th-quasiquotation" /> for more information. - </para> - </listitem> - <listitem> - <para> - The new ViewPatterns language extension allows - "view patterns". The syntax for view patterns - is <literal>expression -> pattern</literal> in a pattern. - For more information, see <xref linkend="view-patterns" />. - </para> - </listitem> - <listitem> - <para> - GHC already supported (e op) postfix operators, but this - support was enabled by default. Now you need to use the - PostfixOperators language extension if you want it. - See <xref linkend="postfix-operators" /> for more information - on postfix operators. - </para> - </listitem> - <listitem> - <para> - The new TransformListComp language extension enables - implements generalised list comprehensions, as described in - the paper "Comprehensive comprehensions" (Peyton Jones & - Wadler, Haskell Workshop 2007). - For more information see - <xref linkend="generalised-list-comprehensions" />. - </para> - </listitem> - <listitem> - <para> - If you want to use impredicative types then you now need to - enable the ImpredicativeTypes language extension. - See <xref linkend="impredicative-polymorphism" /> for more - information. - </para> - </listitem> - <listitem> - <para> - FFI change: header files are now <emphasis>not - used</emphasis> when compiling via C. - The <option>-#include</option> flag, - the <literal>includes</literal> field - in <literal>.cabal</literal> files, and header files - specified in a <literal>foreign import</literal> - declaration all have no effect when compiling Haskell - source code.</para> - - <para>This change has important ramifications if you are - calling FFI functions that are defined by macros (or renamed - by macros). If you need to call one of these functions, - then write a C wrapper for the function and call the wrapper - using the FFI instead. In this way, your code will work - with GHC 6.10.1, and will also work - with <option>-fasm</option> in older GHCs.</para> - - <para>This change was made for several reasons. - Firstly, <option>-fvia-C</option> now behaves consistently - with <option>-fasm</option>, which is important because we - intend to stop compiling via C in the future. Also, we - don't need to worry about the interactions between header - files, or CPP options necessary to expose certain functions - from the system header files (this was becoming quite a - headache). We don't need to worry about needing header - files when inlining FFI calls across module or package - boundaries; calls can now be inlined freely. One downside - is that you don't get a warning from the C compiler when you - call a function via the FFI at the wrong type. - </para> - - <para>Another consequence of this change is that - calling <emphasis>varargs</emphasis> functions (such - as <literal>printf</literal>) via the FFI no longer works. - It has never been officially supported (the FFI spec outlaws - it), but in GHC 6.10.1 it may now really cause a crash on - certain platforms. Again, to call one of these functions - use appropriate fixed-argument C wrappers.</para> - </listitem> - <listitem> - <para> - There is a new languages extension PackageImports which allows - imports to be qualified with the package they should come - from, e.g. - </para> -<programlisting> -import "network" Network.Socket -</programlisting> - <para> - Note that this feature is not intended for general use, it - was added for constructing backwards-compatibility packages - such as the <literal>base-3.0.3.0</literal> package. See - <xref linkend="package-imports" /> for more details. - </para> - </listitem> - <listitem> - <para> - In earlier versions of GHC, the recompilation checker didn't - notice changes in other packages meant that recompilation is - needed. This is now handled properly, using MD5 checksums of - the interface ABIs. - </para> - </listitem> - <listitem> - <para> - GHC now treats the Unicode "Letter, Other" class as lowercase - letters. This is an arbitrary choice, but better than not - allowing them in identifiers at all. This may be revisited - by Haskell'. - </para> - </listitem> - <listitem> - <para> - In addition to the <literal>DEPRECATED</literal> pragma, you - can now attach arbitrary warnings to declarations with the new - <literal>WARNING</literal> pragma. See - <xref linkend="warning-deprecated-pragma" /> for more details. - </para> - </listitem> - <listitem> - <para> - If GHC is failing due to <literal>-Werror</literal>, then it - now emits a message telling you so. - </para> - </listitem> - <listitem> - <para> - GHC now warns about unrecognised pragmas, as they are often - caused by a typo. The - <literal>-fwarn-unrecognised-pragmas</literal> controls - whether this warning is emitted. - The warning is enabled by default. - </para> - </listitem> - <listitem> - <para> - There is a new flag - <literal>-fwarn-dodgy-foreign-imports</literal> which controls - a new warning about FFI delcarations of the form - </para> -<programlisting> -foreign import "f" f :: FunPtr t -</programlisting> - <para> - on the grounds that it is probably meant to be - </para> -<programlisting> -foreign import "&f" f :: FunPtr t -</programlisting> - <para> - The warning is enabled by default. - </para> - </listitem> - <listitem> - <para> - External core (output only) is working again. - </para> - </listitem> - <listitem> - <para> - There is a new flag <literal>-dsuppress-uniques</literal> that - makes GHC's intermediate core easier to read. This flag cannot - be used when actually generating code. - </para> - </listitem> - <listitem> - <para> - There is a new flag <literal>-dno-debug-output</literal> that - suppresses all of the debug information when running a - compiler built with the <literal>DEBUG</literal> option. - </para> - </listitem> - <listitem> - <para> - A bug in earlier versions of GHC meant that sections didn't - always need to be parenthesised, e.g. - <literal>(+ 1, 2)</literal> was accepted. This has now been - fixed. - </para> - </listitem> - <listitem> - <para> - The <literal>-fspec-threshold</literal> flag has been replaced - by <literal>-fspec-constr-threshold</literal> and - <literal>-fliberate-case-threshold</literal> flags. - The thresholds can be disabled by - <literal>-fno-spec-constr-threshold</literal> and - <literal>-fno-liberate-case-threshold</literal>. - </para> - </listitem> - <listitem> - <para> - The new flag <literal>-fsimplifier-phases</literal> - controls the number of simplifier phases run during - optimisation. These are numbered from n to 1 (by default, n=2). - Phase 0 is always run regardless of this flag. - </para> - </listitem> - <listitem> - <para> - Simplifier phases can have an arbitrary number of tags - assigned to them, and multiple phases can share the same tags. - The tags can be used as arguments to the new flag - <literal>-ddump-simpl-phases</literal> - to specify which phases are to be dumped. - </para> - - <para> - For example, - <literal>-ddump-simpl-phases=main</literal> will dump the - output of phases 2, 1 and 0 of the initial simplifier run - (they all share the "main" tag) while - <literal>-ddump-simpl-phases=main:0</literal> - will dump only the output of phase 0 of that run. - </para> - - <para> - At the moment, the supported tags are - main (the main, staged simplifier run (before strictness)), - post-worker-wrapper (after the w/w split), - post-liberate-case (after LiberateCase), and - final (final clean-up run) - </para> - - <para> - The names are somewhat arbitrary and will change in the future. - </para> - </listitem> - <listitem> - <para> - The <literal>-fno-method-sharing</literal> flag is now - dynamic (it used to be static). - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Deprecated flags</title> - - <itemizedlist> - <listitem> - <para> - The new flag <literal>-fwarn-deprecated-flags</literal>, - controls whether we warn about deprecated flags and language - extensions. The warning is on by default. - </para> - </listitem> - <listitem> - <para> - The following language extensions are now marked as - deprecated; expect them to be removed in a future release: - </para> - <itemizedlist> - <listitem> - <para> - <literal>RecordPuns</literal> - (use <literal>NamedFieldPuns</literal> instead) - </para> - </listitem> - <listitem> - <para> - <literal>PatternSignatures</literal> - (use <literal>ScopedTypeVariables</literal> instead) - </para> - </listitem> - </itemizedlist> - </listitem> - <listitem> - <para> - The following flags are now marked as deprecated; - expect them to be removed in a future release: - </para> - <itemizedlist> - <listitem> - <para> - <literal>-Onot</literal> - (use <literal>-O0</literal> instead) - </para> - </listitem> - <listitem> - <para> - <literal>-Wnot</literal> - (use <literal>-w</literal> instead) - </para> - </listitem> - <listitem> - <para> - <literal>-frewrite-rules</literal> - (use <literal>-fenable-rewrite-rules</literal> instead) - </para> - </listitem> - <listitem> - <para> - <literal>-no-link</literal> - (use <literal>-c</literal> instead) - </para> - </listitem> - <listitem> - <para> - <literal>-recomp</literal> - (use <literal>-fno-force-recomp</literal> instead) - </para> - </listitem> - <listitem> - <para> - <literal>-no-recomp</literal> - (use <literal>-fforce-recomp</literal> instead) - </para> - </listitem> - <listitem> - <para> - <literal>-syslib</literal> - (use <literal>-package</literal> instead) - </para> - </listitem> - <listitem> - <para> - <literal>-fth</literal> - (use the <literal>TemplateHaskell</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-ffi</literal>, <literal>-fffi</literal> - (use the <literal>ForeignFunctionInterface</literal> - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-farrows</literal> - (use the <literal>Arrows</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-fgenerics</literal> - (use the <literal>Generics</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-fno-implicit-prelude</literal> - (use the <literal>NoImplicitPrelude</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-fbang-patterns</literal> - (use the <literal>BangPatterns</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-fno-monomorphism-restriction</literal> - (use the <literal>NoMonomorphismRestriction</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-fmono-pat-binds</literal> - (use the <literal>MonoPatBinds</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-fextended-default-rules</literal> - (use the <literal>ExtendedDefaultRules</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-fimplicit-params</literal> - (use the <literal>ImplicitParams</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-fscoped-type-variables</literal> - (use the <literal>ScopedTypeVariables</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-fparr</literal> - (use the <literal>PArr</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-fallow-overlapping-instances</literal> - (use the <literal>OverlappingInstances</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-fallow-undecidable-instances</literal> - (use the <literal>UndecidableInstances</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-fallow-incoherent-instances</literal> - (use the <literal>IncoherentInstances</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-optdep-s</literal> - (use <literal>-dep-suffix</literal> instead) - </para> - </listitem> - <listitem> - <para> - <literal>-optdep-f</literal> - (use <literal>-dep-makefile</literal> instead) - </para> - </listitem> - <listitem> - <para> - <literal>-optdep-w</literal> - (has no effect) - </para> - </listitem> - <listitem> - <para> - <literal>-optdep--include-prelude</literal> - (use <literal>-include-pkg-deps</literal> instead) - </para> - </listitem> - <listitem> - <para> - <literal>-optdep--include-pkg-deps</literal> - (use <literal>-include-pkg-deps</literal> instead) - </para> - </listitem> - <listitem> - <para> - <literal>-optdep--exclude-module</literal> - (use <literal>-exclude-module</literal> instead) - </para> - </listitem> - <listitem> - <para> - <literal>-optdep-x</literal> - (use <literal>-exclude-module</literal> instead) - </para> - </listitem> - </itemizedlist> - </listitem> - <listitem> - <para> - The following flags have been removed: - </para> - <itemizedlist> - <listitem> - <para> - <literal>-no-link-chk</literal> - (has been a no-op since at least 6.0) - </para> - </listitem> - <listitem> - <para> - <literal>-fruntime-types</literal> - (has not been used for years) - </para> - </listitem> - <listitem> - <para> - <literal>-fhardwire-lib-paths</literal> - (use <literal>-dynload sysdep</literal>) - </para> - </listitem> - </itemizedlist> - </listitem> - <listitem> - <para> - The <literal>-unreg</literal> flag, which was used to build - unregisterised code with a registerised compiler, has been - removed. Now you need to build an unregisterised compiler - if you want to build unregisterised code. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>GHC API changes</title> - - <itemizedlist> - <listitem> - <para> - There is now a Ghc Monad used to carry around GHC's - Session data. This Monad also provides exception handling - functions. - </para> - </listitem> - <listitem> - <para> - It is now possible to get the raw characters corresponding to - each token the lexer outputs, and thus to reconstruct the - original file. - </para> - </listitem> - <listitem> - <para> - GHCi implicitly brings all exposed modules into scope with - qualified module names. There is a new flag - <literal>-fimplicit-import-qualified</literal> - that controls this behaviour, so other GHC API clients can - specify whether or not they want it. - </para> - </listitem> - <listitem> - <para> - There is now haddock documentation for much of the GHC API. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>GHCi changes</title> - - <itemizedlist> - <listitem> - <para> - You can now force GHCi to interpret a module, rather than - loading its compiled code, by prepending a * character to its - name, e.g. - </para> -<programlisting> -Prelude> :load *A -Compiling A ( A.hs, interpreted ) -*A> -</programlisting> - </listitem> - <listitem> - <para> - By default, GHCi will not print bind results, e.g. - </para> -<programlisting> -Prelude> c <- return 'c' -Prelude> -</programlisting> - <para> - does not print <literal>'c'</literal>. Use - <literal>-fprint-bind-result</literal> if you want the old - behaviour. - </para> - </listitem> - <listitem> - <para> - GHCi now uses editline, rather than readline, for input. - This shouldn't affect its behaviour. - </para> - </listitem> - <listitem> - <para> - The GHCi prompt history is now saved in - <literal>~/.ghc/ghci_history</literal>. - </para> - </listitem> - <listitem> - <para> - GHCi now uses libffi to make FFI calls, which means that the - FFI now works in GHCi on a much wider range of platforms - (all those platforms that libffi supports). - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Runtime system changes</title> - - <itemizedlist> - <listitem> - <para> - The garbage collector can now use multiple threads in parallel. - The new <literal>-g<replaceable>n</replaceable></literal> RTS - flag controls it, e.g. run your program with - <literal>+RTS -g2 -RTS</literal> to use 2 threads. - The <option>-g</option> option is implied by the - usual <option>-N</option> option, so normally there will be - no need to specify it separately, although occasionally it - is useful to turn it off with <option>-g1</option>.</para> - <para>Do let us know if you experience strange effects, - especially an increase in GC time when using the parallel GC - (use <option>+RTS -s -RTS</option> to measure GC time). - See <xref linkend="rts-options-gc" /> for more details.</para> - </listitem> - <listitem> - <para> - It is now possible to generate a heap profile without - recompiling your program for profiling. Run the program - with <option>+RTS -hT</option> to generate a basic heap - profile, and use <command>hp2ps</command> as usual to - convert the heap profile into a <literal>.ps</literal> file - for viewing. See <xref linkend="rts-profiling" /> for more - details. - </para> - </listitem> - <listitem> - <para> - If the user presses control-C while running a Haskell program - then the program gets an asynchronous UserInterrupt exception. - </para> - </listitem> - <listitem> - <para> - We now ignore SIGPIPE by default. - </para> - </listitem> - <listitem> - <para> - The <literal>-S</literal> and <literal>-s</literal> RTS flags - now send their output to stderr, rather than - <literal><replaceable>prog</replaceable>.stat</literal>, - by default. - </para> - </listitem> - <listitem> - <para> - The new <literal>-vg</literal> RTS flag provides some RTS trace - messages even in the non-debug RTS variants. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>runghc</title> - - <itemizedlist> - <listitem> - <para> - runghc now uses the compiler that it came with to run the - code, rather than the first compiler that it finds on the - PATH. - </para> - </listitem> - <listitem> - <para> - If the program to run does not have a <literal>.lhs</literal> - extension then runghc now treats it as a <literal>.hs</literal> - file. In particular, this means that programs without an - extension now work. - </para> - </listitem> - <listitem> - <para> - <literal>runghc foo</literal> will now work if - <literal>foo.hs</literal> or <literal>foo.lhs</literal> exists. - </para> - </listitem> - <listitem> - <para> - runghc can now take the code to run from stdin. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>ghc-pkg</title> - - <itemizedlist> - <listitem> - <para>ghc-pkg will refuse to unregister a package on which - other packages depend, unless - the <option>––force</option> option is also - supplied.</para> - </listitem> - <listitem> - <para> - ghc-pkg now has a <literal>-no-user-package-conf</literal> - flag which instructs it to ignore the user's personal - package.conf. - </para> - </listitem> - <listitem> - <para> - ghc-pkg no longer allows you to register two packages that - differ in case only. - </para> - </listitem> - <listitem> - <para> - ghc-pkg no longer allows you to register packages which have - unversioned dependencies. - </para> - </listitem> - <listitem> - <para> - There is a new command <literal>dump</literal> which is - similar to <literal>describe '*'</literal>, but in a format - that is designed to be parsable by other tools. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Haddock</title> - - <itemizedlist> - <listitem> - <para> - Haddock 2 now comes with GHC. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>DPH changes</title> - - <itemizedlist> - <listitem> - <para> - DPH is now an extralib. - </para> - </listitem> - <listitem> - <para> - There is a new flag <literal>-Odph</literal> that sets the - flags recommended when using DPH. Currently it is equivalent - to - <literal> - -O2 -fno-method-sharing -fdicts-cheap - -fmax-simplifier-iterations20 -fno-spec-constr-threshold - </literal> - </para> - </listitem> - <listitem> - <para> - There are now flags <literal>-fdph-seq</literal> and - <literal>-fdph-par</literal> for selecting which DPH backend - to use. - </para> - </listitem> - <listitem> - <para> - The <literal>-fflatten</literal> flag has been removed. It - never worked and has now been superceded by vectorisation. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Boot Libraries</title> - - <sect3> - <title>array</title> - <itemizedlist> - <listitem> - <para> - Version number 0.2.0.0 (was 0.1.0.0) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>base</title> - <itemizedlist> - <listitem> - <para> - Version number 4.0.0.0 (was 3.0.2.0) - </para> - </listitem> - <listitem> - <para> - We also ship a base version 3.0.3.0, so legacy code should - continue to work. - </para> - </listitem> - <listitem> - <para>The <literal>Show</literal> instance - for <literal>Ratio</literal> now puts spaces around - the <literal>%</literal>, as required by Haskell 98.</para> - </listitem> - <listitem> - <para> - There is a new module <literal>Control.Category</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>>>></literal> is no longer a method of the - <literal>Arrow</literal> class; instead - <literal>Category</literal> is a superclass of - <literal>Arrow</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>pure</literal> is no longer a method of the - <literal>Arrow</literal> class; use <literal>arr</literal> - instead. - </para> - </listitem> - <listitem> - <para> - <literal>Control.Exception</literal> now uses extensible - exceptions. The old style of exceptions are still available - in <literal>Control.OldException</literal>, but we expect to - remove them in a future release. - </para> - </listitem> - <listitem> - <para> - There is a new function - <literal>System.Exit.exitSuccess :: IO a</literal> - analogous to the existing - <literal>System.Exit.exitFailure :: IO a</literal>. - </para> - </listitem> - <listitem> - <para> - There are new functions - <literal>Data.Either.lefts :: [Either a b] -> [a]</literal>, - <literal>Data.Either.rights :: [Either a b] -> [b]</literal> - and - <literal> - Data.Either.partitionEithers :: [Either a b] -> ([a], [b]) - </literal>. - </para> - </listitem> - <listitem> - <para> - The new function - <literal>Data.List.subsequences :: [a] -> [[a]]</literal> - gives all sublists of a list, e.g. - <literal> - subsequences "abc" == - ["","a","b","ab","c","ac","bc","abc"] - </literal>. - </para> - </listitem> - <listitem> - <para> - The new function - <literal>Data.List.permutations :: [a] -> [[a]]</literal> - gives all permutations of a list, e.g. - <literal> - permutations "abc" == - ["abc","bac","cba","bca","cab","acb"] - </literal>. - </para> - </listitem> - <listitem> - <para> - The new functions - <literal>Data.Traversable.mapAccumL</literal> and - <literal>Data.Traversable.mapAccumR</literal> generalise their - <literal>Data.List</literal> counterparts to work on any - <literal>Traversable</literal> type. - </para> - </listitem> - <listitem> - <para> - The new function - <literal>Control.Exception.blocked :: IO Bool</literal> - tells you whether or not exceptions are blocked (as controlled - by <literal>Control.Exception.(un)block</literal>). - </para> - </listitem> - <listitem> - <para> - There is a new function - <literal>traceShow :: Show a => a -> b -> b</literal> in - <literal>Debug.Trace</literal>. - </para> - </listitem> - <listitem> - <para> - The type of <literal>Control.Monad.forever</literal> has - been generalised from - <literal>Monad m => m a -> m ()</literal> to - <literal>Monad m => m a -> m b</literal>. - </para> - </listitem> - <listitem> - <para> - The new value <literal>GHC.Exts.maxTupleSize</literal> - tells you the largest tuple size that can be used. This is - mostly of use in Template Haskell programs. - </para> - </listitem> - <listitem> - <para> - <literal>GHC.Exts</literal> now exports - <literal>Down(..)</literal>, - <literal>groupWith</literal>, - <literal>sortWith</literal> and - <literal>the</literal> which are used in the desugaring of - generalised comprehensions. - </para> - </listitem> - <listitem> - <para> - <literal>GHC.Exts</literal> no longer exports the - <literal>Integer</literal> internals. If you want them then - you need to get them directly from the - new <literal>integer</literal> package. - </para> - </listitem> - <listitem> - <para> - The new function <literal>GHC.Conc.threadStatus</literal> - allows you to ask whether a thread is running, blocked on - an MVar, etc. - </para> - </listitem> - <listitem> - <para> - The <literal>Data.Generics</literal> hierarchy has been - moved to a new package <literal>syb</literal>. - </para> - </listitem> - <listitem> - <para> - The <literal>GHC.Prim</literal> and - <literal>GHC.PrimopWrappers</literal> modules have been - moved into a new <literal>ghc-prim</literal> package. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>bytestring</title> - <itemizedlist> - <listitem> - <para> - Version number 0.9.0.1.2 (was 0.9.0.1.1) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>Cabal</title> - <itemizedlist> - <listitem> - <para> - Version number 1.6.0.1 (was 1.2.4.0) - </para> - </listitem> - <listitem> - <para> - Many API changes. See the Cabal docs for more information. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>containers</title> - <itemizedlist> - <listitem> - <para> - Version number 0.2.0.0 (was 0.1.0.2) - </para> - </listitem> - <listitem> - <para> - Various result type now use <literal>Maybe</literal> rather - than allowing any Monad. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>directory</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.0.2 (was 1.0.0.1) - </para> - </listitem> - <listitem> - <para> - No longer defines the UNICODE CPP symbol for packages that - use it. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>editline</title> - <itemizedlist> - <listitem> - <para> - This is a new bootlib, version 0.2.1.0. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>filepath</title> - <itemizedlist> - <listitem> - <para> - Version number 1.1.0.1 (was 1.1.0.0) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>ghc-prim</title> - <itemizedlist> - <listitem> - <para> - This is a new bootlib, version 0.1.0.0. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>haskell98</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.1.0 (unchanged) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>hpc</title> - <itemizedlist> - <listitem> - <para> - Version number 0.5.0.2 (was 0.5.0.1) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>integer</title> - <itemizedlist> - <listitem> - <para> - This is a new bootlib, version 0.1.0.0. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>old-locale</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.0.1 (was 1.0.0.0) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>old-time</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.0.1 (was 1.0.0.0) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>packedstring</title> - <itemizedlist> - <listitem> - <para> - Version number 0.1.0.1 (was 0.1.0.0) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>pretty</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.1.0 (was 1.0.0.0) - </para> - </listitem> - <listitem> - <para> - There is a new combinator - <literal>zeroWidthText :: String -> Doc</literal> - for printing things like ANSI escape sequences. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>process</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.1.0 (was 1.0.0.1) - </para> - </listitem> - <listitem> - <para> - The <literal>System.Process</literal> API has been overhauled. - The new API is a superset of the old API, however. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>random</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.0.1 (was 1.0.0.0) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>readline</title> - <itemizedlist> - <listitem> - <para> - This is no longer a bootlib; editline replaces it. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>syb</title> - <itemizedlist> - <listitem> - <para> - This is a new bootlib, version 0.1.0.0. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>template-haskell</title> - <itemizedlist> - <listitem> - <para> - Version number 2.3.0.0 (was 2.2.0.0) - </para> - </listitem> - <listitem> - <para> - The datatypes now have support for Word primitives. - </para> - </listitem> - <listitem> - <para> - <literal>currentModule :: Q String</literal> has been - replaced with - <literal>location :: Q Loc</literal>, where - <literal>Loc</literal> is a new datatype. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>unix</title> - <itemizedlist> - <listitem> - <para> - Version number 2.3.1.0 (was 2.3.0.1) - </para> - </listitem> - <listitem> - <para> - The <literal>System.Posix.Terminal.BaudRate</literal> type - now includes <literal>B57600</literal> and - <literal>B115200</literal> constructors. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>Win32</title> - <itemizedlist> - <listitem> - <para> - Version number 2.2.0.0 (was 2.1.1.1) - </para> - </listitem> - <listitem> - <para> - No longer defines the UNICODE CPP symbol for packages that - use it. - </para> - </listitem> - </itemizedlist> - </sect3> - </sect2> -</sect1> - diff --git a/docs/users_guide/6.12.1-notes.xml b/docs/users_guide/6.12.1-notes.xml deleted file mode 100644 index 9e0ecbfbf8..0000000000 --- a/docs/users_guide/6.12.1-notes.xml +++ /dev/null @@ -1,1304 +0,0 @@ -<?xml version="1.0" encoding="iso-8859-1"?> -<sect1 id="release-6-12-1"> - <title>Release notes for version 6.12.1</title> - - <para> - The significant changes to the various parts of the compiler are - listed in the following sections. There have also been numerous bug - fixes and performance improvements over the 6.10 branch. - </para> - - <sect2> - <title>Language changes</title> - <itemizedlist> - <listitem> - <para> - The new <literal>TupleSections</literal> language extension - enables tuple sections, such as <literal>(, True)</literal>. - See <xref linkend="tuple-sections" /> for more information. - </para> - </listitem> - - <listitem> - <para> - The new <literal>MonoLocalBinds</literal> language extension - disables type variable generalisation for bindings in - <literal>let</literal> and <literal>where</literal> clauses. - </para> - </listitem> - - <listitem> - <para> - The new <literal>DeriveFunctor</literal>, - <literal>DeriveFoldable</literal> and - <literal>DeriveTraversable</literal> language extensions - enable deriving for the respective type classes. - See <xref linkend="deriving-typeable" /> for more information. - </para> - </listitem> - - <listitem> - <para> - The new <literal>NoNPlusKPatterns</literal> language extension - disables <literal>n+k</literal> patterns. - See <xref linkend="n-k-patterns" /> for more information. - </para> - </listitem> - - <listitem> - <para> - Some improvements have been made to record puns: - </para> - <itemizedlist> - <listitem> - <para> - <literal>C { A.a }</literal> now works, expanding to - <literal>C { A.a = a }</literal>. - </para> - </listitem> - - <listitem> - <para> - <literal>-fwarn-unused-matches</literal> no longer - warns about bindings introduced by - <literal>f (C {..}) = x</literal>. - </para> - </listitem> - - <listitem> - <para> - The <literal>RecordWildCards</literal> language - extension implies - <literal>DisambiguateRecordFields</literal>. - </para> - </listitem> - </itemizedlist> - </listitem> - - <listitem> - <para> - Declarations such as - </para> -<programlisting> -data T a where - MkT :: forall a. Eq a => { x,y :: !a } -> T a -</programlisting> - <para> - are now only accepted if the extension - <literal>TypeOperators</literal> is on. - </para> - </listitem> - - <listitem> - <para> - It is now possible to define GADT records with class - constraints. The syntax is: - </para> -<programlisting> -data T a where - MkT :: forall a. Eq a => { x,y :: !a } -> T a -</programlisting> - </listitem> - - <listitem> - <para> - You can now list multiple GADT constructors with the same type, - e.g.: - </para> -<programlisting> -data T where - A, B :: T - C :: Int -> T -</programlisting> - </listitem> - - <listitem> - <para> - It is now possible to use GADT syntax for data families: - </para> -<programlisting> -data instance T [a] where - T1 :: a -> T [a] -</programlisting> - <para> - and make data instances be GADTs: - </para> -<programlisting> -data instance T [a] where - T1 :: Int -> T [Int] - T2 :: a -> b -> T [(a,b)] -</programlisting> - </listitem> - - <listitem> - <para> - Record updates can now be used with datatypes containing - existential type variables, provided the fields being altered - do not mention the existential types. - </para> - </listitem> - - <listitem> - <para> - The <literal>ImpredicativeTypes</literal> extension now imples - the <literal>RankNTypes</literal> extension. - </para> - </listitem> - - <listitem> - <para> - The <literal>ImpredicativeTypes</literal> extension is no - longer enabled by <literal>-fglasgow-exts</literal>. - </para> - </listitem> - - <listitem> - <para> - You can now give multi-line <literal>DEPRECATED</literal> and - <literal>WARNING</literal> pragmas: - </para> -<programlisting> -{-# DEPRECATED defaultUserHooks - ["Use simpleUserHooks or autoconfUserHooks, unless you need Cabal-1.2" - , "compatibility in which case you must stick with defaultUserHooks"] - #-} -</programlisting> - </listitem> - - <listitem> - <para> - The <literal>-#include</literal> flag and - <literal>INCLUDE</literal> pragma are now deprecated and - ignored. Since version 6.10.1, GHC has generated its own C - prototypes for foreign calls, rather than relying on - prototypes from C header files. - </para> - </listitem> - - <listitem> - <para> - The <literal>threadsafe</literal> foreign import safety level - is now deprecated; use <literal>safe</literal> instead. - </para> - </listitem> - - <listitem> - <para> - There is a new FFI calling convention called - <literal>prim</literal>, which allows calling C-- functions - (see <xref linkend="ffi-prim" />). - Most users are not expected to need this. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Warnings</title> - <itemizedlist> - <listitem> - <para> - A warning is now emitted if an unlifted type is bound in a - lazy pattern (in <literal>let</literal> or - <literal>where</literal> clause, or in an irrefutable pattern) - unless it is inside a bang pattern. - This warning is controlled by the - <literal>-fwarn-lazy-unlifted-bindings</literal> flag. - In a future version of GHC this will be an error. - </para> - </listitem> - - <listitem> - <para> - There are two new warnings if a monadic result of type other than - <literal>m ()</literal> is used in a <literal>do</literal> - block, but its result is not bound. - The flags <literal>-fwarn-unused-do-bind</literal> - and <literal>-fwarn-wrong-do-bind</literal> control - these warnings (see <xref linkend="options-sanity" />). - </para> - </listitem> - - <listitem> - <para> - The new flag <literal>-fwarn-dodgy-exports</literal> controls - whether an error is given for exporting a type synonym as - <literal>T(..)</literal>. - </para> - </listitem> - - <listitem> - <para> - Name shadowing warnings are no longer given for variable names - beginning with an underscore. - </para> - </listitem> - - <listitem> - <para> - When <literal>-Werror</literal> is given, we now pass - <literal>-Werror</literal> to <literal>cpp</literal>. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Runtime system</title> - - <para>The following options are all described in - <xref linkend="rts-options-gc" />.</para> - - <itemizedlist> - <listitem> - <para> - The flag <literal>+RTS -N</literal> now automatically - determines how many threads to use, based on the number - of CPUs in your machine. - </para> - </listitem> - - <listitem> - <para> - The parallel GC now uses the same threads as the mutator, - with the consequence that you can no longer select a - different number of threads to use for GC. - The <option>-g<replaceable>n</replaceable></option> RTS - option has been removed, except that <option>-g1</option> is - still accepted for backwards compatibility. - </para> - - <para> - The new flag - <literal>+RTS -qg<replaceable>gen</replaceable></literal> sets - the minimum generation for which parallel garbage collection - is used. Defaults to 1. The flag <literal>-qg</literal> on - its own disables parallel GC. - </para> - </listitem> - - <listitem> - <para> - The new flag <literal>+RTS -qb<replaceable>gen</replaceable></literal> - controls load balancing in the parallel GC. - </para> - </listitem> - - <listitem> - <para> - The new flag <literal>+RTS -qa</literal> - uses the OS to set thread affinity (experimental). - </para> - </listitem> - - <listitem> - <para> - If you link with the <literal>-eventlog</literal> flag, then - the new flag <literal>+RTS -l</literal> generates - <literal><replaceable>prog</replaceable>.eventlog</literal> - files, which tools such as ThreadScope can use to show the - behaviour of your program (see <xref linkend="rts-eventlog" />). The - <literal>+RTS -D><replaceable>x</replaceable></literal> output - is also sent to the eventlog file if this option is enabled. - The <literal>+RTS -v</literal> flag sends eventlog data to - stderr instead. - </para> - </listitem> - - <listitem> - <para> - There is a new statistic in the <literal>+RTS -s</literal> output: - </para> -<programlisting> -SPARKS: 1430 (2 converted, 1427 pruned) -</programlisting> - <para> - This tells you how many sparks (requests for parallel - execution, caused by calls to <literal>par</literal>) were - created, how many were actually evaluated in parallel - (converted), and how many were found to be already evaluated - and were thus discarded (pruned). Any unaccounted for sparks - are simply discarded at the end of evaluation. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Build system</title> - <itemizedlist> - <listitem> - <para> - We now require GHC >= 6.8 to build. - </para> - </listitem> - - <listitem> - <para> - We now require that gcc is >= 3.0. - </para> - </listitem> - - <listitem> - <para> - In order to generate the parsers, happy >= 1.16 is now - required. The parsers are pre-generated in the source tarball, - so most users will not need Happy. - </para> - </listitem> - - <listitem> - <para> - It is now possible to build GHC with a simple, BSD-licensed - Haskell implementation of Integer, instead of the - implementation on top of GMP. To do so, set - <literal>INTEGER_LIBRARY</literal> to - <literal>integer-simple</literal> in - <literal>mk/build.mk</literal>. - </para> - </listitem> - - <listitem> - <para> - The build system has been rewritten for the 6.12 series. - See <ulink url="http://hackage.haskell.org/trac/ghc/wiki/Building/Using">the building guide</ulink> - for more information. - </para> - </listitem> - - <listitem> - <para> - The build system now uses variables like - <literal>bindir</literal> compatibly with the GNU standard. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Compiler</title> - <itemizedlist> - <listitem> - <para> - The "Interface file version" field of the - <literal>ghc --info</literal> output has been removed, as it - is no longer used by GHC. - </para> - </listitem> - - <listitem> - <para> - There is a new "LibDir" field in the - <literal>ghc --info</literal> output. - </para> - </listitem> - - <listitem> - <para> - A field <replaceable>f</replaceable> in the - <literal>ghc --info</literal> can now be printed with - <literal>ghc --print-<replaceable>f</replaceable></literal>, with letters lower-cased - and spaces replaced by dashes. - </para> - </listitem> - - <listitem> - <para> - GHC now works (as a 32bit application) on OS X Snow Leopard. - </para> - </listitem> - - <listitem> - <para> - The native code generator now works on Sparc Solaris. - </para> - </listitem> - - <listitem> - <para> - Haddock interface files are now portable between different - architectures. - </para> - </listitem> - - <listitem> - <para> - The new linker flag <literal>-eventlog</literal> enables the - <literal>+RTS -l</literal> event logging features. The - <literal>-debug</literal> flag also enables them. - </para> - </listitem> - - <listitem> - <para> - There is a new flag <literal>-feager-blackholing</literal> - which typically gives better performing code when running - with multiple threads. - See <xref linkend="parallel-compile-options" /> for more - information. - </para> - </listitem> - - <listitem> - <para> - There is a new flag <literal>-fbuilding-cabal-package</literal> - which signals to GHC that it is being run by a build system, - rather than invoked directly. This currently means that GHC - gives different error messages in certain situations. - </para> - </listitem> - - <listitem> - <para> - The following flags were static, but are now dynamic: - <literal>-fext-core</literal>, - <literal>-fauto-sccs-on-all-toplevs</literal>, - <literal>-auto-all</literal>, - <literal>-no-auto-all</literal>, - <literal>-fauto-sccs-on-exported-toplevs</literal>, - <literal>-auto</literal>, - <literal>-no-auto</literal>, - <literal>-fauto-sccs-on-individual-cafs</literal>, - <literal>-caf-all</literal> and - <literal>-no-caf-all</literal>. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>GHCi</title> - <itemizedlist> - <listitem> - <para> - If the argument to <literal>:set prompt</literal> starts with - a double quote then it is read with Haskell String syntax, - e.g.: - </para> -<programlisting> -Prelude> :set prompt "Loaded: %s\n> " -Loaded: Prelude -> -</programlisting> - </listitem> - - <listitem> - <para> - The arguments to <literal>:set set</literal> - and <literal>:set show</literal> can now be tab completed. - </para> - </listitem> - - <listitem> - <para> - We inherit some benefits from an upgraded version of haskeline: - </para> - <itemizedlist> - <listitem> - <para> - A multitude of new emacs and vi commands. - </para> - </listitem> - - <listitem> - <para> - New preference 'historyDuplicates' to prevent storage - of duplicate lines. - </para> - </listitem> - - <listitem> - <para> - Support PageUp and PageDown keys. - </para> - </listitem> - </itemizedlist> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Template Haskell</title> - <itemizedlist> - <listitem> - <para> - You can now omit the splice notation for top-level declaration - splices, e.g.: - </para> -<programlisting> -data T = T1 | T2 -deriveMyStuff ''T -</programlisting> - </listitem> - - <listitem> - <para> - Splices are now nestable, e.g. you can say - <literal>f x = $(g $(h 'x))</literal>. - </para> - </listitem> - - <listitem> - <para> - It is now possible to splice in types. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Package Handling</title> - <itemizedlist> - <listitem> - <para> - Shared libraries are now supported on x86 and x86_64 Linux. - To use shared libraries, use the <literal>-dynamic</literal> - flag. - See <xref linkend="using-shared-libs" /> for more information. - </para> - </listitem> - - <listitem> - <para> - The new <literal>-fno-shared-implib</literal> flag can be used - to stop GHC generating the <literal>.lib</literal> import - library when making a dynamic library. This reduces the disk - space used when you do not need it. - </para> - </listitem> - - <listitem> - <para> - Packages can now be identified by a "package ID", which is - based on a hash of the ABIs. The new flag - <literal>-package-id</literal> allows packages to be - selected by this identifier (see <xref linkend="package-ids" - />). Package IDs enable GHC to detect potential - incompatibilities between packages and broken dependencies - much more accurately than before. - </para> - </listitem> - - <listitem> - <para> - The new flag <literal>--abi-hash</literal>, used thus: - </para> -<programlisting> -ghc --abi-hash M1 M2 ... -</programlisting> - <para> - prints the combined hash of all the modules listed. It is - used to make package IDs. - </para> - </listitem> - - <listitem> - <para> - You can now give <literal>ghc-pkg</literal> a - <literal>-v0</literal> flag to make it be silent, - <literal>-v1</literal> for normal verbosity (the default), - or <literal>-v2</literal> or <literal>-v</literal> for - verbose output. - </para> - </listitem> - - <listitem> - <para> - Rather than being a single <literal>package.conf</literal> file, - package databases now consist of a directory containing one - file per package, and a binary cache of the information. - GHC should be much faster to start up when the package - database grows large. - </para> - </listitem> - - <listitem> - <para> - There is a new command <literal>ghc-pkg init</literal> to - create a package database. - </para> - </listitem> - - <listitem> - <para> - There is a new command <literal>ghc-pkg dot</literal> to - generate a GraphViz graph of the dependencies between - installed packages. - </para> - </listitem> - - <listitem> - <para> - There is a new command <literal>ghc-pkg recache</literal> to - update the package database cache should it become out of - date, or for registering packages manually. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Libraries</title> - - <para> - GHC no longer comes with any extralibs; instead, the - <ulink url="http://hackage.haskell.org/platformi/">Haskell Platform</ulink> - will provide a consistent set of additional libraries. - </para> - - <sect3> - <title>array</title> - <itemizedlist> - <listitem> - <para> - Version number 0.3.0.0 (was 0.2.0.0) - </para> - </listitem> - - <listitem> - <para> - The <literal>Data.Array.Diff</literal> module has been moved - to its own package. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>base</title> - <itemizedlist> - <listitem> - <para> - Version number 4.2.0.0 (was 4.1.0.0) - </para> - </listitem> - - <listitem> - <para> - We also ship a base version 3.0.3.2 (was 3.0.3.1), so legacy - code should continue to work. This package is now deprecated, - and will be removed in a future version of GHC. - </para> - </listitem> - - <listitem> - <para> - Handle IO now supports automatic character set encoding - and newline translation. For more information, see the - "Unicode encoding/decoding" and "Newline conversion" sections - in the <literal>System.IO</literal> haddock docs. - </para> - </listitem> - - <listitem> - <para> - Lazy I/O now throws an exception if an error is - encountered, in a divergence from the Haskell 98 spec which - requires that errors are discarded (see Section 21.2.2 of - the Haskell 98 report). The exception thrown is the usual - IO exception that would be thrown if the failing IO - operation was performed in the IO monad, and can be caught - by <literal>System.IO.Error.catch</literal> - or <literal>Control.Exception.catch</literal>. - </para> - </listitem> - - <listitem> - <para> - It is now possible to create your own handles. - For more information, see the - <literal>GHC.IO.Handle</literal> haddock docs. - </para> - </listitem> - - <listitem> - <para> - <literal>System.IO</literal> now exports two new functions, - <literal>openTempFileWithDefaultPermissions</literal> and - <literal>openBinaryTempFileWithDefaultPermissions</literal>. - </para> - </listitem> - - <listitem> - <para> - <literal>Data.Fixed</literal> now provides - <literal>Data</literal> and <literal>Typeable</literal> - instances for <literal>Fixed</literal>, and exports - a number of new types: - <literal>E0</literal>, <literal>Uni</literal>, - <literal>E1</literal>, <literal>Deci</literal>, - <literal>E2</literal>, <literal>Centi</literal>, - <literal>E3</literal>, <literal>Milli</literal>, - <literal>E9</literal> and <literal>Nano</literal>. - </para> - </listitem> - - <listitem> - <para> - In <literal>Control.Exception</literal>, - <literal>BlockedOnDeadMVar</literal> - has been renamed to - <literal>BlockedIndefinitelyOnMVar</literal> - and <literal>BlockedIndefinitely</literal> - has been renamed to - <literal>BlockedIndefinitelyOnSTM</literal>. - </para> - </listitem> - - <listitem> - <para> - The <literal>Control.OldException</literal> module has been - deprecated. - </para> - </listitem> - - <listitem> - <para> - <literal>System.Posix.Internals.setNonBlockingFD</literal> - now takes an additional <literal>Bool</literal> argument, so - you can turn blocking back on again. - </para> - </listitem> - - <listitem> - <para> - A new function <literal>eof</literal> has been added to - <literal>Text.ParserCombinators.ReadP</literal>. - </para> - </listitem> - - <listitem> - <para> - The <literal>Foreign.C.Types.CLDouble</literal> type has - been removed. It was never correct, but just a duplicate of - <literal>Foreign.C.Types.CDouble</literal>. - </para> - </listitem> - - <listitem> - <para> - In <literal>Data.Data</literal>, the - <literal>StringRep</literal> and - <literal>StringConstr</literal> constructors have been - removed. The <literal>CharRep</literal> and - <literal>CharConstr</literal> constructors should be used - instead. - </para> - </listitem> - - <listitem> - <para> - In <literal>Data.Data</literal>, - <literal>mkIntConstr</literal> has been deprecated in favour - of the new <literal>mkIntegralConstr</literal>. - </para> - </listitem> - - <listitem> - <para> - In <literal>Data.Data</literal>, - <literal>mkFloatConstr</literal> has been deprecated in - favour of the new <literal>mkRealConstr</literal>. - </para> - </listitem> - - <listitem> - <para> - In <literal>Data.Data</literal>, - <literal>mkNorepType</literal> has been deprecated in - favour of the new <literal>mkNoRepType</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>bytestring</title> - <itemizedlist> - <listitem> - <para> - Version number 0.9.1.5 (was 0.9.1.4) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>Cabal</title> - <itemizedlist> - <listitem> - <para> - Version number 1.8.0.0 (was 1.6.0.3) - </para> - </listitem> - - <listitem> - <para> - Many API changes. See the Cabal docs for more information. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>containers</title> - <itemizedlist> - <listitem> - <para> - Version number 0.3.0.0 (was 0.2.0.1) - </para> - </listitem> - - <listitem> - <para> - <literal>mapAccumRWithKey</literal> has been added to - <literal>Data.IntMap</literal>. - </para> - </listitem> - - <listitem> - <para> - A <literal>Traversable</literal> instance has been added to - <literal>Data.IntMap.IntMap</literal>. - </para> - </listitem> - - <listitem> - <para> - The types of <literal>Data.IntMap.intersectionWith</literal> - and <literal>Data.IntMap.intersectionWithKey</literal> have - been changed from - </para> -<programlisting> -intersectionWith :: (a -> b -> a) -> IntMap a -> IntMap b -> IntMap a -intersectionWithKey :: (Key -> a -> b -> a) -> IntMap a -> IntMap b -> IntMap a -</programlisting> - <para> - to - </para> -<programlisting> -intersectionWith :: (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c -intersectionWithKey :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c -</programlisting> - </listitem> - - <listitem> - <para> - The types of <literal>Data.IntMap.findMin</literal> - and <literal>Data.IntMap.findMax</literal> have - been changed from - </para> -<programlisting> -findMin :: IntMap a -> a -findMax :: IntMap a -> a -</programlisting> - <para> - to - </para> -<programlisting> -findMin :: IntMap a -> (Int,a) -findMax :: IntMap a -> (Int,a) -</programlisting> - </listitem> - - <listitem> - <para> - <literal>Data.Map</literal> now exports - <literal>mapAccumRWithKey</literal>, - <literal>foldrWithKey</literal>, - <literal>foldlWithKey</literal> and - <literal>toDescList</literal>. - </para> - </listitem> - - <listitem> - <para> - <literal>Data.Sequence</literal> now exports - <literal>replicate</literal>, - <literal>replicateA</literal>, - <literal>replicateM</literal>, - <literal>iterateN</literal>, - <literal>unfoldr</literal>, - <literal>unfoldl</literal>, - <literal>scanl</literal>, - <literal>scanl1</literal>, - <literal>scanr</literal>, - <literal>scanr1</literal>, - <literal>tails</literal>, - <literal>inits</literal>, - <literal>takeWhileL</literal>, - <literal>takeWhileR</literal>, - <literal>dropWhileL</literal>, - <literal>dropWhileR</literal>, - <literal>spanl</literal>, - <literal>spanr</literal>, - <literal>breakl</literal>, - <literal>breakr</literal>, - <literal>partition</literal>, - <literal>filter</literal>, - <literal>sort</literal>, - <literal>sortBy</literal>, - <literal>unstableSort</literal>, - <literal>unstableSortBy</literal>, - <literal>elemIndexL</literal>, - <literal>elemIndicesL</literal>, - <literal>elemIndexR</literal>, - <literal>elemIndicesR</literal>, - <literal>findIndexL</literal>, - <literal>findIndicesL</literal>, - <literal>findIndexR</literal>, - <literal>findIndicesR</literal>, - <literal>foldlWithIndex</literal>, - <literal>foldrWithIndex</literal>, - <literal>mapWithIndex</literal>, - <literal>zip</literal>, - <literal>zipWith</literal>, - <literal>zip3</literal>, - <literal>zipWith3</literal>, - <literal>zip4</literal> and - <literal>zipWith4</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>directory</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.1.0 (was 1.0.0.3) - </para> - </listitem> - - <listitem> - <para> - A new function <literal>copyPermissions</literal> has been - added to <literal>System.Directory</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title> - dph - (dph-base, dph-par, dph-prim-interface, dph-prim-par, - dph-prim-seq, dph-seq) - </title> - <itemizedlist> - <listitem> - <para> - All the dph packages are version 0.4.0. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>extensible-exceptions</title> - <itemizedlist> - <listitem> - <para> - Version number 0.1.1.1 (was 0.1.1.0) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>filepath</title> - <itemizedlist> - <listitem> - <para> - Version number 1.1.0.3 (was 1.1.0.2) - </para> - </listitem> - - <listitem> - <para> - The list of characters that are invalid in filenames on - Windows now includes <literal>\</literal> (backslash). - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>ghc-binary</title> - <itemizedlist> - <listitem> - <para> - This is an internal package, and should not be used. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>ghc-prim</title> - <itemizedlist> - <listitem> - <para> - Version number 0.2.0.0 (was 0.1.0.0) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>haskell98</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.1.1 (was 1.0.1.0) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>hpc</title> - <itemizedlist> - <listitem> - <para> - Version number 0.5.0.4 (was 0.5.0.3) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>integer-gmp</title> - <itemizedlist> - <listitem> - <para> - Version number 0.2.0.0 (was called integer, version 0.1.0.1) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>integer-simple</title> - <itemizedlist> - <listitem> - <para> - This is a new boot package, version 0.1.0.0. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>old-locale</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.0.2 (was 1.0.0.1) - </para> - </listitem> - - <listitem> - <para> - Date and time in ISO8601 format are now separated by - <literal>T</literal> rather than a space. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>old-time</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.0.3 (was 1.0.0.2) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>packedstring</title> - <itemizedlist> - <listitem> - <para> - This is no longer a boot package. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>pretty</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.1.1 (was 1.0.1.0) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>process</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.1.2 (was 1.0.1.1) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>random</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.0.2 (was 1.0.0.1) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>syb</title> - <itemizedlist> - <listitem> - <para> - Version number 0.1.0.2 (was 0.1.0.1) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>template-haskell</title> - <itemizedlist> - <listitem> - <para> - Version number 2.4.0.0 (was 2.3.0.1) - </para> - </listitem> - - <listitem> - <para> - Support for <literal>inline</literal> and - <literal>specialise</literal> pragmas has been added. - </para> - </listitem> - - <listitem> - <para> - Support for bang patterns has been added - </para> - </listitem> - - <listitem> - <para> - Support for kind annotations has been added - </para> - </listitem> - - <listitem> - <para> - Support for equality constraints has been added - </para> - </listitem> - - <listitem> - <para> - Support for type family declarations has been added - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>time</title> - <itemizedlist> - <listitem> - <para> - This is a new boot package, version 1.1.4. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>unix</title> - <itemizedlist> - <listitem> - <para> - Version number 2.4.0.0 (was 2.3.2.0) - </para> - </listitem> - - <listitem> - <para> - <literal>System.Posix.IO</literal> now exports - <literal>fdReadBuf</literal> and - <literal>fdWriteBuf</literal>. - </para> - </listitem> - - <listitem> - <para> - <literal>System.Posix.Process.executeFile</literal> now - returns <literal>IO a</literal> instead of - <literal>IO ()</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>Win32</title> - <itemizedlist> - <listitem> - <para> - Version number 2.2.0.1 (was 2.2.0.0) - </para> - </listitem> - - <listitem> - <para> - <literal>System.Win32.File</literal> now exports - <literal>WIN32_FIND_DATA</literal>, - <literal>FindData</literal>, - <literal>getFindDataFileName</literal>, - <literal>findFirstFile</literal>, - <literal>findNextFile</literal> and - <literal>findClose</literal>. - </para> - </listitem> - - <listitem> - <para> - <literal>System.Win32.Info</literal> now exports - <literal>getCurrentDirectory</literal>, - <literal>getTemporaryDirectory</literal>, - <literal>getFullPathName</literal> and - <literal>searchPath</literal>. - </para> - </listitem> - - <listitem> - <para> - <literal>System.Win32.Types</literal> now exports - <literal>HRESULT</literal>. - </para> - </listitem> - - <listitem> - <para> - There is a new module <literal>System.Win32.Shell</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - </sect2> -</sect1> - diff --git a/docs/users_guide/6.6-notes.xml b/docs/users_guide/6.6-notes.xml deleted file mode 100644 index a04b99e4c0..0000000000 --- a/docs/users_guide/6.6-notes.xml +++ /dev/null @@ -1,1718 +0,0 @@ -<?xml version="1.0" encoding="iso-8859-1"?> -<sect1 id="release-6-6"> - <title>Release notes for version 6.6</title> - - <sect2> - <title>User-visible compiler changes</title> - <itemizedlist> - <listitem> - <para> - GHC now supports SMP: - when you compile with <option>-threaded</option>, you now get - an RTS flag <option>-N</option> that allows you to specify the - number of OS threads that GHC should use. Defaults to 1. - See <xref linkend="using-smp" /> and <xref - linkend="lang-parallel" />. - </para> - </listitem> - <listitem> - <para> - GHC now handles impredicative polymorphism; see <xref linkend="impredicative-polymorphism" />. - </para> - </listitem> - <listitem> - <para> - There are significant changes to the way scoped type variables work, - and some programs that used to compile may no longer do so. - The new story is documented in <xref linkend="scoped-type-variables" />. - (<ulink url="http://www.haskell.org/pipermail/glasgow-haskell-users/2006-January/009565.html"> Simon's e-mail</ulink> - gives some background, but the user manual should be complete (tell - us if not), and - certainly takes precedence if there is any conflict.) - </para> - </listitem> - <listitem> - <para> - GHC now supports bang patterns to require a function is strict - in a given argument, e.g. - <programlisting> - f (!x, y) = [x,y]</programlisting> - is equivalent to - <programlisting> - f (x, y) | x `seq` False = undefined - | otherwise = [x,y]</programlisting> - See <xref linkend="bang-patterns" /> for more details. - </para> - </listitem> - <listitem> - <para> - The restriction that you cannot use two packages together if - they contain a module with the same name has been removed. - In implementation terms, the package name is now included in - every exported symbol name in the object file, so that - modules with the same name in different packages do not - clash. See <xref linkend="package-overlaps" />. - </para> - </listitem> - <listitem> - <para> - GHC now treats source files as UTF-8 (ASCII is a strict - subset of UTF-8, so ASCII source files will continue to - work as before). However, invalid UTF-8 sequences are - ignored in comments, so ASCII code with comments in, for - example, Latin-1 will also work. - </para> - - <para> - A way to have Latin-1 source files pre-processed by GHC is - described in <xref linkend="pre-processor" />. - </para> - </listitem> - <listitem> - <para> - GADTs can now use record syntax. Also, if the datatype could - have been declared with Haskell 98 syntax then deriving - clauses are permitted. For more info see <xref linkend="gadt" />. - </para> - </listitem> - <listitem> - <para> - There is a new pragma <literal>LANGUAGE</literal> which allows - extensions to be specified portably, i.e. without having to - resort to the <literal>OPTIONS_GHC</literal> pragma and giving - GHC-specific options. The arguments to the pragma are the same - extensions that Cabal knows about. More info in - <xref linkend="language-pragma" />. - </para> - </listitem> - <listitem> - <para> - When you use <command>ghc --make</command>, GHC will now take - the executable filename from the name of the file containing - the <literal>Main</literal> module rather than using - <filename>a.out</filename>. The <filename>.exe</filename> - extension is appended on Windows, and it can of course be - overridden with <option>-o</option>. - </para> - </listitem> - <listitem> - <para> - GHC's garbage collector now deals more intelligently with - mutable data, so you mostly no longer need to worry about GC - performance when a lot of memory is taken up by - <literal>STArray</literal>s, <literal>IOArray</literal>s, - <literal>STRef</literal>s or <literal>IORef</literal>s. - For more details see - <ulink url="http://hackage.haskell.org/trac/ghc/ticket/650">trac bug #650</ulink>. - </para> - </listitem> - <listitem> - <para> - GHC now allows more generalisation when typing mutually - recursive bindings, resulting in more programs being accepted. - See <xref linkend="typing-binds" /> for more details. - </para> - </listitem> - <listitem> - <para> - The rules for instance declarations have been further relaxed. - You are now permitted to have instances whose heads contain - only type variables, e.g. - <programlisting> - instance C a</programlisting> - and instances whose constraints are not only type variables, - e.g. - <programlisting> - instance C2 Int a => C3 [a] b</programlisting> - For more details, see <xref linkend="instance-rules" />. - </para> - </listitem> - <listitem> - <para> - The following flags (and, where appropriate, their inverses) - used to be static (can only be given on - the command line) but are now dynamic (can also be given in - an <literal>OPTIONS_GHC</literal> pragma or with - <literal>:set</literal> in GHCi): - <option>-c</option>, - <option>-hcsuf</option>, - <option>-hidir</option>, - <option>-hisuf</option>, - <option>-o</option>, - <option>-odir</option>, - <option>-ohi</option>, - <option>-osuf</option>, - <option>-keep-hc-file</option>, - <option>-keep-s-file</option>, - <option>-keep-raw-s-file</option>, - <option>-keep-tmp-files</option>, - <option>-tmpdir</option>, - <option>-i</option>, - <option>-package</option>, - <option>-hide-package</option>, - <option>-ignore-package</option>, - <option>-package-conf</option>, - <option>-no-user-package-conf</option>, - <option>-fcontext-stack</option>, - <option>-fexcess-precision</option>, - <option>-fignore-asserts</option>, - <option>-fignore-interface-pragmas</option>, - <option>-I</option>, - <option>-framework</option>, - <option>-framework-path</option>, - <option>-l</option>, - <option>-L</option>, - <option>-main-is</option>, - <option>-no-hs-main</option>, - <option>-split-objs</option>, - <option>-pgmL</option>, - <option>-pgmP</option>, - <option>-pgmc</option>, - <option>-pgma</option>, - <option>-pgml</option>, - <option>-pgmdll</option>, - <option>-pgmF</option>, - <option>-optl</option>, - <option>-optdll</option>, - <option>-optdep</option>, - <option>-fno-asm-mangling</option>. - See <xref linkend="static-dynamic-flags" /> for more on - the meaning of static and dynamic flags, and - <xref linkend="flag-reference" /> for more on the flags - themselves. - </para> - </listitem> - <listitem> - <para> - There is a new flag <option>-x</option> for overriding the - default behaviour for source files; see - <xref linkend="overriding-suffixes" /> details. - </para> - </listitem> - <listitem> - <para> - The - <option>-no-recomp</option><indexterm><primary><option>-no-recomp</option></primary></indexterm> - option is now called - <option>-fforce-recomp</option><indexterm><primary><option>-fforce-recomp</option></primary></indexterm>. - (the old name is still accepted for backwards compatibility, - but will be removed in the future). - </para> - </listitem> - <listitem> - <para> - The <option>-fglobalise-toplev-names</option> - flag has been removed. - </para> - </listitem> - <listitem> - <para> - The <option>-fallow-overlapping-instances</option> flag is - implied by the <option>-fallow-incoherent-instances</option> - flag. - </para> - </listitem> - <listitem> - <para> - The directory that the <filename>foo_stub.c</filename> and - <filename>foo_stub.h</filename> files are put in can now be - controlled with the <option>-stubdir</option> flag. - See <xref linkend="options-output" /> for more details. - </para> - </listitem> - <listitem> - <para> - When the <option>-fno-implicit-prelude</option> is given, - the equality test performed when pattern matching against an - overloaded numeric literal now uses the - <literal>(==)</literal> in scope, rather than the one from - <literal>Prelude</literal>. Likewise, the subtraction and - inequality test performed when pattern matching against - <literal>n+k</literal> patterns uses the - <literal>(-)</literal> and <literal>(>=)</literal> in scope. - </para> - </listitem> - <listitem> - <para> - Another change to <option>-fno-implicit-prelude</option>: - with the exception of the arrow syntax, the types of - functions used by sugar (such as do notation, numeric - literal patterns) need not match the types of the - <literal>Prelude</literal> functions normally used. - </para> - </listitem> - <listitem> - <para> - The <literal>InstalledPackageInfo</literal> syntax has - changed. Now - instead of <literal>extra-libs</literal> we have - <literal>extra-libraries</literal>, - instead of <literal>extra-hugs-opts</literal> we have - <literal>hugs-options</literal>, - instead of <literal>extra-cc-opts</literal> we have - <literal>cc-options</literal>, - instead of <literal>extra-ld-opts</literal> we have - <literal>ld-options</literal>, - and instead of <literal>extra-frameworks</literal> we have - <literal>frameworks</literal>. - See <xref linkend="installed-pkg-info" /> for details. - </para> - </listitem> - <listitem> - <para> - If you <literal>newtype</literal> the IO monad, e.g. - <programlisting> - newtype MyIO a = MyIO (IO a)</programlisting> - then GHC will now allow you to have FFI calls return - <literal>MyIO <replaceable>t</replaceable></literal> - rather than just - <literal>IO <replaceable>t</replaceable></literal>. - See <xref linkend="ffi-newtype-io"/> - </para> - </listitem> - <listitem> <para> GHC's mechansim for deriving user-defined classes - for newtypes has been further generalised, to multi-parameter type - classes and higher-kinded types. See <xref - linkend="newtype-deriving"/>. - </para></listitem> - <listitem> - <para> - By default, pattern bindings in GHC are now monomorphic. - This means that some valid Haskell 98 programs will get - rejected, but we believe they will be few in number. - To revert to the old behaviour use the - <option>-fno-mono-pat-binds</option> flag. - More details are in <xref linkend="options-language" />. - </para> - </listitem> - <listitem> - <para> - GHCi already does more defaulting than Haskell 98 so that, for - example, <literal>reverse []</literal> shows a result rather - than giving an ambiguous type variable error. There is now a - flag <option>-fextended-default-rules</option> to use these - defaulting rules with GHC too. - More details are in <xref linkend="extended-default-rules" />. - </para> - </listitem> - <listitem> - <para> - You can now give both class and instance declarations in - <filename>.hs-boot</filename> files. More details in - <xref linkend="mutual-recursion" />. - </para> - </listitem> - <listitem> - <para> - Linear implicit parameters have been scheduled for removal for some - time. In 6.6 we've removed them from the user manual, and they may - well disappear from the compiler itself in 6.6.1. - </para> - </listitem> - <listitem> - <para> - If the program is idle for a certain amount of time then GHC - will now take the opportunity to do a major garbage collection. - The amount of idle time that is required before that happens - is controlled by the new <literal>-I</literal> RTS flag. - There is more detail in <xref linkend="rts-options-gc" />. - </para> - </listitem> - <listitem> - <para> - It is now possible to control the frequency that the RTS clock - ticks at with the new <literal>-V</literal> RTS flag. This is - normally handled automatically by other flags, but this flag - is needed if you want to increase the resolution of the time - profiler. - For more details see <xref linkend="rts-options-misc" />. - </para> - </listitem> - <listitem> - <para> - The old syntax for FFI declarations (deprecated since 5.04) - is no longer accepted. - </para> - </listitem> - <listitem> - <para> - The <option>-split-objs</option> flag, which when used to compile - libraries means executables using the library will be smaller, - can now be used with <option>--make</option> and hence - can be used by cabal. - See <xref linkend="options-linker" /> for more information. - </para> - </listitem> - <listitem> - <para> - Template Haskell used to have limited support for type signatures in - patterns, but since that design is in flux for Haskell (let alone - Template Haskell), we've removed type signatures in patterns from - Template Haskell. - </para> - </listitem> - <listitem> - <para> - GHC now supports postfix operators, as a simple generalisation of - left sections (<xref linkend="postfix-operators"/>). - </para> - </listitem> - <listitem> - <para> - Parallel arrays, as enabled by <literal>-fparr</literal>, no - longer work. They'll be coming back shortly, in full glory. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>GHCi changes</title> - - <itemizedlist> - <listitem> - <para> - GHCi now allows tab completion of in-scope names and modules - on platforms that use readline (i.e. not Windows). - </para> - </listitem> - <listitem> - <para> - GHCi now has a <literal>:main</literal> command that allows - you to call the <literal>main</literal> function with - command-line arguments. - See <xref linkend="ghci-commands" /> for more information. - </para> - </listitem> - <listitem> - <para> - GHCi now has <literal>:ctags</literal> and - <literal>:etags</literal> commands to generate tags files for - vi-style and emacs-style editors respectively. - See <xref linkend="ghci-commands" /> for more information. - </para> - </listitem> - <listitem> - <para> - GHCi now has an <literal>:edit</literal> command which pops - up an editor on the most recently loaded file, or a - specified file. See <xref linkend="ghci-commands" /> for - more information. - </para> - </listitem> - <listitem> - <para> - GHCi now invokes <literal>print</literal> by default on the - result of IO actions and bindings at the prompt. This is - occasionally not what you want, so it can be disabled (at - least for bindings) with - <literal>:set -fno-print-bind-result</literal>. See <xref - linkend="ghci-stmts" />.</para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Libraries</title> - <para> - Libraries are now divided into core libraries (those that are - necessary to build GHC) and extra libraries. Decoupling the extra - libraries means that they can release independently of GHC - releases, and makes development builds of GHC quicker as they no - longer need to build unnecessary libraries. - </para> - - <para> - The hslibs libraries have finally been removed. - </para> - </sect2> - - <sect2> - <title>Core Libraries</title> - <sect3> - <title>base</title> - <itemizedlist> - <listitem> - <para> - Version number 2.1 (was 1.0). - </para> - </listitem> - <listitem> - <para> - We now have <literal>Read</literal> and - <literal>Show</literal> instances for up to 15-tuples (used - to be up to 5-tuples). - </para> - </listitem> - <listitem> - <para> - New module <literal>Control.Applicative</literal> that - describes a structure intermediate between a functor and - a monad: it provides pure expressions and sequencing, but - no binding. - </para> - </listitem> - <listitem> - <para> - <literal>Control.Exception</literal> now exports - <literal>bracketOnError</literal>, which behaves like - <literal>bracket</literal> but only runs the final - action if the main action raised an error. - </para> - </listitem> - <listitem> - <para> - There is a new module - <literal>Control.Monad.Instances</literal> which - provides <literal>Monad</literal> and - <literal>Functor</literal> instances for - <literal>((->) r)</literal> (were in - <literal>mtl</literal>'s - <literal>Control.Monad.Reader</literal>), - a <literal>Functor</literal> instance for - <literal>(Either a)</literal> (was in <literal>mtl</literal>'s - <literal>Control.Monad.Error</literal>) and a - <literal>Functor</literal> instance for - <literal>((,) a)</literal> (new). - </para> - </listitem> - <listitem> - <para> - The <literal>MonadFix</literal> instance for - <literal>((->) r)</literal> is now in - <literal>Control.Monad.Fix</literal> (was in - <literal>mtl</literal>'s - <literal>Control.Monad.Reader</literal>). - </para> - </listitem> - <listitem> - <para> - <literal>Control.Monad.ST</literal> now exports - <literal>unsafeSTToIO</literal>. - </para> - </listitem> - <listitem> - <para> - The <literal>HasBounds</literal> class has been removed from - <literal>Data.Array.Base</literal>, and its - <literal>bounds</literal> method is now in the - <literal>IArray</literal> class. The - <literal>MArray</literal> class - has also gained a method <literal>getBounds</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>Data.Array.Base</literal> now provides an - <literal>MArray (STArray s) e (Lazy.ST s)</literal> - instance. - </para> - </listitem> - <listitem> - <para> - <literal>Data.Array.Storable</literal> now exports a - function <literal>unsafeForeignPtrToStorableArray</literal>. - </para> - </listitem> - <listitem> - <para> - The new <literal>Data.ByteString</literal> hierarchy - provides time and space-efficient byte vectors. - The old <literal>Data.PackedString</literal> module is now - deprecated as a result, although there is not yet a - replacement if you need full unicode support. - </para> - </listitem> - <listitem> - <para> - <literal>GHC.Exts</literal> now provides a function - <literal>inline</literal> which, provided the RHS is visible - to the compiler, forcibly inlines its argument. - Otherwise, it acts like <literal>id</literal>. - For more details, see <xref linkend="special-ids" />. - </para> - </listitem> - <listitem> - <para> - <literal>GHC.Exts</literal> now provides a function - <literal>lazy</literal>, where <literal>lazy f</literal> - behaves like <literal>f</literal>, except GHC is forced - to believe that it is lazy in its first argument. - For more details, see <xref linkend="special-ids" />. - </para> - </listitem> - <listitem> - <para> - <literal>Data.FiniteMap</literal> has been removed - (deprecated since 6.4). Use <literal>Data.Map</literal> - instead. - </para> - </listitem> - <listitem> - <para> - <literal>Data.Char</literal> now exports - <literal>isLetter</literal>, - <literal>isMark</literal>, - <literal>isNumber</literal>, - <literal>isPunctuation</literal>, - <literal>isSymbol</literal>, - <literal>isSeparator</literal>, - <literal>isAsciiUpper</literal>, - <literal>isAsciiLower</literal> and - <literal>toTitle</literal>. - It also exports a function - <literal>generalCategory</literal> that tells you the - category of a character in terms of a datatype - <literal>GeneralCategory</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>Data.Dynamic</literal> now exports a function - <literal>dynTypeRep</literal>. - </para> - </listitem> - <listitem> - <para> - There is a new module <literal>Data.Eq</literal> which - just exports the <literal>Eq</literal> class. - Likewise, a new module <literal>Data.Ord</literal> - exports the <literal>Ord</literal> class, as well as the - handy <literal>comparing</literal> function. - </para> - </listitem> - <listitem> - <para> - There is a new module <literal>Data.Fixed</literal> - providing fixed-precision arithmetic. - </para> - </listitem> - <listitem> - <para> - There is a new module <literal>Data.Foldable</literal> - providing a class for foldable datatypes. It gives instances - for <literal>Maybe</literal>, <literal>[]</literal> and - <literal>Array i</literal>. - </para> - </listitem> - <listitem> - <para> - There is a new module <literal>Data.Traversable</literal> - providing a class for data structures that can be traversed - from left to right. It gives instances - for <literal>Maybe</literal>, <literal>[]</literal> and - <literal>Array i</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>Data.FunctorM</literal> has been deprecated; - use <literal>Data.Foldable</literal> and - <literal>Data.Traversable</literal> instead. - </para> - </listitem> - <listitem> - <para> - The <literal>toConstr</literal> definitions for tuples in - <literal>Data.Generics.Instances</literal> now actually - evaluate their arguments to tuples before returning - anything. - </para> - </listitem> - <listitem> - <para> - <literal>Data.IntMap</literal> now exports - <literal>notMember</literal>, - <literal>alter</literal>, - <literal>mapMaybe</literal>, - <literal>mapMaybeWithKey</literal>, - <literal>mapEither</literal> and - <literal>mapEitherWithKey</literal>. - It also has <literal>Monoid</literal>, - <literal>Foldable</literal> and <literal>Read</literal> - instances. - </para> - </listitem> - <listitem> - <para> - <literal>Data.IntSet</literal> now exports - <literal>notMember</literal>. It also has - <literal>Monoid</literal> and <literal>Read</literal> - instances. - </para> - </listitem> - <listitem> - <para> - <literal>Data.Map</literal> now exports - <literal>notMember</literal>, - <literal>alter</literal>, - <literal>mapMaybe</literal>, - <literal>mapMaybeWithKey</literal>, - <literal>mapEither</literal>, - <literal>mapEitherWithKey</literal>, - <literal>minView</literal> and - <literal>maxView</literal>. - It also has <literal>Monoid</literal>, - <literal>Traversable</literal>, <literal>Foldable</literal> - and <literal>Read</literal> instances. - </para> - </listitem> - <listitem> - <para> - <literal>Data.Set</literal> now exports - <literal>notMember</literal>, - <literal>minView</literal> and - <literal>maxView</literal>. - It also has <literal>Monoid</literal>, - <literal>Foldable</literal> - and <literal>Read</literal> instances. - </para> - - <para> - The old, deprecated (since 6.4) interface consisting of - <literal>emptySet</literal>, - <literal>mkSet</literal>, - <literal>setToList</literal>, - <literal>unitSet</literal>, - <literal>elementOf</literal>, - <literal>isEmptySet</literal>, - <literal>cardinality</literal>, - <literal>unionManySets</literal>, - <literal>minusSet</literal>, - <literal>mapSet</literal>, - <literal>intersect</literal>, - <literal>addToSet</literal> and - <literal>delFromSet</literal> has been removed. - </para> - </listitem> - <listitem> - <para> - <literal>Data.Monoid</literal> no longer contains the - <literal>Monoid</literal> - instances for <literal>Map</literal>, - <literal>IntMap</literal>, <literal>Set</literal> and - <literal>IntSet</literal>. They have been moved to their own - modules, as above. The <literal>(a -> a)</literal> instance - has been replaced with a - <literal>Monoid b => Monoid (a -> b)</literal> instance. - The module also now exports - <literal>Dual</literal>, - <literal>Endo</literal>, - <literal>All</literal>, - <literal>Any</literal>, - <literal>Sum</literal> and - <literal>Product</literal> types, and - <literal>Monoid</literal> instances for them. - </para> - </listitem> - <listitem> - <para> - There is a new module <literal>Data.Sequence</literal> - for finite sequences. The <literal>Data.Queue</literal> - module is now deprecated in favour of this faster, more - featureful replacement. - </para> - </listitem> - <listitem> - <para> - <literal>Data.Tree</literal> now has - <literal>Data</literal>, <literal>Typeable</literal>, - <literal>Traversable</literal> and - <literal>Foldable</literal> - instances for the - <literal>Tree</literal> datatype. - </para> - </listitem> - <listitem> - <para> - <literal>Data.Typeable</literal> now uses - <option>-fallow-overlapping-instances</option>, so the - generic instances can be overriden for your own datatypes. - </para> - </listitem> - <listitem> - <para> - <literal>Debug.Trace</literal> now exports - <literal>traceShow</literal>, which is the same as - <literal>trace</literal> except its first argument can be - any showable thing rather than being required to be a - string. - </para> - </listitem> - <listitem> - <para> - <literal>Foreign.C.Types</literal> now also defines - <literal>CIntPtr</literal>, - <literal>CUIntPtr</literal>, - <literal>CIntMax</literal> and - <literal>CUIntMax</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>Foreign.ForeignPtr</literal> now exports - <literal>FinalizerEnvPtr</literal>, - <literal>newForeignPtrEnv</literal> and - <literal>addForeignPtrFinalizerEnv</literal>. - Together, these allow the use of finalizers which are passed - an additional environment parameter. - </para> - </listitem> - <listitem> - <para> - <literal>Foreign.Marshal.Utils</literal> no longer exports - the <literal>withObject</literal> function, deprecated since - 5.04; use <literal>with</literal> instead. - </para> - </listitem> - <listitem> - <para> - Foreign.Ptr now also defines - <literal>IntPtr</literal>, - <literal>ptrToIntPtr</literal>, - <literal>intPtrToPtr</literal>, - <literal>WordPtr</literal>, - <literal>ptrToWordPtr</literal> and - <literal>wordPtrToPtr</literal>. - </para> - </listitem> - <listitem> - <para> - There are now <literal>Bounded</literal> instances for up to - 15-tuples (used to be up to 4-tuples). - </para> - </listitem> - <listitem> - <para> - The <literal>Text.Html</literal> and - <literal>Text.Html.BlockTable</literal> modules have now - been removed, with the new <literal>html</literal> and - <literal>xhtml</literal> packages providing replacements. - </para> - </listitem> - <listitem> - <para> - <literal>Text.Read</literal> now exports a function - <literal>parens</literal> which parses a value in an - arbitrary number of parentheses. - </para> - </listitem> - <listitem> - <para> - The <literal>ForeignPtr</literal> datatype has been altered - to make it more efficient. There are also new functions - <literal>mallocPlainForeignPtr</literal> and - <literal>mallocPlainForeignPtrBytes</literal> which - do not allow you to attach a finalizer to the - <literal>ForeignPtr</literal>. - </para> - </listitem> - <listitem> - <para> - The <literal>Text.Regex</literal> and - <literal>Text.Regex.Posix</literal> modules have been removed. - Instead, use the new <literal>regex-compat</literal> package - for a drop-in <literal>Text.Regex</literal> replacement, or - the new library in the new <literal>regex-posix</literal> - package. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>Cabal</title> - <itemizedlist> - <listitem> - <para> - Version number 1.1.6 (was 1.1.4). - </para> - </listitem> - <listitem> - <para> - Support for JHC, symmetric to the support for the other - implementations, has been added throughout. - </para> - </listitem> - <listitem> - <para> - Support for object splitting and building in-place - has been added throughout. - </para> - </listitem> - <listitem> - <para> - Added a <filename>debianTemplate</filename> directory with - templates for building Debian packages from Cabal packages. - </para> - </listitem> - <listitem> - <para> - There are now modules - <literal>Distribution.Simple.<replaceable>compiler</replaceable></literal> - for each of <literal>GHC</literal>, <literal>NHC</literal>, - <literal>Hugs</literal> and <literal>JHC</literal>. - The <literal>Distribution.Simple.Build</literal> and - <literal>Distribution.Simple.Install</literal> modules have - shrunk correspondingly. - </para> - </listitem> - <listitem> - <para> - <literal>Distribution.GetOpt</literal> is no longer a - visible module. - </para> - </listitem> - <listitem> - <para> - <literal>Distribution.Simple</literal> exports a function - <literal>defaultMainArgs</literal>, which is identical to - <literal>defaultMain</literal> except that the arguments are - given as a list of strings rather than being retrieved with - <literal>getArgs</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>Distribution.Simple.Configure</literal> - no longer exports - <literal>LocalBuildInfo</literal>, - but does now export - <literal>configDependency</literal> and - <literal>configCompilerAux</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>Distribution.Simple.LocalBuildInfo</literal> now - exports <literal>mkHaddockDir</literal>, - <literal>distPref</literal>, - <literal>srcPref</literal>, - <literal>autogenModulesDir</literal> and - <literal>mkIncludeDir</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>Distribution.PackageDescription</literal> now - exports <literal>haddockName</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>Distribution.Simple.Utils</literal> now exports - <literal>copyDirectoryRecursiveVerbose</literal>, - <literal>dirOf</literal>, - <literal>distPref</literal>, - <literal>haddockPref</literal> and - <literal>srcPref</literal>. - It no longer exports <literal>mkGHCiLibName</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>haskell98</title> - <itemizedlist> - <listitem> - <para> - No change (version 1.0). - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>parsec</title> - <itemizedlist> - <listitem> - <para> - Version number 2.0 (was 1.0). - </para> - </listitem> - <listitem> - <para> - No other change. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>readline</title> - <itemizedlist> - <listitem> - <para> - No change (version 1.0). - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>regex-base</title> - <itemizedlist> - <listitem> - <para> - Version 0.71. - </para> - </listitem> - <listitem> - <para> - New library that provides common functions for different - regex backends. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>regex-compat</title> - <itemizedlist> - <listitem> - <para> - Version 0.71. - </para> - </listitem> - <listitem> - <para> - New package providing a replacement - <literal>Text.Regex</literal> module. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>regex-posix</title> - <itemizedlist> - <listitem> - <para> - Version 0.71. - </para> - </listitem> - <listitem> - <para> - A new package providing POSIX regexes. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>stm</title> - <itemizedlist> - <listitem> - <para> - Version number 2.1 (was 1.0). - </para> - </listitem> - <listitem> - <para> - A new module <literal>Control.Monad.STM</literal> - contains the - <literal>MonadPlus</literal> instance for - <literal>STM</literal> and the function - <literal>check</literal> (both used to be in - <literal>Control.Concurrent.STM</literal>). - It also re-exports - <literal>STM</literal>, - <literal>atomically</literal>, - <literal>retry</literal>, - <literal>orElse</literal> and - <literal>catchSTM</literal>. - </para> - </listitem> - <listitem> - <para> - A new module - <literal>Control.Concurrent.STM.TArray</literal> defines - <literal>TArray</literal>, a transactional array, and makes - it an instance of <literal>MArray</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>Control.Concurrent.STM.TChan</literal> now provides - a function <literal>newTChanIO</literal>, which allows - <literal>TChan</literal>s to be created in the IO monad. - Similarly, <literal>Control.Concurrent.STM.TMVar</literal> - provides <literal>newTMVarIO</literal> and - <literal>newEmptyTMVarIO</literal>, and - <literal>Control.Concurrent.STM.TVar</literal> exports - <literal>newTVarIO</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>Control.Concurrent.STM.TVar</literal> exports - <literal>registerDelay</literal>. - </para> - </listitem> - <listitem> - <para> - The <literal>Control.Concurrent.STM</literal> module has been - updated to re-export all the new modules. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>template-haskell</title> - <itemizedlist> - <listitem> - <para> - Version number 2.0 (was 1.0). - </para> - </listitem> - <listitem> - <para> - A <literal>Show</literal> instance is now derived for - <literal>Info</literal>, <literal>Fixity</literal> and - <literal>FixityDirection</literal> in - <literal>Language.Haskell.TH.Syntax</literal>. - </para> - </listitem> - <listitem> - <para> - In <literal>Language.Haskell.TH.Syntax</literal>, there is - a type <literal>PkgName</literal> and functions - <literal>mkPkgName</literal> and - <literal>pkgString</literal> - for dealing with package names. - </para> - </listitem> - <listitem> - <para> - The <literal>patGE</literal> function in - <literal>Language.Haskell.TH.Lib</literal> now takes the - final expression separately to the list of statements - rather than splitting it off itself. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>unix</title> - <itemizedlist> - <listitem> - <para> - No change (version 1.0). - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>Win32</title> - <itemizedlist> - <listitem> - <para> - Version number 2.1 (was 1.0). - </para> - </listitem> - <listitem> - <para> - Now maintained by Esa Ilari Vuokko. - </para> - </listitem> - <listitem> - <para> - There is a new module - <literal>System.Win32.Console</literal> - providing an interface to the Windows Console API. - </para> - </listitem> - <listitem> - <para> - There is a new module - <literal>System.Win32.DebugApi</literal> - providing an interface to the Windows DebugApi. - </para> - </listitem> - <listitem> - <para> - There is a new module - <literal>System.Win32.FileMapping</literal> - for working with memory-mapped files. - </para> - </listitem> - <listitem> - <para> - There is a new module - <literal>System.Win32.SimpleMAPI</literal> - for using the Windows mail API. - </para> - </listitem> - <listitem> - <para> - There is a new module - <literal>System.Win32.Time</literal> - for using the Windows time API. - </para> - </listitem> - <listitem> - <para> - <literal>iNVALID_HANDLE_VALUE</literal> has moved from - <literal>Graphics.Win32.Misc</literal> to - <literal>System.Win32.Types</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>System.Win32.File</literal> has a new - function <literal>getFileInformationByHandle</literal> - and associated data types. - </para> - </listitem> - <listitem> - <para> - <literal>System.Win32.Info</literal> has a new - function <literal>getSystemInfo</literal> and associated - data types. - </para> - </listitem> - <listitem> - <para> - <literal>System.Win32.Process</literal> now has many more - exports. - </para> - </listitem> - <listitem> - <para> - <literal>System.Win32.Types</literal> has new types - <literal>LARGE_INTEGER</literal>, <literal>DDWORD</literal> - and <literal>SIZE_T</literal>. It also has new helper - functions <literal>ddwordToDwords</literal> and - <literal>dwordsToDdword</literal> to split and combine - ddwords into high and low components. - </para> - </listitem> - <listitem> - <para> - <literal>System.Win32</literal> re-exports - <literal>System.Win32.FileMapping</literal>, - <literal>System.Win32.Time</literal> - and <literal>System.Win32.Console</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - </sect2> - - <sect2> - <title>Extra Libraries</title> - <sect3> - <title>ALUT</title> - <itemizedlist> - <listitem> - <para> - Version number 2.0 (was 1.0). - </para> - </listitem> - <listitem> - <para> - <literal>Sound.ALUT.BuiltInSounds</literal> has been removed. - Its <literal>Phase</literal> and <literal>Duration</literal> - exports are now exported by - <literal>Sound.ALUT.Loaders</literal> and its - <literal>helloWorld</literal>, - <literal>sine</literal>, - <literal>square</literal>, - <literal>sawtooth</literal>, - <literal>impulse</literal> and - <literal>whiteNoise</literal> - exports are now constructors of the - <literal>Sound.ALUT.Loaders.SoundDataSource</literal> - datatype. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>arrows</title> - <itemizedlist> - <listitem> - <para> - Version number 0.2 (was 0.1). - </para> - </listitem> - <listitem> - <para> - <literal>Control.Sequence</literal> has been removed in - favour of the new <literal>Control.Applicative</literal> - module in <literal>base</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>cgi</title> - <itemizedlist> - <listitem> - <para> - Version 2006.8.14. - </para> - </listitem> - <listitem> - <para> - <literal>cgi</literal> is a new package, developing on - what used to be <literal>Network.CGI</literal> in the - <literal>network</literal> package. - </para> - </listitem> - <listitem> - <para> - The <literal>Network.CGI.Compat</literal> module provides - a similar interface to the old <literal>Network.CGI</literal> - module, but it uses <literal>Text.XHtml</literal> rather than - <literal>Text.Html</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>fgl</title> - <itemizedlist> - <listitem> - <para> - Version number 5.3 (was 5.2). - </para> - </listitem> - <listitem> - <para> - <literal>Data.Graph.Inductive.Graph</literal> no longer - exports <literal>UContext</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>Data.Graph.Inductive.Graph</literal> now exports - <literal>delLEdge</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>GLUT</title> - <itemizedlist> - <listitem> - <para> - Version number remains 2.0. - </para> - </listitem> - <listitem> - <para> - In <literal>Graphics.UI.GLUT.Initialization</literal>, - <literal>DisplayMode</literal> has a new constructor - <literal>WithAuxBuffers</literal> and - <literal>DisplayCapability</literal> has a new constructor - <literal>DisplayAux</literal>. These represent freeglut-only - features. - </para> - </listitem> - <listitem> - <para> - There are new examples in - <filename>BOGLGP/Chapter03/OnYourOwn1.hs</filename>, - <filename>RedBook/AAIndex.hs</filename>, - <filename>RedBook/AARGB.hs</filename>, - <filename>RedBook/AccAnti.hs</filename>, - <filename>RedBook/AccPersp.hs</filename>, - <filename>RedBook/Alpha3D.hs</filename>, - <filename>RedBook/DOF.hs</filename>, - <filename>RedBook/FogIndex.hs</filename>, - <filename>RedBook/Multisamp.hs</filename>, - <filename>RedBook/PointP.hs</filename>, - <filename>RedBook/PolyOff.hs</filename>, - <filename>RedBook/Stencil.hs</filename>, - <filename>RedBook/Stroke.hs</filename> and - <filename>RedBook/Torus.hs</filename>, - and the examples in - <filename>RedBook/Font.hs</filename> and - <filename>RedBook/Histogram.hs</filename> have been - improved. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>haskell-src</title> - <itemizedlist> - <listitem> - <para> - No change (version 1.0). - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>HGL</title> - <itemizedlist> - <listitem> - <para> - No change (version 3.1). - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>html</title> - <itemizedlist> - <listitem> - <para> - Version 1.0. - </para> - </listitem> - <listitem> - <para> - <literal>html</literal> is a new package, developing on - what used to be <literal>Text.Html</literal> and - <literal>Text.Html.BlockTable</literal> in the - <literal>base</literal> package. - </para> - </listitem> - <listitem> - <para> - <literal>Text.Html.BlockTable</literal> exports a new - function <literal>empty</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>HUnit</title> - <itemizedlist> - <listitem> - <para> - No change (version 1.1). - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>mtl</title> - <itemizedlist> - <listitem> - <para> - No change (version 1.0). - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>network</title> - <itemizedlist> - <listitem> - <para> - Version number 2.0 (was 1.0). - </para> - </listitem> - <listitem> - <para> - <literal>Network.CGI</literal> has been removed; use the - <literal>cgi</literal> package instead. - </para> - </listitem> - <listitem> - <para> - <literal>Network.BSD</literal> no longer exports - <literal>symlink</literal> or <literal>readlink</literal>; - use - <literal>System.Posix.Files.createSymbolicLink</literal> and - <literal>System.Posix.Files.readSymbolicLink</literal> - instead. - </para> - </listitem> - <listitem> - <para> - <literal>Network.BSD</literal> now exports - <literal>defaultProtocol</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>Network.Socket.SocketStatus</literal> now has a - constructor <literal>ConvertedToHandle</literal> for sockets - that have been converted to handles. - </para> - </listitem> - <listitem> - <para> - <literal>Network.Socket.Family</literal> now has the - following additional constructors: - <literal>AF_NETROM</literal>, - <literal>AF_BRIDGE</literal>, - <literal>AF_ATMPVC</literal>, - <literal>AF_ROSE</literal>, - <literal>AF_NETBEUI</literal>, - <literal>AF_SECURITY</literal>, - <literal>AF_PACKET</literal>, - <literal>AF_ASH</literal>, - <literal>AF_ECONET</literal>, - <literal>AF_ATMSVC</literal>, - <literal>AF_IRDA</literal>, - <literal>AF_PPPOX</literal>, - <literal>AF_WANPIPE</literal> and - <literal>AF_BLUETOOTH</literal>. - </para> - </listitem> - <listitem> - <para> - In <literal>Network.URI</literal>, - <literal>parseabsoluteURI</literal> has been deprecated with - a new function <literal>parseAbsoluteURI</literal> taking - its place. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>ObjectIO</title> - <itemizedlist> - <listitem> - <para> - No change (version 1.0). - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>OpenAL</title> - <itemizedlist> - <listitem> - <para> - Version number 1.3 (was 1.2). - </para> - </listitem> - <listitem> - <para> - No other change. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>OpenGL</title> - <itemizedlist> - <listitem> - <para> - Version number 2.1 (was 2.0). - </para> - </listitem> - <listitem> - <para> - No other change. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>QuickCheck</title> - <itemizedlist> - <listitem> - <para> - No change (version 1.0). - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>time</title> - <itemizedlist> - <listitem> - <para> - Version 1.0. - </para> - </listitem> - <listitem> - <para> - <literal>time</literal> is a new package, for dealing with - dates, times and time intervals. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>X11</title> - <itemizedlist> - <listitem> - <para> - Version number 1.2 (was 1.1). - </para> - </listitem> - <listitem> - <para> - In <literal>Graphics.X11.Xlib.Types</literal>, - <literal>XGCValues</literal> has been renamed - <literal>GCValues</literal> and - <literal>XSetWindowAttributes</literal> has been renamed - <literal>SetWindowAttributes</literal>. - </para> - </listitem> - <listitem> - <para> - In <literal>Graphics.X11.Xlib.Misc</literal>, - <literal>allocaXSetWindowAttributes</literal> has been - renamed <literal>allocaSetWindowAttributes</literal>. - </para> - </listitem> - <listitem> - <para> - The <literal>FontStruct</literal> type has moved from - <literal>Graphics.X11.Xlib.Types</literal> to - <literal>Graphics.X11.Xlib.Font</literal>. - </para> - </listitem> - <listitem> - <para> - The - <literal>Point</literal>, - <literal>Rectangle</literal>, - <literal>Arc</literal>, - <literal>Segment</literal> and - <literal>Color</literal> types in - <literal>Graphics.X11.Xlib.Types</literal> - are now proper datatypes rather than synonyms for tuples. - They all have a <literal>Storable</literal> instance. - </para> - </listitem> - <listitem> - <para> - The <literal>Byte</literal> and <literal>Short</literal> - types from <literal>Graphics.X11.Xlib.Types</literal> have - been removed. - The following type synonyms, which had already been marked - "Backwards compatibility", have also been removed: - <literal>ListPoint</literal>, - <literal>ListRectangle</literal>, - <literal>ListArc</literal>, - <literal>ListSegment</literal> and - <literal>ListColor</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>Eq</literal>, - <literal>Ord</literal>, - <literal>Show</literal>, - <literal>Typeable</literal> and - <literal>Data</literal> are now derived for: - <literal>XEvent</literal>, - <literal>FdSet</literal> and - <literal>TimeZone</literal> in - <literal>Graphics.X11.Xlib.Event</literal>, - <literal>FontStruct</literal> in - <literal>Graphics.X11.Xlib.Font</literal>, - <literal>XErrorEvent</literal>, - <literal>XComposeStatus</literal> and - <literal>XTextProperty</literal> in - <literal>Graphics.X11.Xlib.Misc</literal>, - <literal>Region</literal> in - <literal>Graphics.X11.Xlib.Region</literal>, - <literal>Display</literal>, - <literal>Screen</literal>, - <literal>Visual</literal>, - <literal>GC</literal>, - <literal>GCValues</literal>, - <literal>SetWindowAttributes</literal>, - <literal>Point</literal>, - <literal>Rectangle</literal>, - <literal>Arc</literal>, - <literal>Segment</literal> and - <literal>Color</literal> in - <literal>Graphics.X11.Xlib.Types</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>xhtml</title> - <itemizedlist> - <listitem> - <para> - Version 2006.8.14. - </para> - </listitem> - <listitem> - <para> - <literal>xhtml</literal> is a new package, developing on - what used to be <literal>Text.Html</literal> and - <literal>Text.Html.BlockTable</literal> in the - <literal>base</literal> package. - </para> - </listitem> - </itemizedlist> - </sect3> - </sect2> - - <sect2> - <title>GHC As A Library</title> - <para> - Version number 6.6. - </para> - <para> - The internal modules of GHC are now available as a library, package - name <literal>ghc</literal>. - The interface has not been designed with use by other programs - in mind, so expect the API to vary radically in future - releases. - </para> - <para> - An introduction to using the library can be found - <ulink url="http://www.haskell.org/haskellwiki/GHC/As_a_library">on the wiki</ulink>. - </para> - </sect2> - - <sect2> - <title>Internal changes</title> - <itemizedlist> - <listitem> - <para> - GHC development now has its own integrated - <ulink url="http://hackage.haskell.org/trac/ghc">wiki and bug - tracker</ulink>. - </para> - </listitem> - <listitem> - <para> - GHC has now moved to darcs. See - <ulink - url="http://hackage.haskell.org/trac/ghc/wiki/GhcDarcs">the - wiki</ulink> for more details. The sources have moved around a - bit within the tree as a result, most notably the GHC sources - are no longer kept within a <filename>ghc/</filename> - subdirectory. - </para> - </listitem> - <listitem> - <para> - The native code generator is now capable of compiling loops, - which gets us a big step closer to being able to compile - entirely without gcc on well-supported arches. - </para> - </listitem> - </itemizedlist> - </sect2> -</sect1> - diff --git a/docs/users_guide/7.0.1-notes.xml b/docs/users_guide/7.0.1-notes.xml deleted file mode 100644 index 4d3e2994e6..0000000000 --- a/docs/users_guide/7.0.1-notes.xml +++ /dev/null @@ -1,1226 +0,0 @@ -<?xml version="1.0" encoding="iso-8859-1"?> -<sect1 id="release-7-0-1"> - <title>Release notes for version 7.0.1</title> - - <para> - The significant changes to the various parts of the compiler are - listed in the following sections. There have also been numerous bug - fixes and performance improvements over the 6.12 branch. - </para> - - <sect2> - <title>Highlights</title> - <itemizedlist> - <listitem> - <para> - GHC now defaults to the Haskell 2010 language standard. - </para> - - <para> - Libraries are not quite so straightforward. By default, GHC - provides access to the <literal>base</literal> package, - which includes the Haskell 2010 libraries, albeit with a few - minor differences. For those who want to write strictly - standards-conforming code we also provide - the <literal>haskell2010</literal> package which provides - the precise APIs specified by Haskell 2010, but because the - module names in this package overlap with those in - the <literal>base</literal> package it is not possible to - use both <literal>haskell2010</literal> - and <literal>base</literal> at the same time (this also - applies to the <literal>array</literal> package). Hence to use - the Haskell 2010 libraries you should hide - the <literal>base</literal> and <literal>array</literal> - packages, for example with GHCi: -<screen> -$ ghci -package haskell2010 -hide-package base -hide-package array -</screen> - If you are using Cabal it isn't necessary to - hide <literal>base</literal> and <literal>array</literal> - explicitly, just don't include them in your <literal>build-depends</literal>. - </para> - </listitem> - - <listitem> - <para> - On POSIX platforms, there is a new I/O manager based on - epoll/kqueue/poll, which allows multithreaded I/O code to - scale to a much larger number (100k+) of threads. - </para> - </listitem> - - <listitem> - <para> - GHC now includes an LLVM code generator. For certain code, - particularly arithmetic heavy code, using the LLVM code - generator can bring some nice performance improvements. - </para> - </listitem> - - <listitem> - <para> - The type checker has been overhauled, which means it is now - able to correctly handle interactions between the type system - extensions. - </para> - </listitem> - - <listitem> - <para> - The inliner has been overhauled, which should in general - give better performance while reducing unnecessary code-size - explosion. - </para> - </listitem> - - <listitem> - <para> - Large parts of the runtime system have been overhauled, in - particular the machinery related to blocking and wakeup of - threads and exception throwing (<literal>throwTo</literal>). - Several instances of pathological performance have been - fixed, especially where large numbers of threads are - involved. - </para> - </listitem> - - <listitem> - <para> - Due to changes in the runtime system, if you are - using <literal>Control.Parallel.Strategies</literal> from - the <literal>parallel</literal> package, please upgrade to - at least version 2 (preferably version 3). The - implementation of Strategies - in <literal>parallel-1.x</literal> will lose parallelism - with GHC 7.0.1. - </para> - </listitem> - - <listitem> - <para> - The full Haskell <literal>import</literal> syntax can now been - used to bring modules into scope in GHCi, e.g. - </para> -<programlisting> -Prelude> import Data.List as L -Prelude Data.List> L.length "foo" -3 -</programlisting> - </listitem> - - <listitem> - <para> - GHC now comes with a more recent mingw bundled on Windows, - which includes a fix for windres on Windows 7. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Language changes</title> - <itemizedlist> - <listitem> - <para> - GHC now understands the <literal>Haskell98</literal> and - <literal>Haskell2010</literal> languages. - </para> - - <para> - These get processed before the language extension pragmas, - and define the default sets of extensions that are enabled. - If neither is specified, then the default is - <literal>Haskell2010</literal> plus the - <literal>MonoPatBinds</literal> extension. - </para> - </listitem> - - <listitem> - <para> - GHC now supports the <literal>DoAndIfThenElse</literal> - extension, which is part of the Haskell 2010 standard. - </para> - </listitem> - - <listitem> - <para> - Datatype contexts, such as the <literal>Eq a</literal> in - </para> -<programlisting> -data Eq a => Set a = NilSet | ConsSet a (Set a) -</programlisting> - <para> - are now treated as an extension - <literal>DatatypeContexts</literal> (on by default) by GHC. - </para> - </listitem> - - <listitem> - <para> - GHC's support for unicode source has been improved, including - removing support for U+22EF for the <literal>..</literal> - symbol. See <xref linkend="unicode-syntax" /> for more details. - </para> - </listitem> - - <listitem> - <para> - Pragmas are now reread after preprocessing. In particular, - this means that if a pragma is used to turn CPP on, then other - pragmas can be put in CPP conditionals. - </para> - </listitem> - - <listitem> - <para> - The <literal>TypeOperators</literal> extension now allows - instance heads to use infix syntax. - </para> - </listitem> - - <listitem> - <para> - The <literal>PackageImports</literal> extension now understands - <literal>this</literal> to mean the current package. - </para> - </listitem> - - <listitem> - <para> - The <literal>INLINE</literal> and <literal>NOINLINE</literal> - pragmas can now take a <literal>CONLIKE</literal> modifier, - which indicates that the right hand side is cheap to compute, - and can thus be duplicated more freely. - See <xref linkend="conlike" /> for more details. - </para> - </listitem> - - <listitem> - <para> - A <literal>ForceSpecConstr</literal> annotation on a type, e.g. - </para> -<programlisting> -import SpecConstr -{-# ANN type SPEC ForceSpecConstr #-} -</programlisting> - <para> - can be used to force GHC to fully specialise argument of that - type. - </para> - </listitem> - - <listitem> - <para> - A <literal>NoSpecConstr</literal> annotation on a type, e.g. - </para> -<programlisting> -import SpecConstr -{-# ANN type T NoSpecConstr #-} -</programlisting> - <para> - can be used to prevent SpecConstr from specialising on - arguments of that type. - </para> - </listitem> - - <listitem> - <para> - There is are two experimental new extensions - <literal>AlternativeLayoutRule</literal> and - <literal>AlternativeLayoutRuleTransitional</literal>, - which are for exploring alternative layout rules in Haskell'. - The details are subject to change, so we advise against using - them in real code for now. - </para> - </listitem> - - <listitem> - <para> - The <literal>NewQualifiedOperators</literal> extension has - been deprecated, as it was rejected by the Haskell' committee. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Warnings</title> - <itemizedlist> - <listitem> - <para> - There is now a warning for missing import lists, controlled - by the new <literal>-fwarn-missing-import-lists</literal> flag. - </para> - </listitem> - - <listitem> - <para> - GHC will now warn about <literal>SPECIALISE</literal> and - <literal>UNPACK</literal> pragmas that have no effect. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>DLLs</title> - <itemizedlist> - <listitem> - <para> - Shared libraries are once again supported on Windows. - </para> - </listitem> - - <listitem> - <para> - Shared libraries are now supported on OS X, both on x86 and on - PowerPC. The new <literal>-dylib-install-name</literal> GHC - flag is used to set the location of the dynamic library. - See <xref linkend="finding-shared-libs" /> for more details. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Runtime system</title> - - <itemizedlist> - <listitem> - <para> - For security reasons, by default, the only RTS flag that - programs accept is <literal>+RTS --info</literal>. If you want - the full range of RTS flags then you need to link with the new - <literal>-rtsopts</literal> flag. See - <xref linkend="options-linker" /> for more details. - </para> - </listitem> - - <listitem> - <para> - The RTS now exports a function <literal>setKeepCAFs</literal> - which is important when loading Haskell DLLs dynamically, as - a DLL may refer to CAFs that have already been GCed. - </para> - </listitem> - - <listitem> - <para> - The garbage collector no longer allows you to specify a number - of steps; there are now always 2. The <literal>-T</literal> - RTS flag has thus been removed. - </para> - </listitem> - - <listitem> - <para> - A new RTS flag <literal>-H</literal> causes the RTS to use a - larger nursery, but without exceeding the amount of memory - that the application is already using. It makes some programs - go slower, but others go faster. - </para> - </listitem> - - <listitem> - <para> - GHC now returns memory to the OS, if memory usage peaks and - then drops again. This is mainly useful for long running - processes which normally use very little memory, but - occasionally need a lot of memory for a short period of time. - </para> - </listitem> - - <listitem> - <para> - On OS X, eventLog events are now available as DTrace probes. - </para> - </listitem> - - <listitem> - <para> - The PAPI support has been improved. The new RTS flag - <literal>-a#0x40000000</literal> can be used to tell the RTS - to collect the native PAPI event <literal>0x40000000</literal>. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Compiler</title> - <itemizedlist> - <listitem> - <para> - GHC now defaults to <literal>--make</literal> mode, i.e. GHC - will chase dependencies for you automatically by default. - </para> - </listitem> - - <listitem> - <para> - GHC now includes an LLVM code generator. - </para> - <para> - This includes a number of new flags: - a flag to tell GHC to use LLVM, <literal>-fllvm</literal>; - a flag to dump the LLVM input ,<literal>-ddump-llvm</literal>; - flags to keep the LLVM intermediate files, - <literal>-keep-llvm-file</literal> and - <literal>-keep-llvm-files</literal>; - flags to set the location and options for the LLVM optimiser - and compiler, - <literal>-pgmlo</literal>, - <literal>-pgmlc</literal>, - <literal>-optlo</literal> and - <literal>-optlc</literal>. - The LLVM code generator requires LLVM version 2.7 or later on - your path. - </para> - </listitem> - - <listitem> - <para> - It is now possible to use <literal>-fno-code</literal> with - <literal>--make</literal>. - </para> - </listitem> - - <listitem> - <para> - The new flag <literal>-dsuppress-coercions</literal> controls - whether GHC prints coercions in core dumps. - </para> - </listitem> - - <listitem> - <para> - The new flag <literal>-dsuppress-module-prefixes</literal> - controls whether GHC prints module qualification prefixes - in core dumps. - </para> - </listitem> - - <listitem> - <para> - The inliner has been overhauled. The most significant - user-visible change is that only saturated functions are - inlined, e.g. - </para> -<programlisting> -(.) f g x = f (g x) -</programlisting> - <para> - would only be inlined if <literal>(.)</literal> is applied to 3 - arguments, while - </para> -<programlisting> -(.) f g = \x -> f (g x) -</programlisting> - <para> - will be inlined if only applied to 2 arguments. - </para> - </listitem> - - <listitem> - <para> - The <literal>-finline-if-enough-args</literal> flag is no - longer supported. - </para> - </listitem> - - <listitem> - <para> - Column numbers in warnings and error messages now start at 1, - as is more standard, rather than 0. - </para> - </listitem> - - <listitem> - <para> - GHCi now understands most linker scripts. In particular, this - means that GHCi is able to load the C pthread library. - </para> - </listitem> - - <listitem> - <para> - The <literal>ghc --info</literal> output has been updated: - </para> - <para> - It now includes the - location of the global package database, in the - <literal>Global Package DB</literal> field. - </para> - <para> - It now includes the build, host and target platforms, in the - <literal>Build platform</literal>, - <literal>Host platform</literal> and - <literal>Target platform</literal> fields. - </para> - <para> - It now includes a <literal>Have llvm code generator</literal> - field. - </para> - <para> - The <literal>Win32 DLLs</literal> field has been removed. - </para> - </listitem> - - <listitem> - <para> - The registerised via-C backend, and the - <literal>-fvia-C</literal> flag, have been deprecated. The poor - floating-point performance in the x86 native code generator - has now been fixed, so we don't believe there is still any - reason to use the via-C backend. - </para> - </listitem> - - <listitem> - <para> - There is now a new flag <literal>--supported-extensions</literal>, - which currently behaves the same as - <literal>--supported-languages</literal>. - </para> - </listitem> - - <listitem> - <para> - GHC progress output such as - </para> -<programlisting> -[ 1 of 5] Compiling Foo ( Foo.hs, Foo.o ) -</programlisting> - <para> - is now sent to stdout rather than stderr. - </para> - </listitem> - - <listitem> - <para> - The new flag <literal>-fexpose-all-unfoldings</literal> - makes GHC put unfoldings for <emphasis>everything</emphasis> - in the interface file. - </para> - </listitem> - - <listitem> - <para> - There are two new flags, <literal>-fno-specialise</literal> - and <literal>-fno-float-in</literal>, for disabling the - specialise and float-in passes. - </para> - </listitem> - - <listitem> - <para> - The new flag <literal>-fstrictness-before=<replaceable>n</replaceable></literal> tells - GHC to run an additional strictness analysis pass - before simplifier phase <replaceable>n</replaceable>. - </para> - </listitem> - - <listitem> - <para> - There is a new flag - <literal>-funfolding-dict-discount</literal> - for tweaking the optimiser's behaviour. - </para> - </listitem> - - <listitem> - <para> - The <literal>-fspec-inline-join-points</literal> flag has been - removed. - </para> - </listitem> - - <listitem> - <para> - The <literal>-dynload wrapper</literal> flag has been - removed. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>GHCi</title> - <itemizedlist> - <listitem> - <para> - GHCi now understands layout in multi-line commands, so - this now works: - </para> -<programlisting> -Prelude> :{ -Prelude| let x = 1 -Prelude| y = 2 in x + y -Prelude| :} -3 -</programlisting> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Template Haskell and Quasi-Quoters</title> - <itemizedlist> - <listitem> - <para> - It is now possible to quasi-quote patterns with - <literal>[p| ... |]</literal>. - </para> - </listitem> - - <listitem> - <para> - It is no longer to use a <literal>$</literal> before the - name of a quasi-quoter, e.g. one can now say - <literal>[expr| ... |]</literal> rather than - <literal>[$expr| ... |]</literal>. - </para> - </listitem> - - <listitem> - <para> - It is now possible to use a quasi-quoter for types, e.g. - <literal>f :: [$qq| ... |]</literal> - </para> - </listitem> - - <listitem> - <para> - It is now possible to quasi-quote existentials and GADTs. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>GHC API</title> - <itemizedlist> - <listitem> - <para> - There are now <literal>Data</literal> and - <literal>Typeable</literal> instances for the - HsSyn typed. - </para> - </listitem> - - <listitem> - <para> - As language extensions are not applied until after the base - language (Haskell98, Haskell2010 or the default) has been - selected, it is now necessary to tell the GHC API the point - at which the extension flags should be processed. Normally - this is done by calling - <literal>DynFlags.flattenExtensionFlags</literal> once all - the flags and pragmas have been read. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Libraries</title> - - <sect3> - <title>array</title> - <itemizedlist> - <listitem> - <para> - Version number 0.3.0.2 (was 0.3.0.1) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>base</title> - <itemizedlist> - <listitem> - <para> - Version number 4.3.0.0 (was 4.2.0.2) - </para> - </listitem> - - <listitem> - <para> - There is a new asynchronous exception control API - in <literal>Control.Exception</literal>, using the - new functions - <literal>mask :: ((forall a. IO a -> IO a) -> IO b) -> IO b</literal> - and <literal>mask_ :: IO a -> IO a</literal> - rather than the old - <literal>block</literal> and <literal>unblock</literal>. - There are also functions - <literal>uninterruptibleMask :: ((forall a. IO a -> IO a) -> IO b) -> IO b</literal> - and - <literal>getMaskingState :: IO MaskingState</literal>, - and a type - <literal>MaskingState</literal>, as well as - <literal>forkIOUnmasked :: IO () -> IO ThreadId</literal> - in <literal>Control.Concurrent</literal>. - </para> - </listitem> - - <listitem> - <para> - <literal>Control.Monad</literal> exports a new function - <literal>void :: Functor f => f a -> f ()</literal>. - </para> - </listitem> - - <listitem> - <para> - <literal>Data.Tuple</literal> exports a new function - <literal>swap :: (a,b) -> (b,a)</literal>. - </para> - </listitem> - - <listitem> - <para> - <literal>System.IO</literal> exports a new function - <literal>hGetBufSome :: Handle -> Ptr a -> Int -> IO Int</literal> - which is like <literal>hGetBuf</literal> but can - return short reads. - </para> - </listitem> - - <listitem> - <para> - There is a new function - <literal>mfilter :: MonadPlus m => (a -> Bool) -> m a -> m a</literal> - in - <literal>Control.Monad</literal>. - </para> - </listitem> - - <listitem> - <para> - The <literal>Foreign.Marshal</literal> module now - exports - <literal>unsafeLocalState :: IO a -> a</literal> - as specified by Haskell 2010. - </para> - </listitem> - - <listitem> - <para> - The <literal></literal> - module now exports four new functions specified by - Haskell 2010: - <literal>castCUCharToChar :: CUChar -> Char</literal>, - <literal>castCharToCUChar :: Char -> CUChar</literal>, - <literal>castCSCharToChar :: CSChar -> Char</literal> and - <literal>castCharToCSChar :: Char -> CSChar</literal>. - </para> - </listitem> - - <listitem> - <para> - The <literal>Foreign.Marshal.Alloc</literal> - module now exports - <literal>allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b</literal> - for allocating memory with a particular alignment. - </para> - </listitem> - - <listitem> - <para> - There is a new function - <literal>numSparks :: IO Int</literal> - in <literal>GHC.Conc</literal>. - </para> - </listitem> - - <listitem> - <para> - <literal>Data.Either.partitionEithers</literal> - in now lazier. - </para> - </listitem> - - <listitem> - <para> - There is now a <literal>Typeable</literal> instance for - <literal>Data.Unique.Unique</literal>. - </para> - </listitem> - - <listitem> - <para> - <literal>Control.Concurrent.SampleVar.SampleVar</literal> - is now an abstract type. - </para> - </listitem> - - <listitem> - <para> - There are now - <literal>Applicative</literal>, - <literal>Alternative</literal> and - <literal>MonadPlus</literal> - instances for <literal>STM</literal>. - </para> - </listitem> - - <listitem> - <para> - There are now <literal>Applicative</literal>, - <literal>Monad</literal> and - <literal>MonadFix</literal> - instances for <literal>Either</literal>. - </para> - </listitem> - - <listitem> - <para> - There are now - <literal>Ord</literal>, - <literal>Read</literal> and - <literal>Show</literal> instances for - <literal>Newline</literal> and - <literal>NewlineMode</literal>. - </para> - </listitem> - - <listitem> - <para> - There is now a <literal>Show</literal> instance for - <literal>TextEncoding</literal>. - </para> - </listitem> - - <listitem> - <para> - The <literal>unGetChan</literal> and - <literal>isEmptyChan</literal> functions in - <literal>Control.Concurrent.Chan</literal> are now - deprecated. - <literal>Control.Concurrent.STM.TChan</literal> - should be used instead if you need that - functionality. - </para> - </listitem> - - <listitem> - <para> - The <literal>Read Integer</literal> instance now - matches the standard definition. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>base 3 compat</title> - <itemizedlist> - <listitem> - <para> - We no longer ship a base 3 compat package - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>bin-package-db</title> - <itemizedlist> - <listitem> - <para> - This is an internal package, and should not be used. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>bytestring</title> - <itemizedlist> - <listitem> - <para> - Version number 0.9.1.8 (was 0.9.1.7) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>Cabal</title> - <itemizedlist> - <listitem> - <para> - Version number 1.10.0.0 (was 1.8.0.6) - </para> - </listitem> - - <listitem> - <para> - Many API changes. See the Cabal docs for more information. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>containers</title> - <itemizedlist> - <listitem> - <para> - Version number 0.4.0.0 (was 0.3.0.0) - </para> - </listitem> - - <listitem> - <para> - Strictness is now more consistent, with containers - being strict in their elements even in singleton - cases. - </para> - </listitem> - - <listitem> - <para> - There is a new function - <literal>insertLookupWithKey'</literal> in - <literal>Data.Map</literal>. - </para> - </listitem> - - <listitem> - <para> - The <literal>foldWithKey</literal> function in - <literal>Data.Map</literal> has been deprecated in - favour of <literal>foldrWithKey</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>directory</title> - <itemizedlist> - <listitem> - <para> - Version number 1.1.0.0 (was 1.0.1.1) - </para> - </listitem> - - <listitem> - <para> - The <literal>System.Directory</literal> module - now exports the <literal>Permissions</literal> type - abstractly. There are also new functions - <literal>setOwnerReadable</literal>, - <literal>setOwnerWritable</literal>, - <literal>setOwnerExecutable</literal> and - <literal>setOwnerSearchable</literal>, and - a new value <literal>emptyPermissions</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title> - dph - (dph-base, dph-par, dph-prim-interface, dph-prim-par, - dph-prim-seq, dph-seq) - </title> - <itemizedlist> - <listitem> - <para> - All the dph packages are version 0.4.0. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>extensible-exceptions</title> - <itemizedlist> - <listitem> - <para> - Version number 0.1.1.2 (was 0.1.1.1) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>filepath</title> - <itemizedlist> - <listitem> - <para> - Version number 1.2.0.0 (was 1.1.0.4) - </para> - </listitem> - - <listitem> - <para> - The current directory is now <literal>"."</literal> - rather than <literal>""</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>ghc-binary</title> - <itemizedlist> - <listitem> - <para> - This is an internal package, and should not be used. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>ghc-prim</title> - <itemizedlist> - <listitem> - <para> - This is an internal package, and should not be used. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>haskell98</title> - <itemizedlist> - <listitem> - <para> - Version number 1.1.0.0 (was 1.0.1.1) - </para> - </listitem> - - <listitem> - <para> - In the <literal>Directory</literal> module, the - <literal>Permissions</literal> type and the - <literal>getPermissions</literal> and - <literal>setPermissions</literal> functions are now - different to their equivalents in - <literal>base:System.Directory</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>haskell2010</title> - <itemizedlist> - <listitem> - <para> - This is a new boot package, version 1.0.0.0. - It is not exposed by default. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>hpc</title> - <itemizedlist> - <listitem> - <para> - Version number 0.5.0.6 (was 0.5.0.5) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>integer-gmp</title> - <itemizedlist> - <listitem> - <para> - Version number 0.2.0.2 (was 0.2.0.1) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>old-locale</title> - <itemizedlist> - <listitem> - <para> - No change (version 1.0.0.2) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>old-time</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.0.6 (was 1.0.0.5) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>pretty</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.1.2 (was 1.0.1.1) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>process</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.1.4 (was 1.0.1.3) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>random</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.0.3 (was 1.0.0.2) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>syb</title> - <itemizedlist> - <listitem> - <para> - The syb package is no longer included with GHC. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>template-haskell</title> - <itemizedlist> - <listitem> - <para> - Version number 2.5.0.0 (was 2.4.0.1) - </para> - </listitem> - - <listitem> - <para> - There is a new type synonym <literal>DecsQ</literal> - in <literal>Language.Haskell.TH.Lib</literal>. - </para> - </listitem> - - <listitem> - <para> - There is a new <literal>StringPrimL</literal> - constructor in - <literal>Language.Haskell.TH.Syntax.Lit</literal>, - and a new helper function - <literal>stringPrimL</literal> for it in - <literal>Language.Haskell.TH.Lib</literal>. - </para> - </listitem> - - <listitem> - <para> - There is a new function <literal>quoteFile</literal> - in <literal>Language.Haskell.TH.Quote</literal>. - </para> - </listitem> - - <listitem> - <para> - The - <literal>Language.Haskell.TH.Quote.QuasiQuoter</literal> - type has two new fields: - <literal>quoteType</literal> and - <literal>quoteDec</literal>. - </para> - </listitem> - - <listitem> - <para> - There is a new <literal>ClassInstance</literal> - type in <literal>Language.Haskell.TH.Syntax</literal>. - The - <literal>Language.Haskell.TH.Syntax.Info.ClassI</literal> - constructor now includes a value of this type, which - allows instance information to be queried via the - new <literal>isClassInstance</literal> - and <literal>classInstances</literal> functions. - There is also a new method - <literal>qClassInstances</literal> in the - <literal>Quasi</literal> class. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>time</title> - <itemizedlist> - <listitem> - <para> - Version number 1.2.0.3 (was 1.1.4) - </para> - </listitem> - - <listitem> - <para> - The types provided by the time package now include - <literal>Data</literal> instances. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>unix</title> - <itemizedlist> - <listitem> - <para> - Version number 2.4.1.0 (was 2.4.0.2) - </para> - </listitem> - - <listitem> - <para> - There are three new helper function in - <literal>System.Posix.Error</literal>: - <literal>throwErrnoPathIfRetry</literal>, - <literal>throwErrnoPathIfNullRetry</literal> and - <literal>throwErrnoPathIfMinus1Retry</literal>. - </para> - </listitem> - - <listitem> - <para> - There are three new functions in - <literal>System.Posix.User</literal>: - <literal>setEffectiveUserID</literal>, - <literal>setEffectiveGroupID</literal> and - <literal>setGroups</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - </sect2> -</sect1> - diff --git a/docs/users_guide/extending_ghc.xml b/docs/users_guide/extending_ghc.xml new file mode 100644 index 0000000000..11cd75d898 --- /dev/null +++ b/docs/users_guide/extending_ghc.xml @@ -0,0 +1,284 @@ +<?xml version="1.0" encoding="iso-8859-1"?> +<chapter id="extending-ghc"> + <title>Extending and using GHC as a Library</title> + + <para>GHC exposes its internal APIs to users through the built-in ghc package. It allows you to write programs that leverage GHC's entire compilation driver, in order to analyze or compile Haskell code programmatically. Furthermore, GHC gives users the ability to load compiler plugins during compilation - modules which are allowed to view and change GHC's internal intermediate representation, Core. Plugins are suitable for things like experimental optimizations or analysis, and offer a lower barrier of entry to compiler development for many common cases.</para> + + <para>Furthermore, GHC offers a lightweight annotation mechanism that you can use to annotate your source code with metadata, which you can later inspect with either the compiler API or a compiler plugin.</para> + + <sect1 id="annotation-pragmas"> + <title>Source annotations</title> + + <para>Annotations are small pragmas that allow you to attach data to identifiers in source code, which are persisted when compiled. These pieces of data can then inspected and utilized when using GHC as a library or writing a compiler plugin.</para> + + <sect2 id="ann-pragma"> + <title>Annotating values</title> + + <indexterm><primary>ANN</primary></indexterm> + + <para>Any expression that has both <literal>Typeable</literal> and <literal>Data</literal> instances may be attached to a top-level value + binding using an <literal>ANN</literal> pragma. In particular, this means you can use <literal>ANN</literal> + to annotate data constructors (e.g. <literal>Just</literal>) as well as normal values (e.g. <literal>take</literal>). + By way of example, to annotate the function <literal>foo</literal> with the annotation <literal>Just "Hello"</literal> + you would do this:</para> + +<programlisting> +{-# ANN foo (Just "Hello") #-} +foo = ... +</programlisting> + + <para> + A number of restrictions apply to use of annotations: + <itemizedlist> + <listitem><para>The binder being annotated must be at the top level (i.e. no nested binders)</para></listitem> + <listitem><para>The binder being annotated must be declared in the current module</para></listitem> + <listitem><para>The expression you are annotating with must have a type with <literal>Typeable</literal> and <literal>Data</literal> instances</para></listitem> + <listitem><para>The <ulink linkend="using-template-haskell">Template Haskell staging restrictions</ulink> apply to the + expression being annotated with, so for example you cannot run a function from the module being compiled.</para> + + <para>To be precise, the annotation <literal>{-# ANN x e #-}</literal> is well staged if and only if <literal>$(e)</literal> would be + (disregarding the usual type restrictions of the splice syntax, and the usual restriction on splicing inside a splice - <literal>$([|1|])</literal> is fine as an annotation, albeit redundant).</para></listitem> + </itemizedlist> + + If you feel strongly that any of these restrictions are too onerous, <ulink url="http://hackage.haskell.org/trac/ghc/wiki/MailingListsAndIRC"> + please give the GHC team a shout</ulink>. + </para> + + <para>However, apart from these restrictions, many things are allowed, including expressions which are not fully evaluated! + Annotation expressions will be evaluated by the compiler just like Template Haskell splices are. So, this annotation is fine:</para> + +<programlisting> +{-# ANN f SillyAnnotation { foo = (id 10) + $([| 20 |]), bar = 'f } #-} +f = ... +</programlisting> + </sect2> + + <sect2 id="typeann-pragma"> + <title>Annotating types</title> + + <indexterm><primary>ANN type</primary></indexterm> + <indexterm><primary>ANN</primary></indexterm> + + <para>You can annotate types with the <literal>ANN</literal> pragma by using the <literal>type</literal> keyword. For example:</para> + +<programlisting> +{-# ANN type Foo (Just "A `Maybe String' annotation") #-} +data Foo = ... +</programlisting> + </sect2> + + <sect2 id="modann-pragma"> + <title>Annotating modules</title> + + <indexterm><primary>ANN module</primary></indexterm> + <indexterm><primary>ANN</primary></indexterm> + + <para>You can annotate modules with the <literal>ANN</literal> pragma by using the <literal>module</literal> keyword. For example:</para> + +<programlisting> +{-# ANN module (Just "A `Maybe String' annotation") #-} +</programlisting> + </sect2> + + </sect1> + + <sect1 id="ghc-as-a-library"> + <title>Using GHC as a Library</title> + + <para>The <literal>ghc</literal> package exposes most of GHC's frontend to users, and thus allows you to write programs that leverage it. This library is actually the same library used by GHC's internal, frontend compilation driver, and thus allows you to write tools that programmatically compile source code and inspect it. Such functionality is useful in order to write things like IDE or refactoring tools. As a simple example, here's a program which compiles a module, much like ghc itself does by default when invoked:</para> + +<programlisting> +import GHC +import GHC.Paths ( libdir ) +import DynFlags ( defaultDynFlags ) + +main = + defaultErrorHandler defaultDynFlags $ do + runGhc (Just libdir) $ do + dflags <- getSessionDynFlags + setSessionDynFlags dflags + target <- guessTarget "test_main.hs" Nothing + setTargets [target] + load LoadAllTargets +</programlisting> + + <para>The argument to <literal>runGhc</literal> is a bit tricky. GHC needs this to find its libraries, so the argument must refer to the directory that is printed by <literal>ghc --print-libdir</literal> for the same version of GHC that the program is being compiled with. Above we therefore use the <literal>ghc-paths</literal> package which provides this for us. </para> + + <para>Compiling it results in:</para> + +<programlisting> +$ cat test_main.hs +main = putStrLn "hi" +$ ghc -package ghc simple_ghc_api.hs +[1 of 1] Compiling Main ( simple_ghc_api.hs, simple_ghc_api.o ) +Linking simple_ghc_api ... +$ ./simple_ghc_api +$ ./test_main +hi +$ +</programlisting> + + <para>For more information on using the API, as well as more samples and references, please see <ulink url="http://haskell.org/haskellwiki/GHC/As_a_library">this Haskell.org wiki page</ulink>.</para> + </sect1> + + <sect1 id="compiler-plugins"> + <title>Compiler Plugins</title> + + <para>GHC has the ability to load compiler plugins at compile time. The feature is similar to the one provided by <ulink url="http://gcc.gnu.org/wiki/plugins">GCC</ulink>, and allows users to write plugins that can inspect and modify the compilation pipeline, as well as transform and inspect GHC's intermediate language, Core. Plugins are suitable for experimental analysis or optimization, and require no changes to GHC's source code to use.</para> + + <para>Plugins cannot optimize/inspect C--, nor can they implement things like parser/front-end modifications like GCC. If you feel strongly that any of these restrictions are too onerous, <ulink url="http://hackage.haskell.org/trac/ghc/wiki/MailingListsAndIRC"> please give the GHC team a shout</ulink>.</para> + + <sect2 id="using-compiler-plugins"> + <title>Using compiler plugins</title> + + <para>Plugins can be specified on the command line with the option <literal>-fplugin=<replaceable>module</replaceable></literal> where <replaceable>module</replaceable> is a module in a registered package that exports a plugin. Arguments can be given to plugins with the command line option <literal>-fplugin-opt=<replaceable>module</replaceable>:<replaceable>args</replaceable></literal>, where <replaceable>args</replaceable> are arguments interpreted by the plugin provided by <replaceable>module</replaceable>.</para> + + <para>As an example, in order to load the plugin exported by <literal>Foo.Plugin</literal> in the package <literal>foo-ghc-plugin</literal>, and give it the parameter "baz", we would invoke GHC like this:</para> + +<programlisting> +$ ghc -fplugin Foo.Plugin -fplugin-opt Foo.Plugin:baz Test.hs +[1 of 1] Compiling Main ( Test.hs, Test.o ) +Loading package ghc-prim ... linking ... done. +Loading package integer-gmp ... linking ... done. +Loading package base ... linking ... done. +Loading package ffi-1.0 ... linking ... done. +Loading package foo-ghc-plugin-0.1 ... linking ... done. +... +Linking Test ... +$ +</programlisting> + + <para>Since plugins are exported by registered packages, it's safe to put dependencies on them in cabal for example, and specify plugin arguments to GHC through the <literal>ghc-options</literal> field.</para> + </sect2> + + <sect2 id="writing-compiler-plugins"> + <title>Writing compiler plugins</title> + + <para>Plugins are modules that export at least a single identifier, <literal>plugin</literal>, of type <literal>GhcPlugins.Plugin</literal>. All plugins should <literal>import GhcPlugins</literal> as it defines the interface to the compilation pipeline.</para> + + <para>A <literal>Plugin</literal> effectively holds a function which installs a compilation pass into the compiler pipeline. By default there is the empty plugin which does nothing, <literal>GhcPlugins.defaultPlugin</literal>, which you should override with record syntax to specify your installation function. Since the exact fields of the <literal>Plugin</literal> type are open to change, this is the best way to ensure your plugins will continue to work in the future with minimal interface impact.</para> + + <para><literal>Plugin</literal> exports a field, <literal>installCoreToDos</literal> which is a function of type <literal>[CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]</literal>. A <literal>CommandLineOption</literal> is effectively just <literal>String</literal>, and a <literal>CoreToDo</literal> is basically a function of type <literal>Core -> Core</literal>. A <literal>CoreToDo</literal> gives your pass a name and runs it over every compiled module when you invoke GHC.</para> + + <para>As a quick example, here is a simple plugin that just does nothing and just returns the original compilation pipeline, unmodified, and says 'Hello':</para> + +<programlisting> +module DoNothing.Plugin (plugin) where +import GhcPlugins + +plugin :: Plugin +plugin = defaultPlugin { + installCoreToDos = install + } + +install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install _ todo = do + putMsgS "Hello!" + return todo +</programlisting> + + <para>Provided you compiled this plugin and registered it in a package (with cabal for instance,) you can then use it by just specifying <literal>-fplugin=DoNothing.Plugin</literal> on the command line, and during the compilation you should see GHC say 'Hello'.</para> + + <sect3 id="coretodo-in-more-detail"> + <title><literal>CoreToDo</literal> in more detail</title> + + <para><literal>CoreToDo</literal> is effectively a data type that describes all the kinds of optimization passes GHC does on Core. There are passes for simplification, CSE, vectorisation, etc. There is a specific case for plugins, <literal>CoreDoPluginPass :: String -> PluginPass -> CoreToDo</literal> which should be what you always use when inserting your own pass into the pipeline. The first parameter is the name of the plugin, and the second is the pass you wish to insert.</para> + + <para><literal>CoreM</literal> is a monad that all of the Core optimizations live and operate inside of.</para> + + <para>A plugin's installation function (<literal>install</literal> in the above example) takes a list of <literal>CoreToDo</literal>s and returns a list of <literal>CoreToDo</literal>. Before GHC begins compiling modules, it enumerates all the needed plugins you tell it to load, and runs all of their installation functions, initially on a list of passes that GHC specifies itself. After doing this for every plugin, the final list of passes is given to the optimizer, and are run by simply going over the list in order.</para> + + <para>You should be careful with your installation function, because the list of passes you give back isn't questioned or double checked by GHC at the time of this writing. An installation function like the following:</para> + +<programlisting> +install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install _ _ = return [] +</programlisting> + + <para>is certainly valid, but also certainly not what anyone really wants.</para> + </sect3> + + <sect3 id="manipulating-bindings"> + <title>Manipulating bindings</title> + + <para>In the last section we saw that besides a name, a <literal>CoreDoPluginPass</literal> takes a pass of type <literal>PluginPass</literal>. A <literal>PluginPass</literal> is a synonym for <literal>(ModGuts -> CoreM ModGuts)</literal>. <literal>ModGuts</literal> is a type that represents the one module being compiled by GHC at any given time.</para> + + <para>A <literal>ModGuts</literal> holds all of the module's top level bindings which we can examine. These bindings are of type <literal>CoreBind</literal> and effectively represent the binding of a name to body of code. Top-level module bindings are part of a <literal>ModGuts</literal> in the field <literal>mg_binds</literal>. Implementing a pass that manipulates the top level bindings merely needs to iterate over this field, and return a new <literal>ModGuts</literal> with an updated <literal>mg_binds</literal> field. Because this is such a common case, there is a function provided named <literal>bindsOnlyPass</literal> which lifts a function of type <literal>([CoreBind] -> CoreM [CoreBind])</literal> to type <literal>(ModGuts -> CoreM ModGuts)</literal>. </para> + + <para>Continuing with our example from the last section, we can write a simple plugin that just prints out the name of all the non-recursive bindings in a module it compiles:</para> + +<programlisting> +module SayNames.Plugin (plugin) where +import GhcPlugins + +plugin :: Plugin +plugin = defaultPlugin { + installCoreToDos = install + } + +install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install _ todo = return (CoreDoPluginPass "Say name" pass : todo) + +pass :: ModGuts -> CoreM ModGuts +pass = bindsOnlyPass (mapM printBind) + where printBind :: CoreBind -> CoreM CoreBind + printBind bndr@(NonRec b _) = do + putMsgS $ "Non-recursive binding named " ++ showSDoc (ppr b) + return bndr + printBind bndr = return bndr +</programlisting> + </sect3> + + <sect3 id="getting-annotations"> + <title>Using Annotations</title> + + <para>Previously we discussed annotation pragmas (<xref linkend="annotation-pragmas"/>), which we mentioned could be used to give compiler plugins extra guidance or information. Annotations for a module can be retrieved by a plugin, but you must go through the modules <literal>ModGuts</literal> in order to get it. Because annotations can be arbitrary instances of <literal>Data</literal> and <literal>Typeable</literal>, you need to give a type annotation specifying the proper type of data to retrieve from the interface file, and you need to make sure the annotation type used by your users is the same one your plugin uses. For this reason, we advise distributing annotations as part of the package which also provides compiler plugins if possible.</para> + + <para>To get the annotations of a single binder, you can use `getAnnotations` and specify the proper type. Here's an example that will print out the name of any top-level non-recursive binding with the <literal>SomeAnn</literal> annotation:</para> + +<programlisting> +{-# LANGUAGE DeriveDataTypeable #-} +module SayAnnNames.Plugin (plugin, SomeAnn) where +import GhcPlugins +import Control.Monad (when) +import Data.Data +import Data.Typeable + +data SomeAnn = SomeAnn deriving (Data, Typeable) + +plugin :: Plugin +plugin = defaultPlugin { + installCoreToDos = install + } + +install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install _ todo = return (CoreDoPluginPass "Say name" pass : todo) + +pass :: ModGuts -> CoreM ModGuts +pass g = mapM_ (printAnn g) (mg_binds g) >> return g + where printAnn :: ModGuts -> CoreBind -> CoreM CoreBind + printAnn guts bndr@(NonRec b _) = do + anns <- annotationsOn guts b :: CoreM [SomeAnn] + when (not $ null anns) $ putMsgS $ "Annotated binding found: " ++ showSDoc (ppr b) + return bndr + printAnn _ bndr = return bndr + +annotationsOn :: Data a => ModGuts -> CoreBndr -> CoreM [a] +annotationsOn guts bndr = do + anns <- getAnnotations deserializeWithData guts + return $ lookupWithDefaultUFM anns [] (varUnique bndr) +</programlisting> + + <para>Please see the GHC API documentation for more about how to use internal APIs, etc.</para> + </sect3> + </sect2> + + </sect1> + +</chapter> + +<!-- Emacs stuff: + ;;; Local Variables: *** + ;;; sgml-parent-document: ("users_guide.xml" "book" "chapter" "sect1") *** + ;;; End: *** + --> diff --git a/docs/users_guide/ffi-chap.xml b/docs/users_guide/ffi-chap.xml index 2fef13515d..c037623a49 100644 --- a/docs/users_guide/ffi-chap.xml +++ b/docs/users_guide/ffi-chap.xml @@ -101,7 +101,9 @@ OK: The problem is that it is not possible in general to interrupt a foreign call safely. However, GHC does provide a way to interrupt blocking system calls which works for - most system calls on both Unix and Windows. A foreign call + most system calls on both Unix and Windows. When the + <literal>InterruptibleFFI</literal> extension is enabled, + a foreign call can be annotated with <literal>interruptible</literal> instead of <literal>safe</literal> or <literal>unsafe</literal>: diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 7ef9e80045..ddec7d79d9 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -933,6 +933,12 @@ <entry><option>-XNoUnliftedFFITypes</option></entry> </row> <row> + <entry><option>-XInterruptibleFFI</option></entry> + <entry>Enable interruptible FFI.</entry> + <entry>dynamic</entry> + <entry><option>-XNoInterruptibleFFI</option></entry> + </row> + <row> <entry><option>-XLiberalTypeSynonyms</option></entry> <entry>Enable <link linkend="type-synonyms">liberalised type synonyms</link>.</entry> <entry>dynamic</entry> @@ -1397,13 +1403,6 @@ </row> <row> - <entry><option>-fmethod-sharing</option></entry> - <entry>Share specialisations of overloaded functions (default)</entry> - <entry>dynamic</entry> - <entry><option>-fno-method-sharing</option></entry> - </row> - - <row> <entry><option>-fdo-eta-reduction</option></entry> <entry>Enable eta-reduction. Implied by <option>-O</option>.</entry> <entry>dynamic</entry> @@ -2016,6 +2015,40 @@ phase <replaceable>n</replaceable></entry> </sect2> <sect2> + <title>Plugin options</title> + + <para><xref linkend="compiler-plugins"/></para> + + <informaltable> + <tgroup cols="4" align="left" colsep="1" rowsep="1"> + <thead> + <row> + <entry>Flag</entry> + <entry>Description</entry> + <entry>Static/Dynamic</entry> + <entry>Reverse</entry> + </row> + </thead> + <tbody> + <row> + <entry><option>-fplugin</option>=<replaceable>module</replaceable></entry> + <entry>Load a plugin exported by a given module</entry> + <entry>static</entry> + <entry>-</entry> + </row> + <row> + <entry><option>-fplugin-opt</option>=<replaceable>module:args</replaceable></entry> + <entry>Give arguments to a plugin module; module must be specified with <option>-fplugin</option></entry> + <entry>static</entry> + <entry>-</entry> + </row> + </tbody> + </tgroup> + </informaltable> + </sect2> + + + <sect2> <title>Replacing phases</title> <para><xref linkend="replacing-phases"/></para> diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 54b7a0f609..3d4b994f72 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -5075,10 +5075,6 @@ class (F a ~ b) => C a b where with the class head. Method signatures are not affected by that process. </para> - <para> - NB: Equalities in superclass contexts are not fully implemented in - GHC 6.10. - </para> </sect3> <sect3 id-="ty-fams-in-instances"> @@ -8100,82 +8096,6 @@ happen. </sect3> </sect2> - <sect2 id="annotation-pragmas"> - <title>ANN pragmas</title> - - <para>GHC offers the ability to annotate various code constructs with additional - data by using three pragmas. This data can then be inspected at a later date by - using GHC-as-a-library.</para> - - <sect3 id="ann-pragma"> - <title>Annotating values</title> - - <indexterm><primary>ANN</primary></indexterm> - - <para>Any expression that has both <literal>Typeable</literal> and <literal>Data</literal> instances may be attached to a top-level value - binding using an <literal>ANN</literal> pragma. In particular, this means you can use <literal>ANN</literal> - to annotate data constructors (e.g. <literal>Just</literal>) as well as normal values (e.g. <literal>take</literal>). - By way of example, to annotate the function <literal>foo</literal> with the annotation <literal>Just "Hello"</literal> - you would do this:</para> - -<programlisting> -{-# ANN foo (Just "Hello") #-} -foo = ... -</programlisting> - - <para> - A number of restrictions apply to use of annotations: - <itemizedlist> - <listitem><para>The binder being annotated must be at the top level (i.e. no nested binders)</para></listitem> - <listitem><para>The binder being annotated must be declared in the current module</para></listitem> - <listitem><para>The expression you are annotating with must have a type with <literal>Typeable</literal> and <literal>Data</literal> instances</para></listitem> - <listitem><para>The <ulink linkend="using-template-haskell">Template Haskell staging restrictions</ulink> apply to the - expression being annotated with, so for example you cannot run a function from the module being compiled.</para> - - <para>To be precise, the annotation <literal>{-# ANN x e #-}</literal> is well staged if and only if <literal>$(e)</literal> would be - (disregarding the usual type restrictions of the splice syntax, and the usual restriction on splicing inside a splice - <literal>$([|1|])</literal> is fine as an annotation, albeit redundant).</para></listitem> - </itemizedlist> - - If you feel strongly that any of these restrictions are too onerous, <ulink url="http://hackage.haskell.org/trac/ghc/wiki/MailingListsAndIRC"> - please give the GHC team a shout</ulink>. - </para> - - <para>However, apart from these restrictions, many things are allowed, including expressions which are not fully evaluated! - Annotation expressions will be evaluated by the compiler just like Template Haskell splices are. So, this annotation is fine:</para> - -<programlisting> -{-# ANN f SillyAnnotation { foo = (id 10) + $([| 20 |]), bar = 'f } #-} -f = ... -</programlisting> - </sect3> - - <sect3 id="typeann-pragma"> - <title>Annotating types</title> - - <indexterm><primary>ANN type</primary></indexterm> - <indexterm><primary>ANN</primary></indexterm> - - <para>You can annotate types with the <literal>ANN</literal> pragma by using the <literal>type</literal> keyword. For example:</para> - -<programlisting> -{-# ANN type Foo (Just "A `Maybe String' annotation") #-} -data Foo = ... -</programlisting> - </sect3> - - <sect3 id="modann-pragma"> - <title>Annotating modules</title> - - <indexterm><primary>ANN module</primary></indexterm> - <indexterm><primary>ANN</primary></indexterm> - - <para>You can annotate modules with the <literal>ANN</literal> pragma by using the <literal>module</literal> keyword. For example:</para> - -<programlisting> -{-# ANN module (Just "A `Maybe String' annotation") #-} -</programlisting> - </sect3> - </sect2> <sect2 id="line-pragma"> <title>LINE pragma</title> diff --git a/docs/users_guide/intro.xml b/docs/users_guide/intro.xml index e219f9020c..e0ed2f373e 100644 --- a/docs/users_guide/intro.xml +++ b/docs/users_guide/intro.xml @@ -346,7 +346,7 @@ </sect1> -&relnotes1; +<!-- &relnotes1; --> </chapter> diff --git a/docs/users_guide/runtime_control.xml b/docs/users_guide/runtime_control.xml index defae22823..48ea0a875b 100644 --- a/docs/users_guide/runtime_control.xml +++ b/docs/users_guide/runtime_control.xml @@ -1114,11 +1114,60 @@ char *ghc_rts_opts = "-H128m -K1m"; <listitem> <para> Log events in binary format to the - file <filename><replaceable>program</replaceable>.eventlog</filename>, - where <replaceable>flags</replaceable> is a sequence of - zero or more characters indicating which kinds of events - to log. Currently there is only one type - supported: <literal>-ls</literal>, for scheduler events. + file <filename><replaceable>program</replaceable>.eventlog</filename>. + Without any <replaceable>flags</replaceable> specified, this logs a + default set of events, suitable for use with tools like ThreadScope. + </para> + + <para> + For some special use cases you may want more control over which + events are included. The <replaceable>flags</replaceable> is a + sequence of zero or more characters indicating which classes of + events to log. Currently there are four classes of events that can + be enabled/disabled: + <simplelist> + <member> + <option>s</option> — scheduler events, including Haskell + thread creation and start/stop events + </member> + <member> + <option>g</option> — GC events, including GC start/stop + </member> + <member> + <option>p</option> — parallel sparks (sampled) + </member> + <member> + <option>f</option> — parallel sparks (fully accurate) + </member> + </simplelist> + </para> + + <para> + For spark events there are two modes: sampled and fully accurate. + There are various events in the life cycle of each spark, usually + just creating and running, but there are some more exceptional + possibilities. In the sampled mode the number of occurrences of each + kind of spark event is sampled at frequent intervals. In the fully + accurate mode every spark event is logged individually. The latter + has a higher runtime overhead and is not enabled by default. + </para> + + <para> + The initial enabled event classes are 's', 'g' and 'p'. In addition + you can disable specific classes, or enable/disable all classes at + once: + <simplelist> + <member> + <option>a</option> — enable all event classes listed above + </member> + <member> + <option>-<replaceable>x</replaceable></option> — disable the + given class of events, for any event class listed above or + <option>-a</option> for all classes + </member> + </simplelist> + For example, <option>-l-ag</option> would disable all event classes + (<option>-a</option>) except for GC events (<option>g</option>). </para> <para> @@ -1128,7 +1177,7 @@ char *ghc_rts_opts = "-H128m -K1m"; the <ulink url="http://hackage.haskell.org/package/ghc-events">ghc-events</ulink> library. To dump the contents of a <literal>.eventlog</literal> file as text, use the - tool <literal>show-ghc-events</literal> that comes with + tool <literal>ghc-events-show</literal> that comes with the <ulink url="http://hackage.haskell.org/package/ghc-events">ghc-events</ulink> package. </para> diff --git a/docs/users_guide/safe_haskell.xml b/docs/users_guide/safe_haskell.xml index c2f42c000c..07da84fe16 100644 --- a/docs/users_guide/safe_haskell.xml +++ b/docs/users_guide/safe_haskell.xml @@ -1,72 +1,299 @@ <?xml version="1.0" encoding="iso-8859-1"?> <sect1 id="safe-haskell"> <title>Safe Haskell</title> - - Safe Haskell is an extension to the Haskell language supported by GHC, that - provides certain safety guarantees about Haskell code compiled using this - extension. It allows people to build more advance security mechanisms on top - of Haskell and for the safe execution of untrusted Haskell code. Its purpose - isn't to provide a complete secure execution environment for Haskell code but - to give users enough guarantees about the Haskell language to be able to - build such systems. Its design is similar to the safe and unsafe module - system supported by the Modula-3 language. - + + <para> + Safe Haskell is an extension to the Haskell language that is implemented in + GHC as of version 7.2. It allows for unsafe code to be securely included in a + trusted code base by restricting the features of GHC Haskell the code is + allowed to use. Put simply, it makes the types of programs trustable. Safe + Haskell itself is aimed to be as minimal as possible while still providing + strong enough guarantees about compiled Haskell code for more advance secure + systems to be built on top of it. These include techniques such as + information flow control security or encrypted computations. + </para> + The design of Safe Haskell covers the following aspects: + <itemizedlist> - <listitem>A <link linkend="safe-language-overview">safe language</link> - dialect of Haskell that provides guarantees about the code. Mainly it - allows the types and module boundaries to be trusted. + <listitem>A <link linkend="safe-language">safe language</link> dialect of + Haskell that provides guarantees about the code. It allows types and + module boundaries to be trusted. </listitem> <listitem>A new <emphasis>safe import</emphasis> extension that specifies - the module being imported must be trusted. + that the module being imported must be trusted. </listitem> <listitem>A definition of <emphasis>trust</emphasis> (or safety) and how it operates, along with ways of defining and changing the trust of modules and packages. </listitem> </itemizedlist> - - <sect2 id="safe-language-overview"> - <title>Safe Language Overview</title> - The Safe Haskell <emphasis>Safe language</emphasis> guarantees the + <sect2 id="safe-use-cases"> + <title>Uses of Safe Haskell</title> + + Safe Haskell has been designed with two use cases in mind: + + <itemizedlist> + <listitem>Enforcing strict type safety at compile time</listitem> + <listitem>Compiling and executing untrusted code</listitem> + </itemizedlist> + + <sect3> + <title>Strict type-safety (good style)</title> + + Haskell offers a powerful type system and separation of pure and + effectual functions through the <literal>IO</literal> monad. There are + several loop holes in the type system though, the most obvious offender + being the <literal>unsafePerformIO :: IO a -> a</literal> function. The + safe language dialect of Safe Haskell disallows the use of such + functions. This can be useful for a variety of purposes as it makes + Haskell code easier to analyze and reason about. It also codifies an + existing culture in the Haskell community of trying to avoid using such + unsafe functions unless absolutely necessary. As such using the safe + language (through the <option>-XSafe</option> flag) can be though of as a + way of enforcing good style, similar to the function of + <option>-Wall</option>. + </sect3> + + <sect3> + <title>Building secure systems (restricted IO Monads)</title> + + <para> + Safe Haskell is designed to give users enough guarantees about the safety + properties of compiled code so that secure systems can be built using + Haskell. A lot of work has been done with Haskell, building such systems + as information flow control security, capability based security, DSLs for + working with encrypted data... etc. These systems all rely on properties + of the Haskell language that aren't true in the general case where uses + of functions like <literal>unsafePerformIO</literal> are allowed. + </para> + + <para> + As an example lets define an interface for a plugin system where the + plugin authors are untrusted, possibly malicious third-parties. We do + this by restricting the plugin interface to pure functions or to a + restricted <literal>IO</literal> monad that we have defined that only + allows a safe subset of <literal>IO</literal> actions to be executed. We + define the plugin interface here so that it requires the plugin module, + <literal>Danger</literal>, to export a single computation, + <literal>Danger.runMe</literal>, of type <literal>RIO ()</literal>, where + <literal>RIO</literal> is a new monad defined as follows: + </para> + + <programlisting> + -- Either of the following Safe Haskell pragmas would do + {-# LANGUAGE Trustworthy #-} + {-# LANGUAGE Safe #-} + + module RIO (RIO(), runRIO, rioReadFile, rioWriteFile) where + + -- Notice that symbol UnsafeRIO is not exported from this module! + newtype RIO a = UnsafeRIO { runRIO :: IO a } + + instance Monad RIO where + return = UnsafeRIO . return + (UnsafeRIO m) >>= k = UnsafeRIO $ m >>= runRIO . k + + -- Returns True iff access is allowed to file name + pathOK :: FilePath -> IO Bool + pathOK file = {- Implement some policy based on file name -} + + rioReadFile :: FilePath -> RIO String + rioReadFile file = UnsafeRIO $ do + ok <- pathOK file + if ok then readFile file else return "" + + rioWriteFile :: FilePath -> String -> RIO () + rioWriteFile file contents = UnsafeRIO $ do + ok <- pathOK file + if ok then writeFile file contents else return () + </programlisting> + + We compile Danger using the new Safe Haskell <option>-XSafe</option> flag: + + <programlisting> + {-# LANGUAGE Safe #-} + module Danger ( runMe ) where + + runMe :: RIO () + runMe = ... + </programlisting> + + Before going into the Safe Haskell details, lets point out some of + the reasons this design would fail without Safe Haskell: + + <itemizedlist> + <listitem>The design attempts to restrict the operations that Danger + can perform by using types, specifically the <literal>RIO</literal> + type wrapper around <literal>IO</literal>. The author of Danger can + subvert this though by simply writing arbitrary + <literal>IO</literal> actions and using <literal>unsafePerformIO :: + IO a -> a</literal> to execute them as pure functions. + </listitem> + <listitem>The design also relies on the Danger module not being able + to access the <literal>UnsafeRIO</literal> constructor. + Unfortunately Template Haskell can be used to subvert module + boundaries and so could be used gain access to this constructor. + </listitem> + <listitem>There is no way to place restrictions on the modules that + the untrusted Danger module can import. This gives the author of + Danger a very large attack surface, essentially any package + currently installed on the system. Should any of these packages + have a vulnerability then the Danger module can exploit this. The + only way to stop this would be to patch or remove packages with + known vulnerabilities even if they should only be used by + trusted code such as the RIO module. + </listitem> + </itemizedlist> + + <para> + To stop these attacks Safe Haskell can be used. This is done by compiling + the RIO module with the <option>-XTrustworthy</option> flag and compiling + the Danger module with the <option>-XSafe</option> flag. + </para> + + <para> + The use of the <option>-XSafe</option> flag to compile the Danger module + restricts the features of Haskell that can be used to a + <link linkend="safe-language">safe subset</link>. This includes + disallowing <literal>unsafePerfromIO</literal>, Template Haskell, pure + FFI functions, Generalized Newtype Deriving, RULES and restricting the + operation of Overlapping Instances. The <option>-XSafe</option> flag also + restricts the modules can be imported by Danger to only those that are + considered trusted. Trusted modules are those compiled with + <option>-XSafe</option>, where GHC provides a mechanical guarantee that + the code is safe. Or those modules compiled with + <option>-XTrustworthy</option>, where the module author claims that the + module is Safe. + </para> + + <para> + This is why the RIO module is compiled with + <option>-XTrustworthy</option>, to allow the Danger module to import it. + The <option>-XTrustworthy</option> flag doesn't place any restrictions on + the module like <option>-XSafe</option> does. Instead the module author + claims that while code may use unsafe features internally, it only + exposes an API that can used in a safe manner. There is an issue here as + <option>-XTrustworthy</option> may be used by an arbitrary module and + module author. Because of this for trustworthy modules to be considered + trusted, and so allowed to be used in <option>-XSafe</option> compiled + code, the client C compiling the code must tell GHC that they trust the + package the trustworthy module resides in. This is essentially a way of + for C to say, while this package contains trustworthy modules that can be + used by untrusted modules compiled with <option>-XSafe </option>, I trust + the author(s) of this package and trust the modules only expose a safe + API. The trust of a package can be changed at any time, so if a + vulnerability found in a package, C can declare that package untrusted so + that any future compilation against that package would fail. For a more + detailed overview of this mechanism see <xref linkend="safe-trust"/>. + </para> + + <para> + So Danger can import module RIO because RIO is marked trustworthy. Thus, + Danger can make use of the rioReadFile and rioWriteFile functions to + access permitted file names. The main application then imports both RIO + and Danger. To run the plugin, it calls RIO.runRIO Danger.runMe within + the IO monad. The application is safe in the knowledge that the only IO + to ensue will be to files whose paths were approved by the pathOK test. + </para> + </sect3> + </sect2> + + <sect2 id="safe-language"> + <title>Safe Language</title> + + The Safe Haskell <emphasis>safe language</emphasis> guarantees the following properties: + <itemizedlist> - <listitem><emphasis>Referential transparency.</emphasis> Functions - in the Safe language are deterministic, evaluating them will not - cause any side effects. Functions in the <emphasis>IO</emphasis> - monad are still allowed and behave as usual but any pure function - as according to the functions type is guaranteed to indeed be - pure. This property allows a user of the Safe language to trust - the types of functions. + <listitem><emphasis>Referential transparency</emphasis> — Functions + in the safe language are deterministic, evaluating them will not + cause any side effects. Functions in the <literal>IO</literal> monad + are still allowed and behave as usual. Any pure function though, as + according to its type, is guaranteed to indeed be pure. This property + allows a user of the safe language to trust the types. This means, + for example, that the <literal>unsafePerformIO :: IO a -> a</literal> + function is disallowed in the safe language. </listitem> - <listitem><emphasis>Module boundary control.</emphasis> Haskell code - compiled using the Safe language is guaranteed to only access - symbols that are publicly available to it through other modules - export lists. An import part of this is that safe compiled code - is not able to examine or create data values using data constructors - that the module cannot import. If a module M establishes some - invariants through careful use of its export list then code - compiled using the Safe language that imports M is guaranteed to - respect those invariants. + <listitem><emphasis>Module boundary control</emphasis> — Haskell + code compiled using the safe language is guaranteed to only access + symbols that are publicly available to it through other modules export + lists. An important part of this is that safe compiled code is not + able to examine or create data values using data constructors + that it cannot import. If a module M establishes some invariants + through careful use of its export list then code compiled using the + safe language that imports M is guaranteed to respect those invariants. + Because of this, <emphasis><link linkend="template-haskell">Template + Haskell</link></emphasis> and <emphasis> + <link linkend="newtype-deriving">GeneralizedNewtypeDeriving</link> + </emphasis> are both disabled in the safe language as they can be used + to violate this property. </listitem> - <listitem><emphasis>Semantic consistency.</emphasis> The Safe language - is strictly a subset of Haskell as implemented by GHC. Any expression - that compiles in the safe language has the same meaning as it does - when compiled in normal Haskell. In addition, in any module that imports - a Safe language module, expressions that compile both with and without - the safe import have the same meaning in both cases. That is, importing - a module using the Safe language cannot change the meaning of existing - code that isn't dependent on that module. + <listitem><emphasis>Semantic consistency</emphasis> — The safe + language is strictly a subset of Haskell as implemented by GHC. Any + expression that compiles in the safe language has the same meaning as + it does when compiled in normal Haskell. In addition, in any module + that imports a safe language module, expressions that compile both + with and without the safe import have the same meaning in both cases. + That is, importing a module using the safe language cannot change the + meaning of existing code that isn't dependent on that module. So for + example, there are some restrictions placed on the <emphasis> + <link linkend="instance-overlap">Overlapping Instances</link> + </emphasis> extension as it can violate this property. </listitem> </itemizedlist> - - Put simply, these three properties guarantee that you can trust the types - in the Safe language, can trust that module export lists are respected - in the Safe language and can trust that code which successfully compiles - in the Safe language has the same meaning as it normally would. Please see - <xref linkend="safe-language"/> for a more detailed view of the safe - language. + + <para> + These three properties guarantee that you can trust the types in the safe + language, can trust that module export lists are respected in the safe + language and can trust that code that successfully compiles using the safe + language has the same meaning as it normally would. + </para> + + Lets now look at the details of the safe language. In the safe language + dialect (enabled by <option>-XSafe</option>) we disable completely the + following features: + + <itemizedlist> + <listitem><emphasis>GeneralizedNewtypeDeriving</emphasis> — It can + be used to violate constructor access control, by allowing untrusted + code to manipulate protected data types in ways the data type author + did not intend. For example can be used to break invariants of data + structures.</listitem> + <listitem><emphasis>TemplateHaskell</emphasis> — Is particularly + dangerous, as it can cause side effects even at compilation time and + can be used to access abstract data types. It is very easy to break + module boundaries with TH.</listitem> + </itemizedlist> + + In the safe language dialect we restrict the following features: + <itemizedlist> + <listitem><emphasis>ForeignFunctionInterface</emphasis> — This is + mostly safe, but foreign import declarations that import a function + with a non-IO type are disallowed. All FFI imports must reside in the + IO Monad.</listitem> + <listitem><emphasis>RULES</emphasis> — As they can change the + behaviour of trusted code in unanticipated ways, violating semantic + consistency they are restricted in function. Specifically any RULES + defined in a module M compiled with <option>-XSafe</option> are + dropped. RULES defined in trustworthy modules that M imports are still + valid and will fire as usual.</listitem> + <listitem><emphasis>OverlappingInstances</emphasis> — This + extension can be used to violate semantic consistency, because + malicious code could redefine a type instance (by containing a more + specific instance definition) in a way that changes the behaviour of + code importing the untrusted module. The extension is not disabled for + a module M compiled with <option>-XSafe</option> but restricted. While M + can define overlapping instance declarations, they can only overlap + other instance declaration defined in M. If in a module N that imports + M, at a call site that uses a type-class function there is a choice of + which instance to use (i.e. an overlap) and the most specific instances + is from M, then all the other choices must also be from M. If not, a + compilation error will occur. A simple way to think of this is a + <emphasis>same origin policy</emphasis> for overlapping instances + defined in Safe compiled modules.</listitem> + </itemizedlist> </sect2> <sect2 id="safe-imports"> @@ -74,61 +301,66 @@ Safe Haskell enables a small extension to the usual import syntax of Haskell, adding a <emphasis>safe</emphasis> keyword: - <programlisting> impdecl -> import [safe] [qualified] modid [as modid] [impspec] </programlisting> - When used, the module being imported with the safe keyword must be a trusted - module, otherwise a compilation error will occur. The safe import extension - is enabled by either of the <emphasis>-XSafe</emphasis>, - <emphasis>-XTrustworthy</emphasis>, <emphasis>-XSafeLanguage</emphasis> or - <emphasis>-XSafeImports</emphasis> flags and corresponding PRAGMA's. When - either the <emphasis>-XSafe</emphasis> or - <emphasis>-XSafeLanguage</emphasis> flag is used, the safe keyword is - allowed but meaningless -- all imports are safe regardless. + When used, the module being imported with the safe keyword must be a + trusted module, otherwise a compilation error will occur. The safe import + extension is enabled by either of the <option>-XSafe</option>, + <option>-XTrustworthy</option>, or <option>-XSafeImports</option> + flags and corresponding PRAGMA's. When the <option>-XSafe</option> flag + is used, the safe keyword is allowed but meaningless, every import + is required to be safe regardless. </sect2> <sect2 id="safe-trust"> <title>Trust</title> The Safe Haskell extension introduces the following two new language flags: + <itemizedlist> - <listitem><emphasis>-XSafe:</emphasis> Enables the Safe language dialect, - asking GHC to guarantee trust. The safe language dialect requires that - all imports be trusted or a compile error will occur.</listitem> - <listitem><emphasis>-XTrustworthy:</emphasis> Means that while this module - may invoke unsafe functions internally, the module's author claims that - it exports an API that can't be used in an unsafe way. This doesn't enable - the Safe language or place any restrictions on the allowed Haskell code. - The trust guarantee is provided by the module author, not GHC. An import - statement with the safe keyword results in a compilation error if the - imported module is not trussted. An import statement without the keyword - behaves as usual and can import any module whether trusted or - not.</listitem> + <listitem><emphasis>-XSafe</emphasis> — Enables the safe language + dialect, asking GHC to guarantee trust. The safe language dialect + requires that all imports be trusted or a compilation error will + occur.</listitem> + <listitem><emphasis>-XTrustworthy</emphasis> — Means that while + this module may invoke unsafe functions internally, the module's + author claims that it exports an API that can't be used in an unsafe + way. This doesn't enable the safe language or place any restrictions + on the allowed Haskell code. The trust guarantee is provided by the + module author, not GHC. An import statement with the safe keyword + results in a compilation error if the imported module is not trusted. + An import statement without the keyword behaves as usual and can + import any module whether trusted or not.</listitem> </itemizedlist> + <para> Whether or not a module is trusted depends on a notion of trust for - packages, which is determined by the client C invoking GHC (i.e., you). A + packages, which is determined by the client C invoking GHC (i.e. you). A package <emphasis>P</emphasis> is trusted when either C's package database records that <emphasis>P</emphasis> is trusted (and no command-line arguments override this), or C's command-line flags say to trust it regardless of what is recorded in the package database. In either case, C is the only authority on package trust. It is up to the client to decide - which packages they trust. + which <link linkend="safe-package-trust">packages they trust</link>. + </para> - Now a <emphasis>module M in a package P is trusted by a client C</emphasis> + So a <emphasis>module M in a package P is trusted by a client C</emphasis> if and only if: + <itemizedlist> <listitem>Both of these hold: <itemizedlist> - <listitem> The module was compiled with <emphasis>-XSafe</emphasis></listitem> + <listitem> The module was compiled with <option>-XSafe</option> + </listitem> <listitem> All of M's direct imports are trusted by C</listitem> </itemizedlist> </listitem> <listitem><emphasis>OR</emphasis> all of these hold: <itemizedlist> - <listitem>The module was compiled with <emphasis>-XTrustworthy</emphasis></listitem> + <listitem>The module was compiled with <option>-XTrustworthy</option> + </listitem> <listitem>All of M's direct safe imports are trusted by C</listitem> <listitem>Package P is trusted by C</listitem> </itemizedlist> @@ -136,319 +368,79 @@ </itemizedlist> For the first trust definition the trust guarantee is provided by GHC - through the restrictions imposed by the Safe language. For the second + through the restrictions imposed by the safe language. For the second definition of trust, the guarantee is provided initially by the module author. The client C then establishes that they trust the module author by indicating they trust the package the module resides in. This trust chain is required as GHC provides no guarantee for - <emphasis>-XTrustworthy</emphasis> compiled modules. + <literal>-XTrustworthy</literal> compiled modules. <sect3 id="safe-trust-example"> - <title>Example</title> - - <programlisting> - Package Wuggle: - {-# LANGUAGE Safe #-} - module Buggle where - import Prelude - f x = ...blah... - - Package P: - {-# LANGUAGE Trustworthy #-} - module M where - import System.IO.Unsafe - import safe Buggle - </programlisting> - - Suppose a client C decides to trust package P. Then does C trust module M? - To decide, GHC must check M's imports: M imports System.IO.Unsafe. M was - compiled with -XTrustworthy, so P's author takes responsibility for that - import. C trusts P's author, so C trusts M to only use its unsafe - imports (System.IO.Unsafe in this example)in a safe and consistent - manner with respect the API M exposes. M also has a safe import of - Buggle, so for this import P's author takes no responsibility for the - safety or otherwise. So GHC must check whether Buggle is trusted by C. - Is it? Well, it is compiled with -XSafe, so the code in Buggle itself is - machine-checked to be OK, but again under the assumption that all of - Buggle's imports are trusted by C. Prelude comes from base, which C - trusts, and is compiled with -XTrustworthy (While Prelude is typically - imported implicitly, it still obeys the same rules outlined here). So - Buggle is considered trusted. - - Notice that C didn't need to trust package Wuggle; the machine checking - is enough. C only needs to trust packages that have -XTrustworthy - modules in them. - </sect3> + <title>Example</title> - <sect3 id="safe-no-trust"> - <title>Safe Language & Imports without Trust</title> - - Safe Haskell also allows the new language extensions -- the Safe language - dialect and safe imports -- to be used independtly of any trust - assertions for the code. - - <itemizedlist> - <listitem><emphasis>-XSafeImports</emphasis>: enables the safe import - extension. The module using this feature is left untrusted - though.</listitem> - <listitem><emphasis>-XSafeLanguage</emphasis>: - enables the safe language extension. The module using this feature - is left untrusted though.</listitem> - </itemizedlist> - - These are extensions are useful for encouraging good programming style and - also for flexibility during development when using Safe Haskell. The Safe - language encourages users to avoid liberal use of unsafe Haskell language - features. There are also situations where a module may only use the Safe - language subset but exposes some internal API's that code using - <emphasis>-XSafe</emphasis> shouldn't be allowed to access for security - reasons. Please see <link linkend="safe-use-cases">Safe Haskell use - cases</link> for a more detailed explanation. - </sect3> + <programlisting> + Package Wuggle: + {-# LANGUAGE Safe #-} + module Buggle where + import Prelude + f x = ...blah... + + Package P: + {-# LANGUAGE Trustworthy #-} + module M where + import System.IO.Unsafe + import safe Buggle + </programlisting> - <sect3 id="safe-flag-summary"> - <title>Safe Haskell Flag Summary</title> - - In summary, Safe Haskell consists of the following language flags: - - <itemizedlist> - <listitem> - <emphasis>-XSafe</emphasis> - <itemizedlist> - <listitem>To be trusted, all of the module's direct imports must be - trusted, but the module itself need not reside in a trusted - package, because the compiler vouches for its trustworthiness. The - "safe" keyword is allowed but meaningless in import statements -- - conceptually every import is safe whether or not so - tagged.</listitem> - <listitem><emphasis>Module Trusted:</emphasis> Yes</listitem> - <listitem><emphasis>Haskell Language:</emphasis> Restricted to Safe - Language</listitem> - <listitem><emphasis>Imported Modules:</emphasis> All forced to be - safe imports, all must be trusted.</listitem> - </itemizedlist> - </listitem> - <listitem> - <emphasis>-XSafeLanguage:</emphasis> - <itemizedlist> - <listitem>The module is never trusted, because the author does not - claim it is trustworthy. As long as the module compiles both ways, - the result is identical whether or not the -XSafeLanguage flag is - supplied. As with -XSafe, the "safe" import keyword is allowed but - meaningless -- all imports must be safe.</listitem> - <listitem><emphasis>Module Trusted:</emphasis> No</listitem> - <listitem><emphasis>Haskell Language:</emphasis> Restricted to Safe - Language</listitem> - <listitem><emphasis>Imported Modules:</emphasis> All forced to be - safe imports, all must be trusted.</listitem> - </itemizedlist> - </listitem> - <listitem> - <emphasis>-XTrustworthy:</emphasis> - <itemizedlist> - <listitem>This establishes that the module is trusted, but the - guarantee is provided by the module's author. A client of this - module then specifies that they trust the module author by - specifying they trust the package containing the module. - '-XTrustworthy' has no effect on the accepted range of Haskell - programs or their semantics, except that they allow the safe - import keyword.</listitem> - <listitem><emphasis>Module Trusted:</emphasis> Yes but only if - Package the module resides in is also trusted.</listitem> - <listitem><emphasis>Haskell Language:</emphasis> Unrestricted - </listitem> - <listitem><emphasis>Imported Modules:</emphasis> Under control - of module author which ones must be trusted.</listitem> - </itemizedlist> - </listitem> - <listitem> - <emphasis>-XSafeLanguage -XTrustworthy:</emphasis> - <itemizedlist> - <listitem>For the trust property this has the same effect as - '-XTrustworthy' by itself. However unlike -XTrustworthy it also - restricts the range of acceptable Haskell programs to the Safe - language. The difference from this and using -XSafe is the - different trust type and that not all imports are forced to be - safe imports, they are instead optionally specified by the module - author.</listitem> - <listitem><emphasis>Module Trusted:</emphasis> Yes but only if Package - the module resides in is also trusted.</listitem> - <listitem><emphasis>Haskell Language:</emphasis> Restricted to Safe - Language</listitem> - <listitem><emphasis>Imported Modules:</emphasis> Under control of - module author which ones must be trusted.</listitem> - </itemizedlist> - </listitem> - <listitem> - <emphasis>-XSafeImport:</emphasis> - <itemizedlist> - <listitem>Enable the Safe Import extension so that a module can - require a dependency to be trusted without asserting any trust - about itself.</listitem> - <listitem><emphasis>Module Trusted:</emphasis> No</listitem> - <listitem><emphasis>Haskell Language:</emphasis> - Unrestricted</listitem> - <listitem><emphasis>Imported Modules:</emphasis> Under control of - module author which ones must be trusted.</listitem> - </itemizedlist> - </listitem> - </itemizedlist> + <para> + Suppose a client C decides to trust package P. Then does C trust module + M? To decide, GHC must check M's imports — M imports + System.IO.Unsafe. M was compiled with <option>-XTrustworthy</option>, so + P's author takes responsibility for that import. C trusts P's author, so + C trusts M to only use its unsafe imports in a safe and consistent + manner with respect to the API M exposes. M also has a safe import of + Buggle, so for this import P's author takes no responsibility for the + safety, so GHC must check whether Buggle is trusted by C. Is it? Well, + it is compiled with <option>-XSafe</option>, so the code in Buggle + itself is machine-checked to be OK, but again under the assumption that + all of Buggle's imports are trusted by C. Prelude comes from base, which + C trusts, and is compiled with <option>-XTrustworthy</option> (While + Prelude is typically imported implicitly, it still obeys the same rules + outlined here). So Buggle is considered trusted. + </para> + + <para> + Notice that C didn't need to trust package Wuggle; the machine checking + is enough. C only needs to trust packages that contain + <option>-XTrustworthy</option> modules. + </para> </sect3> <sect3 id="safe-package-trust"> <title>Package Trust</title> - Safe Haskell gives packages a new boolean property, that of trust. Several new options are available - at the GHC command-line to specify the trust property of packages: + Safe Haskell gives packages a new Boolean property, that of trust. + Several new options are available at the GHC command-line to specify the + trust property of packages: <itemizedlist> - <listitem><emphasis>-trust P</emphasis>: Exposes package P if it was - hidden and considers it a trusted package regardless of the package - database.</listitem> - <listitem><emphasis>-distrust P</emphasis>: Exposes package P if it was - hidden and considers it an untrusted package regardless of the + <listitem><emphasis>-trust P</emphasis> — Exposes package P if it + was hidden and considers it a trusted package regardless of the + package database.</listitem> + <listitem><emphasis>-distrust P</emphasis> — Exposes package P if + it was hidden and considers it an untrusted package regardless of the package database.</listitem> - <listitem><emphasis>-distrust-all-packages</emphasis>: Considers all - packages distrusted unless they are explicitly set to be trusted by - subsequent command-line options.</listitem> + <listitem><emphasis>-distrust-all-packages</emphasis> — Considers + all packages distrusted unless they are explicitly set to be trusted + by subsequent command-line options.</listitem> </itemizedlist> - To set a package's trust property in the package database please refer to <xref linkend="packages"/>. - </sect3> - - </sect2> - - <sect2 id="safe-language"> - <title>Safe Language Details</title> - - In the Safe language dialect we disable completely the following Haskell language features: - <itemizedlist> - <listitem><emphasis>GeneralizedNewtypeDeriving:</emphasis> It can be used - to violate constructor access control, by allowing untrusted code to - manipulate protected data types in ways the data type author did not - intend. For example can be used to break invariants of data - structures.</listitem> - <listitem><emphasis>TemplateHaskell:</emphasis> Is particularly - dangerous, as it can cause side effects even at compilation time and - can be used to access abstract data types. It is very easy to break - module boundaries with TH.</listitem> - </itemizedlist> - - In the Safe language dialect we restrict the following Haskell language features: - <itemizedlist> - <listitem><emphasis>ForeignFunctionInterface:</emphasis> This is mostly - safe, but foreign import declarations that import a function with a - non-IO type are disallowed. All FFI imports must reside in the IO - Monad.</listitem> - <listitem><emphasis>RULES:</emphasis> As they can change the behaviour of - trusted code in unanticipated ways, violating semantic consistency they - are restricted in function. Specifically any RULES defined in a module - M compiled with -XSafe or -XSafeLanguage are dropped. RULES defined in - trustworthy modules that M imports are still valid and will fire as - usual.</listitem> - <listitem><emphasis>OverlappingInstances:</emphasis> This extension - can be used to violate semantic consistency, because malicious code - could redefine a type instance (by containing a more specific - instance definition) in a way that changes the behaviour of code - importing the untrusted module. The extension is not disabled for a - module M compiled with -XSafe or -XSafeLanguage but restricted. - While M can define overlapping instance declarations, they can - only overlap other instance declaration defined in M. If in a module N - that imports M, at a call site that uses type-class function there is - a choice of which instance to use (i.e. overlapping) and the most - specific instances is from M, then all the other choices must also be - from M. If not, a compilation error will occur. A simple way to think - of this is a <emphasis>same origin policy</emphasis> for overlapping - instances defined in Safe compiled modules.</listitem> - </itemizedlist> - </sect2> - - <sect2 id="safe-use-cases"> - <title>Use Cases</title> - - Safe Haskell has been designed with the following use cases in mind. - - <sect3> - <title>Enforcing Good Programming Style</title> - - Over-reliance on magic functions such as unsafePerformIO or magic symbols - such as realWorld# can lead to less elegant Haskell code. The Safe dialect - formalizes this notion of magic and prohibits its use. Thus, people may - encourage their collaborators to use the Safe dialect, except when truly - necessary, so as to promote better programming style. It can be thought - of as an addition to using <option>-Wall -Werror</option>. - </sect3> - - <sect3> - <title>Building Secure Systems (restricted IO Monads)</title> - - The original use case that Safe Haskell was designed for was to allow - secure systems to be built on top of the Haskell programming language. - Many researchers have done great work with Haskell, building such systems - as information flow control security systems, capability based security - system, languages for working with encrypted data... etc. These systems - all rely on properties of the Haskell language that aren't true in the - general case where uses of functions like - <emphasis>unsafePerformIO</emphasis> are allowed. Safe Haskell however - gives enough guarantees about the compiled Haskell code to be able to - successfully build secure systems on top of. - - As an example lets define an interface for a plugin system where the - plugin authors are untrusted, possibly malicious third-parties. We do - this by restricting the interface to pure functions or to a restricted IO - monad that we have defined that only allows a safe subset of IO actions - to be executed. We define the plugin interface here so that it requires - the plugin module, <emphasis>Danger</emphasis>, to export a single - computation, <emphasis>Danger.runMe</emphasis>, of type <emphasis>RIO - ()</emphasis>, where <emphasis>RIO</emphasis> is a new monad defined as - follows: - - <programlisting> - -- Either of the following pragmas would do - {-# LANGUAGE Trustworthy #-} - {-# LANGUAGE Safe #-} - - module RIO (RIO(), runRIO, rioReadFile, rioWriteFile) where - - -- Notice that symbol UnsafeRIO is not exported from this module! - - newtype RIO a = UnsafeRIO { runRIO :: IO a } - - instance Monad RIO where - return = UnsafeRIO . return - (UnsafeRIO m) >>= k = UnsafeRIO $ m >>= runRIO . k - - -- Returns True iff access is allowed to file name - pathOK :: FilePath -> IO Bool - pathOK file = {- Implement some policy based on file name -} - - rioReadFile :: FilePath -> RIO String - rioReadFile file = UnsafeRIO $ do - ok <- pathOK file - if ok then readFile file else return "" - - rioWriteFile :: FilePath -> String -> RIO () - rioWriteFile file contents = UnsafeRIO $ do - ok <- pathOK file - if ok then writeFile file contents else return () - </programlisting> - - We compile Danger using the -XSafe flag. Danger can import module RIO - because RIO is marked Trustworthy. Thus, Danger can make use of the - rioReadFile and rioWriteFile functions to access permitted file names. - - The main application then imports both RIO and Danger. To run the - plugin, it calls RIO.runRIO Danger.runMe within the IO monad. The - application is safe in the knowledge that the only IO to ensue will be - to files whose paths were approved by the pathOK test. We are relying on - the fact that the type system and constructor privacy prevent RIO - computations from executing IO actions directly. Only functions with - access to privileged symbol UnsafeRIO can lift IO computations into the - RIO monad. + To set a package's trust property in the package database please refer to + <xref linkend="packages"/>. </sect3> - <sect3> - <title>Uses of -XSafeImports</title> + <sect3 id="safe-no-trust"> + <title>Safe Imports without Trust</title> If you are writing a module and want to import a module from an untrusted author, then you would use the following syntax: @@ -460,28 +452,74 @@ As the safe import keyword is a feature of Safe Haskell and not Haskell98 this would fail though unless you enabled Safe imports through on the of the Safe Haskell language flags. Three flags enable safe imports, - <emphasis>-XSafe, -XTrustworthy</emphasis> and - <emphasis>-XSafeImports</emphasis>. However <emphasis>-XSafe and - -XTrustworthy</emphasis> do more then just enable the keyword which may - be undesirable. Using the <emphasis>-XSafeImports</emphasis> language flag - allows you to enable safe imports and nothing more. + <option>-XSafe, -XTrustworthy</option> and + <option>-XSafeImports</option>. However <option>-XSafe</option> and + <option>-XTrustworthy</option> do more then just enable the keyword which + may be undesirable. Using the <option>-XSafeImports</option> language + flag allows you to enable safe imports and nothing more. </sect3> + </sect2> + + <sect2 id="safe-flag-summary"> + <title>Safe Haskell Flag Summary</title> + + In summary, Safe Haskell consists of the following language flags: + + <variablelist> + <varlistentry> + <term>-XSafe</term> + <listitem>To be trusted, all of the module's direct imports must be + trusted, but the module itself need not reside in a trusted + package, because the compiler vouches for its trustworthiness. The + "safe" keyword is allowed but meaningless in import statements, + every import is required to be safe regardless. + <itemizedlist> + <listitem><emphasis>Module Trusted</emphasis> — Yes</listitem> + <listitem><emphasis>Haskell Language</emphasis> — Restricted to Safe + Language</listitem> + <listitem><emphasis>Imported Modules</emphasis> — All forced to be + safe imports, all must be trusted.</listitem> + </itemizedlist> + </listitem> + </varlistentry> + + <varlistentry> + <term>-XTrustworthy</term> + <listitem>This establishes that the module is trusted, but the + guarantee is provided by the module's author. A client of this + module then specifies that they trust the module author by + specifying they trust the package containing the module. + <option>-XTrustworthy</option> has no effect on the accepted range + of Haskell programs or their semantics, except that they allow the + safe import keyword. + <itemizedlist> + <listitem><emphasis>Module Trusted</emphasis> — Yes but only if the + package the module resides in is also trusted.</listitem> + <listitem><emphasis>Haskell Language</emphasis> — Unrestricted + </listitem> + <listitem><emphasis>Imported Modules</emphasis> — Under control of + module author which ones must be trusted.</listitem> + </itemizedlist> + </listitem> + </varlistentry> + + <varlistentry> + <term>-XSafeImport</term> + <listitem>Enable the Safe Import extension so that a module can + require a dependency to be trusted without asserting any trust + about itself. + <itemizedlist> + <listitem><emphasis>Module Trusted</emphasis> — No</listitem> + <listitem><emphasis>Haskell Language</emphasis> — + Unrestricted</listitem> + <listitem><emphasis>Imported Modules</emphasis> — Under control of + module author which ones must be trusted.</listitem> + </itemizedlist> + </listitem> + </varlistentry> + + </variablelist> - <sect3> - <title>Uses of -XSafeLanguage</title> - - The <emphasis>-XSafeLanguage</emphasis> flag has two use cases. Firstly - as stated above it can be used to enforce good programming style. - Secondly, in the <emphasis>RIO</emphasis> restricted IO monad example - above there is no reason that it can't be implemented in the Safe - Language as its code isn't reliant on any unsafe features of Haskell. - However we may also wish to export the <emphasis>UnsafeRIO</emphasis> - action in the defining module or <emphasis>RIO</emphasis> and then define - a new module that only exports a safe subset of the original definition - of <emphasis>RIO</emphasis>. The defining module can use the - <emphasis>-XSafeLanguage</emphasis> flag and be assured that the - untrusted <emphasis>Danger</emphasis> module can't import it. - </sect3> </sect2> </sect1> diff --git a/docs/users_guide/ug-book.xml.in b/docs/users_guide/ug-book.xml.in index 8c1e1b162b..1ff487c2ed 100644 --- a/docs/users_guide/ug-book.xml.in +++ b/docs/users_guide/ug-book.xml.in @@ -16,6 +16,7 @@ &sooner; &lang-features; &ffi-chap; +&extending-ghc; &wrong; &utils; &win32-dll; diff --git a/docs/users_guide/ug-ent.xml.in b/docs/users_guide/ug-ent.xml.in index 2d19d97688..b550035952 100644 --- a/docs/users_guide/ug-ent.xml.in +++ b/docs/users_guide/ug-ent.xml.in @@ -3,7 +3,7 @@ <!ENTITY flags SYSTEM "flags.xml"> <!ENTITY license SYSTEM "license.xml"> <!ENTITY intro SYSTEM "intro.xml" > -<!ENTITY relnotes1 SYSTEM "7.0.1-notes.xml" > +<!-- <!ENTITY relnotes1 SYSTEM "7.0.1-notes.xml" > --> <!ENTITY using SYSTEM "using.xml" > <!ENTITY runtime SYSTEM "runtime_control.xml" > <!ENTITY prof SYSTEM "profiling.xml" > @@ -14,6 +14,7 @@ <!ENTITY packages SYSTEM "packages.xml" > <!ENTITY parallel SYSTEM "parallel.xml" > <!ENTITY safehaskell SYSTEM "safe_haskell.xml" > +<!ENTITY extending-ghc SYSTEM "extending_ghc.xml" > <!ENTITY phases SYSTEM "phases.xml" > <!ENTITY separate SYSTEM "separate_compilation.xml" > <!ENTITY bugs SYSTEM "bugs.xml" > @@ -297,12 +297,12 @@ INTREE_ONLY_PACKAGES := haskeline mtl terminfo utf8-string xhtml DPH_PACKAGES := dph/dph-base dph/dph-prim-interface dph/dph-prim-seq \ dph/dph-common dph/dph-prim-par dph/dph-par dph/dph-seq \ - vector primitive + vector primitive random # Packages that, if present, must be built by the stage2 compiler, # because they use TH and/or annotations, or depend on other stage2 # packages: -STAGE2_PACKAGES := $(DPH_PACKAGES) haskell98 haskell2010 random +STAGE2_PACKAGES := $(DPH_PACKAGES) haskell98 haskell2010 # Packages that we shouldn't build if we don't have TH (e.g. because # we're building a profiled compiler): TH_PACKAGES := $(DPH_PACKAGES) @@ -386,7 +386,6 @@ $(eval $(call addPackage,old-time)) $(eval $(call addPackage,time)) $(eval $(call addPackage,directory)) $(eval $(call addPackage,process)) -$(eval $(call addPackage,random)) $(eval $(call addPackage,extensible-exceptions)) $(eval $(call addPackage,haskell98)) $(eval $(call addPackage,haskell2010)) @@ -617,7 +616,10 @@ endif # ---------------------------------------------- # Actually include all the sub-ghc.mk's -include $(patsubst %, %/ghc.mk, $(BUILD_DIRS)) +# BUILD_DIRS_EXTRA needs to come after BUILD_DIRS, because stuff in +# libraries/dph/ghc.mk refers to stuff defined earlier, in particular +# things like $(libraries/dph/dph-base_dist-install_GHCI_LIB) +include $(patsubst %, %/ghc.mk, $(BUILD_DIRS) $(BUILD_DIRS_EXTRA)) # A useful pseudo-target (must be after the include above, because it needs # the value of things like $(libraries/base_dist-install_v_LIB). @@ -886,6 +888,10 @@ install_packages: libffi/package.conf.install rts/package.conf.install $(call make-command, \ "$(INSTALLED_GHC_PKG_REAL)" \ --global-conf "$(INSTALLED_PACKAGE_CONF)" hide $p)) +# when we install the packages above, ghc-pkg obeys umask when creating +# package.cache, but for everything else we specify the permissions. We +# therefore now fix the permissions of package.cache + $(CREATE_DATA) '$(INSTALLED_PACKAGE_CONF)/package.cache' # ----------------------------------------------------------------------------- # Binary distributions @@ -1072,7 +1078,7 @@ sdist-prep : $(call sdist_file,compiler,stage2,parser,,Lexer,x) $(call sdist_file,compiler,stage2,parser,,Parser,y.pp) $(call sdist_file,compiler,stage2,parser,,ParserCore,y) - $(call sdist_file,utils/hpc,dist,,,HpcParser,y) + $(call sdist_file,utils/hpc,dist-install,,,HpcParser,y) $(call sdist_file,utils/genprimopcode,dist,,,Lexer,x) $(call sdist_file,utils/genprimopcode,dist,,,Parser,y) $(call sdist_file,utils/haddock,dist,src,Haddock,Lex,x) diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 139c2b462e..5b44097e17 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -897,6 +897,14 @@ noArgs :: GHCi () -> String -> GHCi () noArgs m "" = m noArgs _ _ = liftIO $ putStrLn "This command takes no arguments" +withSandboxOnly :: String -> GHCi () -> GHCi () +withSandboxOnly cmd this = do + dflags <- getDynFlags + if not (dopt Opt_GhciSandbox dflags) + then printForUser (text cmd <+> + ptext (sLit "is not supported with -fno-ghci-sandbox")) + else this + help :: String -> GHCi () help _ = liftIO (putStr helpText) @@ -2086,32 +2094,37 @@ pprintCommand bind force str = do pprintClosureCommand bind force str stepCmd :: String -> GHCi () -stepCmd [] = doContinue (const True) GHC.SingleStep -stepCmd expression = runStmt expression GHC.SingleStep >> return () +stepCmd arg = withSandboxOnly ":step" $ step arg + where + step [] = doContinue (const True) GHC.SingleStep + step expression = runStmt expression GHC.SingleStep >> return () stepLocalCmd :: String -> GHCi () -stepLocalCmd [] = do - mb_span <- getCurrentBreakSpan - case mb_span of - Nothing -> stepCmd [] - Just loc -> do - Just mod <- getCurrentBreakModule - current_toplevel_decl <- enclosingTickSpan mod loc - doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep - -stepLocalCmd expression = stepCmd expression +stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg + where + step expr + | not (null expr) = stepCmd expr + | otherwise = do + mb_span <- getCurrentBreakSpan + case mb_span of + Nothing -> stepCmd [] + Just loc -> do + Just mod <- getCurrentBreakModule + current_toplevel_decl <- enclosingTickSpan mod loc + doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep stepModuleCmd :: String -> GHCi () -stepModuleCmd [] = do - mb_span <- getCurrentBreakSpan - case mb_span of - Nothing -> stepCmd [] - Just _ -> do - Just span <- getCurrentBreakSpan - let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span - doContinue f GHC.SingleStep - -stepModuleCmd expression = stepCmd expression +stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg + where + step expr + | not (null expr) = stepCmd expr + | otherwise = do + mb_span <- getCurrentBreakSpan + case mb_span of + Nothing -> stepCmd [] + Just span -> do + let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span + doContinue f GHC.SingleStep -- | Returns the span of the largest tick containing the srcspan given enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan @@ -2127,11 +2140,14 @@ enclosingTickSpan mod (RealSrcSpan src) = do return . head . sortBy leftmost_largest $ enclosing_spans traceCmd :: String -> GHCi () -traceCmd [] = doContinue (const True) GHC.RunAndLogSteps -traceCmd expression = runStmt expression GHC.RunAndLogSteps >> return () +traceCmd arg + = withSandboxOnly ":trace" $ trace arg + where + trace [] = doContinue (const True) GHC.RunAndLogSteps + trace expression = runStmt expression GHC.RunAndLogSteps >> return () continueCmd :: String -> GHCi () -continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion +continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion -- doContinue :: SingleStep -> GHCi () doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi () @@ -2141,12 +2157,12 @@ doContinue pred step = do return () abandonCmd :: String -> GHCi () -abandonCmd = noArgs $ do +abandonCmd = noArgs $ withSandboxOnly ":abandon" $ do b <- GHC.abandon -- the prompt will change to indicate the new context when (not b) $ liftIO $ putStrLn "There is no computation running." deleteCmd :: String -> GHCi () -deleteCmd argLine = do +deleteCmd argLine = withSandboxOnly ":delete" $ do deleteSwitch $ words argLine where deleteSwitch :: [String] -> GHCi () @@ -2194,7 +2210,7 @@ bold c | do_bold = text start_bold <> c <> text end_bold | otherwise = c backCmd :: String -> GHCi () -backCmd = noArgs $ do +backCmd = noArgs $ withSandboxOnly ":back" $ do (names, _, span) <- GHC.back printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span printTypeOfNames names @@ -2203,7 +2219,7 @@ backCmd = noArgs $ do enqueueCommands [stop st] forwardCmd :: String -> GHCi () -forwardCmd = noArgs $ do +forwardCmd = noArgs $ withSandboxOnly ":forward" $ do (names, ix, span) <- GHC.forward printForUser $ (if (ix == 0) then ptext (sLit "Stopped at") @@ -2215,8 +2231,7 @@ forwardCmd = noArgs $ do -- handle the "break" command breakCmd :: String -> GHCi () -breakCmd argLine = do - breakSwitch $ words argLine +breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine breakSwitch :: [String] -> GHCi () breakSwitch [] = do diff --git a/ghc/Main.hs b/ghc/Main.hs index 71a45f8a9a..4a91acd3b9 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -78,8 +78,7 @@ import Data.Maybe main :: IO () main = do hSetBuffering stdout NoBuffering - let defaultErrorHandlerDynFlags = defaultDynFlags (panic "No settings") - GHC.defaultErrorHandler defaultErrorHandlerDynFlags $ do + GHC.defaultErrorHandler defaultLogAction $ do -- 1. extract the -B flag from the args argv0 <- getArgs diff --git a/ghc/ghc-bin.cabal.in b/ghc/ghc-bin.cabal.in index 61b7b340ac..ba17150e9a 100644 --- a/ghc/ghc-bin.cabal.in +++ b/ghc/ghc-bin.cabal.in @@ -29,7 +29,7 @@ Executable ghc array >= 0.1 && < 0.4, bytestring >= 0.9 && < 0.10, directory >= 1 && < 1.2, - process >= 1 && < 1.1, + process >= 1 && < 1.2, filepath >= 1 && < 1.3, ghc if os(windows) diff --git a/includes/rts/EventLogFormat.h b/includes/rts/EventLogFormat.h index 1bbb2f0074..925aec4ed1 100644 --- a/includes/rts/EventLogFormat.h +++ b/includes/rts/EventLogFormat.h @@ -104,8 +104,7 @@ #define EVENT_STOP_THREAD 2 /* (thread, status, blockinfo) */ #define EVENT_THREAD_RUNNABLE 3 /* (thread) */ #define EVENT_MIGRATE_THREAD 4 /* (thread, new_cap) */ -#define EVENT_RUN_SPARK 5 /* (thread) */ -#define EVENT_STEAL_SPARK 6 /* (thread, victim_cap) */ +/* 5, 6 deprecated */ #define EVENT_SHUTDOWN 7 /* () */ #define EVENT_THREAD_WAKEUP 8 /* (thread, other_cap) */ #define EVENT_GC_START 9 /* () */ @@ -133,22 +132,36 @@ #define EVENT_PROGRAM_ENV 31 /* (capset, environment_vector) */ #define EVENT_OSPROCESS_PID 32 /* (capset, pid) */ #define EVENT_OSPROCESS_PPID 33 /* (capset, parent_pid) */ +#define EVENT_SPARK_COUNTERS 34 /* (crt,dud,ovf,cnv,fiz,gcd,rem) */ +#define EVENT_SPARK_CREATE 35 /* () */ +#define EVENT_SPARK_DUD 36 /* () */ +#define EVENT_SPARK_OVERFLOW 37 /* () */ +#define EVENT_SPARK_RUN 38 /* () */ +#define EVENT_SPARK_STEAL 39 /* (victim_cap) */ +#define EVENT_SPARK_FIZZLE 40 /* () */ +#define EVENT_SPARK_GC 41 /* () */ +#define EVENT_INTERN_STRING 42 /* (string, id) {not used by ghc} */ -/* Range 34 - 59 is available for new events */ +/* Range 43 - 59 is available for new GHC and common events */ /* Range 60 - 80 is used by eden for parallel tracing * see http://www.mathematik.uni-marburg.de/~eden/ */ +/* Range 100 - 139 is reserved for Mercury */ + /* * The highest event code +1 that ghc itself emits. Note that some event * ranges higher than this are reserved but not currently emitted by ghc. * This must match the size of the EventDesc[] array in EventLog.c */ -#define NUM_EVENT_TAGS 34 +#define NUM_GHC_EVENT_TAGS 42 #if 0 /* DEPRECATED EVENTS: */ +/* we don't actually need to record the thread, it's implicit */ +#define EVENT_RUN_SPARK 5 /* (thread) */ +#define EVENT_STEAL_SPARK 6 /* (thread, victim_cap) */ /* ghc changed how it handles sparks so these are no longer applicable */ #define EVENT_CREATE_SPARK 13 /* (cap, thread) */ #define EVENT_SPARK_TO_THREAD 14 /* (cap, thread, spark_thread) */ diff --git a/includes/rts/Flags.h b/includes/rts/Flags.h index 42ca671768..46f1eb893b 100644 --- a/includes/rts/Flags.h +++ b/includes/rts/Flags.h @@ -127,8 +127,10 @@ struct PROFILING_FLAGS { struct TRACE_FLAGS { int tracing; rtsBool timestamp; /* show timestamp in stderr output */ - rtsBool scheduler; /* trace scheduler events */ + rtsBool gc; /* trace GC events */ + rtsBool sparks_sampled; /* trace spark events by a sampled method */ + rtsBool sparks_full; /* trace spark events 100% accurately */ }; struct CONCURRENT_FLAGS { diff --git a/includes/rts/Globals.h b/includes/rts/Globals.h index 218b7ef155..9a2fbd0dd4 100644 --- a/includes/rts/Globals.h +++ b/includes/rts/Globals.h @@ -17,7 +17,6 @@ #ifndef RTS_GLOBALS_H #define RTS_GLOBALS_H -StgStablePtr getOrSetTypeableStore(StgStablePtr value); StgStablePtr getOrSetGHCConcSignalSignalHandlerStore(StgStablePtr value); StgStablePtr getOrSetGHCConcWindowsPendingDelaysStore(StgStablePtr ptr); StgStablePtr getOrSetGHCConcWindowsIOManagerThreadStore(StgStablePtr ptr); diff --git a/libraries/bin-package-db/bin-package-db.cabal b/libraries/bin-package-db/bin-package-db.cabal index b8b1f65094..697b954f30 100644 --- a/libraries/bin-package-db/bin-package-db.cabal +++ b/libraries/bin-package-db/bin-package-db.cabal @@ -25,7 +25,7 @@ Library { build-depends: base >= 4 && < 5 build-depends: binary == 0.5.*, - Cabal >= 1.8 && < 1.12 + Cabal >= 1.8 && < 1.14 extensions: CPP } diff --git a/mk/validate-settings.mk b/mk/validate-settings.mk index 7dc124fcba..9f06417ea8 100644 --- a/mk/validate-settings.mk +++ b/mk/validate-settings.mk @@ -10,9 +10,9 @@ SRC_CC_OPTS += -Wall $(WERROR) # we turn it on explicitly for consistency with other users ifeq "$(GccLT46)" "NO" SRC_CC_OPTS += -Werror=unused-but-set-variable -endif # gcc 4.6 gives 3 warning for giveCapabilityToTask not being inlined SRC_CC_OPTS += -Wno-error=inline +endif SRC_HC_OPTS += -Wall $(WERROR) -H64m -O0 @@ -61,7 +61,9 @@ libraries/containers_dist-install_EXTRA_HC_OPTS += -fno-warn-incomplete-patterns libraries/bytestring_dist-install_EXTRA_HC_OPTS += -fno-warn-identities # Temporarily turn off unused-do-bind warnings for the time package -libraries/time_dist-install_EXTRA_HC_OPTS += -fno-warn-unused-do-bind +libraries/time_dist-install_EXTRA_HC_OPTS += -fno-warn-unused-do-bind +# Temporary: mkTyCon is deprecated +libraries/time_dist-install_EXTRA_HC_OPTS += -fno-warn-deprecations # On Windows, there are also some unused import warnings libraries/time_dist-install_EXTRA_HC_OPTS += -fno-warn-unused-imports -fno-warn-identities @@ -64,7 +64,6 @@ libraries/old-locale - packages/old-locale.git libraries/old-time - packages/old-time.git git libraries/pretty - packages/pretty.git git libraries/process - packages/process.git git -libraries/random - packages/random.git git libraries/template-haskell - packages/template-haskell.git git libraries/terminfo - packages/terminfo.git git libraries/unix - packages/unix.git git @@ -76,6 +75,7 @@ nofib nofib nofib.git libraries/deepseq extra packages/deepseq.git git libraries/parallel extra packages/parallel.git git libraries/stm extra packages/stm.git git +libraries/random dph packages/random.git git libraries/primitive dph packages/primitive.git git libraries/vector dph packages/vector.git git libraries/dph dph packages/dph.git git diff --git a/quickcheck/HeaderInfoTests.hs b/quickcheck/HeaderInfoTests.hs deleted file mode 100644 index 6f8bef6239..0000000000 --- a/quickcheck/HeaderInfoTests.hs +++ /dev/null @@ -1,129 +0,0 @@ -module HeaderInfoTests - ( prop_optionsIdentity - , prop_languageParse - , prop_languageError - ) where - -import Test.QuickCheck -import Test.QuickCheck.Batch -import Data.Char - -import Control.Monad -import System.IO.Unsafe - -import HeaderInfo -import StringBuffer -import SrcLoc - -import Language.Haskell.Extension - -newtype CmdOptions = CmdOptions {cmdOptions :: [String]} - deriving Show - -instance Arbitrary CmdOptions where - arbitrary = resize 30 $ liftM CmdOptions arbitrary - coarbitrary = undefined - -instance Arbitrary Char where - arbitrary = elements $ ['a'..'z']++['A'..'Z'] - coarbitrary = undefined - -data Options = Options - | Options_GHC - deriving Show - -instance Arbitrary Options where - arbitrary = elements [Options,Options_GHC] - coarbitrary = undefined - --- Test that OPTIONS are correctly extracted from a buffer --- with comments and garbage. -prop_optionsIdentity lowercase options cmds - = not (null cmds) ==> - all (all (not.null).cmdOptions) cmds ==> - concatMap cmdOptions cmds == map unLoc (getOptions buffer "somefile") - where buffer = unsafePerformIO $ stringToStringBuffer str - str = concatMap mkPragma cmds ++ - "\n @#@# garbage #@#@ \n" - mkPragma (CmdOptions cmd) - = unlines [ "-- Pragma: " - , unwords $ ["{-#", pragma]++cmd++["#-}"] - , "{- End of pragma -}" ] - pragma = (if lowercase then map toLower else map toUpper) $ - case options of - Options -> "OPTIONS" - Options_GHC -> "OPTIONS_GHC" - -newtype Extensions = Extensions [Extension] - deriving Show - -instance Arbitrary Extensions where - arbitrary = resize 30 $ liftM Extensions arbitrary - coarbitrary = undefined - -extensions :: [Extension] -extensions = [ OverlappingInstances - , UndecidableInstances - , IncoherentInstances - , RecursiveDo - , ParallelListComp - , MultiParamTypeClasses - , NoMonomorphismRestriction - , FunctionalDependencies - , Rank2Types - , RankNTypes - , PolymorphicComponents - , ExistentialQuantification - , ScopedTypeVariables - , ImplicitParams - , FlexibleContexts - , FlexibleInstances - , EmptyDataDecls - , CPP - , TypeSynonymInstances - , TemplateHaskell - , ForeignFunctionInterface - , InlinePhase - , ContextStack - , Arrows - , Generics - , NoImplicitPrelude - , NamedFieldPuns - , PatternGuards - , GeneralizedNewtypeDeriving - , ExtensibleRecords - , RestrictedTypeSynonyms - , HereDocuments ] - --- derive Enum for Extension? -instance Arbitrary Extension where - arbitrary = elements extensions - coarbitrary = undefined - --- Test that we can parse all known extensions. -prop_languageParse lowercase (Extensions exts) - = not (null exts) ==> - not (isBottom (getOptions buffer "somefile")) - where buffer = unsafePerformIO $ stringToStringBuffer str - str = unlines [ "-- Pragma: " - , unwords $ ["{-#", pragma, ppExts exts "" , "#-}"] - , "{- End of pragma -}" - , "garbage#@$#$" ] - ppExts [e] = shows e - ppExts (x:xs) = shows x . showChar ',' . ppExts xs - ppExts [] = id - pragma = (if lowercase then map toLower else map toUpper) - "LANGUAGE" - --- Test that invalid extensions cause exceptions. -prop_languageError lowercase ext - = not (null ext) ==> - ext `notElem` map show extensions ==> - isBottom (foldr seq () (getOptions buffer "somefile")) - where buffer = unsafePerformIO $ stringToStringBuffer str - str = unlines [ "-- Pragma: " - , unwords $ ["{-#", pragma, ext , "#-}"] - , "{- End of pragma -}" - , "garbage#@$#$" ] - pragma = (if lowercase then map toLower else map toUpper) - "LANGUAGE" diff --git a/quickcheck/README b/quickcheck/README deleted file mode 100644 index 251bc807e0..0000000000 --- a/quickcheck/README +++ /dev/null @@ -1,9 +0,0 @@ -QuickCheck for the GHC library. - -Requirements: - stage2 of ghc. - -Usage: - ./run.sh - ./run.sh debug # runs quickCheck in debug mode. - ./run.sh ghci [file] # loads [file] with the stage2 compiler. diff --git a/quickcheck/RunTests.hs b/quickcheck/RunTests.hs deleted file mode 100644 index 4aabb48584..0000000000 --- a/quickcheck/RunTests.hs +++ /dev/null @@ -1,62 +0,0 @@ -module RunTests where - -import Test.QuickCheck.Batch hiding (runTests) -import System.Exit -import System.Environment - -import HeaderInfoTests as HI - -runUnitTests :: Bool -> IO () -runUnitTests debug = exitWith =<< performTests debug - -performTests :: Bool -> IO ExitCode -performTests debug = - do e1 <- exeTests "HeaderInfo" opts - [ run HI.prop_optionsIdentity - , run HI.prop_languageParse - , run HI.prop_languageError ] - return (foldr1 cat [e1]) - where opts = TestOptions 100 10 debug - cat (e@(ExitFailure _)) _ = e - cat _ e = e - -exeTests :: String -> TestOptions -> [TestOptions -> IO TestResult] -> IO ExitCode -exeTests name scale actions = - do putStr (rjustify 25 name ++ " : ") - tr 1 actions [] 0 False - where - rjustify n s = replicate (max 0 (n - length s)) ' ' ++ s - tr n [] xs c e = do - putStr (rjustify (max 0 (35-n)) " (" ++ show c ++ ")\n") - mapM_ fa xs - if e - then return (ExitFailure 1) - else return ExitSuccess - tr n (action:actions) others c e = - do r <- action scale - case r of - (TestOk _ m _) - -> do { putStr "." ; - tr (n+1) actions others (c+m) e } - (TestExausted s m ss) - -> do { putStr "?" ; - tr (n+1) actions others (c+m) e } - (TestAborted e) - -> do { print e; - putStr "*" ; - tr (n+1) actions others c True } - (TestFailed f num) - -> do { putStr "#" ; - tr (n+1) actions ((f,n,num):others) (c+num) True } - fa :: ([String],Int,Int) -> IO () - fa (f,n,no) = - do putStr "\n" - putStr (" ** test " - ++ show (n :: Int) - ++ " of " - ++ name - ++ " failed with the binding(s)\n") - sequence_ [putStr (" ** " ++ v ++ "\n") - | v <- f ] - putStr "\n" - diff --git a/quickcheck/run.sh b/quickcheck/run.sh deleted file mode 100644 index cff728abee..0000000000 --- a/quickcheck/run.sh +++ /dev/null @@ -1,23 +0,0 @@ -#!/bin/sh - -# I suck at bash scripting. Please feel free to make this code better. - -Root=../compiler - -ExtraOptions="-cpp -fglasgow-exts -package ghc" - -HC=$Root/stage2/ghc-inplace - -Debug="False" - -if [ "$1" == "debug" ] - then - Debug="True" -fi - -if [ "$1" == "ghci" ] - then - $HC --interactive $ExtraOptions $2 - else - $HC --interactive -e "runUnitTests $Debug" $ExtraOptions RunTests.hs -fi
\ No newline at end of file diff --git a/rts/Capability.c b/rts/Capability.c index fe5dbdca40..91c5e2d98e 100644 --- a/rts/Capability.c +++ b/rts/Capability.c @@ -92,12 +92,17 @@ findSpark (Capability *cap) // spark = reclaimSpark(cap->sparks); // However, measurements show that this makes at least one benchmark // slower (prsa) and doesn't affect the others. - spark = tryStealSpark(cap); + spark = tryStealSpark(cap->sparks); + while (spark != NULL && fizzledSpark(spark)) { + cap->spark_stats.fizzled++; + traceEventSparkFizzle(cap); + spark = tryStealSpark(cap->sparks); + } if (spark != NULL) { - cap->sparks_converted++; + cap->spark_stats.converted++; // Post event for running a spark from capability's own pool. - traceEventRunSpark(cap, cap->r.rCurrentTSO); + traceEventSparkRun(cap); return spark; } @@ -121,7 +126,12 @@ findSpark (Capability *cap) if (emptySparkPoolCap(robbed)) // nothing to steal here continue; - spark = tryStealSpark(robbed); + spark = tryStealSpark(robbed->sparks); + while (spark != NULL && fizzledSpark(spark)) { + cap->spark_stats.fizzled++; + traceEventSparkFizzle(cap); + spark = tryStealSpark(robbed->sparks); + } if (spark == NULL && !emptySparkPoolCap(robbed)) { // we conflicted with another thread while trying to steal; // try again later. @@ -129,9 +139,8 @@ findSpark (Capability *cap) } if (spark != NULL) { - cap->sparks_converted++; - - traceEventStealSpark(cap, cap->r.rCurrentTSO, robbed->no); + cap->spark_stats.converted++; + traceEventSparkSteal(cap, robbed->no); return spark; } @@ -224,11 +233,13 @@ initCapability( Capability *cap, nat i ) cap->returning_tasks_hd = NULL; cap->returning_tasks_tl = NULL; cap->inbox = (Message*)END_TSO_QUEUE; - cap->sparks_created = 0; - cap->sparks_dud = 0; - cap->sparks_converted = 0; - cap->sparks_gcd = 0; - cap->sparks_fizzled = 0; + cap->sparks = allocSparkPool(); + cap->spark_stats.created = 0; + cap->spark_stats.dud = 0; + cap->spark_stats.overflowed = 0; + cap->spark_stats.converted = 0; + cap->spark_stats.gcd = 0; + cap->spark_stats.fizzled = 0; #endif cap->f.stgEagerBlackholeInfo = (W_)&__stg_EAGER_BLACKHOLE_info; @@ -255,6 +266,9 @@ initCapability( Capability *cap, nat i ) cap->pinned_object_block = NULL; traceCapsetAssignCap(CAPSET_OSPROCESS_DEFAULT, i); +#if defined(THREADED_RTS) + traceSparkCounters(cap); +#endif } /* --------------------------------------------------------------------------- @@ -608,6 +622,7 @@ yieldCapability (Capability** pCap, Task *task) traceEventGcStart(cap); gcWorkerThread(cap); traceEventGcEnd(cap); + traceSparkCounters(cap); return; } @@ -819,7 +834,9 @@ shutdownCapability (Capability *cap, // threads performing foreign calls that will eventually try to // return via resumeThread() and attempt to grab cap->lock. // closeMutex(&cap->lock); - + + traceSparkCounters(cap); + #endif /* THREADED_RTS */ traceCapsetRemoveCap(CAPSET_OSPROCESS_DEFAULT, cap->no); @@ -834,6 +851,10 @@ shutdownCapabilities(Task *task, rtsBool safe) shutdownCapability(&capabilities[i], task, safe); } traceCapsetDelete(CAPSET_OSPROCESS_DEFAULT); + +#if defined(THREADED_RTS) + ASSERT(checkSparkCountInvariant()); +#endif } static void @@ -904,3 +925,34 @@ markCapabilities (evac_fn evac, void *user) markCapability(evac, user, &capabilities[n], rtsFalse); } } + +#if defined(THREADED_RTS) +rtsBool checkSparkCountInvariant (void) +{ + SparkCounters sparks = { 0, 0, 0, 0, 0, 0 }; + StgWord64 remaining = 0; + nat i; + + for (i = 0; i < n_capabilities; i++) { + sparks.created += capabilities[i].spark_stats.created; + sparks.dud += capabilities[i].spark_stats.dud; + sparks.overflowed+= capabilities[i].spark_stats.overflowed; + sparks.converted += capabilities[i].spark_stats.converted; + sparks.gcd += capabilities[i].spark_stats.gcd; + sparks.fizzled += capabilities[i].spark_stats.fizzled; + remaining += sparkPoolSize(capabilities[i].sparks); + } + + /* The invariant is + * created = converted + remaining + gcd + fizzled + */ + debugTrace(DEBUG_sparks,"spark invariant: %ld == %ld + %ld + %ld + %ld " + "(created == converted + remaining + gcd + fizzled)", + sparks.created, sparks.converted, remaining, + sparks.gcd, sparks.fizzled); + + return (sparks.created == + sparks.converted + remaining + sparks.gcd + sparks.fizzled); + +} +#endif diff --git a/rts/Capability.h b/rts/Capability.h index d380af9cff..10c7c496e4 100644 --- a/rts/Capability.h +++ b/rts/Capability.h @@ -98,11 +98,7 @@ struct Capability_ { SparkPool *sparks; // Stats on spark creation/conversion - nat sparks_created; - nat sparks_dud; - nat sparks_converted; - nat sparks_gcd; - nat sparks_fizzled; + SparkCounters spark_stats; #endif // Per-capability STM-related data @@ -143,6 +139,10 @@ struct Capability_ { ASSERT(myTask() == task); \ ASSERT_TASK_ID(task); +#if defined(THREADED_RTS) +rtsBool checkSparkCountInvariant (void); +#endif + // Converts a *StgRegTable into a *Capability. // INLINE_HEADER Capability * diff --git a/rts/Globals.c b/rts/Globals.c index 7b8967f685..06b2f9721f 100644 --- a/rts/Globals.c +++ b/rts/Globals.c @@ -19,7 +19,6 @@ #include "Stable.h" typedef enum { - TypeableStore, GHCConcSignalSignalHandlerStore, GHCConcWindowsPendingDelaysStore, GHCConcWindowsIOManagerThreadStore, @@ -80,13 +79,6 @@ static StgStablePtr getOrSetKey(StoreKey key, StgStablePtr ptr) return ret; } - -StgStablePtr -getOrSetTypeableStore(StgStablePtr ptr) -{ - return getOrSetKey(TypeableStore,ptr); -} - StgStablePtr getOrSetGHCConcSignalSignalHandlerStore(StgStablePtr ptr) { diff --git a/rts/Linker.c b/rts/Linker.c index 6d29ce7409..781f705536 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -787,7 +787,6 @@ typedef struct _RtsSymbolVal { SymI_HasProto(forkProcess) \ SymI_HasProto(forkOS_createThread) \ SymI_HasProto(freeHaskellFunctionPtr) \ - SymI_HasProto(getOrSetTypeableStore) \ SymI_HasProto(getOrSetGHCConcSignalSignalHandlerStore) \ SymI_HasProto(getOrSetGHCConcWindowsPendingDelaysStore) \ SymI_HasProto(getOrSetGHCConcWindowsIOManagerThreadStore) \ diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c index 24181d32b0..fcc1f49a36 100644 --- a/rts/RtsFlags.c +++ b/rts/RtsFlags.c @@ -163,6 +163,9 @@ void initRtsFlagsDefaults(void) RtsFlags.TraceFlags.tracing = TRACE_NONE; RtsFlags.TraceFlags.timestamp = rtsFalse; RtsFlags.TraceFlags.scheduler = rtsFalse; + RtsFlags.TraceFlags.gc = rtsFalse; + RtsFlags.TraceFlags.sparks_sampled= rtsFalse; + RtsFlags.TraceFlags.sparks_full = rtsFalse; #endif RtsFlags.MiscFlags.tickInterval = 20; /* In milliseconds */ @@ -288,9 +291,15 @@ usage_text[] = { # endif " where [flags] can contain:", " s scheduler events", +" g GC events", +" p par spark events (sampled)", +" f par spark events (full detail)", # ifdef DEBUG " t add time stamps (only useful with -v)", # endif +" a all event classes above", +" -x disable an event class, for any flag above", +" the initial enabled event classes are 'sgp'", #endif #if !defined(PROFILING) @@ -1429,19 +1438,64 @@ decodeSize(const char *flag, nat offset, StgWord64 min, StgWord64 max) static void read_trace_flags(char *arg) { char *c; + rtsBool enabled = rtsTrue; + /* Syntax for tracing flags currently looks like: + * + * -l To turn on eventlog tracing with default trace classes + * -lx Turn on class 'x' (for some class listed below) + * -l-x Turn off class 'x' + * -la Turn on all classes + * -l-a Turn off all classes + * + * This lets users say things like: + * -la-p "all but sparks" + * -l-ap "only sparks" + */ + + /* Start by turning on the default tracing flags. + * + * Currently this is all the trace classes, except full-detail sparks. + * Similarly, in future we might default to slightly less verbose + * scheduler or GC tracing. + */ + RtsFlags.TraceFlags.scheduler = rtsTrue; + RtsFlags.TraceFlags.gc = rtsTrue; + RtsFlags.TraceFlags.sparks_sampled = rtsTrue; for (c = arg; *c != '\0'; c++) { switch(*c) { case '\0': break; + case '-': + enabled = rtsFalse; + break; + case 'a': + RtsFlags.TraceFlags.scheduler = enabled; + RtsFlags.TraceFlags.gc = enabled; + RtsFlags.TraceFlags.sparks_sampled = enabled; + RtsFlags.TraceFlags.sparks_full = enabled; + enabled = rtsTrue; + break; + case 's': - RtsFlags.TraceFlags.scheduler = rtsTrue; + RtsFlags.TraceFlags.scheduler = enabled; + enabled = rtsTrue; + break; + case 'p': + RtsFlags.TraceFlags.sparks_sampled = enabled; + enabled = rtsTrue; + break; + case 'f': + RtsFlags.TraceFlags.sparks_full = enabled; + enabled = rtsTrue; break; case 't': - RtsFlags.TraceFlags.timestamp = rtsTrue; + RtsFlags.TraceFlags.timestamp = enabled; + enabled = rtsTrue; break; case 'g': - // ignored for backwards-compat + RtsFlags.TraceFlags.gc = enabled; + enabled = rtsTrue; break; default: errorBelch("unknown trace option: %c",*c); diff --git a/rts/RtsProbes.d b/rts/RtsProbes.d index bd32fca385..755b25525b 100644 --- a/rts/RtsProbes.d +++ b/rts/RtsProbes.d @@ -43,8 +43,6 @@ provider HaskellEvent { probe stop__thread (EventCapNo, EventThreadID, EventThreadStatus, EventThreadID); probe thread__runnable (EventCapNo, EventThreadID); probe migrate__thread (EventCapNo, EventThreadID, EventCapNo); - probe run__spark (EventCapNo, EventThreadID); - probe steal__spark (EventCapNo, EventThreadID, EventCapNo); probe shutdown (EventCapNo); probe thread_wakeup (EventCapNo, EventThreadID, EventCapNo); probe gc__start (EventCapNo); @@ -67,4 +65,16 @@ provider HaskellEvent { probe capset__assign__cap(EventCapsetID, EventCapNo); probe capset__remove__cap(EventCapsetID, EventCapNo); + probe spark__counters(EventCapNo, + StgWord, StgWord, StgWord + StgWord, StgWord, StgWord + StgWord); + + probe spark__create (EventCapNo); + probe spark__dud (EventCapNo); + probe spark__overflow (EventCapNo); + probe spark__run (EventCapNo); + probe spark__steal (EventCapNo, EventCapNo); + probe spark__fizzle (EventCapNo); + probe spark__gc (EventCapNo); }; diff --git a/rts/Schedule.c b/rts/Schedule.c index 45959a92eb..2a2cc22a66 100644 --- a/rts/Schedule.c +++ b/rts/Schedule.c @@ -581,6 +581,10 @@ static void schedulePreLoop(void) { // initialisation for scheduler - what cannot go into initScheduler() + +#if defined(mingw32_HOST_OS) + win32AllocStack(); +#endif } /* ----------------------------------------------------------------------------- @@ -779,6 +783,10 @@ schedulePushWork(Capability *cap USED_IF_THREADS, if (emptySparkPoolCap(free_caps[i])) { spark = tryStealSpark(cap->sparks); if (spark != NULL) { + /* TODO: if anyone wants to re-enable this code then + * they must consider the fizzledSpark(spark) case + * and update the per-cap spark statistics. + */ debugTrace(DEBUG_sched, "pushing spark %p to capability %d", spark, free_caps[i]->no); traceEventStealSpark(free_caps[i], t, cap->no); @@ -1406,6 +1414,11 @@ scheduleDoGC (Capability *cap, Task *task USED_IF_THREADS, rtsBool force_major) // multi-threaded GC: make sure all the Capabilities donate one // GC thread each. waitForGcThreads(cap); + +#if defined(THREADED_RTS) + // Stable point where we can do a global check on our spark counters + ASSERT(checkSparkCountInvariant()); +#endif } #endif @@ -1436,6 +1449,8 @@ delete_threads_and_gc: #endif traceEventGcEnd(cap); + traceSparkCounters(cap); + if (recent_activity == ACTIVITY_INACTIVE && force_major) { // We are doing a GC because the system has been idle for a @@ -1453,6 +1468,11 @@ delete_threads_and_gc: recent_activity = ACTIVITY_YES; } +#if defined(THREADED_RTS) + // Stable point where we can do a global check on our spark counters + ASSERT(checkSparkCountInvariant()); +#endif + if (heap_census) { debugTrace(DEBUG_sched, "performing heap census"); heapCensus(); @@ -1992,10 +2012,6 @@ initScheduler(void) initTaskManager(); -#if defined(THREADED_RTS) - initSparkPools(); -#endif - RELEASE_LOCK(&sched_mutex); #if defined(THREADED_RTS) diff --git a/rts/Sparks.c b/rts/Sparks.c index a826190941..4241656795 100644 --- a/rts/Sparks.c +++ b/rts/Sparks.c @@ -17,14 +17,10 @@ #if defined(THREADED_RTS) -void -initSparkPools( void ) +SparkPool * +allocSparkPool( void ) { - /* walk over the capabilities, allocating a spark pool for each one */ - nat i; - for (i = 0; i < n_capabilities; i++) { - capabilities[i].sparks = newWSDeque(RtsFlags.ParFlags.maxLocalSparks); - } + return newWSDeque(RtsFlags.ParFlags.maxLocalSparks); } void @@ -63,48 +59,23 @@ newSpark (StgRegTable *reg, StgClosure *p) Capability *cap = regTableToCapability(reg); SparkPool *pool = cap->sparks; - /* I am not sure whether this is the right thing to do. - * Maybe it is better to exploit the tag information - * instead of throwing it away? - */ - p = UNTAG_CLOSURE(p); - - if (closure_SHOULD_SPARK(p)) { - pushWSDeque(pool,p); - cap->sparks_created++; + if (!fizzledSpark(p)) { + if (pushWSDeque(pool,p)) { + cap->spark_stats.created++; + traceEventSparkCreate(cap); + } else { + /* overflowing the spark pool */ + cap->spark_stats.overflowed++; + traceEventSparkOverflow(cap); + } } else { - cap->sparks_dud++; + cap->spark_stats.dud++; + traceEventSparkDud(cap); } return 1; } -/* ----------------------------------------------------------------------------- - * - * tryStealSpark: try to steal a spark from a Capability. - * - * Returns a valid spark, or NULL if the pool was empty, and can - * occasionally return NULL if there was a race with another thread - * stealing from the same pool. In this case, try again later. - * - -------------------------------------------------------------------------- */ - -StgClosure * -tryStealSpark (Capability *cap) -{ - SparkPool *pool = cap->sparks; - StgClosure *stolen; - - do { - stolen = stealWSDeque_(pool); - // use the no-loopy version, stealWSDeque_(), since if we get a - // spurious NULL here the caller may want to try stealing from - // other pools before trying again. - } while (stolen != NULL && !closure_SHOULD_SPARK(stolen)); - - return stolen; -} - /* -------------------------------------------------------------------------- * Remove all sparks from the spark queues which should not spark any * more. Called after GC. We assume exclusive access to the structure @@ -205,7 +176,8 @@ pruneSparkQueue (Capability *cap) // evaluated, but it doesn't hurt to have this check for // robustness. pruned_sparks++; - cap->sparks_fizzled++; + cap->spark_stats.fizzled++; + traceEventSparkFizzle(cap); } else { info = spark->header.info; if (IS_FORWARDING_PTR(info)) { @@ -217,7 +189,8 @@ pruneSparkQueue (Capability *cap) n++; } else { pruned_sparks++; // discard spark - cap->sparks_fizzled++; + cap->spark_stats.fizzled++; + traceEventSparkFizzle(cap); } } else if (HEAP_ALLOCED(spark)) { if ((Bdescr((P_)spark)->flags & BF_EVACUATED)) { @@ -227,11 +200,13 @@ pruneSparkQueue (Capability *cap) n++; } else { pruned_sparks++; // discard spark - cap->sparks_fizzled++; + cap->spark_stats.fizzled++; + traceEventSparkFizzle(cap); } } else { pruned_sparks++; // discard spark - cap->sparks_gcd++; + cap->spark_stats.gcd++; + traceEventSparkGC(cap); } } else { if (INFO_PTR_TO_STRUCT(info)->type == THUNK_STATIC) { @@ -241,11 +216,13 @@ pruneSparkQueue (Capability *cap) n++; } else { pruned_sparks++; // discard spark - cap->sparks_gcd++; + cap->spark_stats.gcd++; + traceEventSparkGC(cap); } } else { pruned_sparks++; // discard spark - cap->sparks_fizzled++; + cap->spark_stats.fizzled++; + traceEventSparkFizzle(cap); } } } diff --git a/rts/Sparks.h b/rts/Sparks.h index cffe99dd39..e381dd540f 100644 --- a/rts/Sparks.h +++ b/rts/Sparks.h @@ -15,12 +15,22 @@ /* typedef for SparkPool in RtsTypes.h */ +/* Stats on spark creation/conversion */ +typedef struct { + StgWord created; + StgWord dud; + StgWord overflowed; + StgWord converted; + StgWord gcd; + StgWord fizzled; +} SparkCounters; + #if defined(THREADED_RTS) typedef WSDeque SparkPool; // Initialisation -void initSparkPools (void); +SparkPool *allocSparkPool (void); // Take a spark from the "write" end of the pool. Can be called // by the pool owner only. @@ -30,7 +40,9 @@ INLINE_HEADER StgClosure* reclaimSpark(SparkPool *pool); // if the pool is almost empty). INLINE_HEADER rtsBool looksEmpty(SparkPool* deque); -StgClosure * tryStealSpark (Capability *cap); +INLINE_HEADER StgClosure * tryStealSpark (SparkPool *pool); +INLINE_HEADER rtsBool fizzledSpark (StgClosure *); + void freeSparkPool (SparkPool *pool); void createSparkThread (Capability *cap); void traverseSparkQueue(evac_fn evac, void *user, Capability *cap); @@ -63,6 +75,32 @@ INLINE_HEADER void discardSparks (SparkPool *pool) discardElements(pool); } +/* ---------------------------------------------------------------------------- + * + * tryStealSpark: try to steal a spark from a Capability. + * + * Returns either: + * (a) a useful spark; + * (b) a fizzled spark (use fizzledSpark to check); + * (c) or NULL if the pool was empty, and can occasionally return NULL + * if there was a race with another thread stealing from the same + * pool. In this case, try again later. + * + -------------------------------------------------------------------------- */ + +INLINE_HEADER StgClosure * tryStealSpark (SparkPool *pool) +{ + return stealWSDeque_(pool); + // use the no-loopy version, stealWSDeque_(), since if we get a + // spurious NULL here the caller may want to try stealing from + // other pools before trying again. +} + +INLINE_HEADER rtsBool fizzledSpark (StgClosure *spark) +{ + return (GET_CLOSURE_TAG(spark) != 0 || !closure_SHOULD_SPARK(spark)); +} + #endif // THREADED_RTS #include "EndPrivate.h" diff --git a/rts/Stats.c b/rts/Stats.c index 9fc702a2a3..7c02b5a7d9 100644 --- a/rts/Stats.c +++ b/rts/Stats.c @@ -629,21 +629,20 @@ stat_exit(int alloc) { nat i; - lnat sparks_created = 0; - lnat sparks_dud = 0; - lnat sparks_converted = 0; - lnat sparks_gcd = 0; - lnat sparks_fizzled = 0; + SparkCounters sparks = { 0, 0, 0, 0, 0, 0}; for (i = 0; i < n_capabilities; i++) { - sparks_created += capabilities[i].sparks_created; - sparks_dud += capabilities[i].sparks_dud; - sparks_converted += capabilities[i].sparks_converted; - sparks_gcd += capabilities[i].sparks_gcd; - sparks_fizzled += capabilities[i].sparks_fizzled; + sparks.created += capabilities[i].spark_stats.created; + sparks.dud += capabilities[i].spark_stats.dud; + sparks.overflowed+= capabilities[i].spark_stats.overflowed; + sparks.converted += capabilities[i].spark_stats.converted; + sparks.gcd += capabilities[i].spark_stats.gcd; + sparks.fizzled += capabilities[i].spark_stats.fizzled; } - statsPrintf(" SPARKS: %ld (%ld converted, %ld dud, %ld GC'd, %ld fizzled)\n\n", - sparks_created + sparks_dud, sparks_converted, sparks_dud, sparks_gcd, sparks_fizzled); + statsPrintf(" SPARKS: %ld (%ld converted, %ld overflowed, %ld dud, %ld GC'd, %ld fizzled)\n\n", + sparks.created + sparks.dud + sparks.overflowed, + sparks.converted, sparks.overflowed, sparks.dud, + sparks.gcd, sparks.fizzled); } #endif diff --git a/rts/StgCRun.c b/rts/StgCRun.c index 54ac04151c..69d9549f6e 100644 --- a/rts/StgCRun.c +++ b/rts/StgCRun.c @@ -192,6 +192,18 @@ StgRunIsImplementedInAssembler(void) ); } +#if defined(mingw32_HOST_OS) +// On windows the stack has to be allocated 4k at a time, otherwise +// we get a segfault. The C compiler knows how to do this (it calls +// _alloca()), so we make sure that we can allocate as much stack as +// we need: +StgWord8 *win32AllocStack(void) +{ + StgWord8 stack[RESERVED_C_STACK_BYTES + 16 + 12]; + return stack; +} +#endif + #endif /* ---------------------------------------------------------------------------- diff --git a/rts/StgRun.h b/rts/StgRun.h index f277097df7..71b92e2d88 100644 --- a/rts/StgRun.h +++ b/rts/StgRun.h @@ -11,4 +11,8 @@ RTS_PRIVATE StgRegTable * StgRun (StgFunPtr f, StgRegTable *basereg); +#if defined(mingw32_HOST_OS) +StgWord8 *win32AllocStack(void); +#endif + #endif /* STGRUN_H */ diff --git a/rts/Trace.c b/rts/Trace.c index 70f4a39742..1dce968490 100644 --- a/rts/Trace.c +++ b/rts/Trace.c @@ -47,6 +47,9 @@ int DEBUG_sparks; // events int TRACE_sched; +int TRACE_gc; +int TRACE_spark_sampled; +int TRACE_spark_full; #ifdef THREADED_RTS static Mutex trace_utx; @@ -90,8 +93,25 @@ void initTracing (void) RtsFlags.TraceFlags.scheduler || RtsFlags.DebugFlags.scheduler; + // -Dg turns on gc tracing too + TRACE_gc = + RtsFlags.TraceFlags.gc || + RtsFlags.DebugFlags.gc; + + TRACE_spark_sampled = + RtsFlags.TraceFlags.sparks_sampled; + + // -Dr turns on full spark tracing + TRACE_spark_full = + RtsFlags.TraceFlags.sparks_full || + RtsFlags.DebugFlags.sparks; + eventlog_enabled = RtsFlags.TraceFlags.tracing == TRACE_EVENTLOG; + /* Note: we can have TRACE_sched or TRACE_spark turned on even when + eventlog_enabled is off. In the DEBUG way we may be tracing to stderr. + */ + if (eventlog_enabled) { initEventLogging(); } @@ -179,22 +199,10 @@ static void traceSchedEvent_stderr (Capability *cap, EventTypeNum tag, debugBelch("cap %d: thread %lu appended to run queue\n", cap->no, (lnat)tso->id); break; - case EVENT_RUN_SPARK: // (cap, thread) - debugBelch("cap %d: thread %lu running a spark\n", - cap->no, (lnat)tso->id); - break; - case EVENT_CREATE_SPARK_THREAD: // (cap, spark_thread) - debugBelch("cap %d: creating spark thread %lu\n", - cap->no, (long)info1); - break; case EVENT_MIGRATE_THREAD: // (cap, thread, new_cap) debugBelch("cap %d: thread %lu migrating to cap %d\n", cap->no, (lnat)tso->id, (int)info1); break; - case EVENT_STEAL_SPARK: // (cap, thread, victim_cap) - debugBelch("cap %d: thread %lu stealing a spark from cap %d\n", - cap->no, (lnat)tso->id, (int)info1); - break; case EVENT_THREAD_WAKEUP: // (cap, thread, info1_cap) debugBelch("cap %d: waking up thread %lu on cap %d\n", cap->no, (lnat)tso->id, (int)info1); @@ -212,27 +220,6 @@ static void traceSchedEvent_stderr (Capability *cap, EventTypeNum tag, case EVENT_SHUTDOWN: // (cap) debugBelch("cap %d: shutting down\n", cap->no); break; - case EVENT_REQUEST_SEQ_GC: // (cap) - debugBelch("cap %d: requesting sequential GC\n", cap->no); - break; - case EVENT_REQUEST_PAR_GC: // (cap) - debugBelch("cap %d: requesting parallel GC\n", cap->no); - break; - case EVENT_GC_START: // (cap) - debugBelch("cap %d: starting GC\n", cap->no); - break; - case EVENT_GC_END: // (cap) - debugBelch("cap %d: finished GC\n", cap->no); - break; - case EVENT_GC_IDLE: // (cap) - debugBelch("cap %d: GC idle\n", cap->no); - break; - case EVENT_GC_WORK: // (cap) - debugBelch("cap %d: GC working\n", cap->no); - break; - case EVENT_GC_DONE: // (cap) - debugBelch("cap %d: GC done\n", cap->no); - break; default: debugBelch("cap %d: thread %lu: event %d\n\n", cap->no, (lnat)tso->id, tag); @@ -256,6 +243,56 @@ void traceSchedEvent_ (Capability *cap, EventTypeNum tag, } } +#ifdef DEBUG +static void traceGcEvent_stderr (Capability *cap, EventTypeNum tag) +{ + ACQUIRE_LOCK(&trace_utx); + + tracePreface(); + switch (tag) { + case EVENT_REQUEST_SEQ_GC: // (cap) + debugBelch("cap %d: requesting sequential GC\n", cap->no); + break; + case EVENT_REQUEST_PAR_GC: // (cap) + debugBelch("cap %d: requesting parallel GC\n", cap->no); + break; + case EVENT_GC_START: // (cap) + debugBelch("cap %d: starting GC\n", cap->no); + break; + case EVENT_GC_END: // (cap) + debugBelch("cap %d: finished GC\n", cap->no); + break; + case EVENT_GC_IDLE: // (cap) + debugBelch("cap %d: GC idle\n", cap->no); + break; + case EVENT_GC_WORK: // (cap) + debugBelch("cap %d: GC working\n", cap->no); + break; + case EVENT_GC_DONE: // (cap) + debugBelch("cap %d: GC done\n", cap->no); + break; + default: + barf("traceGcEvent: unknown event tag %d", tag); + break; + } + + RELEASE_LOCK(&trace_utx); +} +#endif + +void traceGcEvent_ (Capability *cap, EventTypeNum tag) +{ +#ifdef DEBUG + if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) { + traceGcEvent_stderr(cap, tag); + } else +#endif + { + /* currently all GC events are nullary events */ + postEvent(cap, tag); + } +} + void traceCapsetModify_ (EventTypeNum tag, CapsetID capset, StgWord32 other) @@ -335,15 +372,80 @@ void traceOSProcessInfo_(void) { } } -void traceEvent_ (Capability *cap, EventTypeNum tag) +#ifdef DEBUG +static void traceSparkEvent_stderr (Capability *cap, EventTypeNum tag, + StgWord info1) +{ + ACQUIRE_LOCK(&trace_utx); + + tracePreface(); + switch (tag) { + + case EVENT_CREATE_SPARK_THREAD: // (cap, spark_thread) + debugBelch("cap %d: creating spark thread %lu\n", + cap->no, (long)info1); + break; + case EVENT_SPARK_CREATE: // (cap) + debugBelch("cap %d: added spark to pool\n", + cap->no); + break; + case EVENT_SPARK_DUD: // (cap) + debugBelch("cap %d: discarded dud spark\n", + cap->no); + break; + case EVENT_SPARK_OVERFLOW: // (cap) + debugBelch("cap %d: discarded overflowed spark\n", + cap->no); + break; + case EVENT_SPARK_RUN: // (cap) + debugBelch("cap %d: running a spark\n", + cap->no); + break; + case EVENT_SPARK_STEAL: // (cap, victim_cap) + debugBelch("cap %d: stealing a spark from cap %d\n", + cap->no, (int)info1); + break; + case EVENT_SPARK_FIZZLE: // (cap) + debugBelch("cap %d: fizzled spark removed from pool\n", + cap->no); + break; + case EVENT_SPARK_GC: // (cap) + debugBelch("cap %d: GCd spark removed from pool\n", + cap->no); + break; + default: + barf("traceSparkEvent: unknown event tag %d", tag); + break; + } + + RELEASE_LOCK(&trace_utx); +} +#endif + +void traceSparkEvent_ (Capability *cap, EventTypeNum tag, StgWord info1) +{ +#ifdef DEBUG + if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) { + traceSparkEvent_stderr(cap, tag, info1); + } else +#endif + { + postSparkEvent(cap,tag,info1); + } +} + +void traceSparkCounters_ (Capability *cap, + SparkCounters counters, + StgWord remaining) { #ifdef DEBUG if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) { - traceSchedEvent_stderr(cap, tag, 0, 0, 0); + /* we currently don't do debug tracing of spark stats but we must + test for TRACE_STDERR because of the !eventlog_enabled case. */ } else #endif { - postEvent(cap,tag); + postSparkCountersEvent(cap, counters, remaining); } } diff --git a/rts/Trace.h b/rts/Trace.h index dd396904e7..40a4522a26 100644 --- a/rts/Trace.h +++ b/rts/Trace.h @@ -62,6 +62,9 @@ extern int DEBUG_sparks; // events extern int TRACE_sched; +extern int TRACE_gc; +extern int TRACE_spark_sampled; +extern int TRACE_spark_full; // ----------------------------------------------------------------------------- // Posting events @@ -96,16 +99,30 @@ void traceEnd (void); void traceSchedEvent_ (Capability *cap, EventTypeNum tag, StgTSO *tso, StgWord info1, StgWord info2); +/* + * Record a GC event + */ +#define traceGcEvent(cap, tag) \ + if (RTS_UNLIKELY(TRACE_gc)) { \ + traceGcEvent_(cap, tag); \ + } -/* - * Record a nullary event +void traceGcEvent_ (Capability *cap, EventTypeNum tag); + +/* + * Record a spark event */ -#define traceEvent(cap, tag) \ - if (RTS_UNLIKELY(TRACE_sched)) { \ - traceEvent_(cap, tag); \ +#define traceSparkEvent(cap, tag) \ + if (RTS_UNLIKELY(TRACE_spark_full)) { \ + traceSparkEvent_(cap, tag, 0); \ + } + +#define traceSparkEvent2(cap, tag, other) \ + if (RTS_UNLIKELY(TRACE_spark_full)) { \ + traceSparkEvent_(cap, tag, other); \ } -void traceEvent_ (Capability *cap, EventTypeNum tag); +void traceSparkEvent_ (Capability *cap, EventTypeNum tag, StgWord info1); // variadic macros are C99, and supported by gcc. However, the // ##__VA_ARGS syntax is a gcc extension, which allows the variable @@ -184,11 +201,17 @@ void traceCapsetModify_ (EventTypeNum tag, void traceOSProcessInfo_ (void); +void traceSparkCounters_ (Capability *cap, + SparkCounters counters, + StgWord remaining); + #else /* !TRACING */ #define traceSchedEvent(cap, tag, tso, other) /* nothing */ #define traceSchedEvent2(cap, tag, tso, other, info) /* nothing */ -#define traceEvent(cap, tag) /* nothing */ +#define traceGcEvent(cap, tag) /* nothing */ +#define traceSparkEvent(cap, tag) /* nothing */ +#define traceSparkEvent2(cap, tag, other) /* nothing */ #define traceCap(class, cap, msg, ...) /* nothing */ #define trace(class, msg, ...) /* nothing */ #define debugTrace(class, str, ...) /* nothing */ @@ -197,6 +220,7 @@ void traceOSProcessInfo_ (void); INLINE_HEADER void traceEventStartup_ (int n_caps STG_UNUSED) {}; #define traceCapsetModify_(tag, capset, other) /* nothing */ #define traceOSProcessInfo_() /* nothing */ +#define traceSparkCounters_(cap, counters, remaining) /* nothing */ #endif /* TRACING */ @@ -225,10 +249,6 @@ void dtraceUserMsgWrapper(Capability *cap, char *msg); HASKELLEVENT_THREAD_RUNNABLE(cap, tid) #define dtraceMigrateThread(cap, tid, new_cap) \ HASKELLEVENT_MIGRATE_THREAD(cap, tid, new_cap) -#define dtraceRunSpark(cap, tid) \ - HASKELLEVENT_RUN_SPARK(cap, tid) -#define dtraceStealSpark(cap, tid, victim_cap) \ - HASKELLEVENT_STEAL_SPARK(cap, tid, victim_cap) #define dtraceShutdown(cap) \ HASKELLEVENT_SHUTDOWN(cap) #define dtraceThreadWakeup(cap, tid, other_cap) \ @@ -262,6 +282,22 @@ INLINE_HEADER void dtraceStartup (int num_caps) { HASKELLEVENT_CAPSET_ASSIGN_CAP(capset, capno) #define dtraceCapsetRemoveCap(capset, capno) \ HASKELLEVENT_CAPSET_REMOVE_CAP(capset, capno) +#define dtraceSparkCounters(cap, a, b, c, d, e, f, g) \ + HASKELLEVENT_SPARK_COUNTERS(cap, a, b, c, d, e, f, g) +#define dtraceSparkCreate(cap) \ + HASKELLEVENT_SPARK_CREATE(cap) +#define dtraceSparkDud(cap) \ + HASKELLEVENT_SPARK_DUD(cap) +#define dtraceSparkOverflow(cap) \ + HASKELLEVENT_SPARK_OVERFLOW(cap) +#define dtraceSparkRun(cap) \ + HASKELLEVENT_SPARK_RUN(cap) +#define dtraceSparkSteal(cap, victim_cap) \ + HASKELLEVENT_SPARK_STEAL(cap, victim_cap) +#define dtraceSparkFizzle(cap) \ + HASKELLEVENT_SPARK_FIZZLE(cap) +#define dtraceSparkGc(cap) \ + HASKELLEVENT_SPARK_GC(cap) #else /* !defined(DTRACE) */ @@ -270,8 +306,6 @@ INLINE_HEADER void dtraceStartup (int num_caps) { #define dtraceStopThread(cap, tid, status, info) /* nothing */ #define dtraceThreadRunnable(cap, tid) /* nothing */ #define dtraceMigrateThread(cap, tid, new_cap) /* nothing */ -#define dtraceRunSpark(cap, tid) /* nothing */ -#define dtraceStealSpark(cap, tid, victim_cap) /* nothing */ #define dtraceShutdown(cap) /* nothing */ #define dtraceThreadWakeup(cap, tid, other_cap) /* nothing */ #define dtraceGcStart(cap) /* nothing */ @@ -288,6 +322,14 @@ INLINE_HEADER void dtraceStartup (int num_caps STG_UNUSED) {}; #define dtraceCapsetDelete(capset) /* nothing */ #define dtraceCapsetAssignCap(capset, capno) /* nothing */ #define dtraceCapsetRemoveCap(capset, capno) /* nothing */ +#define dtraceSparkCounters(cap, a, b, c, d, e, f, g) /* nothing */ +#define dtraceSparkCreate(cap) /* nothing */ +#define dtraceSparkDud(cap) /* nothing */ +#define dtraceSparkOverflow(cap) /* nothing */ +#define dtraceSparkRun(cap) /* nothing */ +#define dtraceSparkSteal(cap, victim_cap) /* nothing */ +#define dtraceSparkFizzle(cap) /* nothing */ +#define dtraceSparkGc(cap) /* nothing */ #endif @@ -352,22 +394,6 @@ INLINE_HEADER void traceEventMigrateThread(Capability *cap STG_UNUSED, (EventCapNo)new_cap); } -INLINE_HEADER void traceEventRunSpark(Capability *cap STG_UNUSED, - StgTSO *tso STG_UNUSED) -{ - traceSchedEvent(cap, EVENT_RUN_SPARK, tso, 0); - dtraceRunSpark((EventCapNo)cap->no, (EventThreadID)tso->id); -} - -INLINE_HEADER void traceEventStealSpark(Capability *cap STG_UNUSED, - StgTSO *tso STG_UNUSED, - nat victim_cap STG_UNUSED) -{ - traceSchedEvent(cap, EVENT_STEAL_SPARK, tso, victim_cap); - dtraceStealSpark((EventCapNo)cap->no, (EventThreadID)tso->id, - (EventCapNo)victim_cap); -} - INLINE_HEADER void traceEventShutdown(Capability *cap STG_UNUSED) { traceSchedEvent(cap, EVENT_SHUTDOWN, 0, 0); @@ -385,33 +411,44 @@ INLINE_HEADER void traceEventThreadWakeup(Capability *cap STG_UNUSED, INLINE_HEADER void traceEventGcStart(Capability *cap STG_UNUSED) { - traceSchedEvent(cap, EVENT_GC_START, 0, 0); + traceGcEvent(cap, EVENT_GC_START); dtraceGcStart((EventCapNo)cap->no); } INLINE_HEADER void traceEventGcEnd(Capability *cap STG_UNUSED) { - traceSchedEvent(cap, EVENT_GC_END, 0, 0); + traceGcEvent(cap, EVENT_GC_END); dtraceGcEnd((EventCapNo)cap->no); } INLINE_HEADER void traceEventRequestSeqGc(Capability *cap STG_UNUSED) { - traceSchedEvent(cap, EVENT_REQUEST_SEQ_GC, 0, 0); + traceGcEvent(cap, EVENT_REQUEST_SEQ_GC); dtraceRequestSeqGc((EventCapNo)cap->no); } INLINE_HEADER void traceEventRequestParGc(Capability *cap STG_UNUSED) { - traceSchedEvent(cap, EVENT_REQUEST_PAR_GC, 0, 0); + traceGcEvent(cap, EVENT_REQUEST_PAR_GC); dtraceRequestParGc((EventCapNo)cap->no); } -INLINE_HEADER void traceEventCreateSparkThread(Capability *cap STG_UNUSED, - StgThreadID spark_tid STG_UNUSED) +INLINE_HEADER void traceEventGcIdle(Capability *cap STG_UNUSED) { - traceSchedEvent(cap, EVENT_CREATE_SPARK_THREAD, 0, spark_tid); - dtraceCreateSparkThread((EventCapNo)cap->no, (EventThreadID)spark_tid); + traceGcEvent(cap, EVENT_GC_IDLE); + dtraceGcIdle((EventCapNo)cap->no); +} + +INLINE_HEADER void traceEventGcWork(Capability *cap STG_UNUSED) +{ + traceGcEvent(cap, EVENT_GC_WORK); + dtraceGcWork((EventCapNo)cap->no); +} + +INLINE_HEADER void traceEventGcDone(Capability *cap STG_UNUSED) +{ + traceGcEvent(cap, EVENT_GC_DONE); + dtraceGcDone((EventCapNo)cap->no); } INLINE_HEADER void traceEventStartup(void) @@ -428,24 +465,6 @@ INLINE_HEADER void traceEventStartup(void) dtraceStartup(n_caps); } -INLINE_HEADER void traceEventGcIdle(Capability *cap STG_UNUSED) -{ - traceEvent(cap, EVENT_GC_IDLE); - dtraceGcIdle((EventCapNo)cap->no); -} - -INLINE_HEADER void traceEventGcWork(Capability *cap STG_UNUSED) -{ - traceEvent(cap, EVENT_GC_WORK); - dtraceGcWork((EventCapNo)cap->no); -} - -INLINE_HEADER void traceEventGcDone(Capability *cap STG_UNUSED) -{ - traceEvent(cap, EVENT_GC_DONE); - dtraceGcDone((EventCapNo)cap->no); -} - INLINE_HEADER void traceCapsetCreate(CapsetID capset STG_UNUSED, CapsetType capset_type STG_UNUSED) { @@ -480,6 +499,73 @@ INLINE_HEADER void traceOSProcessInfo(void) * is available to DTrace directly */ } +INLINE_HEADER void traceEventCreateSparkThread(Capability *cap STG_UNUSED, + StgThreadID spark_tid STG_UNUSED) +{ + traceSparkEvent2(cap, EVENT_CREATE_SPARK_THREAD, spark_tid); + dtraceCreateSparkThread((EventCapNo)cap->no, (EventThreadID)spark_tid); +} + +INLINE_HEADER void traceSparkCounters(Capability *cap STG_UNUSED) +{ +#ifdef THREADED_RTS + if (RTS_UNLIKELY(TRACE_spark_sampled)) { + traceSparkCounters_(cap, cap->spark_stats, sparkPoolSize(cap->sparks)); + } +#endif + dtraceSparkCounters((EventCapNo)cap->no, + cap->spark_stats.created, + cap->spark_stats.dud, + cap->spark_stats.overflowed, + cap->spark_stats.converted, + cap->spark_stats.gcd, + cap->spark_stats.fizzled, + sparkPoolSize(cap->sparks)); +} + +INLINE_HEADER void traceEventSparkCreate(Capability *cap STG_UNUSED) +{ + traceSparkEvent(cap, EVENT_SPARK_CREATE); + dtraceSparkCreate((EventCapNo)cap->no); +} + +INLINE_HEADER void traceEventSparkDud(Capability *cap STG_UNUSED) +{ + traceSparkEvent(cap, EVENT_SPARK_DUD); + dtraceSparkDud((EventCapNo)cap->no); +} + +INLINE_HEADER void traceEventSparkOverflow(Capability *cap STG_UNUSED) +{ + traceSparkEvent(cap, EVENT_SPARK_OVERFLOW); + dtraceSparkOverflow((EventCapNo)cap->no); +} + +INLINE_HEADER void traceEventSparkRun(Capability *cap STG_UNUSED) +{ + traceSparkEvent(cap, EVENT_SPARK_RUN); + dtraceSparkRun((EventCapNo)cap->no); +} + +INLINE_HEADER void traceEventSparkSteal(Capability *cap STG_UNUSED, + nat victim_cap STG_UNUSED) +{ + traceSparkEvent2(cap, EVENT_SPARK_STEAL, victim_cap); + dtraceSparkSteal((EventCapNo)cap->no, (EventCapNo)victim_cap); +} + +INLINE_HEADER void traceEventSparkFizzle(Capability *cap STG_UNUSED) +{ + traceSparkEvent(cap, EVENT_SPARK_FIZZLE); + dtraceSparkFizzle((EventCapNo)cap->no); +} + +INLINE_HEADER void traceEventSparkGC(Capability *cap STG_UNUSED) +{ + traceSparkEvent(cap, EVENT_SPARK_GC); + dtraceSparkGc((EventCapNo)cap->no); +} + #include "EndPrivate.h" #endif /* TRACE_H */ diff --git a/rts/eventlog/EventLog.c b/rts/eventlog/EventLog.c index cea313e660..db0f3e4ad5 100644 --- a/rts/eventlog/EventLog.c +++ b/rts/eventlog/EventLog.c @@ -60,8 +60,6 @@ char *EventDesc[] = { [EVENT_STOP_THREAD] = "Stop thread", [EVENT_THREAD_RUNNABLE] = "Thread runnable", [EVENT_MIGRATE_THREAD] = "Migrate thread", - [EVENT_RUN_SPARK] = "Run spark", - [EVENT_STEAL_SPARK] = "Steal spark", [EVENT_SHUTDOWN] = "Shutdown", [EVENT_THREAD_WAKEUP] = "Wakeup thread", [EVENT_GC_START] = "Starting GC", @@ -84,7 +82,15 @@ char *EventDesc[] = { [EVENT_PROGRAM_ARGS] = "Program arguments", [EVENT_PROGRAM_ENV] = "Program environment variables", [EVENT_OSPROCESS_PID] = "Process ID", - [EVENT_OSPROCESS_PPID] = "Parent process ID" + [EVENT_OSPROCESS_PPID] = "Parent process ID", + [EVENT_SPARK_COUNTERS] = "Spark counters", + [EVENT_SPARK_CREATE] = "Spark create", + [EVENT_SPARK_DUD] = "Spark dud", + [EVENT_SPARK_OVERFLOW] = "Spark overflow", + [EVENT_SPARK_RUN] = "Spark run", + [EVENT_SPARK_STEAL] = "Spark steal", + [EVENT_SPARK_FIZZLE] = "Spark fizzle", + [EVENT_SPARK_GC] = "Spark GC", }; // Event type. @@ -95,7 +101,7 @@ typedef struct _EventType { char *desc; // Description } EventType; -EventType eventTypes[NUM_EVENT_TAGS]; +EventType eventTypes[NUM_GHC_EVENT_TAGS]; static void initEventsBuf(EventsBuf* eb, StgWord64 size, EventCapNo capno); static void resetEventsBuf(EventsBuf* eb); @@ -194,7 +200,7 @@ initEventLogging(void) + 10 /* .eventlog */, "initEventLogging"); - if (sizeof(EventDesc) / sizeof(char*) != NUM_EVENT_TAGS) { + if (sizeof(EventDesc) / sizeof(char*) != NUM_GHC_EVENT_TAGS) { barf("EventDesc array has the wrong number of elements"); } @@ -244,7 +250,7 @@ initEventLogging(void) // Mark beginning of event types in the header. postInt32(&eventBuf, EVENT_HET_BEGIN); - for (t = 0; t < NUM_EVENT_TAGS; ++t) { + for (t = 0; t < NUM_GHC_EVENT_TAGS; ++t) { eventTypes[t].etNum = t; eventTypes[t].desc = EventDesc[t]; @@ -253,13 +259,11 @@ initEventLogging(void) case EVENT_CREATE_THREAD: // (cap, thread) case EVENT_RUN_THREAD: // (cap, thread) case EVENT_THREAD_RUNNABLE: // (cap, thread) - case EVENT_RUN_SPARK: // (cap, thread) case EVENT_CREATE_SPARK_THREAD: // (cap, spark_thread) eventTypes[t].size = sizeof(EventThreadID); break; case EVENT_MIGRATE_THREAD: // (cap, thread, new_cap) - case EVENT_STEAL_SPARK: // (cap, thread, victim_cap) case EVENT_THREAD_WAKEUP: // (cap, thread, other_cap) eventTypes[t].size = sizeof(EventThreadID) + sizeof(EventCapNo); @@ -295,6 +299,11 @@ initEventLogging(void) sizeof(EventCapsetID) + sizeof(StgWord32); break; + case EVENT_SPARK_STEAL: // (cap, victim_cap) + eventTypes[t].size = + sizeof(EventCapNo); + break; + case EVENT_SHUTDOWN: // (cap) case EVENT_REQUEST_SEQ_GC: // (cap) case EVENT_REQUEST_PAR_GC: // (cap) @@ -303,6 +312,12 @@ initEventLogging(void) case EVENT_GC_IDLE: case EVENT_GC_WORK: case EVENT_GC_DONE: + case EVENT_SPARK_CREATE: // (cap) + case EVENT_SPARK_DUD: // (cap) + case EVENT_SPARK_OVERFLOW: // (cap) + case EVENT_SPARK_RUN: // (cap) + case EVENT_SPARK_FIZZLE: // (cap) + case EVENT_SPARK_GC: // (cap) eventTypes[t].size = 0; break; @@ -314,6 +329,10 @@ initEventLogging(void) eventTypes[t].size = 0xffff; break; + case EVENT_SPARK_COUNTERS: // (cap, 7*counter) + eventTypes[t].size = 7 * sizeof(StgWord64); + break; + case EVENT_BLOCK_MARKER: eventTypes[t].size = sizeof(StgWord32) + sizeof(EventTimestamp) + sizeof(EventCapNo); @@ -435,7 +454,6 @@ postSchedEvent (Capability *cap, case EVENT_CREATE_THREAD: // (cap, thread) case EVENT_RUN_THREAD: // (cap, thread) case EVENT_THREAD_RUNNABLE: // (cap, thread) - case EVENT_RUN_SPARK: // (cap, thread) { postThreadID(eb,thread); break; @@ -448,7 +466,6 @@ postSchedEvent (Capability *cap, } case EVENT_MIGRATE_THREAD: // (cap, thread, new_cap) - case EVENT_STEAL_SPARK: // (cap, thread, victim_cap) case EVENT_THREAD_WAKEUP: // (cap, thread, other_cap) { postThreadID(eb,thread); @@ -465,19 +482,83 @@ postSchedEvent (Capability *cap, } case EVENT_SHUTDOWN: // (cap) - case EVENT_REQUEST_SEQ_GC: // (cap) - case EVENT_REQUEST_PAR_GC: // (cap) - case EVENT_GC_START: // (cap) - case EVENT_GC_END: // (cap) { break; } default: - barf("postEvent: unknown event tag %d", tag); + barf("postSchedEvent: unknown event tag %d", tag); + } +} + +void +postSparkEvent (Capability *cap, + EventTypeNum tag, + StgWord info1) +{ + EventsBuf *eb; + + eb = &capEventBuf[cap->no]; + + if (!hasRoomForEvent(eb, tag)) { + // Flush event buffer to make room for new event. + printAndClearEventBuf(eb); + } + + postEventHeader(eb, tag); + + switch (tag) { + case EVENT_CREATE_SPARK_THREAD: // (cap, spark_thread) + { + postThreadID(eb,info1 /* spark_thread */); + break; + } + + case EVENT_SPARK_STEAL: // (cap, victim_cap) + { + postCapNo(eb,info1 /* victim_cap */); + break; + } + + case EVENT_SPARK_CREATE: // (cap) + case EVENT_SPARK_DUD: // (cap) + case EVENT_SPARK_OVERFLOW: // (cap) + case EVENT_SPARK_RUN: // (cap) + case EVENT_SPARK_FIZZLE: // (cap) + case EVENT_SPARK_GC: // (cap) + { + break; + } + + default: + barf("postSparkEvent: unknown event tag %d", tag); } } +void +postSparkCountersEvent (Capability *cap, + SparkCounters counters, + StgWord remaining) +{ + EventsBuf *eb; + + eb = &capEventBuf[cap->no]; + + if (!hasRoomForEvent(eb, EVENT_SPARK_COUNTERS)) { + // Flush event buffer to make room for new event. + printAndClearEventBuf(eb); + } + + postEventHeader(eb, EVENT_SPARK_COUNTERS); + postWord64(eb,counters.created); + postWord64(eb,counters.dud); + postWord64(eb,counters.overflowed); + postWord64(eb,counters.converted); + postWord64(eb,counters.gcd); + postWord64(eb,counters.fizzled); + postWord64(eb,remaining); +} + void postCapsetModifyEvent (EventTypeNum tag, EventCapsetID capset, StgWord32 other) diff --git a/rts/eventlog/EventLog.h b/rts/eventlog/EventLog.h index 602ac2c87b..6bb1404e92 100644 --- a/rts/eventlog/EventLog.h +++ b/rts/eventlog/EventLog.h @@ -69,6 +69,18 @@ void postCapsetVecEvent (EventTypeNum tag, int argc, char *msg[]); +/* + * Post a `par` spark event + */ +void postSparkEvent(Capability *cap, EventTypeNum tag, StgWord info1); + +/* + * Post an event with several counters relating to `par` sparks. + */ +void postSparkCountersEvent (Capability *cap, + SparkCounters counters, + StgWord remaining); + #else /* !TRACING */ INLINE_HEADER void postSchedEvent (Capability *cap STG_UNUSED, diff --git a/rules/extra-packages.mk b/rules/extra-packages.mk index e3af94f8db..98868b45db 100644 --- a/rules/extra-packages.mk +++ b/rules/extra-packages.mk @@ -27,9 +27,13 @@ # add P to the list of packages define extra-packages + +# Collects some dirs containing ghc.mk files that we need to include: +BUILD_DIRS_EXTRA= + $$(foreach p,$$(patsubst libraries/%,%,$$(wildcard $$(shell grep '^[^ #][^ ]* \+\(dph\|extra\) \+[^ ]\+ \+[^ ]\+$$$$' packages | sed 's/ .*//'))),\ $$(if $$(wildcard libraries/$$p/ghc-packages),\ - $$(eval BUILD_DIRS += libraries/$$p) \ + $$(eval BUILD_DIRS_EXTRA += libraries/$$p) \ $$(foreach q,$$(shell cat libraries/$$p/ghc-packages2),$$(eval $$(call extra-package,$$p,$$p/$$q))),\ $$(eval $$(call extra-package,$$p,$$p)))\ ) @@ -5,8 +5,8 @@ use Cwd; # Usage: # -# ./sync-all [-q] [-s] [--ignore-failure] [-r repo] -# [--nofib] [--testsuite] [--checked-out] cmd [git flags] +# ./sync-all [-q] [-s] [--ignore-failure] [-r repo] [--checked-out] [--bare] +# [--nofib] [--extra] [--testsuite] [--resume] cmd [git flags] # # Applies the command "cmd" to each repository in the tree. # sync-all will try to do the right thing for both git and darcs repositories. @@ -21,6 +21,11 @@ use Cwd; # -------------- Flags ------------------- # -q says to be quite, and -s to be silent. # +# --resume will restart a command that failed, from the repo at which +# it failed. This means you don't need to wait while, e.g., "pull" +# goes through all the repos it's just pulled, and tries to pull them +# again. +# # --ignore-failure says to ignore errors and move on to the next repository # # -r repo says to use repo as the location of package repositories @@ -31,6 +36,12 @@ use Cwd; # via HTTP or SSH are assumed to be in the main repo layout; use # --checked-out to override the latter. # +# --bare says that the local repo is in bare layout, same as the main repo. +# It also means that these repos are bare. You only have to use this flag if +# you don't have a bare ghc.git in the current directory and would like to 'get' +# all of the repos bare. Requires packages.conf to be present in the current +# directory (a renamed packages file from the main ghc repo). +# # --nofib, --testsuite also get the nofib and testsuite repos respectively # # ------------ Which repos to use ------------- @@ -64,15 +75,16 @@ $| = 1; # autoflush stdout after each print, to avoid output after die my $defaultrepo; my @packages; my $verbose = 2; +my $try_to_resume = 0; my $ignore_failure = 0; -my $checked_out_flag = 0; +my $checked_out_flag = 0; # NOT the opposite of bare_flag (describes remote repo state) my $get_mode; +my $bare_flag = ""; # NOT the opposite of checked_out_flag (describes local repo state) my %tags; # Figure out where to get the other repositories from. sub getrepo { - my $basedir = "."; my $repo; if (defined($defaultrepo)) { @@ -81,9 +93,14 @@ sub getrepo { } else { # Figure out where to get the other repositories from, # based on where this GHC repo came from. - my $branch = `git branch | grep "\* " | sed "s/^\* //"`; chomp $branch; - my $remote = `git config branch.$branch.remote`; chomp $remote; - $repo = `git config remote.$remote.url`; chomp $repo; + my $git_dir = $bare_flag ? "--git-dir=ghc.git" : ""; + my $branch = `git $git_dir branch | grep "\* " | sed "s/^\* //"`; chomp $branch; + my $remote = `git $git_dir config branch.$branch.remote`; chomp $remote; + if ($remote eq "") { + # remotes are not mandatory for branches (e.g. not recorded by default for bare repos) + $remote = "origin"; + } + $repo = `git $git_dir config remote.$remote.url`; chomp $repo; } my $repo_base; @@ -117,7 +134,7 @@ sub getrepo { } } elsif ($repo =~ /^\/|\.\.\/|.:(\/|\\)/) { - # Local filesystem, either absolute or relative path + # Local filesystem, either absolute (C:/ or /) or relative (../) path $repo_base = $repo; if (-f "$repo/HEAD") { # assume a local mirror: @@ -142,7 +159,9 @@ sub parsePackages { my @repos; my $lineNum; - open IN, "< packages" or die "Can't open packages file"; + open IN, "< packages.conf" + or open IN, "< packages" # clashes with packages directory when using --bare + or die "Can't open packages file (or packages.conf)"; @repos = <IN>; close IN; @@ -216,6 +235,10 @@ sub scmall { my $pwd; my @args; + my $started; + my $doing; + my $start_repo; + my ($repo_base, $checked_out_tree) = getrepo(); my $is_github_repo = $repo_base =~ m/(git@|git:\/\/|https:\/\/)github.com/; @@ -253,29 +276,59 @@ sub scmall { push(@args, @_); - for $line (@packages) { + # $doing is a good enough approximation to what we are doing that + # we can use it to check that --resume is resuming the right command + $doing = join(" ", ($command, @args)); + $started = 1; + if ($try_to_resume && -f "resume") { + my $what; + open RESUME, "< resume" + or die "Can't open resume file"; + $start_repo = <RESUME>; + chomp $start_repo; + $what = <RESUME>; + chomp $what; + close RESUME; + if ($what eq $doing) { + $started = 0; + } + } - $localpath = $$line{"localpath"}; + for $line (@packages) { $tag = $$line{"tag"}; - $remotepath = $$line{"remotepath"}; $scm = $$line{"vcs"}; + # Use the "remote" structure for bare git repositories + $localpath = ($bare_flag && $scm eq "git") ? + $$line{"remotepath"} : $$line{"localpath"}; + $remotepath = ($checked_out_tree) ? + $$line{"localpath"} : $$line{"remotepath"}; + + if (!$started) { + if ($start_repo eq $localpath) { + $started = 1; + } + else { + next; + } + } + + open RESUME, "> resume.tmp"; + print RESUME "$localpath\n"; + print RESUME "$doing\n"; + close RESUME; + rename "resume.tmp", "resume"; # Check the SCM is OK as early as possible die "Unknown SCM: $scm" if (($scm ne "darcs") and ($scm ne "git")); # We can't create directories on GitHub, so we translate - # "package/foo" into "package-foo". + # "packages/foo" into "package-foo". if ($is_github_repo) { $remotepath =~ s/\//-/; } - # Work out the path for this package in the repo we pulled from - if ($checked_out_tree) { - $path = "$repo_base/$localpath"; - } - else { - $path = "$repo_base/$remotepath"; - } + # Construct the path for this package in the repo we pulled from + $path = "$repo_base/$remotepath"; if ($command =~ /^(?:g|ge|get)$/) { # Skip any repositories we have not included the tag for @@ -306,18 +359,22 @@ sub scmall { scm (".", $scm, "get", $get_mode, $path, $localpath, @args); } else { - scm (".", $scm, "clone", $path, $localpath, @args); + my @argsWithBare = @args; + push @argsWithBare, $bare_flag if $bare_flag; + scm (".", $scm, "clone", $path, $localpath, @argsWithBare); scm ($localpath, $scm, "config", "core.ignorecase", "true"); } next; } - if (-d "$localpath/_darcs") { - if (-d "$localpath/.git") { + my $darcs_repo_present = 1 if -d "$localpath/_darcs"; + my $git_repo_present = 1 if -d "$localpath/.git" || ($bare_flag && -d "$localpath"); + if ($darcs_repo_present) { + if ($git_repo_present) { die "Found both _darcs and .git in $localpath"; } $scm = "darcs"; - } elsif (-d "$localpath/.git") { + } elsif ($git_repo_present) { $scm = "git"; } elsif ($tag eq "") { die "Required repo $localpath is missing"; @@ -415,8 +472,9 @@ sub scmall { die "Unknown command: $command"; } } -} + unlink "resume"; +} sub help() { @@ -424,7 +482,7 @@ sub help() my $help = <<END; Usage: - ./sync-all [-q] [-s] [--ignore-failure] [-r repo] [--checked-out] + ./sync-all [-q] [-s] [--ignore-failure] [-r repo] [--checked-out] [--bare] [--package-tag1] ... [--package-tagN] command Supported commands: @@ -450,12 +508,18 @@ Supported commands: * config * log +Note: --cheched-out and --bare flags are NOT the opposite of each other. + --checked-out: describes the layout of the remote repository tree. + --bare: describes the layout of the local repository tree. + Available package-tags are: END # Collect all the tags in the packages file my %available_tags; - open IN, "< packages" or die "Can't open packages file"; + open IN, "< packages.conf" + or open IN, "< packages" # clashes with packages directory when using --bare + or die "Can't open packages file (or packages.conf)"; while (<IN>) { chomp; if (/^([^# ]+) +(?:([^ ]+) +)?([^ ]+) +([^ ]+)/) { @@ -476,9 +540,6 @@ END } sub main { - if (! -d ".git" || ! -d "compiler") { - die "error: sync-all must be run from the top level of the ghc tree." - } $tags{"-"} = 1; $tags{"dph"} = 1; @@ -496,17 +557,25 @@ sub main { elsif ($arg eq "-r") { $defaultrepo = shift; } + elsif ($arg eq "--resume") { + $try_to_resume = 1; + } elsif ($arg eq "--ignore-failure") { $ignore_failure = 1; } elsif ($arg eq "--complete" || $arg eq "--partial") { $get_mode = $arg; } - # Use --checked-out if the remote repos are a checked-out tree, + # Use --checked-out if the _remote_ repos are a checked-out tree, # rather than the master trees. elsif ($arg eq "--checked-out") { $checked_out_flag = 1; } + # Use --bare if the _local_ repos are bare repos, + # rather than a checked-out tree. + elsif ($arg eq "--bare") { + $bare_flag = $arg; + } # --<tag> says we grab the libs tagged 'tag' with # 'get'. It has no effect on the other commands. elsif ($arg =~ m/^--no-(.*)$/) { @@ -524,6 +593,22 @@ sub main { } } + # check for ghc repositories in cwd + my $checked_out_found = 1 if (-d ".git" && -d "compiler"); + my $bare_found = 1 if (-d "ghc.git"); + + if ($bare_flag && ! $bare_found && ! $defaultrepo) { + die "error: bare repository ghc.git not found.\n" + . " Either clone a bare ghc repo first or specify the repo location. E.g.:\n" + . " ./sync-all --bare [--testsuite --nofib --extra] -r http://darcs.haskell.org/ get\n" + } + elsif ($bare_found) { + $bare_flag = "--bare"; + } + elsif (! $bare_flag && ! $checked_out_found) { + die "error: sync-all must be run from the top level of the ghc tree."; + } + if ($#_ eq -1) { help(); } diff --git a/utils/ghc-cabal/ghc-cabal.cabal b/utils/ghc-cabal/ghc-cabal.cabal index cd8d550c2e..55a4a188ad 100644 --- a/utils/ghc-cabal/ghc-cabal.cabal +++ b/utils/ghc-cabal/ghc-cabal.cabal @@ -16,7 +16,7 @@ Executable ghc-cabal Main-Is: ghc-cabal.hs Build-Depends: base >= 3 && < 5, - Cabal >= 1.10 && < 1.12, + Cabal >= 1.10 && < 1.14, directory >= 1.1 && < 1.2, filepath >= 1.2 && < 1.3 diff --git a/utils/ghc-pkg/ghc-pkg.cabal b/utils/ghc-pkg/ghc-pkg.cabal index a0f3c36e1d..4f96dcc4ba 100644 --- a/utils/ghc-pkg/ghc-pkg.cabal +++ b/utils/ghc-pkg/ghc-pkg.cabal @@ -20,7 +20,7 @@ Executable ghc-pkg Build-Depends: base >= 4 && < 5, directory >= 1 && < 1.2, - process >= 1 && < 1.1, + process >= 1 && < 1.2, filepath, Cabal, binary, diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index 4ba8157dcc..fafd63eabb 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -11,7 +11,7 @@ import HscTypes ( msHsFilePath ) import Name ( getOccString ) --import ErrUtils ( printBagOfErrors ) import Panic ( panic ) -import DynFlags ( defaultDynFlags ) +import DynFlags ( defaultLogAction ) import Bag import Exception import FastString @@ -102,7 +102,7 @@ main = do then Just `liftM` openFile "TAGS" openFileMode else return Nothing - GHC.defaultErrorHandler (defaultDynFlags (panic "No settings")) $ + GHC.defaultErrorHandler defaultLogAction $ runGhc (Just ghc_topdir) $ do --liftIO $ print "starting up session" dflags <- getSessionDynFlags diff --git a/utils/runghc/runghc.cabal.in b/utils/runghc/runghc.cabal.in index 7dfdc97a5d..3bab879c91 100644 --- a/utils/runghc/runghc.cabal.in +++ b/utils/runghc/runghc.cabal.in @@ -21,7 +21,7 @@ Executable runghc if flag(base3) Build-Depends: base >= 3 && < 5, directory >= 1 && < 1.2, - process >= 1 && < 1.1 + process >= 1 && < 1.2 else Build-Depends: base < 3 Build-Depends: filepath @@ -45,6 +45,13 @@ do shift done +if ! [ -d testsuite ] +then + echo 'You need the testsuite to validate' >&2 + echo 'Run "./sync-all --testsuite get" to get it' >&2 + exit 1 +fi + if [ "$THREADS" = "" ]; then if [ "$CPUS" = "" ]; then threads=2 |