diff options
45 files changed, 1047 insertions, 979 deletions
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 76d5e79a21..de27f18a71 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -263,23 +263,23 @@ data ForeignLabelSource -- We can't make a Show instance for CLabel because lots of its components don't have instances. -- The regular Outputable instance only shows the label name, and not its other info. -- -pprDebugCLabel :: CLabel -> SDoc -pprDebugCLabel lbl +pprDebugCLabel :: Platform -> CLabel -> SDoc +pprDebugCLabel platform lbl = case lbl of - IdLabel{} -> ppr lbl <> (parens $ text "IdLabel") + IdLabel{} -> pprPlatform platform lbl <> (parens $ text "IdLabel") CmmLabel pkg name _info - -> ppr lbl <> (parens $ text "CmmLabel" <+> ppr pkg) + -> pprPlatform platform lbl <> (parens $ text "CmmLabel" <+> ppr pkg) - RtsLabel{} -> ppr lbl <> (parens $ text "RtsLabel") + RtsLabel{} -> pprPlatform platform lbl <> (parens $ text "RtsLabel") ForeignLabel name mSuffix src funOrData - -> ppr lbl <> (parens + -> pprPlatform platform lbl <> (parens $ text "ForeignLabel" <+> ppr mSuffix <+> ppr src <+> ppr funOrData) - _ -> ppr lbl <> (parens $ text "other CLabel)") + _ -> pprPlatform platform lbl <> (parens $ text "other CLabel)") -- True if a local IdLabel that we won't mark as exported @@ -509,38 +509,38 @@ mkPlainModuleInitLabel mod = PlainModuleInitLabel mod -- ----------------------------------------------------------------------------- -- Convert between different kinds of label -toClosureLbl :: CLabel -> CLabel -toClosureLbl (IdLabel n c _) = IdLabel n c Closure -toClosureLbl l = pprPanic "toClosureLbl" (pprCLabel l) - -toSlowEntryLbl :: CLabel -> CLabel -toSlowEntryLbl (IdLabel n c _) = IdLabel n c Slow -toSlowEntryLbl l = pprPanic "toSlowEntryLbl" (pprCLabel l) - -toRednCountsLbl :: CLabel -> CLabel -toRednCountsLbl (IdLabel n c _) = IdLabel n c RednCounts -toRednCountsLbl l = pprPanic "toRednCountsLbl" (pprCLabel l) - -toEntryLbl :: CLabel -> CLabel -toEntryLbl (IdLabel n c LocalInfoTable) = IdLabel n c LocalEntry -toEntryLbl (IdLabel n c ConInfoTable) = IdLabel n c ConEntry -toEntryLbl (IdLabel n c StaticInfoTable) = IdLabel n c StaticConEntry -toEntryLbl (IdLabel n c _) = IdLabel n c Entry -toEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt -toEntryLbl (CmmLabel m str CmmInfo) = CmmLabel m str CmmEntry -toEntryLbl (CmmLabel m str CmmRetInfo) = CmmLabel m str CmmRet -toEntryLbl l = pprPanic "toEntryLbl" (pprCLabel l) - -toInfoLbl :: CLabel -> CLabel -toInfoLbl (IdLabel n c Entry) = IdLabel n c InfoTable -toInfoLbl (IdLabel n c LocalEntry) = IdLabel n c LocalInfoTable -toInfoLbl (IdLabel n c ConEntry) = IdLabel n c ConInfoTable -toInfoLbl (IdLabel n c StaticConEntry) = IdLabel n c StaticInfoTable -toInfoLbl (IdLabel n c _) = IdLabel n c InfoTable -toInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo -toInfoLbl (CmmLabel m str CmmEntry) = CmmLabel m str CmmInfo -toInfoLbl (CmmLabel m str CmmRet) = CmmLabel m str CmmRetInfo -toInfoLbl l = pprPanic "CLabel.toInfoLbl" (pprCLabel l) +toClosureLbl :: Platform -> CLabel -> CLabel +toClosureLbl _ (IdLabel n c _) = IdLabel n c Closure +toClosureLbl platform l = pprPanic "toClosureLbl" (pprCLabel platform l) + +toSlowEntryLbl :: Platform -> CLabel -> CLabel +toSlowEntryLbl _ (IdLabel n c _) = IdLabel n c Slow +toSlowEntryLbl platform l = pprPanic "toSlowEntryLbl" (pprCLabel platform l) + +toRednCountsLbl :: Platform -> CLabel -> CLabel +toRednCountsLbl _ (IdLabel n c _) = IdLabel n c RednCounts +toRednCountsLbl platform l = pprPanic "toRednCountsLbl" (pprCLabel platform l) + +toEntryLbl :: Platform -> CLabel -> CLabel +toEntryLbl _ (IdLabel n c LocalInfoTable) = IdLabel n c LocalEntry +toEntryLbl _ (IdLabel n c ConInfoTable) = IdLabel n c ConEntry +toEntryLbl _ (IdLabel n c StaticInfoTable) = IdLabel n c StaticConEntry +toEntryLbl _ (IdLabel n c _) = IdLabel n c Entry +toEntryLbl _ (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt +toEntryLbl _ (CmmLabel m str CmmInfo) = CmmLabel m str CmmEntry +toEntryLbl _ (CmmLabel m str CmmRetInfo) = CmmLabel m str CmmRet +toEntryLbl platform l = pprPanic "toEntryLbl" (pprCLabel platform l) + +toInfoLbl :: Platform -> CLabel -> CLabel +toInfoLbl _ (IdLabel n c Entry) = IdLabel n c InfoTable +toInfoLbl _ (IdLabel n c LocalEntry) = IdLabel n c LocalInfoTable +toInfoLbl _ (IdLabel n c ConEntry) = IdLabel n c ConInfoTable +toInfoLbl _ (IdLabel n c StaticConEntry) = IdLabel n c StaticInfoTable +toInfoLbl _ (IdLabel n c _) = IdLabel n c InfoTable +toInfoLbl _ (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo +toInfoLbl _ (CmmLabel m str CmmEntry) = CmmLabel m str CmmInfo +toInfoLbl _ (CmmLabel m str CmmRet) = CmmLabel m str CmmRetInfo +toInfoLbl platform l = pprPanic "CLabel.toInfoLbl" (pprCLabel platform l) -- ----------------------------------------------------------------------------- -- Does a CLabel refer to a CAF? @@ -891,14 +891,12 @@ Not exporting these Just_info labels reduces the number of symbols somewhat. -} -instance Outputable CLabel where - ppr = pprCLabel instance PlatformOutputable CLabel where - pprPlatform _ = pprCLabel + pprPlatform = pprCLabel -pprCLabel :: CLabel -> SDoc +pprCLabel :: Platform -> CLabel -> SDoc -pprCLabel (AsmTempLabel u) +pprCLabel _ (AsmTempLabel u) | cGhcWithNativeCodeGen == "YES" = getPprStyle $ \ sty -> if asmStyle sty then @@ -906,19 +904,19 @@ pprCLabel (AsmTempLabel u) else char '_' <> pprUnique u -pprCLabel (DynamicLinkerLabel info lbl) +pprCLabel platform (DynamicLinkerLabel info lbl) | cGhcWithNativeCodeGen == "YES" - = pprDynamicLinkerAsmLabel info lbl + = pprDynamicLinkerAsmLabel platform info lbl -pprCLabel PicBaseLabel +pprCLabel _ PicBaseLabel | cGhcWithNativeCodeGen == "YES" = ptext (sLit "1b") -pprCLabel (DeadStripPreventer lbl) +pprCLabel platform (DeadStripPreventer lbl) | cGhcWithNativeCodeGen == "YES" - = pprCLabel lbl <> ptext (sLit "_dsp") + = pprCLabel platform lbl <> ptext (sLit "_dsp") -pprCLabel lbl +pprCLabel _ lbl = getPprStyle $ \ sty -> if cGhcWithNativeCodeGen == "YES" && asmStyle sty then maybe_underscore (pprAsmCLbl lbl) @@ -1072,63 +1070,40 @@ asmTempLabelPrefix = (sLit ".L") #endif -pprDynamicLinkerAsmLabel :: DynamicLinkerLabelInfo -> CLabel -> SDoc +pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> CLabel -> SDoc +pprDynamicLinkerAsmLabel platform dllInfo lbl + = if platform == Platform ArchX86_64 OSDarwin + then case dllInfo of + CodeStub -> char 'L' <> pprCLabel platform lbl <> text "$stub" + SymbolPtr -> char 'L' <> pprCLabel platform lbl <> text "$non_lazy_ptr" + GotSymbolPtr -> pprCLabel platform lbl <> text "@GOTPCREL" + GotSymbolOffset -> pprCLabel platform lbl + _ -> panic "pprDynamicLinkerAsmLabel" + else if platformOS platform == OSDarwin + then case dllInfo of + CodeStub -> char 'L' <> pprCLabel platform lbl <> text "$stub" + SymbolPtr -> char 'L' <> pprCLabel platform lbl <> text "$non_lazy_ptr" + _ -> panic "pprDynamicLinkerAsmLabel" + else if platformArch platform == ArchPPC && osElfTarget (platformOS platform) + then case dllInfo of + CodeStub -> pprCLabel platform lbl <> text "@plt" + SymbolPtr -> text ".LC_" <> pprCLabel platform lbl + _ -> panic "pprDynamicLinkerAsmLabel" + else if platformArch platform == ArchX86_64 && osElfTarget (platformOS platform) + then case dllInfo of + CodeStub -> pprCLabel platform lbl <> text "@plt" + GotSymbolPtr -> pprCLabel platform lbl <> text "@gotpcrel" + GotSymbolOffset -> pprCLabel platform lbl + SymbolPtr -> text ".LC_" <> pprCLabel platform lbl + else if osElfTarget (platformOS platform) + then case dllInfo of + CodeStub -> pprCLabel platform lbl <> text "@plt" + SymbolPtr -> text ".LC_" <> pprCLabel platform lbl + GotSymbolPtr -> pprCLabel platform lbl <> text "@got" + GotSymbolOffset -> pprCLabel platform lbl <> text "@gotoff" + else if platformOS platform == OSMinGW32 + then case dllInfo of + SymbolPtr -> text "__imp_" <> pprCLabel platform lbl + _ -> panic "pprDynamicLinkerAsmLabel" + else panic "pprDynamicLinkerAsmLabel" -#if x86_64_TARGET_ARCH && darwin_TARGET_OS -pprDynamicLinkerAsmLabel CodeStub lbl - = char 'L' <> pprCLabel lbl <> text "$stub" -pprDynamicLinkerAsmLabel SymbolPtr lbl - = char 'L' <> pprCLabel lbl <> text "$non_lazy_ptr" -pprDynamicLinkerAsmLabel GotSymbolPtr lbl - = pprCLabel lbl <> text "@GOTPCREL" -pprDynamicLinkerAsmLabel GotSymbolOffset lbl - = pprCLabel lbl -pprDynamicLinkerAsmLabel _ _ - = panic "pprDynamicLinkerAsmLabel" - -#elif darwin_TARGET_OS -pprDynamicLinkerAsmLabel CodeStub lbl - = char 'L' <> pprCLabel lbl <> text "$stub" -pprDynamicLinkerAsmLabel SymbolPtr lbl - = char 'L' <> pprCLabel lbl <> text "$non_lazy_ptr" -pprDynamicLinkerAsmLabel _ _ - = panic "pprDynamicLinkerAsmLabel" - -#elif powerpc_TARGET_ARCH && elf_OBJ_FORMAT -pprDynamicLinkerAsmLabel CodeStub lbl - = pprCLabel lbl <> text "@plt" -pprDynamicLinkerAsmLabel SymbolPtr lbl - = text ".LC_" <> pprCLabel lbl -pprDynamicLinkerAsmLabel _ _ - = panic "pprDynamicLinkerAsmLabel" - -#elif x86_64_TARGET_ARCH && elf_OBJ_FORMAT -pprDynamicLinkerAsmLabel CodeStub lbl - = pprCLabel lbl <> text "@plt" -pprDynamicLinkerAsmLabel GotSymbolPtr lbl - = pprCLabel lbl <> text "@gotpcrel" -pprDynamicLinkerAsmLabel GotSymbolOffset lbl - = pprCLabel lbl -pprDynamicLinkerAsmLabel SymbolPtr lbl - = text ".LC_" <> pprCLabel lbl - -#elif elf_OBJ_FORMAT -pprDynamicLinkerAsmLabel CodeStub lbl - = pprCLabel lbl <> text "@plt" -pprDynamicLinkerAsmLabel SymbolPtr lbl - = text ".LC_" <> pprCLabel lbl -pprDynamicLinkerAsmLabel GotSymbolPtr lbl - = pprCLabel lbl <> text "@got" -pprDynamicLinkerAsmLabel GotSymbolOffset lbl - = pprCLabel lbl <> text "@gotoff" - -#elif mingw32_TARGET_OS -pprDynamicLinkerAsmLabel SymbolPtr lbl - = text "__imp_" <> pprCLabel lbl -pprDynamicLinkerAsmLabel _ _ - = panic "pprDynamicLinkerAsmLabel" - -#else -pprDynamicLinkerAsmLabel _ _ - = panic "pprDynamicLinkerAsmLabel" -#endif diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index 699f1003b6..0301deb593 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -44,6 +44,7 @@ import Control.Monad import Name import OptimizationFuel import Outputable +import Platform import SMRep import UniqSupply @@ -193,8 +194,8 @@ cafLattice = DataflowLattice "live cafs" Map.empty add where add _ (OldFact old) (NewFact new) = case old `Map.union` new of new' -> (changeIf $ Map.size new' > Map.size old, new') -cafTransfers :: BwdTransfer CmmNode CAFSet -cafTransfers = mkBTransfer3 first middle last +cafTransfers :: Platform -> BwdTransfer CmmNode CAFSet +cafTransfers platform = mkBTransfer3 first middle last where first _ live = live middle m live = foldExpDeep addCaf m live last l live = foldExpDeep addCaf l (joinOutFacts cafLattice l live) @@ -203,10 +204,12 @@ cafTransfers = mkBTransfer3 first middle last CmmLit (CmmLabelOff c _) -> add c set CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $ add c2 set _ -> set - add l s = if hasCAF l then Map.insert (toClosureLbl l) () s else s + add l s = if hasCAF l then Map.insert (toClosureLbl platform l) () s + else s -cafAnal :: CmmGraph -> FuelUniqSM CAFEnv -cafAnal g = liftM snd $ dataflowPassBwd g [] $ analBwd cafLattice cafTransfers +cafAnal :: Platform -> CmmGraph -> FuelUniqSM CAFEnv +cafAnal platform g + = liftM snd $ dataflowPassBwd g [] $ analBwd cafLattice (cafTransfers platform) ----------------------------------------------------------------------- -- Building the SRTs @@ -218,9 +221,12 @@ data TopSRT = TopSRT { lbl :: CLabel , rev_elts :: [CLabel] , elt_map :: Map CLabel Int } -- map: CLabel -> its last entry in the table -instance Outputable TopSRT where - ppr (TopSRT lbl next elts eltmap) = - text "TopSRT:" <+> ppr lbl <+> ppr next <+> ppr elts <+> ppr eltmap +instance PlatformOutputable TopSRT where + pprPlatform platform (TopSRT lbl next elts eltmap) = + text "TopSRT:" <+> pprPlatform platform lbl + <+> ppr next + <+> pprPlatform platform elts + <+> pprPlatform platform eltmap emptySRT :: MonadUnique m => m TopSRT emptySRT = @@ -335,13 +341,13 @@ to_SRT top_srt off len bmp -- keep its CAFs live.) -- Any procedure referring to a non-static CAF c must keep live -- any CAF that is reachable from c. -localCAFInfo :: CAFEnv -> CmmDecl -> Maybe (CLabel, CAFSet) -localCAFInfo _ (CmmData _ _) = Nothing -localCAFInfo cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) = +localCAFInfo :: Platform -> CAFEnv -> CmmDecl -> Maybe (CLabel, CAFSet) +localCAFInfo _ _ (CmmData _ _) = Nothing +localCAFInfo platform cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) = case info_tbl top_info of CmmInfoTable { cit_rep = rep } | not (isStaticRep rep) - -> Just (toClosureLbl top_l, + -> Just (toClosureLbl platform top_l, expectJust "maybeBindCAFs" $ mapLookup entry cafEnv) _ -> Nothing diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index a11b61cb91..15f255472f 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -16,6 +16,7 @@ import Bitmap import Maybes import Constants import Panic +import Platform import StaticFlags import UniqSupply import MonadUtils @@ -30,10 +31,10 @@ mkEmptyContInfoTable info_lbl , cit_prof = NoProfilingInfo , cit_srt = NoC_SRT } -cmmToRawCmm :: [Old.CmmGroup] -> IO [Old.RawCmmGroup] -cmmToRawCmm cmms +cmmToRawCmm :: Platform -> [Old.CmmGroup] -> IO [Old.RawCmmGroup] +cmmToRawCmm platform cmms = do { uniqs <- mkSplitUniqSupply 'i' - ; return (initUs_ uniqs (mapM (concatMapM mkInfoTable) cmms)) } + ; return (initUs_ uniqs (mapM (concatMapM (mkInfoTable platform)) cmms)) } -- Make a concrete info table, represented as a list of CmmStatic -- (it can't be simply a list of Word, because the SRT field is @@ -68,16 +69,16 @@ cmmToRawCmm cmms -- -- * The SRT slot is only there if there is SRT info to record -mkInfoTable :: CmmDecl -> UniqSM [RawCmmDecl] -mkInfoTable (CmmData sec dat) +mkInfoTable :: Platform -> CmmDecl -> UniqSM [RawCmmDecl] +mkInfoTable _ (CmmData sec dat) = return [CmmData sec dat] -mkInfoTable (CmmProc (CmmInfo _ _ info) entry_label blocks) +mkInfoTable platform (CmmProc (CmmInfo _ _ info) entry_label blocks) | CmmNonInfoTable <- info -- Code without an info table. Easy. = return [CmmProc Nothing entry_label blocks] | CmmInfoTable { cit_lbl = info_lbl } <- info - = do { (top_decls, info_cts) <- mkInfoTableContents info Nothing + = do { (top_decls, info_cts) <- mkInfoTableContents platform info Nothing ; return (top_decls ++ mkInfoTableAndCode info_lbl info_cts entry_label blocks) } @@ -88,18 +89,20 @@ type InfoTableContents = ( [CmmLit] -- The standard part , [CmmLit] ) -- The "extra bits" -- These Lits have *not* had mkRelativeTo applied to them -mkInfoTableContents :: CmmInfoTable +mkInfoTableContents :: Platform + -> CmmInfoTable -> Maybe StgHalfWord -- Override default RTS type tag? -> UniqSM ([RawCmmDecl], -- Auxiliary top decls InfoTableContents) -- Info tbl + extra bits -mkInfoTableContents info@(CmmInfoTable { cit_lbl = info_lbl +mkInfoTableContents platform + info@(CmmInfoTable { cit_lbl = info_lbl , cit_rep = smrep , cit_prof = prof , cit_srt = srt }) mb_rts_tag | RTSRep rts_tag rep <- smrep - = mkInfoTableContents info{cit_rep = rep} (Just rts_tag) + = mkInfoTableContents platform info{cit_rep = rep} (Just rts_tag) -- Completely override the rts_tag that mkInfoTableContents would -- otherwise compute, with the rts_tag stored in the RTSRep -- (which in turn came from a handwritten .cmm file) @@ -156,7 +159,7 @@ mkInfoTableContents info@(CmmInfoTable { cit_lbl = info_lbl , srt_lit, liveness_lit, slow_entry ] ; return (Nothing, Nothing, extra_bits, liveness_data) } where - slow_entry = CmmLabel (toSlowEntryLbl info_lbl) + slow_entry = CmmLabel (toSlowEntryLbl platform info_lbl) srt_lit = case srt_label of [] -> mkIntCLit 0 (lit:_rest) -> ASSERT( null _rest ) lit @@ -164,7 +167,7 @@ mkInfoTableContents info@(CmmInfoTable { cit_lbl = info_lbl mk_pieces BlackHole _ = panic "mk_pieces: BlackHole" -mkInfoTableContents _ _ = panic "mkInfoTableContents" -- NonInfoTable dealt with earlier +mkInfoTableContents _ _ _ = panic "mkInfoTableContents" -- NonInfoTable dealt with earlier mkSRTLit :: C_SRT -> ([CmmLit], -- srt_label, if any diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 8229d33f00..ff41d58a32 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -30,13 +30,13 @@ import Data.Maybe -- ----------------------------------------------------------------------------- -- Exported entry points: -cmmLint :: (Outputable d, Outputable h) +cmmLint :: (PlatformOutputable d, PlatformOutputable h) => Platform -> GenCmmGroup d h (ListGraph CmmStmt) -> Maybe SDoc -cmmLint platform tops = runCmmLint platform (mapM_ lintCmmDecl) tops +cmmLint platform tops = runCmmLint platform (mapM_ (lintCmmDecl platform)) tops -cmmLintTop :: (Outputable d, Outputable h) +cmmLintTop :: (PlatformOutputable d, PlatformOutputable h) => Platform -> GenCmmDecl d h (ListGraph CmmStmt) -> Maybe SDoc -cmmLintTop platform top = runCmmLint platform lintCmmDecl top +cmmLintTop platform top = runCmmLint platform (lintCmmDecl platform) top runCmmLint :: PlatformOutputable a => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc @@ -48,19 +48,19 @@ runCmmLint platform l p = nest 2 (pprPlatform platform p)]) Right _ -> Nothing -lintCmmDecl :: (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint () -lintCmmDecl (CmmProc _ lbl (ListGraph blocks)) - = addLintInfo (text "in proc " <> pprCLabel lbl) $ +lintCmmDecl :: Platform -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint () +lintCmmDecl platform (CmmProc _ lbl (ListGraph blocks)) + = addLintInfo (text "in proc " <> pprCLabel platform lbl) $ let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks - in mapM_ (lintCmmBlock labels) blocks + in mapM_ (lintCmmBlock platform labels) blocks -lintCmmDecl (CmmData {}) +lintCmmDecl _ (CmmData {}) = return () -lintCmmBlock :: BlockSet -> GenBasicBlock CmmStmt -> CmmLint () -lintCmmBlock labels (BasicBlock id stmts) +lintCmmBlock :: Platform -> BlockSet -> GenBasicBlock CmmStmt -> CmmLint () +lintCmmBlock platform labels (BasicBlock id stmts) = addLintInfo (text "in basic block " <> ppr id) $ - mapM_ (lintCmmStmt labels) stmts + mapM_ (lintCmmStmt platform labels) stmts -- ----------------------------------------------------------------------------- -- lintCmmExpr @@ -68,24 +68,24 @@ lintCmmBlock labels (BasicBlock id stmts) -- Checks whether a CmmExpr is "type-correct", and check for obvious-looking -- byte/word mismatches. -lintCmmExpr :: CmmExpr -> CmmLint CmmType -lintCmmExpr (CmmLoad expr rep) = do - _ <- lintCmmExpr expr +lintCmmExpr :: Platform -> CmmExpr -> CmmLint CmmType +lintCmmExpr platform (CmmLoad expr rep) = do + _ <- lintCmmExpr platform expr -- Disabled, if we have the inlining phase before the lint phase, -- we can have funny offsets due to pointer tagging. -- EZY -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $ -- cmmCheckWordAddress expr return rep -lintCmmExpr expr@(CmmMachOp op args) = do - tys <- mapM lintCmmExpr args +lintCmmExpr platform expr@(CmmMachOp op args) = do + tys <- mapM (lintCmmExpr platform) args if map (typeWidth . cmmExprType) args == machOpArgReps op then cmmCheckMachOp op args tys - else cmmLintMachOpErr expr (map cmmExprType args) (machOpArgReps op) -lintCmmExpr (CmmRegOff reg offset) - = lintCmmExpr (CmmMachOp (MO_Add rep) + else cmmLintMachOpErr platform expr (map cmmExprType args) (machOpArgReps op) +lintCmmExpr platform (CmmRegOff reg offset) + = lintCmmExpr platform (CmmMachOp (MO_Add rep) [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)]) where rep = typeWidth (cmmRegType reg) -lintCmmExpr expr = +lintCmmExpr _ expr = return (cmmExprType expr) -- Check for some common byte/word mismatches (eg. Sp + 1) @@ -102,14 +102,14 @@ isOffsetOp _ = False -- This expression should be an address from which a word can be loaded: -- check for funny-looking sub-word offsets. -_cmmCheckWordAddress :: CmmExpr -> CmmLint () -_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) +_cmmCheckWordAddress :: Platform -> CmmExpr -> CmmLint () +_cmmCheckWordAddress platform e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0 - = cmmLintDubiousWordOffset e -_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) + = cmmLintDubiousWordOffset platform e +_cmmCheckWordAddress platform e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0 - = cmmLintDubiousWordOffset e -_cmmCheckWordAddress _ + = cmmLintDubiousWordOffset platform e +_cmmCheckWordAddress _ _ = return () -- No warnings for unaligned arithmetic with the node register, @@ -118,46 +118,47 @@ notNodeReg :: CmmExpr -> Bool notNodeReg (CmmReg reg) | reg == nodeReg = False notNodeReg _ = True -lintCmmStmt :: BlockSet -> CmmStmt -> CmmLint () -lintCmmStmt labels = lint +lintCmmStmt :: Platform -> BlockSet -> CmmStmt -> CmmLint () +lintCmmStmt platform labels = lint where lint (CmmNop) = return () lint (CmmComment {}) = return () lint stmt@(CmmAssign reg expr) = do - erep <- lintCmmExpr expr + erep <- lintCmmExpr platform expr let reg_ty = cmmRegType reg if (erep `cmmEqType_ignoring_ptrhood` reg_ty) then return () - else cmmLintAssignErr stmt erep reg_ty + else cmmLintAssignErr platform stmt erep reg_ty lint (CmmStore l r) = do - _ <- lintCmmExpr l - _ <- lintCmmExpr r + _ <- lintCmmExpr platform l + _ <- lintCmmExpr platform r return () lint (CmmCall target _res args _ _) = - lintTarget target >> mapM_ (lintCmmExpr . hintlessCmm) args - lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr e >> checkCond e + lintTarget platform target >> mapM_ (lintCmmExpr platform . hintlessCmm) args + lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr platform e >> checkCond platform e lint (CmmSwitch e branches) = do mapM_ checkTarget $ catMaybes branches - erep <- lintCmmExpr e + erep <- lintCmmExpr platform e if (erep `cmmEqType_ignoring_ptrhood` bWord) then return () - else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e <> + else cmmLintErr (text "switch scrutinee is not a word: " <> pprPlatform platform e <> text " :: " <> ppr erep) - lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr . hintlessCmm) args - lint (CmmReturn ress) = mapM_ (lintCmmExpr . hintlessCmm) ress + lint (CmmJump e args) = lintCmmExpr platform e >> mapM_ (lintCmmExpr platform . hintlessCmm) args + lint (CmmReturn ress) = mapM_ (lintCmmExpr platform . hintlessCmm) ress lint (CmmBranch id) = checkTarget id checkTarget id = if setMember id labels then return () else cmmLintErr (text "Branch to nonexistent id" <+> ppr id) -lintTarget :: CmmCallTarget -> CmmLint () -lintTarget (CmmCallee e _) = lintCmmExpr e >> return () -lintTarget (CmmPrim {}) = return () +lintTarget :: Platform -> CmmCallTarget -> CmmLint () +lintTarget platform (CmmCallee e _) = lintCmmExpr platform e >> return () +lintTarget _ (CmmPrim {}) = return () -checkCond :: CmmExpr -> CmmLint () -checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return () -checkCond (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values -checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2 - (ppr expr)) +checkCond :: Platform -> CmmExpr -> CmmLint () +checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return () +checkCond _ (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values +checkCond platform expr + = cmmLintErr (hang (text "expression is not a conditional:") 2 + (pprPlatform platform expr)) -- ----------------------------------------------------------------------------- -- CmmLint monad @@ -181,23 +182,23 @@ addLintInfo info thing = CmmLint $ Left err -> Left (hang info 2 err) Right a -> Right a -cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a -cmmLintMachOpErr expr argsRep opExpectsRep +cmmLintMachOpErr :: Platform -> CmmExpr -> [CmmType] -> [Width] -> CmmLint a +cmmLintMachOpErr platform expr argsRep opExpectsRep = cmmLintErr (text "in MachOp application: " $$ - nest 2 (ppr expr) $$ + nest 2 (pprPlatform platform expr) $$ (text "op is expecting: " <+> ppr opExpectsRep) $$ (text "arguments provide: " <+> ppr argsRep)) -cmmLintAssignErr :: CmmStmt -> CmmType -> CmmType -> CmmLint a -cmmLintAssignErr stmt e_ty r_ty +cmmLintAssignErr :: Platform -> CmmStmt -> CmmType -> CmmType -> CmmLint a +cmmLintAssignErr platform stmt e_ty r_ty = cmmLintErr (text "in assignment: " $$ - nest 2 (vcat [ppr stmt, + nest 2 (vcat [pprPlatform platform stmt, text "Reg ty:" <+> ppr r_ty, text "Rhs ty:" <+> ppr e_ty])) -cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a -cmmLintDubiousWordOffset expr +cmmLintDubiousWordOffset :: Platform -> CmmExpr -> CmmLint a +cmmLintDubiousWordOffset platform expr = cmmLintErr (text "offset is not a multiple of words: " $$ - nest 2 (ppr expr)) + nest 2 (pprPlatform platform expr)) diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index 3c7e3ed6a2..8ab1601e2c 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -70,7 +70,8 @@ cmmPipeline hsc_env (topSRT, rst) prog = -- folding over the groups (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops - let cmms = reverse (concat tops) + let cmms :: CmmGroup + cmms = reverse (concat tops) dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (pprPlatform (targetPlatform dflags) cmms) @@ -148,9 +149,9 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) mapM_ (dumpPlatform platform Opt_D_dump_cmmz_split "Post splitting") gs ------------- More CAFs and foreign calls ------------ - cafEnv <- run $ cafAnal g - let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs - mbpprTrace "localCAFs" (ppr localCAFs) $ return () + cafEnv <- run $ cafAnal platform g + let localCAFs = catMaybes $ map (localCAFInfo platform cafEnv) gs + mbpprTrace "localCAFs" (pprPlatform platform localCAFs) $ return () gs <- run $ mapM (lowerSafeForeignCalls areaMap) gs mapM_ (dumpPlatform platform Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs index 36d00bd991..6b71fd66a8 100644 --- a/compiler/cmm/OldCmm.hs +++ b/compiler/cmm/OldCmm.hs @@ -12,7 +12,6 @@ module OldCmm ( CmmInfo(..), UpdateFrame(..), CmmInfoTable(..), ClosureTypeInfo(..), CmmStatic(..), CmmStatics(..), CmmFormal, CmmActual, cmmMapGraph, cmmTopMapGraph, - cmmMapGraphM, cmmTopMapGraphM, GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts, CmmStmt(..), CmmReturnInfo(..), CmmHinted(..), HintedCmmFormal, HintedCmmActual, @@ -35,7 +34,6 @@ import BlockId import CmmExpr import ForeignCall import ClosureInfo -import Outputable import FastString @@ -121,19 +119,10 @@ mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs) cmmMapGraph :: (g -> g') -> GenCmmGroup d h g -> GenCmmGroup d h g' cmmTopMapGraph :: (g -> g') -> GenCmmDecl d h g -> GenCmmDecl d h g' -cmmMapGraphM :: Monad m => (String -> g -> m g') -> GenCmmGroup d h g -> m (GenCmmGroup d h g') -cmmTopMapGraphM :: Monad m => (String -> g -> m g') -> GenCmmDecl d h g -> m (GenCmmDecl d h g') - cmmMapGraph f tops = map (cmmTopMapGraph f) tops cmmTopMapGraph f (CmmProc h l g) = CmmProc h l (f g) cmmTopMapGraph _ (CmmData s ds) = CmmData s ds -cmmMapGraphM f tops = mapM (cmmTopMapGraphM f) tops -cmmTopMapGraphM f (CmmProc h l g) = - f (showSDoc $ ppr l) g >>= return . CmmProc h l -cmmTopMapGraphM _ (CmmData s ds) = return $ CmmData s ds - - data CmmReturnInfo = CmmMayReturn | CmmNeverReturns deriving ( Eq ) diff --git a/compiler/cmm/OldPprCmm.hs b/compiler/cmm/OldPprCmm.hs index b31cc96dbc..d2f03f78b7 100644 --- a/compiler/cmm/OldPprCmm.hs +++ b/compiler/cmm/OldPprCmm.hs @@ -63,20 +63,18 @@ instance PlatformOutputable instr => PlatformOutputable (ListGraph instr) where 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 + pprPlatform = pprStmt -instance Outputable CmmInfo where - ppr e = pprInfo e +instance PlatformOutputable CmmInfo where + pprPlatform = pprInfo -- -------------------------------------------------------------------------- -instance Outputable CmmSafety where - ppr CmmUnsafe = ptext (sLit "_unsafe_call_") - ppr CmmInterruptible = ptext (sLit "_interruptible_call_") - ppr (CmmSafe srt) = ppr srt +instance PlatformOutputable CmmSafety where + pprPlatform _ CmmUnsafe = ptext (sLit "_unsafe_call_") + pprPlatform _ CmmInterruptible = ptext (sLit "_interruptible_call_") + pprPlatform platform (CmmSafe srt) = pprPlatform platform srt -- -------------------------------------------------------------------------- -- Info tables. The current pretty printer needs refinement @@ -85,13 +83,15 @@ instance Outputable CmmSafety where -- For ideas on how to refine it, they used to be printed in the -- style of C--'s 'stackdata' declaration, just inside the proc body, -- and were labelled with the procedure name ++ "_info". -pprInfo :: CmmInfo -> SDoc -pprInfo (CmmInfo _gc_target update_frame info_table) = +pprInfo :: Platform -> CmmInfo -> SDoc +pprInfo platform (CmmInfo _gc_target update_frame info_table) = vcat [{-ptext (sLit "gc_target: ") <> maybe (ptext (sLit "<none>")) ppr gc_target,-} ptext (sLit "update_frame: ") <> - maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame, - ppr info_table] + maybe (ptext (sLit "<none>")) + (pprUpdateFrame platform) + update_frame, + pprPlatform platform info_table] -- -------------------------------------------------------------------------- -- Basic blocks look like assembly blocks. @@ -103,8 +103,8 @@ pprBBlock platform (BasicBlock ident stmts) = -- -------------------------------------------------------------------------- -- Statements. C-- usually, exceptions to this should be obvious. -- -pprStmt :: CmmStmt -> SDoc -pprStmt stmt = case stmt of +pprStmt :: Platform -> CmmStmt -> SDoc +pprStmt platform stmt = case stmt of -- ; CmmNop -> semi @@ -113,10 +113,10 @@ pprStmt stmt = case stmt of CmmComment s -> text "//" <+> ftext s -- reg = expr; - CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi + CmmAssign reg expr -> ppr reg <+> equals <+> pprPlatform platform expr <> semi -- rep[lv] = expr; - CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi + CmmStore lv expr -> rep <> brackets(pprPlatform platform lv) <+> equals <+> pprPlatform platform expr <> semi where rep = ppr ( cmmExprType expr ) @@ -124,9 +124,9 @@ pprStmt stmt = case stmt of -- ToDo ppr volatile CmmCall (CmmCallee fn cconv) results args safety ret -> sep [ pp_lhs <+> pp_conv - , nest 2 (pprExpr9 fn <> + , nest 2 (pprExpr9 platform fn <> parens (commafy (map ppr_ar args))) - <> brackets (ppr safety) + <> brackets (pprPlatform platform safety) , case ret of CmmMayReturn -> empty CmmNeverReturns -> ptext $ sLit (" never returns") ] <> semi @@ -135,16 +135,16 @@ pprStmt stmt = case stmt of | otherwise = commafy (map ppr_ar results) <+> equals -- Don't print the hints on a native C-- call ppr_ar (CmmHinted ar k) = case cconv of - CmmCallConv -> ppr ar - _ -> ppr (ar,k) + CmmCallConv -> pprPlatform platform ar + _ -> pprPlatform platform (ar,k) pp_conv = case cconv of CmmCallConv -> empty _ -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv) -- Call a CallishMachOp, like sin or cos that might be implemented as a library call. CmmCall (CmmPrim op) results args safety ret -> - pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv) - results args safety ret) + pprStmt platform (CmmCall (CmmCallee (CmmLit lbl) CCallConv) + results args safety ret) where -- HACK: A CallishMachOp doesn't really correspond to a ForeignLabel, but we -- use one to get the label printed. @@ -153,27 +153,29 @@ pprStmt stmt = case stmt of Nothing ForeignLabelInThisPackage IsFunction) CmmBranch ident -> genBranch ident - CmmCondBranch expr ident -> genCondBranch expr ident - CmmJump expr params -> genJump expr params - CmmReturn params -> genReturn params - CmmSwitch arg ids -> genSwitch arg ids + CmmCondBranch expr ident -> genCondBranch platform expr ident + CmmJump expr params -> genJump platform expr params + CmmReturn params -> genReturn platform params + CmmSwitch arg ids -> genSwitch platform arg ids -- Just look like a tuple, since it was a tuple before -- ... is that a good idea? --Isaac Dupree instance (Outputable a) => Outputable (CmmHinted a) where ppr (CmmHinted a k) = ppr (a, k) +instance (PlatformOutputable a) => PlatformOutputable (CmmHinted a) where + pprPlatform platform (CmmHinted a k) = pprPlatform platform (a, k) -pprUpdateFrame :: UpdateFrame -> SDoc -pprUpdateFrame (UpdateFrame expr args) = +pprUpdateFrame :: Platform -> UpdateFrame -> SDoc +pprUpdateFrame platform (UpdateFrame expr args) = hcat [ ptext (sLit "jump") , space , if isTrivialCmmExpr expr - then pprExpr expr + then pprExpr platform expr else case expr of - CmmLoad (CmmReg _) _ -> pprExpr expr - _ -> parens (pprExpr expr) + CmmLoad (CmmReg _) _ -> pprExpr platform expr + _ -> parens (pprExpr platform expr) , space - , parens ( commafy $ map ppr args ) ] + , parens ( commafy $ map (pprPlatform platform) args ) ] -- -------------------------------------------------------------------------- @@ -190,10 +192,10 @@ genBranch ident = -- -- if (expr) { goto lbl; } -- -genCondBranch :: CmmExpr -> BlockId -> SDoc -genCondBranch expr ident = +genCondBranch :: Platform -> CmmExpr -> BlockId -> SDoc +genCondBranch platform expr ident = hsep [ ptext (sLit "if") - , parens(ppr expr) + , parens(pprPlatform platform expr) , ptext (sLit "goto") , ppr ident <> semi ] @@ -202,17 +204,17 @@ genCondBranch expr ident = -- -- jump foo(a, b, c); -- -genJump :: CmmExpr -> [CmmHinted CmmExpr] -> SDoc -genJump expr args = +genJump :: Platform -> CmmExpr -> [CmmHinted CmmExpr] -> SDoc +genJump platform expr args = hcat [ ptext (sLit "jump") , space , if isTrivialCmmExpr expr - then pprExpr expr + then pprExpr platform expr else case expr of - CmmLoad (CmmReg _) _ -> pprExpr expr - _ -> parens (pprExpr expr) + CmmLoad (CmmReg _) _ -> pprExpr platform expr + _ -> parens (pprExpr platform expr) , space - , parens ( commafy $ map ppr args ) + , parens ( commafy $ map (pprPlatform platform) args ) , semi ] @@ -221,11 +223,11 @@ genJump expr args = -- -- return (a, b, c); -- -genReturn :: [CmmHinted CmmExpr] -> SDoc -genReturn args = +genReturn :: Platform -> [CmmHinted CmmExpr] -> SDoc +genReturn platform args = hcat [ ptext (sLit "return") , space - , parens ( commafy $ map ppr args ) + , parens ( commafy $ map (pprPlatform platform) args ) , semi ] -- -------------------------------------------------------------------------- @@ -235,8 +237,8 @@ genReturn args = -- -- switch [0 .. n] (expr) { case ... ; } -- -genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc -genSwitch expr maybe_ids +genSwitch :: Platform -> CmmExpr -> [Maybe BlockId] -> SDoc +genSwitch platform expr maybe_ids = let pairs = groupBy snds (zip [0 .. ] maybe_ids ) @@ -244,8 +246,8 @@ genSwitch expr maybe_ids , int (length maybe_ids - 1) , ptext (sLit "] ") , if isTrivialCmmExpr expr - then pprExpr expr - else parens (pprExpr expr) + then pprExpr platform expr + else parens (pprExpr platform expr) , ptext (sLit " {") ]) 4 (vcat ( map caseify pairs )) $$ rbrace diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 3afdaf1100..78cd6990ba 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -36,6 +36,7 @@ import Unique import UniqSet import FastString import Outputable +import Platform import Constants import Util @@ -67,7 +68,7 @@ import Control.Monad.ST pprCs :: DynFlags -> [RawCmmGroup] -> SDoc pprCs dflags cmms - = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms) + = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC (targetPlatform dflags) c) cmms) where split_marker | dopt Opt_SplitObjs dflags = ptext (sLit "__STG_SPLIT_MARKER") @@ -83,57 +84,57 @@ writeCs dflags handle cmms -- for fun, we could call cmmToCmm over the tops... -- -pprC :: RawCmmGroup -> SDoc -pprC tops = vcat $ intersperse blankLine $ map pprTop tops +pprC :: Platform -> RawCmmGroup -> SDoc +pprC platform tops = vcat $ intersperse blankLine $ map (pprTop platform) tops -- -- top level procs -- -pprTop :: RawCmmDecl -> SDoc -pprTop (CmmProc mb_info clbl (ListGraph blocks)) = +pprTop :: Platform -> RawCmmDecl -> SDoc +pprTop platform (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) $$ + Just (Statics info_clbl info_dat) -> pprDataExterns platform info_dat $$ + pprWordArray platform info_clbl info_dat) $$ (vcat [ blankLine, extern_decls, (if (externallyVisibleCLabel clbl) - then mkFN_ else mkIF_) (pprCLabel clbl) <+> lbrace, + then mkFN_ else mkIF_) (pprCLabel platform clbl) <+> lbrace, nest 8 temp_decls, nest 8 mkFB_, case blocks of [] -> empty -- the first block doesn't get a label: (BasicBlock _ stmts : rest) -> - nest 8 (vcat (map pprStmt stmts)) $$ - vcat (map pprBBlock rest), + nest 8 (vcat (map (pprStmt platform) stmts)) $$ + vcat (map (pprBBlock platform) rest), nest 8 mkFE_, rbrace ] ) where - (temp_decls, extern_decls) = pprTempAndExternDecls blocks + (temp_decls, extern_decls) = pprTempAndExternDecls platform blocks -- Chunks of static data. -- We only handle (a) arrays of word-sized things and (b) strings. -pprTop (CmmData _section (Statics lbl [CmmString str])) = +pprTop platform (CmmData _section (Statics lbl [CmmString str])) = hcat [ - pprLocalness lbl, ptext (sLit "char "), pprCLabel lbl, + pprLocalness lbl, ptext (sLit "char "), pprCLabel platform lbl, ptext (sLit "[] = "), pprStringInCStyle str, semi ] -pprTop (CmmData _section (Statics lbl [CmmUninitialised size])) = +pprTop platform (CmmData _section (Statics lbl [CmmUninitialised size])) = hcat [ - pprLocalness lbl, ptext (sLit "char "), pprCLabel lbl, + pprLocalness lbl, ptext (sLit "char "), pprCLabel platform lbl, brackets (int size), semi ] -pprTop (CmmData _section (Statics lbl lits)) = - pprDataExterns lits $$ - pprWordArray lbl lits +pprTop platform (CmmData _section (Statics lbl lits)) = + pprDataExterns platform lits $$ + pprWordArray platform lbl lits -- -------------------------------------------------------------------------- -- BasicBlocks are self-contained entities: they always end in a jump. @@ -142,24 +143,24 @@ pprTop (CmmData _section (Statics lbl lits)) = -- as many jumps as possible into fall throughs. -- -pprBBlock :: CmmBasicBlock -> SDoc -pprBBlock (BasicBlock lbl stmts) = +pprBBlock :: Platform -> CmmBasicBlock -> SDoc +pprBBlock platform (BasicBlock lbl stmts) = if null stmts then pprTrace "pprC.pprBBlock: curious empty code block for" (pprBlockId lbl) empty else nest 4 (pprBlockId lbl <> colon) $$ - nest 8 (vcat (map pprStmt stmts)) + nest 8 (vcat (map (pprStmt platform) stmts)) -- -------------------------------------------------------------------------- -- Info tables. Just arrays of words. -- See codeGen/ClosureInfo, and nativeGen/PprMach -pprWordArray :: CLabel -> [CmmStatic] -> SDoc -pprWordArray lbl ds +pprWordArray :: Platform -> CLabel -> [CmmStatic] -> SDoc +pprWordArray platform lbl ds = hcat [ pprLocalness lbl, ptext (sLit "StgWord") - , space, pprCLabel lbl, ptext (sLit "[] = {") ] - $$ nest 8 (commafy (pprStatics ds)) + , space, pprCLabel platform lbl, ptext (sLit "[] = {") ] + $$ nest 8 (commafy (pprStatics platform ds)) $$ ptext (sLit "};") -- @@ -173,9 +174,9 @@ pprLocalness lbl | not $ externallyVisibleCLabel lbl = ptext (sLit "static ") -- Statements. -- -pprStmt :: CmmStmt -> SDoc +pprStmt :: Platform -> CmmStmt -> SDoc -pprStmt stmt = case stmt of +pprStmt platform stmt = case stmt of CmmReturn _ -> panic "pprStmt: return statement should have been cps'd away" CmmNop -> empty CmmComment _ -> empty -- (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/") @@ -184,16 +185,16 @@ pprStmt stmt = case stmt of -- some debugging option is on. They can get quite -- large. - CmmAssign dest src -> pprAssign dest src + CmmAssign dest src -> pprAssign platform dest src CmmStore dest src | typeWidth rep == W64 && wordWidth /= W64 -> (if isFloatType rep then ptext (sLit "ASSIGN_DBL") else ptext (sLit ("ASSIGN_Word64"))) <> - parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi + parens (mkP_ <> pprExpr1 platform dest <> comma <> pprExpr platform src) <> semi | otherwise - -> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ] + -> hsep [ pprExpr platform (CmmLoad dest rep), equals, pprExpr platform src <> semi ] where rep = cmmExprType src @@ -201,14 +202,14 @@ pprStmt stmt = case stmt of maybe_proto $$ fnCall where - cast_fn = parens (cCast (pprCFunType (char '*') cconv results args) fn) + cast_fn = parens (cCast platform (pprCFunType (char '*') cconv results args) fn) real_fun_proto lbl = char ';' <> - pprCFunType (pprCLabel lbl) cconv results args <> + pprCFunType (pprCLabel platform lbl) cconv results args <> noreturn_attr <> semi fun_proto lbl = ptext (sLit ";EF_(") <> - pprCLabel lbl <> char ')' <> semi + pprCLabel platform lbl <> char ')' <> semi noreturn_attr = case ret of CmmNeverReturns -> text "__attribute__ ((noreturn))" @@ -219,7 +220,7 @@ pprStmt stmt = case stmt of case fn of CmmLit (CmmLabel lbl) | StdCallConv <- cconv -> - let myCall = pprCall (pprCLabel lbl) cconv results args safety + let myCall = pprCall platform (pprCLabel platform lbl) cconv results args safety in (real_fun_proto lbl, myCall) -- stdcall functions must be declared with -- a function type, otherwise the C compiler @@ -227,22 +228,22 @@ pprStmt stmt = case stmt of -- can't add the @n suffix ourselves, because -- it isn't valid C. | CmmNeverReturns <- ret -> - let myCall = pprCall (pprCLabel lbl) cconv results args safety + let myCall = pprCall platform (pprCLabel platform lbl) cconv results args safety in (real_fun_proto lbl, myCall) | not (isMathFun lbl) -> let myCall = braces ( pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi - $$ pprCall (text "ghcFunPtr") cconv results args safety <> semi + $$ pprCall platform (text "ghcFunPtr") cconv results args safety <> semi ) in (fun_proto lbl, myCall) _ -> (empty {- no proto -}, - pprCall cast_fn cconv results args safety <> semi) + pprCall platform cast_fn cconv results args safety <> semi) -- for a dynamic call, no declaration is necessary. CmmCall (CmmPrim op) results args safety _ret -> - pprCall ppr_fn CCallConv results args' safety + pprCall platform ppr_fn CCallConv results args' safety where ppr_fn = pprCallishMachOp_for_C op -- The mem primops carry an extra alignment arg, must drop it. @@ -251,9 +252,9 @@ pprStmt stmt = case stmt of | otherwise = args CmmBranch ident -> pprBranch ident - CmmCondBranch expr ident -> pprCondBranch expr ident - CmmJump lbl _params -> mkJMP_(pprExpr lbl) <> semi - CmmSwitch arg ids -> pprSwitch arg ids + CmmCondBranch expr ident -> pprCondBranch platform expr ident + CmmJump lbl _params -> mkJMP_(pprExpr platform lbl) <> semi + CmmSwitch arg ids -> pprSwitch platform arg ids pprCFunType :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc pprCFunType ppr_fn cconv ress args @@ -275,9 +276,9 @@ pprBranch ident = ptext (sLit "goto") <+> pprBlockId ident <> semi -- --------------------------------------------------------------------- -- conditional branches to local labels -pprCondBranch :: CmmExpr -> BlockId -> SDoc -pprCondBranch expr ident - = hsep [ ptext (sLit "if") , parens(pprExpr expr) , +pprCondBranch :: Platform -> CmmExpr -> BlockId -> SDoc +pprCondBranch platform expr ident + = hsep [ ptext (sLit "if") , parens(pprExpr platform expr) , ptext (sLit "goto") , (pprBlockId ident) <> semi ] @@ -290,12 +291,12 @@ pprCondBranch expr ident -- 'undefined'. However, they may be defined one day, so we better -- document this behaviour. -- -pprSwitch :: CmmExpr -> [ Maybe BlockId ] -> SDoc -pprSwitch e maybe_ids +pprSwitch :: Platform -> CmmExpr -> [ Maybe BlockId ] -> SDoc +pprSwitch platform e maybe_ids = let pairs = [ (ix, ident) | (ix,Just ident) <- zip [0..] maybe_ids ] pairs2 = [ (map fst as, snd (head as)) | as <- groupBy sndEq pairs ] in - (hang (ptext (sLit "switch") <+> parens ( pprExpr e ) <+> lbrace) + (hang (ptext (sLit "switch") <+> parens ( pprExpr platform e ) <+> lbrace) 4 (vcat ( map caseify pairs2 ))) $$ rbrace @@ -329,12 +330,12 @@ pprSwitch e maybe_ids -- -- (similar invariants apply to the rest of the pretty printer). -pprExpr :: CmmExpr -> SDoc -pprExpr e = case e of - CmmLit lit -> pprLit lit +pprExpr :: Platform -> CmmExpr -> SDoc +pprExpr platform e = case e of + CmmLit lit -> pprLit platform lit - CmmLoad e ty -> pprLoad e ty + CmmLoad e ty -> pprLoad platform e ty CmmReg reg -> pprCastReg reg CmmRegOff reg 0 -> pprCastReg reg @@ -344,17 +345,17 @@ pprExpr e = case e of where pprRegOff op i' = pprCastReg reg <> op <> int i' - CmmMachOp mop args -> pprMachOpApp mop args + CmmMachOp mop args -> pprMachOpApp platform mop args CmmStackSlot _ _ -> panic "pprExpr: CmmStackSlot not supported!" -pprLoad :: CmmExpr -> CmmType -> SDoc -pprLoad e ty +pprLoad :: Platform -> CmmExpr -> CmmType -> SDoc +pprLoad platform e ty | width == W64, wordWidth /= W64 = (if isFloatType ty then ptext (sLit "PK_DBL") else ptext (sLit "PK_Word64")) - <> parens (mkP_ <> pprExpr1 e) + <> parens (mkP_ <> pprExpr1 platform e) | otherwise = case e of @@ -370,32 +371,32 @@ pprLoad e ty -- (For tagging to work, I had to avoid unaligned loads. --ARY) -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift)) - _other -> cLoad e ty + _other -> cLoad platform e ty where width = typeWidth ty -pprExpr1 :: CmmExpr -> SDoc -pprExpr1 (CmmLit lit) = pprLit1 lit -pprExpr1 e@(CmmReg _reg) = pprExpr e -pprExpr1 other = parens (pprExpr other) +pprExpr1 :: Platform -> CmmExpr -> SDoc +pprExpr1 platform (CmmLit lit) = pprLit1 platform lit +pprExpr1 platform e@(CmmReg _reg) = pprExpr platform e +pprExpr1 platform other = parens (pprExpr platform other) -- -------------------------------------------------------------------------- -- MachOp applications -pprMachOpApp :: MachOp -> [CmmExpr] -> SDoc +pprMachOpApp :: Platform -> MachOp -> [CmmExpr] -> SDoc -pprMachOpApp op args +pprMachOpApp platform op args | isMulMayOfloOp op - = ptext (sLit "mulIntMayOflo") <> parens (commafy (map pprExpr args)) + = ptext (sLit "mulIntMayOflo") <> parens (commafy (map (pprExpr platform) args)) where isMulMayOfloOp (MO_U_MulMayOflo _) = True isMulMayOfloOp (MO_S_MulMayOflo _) = True isMulMayOfloOp _ = False -pprMachOpApp mop args +pprMachOpApp platform mop args | Just ty <- machOpNeedsCast mop - = ty <> parens (pprMachOpApp' mop args) + = ty <> parens (pprMachOpApp' platform mop args) | otherwise - = pprMachOpApp' mop args + = pprMachOpApp' platform mop args -- Comparisons in C have type 'int', but we want type W_ (this is what -- resultRepOfMachOp says). The other C operations inherit their type @@ -405,8 +406,8 @@ machOpNeedsCast mop | isComparisonMachOp mop = Just mkW_ | otherwise = Nothing -pprMachOpApp' :: MachOp -> [CmmExpr] -> SDoc -pprMachOpApp' mop args +pprMachOpApp' :: Platform -> MachOp -> [CmmExpr] -> SDoc +pprMachOpApp' platform mop args = case args of -- dyadic [x,y] -> pprArg x <+> pprMachOp_for_C mop <+> pprArg y @@ -418,9 +419,9 @@ pprMachOpApp' mop args where -- Cast needed for signed integer ops - pprArg e | signedOp mop = cCast (machRep_S_CType (typeWidth (cmmExprType e))) e - | needsFCasts mop = cCast (machRep_F_CType (typeWidth (cmmExprType e))) e - | otherwise = pprExpr1 e + pprArg e | signedOp mop = cCast platform (machRep_S_CType (typeWidth (cmmExprType e))) e + | needsFCasts mop = cCast platform (machRep_F_CType (typeWidth (cmmExprType e))) e + | otherwise = pprExpr1 platform e needsFCasts (MO_F_Eq _) = False needsFCasts (MO_F_Ne _) = False needsFCasts (MO_F_Neg _) = True @@ -430,8 +431,8 @@ pprMachOpApp' mop args -- -------------------------------------------------------------------------- -- Literals -pprLit :: CmmLit -> SDoc -pprLit lit = case lit of +pprLit :: Platform -> CmmLit -> SDoc +pprLit platform lit = case lit of CmmInt i rep -> pprHexVal i rep CmmFloat f w -> parens (machRep_F_CType w) <> str @@ -457,54 +458,54 @@ pprLit lit = case lit of -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i where - pprCLabelAddr lbl = char '&' <> pprCLabel lbl + pprCLabelAddr lbl = char '&' <> pprCLabel platform lbl -pprLit1 :: CmmLit -> SDoc -pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit) -pprLit1 lit@(CmmLabelDiffOff _ _ _) = parens (pprLit lit) -pprLit1 lit@(CmmFloat _ _) = parens (pprLit lit) -pprLit1 other = pprLit other +pprLit1 :: Platform -> CmmLit -> SDoc +pprLit1 platform lit@(CmmLabelOff _ _) = parens (pprLit platform lit) +pprLit1 platform lit@(CmmLabelDiffOff _ _ _) = parens (pprLit platform lit) +pprLit1 platform lit@(CmmFloat _ _) = parens (pprLit platform lit) +pprLit1 platform other = pprLit platform other -- --------------------------------------------------------------------------- -- Static data -pprStatics :: [CmmStatic] -> [SDoc] -pprStatics [] = [] -pprStatics (CmmStaticLit (CmmFloat f W32) : rest) +pprStatics :: Platform -> [CmmStatic] -> [SDoc] +pprStatics _ [] = [] +pprStatics platform (CmmStaticLit (CmmFloat f W32) : rest) -- floats are padded to a word, see #1852 | wORD_SIZE == 8, CmmStaticLit (CmmInt 0 W32) : rest' <- rest - = pprLit1 (floatToWord f) : pprStatics rest' + = pprLit1 platform (floatToWord f) : pprStatics platform rest' | wORD_SIZE == 4 - = pprLit1 (floatToWord f) : pprStatics rest + = pprLit1 platform (floatToWord f) : pprStatics platform rest | otherwise = pprPanic "pprStatics: float" (vcat (map ppr' rest)) where ppr' (CmmStaticLit l) = ppr (cmmLitType l) ppr' _other = ptext (sLit "bad static!") -pprStatics (CmmStaticLit (CmmFloat f W64) : rest) - = map pprLit1 (doubleToWords f) ++ pprStatics rest -pprStatics (CmmStaticLit (CmmInt i W64) : rest) +pprStatics platform (CmmStaticLit (CmmFloat f W64) : rest) + = map (pprLit1 platform) (doubleToWords f) ++ pprStatics platform rest +pprStatics platform (CmmStaticLit (CmmInt i W64) : rest) | wordWidth == W32 #ifdef WORDS_BIGENDIAN - = pprStatics (CmmStaticLit (CmmInt q W32) : + = pprStatics platform (CmmStaticLit (CmmInt q W32) : CmmStaticLit (CmmInt r W32) : rest) #else - = pprStatics (CmmStaticLit (CmmInt r W32) : + = pprStatics platform (CmmStaticLit (CmmInt r W32) : CmmStaticLit (CmmInt q W32) : rest) #endif where r = i .&. 0xffffffff q = i `shiftR` 32 -pprStatics (CmmStaticLit (CmmInt _ w) : _) +pprStatics _ (CmmStaticLit (CmmInt _ w) : _) | w /= wordWidth = panic "pprStatics: cannot emit a non-word-sized static literal" -pprStatics (CmmStaticLit lit : rest) - = pprLit1 lit : pprStatics rest -pprStatics (other : _) - = pprPanic "pprWord" (pprStatic other) +pprStatics platform (CmmStaticLit lit : rest) + = pprLit1 platform lit : pprStatics platform rest +pprStatics platform (other : _) + = pprPanic "pprWord" (pprStatic platform other) -pprStatic :: CmmStatic -> SDoc -pprStatic s = case s of +pprStatic :: Platform -> CmmStatic -> SDoc +pprStatic platform s = case s of - CmmStaticLit lit -> nest 4 (pprLit lit) + CmmStaticLit lit -> nest 4 (pprLit platform lit) CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i)) -- these should be inlined, like the old .hc @@ -691,15 +692,15 @@ mkP_ = ptext (sLit "(P_)") -- StgWord* -- -- Generating assignments is what we're all about, here -- -pprAssign :: CmmReg -> CmmExpr -> SDoc +pprAssign :: Platform -> CmmReg -> CmmExpr -> SDoc -- dest is a reg, rhs is a reg -pprAssign r1 (CmmReg r2) +pprAssign _ r1 (CmmReg r2) | isPtrReg r1 && isPtrReg r2 = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ] -- dest is a reg, rhs is a CmmRegOff -pprAssign r1 (CmmRegOff r2 off) +pprAssign _ r1 (CmmRegOff r2 off) | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE == 0) = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ] where @@ -711,10 +712,10 @@ pprAssign r1 (CmmRegOff r2 off) -- dest is a reg, rhs is anything. -- We can't cast the lvalue, so we have to cast the rhs if necessary. Casting -- the lvalue elicits a warning from new GCC versions (3.4+). -pprAssign r1 r2 - | isFixedPtrReg r1 = mkAssign (mkP_ <> pprExpr1 r2) - | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 r2) - | otherwise = mkAssign (pprExpr r2) +pprAssign platform r1 r2 + | isFixedPtrReg r1 = mkAssign (mkP_ <> pprExpr1 platform r2) + | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 platform r2) + | otherwise = mkAssign (pprExpr platform r2) where mkAssign x = if r1 == CmmGlobal BaseReg then ptext (sLit "ASSIGN_BaseReg") <> parens x <> semi else pprReg r1 <> ptext (sLit " = ") <> x <> semi @@ -810,10 +811,11 @@ pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq -- ----------------------------------------------------------------------------- -- Foreign Calls -pprCall :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> CmmSafety - -> SDoc +pprCall :: Platform -> SDoc -> CCallConv + -> [HintedCmmFormal] -> [HintedCmmActual] -> CmmSafety + -> SDoc -pprCall ppr_fn cconv results args _ +pprCall platform ppr_fn cconv results args _ | not (is_cishCC cconv) = panic $ "pprCall: unknown calling convention" @@ -828,12 +830,12 @@ pprCall ppr_fn cconv results args _ ppr_assign _other _rhs = panic "pprCall: multiple results" pprArg (CmmHinted expr AddrHint) - = cCast (ptext (sLit "void *")) expr + = cCast platform (ptext (sLit "void *")) expr -- see comment by machRepHintCType below pprArg (CmmHinted expr SignedHint) - = cCast (machRep_S_CType $ typeWidth $ cmmExprType expr) expr + = cCast platform (machRep_S_CType $ typeWidth $ cmmExprType expr) expr pprArg (CmmHinted expr _other) - = pprExpr expr + = pprExpr platform expr pprUnHint AddrHint rep = parens (machRepCType rep) pprUnHint SignedHint rep = parens (machRepCType rep) @@ -851,29 +853,30 @@ is_cishCC PrimCallConv = False -- Find and print local and external declarations for a list of -- Cmm statements. -- -pprTempAndExternDecls :: [CmmBasicBlock] -> (SDoc{-temps-}, SDoc{-externs-}) -pprTempAndExternDecls stmts +pprTempAndExternDecls :: Platform -> [CmmBasicBlock] + -> (SDoc{-temps-}, SDoc{-externs-}) +pprTempAndExternDecls platform stmts = (vcat (map pprTempDecl (uniqSetToList temps)), - vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls))) + vcat (map (pprExternDecl platform False{-ToDo-}) (Map.keys lbls))) where (temps, lbls) = runTE (mapM_ te_BB stmts) -pprDataExterns :: [CmmStatic] -> SDoc -pprDataExterns statics - = vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls)) +pprDataExterns :: Platform -> [CmmStatic] -> SDoc +pprDataExterns platform statics + = vcat (map (pprExternDecl platform False{-ToDo-}) (Map.keys lbls)) where (_, lbls) = runTE (mapM_ te_Static statics) pprTempDecl :: LocalReg -> SDoc pprTempDecl l@(LocalReg _ rep) = hcat [ machRepCType rep, space, pprLocalReg l, semi ] -pprExternDecl :: Bool -> CLabel -> SDoc -pprExternDecl _in_srt lbl +pprExternDecl :: Platform -> Bool -> CLabel -> SDoc +pprExternDecl platform _in_srt lbl -- do not print anything for "known external" things | not (needsCDecl lbl) = empty | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz | otherwise = hcat [ visibility, label_type lbl, - lparen, pprCLabel lbl, text ");" ] + lparen, pprCLabel platform lbl, text ");" ] where label_type lbl | isCFunctionLabel lbl = ptext (sLit "F_") | otherwise = ptext (sLit "I_") @@ -886,7 +889,7 @@ pprExternDecl _in_srt lbl -- we must generate an appropriate prototype for it, so that the C compiler will -- add the @n suffix to the label (#2276) stdcall_decl sz = - ptext (sLit "extern __attribute__((stdcall)) void ") <> pprCLabel lbl + ptext (sLit "extern __attribute__((stdcall)) void ") <> pprCLabel platform lbl <> parens (commafy (replicate (sz `quot` wORD_SIZE) (machRep_U_CType wordWidth))) <> semi @@ -945,19 +948,19 @@ te_Reg _ = return () -- --------------------------------------------------------------------- -- C types for MachReps -cCast :: SDoc -> CmmExpr -> SDoc -cCast ty expr = parens ty <> pprExpr1 expr +cCast :: Platform -> SDoc -> CmmExpr -> SDoc +cCast platform ty expr = parens ty <> pprExpr1 platform expr -cLoad :: CmmExpr -> CmmType -> SDoc +cLoad :: Platform -> CmmExpr -> CmmType -> SDoc #ifdef BEWARE_LOAD_STORE_ALIGNMENT -cLoad expr rep = +cLoad platform expr rep = let decl = machRepCType rep <+> ptext (sLit "x") <> semi struct = ptext (sLit "struct") <+> braces (decl) packed_attr = ptext (sLit "__attribute__((packed))") cast = parens (struct <+> packed_attr <> char '*') in parens (cast <+> pprExpr1 expr) <> ptext (sLit "->x") #else -cLoad expr rep = char '*' <> parens (cCast (machRepPtrCType rep) expr) +cLoad platform expr rep = char '*' <> parens (cCast platform (machRepPtrCType rep) expr) #endif isCmmWordType :: CmmType -> Bool diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 521ab059b7..d32f129247 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -59,12 +59,12 @@ import Prelude hiding (succ) instance Outputable CmmStackInfo where ppr = pprStackInfo -instance Outputable CmmTopInfo where - ppr = pprTopInfo +instance PlatformOutputable CmmTopInfo where + pprPlatform = pprTopInfo -instance Outputable (CmmNode e x) where - ppr = pprNode +instance PlatformOutputable (CmmNode e x) where + pprPlatform = pprNode instance Outputable Convention where ppr = pprConvention @@ -72,18 +72,18 @@ instance Outputable Convention where instance Outputable ForeignConvention where ppr = pprForeignConvention -instance Outputable ForeignTarget where - ppr = pprForeignTarget +instance PlatformOutputable ForeignTarget where + pprPlatform = pprForeignTarget instance PlatformOutputable (Block CmmNode C C) where - pprPlatform _ = pprBlock + pprPlatform = pprBlock instance PlatformOutputable (Block CmmNode C O) where - pprPlatform _ = pprBlock + pprPlatform = pprBlock instance PlatformOutputable (Block CmmNode O C) where - pprPlatform _ = pprBlock + pprPlatform = pprBlock instance PlatformOutputable (Block CmmNode O O) where - pprPlatform _ = pprBlock + pprPlatform = pprBlock instance PlatformOutputable (Graph CmmNode e x) where pprPlatform = pprGraph @@ -99,22 +99,23 @@ pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) = ptext (sLit "arg_space: ") <> ppr arg_space <+> ptext (sLit "updfr_space: ") <> ppr updfr_space -pprTopInfo :: CmmTopInfo -> SDoc -pprTopInfo (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) = - vcat [ptext (sLit "info_tbl: ") <> ppr info_tbl, +pprTopInfo :: Platform -> CmmTopInfo -> SDoc +pprTopInfo platform (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) = + vcat [ptext (sLit "info_tbl: ") <> pprPlatform platform info_tbl, ptext (sLit "stack_info: ") <> ppr stack_info] ---------------------------------------------------------- -- Outputting blocks and graphs pprBlock :: IndexedCO x SDoc SDoc ~ SDoc - => Block CmmNode e x -> IndexedCO e SDoc SDoc -pprBlock block = foldBlockNodesB3 ( ($$) . ppr - , ($$) . (nest 4) . ppr - , ($$) . (nest 4) . ppr - ) - block - empty + => Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc +pprBlock platform block + = foldBlockNodesB3 ( ($$) . pprPlatform platform + , ($$) . (nest 4) . pprPlatform platform + , ($$) . (nest 4) . pprPlatform platform + ) + block + empty pprGraph :: Platform -> Graph CmmNode e x -> SDoc pprGraph _ GNil = empty @@ -152,23 +153,25 @@ pprConvention (Private {}) = text "<private-convention>" pprForeignConvention :: ForeignConvention -> SDoc pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs -pprForeignTarget :: ForeignTarget -> SDoc -pprForeignTarget (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn +pprForeignTarget :: Platform -> ForeignTarget -> SDoc +pprForeignTarget platform (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn where ppr_fc :: ForeignConvention -> SDoc ppr_fc (ForeignConvention c args res) = doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res ppr_target :: CmmExpr -> SDoc - ppr_target t@(CmmLit _) = ppr t - ppr_target fn' = parens (ppr fn') + ppr_target t@(CmmLit _) = pprPlatform platform t + ppr_target fn' = parens (pprPlatform platform fn') -pprForeignTarget (PrimTarget op) +pprForeignTarget platform (PrimTarget op) -- HACK: We're just using a ForeignLabel to get this printed, the label -- might not really be foreign. - = ppr (CmmLabel (mkForeignLabel - (mkFastString (show op)) - Nothing ForeignLabelInThisPackage IsFunction)) -pprNode :: CmmNode e x -> SDoc -pprNode node = pp_node <+> pp_debug + = pprPlatform platform + (CmmLabel (mkForeignLabel + (mkFastString (show op)) + Nothing ForeignLabelInThisPackage IsFunction)) + +pprNode :: Platform -> CmmNode e x -> SDoc +pprNode platform node = pp_node <+> pp_debug where pp_node :: SDoc pp_node = case node of @@ -179,10 +182,10 @@ pprNode node = pp_node <+> pp_debug CmmComment s -> text "//" <+> ftext s -- reg = expr; - CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi + CmmAssign reg expr -> ppr reg <+> equals <+> pprPlatform platform expr <> semi -- rep[lv] = expr; - CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi + CmmStore lv expr -> rep <> brackets(pprPlatform platform lv) <+> equals <+> pprPlatform platform expr <> semi where rep = ppr ( cmmExprType expr ) @@ -192,7 +195,7 @@ pprNode node = pp_node <+> pp_debug hsep [ ppUnless (null results) $ parens (commafy $ map ppr results) <+> equals, ptext $ sLit "call", - ppr target <> parens (commafy $ map ppr args) <> semi] + pprPlatform platform target <> parens (commafy $ map (pprPlatform platform) args) <> semi] -- goto label; CmmBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi @@ -200,7 +203,7 @@ pprNode node = pp_node <+> pp_debug -- if (expr) goto t; else goto f; CmmCondBranch expr t f -> hsep [ ptext (sLit "if") - , parens(ppr expr) + , parens(pprPlatform platform expr) , ptext (sLit "goto") , ppr t <> semi , ptext (sLit "else goto") @@ -211,7 +214,9 @@ pprNode node = pp_node <+> pp_debug hang (hcat [ ptext (sLit "switch [0 .. ") , int (length maybe_ids - 1) , ptext (sLit "] ") - , if isTrivialCmmExpr expr then ppr expr else parens (ppr expr) + , if isTrivialCmmExpr expr + then pprPlatform platform expr + else parens (pprPlatform platform expr) , ptext (sLit " {") ]) 4 (vcat ( map caseify pairs )) $$ rbrace @@ -232,15 +237,15 @@ pprNode node = pp_node <+> pp_debug <+> parens (ppr res) , ptext (sLit " with update frame") <+> ppr updfr_off , semi ] - where pprFun f@(CmmLit _) = ppr f - pprFun f = parens (ppr f) + where pprFun f@(CmmLit _) = pprPlatform platform f + pprFun f = parens (pprPlatform platform f) CmmForeignCall {tgt=t, res=rs, args=as, succ=s, updfr=u, intrbl=i} -> hcat $ if i then [ptext (sLit "interruptible"), space] else [] ++ [ ptext (sLit "foreign call"), space - , ppr t, ptext (sLit "(...)"), space + , pprPlatform platform t, ptext (sLit "(...)"), space , ptext (sLit "returns to") <+> ppr s - <+> ptext (sLit "args:") <+> parens (ppr as) + <+> ptext (sLit "args:") <+> parens (pprPlatform platform as) <+> ptext (sLit "ress:") <+> parens (ppr rs) , ptext (sLit " with update frame") <+> ppr u , semi ] diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs index 5cd3501b11..370428d750 100644 --- a/compiler/cmm/PprCmmDecl.hs +++ b/compiler/cmm/PprCmmDecl.hs @@ -53,49 +53,51 @@ import SMRep #include "../includes/rts/storage/FunTypes.h" -pprCmms :: (Outputable info, PlatformOutputable g) +pprCmms :: (PlatformOutputable info, PlatformOutputable g) => Platform -> [GenCmmGroup 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, PlatformOutputable g) +writeCmms :: (PlatformOutputable info, PlatformOutputable g) => Platform -> Handle -> [GenCmmGroup CmmStatics info g] -> IO () writeCmms platform handle cmms = printForC handle (pprCmms platform cmms) ----------------------------------------------------------------------------- -instance (Outputable d, Outputable info, PlatformOutputable i) +instance (PlatformOutputable d, PlatformOutputable info, PlatformOutputable i) => PlatformOutputable (GenCmmDecl d info i) where pprPlatform platform t = pprTop platform t -instance Outputable CmmStatics where - ppr e = pprStatics e +instance PlatformOutputable CmmStatics where + pprPlatform = pprStatics -instance Outputable CmmStatic where - ppr e = pprStatic e +instance PlatformOutputable CmmStatic where + pprPlatform = pprStatic -instance Outputable CmmInfoTable where - ppr e = pprInfoTable e +instance PlatformOutputable CmmInfoTable where + pprPlatform = pprInfoTable ----------------------------------------------------------------------------- -pprCmmGroup :: (Outputable d, Outputable info, PlatformOutputable g) - => Platform -> GenCmmGroup d info g -> SDoc +pprCmmGroup :: (PlatformOutputable d, + PlatformOutputable info, + PlatformOutputable g) + => Platform -> GenCmmGroup d info g -> SDoc pprCmmGroup platform tops = vcat $ intersperse blankLine $ map (pprTop platform) tops -- -------------------------------------------------------------------------- -- Top level `procedure' blocks. -- -pprTop :: (Outputable d, Outputable info, PlatformOutputable i) +pprTop :: (PlatformOutputable d, PlatformOutputable info, PlatformOutputable i) => Platform -> GenCmmDecl d info i -> SDoc pprTop platform (CmmProc info lbl graph) - = vcat [ pprCLabel lbl <> lparen <> rparen - , nest 8 $ lbrace <+> ppr info $$ rbrace + = vcat [ pprCLabel platform lbl <> lparen <> rparen + , nest 8 $ lbrace <+> pprPlatform platform info $$ rbrace , nest 4 $ pprPlatform platform graph , rbrace ] @@ -104,30 +106,32 @@ pprTop platform (CmmProc info lbl graph) -- -- section "data" { ... } -- -pprTop _ (CmmData section ds) = - (hang (pprSection section <+> lbrace) 4 (ppr ds)) +pprTop platform (CmmData section ds) = + (hang (pprSection section <+> lbrace) 4 (pprPlatform platform ds)) $$ rbrace -- -------------------------------------------------------------------------- -- Info tables. -pprInfoTable :: CmmInfoTable -> SDoc -pprInfoTable CmmNonInfoTable +pprInfoTable :: Platform -> CmmInfoTable -> SDoc +pprInfoTable _ CmmNonInfoTable = empty -pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep +pprInfoTable platform + (CmmInfoTable { cit_lbl = lbl, cit_rep = rep , cit_prof = prof_info , cit_srt = _srt }) - = vcat [ ptext (sLit "label:") <+> ppr lbl + = vcat [ ptext (sLit "label:") <+> pprPlatform platform lbl , ptext (sLit "rep:") <> ppr rep , case prof_info of NoProfilingInfo -> empty ProfilingInfo ct cd -> vcat [ ptext (sLit "type:") <+> pprWord8String ct , ptext (sLit "desc: ") <> pprWord8String cd ] ] -instance Outputable C_SRT where - ppr (NoC_SRT) = ptext (sLit "_no_srt_") - ppr (C_SRT label off bitmap) = parens (ppr label <> comma <> ppr off <> comma - <> text (show bitmap)) +instance PlatformOutputable C_SRT where + pprPlatform _ (NoC_SRT) = ptext (sLit "_no_srt_") + pprPlatform platform (C_SRT label off bitmap) + = parens (pprPlatform platform label <> comma <> ppr off + <> comma <> text (show bitmap)) instance Outputable ForeignHint where ppr NoHint = empty @@ -135,18 +139,20 @@ instance Outputable ForeignHint where -- ppr AddrHint = quotes(text "address") -- Temp Jan08 ppr AddrHint = (text "PtrHint") +instance PlatformOutputable ForeignHint where + pprPlatform _ = ppr -- -------------------------------------------------------------------------- -- Static data. -- 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) +pprStatics :: Platform -> CmmStatics -> SDoc +pprStatics platform (Statics lbl ds) = vcat ((pprCLabel platform lbl <> colon) : map (pprPlatform platform) ds) -pprStatic :: CmmStatic -> SDoc -pprStatic s = case s of - CmmStaticLit lit -> nest 4 $ ptext (sLit "const") <+> pprLit lit <> semi +pprStatic :: Platform -> CmmStatic -> SDoc +pprStatic platform s = case s of + CmmStaticLit lit -> nest 4 $ ptext (sLit "const") <+> pprLit platform lit <> semi CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i) CmmString s' -> nest 4 $ text "I8[]" <+> text (show s') diff --git a/compiler/cmm/PprCmmExpr.hs b/compiler/cmm/PprCmmExpr.hs index 763034554f..aa86ca04fc 100644 --- a/compiler/cmm/PprCmmExpr.hs +++ b/compiler/cmm/PprCmmExpr.hs @@ -42,6 +42,7 @@ import CmmExpr import CLabel import Outputable +import Platform import FastString import Data.Maybe @@ -49,17 +50,19 @@ import Numeric ( fromRat ) ----------------------------------------------------------------------------- -instance Outputable CmmExpr where - ppr e = pprExpr e +instance PlatformOutputable CmmExpr where + pprPlatform = pprExpr instance Outputable CmmReg where ppr e = pprReg e -instance Outputable CmmLit where - ppr l = pprLit l +instance PlatformOutputable CmmLit where + pprPlatform = pprLit instance Outputable LocalReg where ppr e = pprLocalReg e +instance PlatformOutputable LocalReg where + pprPlatform _ = ppr instance Outputable Area where ppr e = pprArea e @@ -71,15 +74,15 @@ instance Outputable GlobalReg where -- Expressions -- -pprExpr :: CmmExpr -> SDoc -pprExpr e +pprExpr :: Platform -> CmmExpr -> SDoc +pprExpr platform e = case e of CmmRegOff reg i -> - pprExpr (CmmMachOp (MO_Add rep) + pprExpr platform (CmmMachOp (MO_Add rep) [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)]) where rep = typeWidth (cmmRegType reg) - CmmLit lit -> pprLit lit - _other -> pprExpr1 e + CmmLit lit -> pprLit platform lit + _other -> pprExpr1 platform e -- Here's the precedence table from CmmParse.y: -- %nonassoc '>=' '>' '<=' '<' '!=' '==' @@ -95,10 +98,10 @@ pprExpr e -- a default conservative behaviour. -- %nonassoc '>=' '>' '<=' '<' '!=' '==' -pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc -pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op - = pprExpr7 x <+> doc <+> pprExpr7 y -pprExpr1 e = pprExpr7 e +pprExpr1, pprExpr7, pprExpr8 :: Platform -> CmmExpr -> SDoc +pprExpr1 platform (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op + = pprExpr7 platform x <+> doc <+> pprExpr7 platform y +pprExpr1 platform e = pprExpr7 platform e infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc @@ -113,55 +116,55 @@ infixMachOp1 (MO_U_Lt _) = Just (char '<') infixMachOp1 _ = Nothing -- %left '-' '+' -pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0 - = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)]) -pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op - = pprExpr7 x <+> doc <+> pprExpr8 y -pprExpr7 e = pprExpr8 e +pprExpr7 platform (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0 + = pprExpr7 platform (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)]) +pprExpr7 platform (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op + = pprExpr7 platform x <+> doc <+> pprExpr8 platform y +pprExpr7 platform e = pprExpr8 platform e infixMachOp7 (MO_Add _) = Just (char '+') infixMachOp7 (MO_Sub _) = Just (char '-') infixMachOp7 _ = Nothing -- %left '/' '*' '%' -pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op - = pprExpr8 x <+> doc <+> pprExpr9 y -pprExpr8 e = pprExpr9 e +pprExpr8 platform (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op + = pprExpr8 platform x <+> doc <+> pprExpr9 platform y +pprExpr8 platform e = pprExpr9 platform e infixMachOp8 (MO_U_Quot _) = Just (char '/') infixMachOp8 (MO_Mul _) = Just (char '*') infixMachOp8 (MO_U_Rem _) = Just (char '%') infixMachOp8 _ = Nothing -pprExpr9 :: CmmExpr -> SDoc -pprExpr9 e = +pprExpr9 :: Platform -> CmmExpr -> SDoc +pprExpr9 platform e = case e of - CmmLit lit -> pprLit1 lit - CmmLoad expr rep -> ppr rep <> brackets( ppr expr ) + CmmLit lit -> pprLit1 platform lit + CmmLoad expr rep -> ppr rep <> brackets (pprPlatform platform expr) CmmReg reg -> ppr reg CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off) CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off) - CmmMachOp mop args -> genMachOp mop args + CmmMachOp mop args -> genMachOp platform mop args -genMachOp :: MachOp -> [CmmExpr] -> SDoc -genMachOp mop args +genMachOp :: Platform -> MachOp -> [CmmExpr] -> SDoc +genMachOp platform mop args | Just doc <- infixMachOp mop = case args of -- dyadic - [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y + [x,y] -> pprExpr9 platform x <+> doc <+> pprExpr9 platform y -- unary - [x] -> doc <> pprExpr9 x + [x] -> doc <> pprExpr9 platform x _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args" (pprMachOp mop <+> - parens (hcat $ punctuate comma (map pprExpr args))) + parens (hcat $ punctuate comma (map (pprExpr platform) args))) empty | isJust (infixMachOp1 mop) || isJust (infixMachOp7 mop) - || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args)) + || isJust (infixMachOp8 mop) = parens (pprExpr platform (CmmMachOp mop args)) - | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args)) + | otherwise = char '%' <> ppr_op <> parens (commafy (map (pprExpr platform) args)) where ppr_op = text (map (\c -> if c == ' ' then '_' else c) (show mop)) -- replace spaces in (show mop) with underscores, @@ -185,24 +188,24 @@ infixMachOp mop -- To minimise line noise we adopt the convention that if the literal -- has the natural machine word size, we do not append the type -- -pprLit :: CmmLit -> SDoc -pprLit lit = case lit of +pprLit :: Platform -> CmmLit -> SDoc +pprLit platform lit = case lit of CmmInt i rep -> hcat [ (if i < 0 then parens else id)(integer i) , ppUnless (rep == wordWidth) $ space <> dcolon <+> ppr rep ] CmmFloat f rep -> hsep [ double (fromRat f), dcolon, ppr rep ] - CmmLabel clbl -> pprCLabel clbl - CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i - CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-' - <> pprCLabel clbl2 <> ppr_offset i + CmmLabel clbl -> pprCLabel platform clbl + CmmLabelOff clbl i -> pprCLabel platform clbl <> ppr_offset i + CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel platform clbl1 <> char '-' + <> pprCLabel platform clbl2 <> ppr_offset i CmmBlock id -> ppr id CmmHighStackMark -> text "<highSp>" -pprLit1 :: CmmLit -> SDoc -pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit) -pprLit1 lit = pprLit lit +pprLit1 :: Platform -> CmmLit -> SDoc +pprLit1 platform lit@(CmmLabelOff {}) = parens (pprLit platform lit) +pprLit1 platform lit = pprLit platform lit ppr_offset :: Int -> SDoc ppr_offset i diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs index d8675c53df..3cccbef310 100644 --- a/compiler/codeGen/CgBindery.lhs +++ b/compiler/codeGen/CgBindery.lhs @@ -148,9 +148,10 @@ data StableLoc \end{code} \begin{code} -instance Outputable CgIdInfo where - ppr (CgIdInfo id _ vol stb _ _) -- TODO, pretty pring the tag info - = ppr id <+> ptext (sLit "-->") <+> vcat [ppr vol, ppr stb] +instance PlatformOutputable CgIdInfo where + pprPlatform platform (CgIdInfo id _ vol stb _ _) + -- TODO, pretty pring the tag info + = ppr id <+> ptext (sLit "-->") <+> vcat [ppr vol, pprPlatform platform stb] instance Outputable VolatileLoc where ppr NoVolatileLoc = empty @@ -158,12 +159,12 @@ instance Outputable VolatileLoc where ppr (VirHpLoc v) = ptext (sLit "vh") <+> ppr v ppr (VirNodeLoc v) = ptext (sLit "vn") <+> ppr v -instance Outputable StableLoc where - ppr NoStableLoc = empty - ppr VoidLoc = ptext (sLit "void") - ppr (VirStkLoc v) = ptext (sLit "vs") <+> ppr v - ppr (VirStkLNE v) = ptext (sLit "lne") <+> ppr v - ppr (StableLoc a) = ptext (sLit "amode") <+> ppr a +instance PlatformOutputable StableLoc where + pprPlatform _ NoStableLoc = empty + pprPlatform _ VoidLoc = ptext (sLit "void") + pprPlatform _ (VirStkLoc v) = ptext (sLit "vs") <+> ppr v + pprPlatform _ (VirStkLNE v) = ptext (sLit "lne") <+> ppr v + pprPlatform platform (StableLoc a) = ptext (sLit "amode") <+> pprPlatform platform a \end{code} %************************************************************************ diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs index 889b1db752..a675c5625c 100644 --- a/compiler/codeGen/CgCon.lhs +++ b/compiler/codeGen/CgCon.lhs @@ -47,6 +47,7 @@ import Outputable import ListSetOps import Util import Module +import DynFlags import FastString import StaticFlags \end{code} @@ -64,7 +65,7 @@ cgTopRhsCon :: Id -- Name of thing bound to this RHS -> [StgArg] -- Args -> FCode (Id, CgIdInfo) cgTopRhsCon id con args - = do { + = do { dflags <- getDynFlags #if mingw32_TARGET_OS -- Windows DLLs have a problem with static cross-DLL refs. ; this_pkg <- getThisPackage @@ -76,6 +77,7 @@ cgTopRhsCon id con args ; amodes <- getArgAmodes args ; let + platform = targetPlatform dflags name = idName id lf_info = mkConLFInfo con closure_label = mkClosureLabel name $ idCafInfo id @@ -89,7 +91,7 @@ cgTopRhsCon id con args payload = map get_lit amodes_w_offsets get_lit (CmmLit lit, _offset) = lit - get_lit other = pprPanic "CgCon.get_lit" (ppr other) + get_lit other = pprPanic "CgCon.get_lit" (pprPlatform platform other) -- NB1: amodes_w_offsets is sorted into ptrs first, then non-ptrs -- NB2: all the amodes should be Lits! diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index 92db95eba8..305081d680 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -38,6 +38,7 @@ import Unique import StaticFlags import Constants +import DynFlags import Util import Outputable @@ -160,6 +161,8 @@ is not present in the list (it is always assumed). -} mkStackLayout :: FCode [Maybe LocalReg] mkStackLayout = do + dflags <- getDynFlags + let platform = targetPlatform dflags StackUsage { realSp = real_sp, frameSp = frame_sp } <- getStkUsage binds <- getLiveStackBindings @@ -169,7 +172,7 @@ mkStackLayout = do | (offset, b) <- binds] WARN( not (all (\bind -> fst bind >= 0) rel_binds), - ppr binds $$ ppr rel_binds $$ + pprPlatform platform binds $$ pprPlatform platform rel_binds $$ ppr frame_size $$ ppr real_sp $$ ppr frame_sp ) return $ stack_layout rel_binds frame_size diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index f34fdb80be..1bf9366f50 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -396,7 +396,9 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details do { -- Allocate the global ticky counter, -- and establish the ticky-counter -- label for this block - ; let ticky_ctr_lbl = closureRednCountsLabel cl_info + ; dflags <- getDynFlags + ; let platform = targetPlatform dflags + ticky_ctr_lbl = closureRednCountsLabel platform cl_info ; emitTickyCounter cl_info (map stripNV args) ; setTickyCtrLabel ticky_ctr_lbl $ do @@ -454,14 +456,16 @@ mkSlowEntryCode :: ClosureInfo -> [LocalReg] -> FCode () mkSlowEntryCode _ [] = panic "entering a closure with no arguments?" mkSlowEntryCode cl_info arg_regs -- function closure is already in `Node' | Just (_, ArgGen _) <- closureFunInfo cl_info - = emitProcWithConvention Slow CmmNonInfoTable slow_lbl arg_regs jump + = do dflags <- getDynFlags + let platform = targetPlatform dflags + slow_lbl = closureSlowEntryLabel platform cl_info + fast_lbl = closureLocalEntryLabel platform cl_info + -- mkDirectJump does not clobber `Node' containing function closure + jump = mkDirectJump (mkLblExpr fast_lbl) + (map (CmmReg . CmmLocal) arg_regs) + initUpdFrameOff + emitProcWithConvention Slow CmmNonInfoTable slow_lbl arg_regs jump | otherwise = return () - where - slow_lbl = closureSlowEntryLabel cl_info - fast_lbl = closureLocalEntryLabel cl_info - -- mkDirectJump does not clobber `Node' containing function closure - jump = mkDirectJump (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) arg_regs) - initUpdFrameOff ----------------------------------------- thunkCode :: ClosureInfo -> [(NonVoid Id, VirtualHpOffset)] -> CostCentreStack diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index 712263a156..ede24a5c6f 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -80,6 +80,7 @@ import TcType import TyCon import BasicTypes import Outputable +import Platform import Constants import DynFlags @@ -757,19 +758,19 @@ isToplevClosure (ClosureInfo { closureLFInfo = lf_info }) -- Label generation -------------------------------------- -staticClosureLabel :: ClosureInfo -> CLabel -staticClosureLabel = toClosureLbl . closureInfoLabel +staticClosureLabel :: Platform -> ClosureInfo -> CLabel +staticClosureLabel platform = toClosureLbl platform . closureInfoLabel -closureRednCountsLabel :: ClosureInfo -> CLabel -closureRednCountsLabel = toRednCountsLbl . closureInfoLabel +closureRednCountsLabel :: Platform -> ClosureInfo -> CLabel +closureRednCountsLabel platform = toRednCountsLbl platform . closureInfoLabel -closureSlowEntryLabel :: ClosureInfo -> CLabel -closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel +closureSlowEntryLabel :: Platform -> ClosureInfo -> CLabel +closureSlowEntryLabel platform = toSlowEntryLbl platform . closureInfoLabel -closureLocalEntryLabel :: ClosureInfo -> CLabel -closureLocalEntryLabel - | tablesNextToCode = toInfoLbl . closureInfoLabel - | otherwise = toEntryLbl . closureInfoLabel +closureLocalEntryLabel :: Platform -> ClosureInfo -> CLabel +closureLocalEntryLabel platform + | tablesNextToCode = toInfoLbl platform . closureInfoLabel + | otherwise = toEntryLbl platform . closureInfoLabel mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel mkClosureInfoTableLabel id lf_info diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs index 587601f226..4542922675 100644 --- a/compiler/codeGen/StgCmmEnv.hs +++ b/compiler/codeGen/StgCmmEnv.hs @@ -44,6 +44,7 @@ import VarEnv import Control.Monad import Name import StgSyn +import DynFlags import Outputable ------------------------------------- @@ -174,7 +175,8 @@ getCgIdInfo id cgLookupPanic :: Id -> FCode a cgLookupPanic id - = do static_binds <- getStaticBinds + = do dflags <- getDynFlags + static_binds <- getStaticBinds local_binds <- getBinds srt <- getSRTLabel pprPanic "StgCmmEnv: variable not found" @@ -183,7 +185,7 @@ cgLookupPanic id vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ], ptext (sLit "local binds for:"), vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ], - ptext (sLit "SRT label") <+> pprCLabel srt + ptext (sLit "SRT label") <+> pprCLabel (targetPlatform dflags) srt ]) diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index 407a99e571..857fd38e27 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -43,6 +43,7 @@ import IdInfo( CafInfo(..), mayHaveCafRefs ) import Module import FastString( mkFastString, fsLit ) import Constants +import DynFlags ----------------------------------------------------------- -- Initialise dynamic heap objects @@ -332,35 +333,38 @@ entryHeapCheck :: ClosureInfo -> FCode () entryHeapCheck cl_info offset nodeSet arity args code - = do updfr_sz <- getUpdFrameOff + = do dflags <- getDynFlags + + let platform = targetPlatform dflags + + is_thunk = arity == 0 + is_fastf = case closureFunInfo cl_info of + Just (_, ArgGen _) -> False + _otherwise -> True + + args' = map (CmmReg . CmmLocal) args + setN = case nodeSet of + Just n -> mkAssign nodeReg (CmmReg $ CmmLocal n) + Nothing -> mkAssign nodeReg $ + CmmLit (CmmLabel $ staticClosureLabel platform cl_info) + + {- Thunks: Set R1 = node, jump GCEnter1 + Function (fast): Set R1 = node, jump GCFun + Function (slow): Set R1 = node, call generic_gc -} + gc_call upd = setN <*> gc_lbl upd + gc_lbl upd + | is_thunk = mkDirectJump (CmmReg $ CmmGlobal GCEnter1) [] sp + | is_fastf = mkDirectJump (CmmReg $ CmmGlobal GCFun) [] sp + | otherwise = mkForeignJump Slow (CmmReg $ CmmGlobal GCFun) args' upd + where sp = max offset upd + {- DT (12/08/10) This is a little fishy, mainly the sp fix up amount. + - This is since the ncg inserts spills before the stack/heap check. + - This should be fixed up and then we won't need to fix up the Sp on + - GC calls, but until then this fishy code works -} + + updfr_sz <- getUpdFrameOff heapCheck True (gc_call updfr_sz) code - where - is_thunk = arity == 0 - is_fastf = case closureFunInfo cl_info of - Just (_, ArgGen _) -> False - _otherwise -> True - - args' = map (CmmReg . CmmLocal) args - setN = case nodeSet of - Just n -> mkAssign nodeReg (CmmReg $ CmmLocal n) - Nothing -> mkAssign nodeReg $ - CmmLit (CmmLabel $ staticClosureLabel cl_info) - - {- Thunks: Set R1 = node, jump GCEnter1 - Function (fast): Set R1 = node, jump GCFun - Function (slow): Set R1 = node, call generic_gc -} - gc_call upd = setN <*> gc_lbl upd - gc_lbl upd - | is_thunk = mkDirectJump (CmmReg $ CmmGlobal GCEnter1) [] sp - | is_fastf = mkDirectJump (CmmReg $ CmmGlobal GCFun) [] sp - | otherwise = mkForeignJump Slow (CmmReg $ CmmGlobal GCFun) args' upd - where sp = max offset upd - {- DT (12/08/10) This is a little fishy, mainly the sp fix up amount. - - This is since the ncg inserts spills before the stack/heap check. - - This should be fixed up and then we won't need to fix up the Sp on - - GC calls, but until then this fishy code works -} - {- -- This code is slightly outdated now and we could easily keep the above -- GC methods. However, there may be some performance gains to be made by diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 58d858f729..f8137dc564 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -44,6 +44,7 @@ import Id import Name import TyCon ( PrimRep(..) ) import BasicTypes ( Arity ) +import DynFlags import StaticFlags import Constants @@ -142,9 +143,12 @@ direct_call :: String -> CLabel -> Arity -> [CmmExpr] -> [ArgRep] -> FCode () -- NB2: 'arity' refers to the *reps* direct_call caller lbl arity args reps | debugIsOn && arity > length reps -- Too few args - = -- Caller should ensure that there enough args! - pprPanic "direct_call" (text caller <+> ppr arity <+> ppr lbl <+> ppr (length reps) - <+> ppr args <+> ppr reps ) + = do -- Caller should ensure that there enough args! + dflags <- getDynFlags + let platform = targetPlatform dflags + pprPanic "direct_call" (text caller <+> ppr arity + <+> pprPlatform platform lbl <+> ppr (length reps) + <+> pprPlatform platform args <+> ppr reps ) | null rest_reps -- Precisely the right number of arguments = emitCall (NativeDirectCall, NativeReturn) target args @@ -165,8 +169,10 @@ direct_call caller lbl arity args reps -------------- slow_call :: CmmExpr -> [CmmExpr] -> [ArgRep] -> FCode () slow_call fun args reps - = do call <- getCode $ direct_call "slow_call" (mkRtsApFastLabel rts_fun) arity args reps - emit $ mkComment $ mkFastString ("slow_call for " ++ showSDoc (ppr fun) ++ + = do dflags <- getDynFlags + let platform = targetPlatform dflags + call <- getCode $ direct_call "slow_call" (mkRtsApFastLabel rts_fun) arity args reps + emit $ mkComment $ mkFastString ("slow_call for " ++ showSDoc (pprPlatform platform fun) ++ " with pat " ++ showSDoc (ftext rts_fun)) emit (mkAssign nodeReg fun <*> call) where @@ -395,8 +401,9 @@ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body emitClosureAndInfoTable :: CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode () emitClosureAndInfoTable info_tbl conv args body - = do { blks <- getCode body - ; let entry_lbl = toEntryLbl (cit_lbl info_tbl) + = do { dflags <- getDynFlags + ; blks <- getCode body + ; let entry_lbl = toEntryLbl (targetPlatform dflags) (cit_lbl info_tbl) ; emitProcWithConvention conv info_tbl entry_lbl args blks } diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 7ea2183ef2..7263f751c3 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -190,13 +190,13 @@ data CgLoc -- To tail-call it, assign to these locals, -- and branch to the block id -instance Outputable CgIdInfo where - ppr (CgIdInfo { cg_id = id, cg_loc = loc }) - = ppr id <+> ptext (sLit "-->") <+> ppr loc +instance PlatformOutputable CgIdInfo where + pprPlatform platform (CgIdInfo { cg_id = id, cg_loc = loc }) + = ppr id <+> ptext (sLit "-->") <+> pprPlatform platform loc -instance Outputable CgLoc where - ppr (CmmLoc e) = ptext (sLit "cmm") <+> ppr e - ppr (LneLoc b rs) = ptext (sLit "lne") <+> ppr b <+> ppr rs +instance PlatformOutputable CgLoc where + pprPlatform platform (CmmLoc e) = ptext (sLit "cmm") <+> pprPlatform platform e + pprPlatform _ (LneLoc b rs) = ptext (sLit "lne") <+> ppr b <+> ppr rs -- Sequel tells what to do with the result of this expression diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index 1224ad1d5a..88ff1389dd 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -88,7 +88,12 @@ staticTickyHdr = [] emitTickyCounter :: ClosureInfo -> [Id] -> FCode () emitTickyCounter cl_info args = ifTicky $ - do { mod_name <- getModuleName + do { dflags <- getDynFlags + ; mod_name <- getModuleName + ; let platform = targetPlatform dflags + ticky_ctr_label = closureRednCountsLabel platform cl_info + arg_descr = map (showTypeCategory . idType) args + fun_descr mod_name = ppr_for_ticky_name mod_name (closureName cl_info) ; fun_descr_lit <- newStringCLit (fun_descr mod_name) ; arg_descr_lit <- newStringCLit arg_descr ; emitDataLits ticky_ctr_label -- Must match layout of StgEntCounter @@ -104,10 +109,6 @@ emitTickyCounter cl_info args zeroCLit, -- Allocs zeroCLit -- Link ] } - where - ticky_ctr_label = closureRednCountsLabel cl_info - arg_descr = map (showTypeCategory . idType) args - fun_descr mod_name = ppr_for_ticky_name mod_name (closureName cl_info) -- When printing the name of a thing in a ticky file, we want to -- give the module name even for *local* things. We print diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 6f2e08afff..abb8948de6 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -21,6 +21,7 @@ import VarSet import Data.List import FastString import HscTypes +import Platform import StaticFlags import TyCon import MonadUtils @@ -895,9 +896,9 @@ static void hpc_init_Main(void) hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);} \begin{code} -hpcInitCode :: Module -> HpcInfo -> SDoc -hpcInitCode _ (NoHpcInfo {}) = empty -hpcInitCode this_mod (HpcInfo tickCount hashNo) +hpcInitCode :: Platform -> Module -> HpcInfo -> SDoc +hpcInitCode _ _ (NoHpcInfo {}) = empty +hpcInitCode platform this_mod (HpcInfo tickCount hashNo) = vcat [ text "static void hpc_init_" <> ppr this_mod <> text "(void) __attribute__((constructor));" @@ -915,7 +916,7 @@ hpcInitCode this_mod (HpcInfo tickCount hashNo) ]) ] where - tickboxes = pprCLabel (mkHpcTicksLabel $ this_mod) + tickboxes = pprCLabel platform (mkHpcTicksLabel $ this_mod) module_name = hcat (map (text.charToC) $ bytesFS (moduleNameFS (Module.moduleName this_mod))) diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index d85ff0a8df..636677a86f 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -81,7 +81,8 @@ deSugar hsc_env tcg_fam_insts = fam_insts, tcg_hpc = other_hpc_info }) - = do { let dflags = hsc_dflags hsc_env + = do { let dflags = hsc_dflags hsc_env + platform = targetPlatform dflags ; showPass dflags "Desugar" -- Desugar the program @@ -109,7 +110,7 @@ deSugar hsc_env ; ds_rules <- mapMaybeM dsRule rules ; ds_vects <- mapM dsVect vects ; let hpc_init - | opt_Hpc = hpcInitCode mod ds_hpc_info + | opt_Hpc = hpcInitCode platform mod ds_hpc_info | otherwise = empty ; return ( ds_ev_binds , foreign_prs `appOL` core_prs `appOL` spec_prs diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index 5622221713..53b859103c 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -36,10 +36,10 @@ import System.IO llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmmGroup] -> IO () llvmCodeGen dflags h us cmms = let cmm = concat cmms - (cdata,env) = foldr split ([],initLlvmEnv) cmm + (cdata,env) = foldr split ([],initLlvmEnv (targetPlatform dflags)) cmm split (CmmData s d' ) (d,e) = ((s,d'):d,e) split (CmmProc i l _) (d,e) = - let lbl = strCLabel_llvm $ case i of + let lbl = strCLabel_llvm env $ case i of Nothing -> l Just (Statics info_lbl _) -> info_lbl env' = funInsert lbl llvmFunTy e @@ -69,8 +69,8 @@ cmmDataLlvmGens dflags h env [] lmdata return env' cmmDataLlvmGens dflags h env (cmm:cmms) lmdata - = let lmdata'@(l, _, ty, _) = genLlvmData cmm - env' = funInsert (strCLabel_llvm l) ty env + = let lmdata'@(l, _, ty, _) = genLlvmData env cmm + env' = funInsert (strCLabel_llvm env l) ty env in cmmDataLlvmGens dflags h env' cmms (lmdata ++ [lmdata']) diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index c41ced8b76..f075aaa362 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -12,7 +12,7 @@ module LlvmCodeGen.Base ( LlvmVersion, defaultLlvmVersion, LlvmEnv, initLlvmEnv, clearVars, varLookup, varInsert, - funLookup, funInsert, getLlvmVer, setLlvmVer, + funLookup, funInsert, getLlvmVer, setLlvmVer, getLlvmPlatform, cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy, llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign, @@ -34,6 +34,7 @@ import Constants import FastString import OldCmm import qualified Outputable as Outp +import Platform import UniqFM import Unique @@ -89,8 +90,8 @@ llvmFunTy :: LlvmType llvmFunTy = LMFunction $ llvmFunSig' (fsLit "a") ExternallyVisible -- | Llvm Function signature -llvmFunSig :: CLabel -> LlvmLinkageType -> LlvmFunctionDecl -llvmFunSig lbl link = llvmFunSig' (strCLabel_llvm lbl) link +llvmFunSig :: LlvmEnv -> CLabel -> LlvmLinkageType -> LlvmFunctionDecl +llvmFunSig env lbl link = llvmFunSig' (strCLabel_llvm env lbl) link llvmFunSig' :: LMString -> LlvmLinkageType -> LlvmFunctionDecl llvmFunSig' lbl link @@ -100,10 +101,10 @@ llvmFunSig' lbl link (map (toParams . getVarType) llvmFunArgs) llvmFunAlign -- | Create a Haskell function in LLVM. -mkLlvmFunc :: CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks +mkLlvmFunc :: LlvmEnv -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks -> LlvmFunction -mkLlvmFunc lbl link sec blks - = let funDec = llvmFunSig lbl link +mkLlvmFunc env lbl link sec blks + = let funDec = llvmFunSig env lbl link funArgs = map (fsLit . getPlainName) llvmFunArgs in LlvmFunction funDec funArgs llvmStdFunAttrs sec blks @@ -148,46 +149,51 @@ defaultLlvmVersion = 28 -- -- two maps, one for functions and one for local vars. -newtype LlvmEnv = LlvmEnv (LlvmEnvMap, LlvmEnvMap, LlvmVersion) +newtype LlvmEnv = LlvmEnv (LlvmEnvMap, LlvmEnvMap, LlvmVersion, Platform) type LlvmEnvMap = UniqFM LlvmType -- | Get initial Llvm environment. -initLlvmEnv :: LlvmEnv -initLlvmEnv = LlvmEnv (emptyUFM, emptyUFM, defaultLlvmVersion) +initLlvmEnv :: Platform -> LlvmEnv +initLlvmEnv platform = LlvmEnv (emptyUFM, emptyUFM, defaultLlvmVersion, platform) -- | Clear variables from the environment. clearVars :: LlvmEnv -> LlvmEnv -clearVars (LlvmEnv (e1, _, n)) = LlvmEnv (e1, emptyUFM, n) +clearVars (LlvmEnv (e1, _, n, p)) = LlvmEnv (e1, emptyUFM, n, p) -- | Insert functions into the environment. varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv -varInsert s t (LlvmEnv (e1, e2, n)) = LlvmEnv (e1, addToUFM e2 s t, n) -funInsert s t (LlvmEnv (e1, e2, n)) = LlvmEnv (addToUFM e1 s t, e2, n) +varInsert s t (LlvmEnv (e1, e2, n, p)) = LlvmEnv (e1, addToUFM e2 s t, n, p) +funInsert s t (LlvmEnv (e1, e2, n, p)) = LlvmEnv (addToUFM e1 s t, e2, n, p) -- | Lookup functions in the environment. varLookup, funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType -varLookup s (LlvmEnv (_, e2, _)) = lookupUFM e2 s -funLookup s (LlvmEnv (e1, _, _)) = lookupUFM e1 s +varLookup s (LlvmEnv (_, e2, _, _)) = lookupUFM e2 s +funLookup s (LlvmEnv (e1, _, _, _)) = lookupUFM e1 s -- | Get the LLVM version we are generating code for getLlvmVer :: LlvmEnv -> LlvmVersion -getLlvmVer (LlvmEnv (_, _, n)) = n +getLlvmVer (LlvmEnv (_, _, n, _)) = n -- | Set the LLVM version we are generating code for setLlvmVer :: LlvmVersion -> LlvmEnv -> LlvmEnv -setLlvmVer n (LlvmEnv (e1, e2, _)) = LlvmEnv (e1, e2, n) +setLlvmVer n (LlvmEnv (e1, e2, _, p)) = LlvmEnv (e1, e2, n, p) + +-- | Get the platform we are generating code for +getLlvmPlatform :: LlvmEnv -> Platform +getLlvmPlatform (LlvmEnv (_, _, _, p)) = p -- ---------------------------------------------------------------------------- -- * Label handling -- -- | Pretty print a 'CLabel'. -strCLabel_llvm :: CLabel -> LMString -strCLabel_llvm l = (fsLit . show . llvmSDoc . pprCLabel) l +strCLabel_llvm :: LlvmEnv -> CLabel -> LMString +strCLabel_llvm env l + = (fsLit . show . llvmSDoc . pprCLabel (getLlvmPlatform env)) l -- | Create an external definition for a 'CLabel' defined in another module. -genCmmLabelRef :: CLabel -> LMGlobal -genCmmLabelRef = genStringLabelRef . strCLabel_llvm +genCmmLabelRef :: LlvmEnv -> CLabel -> LMGlobal +genCmmLabelRef env = genStringLabelRef . strCLabel_llvm env -- | As above ('genCmmLabelRef') but taking a 'LMString', not 'CLabel'. genStringLabelRef :: LMString -> LMGlobal diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index a5f8160d42..09ccf72fb6 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -313,7 +313,7 @@ genCall env target res args ret = do getFunPtr :: LlvmEnv -> (LMString -> LlvmType) -> CmmCallTarget -> UniqSM ExprData getFunPtr env funTy targ = case targ of - CmmCallee (CmmLit (CmmLabel lbl)) _ -> litCase $ strCLabel_llvm lbl + CmmCallee (CmmLit (CmmLabel lbl)) _ -> litCase $ strCLabel_llvm env lbl CmmCallee expr _ -> do (env', v1, stmts, top) <- exprToVar env expr @@ -614,7 +614,7 @@ genStore_slow env addr val = do other -> pprPanic "genStore: ptr not right type!" - (PprCmm.pprExpr addr <+> text ( + (PprCmm.pprExpr (getLlvmPlatform env) addr <+> text ( "Size of Ptr: " ++ show llvmPtrBits ++ ", Size of var: " ++ show (llvmWidthInBits other) ++ ", Var: " ++ show vaddr)) @@ -880,7 +880,7 @@ genMachOp_slow env opt op [x, y] = case op of else do -- XXX: Error. Continue anyway so we can debug the generated -- ll file. - let cmmToStr = (lines . show . llvmSDoc . PprCmm.pprExpr) + let cmmToStr = (lines . show . llvmSDoc . PprCmm.pprExpr (getLlvmPlatform env)) let dx = Comment $ map fsLit $ cmmToStr x let dy = Comment $ map fsLit $ cmmToStr y (v1, s1) <- doExpr (ty vx) $ binOp vx vy @@ -894,8 +894,8 @@ genMachOp_slow env opt op [x, y] = case op of -- _ -> "unknown" -- panic $ "genMachOp: comparison between different types (" -- ++ o ++ " "++ show vx ++ ", " ++ show vy ++ ")" - -- ++ "\ne1: " ++ (show.llvmSDoc.PprCmm.pprExpr $ x) - -- ++ "\ne2: " ++ (show.llvmSDoc.PprCmm.pprExpr $ y) + -- ++ "\ne1: " ++ (show.llvmSDoc.PprCmm.pprExpr (getLlvmPlatform env) $ x) + -- ++ "\ne2: " ++ (show.llvmSDoc.PprCmm.pprExpr (getLlvmPlatform env) $ y) -- | Need to use EOption here as Cmm expects word size results from -- comparisons while LLVM return i1. Need to extend to llvmWord type @@ -1042,7 +1042,7 @@ genLoad_slow env e ty = do return (env', dvar, stmts `snocOL` cast `snocOL` load, tops) other -> pprPanic "exprToVar: CmmLoad expression is not right type!" - (PprCmm.pprExpr e <+> text ( + (PprCmm.pprExpr (getLlvmPlatform env) e <+> text ( "Size of Ptr: " ++ show llvmPtrBits ++ ", Size of var: " ++ show (llvmWidthInBits other) ++ ", Var: " ++ show iptr)) @@ -1088,7 +1088,7 @@ genLit env (CmmFloat r w) nilOL, []) genLit env cmm@(CmmLabel l) - = let label = strCLabel_llvm l + = let label = strCLabel_llvm env l ty = funLookup label env lmty = cmmToLlvmType $ cmmLitType cmm in case ty of @@ -1193,7 +1193,7 @@ trashStmts = concatOL $ map trashReg activeStgRegs -- with foreign functions. getHsFunc :: LlvmEnv -> CLabel -> UniqSM ExprData getHsFunc env lbl - = let fn = strCLabel_llvm lbl + = let fn = strCLabel_llvm env lbl ty = funLookup fn env in case ty of -- Function in module in right form @@ -1211,7 +1211,7 @@ getHsFunc env lbl -- label not in module, create external reference Nothing -> do - let ty' = LMFunction $ llvmFunSig lbl ExternallyVisible + let ty' = LMFunction $ llvmFunSig env lbl ExternallyVisible let fun = LMGlobalVar fn ty' ExternallyVisible Nothing Nothing False let top = CmmData Data [([],[ty'])] let env' = funInsert fn ty' env diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs index ef86abfd6f..c773e1c009 100644 --- a/compiler/llvmGen/LlvmCodeGen/Data.hs +++ b/compiler/llvmGen/LlvmCodeGen/Data.hs @@ -37,10 +37,10 @@ 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, CmmStatics) -> LlvmUnresData -genLlvmData (sec, Statics lbl xs) = +genLlvmData :: LlvmEnv -> (Section, CmmStatics) -> LlvmUnresData +genLlvmData env (sec, Statics lbl xs) = let static = map genData xs - label = strCLabel_llvm lbl + label = strCLabel_llvm env lbl types = map getStatTypes static getStatTypes (Left x) = cmmToLlvmType $ cmmLitType x @@ -66,7 +66,7 @@ resolveLlvmData env (lbl, sec, alias, unres) = let (env', static, refs) = resDatas env unres ([], []) refs' = catMaybes refs struct = Just $ LMStaticStruc static alias - label = strCLabel_llvm lbl + label = strCLabel_llvm env lbl link = if (externallyVisibleCLabel lbl) then ExternallyVisible else Internal const = isSecConstant sec @@ -111,7 +111,7 @@ resData :: LlvmEnv -> UnresStatic -> (LlvmEnv, LlvmStatic, [Maybe LMGlobal]) resData env (Right stat) = (env, stat, [Nothing]) resData env (Left cmm@(CmmLabel l)) = - let label = strCLabel_llvm l + let label = strCLabel_llvm env l ty = funLookup label env lmty = cmmToLlvmType $ cmmLitType cmm in case ty of diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index 8f585ca3d5..82092ef9e4 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -104,7 +104,7 @@ pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl (ListGraph blks)) else Internal lmblocks = map (\(BasicBlock id stmts) -> LlvmBlock (getUnique id) stmts) blks - fun = mkLlvmFunc lbl' link sec' lmblocks + fun = mkLlvmFunc env lbl' link sec' lmblocks in ppLlvmFunction fun ), ivar) @@ -112,12 +112,12 @@ pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl (ListGraph blks)) -- | Pretty print CmmStatic pprInfoTable :: LlvmEnv -> Int -> CLabel -> CmmStatics -> (Doc, [LlvmVar]) pprInfoTable env count info_lbl stat - = let unres = genLlvmData (Text, stat) + = let unres = genLlvmData env (Text, stat) (_, (ldata, ltypes)) = resolveLlvmData env unres setSection ((LMGlobalVar _ ty l _ _ c), d) = let sec = mkLayoutSection count - ilabel = strCLabel_llvm info_lbl + ilabel = strCLabel_llvm env 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/HscMain.lhs b/compiler/main/HscMain.lhs index 445a9cacbc..7463da7430 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -1107,7 +1107,7 @@ hscGenHardCode cgguts mod_summary <- {-# SCC "CoreToStg" #-} myCoreToStg dflags this_mod prepd_binds - let prof_init = profilingInitCode this_mod cost_centre_info + let prof_init = profilingInitCode platform this_mod cost_centre_info foreign_stubs = foreign_stubs0 `appendStubC` prof_init ------------------ Code generation ------------------ @@ -1123,7 +1123,7 @@ hscGenHardCode cgguts mod_summary -- unless certain dflags are on, the identity function ------------------ Code output ----------------------- - rawcmms <- cmmToRawCmm cmms + rawcmms <- cmmToRawCmm platform cmms 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 @@ -1175,7 +1175,7 @@ hscCompileCmmFile hsc_env filename let dflags = hsc_dflags hsc_env cmm <- ioMsgMaybe $ parseCmmFile dflags filename liftIO $ do - rawCmms <- cmmToRawCmm [cmm] + rawCmms <- cmmToRawCmm (targetPlatform dflags) [cmm] _ <- codeOutput dflags no_mod no_loc NoStubs [] rawCmms return () where diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 09963c4f7a..09b3bf2ec5 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -150,7 +150,7 @@ data NcgImpl statics instr jumpDest = NcgImpl { -------------------- nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmmGroup] -> IO () nativeCodeGen dflags h us cmms - = let nCG' :: (Outputable statics, PlatformOutputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO () + = let nCG' :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO () nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms x86NcgImpl = NcgImpl { cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen @@ -206,7 +206,7 @@ nativeCodeGen dflags h us cmms ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch" -nativeCodeGen' :: (Outputable statics, PlatformOutputable instr, Instruction instr) +nativeCodeGen' :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) => DynFlags -> NcgImpl statics instr jumpDest -> Handle -> UniqSupply -> [RawCmmGroup] -> IO () @@ -273,7 +273,7 @@ nativeCodeGen' dflags ncgImpl h us cmms -- | Do native code generation on all these cmms. -- -cmmNativeGens :: (Outputable statics, PlatformOutputable instr, Instruction instr) +cmmNativeGens :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) => DynFlags -> NcgImpl statics instr jumpDest -> BufHandle @@ -294,11 +294,13 @@ cmmNativeGens _ _ _ _ [] impAcc profAcc _ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count = do + let platform = targetPlatform dflags + (us', native, imports, colorStats, linearStats) <- cmmNativeGen dflags ncgImpl us cmm count Pretty.bufLeftRender h - $ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map (pprNatCmmDecl ncgImpl (targetPlatform dflags)) native + $ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map (pprNatCmmDecl ncgImpl platform) native -- carefully evaluate this strictly. Binding it with 'let' -- and then using 'seq' doesn't work, because the let @@ -312,7 +314,7 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count count' <- return $! count + 1; -- force evaulation all this stuff to avoid space leaks - seqString (showSDoc $ vcat $ map ppr imports) `seq` return () + seqString (showSDoc $ vcat $ map (pprPlatform platform) imports) `seq` return () cmmNativeGens dflags ncgImpl h us' cmms @@ -328,7 +330,7 @@ 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 - :: (Outputable statics, PlatformOutputable instr, Instruction instr) + :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) => DynFlags -> NcgImpl statics instr jumpDest -> UniqSupply @@ -528,8 +530,9 @@ makeImportsDoc dflags imports {- dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $ map head $ group $ sort imps-} - arch = platformArch $ targetPlatform dflags - os = platformOS $ targetPlatform dflags + platform = targetPlatform dflags + arch = platformArch platform + os = platformOS platform -- (Hack) sometimes two Labels pretty-print the same, but have -- different uniques; so we compare their text versions... @@ -537,7 +540,7 @@ makeImportsDoc dflags imports | needImportedSymbols arch os = Pretty.vcat $ (pprGotDeclaration arch os :) $ - map ( pprImportedSymbol arch os . fst . head) $ + map ( pprImportedSymbol platform . fst . head) $ groupBy (\(_,a) (_,b) -> a == b) $ sortBy (\(_,a) (_,b) -> compare a b) $ map doPpr $ @@ -545,7 +548,7 @@ makeImportsDoc dflags imports | otherwise = Pretty.empty - doPpr lbl = (lbl, renderWithStyle (pprCLabel lbl) astyle) + doPpr lbl = (lbl, renderWithStyle (pprCLabel platform lbl) astyle) astyle = mkCodeStyle AsmStyle @@ -879,10 +882,12 @@ cmmStmtConFold stmt CmmCondBranch test dest -> do test' <- cmmExprConFold DataReference test + dflags <- getDynFlagsCmmOpt + let platform = targetPlatform dflags return $ case test' of CmmLit (CmmInt 0 _) -> CmmComment (mkFastString ("deleted: " ++ - showSDoc (pprStmt stmt))) + showSDoc (pprStmt platform stmt))) CmmLit (CmmInt _ _) -> CmmBranch dest _other -> CmmCondBranch test' dest diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs index 2762e4ff25..da83678095 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -427,9 +427,9 @@ asmSDoc d = Outputable.withPprStyleDoc (Outputable.mkCodeStyle Outputable.AsmStyle) d -pprCLabel_asm :: CLabel -> Doc -pprCLabel_asm l - = asmSDoc (pprCLabel l) +pprCLabel_asm :: Platform -> CLabel -> Doc +pprCLabel_asm platform l + = asmSDoc (pprCLabel platform l) needImportedSymbols :: Arch -> OS -> Bool @@ -509,21 +509,21 @@ pprGotDeclaration _ _ -- Whenever you change something in this assembler output, make sure -- the splitter in driver/split/ghc-split.lprl recognizes the new output -pprImportedSymbol :: Arch -> OS -> CLabel -> Doc -pprImportedSymbol ArchPPC OSDarwin importedLbl +pprImportedSymbol :: Platform -> CLabel -> Doc +pprImportedSymbol platform@(Platform ArchPPC OSDarwin) importedLbl | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl = case opt_PIC of False -> vcat [ ptext (sLit ".symbol_stub"), - ptext (sLit "L") <> pprCLabel_asm lbl <> ptext (sLit "$stub:"), - ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm lbl, - ptext (sLit "\tlis r11,ha16(L") <> pprCLabel_asm lbl + ptext (sLit "L") <> pprCLabel_asm platform lbl <> ptext (sLit "$stub:"), + ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm platform lbl, + ptext (sLit "\tlis r11,ha16(L") <> pprCLabel_asm platform lbl <> ptext (sLit "$lazy_ptr)"), - ptext (sLit "\tlwz r12,lo16(L") <> pprCLabel_asm lbl + ptext (sLit "\tlwz r12,lo16(L") <> pprCLabel_asm platform lbl <> ptext (sLit "$lazy_ptr)(r11)"), ptext (sLit "\tmtctr r12"), - ptext (sLit "\taddi r11,r11,lo16(L") <> pprCLabel_asm lbl + ptext (sLit "\taddi r11,r11,lo16(L") <> pprCLabel_asm platform lbl <> ptext (sLit "$lazy_ptr)"), ptext (sLit "\tbctr") ] @@ -532,51 +532,51 @@ pprImportedSymbol ArchPPC OSDarwin importedLbl ptext (sLit ".section __TEXT,__picsymbolstub1,") <> ptext (sLit "symbol_stubs,pure_instructions,32"), ptext (sLit "\t.align 2"), - ptext (sLit "L") <> pprCLabel_asm lbl <> ptext (sLit "$stub:"), - ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm lbl, + ptext (sLit "L") <> pprCLabel_asm platform lbl <> ptext (sLit "$stub:"), + ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm platform lbl, ptext (sLit "\tmflr r0"), - ptext (sLit "\tbcl 20,31,L0$") <> pprCLabel_asm lbl, - ptext (sLit "L0$") <> pprCLabel_asm lbl <> char ':', + ptext (sLit "\tbcl 20,31,L0$") <> pprCLabel_asm platform lbl, + ptext (sLit "L0$") <> pprCLabel_asm platform lbl <> char ':', ptext (sLit "\tmflr r11"), - ptext (sLit "\taddis r11,r11,ha16(L") <> pprCLabel_asm lbl - <> ptext (sLit "$lazy_ptr-L0$") <> pprCLabel_asm lbl <> char ')', + ptext (sLit "\taddis r11,r11,ha16(L") <> pprCLabel_asm platform lbl + <> ptext (sLit "$lazy_ptr-L0$") <> pprCLabel_asm platform lbl <> char ')', ptext (sLit "\tmtlr r0"), - ptext (sLit "\tlwzu r12,lo16(L") <> pprCLabel_asm lbl - <> ptext (sLit "$lazy_ptr-L0$") <> pprCLabel_asm lbl + ptext (sLit "\tlwzu r12,lo16(L") <> pprCLabel_asm platform lbl + <> ptext (sLit "$lazy_ptr-L0$") <> pprCLabel_asm platform lbl <> ptext (sLit ")(r11)"), ptext (sLit "\tmtctr r12"), ptext (sLit "\tbctr") ] $+$ vcat [ ptext (sLit ".lazy_symbol_pointer"), - ptext (sLit "L") <> pprCLabel_asm lbl <> ptext (sLit "$lazy_ptr:"), - ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm lbl, + ptext (sLit "L") <> pprCLabel_asm platform lbl <> ptext (sLit "$lazy_ptr:"), + ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm platform lbl, ptext (sLit "\t.long dyld_stub_binding_helper")] | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl = vcat [ ptext (sLit ".non_lazy_symbol_pointer"), - char 'L' <> pprCLabel_asm lbl <> ptext (sLit "$non_lazy_ptr:"), - ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm lbl, + char 'L' <> pprCLabel_asm platform lbl <> ptext (sLit "$non_lazy_ptr:"), + ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm platform lbl, ptext (sLit "\t.long\t0")] | otherwise = empty -pprImportedSymbol ArchX86 OSDarwin importedLbl +pprImportedSymbol platform@(Platform ArchX86 OSDarwin) importedLbl | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl = case opt_PIC of False -> vcat [ ptext (sLit ".symbol_stub"), - ptext (sLit "L") <> pprCLabel_asm lbl <> ptext (sLit "$stub:"), - ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm lbl, - ptext (sLit "\tjmp *L") <> pprCLabel_asm lbl + ptext (sLit "L") <> pprCLabel_asm platform lbl <> ptext (sLit "$stub:"), + ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm platform lbl, + ptext (sLit "\tjmp *L") <> pprCLabel_asm platform lbl <> ptext (sLit "$lazy_ptr"), - ptext (sLit "L") <> pprCLabel_asm lbl + ptext (sLit "L") <> pprCLabel_asm platform lbl <> ptext (sLit "$stub_binder:"), - ptext (sLit "\tpushl $L") <> pprCLabel_asm lbl + ptext (sLit "\tpushl $L") <> pprCLabel_asm platform lbl <> ptext (sLit "$lazy_ptr"), ptext (sLit "\tjmp dyld_stub_binding_helper") ] @@ -584,16 +584,16 @@ pprImportedSymbol ArchX86 OSDarwin importedLbl vcat [ ptext (sLit ".section __TEXT,__picsymbolstub2,") <> ptext (sLit "symbol_stubs,pure_instructions,25"), - ptext (sLit "L") <> pprCLabel_asm lbl <> ptext (sLit "$stub:"), - ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm lbl, + ptext (sLit "L") <> pprCLabel_asm platform lbl <> ptext (sLit "$stub:"), + ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm platform lbl, ptext (sLit "\tcall ___i686.get_pc_thunk.ax"), ptext (sLit "1:"), - ptext (sLit "\tmovl L") <> pprCLabel_asm lbl + ptext (sLit "\tmovl L") <> pprCLabel_asm platform lbl <> ptext (sLit "$lazy_ptr-1b(%eax),%edx"), ptext (sLit "\tjmp *%edx"), - ptext (sLit "L") <> pprCLabel_asm lbl + ptext (sLit "L") <> pprCLabel_asm platform lbl <> ptext (sLit "$stub_binder:"), - ptext (sLit "\tlea L") <> pprCLabel_asm lbl + ptext (sLit "\tlea L") <> pprCLabel_asm platform lbl <> ptext (sLit "$lazy_ptr-1b(%eax),%eax"), ptext (sLit "\tpushl %eax"), ptext (sLit "\tjmp dyld_stub_binding_helper") @@ -601,23 +601,23 @@ pprImportedSymbol ArchX86 OSDarwin importedLbl $+$ vcat [ ptext (sLit ".section __DATA, __la_sym_ptr") <> (if opt_PIC then int 2 else int 3) <> ptext (sLit ",lazy_symbol_pointers"), - ptext (sLit "L") <> pprCLabel_asm lbl <> ptext (sLit "$lazy_ptr:"), - ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm lbl, - ptext (sLit "\t.long L") <> pprCLabel_asm lbl + ptext (sLit "L") <> pprCLabel_asm platform lbl <> ptext (sLit "$lazy_ptr:"), + ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm platform lbl, + ptext (sLit "\t.long L") <> pprCLabel_asm platform lbl <> ptext (sLit "$stub_binder")] | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl = vcat [ ptext (sLit ".non_lazy_symbol_pointer"), - char 'L' <> pprCLabel_asm lbl <> ptext (sLit "$non_lazy_ptr:"), - ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm lbl, + char 'L' <> pprCLabel_asm platform lbl <> ptext (sLit "$non_lazy_ptr:"), + ptext (sLit "\t.indirect_symbol") <+> pprCLabel_asm platform lbl, ptext (sLit "\t.long\t0")] | otherwise = empty -pprImportedSymbol _ OSDarwin _ +pprImportedSymbol (Platform _ OSDarwin) _ = empty @@ -650,11 +650,11 @@ pprImportedSymbol _ OSDarwin _ -- the NCG will keep track of all DynamicLinkerLabels it uses -- and output each of them using pprImportedSymbol. -pprImportedSymbol ArchPPC_64 os _ +pprImportedSymbol (Platform ArchPPC_64 os) _ | osElfTarget os = empty -pprImportedSymbol _ os importedLbl +pprImportedSymbol platform@(Platform _ os) importedLbl | osElfTarget os = case dynamicLinkerLabelInfo importedLbl of Just (SymbolPtr, lbl) @@ -665,13 +665,13 @@ pprImportedSymbol _ os importedLbl in vcat [ ptext (sLit ".section \".got2\", \"aw\""), - ptext (sLit ".LC_") <> pprCLabel_asm lbl <> char ':', - ptext symbolSize <+> pprCLabel_asm lbl ] + ptext (sLit ".LC_") <> pprCLabel_asm platform lbl <> char ':', + ptext symbolSize <+> pprCLabel_asm platform lbl ] -- PLT code stubs are generated automatically by the dynamic linker. _ -> empty -pprImportedSymbol _ _ _ +pprImportedSymbol _ _ = panic "PIC.pprImportedSymbol: no match" -------------------------------------------------------------------------------- diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 359a63392c..4bde8efd5b 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -357,7 +357,8 @@ iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi) rlo iselExpr64 expr - = pprPanic "iselExpr64(powerpc)" (ppr expr) + = do dflags <- getDynFlagsNat + pprPanic "iselExpr64(powerpc)" (pprPlatform (targetPlatform dflags) expr) @@ -573,7 +574,7 @@ getRegister' _ (CmmLit lit) ] in return (Any (cmmTypeSize rep) code) -getRegister' _ other = pprPanic "getRegister(ppc)" (pprExpr other) +getRegister' dflags other = pprPanic "getRegister(ppc)" (pprExpr (targetPlatform dflags) other) -- extend?Rep: wrap integer expression of type rep -- in a conversion to II32 diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index 4c73a329b5..c33b5e0748 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -51,16 +51,17 @@ import Data.Bits -- Printing this stuff out pprNatCmmDecl :: Platform -> NatCmmDecl CmmStatics Instr -> Doc -pprNatCmmDecl _ (CmmData section dats) = - pprSectionHeader section $$ pprDatas dats +pprNatCmmDecl platform (CmmData section dats) = + pprSectionHeader section $$ pprDatas platform dats -- special case for split markers: -pprNatCmmDecl _ (CmmProc Nothing lbl (ListGraph [])) = pprLabel lbl +pprNatCmmDecl platform (CmmProc Nothing lbl (ListGraph [])) + = pprLabel platform lbl -- special case for code without an info table: pprNatCmmDecl platform (CmmProc Nothing lbl (ListGraph blocks)) = pprSectionHeader Text $$ - pprLabel lbl $$ -- blocks guaranteed not null, so label needed + pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed vcat (map (pprBasicBlock platform) blocks) pprNatCmmDecl platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) = @@ -70,8 +71,8 @@ pprNatCmmDecl platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListG pprCLabel_asm (mkDeadStripPreventer info_lbl) <> char ':' $$ #endif - vcat (map pprData info) $$ - pprLabel info_lbl + vcat (map (pprData platform) info) $$ + pprLabel platform info_lbl ) $$ vcat (map (pprBasicBlock platform) blocks) -- above: Even the first block gets a label, because with branch-chain @@ -92,43 +93,45 @@ pprNatCmmDecl platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListG pprBasicBlock :: Platform -> NatBasicBlock Instr -> Doc pprBasicBlock platform (BasicBlock blockid instrs) = - pprLabel (mkAsmTempLabel (getUnique blockid)) $$ + pprLabel platform (mkAsmTempLabel (getUnique blockid)) $$ vcat (map (pprInstr platform) instrs) -pprDatas :: CmmStatics -> Doc -pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats) +pprDatas :: Platform -> CmmStatics -> Doc +pprDatas platform (Statics lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats) -pprData :: CmmStatic -> Doc -pprData (CmmString str) = pprASCII str +pprData :: Platform -> CmmStatic -> Doc +pprData _ (CmmString str) = pprASCII str #if darwin_TARGET_OS -pprData (CmmUninitialised bytes) = ptext (sLit ".space ") <> int bytes +pprData _ (CmmUninitialised bytes) = ptext (sLit ".space ") <> int bytes #else -pprData (CmmUninitialised bytes) = ptext (sLit ".skip ") <> int bytes +pprData _ (CmmUninitialised bytes) = ptext (sLit ".skip ") <> int bytes #endif -pprData (CmmStaticLit lit) = pprDataItem lit +pprData platform (CmmStaticLit lit) = pprDataItem platform lit -pprGloblDecl :: CLabel -> Doc -pprGloblDecl lbl +pprGloblDecl :: Platform -> CLabel -> Doc +pprGloblDecl platform lbl | not (externallyVisibleCLabel lbl) = empty - | otherwise = ptext (sLit ".globl ") <> pprCLabel_asm lbl + | otherwise = ptext (sLit ".globl ") <> pprCLabel_asm platform lbl -pprTypeAndSizeDecl :: CLabel -> Doc +pprTypeAndSizeDecl :: Platform -> CLabel -> Doc #if linux_TARGET_OS -pprTypeAndSizeDecl lbl +pprTypeAndSizeDecl platform lbl | not (externallyVisibleCLabel lbl) = empty | otherwise = ptext (sLit ".type ") <> - pprCLabel_asm lbl <> ptext (sLit ", @object") + pprCLabel_asm platform lbl <> ptext (sLit ", @object") #else -pprTypeAndSizeDecl _ +pprTypeAndSizeDecl _ _ = empty #endif -pprLabel :: CLabel -> Doc -pprLabel lbl = pprGloblDecl lbl $$ pprTypeAndSizeDecl lbl $$ (pprCLabel_asm lbl <> char ':') +pprLabel :: Platform -> CLabel -> Doc +pprLabel platform lbl = pprGloblDecl platform lbl + $$ pprTypeAndSizeDecl platform lbl + $$ (pprCLabel_asm platform lbl <> char ':') pprASCII :: [Word8] -> Doc @@ -227,57 +230,57 @@ pprCond c GU -> sLit "gt"; LEU -> sLit "le"; }) -pprImm :: Imm -> Doc +pprImm :: Platform -> Imm -> Doc -pprImm (ImmInt i) = int i -pprImm (ImmInteger i) = integer i -pprImm (ImmCLbl l) = pprCLabel_asm l -pprImm (ImmIndex l i) = pprCLabel_asm l <> char '+' <> int i -pprImm (ImmLit s) = s +pprImm _ (ImmInt i) = int i +pprImm _ (ImmInteger i) = integer i +pprImm platform (ImmCLbl l) = pprCLabel_asm platform l +pprImm platform (ImmIndex l i) = pprCLabel_asm platform l <> char '+' <> int i +pprImm _ (ImmLit s) = s -pprImm (ImmFloat _) = ptext (sLit "naughty float immediate") -pprImm (ImmDouble _) = ptext (sLit "naughty double immediate") +pprImm _ (ImmFloat _) = ptext (sLit "naughty float immediate") +pprImm _ (ImmDouble _) = ptext (sLit "naughty double immediate") -pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b -pprImm (ImmConstantDiff a b) = pprImm a <> char '-' - <> lparen <> pprImm b <> rparen +pprImm platform (ImmConstantSum a b) = pprImm platform a <> char '+' <> pprImm platform b +pprImm platform (ImmConstantDiff a b) = pprImm platform a <> char '-' + <> lparen <> pprImm platform b <> rparen #if darwin_TARGET_OS -pprImm (LO i) - = hcat [ pp_lo, pprImm i, rparen ] +pprImm platform (LO i) + = hcat [ pp_lo, pprImm platform i, rparen ] where pp_lo = text "lo16(" -pprImm (HI i) - = hcat [ pp_hi, pprImm i, rparen ] +pprImm platform (HI i) + = hcat [ pp_hi, pprImm platform i, rparen ] where pp_hi = text "hi16(" -pprImm (HA i) - = hcat [ pp_ha, pprImm i, rparen ] +pprImm platform (HA i) + = hcat [ pp_ha, pprImm platform i, rparen ] where pp_ha = text "ha16(" #else -pprImm (LO i) - = pprImm i <> text "@l" +pprImm platform (LO i) + = pprImm platform i <> text "@l" -pprImm (HI i) - = pprImm i <> text "@h" +pprImm platform (HI i) + = pprImm platform i <> text "@h" -pprImm (HA i) - = pprImm i <> text "@ha" +pprImm platform (HA i) + = pprImm platform i <> text "@ha" #endif -pprAddr :: AddrMode -> Doc -pprAddr (AddrRegReg r1 r2) +pprAddr :: Platform -> AddrMode -> Doc +pprAddr _ (AddrRegReg r1 r2) = pprReg r1 <+> ptext (sLit ", ") <+> pprReg r2 -pprAddr (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg r1, char ')' ] -pprAddr (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1, char ')' ] -pprAddr (AddrRegImm r1 imm) = hcat [ pprImm imm, char '(', pprReg r1, char ')' ] +pprAddr _ (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg r1, char ')' ] +pprAddr _ (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1, char ')' ] +pprAddr platform (AddrRegImm r1 imm) = hcat [ pprImm platform imm, char '(', pprReg r1, char ')' ] pprSectionHeader :: Section -> Doc @@ -306,25 +309,25 @@ pprSectionHeader seg #endif -pprDataItem :: CmmLit -> Doc -pprDataItem lit +pprDataItem :: Platform -> CmmLit -> Doc +pprDataItem platform lit = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit) where imm = litToImm lit - ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm imm] + ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm platform imm] - ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm imm] + ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm platform imm] ppr_item FF32 (CmmFloat r _) = let bs = floatToBytes (fromRational r) - in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs + in map (\b -> ptext (sLit "\t.byte\t") <> pprImm platform (ImmInt b)) bs ppr_item FF64 (CmmFloat r _) = let bs = doubleToBytes (fromRational r) - in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs + in map (\b -> ptext (sLit "\t.byte\t") <> pprImm platform (ImmInt b)) bs - ppr_item II16 _ = [ptext (sLit "\t.short\t") <> pprImm imm] + ppr_item II16 _ = [ptext (sLit "\t.short\t") <> pprImm platform imm] ppr_item II64 (CmmInt x _) = [ptext (sLit "\t.long\t") @@ -373,7 +376,7 @@ pprInstr _ (RELOAD slot reg) pprReg reg] -} -pprInstr _ (LD sz reg addr) = hcat [ +pprInstr platform (LD sz reg addr) = hcat [ char '\t', ptext (sLit "l"), ptext (case sz of @@ -389,9 +392,9 @@ pprInstr _ (LD sz reg addr) = hcat [ char '\t', pprReg reg, ptext (sLit ", "), - pprAddr addr + pprAddr platform addr ] -pprInstr _ (LA sz reg addr) = hcat [ +pprInstr platform (LA sz reg addr) = hcat [ char '\t', ptext (sLit "l"), ptext (case sz of @@ -407,9 +410,9 @@ pprInstr _ (LA sz reg addr) = hcat [ char '\t', pprReg reg, ptext (sLit ", "), - pprAddr addr + pprAddr platform addr ] -pprInstr _ (ST sz reg addr) = hcat [ +pprInstr platform (ST sz reg addr) = hcat [ char '\t', ptext (sLit "st"), pprSize sz, @@ -418,9 +421,9 @@ pprInstr _ (ST sz reg addr) = hcat [ char '\t', pprReg reg, ptext (sLit ", "), - pprAddr addr + pprAddr platform addr ] -pprInstr _ (STU sz reg addr) = hcat [ +pprInstr platform (STU sz reg addr) = hcat [ char '\t', ptext (sLit "st"), pprSize sz, @@ -429,23 +432,23 @@ pprInstr _ (STU sz reg addr) = hcat [ AddrRegReg _ _ -> char 'x', pprReg reg, ptext (sLit ", "), - pprAddr addr + pprAddr platform addr ] -pprInstr _ (LIS reg imm) = hcat [ +pprInstr platform (LIS reg imm) = hcat [ char '\t', ptext (sLit "lis"), char '\t', pprReg reg, ptext (sLit ", "), - pprImm imm + pprImm platform imm ] -pprInstr _ (LI reg imm) = hcat [ +pprInstr platform (LI reg imm) = hcat [ char '\t', ptext (sLit "li"), char '\t', pprReg reg, ptext (sLit ", "), - pprImm imm + pprImm platform imm ] pprInstr platform (MR reg1 reg2) | reg1 == reg2 = empty @@ -459,13 +462,13 @@ pprInstr platform (MR reg1 reg2) ptext (sLit ", "), pprReg reg2 ] -pprInstr _ (CMP sz reg ri) = hcat [ +pprInstr platform (CMP sz reg ri) = hcat [ char '\t', op, char '\t', pprReg reg, ptext (sLit ", "), - pprRI ri + pprRI platform ri ] where op = hcat [ @@ -475,13 +478,13 @@ pprInstr _ (CMP sz reg ri) = hcat [ RIReg _ -> empty RIImm _ -> char 'i' ] -pprInstr _ (CMPL sz reg ri) = hcat [ +pprInstr platform (CMPL sz reg ri) = hcat [ char '\t', op, char '\t', pprReg reg, ptext (sLit ", "), - pprRI ri + pprRI platform ri ] where op = hcat [ @@ -491,16 +494,16 @@ pprInstr _ (CMPL sz reg ri) = hcat [ RIReg _ -> empty RIImm _ -> char 'i' ] -pprInstr _ (BCC cond blockid) = hcat [ +pprInstr platform (BCC cond blockid) = hcat [ char '\t', ptext (sLit "b"), pprCond cond, char '\t', - pprCLabel_asm lbl + pprCLabel_asm platform lbl ] where lbl = mkAsmTempLabel (getUnique blockid) -pprInstr _ (BCCFAR cond blockid) = vcat [ +pprInstr platform (BCCFAR cond blockid) = vcat [ hcat [ ptext (sLit "\tb"), pprCond (condNegate cond), @@ -508,16 +511,16 @@ pprInstr _ (BCCFAR cond blockid) = vcat [ ], hcat [ ptext (sLit "\tb\t"), - pprCLabel_asm lbl + pprCLabel_asm platform lbl ] ] where lbl = mkAsmTempLabel (getUnique blockid) -pprInstr _ (JMP lbl) = hcat [ -- an alias for b that takes a CLabel +pprInstr platform (JMP lbl) = hcat [ -- an alias for b that takes a CLabel char '\t', ptext (sLit "b"), char '\t', - pprCLabel_asm lbl + pprCLabel_asm platform lbl ] pprInstr _ (MTCTR reg) = hcat [ @@ -530,16 +533,16 @@ pprInstr _ (BCTR _ _) = hcat [ char '\t', ptext (sLit "bctr") ] -pprInstr _ (BL lbl _) = hcat [ +pprInstr platform (BL lbl _) = hcat [ ptext (sLit "\tbl\t"), - pprCLabel_asm lbl + pprCLabel_asm platform lbl ] 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 platform (ADD reg1 reg2 ri) = pprLogic platform (sLit "add") reg1 reg2 ri +pprInstr platform (ADDIS reg1 reg2 imm) = hcat [ char '\t', ptext (sLit "addis"), char '\t', @@ -547,16 +550,16 @@ pprInstr _ (ADDIS reg1 reg2 imm) = hcat [ ptext (sLit ", "), pprReg reg2, ptext (sLit ", "), - pprImm imm + pprImm platform 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 platform (ADDC reg1 reg2 reg3) = pprLogic platform (sLit "addc") reg1 reg2 (RIReg reg3) +pprInstr platform (ADDE reg1 reg2 reg3) = pprLogic platform (sLit "adde") reg1 reg2 (RIReg reg3) +pprInstr platform (SUBF reg1 reg2 reg3) = pprLogic platform (sLit "subf") reg1 reg2 (RIReg reg3) +pprInstr platform (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic platform (sLit "mullw") reg1 reg2 ri +pprInstr platform (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic platform (sLit "mull") reg1 reg2 ri +pprInstr platform (DIVW reg1 reg2 reg3) = pprLogic platform (sLit "divw") reg1 reg2 (RIReg reg3) +pprInstr platform (DIVWU reg1 reg2 reg3) = pprLogic platform (sLit "divwu") reg1 reg2 (RIReg reg3) pprInstr _ (MULLW_MayOflo reg1 reg2 reg3) = vcat [ hcat [ ptext (sLit "\tmullwo\t"), pprReg reg1, ptext (sLit ", "), @@ -570,7 +573,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 platform (AND reg1 reg2 (RIImm imm)) = hcat [ char '\t', ptext (sLit "andi."), char '\t', @@ -578,14 +581,14 @@ pprInstr _ (AND reg1 reg2 (RIImm imm)) = hcat [ ptext (sLit ", "), pprReg reg2, ptext (sLit ", "), - pprImm imm + pprImm platform imm ] -pprInstr _ (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri +pprInstr platform (AND reg1 reg2 ri) = pprLogic platform (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 platform (OR reg1 reg2 ri) = pprLogic platform (sLit "or") reg1 reg2 ri +pprInstr platform (XOR reg1 reg2 ri) = pprLogic platform (sLit "xor") reg1 reg2 ri -pprInstr _ (XORIS reg1 reg2 imm) = hcat [ +pprInstr platform (XORIS reg1 reg2 imm) = hcat [ char '\t', ptext (sLit "xoris"), char '\t', @@ -593,7 +596,7 @@ pprInstr _ (XORIS reg1 reg2 imm) = hcat [ ptext (sLit ", "), pprReg reg2, ptext (sLit ", "), - pprImm imm + pprImm platform imm ] pprInstr _ (EXTS sz reg1 reg2) = hcat [ @@ -609,9 +612,9 @@ pprInstr _ (EXTS sz reg1 reg2) = hcat [ 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 platform (SLW reg1 reg2 ri) = pprLogic platform (sLit "slw") reg1 reg2 (limitShiftRI ri) +pprInstr platform (SRW reg1 reg2 ri) = pprLogic platform (sLit "srw") reg1 reg2 (limitShiftRI ri) +pprInstr platform (SRAW reg1 reg2 ri) = pprLogic platform (sLit "sraw") reg1 reg2 (limitShiftRI ri) pprInstr _ (RLWINM reg1 reg2 sh mb me) = hcat [ ptext (sLit "\trlwinm\t"), pprReg reg1, @@ -678,8 +681,8 @@ pprInstr _ LWSYNC = ptext (sLit "\tlwsync") -- pprInstr _ _ = panic "pprInstr (ppc)" -pprLogic :: LitString -> Reg -> Reg -> RI -> Doc -pprLogic op reg1 reg2 ri = hcat [ +pprLogic :: Platform -> LitString -> Reg -> Reg -> RI -> Doc +pprLogic platform op reg1 reg2 ri = hcat [ char '\t', ptext op, case ri of @@ -690,7 +693,7 @@ pprLogic op reg1 reg2 ri = hcat [ ptext (sLit ", "), pprReg reg2, ptext (sLit ", "), - pprRI ri + pprRI platform ri ] @@ -718,9 +721,9 @@ pprBinaryF op sz reg1 reg2 reg3 = hcat [ pprReg reg3 ] -pprRI :: RI -> Doc -pprRI (RIReg r) = pprReg r -pprRI (RIImm r) = pprImm r +pprRI :: Platform -> RI -> Doc +pprRI _ (RIReg r) = pprReg r +pprRI platform (RIImm r) = pprImm platform r pprFSize :: Size -> Doc diff --git a/compiler/nativeGen/PprBase.hs b/compiler/nativeGen/PprBase.hs index 5b9000cfca..5a50a79cae 100644 --- a/compiler/nativeGen/PprBase.hs +++ b/compiler/nativeGen/PprBase.hs @@ -18,6 +18,7 @@ module PprBase ( where import qualified Outputable +import Platform import CLabel import Pretty @@ -40,9 +41,9 @@ asmSDoc d = Outputable.withPprStyleDoc (Outputable.mkCodeStyle Outputable.AsmStyle) d -pprCLabel_asm :: CLabel -> Doc -pprCLabel_asm l - = asmSDoc (pprCLabel l) +pprCLabel_asm :: Platform -> CLabel -> Doc +pprCLabel_asm platform l + = asmSDoc (pprCLabel platform l) -- ----------------------------------------------------------------------------- diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs index 19497145f2..efc04930cd 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Main.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs @@ -45,7 +45,7 @@ maxSpinCount = 10 -- | The top level of the graph coloring register allocator. regAlloc - :: (Outputable statics, PlatformOutputable instr, Instruction instr) + :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) => DynFlags -> UniqFM (UniqSet RealReg) -- ^ the registers we can use for allocation -> UniqSet Int -- ^ the set of available spill slots. @@ -72,14 +72,20 @@ regAlloc dflags regsFree slotsFree code return ( code_final , reverse debug_codeGraphs ) -regAlloc_spin - dflags - spinCount - (triv :: Color.Triv VirtualReg RegClass RealReg) - (regsFree :: UniqFM (UniqSet RealReg)) - slotsFree - debug_codeGraphs - code +regAlloc_spin :: (Instruction instr, + PlatformOutputable instr, + PlatformOutputable statics) + => DynFlags + -> Int + -> Color.Triv VirtualReg RegClass RealReg + -> UniqFM (UniqSet RealReg) + -> UniqSet Int + -> [RegAllocStats statics instr] + -> [LiveCmmDecl statics instr] + -> UniqSM ([NatCmmDecl statics instr], + [RegAllocStats statics instr], + Color.Graph VirtualReg RegClass RealReg) +regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code = do let platform = targetPlatform dflags -- if any of these dump flags are turned on we want to hang on to @@ -323,7 +329,7 @@ graphAddCoalesce _ _ -- | Patch registers in code using the reg -> reg mapping in this graph. patchRegsFromGraph - :: (Outputable statics, PlatformOutputable instr, Instruction instr) + :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) => Platform -> Color.Graph VirtualReg RegClass RealReg -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs index 2d783f82ec..626262c658 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs @@ -65,7 +65,7 @@ data RegAllocStats statics instr , raFinal :: [NatCmmDecl statics instr] -- ^ final code , raSRMs :: (Int, Int, Int) } -- ^ spill\/reload\/reg-reg moves present in this code -instance (Outputable statics, PlatformOutputable instr) => PlatformOutputable (RegAllocStats statics instr) where +instance (PlatformOutputable statics, PlatformOutputable instr) => PlatformOutputable (RegAllocStats statics instr) where pprPlatform platform (s@RegAllocStatsStart{}) = text "# Start" diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index a5e8579f47..993156a67e 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -213,12 +213,12 @@ instance PlatformOutputable instr | isEmptyUniqSet regs = empty | otherwise = name <> (hcat $ punctuate space $ map ppr $ uniqSetToList regs) -instance Outputable LiveInfo where - 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) +instance PlatformOutputable LiveInfo where + pprPlatform platform (LiveInfo mb_static firstId liveVRegsOnEntry liveSlotsOnEntry) + = (maybe empty (pprPlatform platform) mb_static) + $$ text "# firstId = " <> ppr firstId + $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry + $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry) @@ -460,7 +460,9 @@ slurpReloadCoalesce live -- | Strip away liveness information, yielding NatCmmDecl stripLive - :: (Outputable statics, PlatformOutputable instr, Instruction instr) + :: (PlatformOutputable statics, + PlatformOutputable instr, + Instruction instr) => Platform -> LiveCmmDecl statics instr -> NatCmmDecl statics instr @@ -468,7 +470,11 @@ stripLive stripLive platform live = stripCmm live - where stripCmm (CmmData sec ds) = CmmData sec ds + where stripCmm :: (PlatformOutputable statics, + PlatformOutputable instr, + Instruction instr) + => LiveCmmDecl statics instr -> NatCmmDecl statics instr + stripCmm (CmmData sec ds) = CmmData sec ds stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label sccs) = let final_blocks = flattenSCCs sccs diff --git a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs index 0f6b12b627..25422659a6 100644 --- a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs +++ b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs @@ -19,6 +19,7 @@ import Size import OldCmm +import DynFlags import OrdList import Outputable @@ -54,9 +55,11 @@ getCondCode (CmmMachOp mop [x, y]) MO_U_Lt _ -> condIntCode LU x y MO_U_Le _ -> condIntCode LEU x y - _ -> pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr (CmmMachOp mop [x,y])) + _ -> do dflags <- getDynFlagsNat + pprPanic "SPARC.CodeGen.CondCode.getCondCode" (pprPlatform (targetPlatform dflags) (CmmMachOp mop [x,y])) -getCondCode other = pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr other) +getCondCode other = do dflags <- getDynFlagsNat + pprPanic "SPARC.CodeGen.CondCode.getCondCode" (pprPlatform (targetPlatform dflags) other) diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs index 6bf2a8f32d..92302e94af 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs @@ -194,7 +194,8 @@ iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) iselExpr64 expr - = pprPanic "iselExpr64(sparc)" (ppr expr) + = do dflags <- getDynFlagsNat + pprPanic "iselExpr64(sparc)" (pprPlatform (targetPlatform dflags) expr) diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs index e9859fe297..e25ecd57b0 100644 --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -49,29 +49,29 @@ import Data.Word -- Printing this stuff out pprNatCmmDecl :: Platform -> NatCmmDecl CmmStatics Instr -> Doc -pprNatCmmDecl _ (CmmData section dats) = - pprSectionHeader section $$ pprDatas dats +pprNatCmmDecl platform (CmmData section dats) = + pprSectionHeader section $$ pprDatas platform dats -- special case for split markers: -pprNatCmmDecl _ (CmmProc Nothing lbl (ListGraph [])) = pprLabel lbl +pprNatCmmDecl platform (CmmProc Nothing lbl (ListGraph [])) = pprLabel platform lbl -- special case for code without info table: -pprNatCmmDecl _ (CmmProc Nothing lbl (ListGraph blocks)) = +pprNatCmmDecl platform (CmmProc Nothing lbl (ListGraph blocks)) = pprSectionHeader Text $$ - pprLabel lbl $$ -- blocks guaranteed not null, so label needed - vcat (map pprBasicBlock blocks) + pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed + vcat (map (pprBasicBlock platform) blocks) -pprNatCmmDecl _ (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) = +pprNatCmmDecl platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) = pprSectionHeader Text $$ ( #if HAVE_SUBSECTIONS_VIA_SYMBOLS - pprCLabel_asm (mkDeadStripPreventer info_lbl) + pprCLabel_asm platform (mkDeadStripPreventer info_lbl) <> char ':' $$ #endif - vcat (map pprData info) $$ - pprLabel info_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 @@ -82,44 +82,46 @@ pprNatCmmDecl _ (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph bl -- so that the linker will not think it is unreferenced and dead-strip -- it. That's why the label is called a DeadStripPreventer (_dsp). $$ text "\t.long " - <+> pprCLabel_asm info_lbl + <+> pprCLabel_asm platform info_lbl <+> char '-' - <+> pprCLabel_asm (mkDeadStripPreventer info_lbl) + <+> pprCLabel_asm platform (mkDeadStripPreventer info_lbl) #endif -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) -pprDatas :: CmmStatics -> Doc -pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats) +pprDatas :: Platform -> CmmStatics -> Doc +pprDatas platform (Statics lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats) -pprData :: CmmStatic -> Doc -pprData (CmmString str) = pprASCII str -pprData (CmmUninitialised bytes) = ptext (sLit ".skip ") <> int bytes -pprData (CmmStaticLit lit) = pprDataItem lit +pprData :: Platform -> CmmStatic -> Doc +pprData _ (CmmString str) = pprASCII str +pprData _ (CmmUninitialised bytes) = ptext (sLit ".skip ") <> int bytes +pprData platform (CmmStaticLit lit) = pprDataItem platform lit -pprGloblDecl :: CLabel -> Doc -pprGloblDecl lbl +pprGloblDecl :: Platform -> CLabel -> Doc +pprGloblDecl platform lbl | not (externallyVisibleCLabel lbl) = empty - | otherwise = ptext (sLit ".global ") <> pprCLabel_asm lbl + | otherwise = ptext (sLit ".global ") <> pprCLabel_asm platform lbl -pprTypeAndSizeDecl :: CLabel -> Doc +pprTypeAndSizeDecl :: Platform -> CLabel -> Doc #if linux_TARGET_OS -pprTypeAndSizeDecl lbl +pprTypeAndSizeDecl platform lbl | not (externallyVisibleCLabel lbl) = empty | otherwise = ptext (sLit ".type ") <> - pprCLabel_asm lbl <> ptext (sLit ", @object") + pprCLabel_asm platform lbl <> ptext (sLit ", @object") #else -pprTypeAndSizeDecl _ +pprTypeAndSizeDecl _ _ = empty #endif -pprLabel :: CLabel -> Doc -pprLabel lbl = pprGloblDecl lbl $$ pprTypeAndSizeDecl lbl $$ (pprCLabel_asm lbl <> char ':') +pprLabel :: Platform -> CLabel -> Doc +pprLabel platform lbl = pprGloblDecl platform lbl + $$ pprTypeAndSizeDecl platform lbl + $$ (pprCLabel_asm platform lbl <> char ':') pprASCII :: [Word8] -> Doc @@ -134,7 +136,7 @@ pprASCII str -- pprInstr: print an 'Instr' instance PlatformOutputable Instr where - pprPlatform _ instr = Outputable.docToSDoc $ pprInstr instr + pprPlatform platform instr = Outputable.docToSDoc $ pprInstr platform instr -- | Pretty print a register. @@ -257,8 +259,8 @@ pprCond c -- | Pretty print an address mode. -pprAddr :: AddrMode -> Doc -pprAddr am +pprAddr :: Platform -> AddrMode -> Doc +pprAddr platform am = case am of AddrRegReg r1 (RegReal (RealRegSingle 0)) -> pprReg r1 @@ -281,30 +283,30 @@ pprAddr am pp_sign = if i > 0 then char '+' else empty AddrRegImm r1 imm - -> hcat [ pprReg r1, char '+', pprImm imm ] + -> hcat [ pprReg r1, char '+', pprImm platform imm ] -- | Pretty print an immediate value. -pprImm :: Imm -> Doc -pprImm imm +pprImm :: Platform -> Imm -> Doc +pprImm platform imm = case imm of ImmInt i -> int i ImmInteger i -> integer i - ImmCLbl l -> pprCLabel_asm l - ImmIndex l i -> pprCLabel_asm l <> char '+' <> int i + ImmCLbl l -> pprCLabel_asm platform l + ImmIndex l i -> pprCLabel_asm platform l <> char '+' <> int i ImmLit s -> s ImmConstantSum a b - -> pprImm a <> char '+' <> pprImm b + -> pprImm platform a <> char '+' <> pprImm platform b ImmConstantDiff a b - -> pprImm a <> char '-' <> lparen <> pprImm b <> rparen + -> pprImm platform a <> char '-' <> lparen <> pprImm platform b <> rparen LO i - -> hcat [ text "%lo(", pprImm i, rparen ] + -> hcat [ text "%lo(", pprImm platform i, rparen ] HI i - -> hcat [ text "%hi(", pprImm i, rparen ] + -> hcat [ text "%hi(", pprImm platform i, rparen ] -- these should have been converted to bytes and placed -- in the data section. @@ -329,124 +331,124 @@ pprSectionHeader seg -- | Pretty print a data item. -pprDataItem :: CmmLit -> Doc -pprDataItem lit +pprDataItem :: Platform -> CmmLit -> Doc +pprDataItem platform lit = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit) where imm = litToImm lit - ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm imm] - ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm imm] + ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm platform imm] + ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm platform imm] ppr_item FF32 (CmmFloat r _) = let bs = floatToBytes (fromRational r) - in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs + in map (\b -> ptext (sLit "\t.byte\t") <> pprImm platform (ImmInt b)) bs ppr_item FF64 (CmmFloat r _) = let bs = doubleToBytes (fromRational r) - in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs + in map (\b -> ptext (sLit "\t.byte\t") <> pprImm platform (ImmInt b)) bs - ppr_item II16 _ = [ptext (sLit "\t.short\t") <> pprImm imm] - ppr_item II64 _ = [ptext (sLit "\t.quad\t") <> pprImm imm] + ppr_item II16 _ = [ptext (sLit "\t.short\t") <> pprImm platform imm] + ppr_item II64 _ = [ptext (sLit "\t.quad\t") <> pprImm platform imm] ppr_item _ _ = panic "SPARC.Ppr.pprDataItem: no match" -- | Pretty print an instruction. -pprInstr :: Instr -> Doc +pprInstr :: Platform -> Instr -> Doc -- nuke comments. -pprInstr (COMMENT _) +pprInstr _ (COMMENT _) = empty -pprInstr (DELTA d) - = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d))) +pprInstr platform (DELTA d) + = pprInstr platform (COMMENT (mkFastString ("\tdelta = " ++ show d))) -- Newblocks and LData should have been slurped out before producing the .s file. -pprInstr (NEWBLOCK _) +pprInstr _ (NEWBLOCK _) = panic "X86.Ppr.pprInstr: NEWBLOCK" -pprInstr (LDATA _ _) +pprInstr _ (LDATA _ _) = panic "PprMach.pprInstr: LDATA" -- 64 bit FP loads are expanded into individual instructions in CodeGen.Expand -pprInstr (LD FF64 _ reg) +pprInstr _ (LD FF64 _ reg) | RegReal (RealRegSingle{}) <- reg = panic "SPARC.Ppr: not emitting potentially misaligned LD FF64 instr" -pprInstr (LD size addr reg) +pprInstr platform (LD size addr reg) = hcat [ ptext (sLit "\tld"), pprSize size, char '\t', lbrack, - pprAddr addr, + pprAddr platform addr, pp_rbracket_comma, pprReg reg ] -- 64 bit FP storees are expanded into individual instructions in CodeGen.Expand -pprInstr (ST FF64 reg _) +pprInstr _ (ST FF64 reg _) | RegReal (RealRegSingle{}) <- reg = panic "SPARC.Ppr: not emitting potentially misaligned ST FF64 instr" -- no distinction is made between signed and unsigned bytes on stores for the -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF), -- so we call a special-purpose pprSize for ST.. -pprInstr (ST size reg addr) +pprInstr platform (ST size reg addr) = hcat [ ptext (sLit "\tst"), pprStSize size, char '\t', pprReg reg, pp_comma_lbracket, - pprAddr addr, + pprAddr platform addr, rbrack ] -pprInstr (ADD x cc reg1 ri reg2) +pprInstr platform (ADD x cc reg1 ri reg2) | not x && not cc && riZero ri = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ] | otherwise - = pprRegRIReg (if x then sLit "addx" else sLit "add") cc reg1 ri reg2 + = pprRegRIReg platform (if x then sLit "addx" else sLit "add") cc reg1 ri reg2 -pprInstr (SUB x cc reg1 ri reg2) +pprInstr platform (SUB x cc reg1 ri reg2) | not x && cc && reg2 == g0 - = hcat [ ptext (sLit "\tcmp\t"), pprReg reg1, comma, pprRI ri ] + = hcat [ ptext (sLit "\tcmp\t"), pprReg reg1, comma, pprRI platform ri ] | not x && not cc && riZero ri = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ] | otherwise - = pprRegRIReg (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2 + = pprRegRIReg platform (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2 -pprInstr (AND b reg1 ri reg2) = pprRegRIReg (sLit "and") b reg1 ri reg2 +pprInstr platform (AND b reg1 ri reg2) = pprRegRIReg platform (sLit "and") b reg1 ri reg2 -pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg (sLit "andn") b reg1 ri reg2 +pprInstr platform (ANDN b reg1 ri reg2) = pprRegRIReg platform (sLit "andn") b reg1 ri reg2 -pprInstr (OR b reg1 ri reg2) +pprInstr platform (OR b reg1 ri reg2) | not b && reg1 == g0 - = let doit = hcat [ ptext (sLit "\tmov\t"), pprRI ri, comma, pprReg reg2 ] + = let doit = hcat [ ptext (sLit "\tmov\t"), pprRI platform ri, comma, pprReg reg2 ] in case ri of RIReg rrr | rrr == reg2 -> empty _ -> doit | otherwise - = pprRegRIReg (sLit "or") b reg1 ri reg2 + = pprRegRIReg platform (sLit "or") b reg1 ri reg2 -pprInstr (ORN b reg1 ri reg2) = pprRegRIReg (sLit "orn") b reg1 ri reg2 +pprInstr platform (ORN b reg1 ri reg2) = pprRegRIReg platform (sLit "orn") b reg1 ri reg2 -pprInstr (XOR b reg1 ri reg2) = pprRegRIReg (sLit "xor") b reg1 ri reg2 -pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg (sLit "xnor") b reg1 ri reg2 +pprInstr platform (XOR b reg1 ri reg2) = pprRegRIReg platform (sLit "xor") b reg1 ri reg2 +pprInstr platform (XNOR b reg1 ri reg2) = pprRegRIReg platform (sLit "xnor") b reg1 ri reg2 -pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") False reg1 ri reg2 -pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") False reg1 ri reg2 -pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") False reg1 ri reg2 +pprInstr platform (SLL reg1 ri reg2) = pprRegRIReg platform (sLit "sll") False reg1 ri reg2 +pprInstr platform (SRL reg1 ri reg2) = pprRegRIReg platform (sLit "srl") False reg1 ri reg2 +pprInstr platform (SRA reg1 ri reg2) = pprRegRIReg platform (sLit "sra") False reg1 ri reg2 -pprInstr (RDY rd) = ptext (sLit "\trd\t%y,") <> pprReg rd -pprInstr (WRY reg1 reg2) +pprInstr _ (RDY rd) = ptext (sLit "\trd\t%y,") <> pprReg rd +pprInstr _ (WRY reg1 reg2) = ptext (sLit "\twr\t") <> pprReg reg1 <> char ',' @@ -454,50 +456,50 @@ pprInstr (WRY reg1 reg2) <> char ',' <> ptext (sLit "%y") -pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg (sLit "smul") b reg1 ri reg2 -pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg (sLit "umul") b reg1 ri reg2 -pprInstr (SDIV b reg1 ri reg2) = pprRegRIReg (sLit "sdiv") b reg1 ri reg2 -pprInstr (UDIV b reg1 ri reg2) = pprRegRIReg (sLit "udiv") b reg1 ri reg2 +pprInstr platform (SMUL b reg1 ri reg2) = pprRegRIReg platform (sLit "smul") b reg1 ri reg2 +pprInstr platform (UMUL b reg1 ri reg2) = pprRegRIReg platform (sLit "umul") b reg1 ri reg2 +pprInstr platform (SDIV b reg1 ri reg2) = pprRegRIReg platform (sLit "sdiv") b reg1 ri reg2 +pprInstr platform (UDIV b reg1 ri reg2) = pprRegRIReg platform (sLit "udiv") b reg1 ri reg2 -pprInstr (SETHI imm reg) +pprInstr platform (SETHI imm reg) = hcat [ ptext (sLit "\tsethi\t"), - pprImm imm, + pprImm platform imm, comma, pprReg reg ] -pprInstr NOP +pprInstr _ NOP = ptext (sLit "\tnop") -pprInstr (FABS size reg1 reg2) +pprInstr _ (FABS size reg1 reg2) = pprSizeRegReg (sLit "fabs") size reg1 reg2 -pprInstr (FADD size reg1 reg2 reg3) +pprInstr _ (FADD size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "fadd") size reg1 reg2 reg3 -pprInstr (FCMP e size reg1 reg2) +pprInstr _ (FCMP e size reg1 reg2) = pprSizeRegReg (if e then sLit "fcmpe" else sLit "fcmp") size reg1 reg2 -pprInstr (FDIV size reg1 reg2 reg3) +pprInstr _ (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "fdiv") size reg1 reg2 reg3 -pprInstr (FMOV size reg1 reg2) +pprInstr _ (FMOV size reg1 reg2) = pprSizeRegReg (sLit "fmov") size reg1 reg2 -pprInstr (FMUL size reg1 reg2 reg3) +pprInstr _ (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "fmul") size reg1 reg2 reg3 -pprInstr (FNEG size reg1 reg2) +pprInstr _ (FNEG size reg1 reg2) = pprSizeRegReg (sLit "fneg") size reg1 reg2 -pprInstr (FSQRT size reg1 reg2) +pprInstr _ (FSQRT size reg1 reg2) = pprSizeRegReg (sLit "fsqrt") size reg1 reg2 -pprInstr (FSUB size reg1 reg2 reg3) +pprInstr _ (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "fsub") size reg1 reg2 reg3 -pprInstr (FxTOy size1 size2 reg1 reg2) +pprInstr _ (FxTOy size1 size2 reg1 reg2) = hcat [ ptext (sLit "\tf"), ptext @@ -517,36 +519,36 @@ pprInstr (FxTOy size1 size2 reg1 reg2) ] -pprInstr (BI cond b blockid) +pprInstr platform (BI cond b blockid) = hcat [ ptext (sLit "\tb"), pprCond cond, if b then pp_comma_a else empty, char '\t', - pprCLabel_asm (mkAsmTempLabel (getUnique blockid)) + pprCLabel_asm platform (mkAsmTempLabel (getUnique blockid)) ] -pprInstr (BF cond b blockid) +pprInstr platform (BF cond b blockid) = hcat [ ptext (sLit "\tfb"), pprCond cond, if b then pp_comma_a else empty, char '\t', - pprCLabel_asm (mkAsmTempLabel (getUnique blockid)) + pprCLabel_asm platform (mkAsmTempLabel (getUnique blockid)) ] -pprInstr (JMP addr) = (<>) (ptext (sLit "\tjmp\t")) (pprAddr addr) -pprInstr (JMP_TBL op _ _) = pprInstr (JMP op) +pprInstr platform (JMP addr) = (<>) (ptext (sLit "\tjmp\t")) (pprAddr platform addr) +pprInstr platform (JMP_TBL op _ _) = pprInstr platform (JMP op) -pprInstr (CALL (Left imm) n _) - = hcat [ ptext (sLit "\tcall\t"), pprImm imm, comma, int n ] +pprInstr platform (CALL (Left imm) n _) + = hcat [ ptext (sLit "\tcall\t"), pprImm platform imm, comma, int n ] -pprInstr (CALL (Right reg) n _) +pprInstr _ (CALL (Right reg) n _) = hcat [ ptext (sLit "\tcall\t"), pprReg reg, comma, int n ] -- | Pretty print a RI -pprRI :: RI -> Doc -pprRI (RIReg r) = pprReg r -pprRI (RIImm r) = pprImm r +pprRI :: Platform -> RI -> Doc +pprRI _ (RIReg r) = pprReg r +pprRI platform (RIImm r) = pprImm platform r -- | Pretty print a two reg instruction. @@ -585,15 +587,15 @@ pprSizeRegRegReg name size reg1 reg2 reg3 -- | Pretty print an instruction of two regs and a ri. -pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc -pprRegRIReg name b reg1 ri reg2 +pprRegRIReg :: Platform -> LitString -> Bool -> Reg -> RI -> Reg -> Doc +pprRegRIReg platform name b reg1 ri reg2 = hcat [ char '\t', ptext name, if b then ptext (sLit "cc\t") else char '\t', pprReg reg1, comma, - pprRI ri, + pprRI platform ri, comma, pprReg reg2 ] diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index afd077b35e..aef789710b 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -401,7 +401,8 @@ iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do ) iselExpr64 expr - = pprPanic "iselExpr64(i386)" (ppr expr) + = do dflags <- getDynFlagsNat + pprPanic "iselExpr64(i386)" (pprPlatform (targetPlatform dflags) expr) -------------------------------------------------------------------------------- @@ -884,7 +885,8 @@ getRegister' _ (CmmLit lit) in return (Any size code) -getRegister' _ other = pprPanic "getRegister(x86)" (ppr other) +getRegister' _ other = do dflags <- getDynFlagsNat + pprPanic "getRegister(x86)" (pprPlatform (targetPlatform dflags) other) intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr @@ -1221,9 +1223,11 @@ getCondCode (CmmMachOp mop [x, y]) MO_U_Lt _ -> condIntCode LU x y MO_U_Le _ -> condIntCode LEU x y - _other -> pprPanic "getCondCode(x86,x86_64,sparc)" (ppr (CmmMachOp mop [x,y])) + _other -> do dflags <- getDynFlagsNat + pprPanic "getCondCode(x86,x86_64,sparc)" (pprPlatform (targetPlatform dflags) (CmmMachOp mop [x,y])) -getCondCode other = pprPanic "getCondCode(2)(x86,sparc)" (ppr other) +getCondCode other = do dflags <- getDynFlagsNat + pprPanic "getCondCode(2)(x86,sparc)" (pprPlatform (targetPlatform dflags) other) diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index dc54378ccc..ab93e2dbb9 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -66,7 +66,7 @@ pprNatCmmDecl platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListG pprSectionHeader platform Text $$ ( #if HAVE_SUBSECTIONS_VIA_SYMBOLS - pprCLabel_asm (mkDeadStripPreventer info_lbl) + pprCLabel_asm platform (mkDeadStripPreventer info_lbl) <> char ':' $$ #endif vcat (map (pprData platform) info) $$ @@ -83,9 +83,9 @@ pprNatCmmDecl platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListG -- so that the linker will not think it is unreferenced and dead-strip -- it. That's why the label is called a DeadStripPreventer (_dsp). $$ text "\t.long " - <+> pprCLabel_asm info_lbl + <+> pprCLabel_asm platform info_lbl <+> char '-' - <+> pprCLabel_asm (mkDeadStripPreventer info_lbl) + <+> pprCLabel_asm platform (mkDeadStripPreventer info_lbl) #endif $$ pprSizeDecl platform info_lbl @@ -93,8 +93,8 @@ pprNatCmmDecl platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListG pprSizeDecl :: Platform -> CLabel -> Doc pprSizeDecl platform lbl | osElfTarget (platformOS platform) = - ptext (sLit "\t.size") <+> pprCLabel_asm lbl - <> ptext (sLit ", .-") <> pprCLabel_asm lbl + ptext (sLit "\t.size") <+> pprCLabel_asm platform lbl + <> ptext (sLit ", .-") <> pprCLabel_asm platform lbl | otherwise = empty pprBasicBlock :: Platform -> NatBasicBlock Instr -> Doc @@ -117,22 +117,22 @@ pprData platform (CmmUninitialised bytes) pprData platform (CmmStaticLit lit) = pprDataItem platform lit -pprGloblDecl :: CLabel -> Doc -pprGloblDecl lbl +pprGloblDecl :: Platform -> CLabel -> Doc +pprGloblDecl platform lbl | not (externallyVisibleCLabel lbl) = empty - | otherwise = ptext (sLit ".globl ") <> pprCLabel_asm lbl + | otherwise = ptext (sLit ".globl ") <> pprCLabel_asm platform lbl pprTypeAndSizeDecl :: Platform -> CLabel -> Doc pprTypeAndSizeDecl platform lbl | osElfTarget (platformOS platform) && externallyVisibleCLabel lbl = ptext (sLit ".type ") <> - pprCLabel_asm lbl <> ptext (sLit ", @object") + pprCLabel_asm platform lbl <> ptext (sLit ", @object") | otherwise = empty pprLabel :: Platform -> CLabel -> Doc -pprLabel platform lbl = pprGloblDecl lbl +pprLabel platform lbl = pprGloblDecl platform lbl $$ pprTypeAndSizeDecl platform lbl - $$ (pprCLabel_asm lbl <> char ':') + $$ (pprCLabel_asm platform lbl <> char ':') pprASCII :: [Word8] -> Doc @@ -314,25 +314,25 @@ pprCond c ALWAYS -> sLit "mp"}) -pprImm :: Imm -> Doc -pprImm (ImmInt i) = int i -pprImm (ImmInteger i) = integer i -pprImm (ImmCLbl l) = pprCLabel_asm l -pprImm (ImmIndex l i) = pprCLabel_asm l <> char '+' <> int i -pprImm (ImmLit s) = s +pprImm :: Platform -> Imm -> Doc +pprImm _ (ImmInt i) = int i +pprImm _ (ImmInteger i) = integer i +pprImm platform (ImmCLbl l) = pprCLabel_asm platform l +pprImm platform (ImmIndex l i) = pprCLabel_asm platform l <> char '+' <> int i +pprImm _ (ImmLit s) = s -pprImm (ImmFloat _) = ptext (sLit "naughty float immediate") -pprImm (ImmDouble _) = ptext (sLit "naughty double immediate") +pprImm _ (ImmFloat _) = ptext (sLit "naughty float immediate") +pprImm _ (ImmDouble _) = ptext (sLit "naughty double immediate") -pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b -pprImm (ImmConstantDiff a b) = pprImm a <> char '-' - <> lparen <> pprImm b <> rparen +pprImm platform (ImmConstantSum a b) = pprImm platform a <> char '+' <> pprImm platform b +pprImm platform (ImmConstantDiff a b) = pprImm platform a <> char '-' + <> lparen <> pprImm platform b <> rparen pprAddr :: Platform -> AddrMode -> Doc -pprAddr _ (ImmAddr imm off) - = let pp_imm = pprImm imm +pprAddr platform (ImmAddr imm off) + = let pp_imm = pprImm platform imm in if (off == 0) then pp_imm @@ -358,7 +358,7 @@ pprAddr platform (AddrBaseIndex base index displacement) where ppr_disp (ImmInt 0) = empty - ppr_disp imm = pprImm imm + ppr_disp imm = pprImm platform imm pprSectionHeader :: Platform -> Section -> Doc @@ -413,17 +413,17 @@ pprDataItem platform lit imm = litToImm lit -- These seem to be common: - ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm imm] - ppr_item II16 _ = [ptext (sLit "\t.word\t") <> pprImm imm] - ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm imm] + ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm platform imm] + ppr_item II16 _ = [ptext (sLit "\t.word\t") <> pprImm platform imm] + ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm platform imm] ppr_item FF32 (CmmFloat r _) = let bs = floatToBytes (fromRational r) - in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs + in map (\b -> ptext (sLit "\t.byte\t") <> pprImm platform (ImmInt b)) bs ppr_item FF64 (CmmFloat r _) = let bs = doubleToBytes (fromRational r) - in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs + in map (\b -> ptext (sLit "\t.byte\t") <> pprImm platform (ImmInt b)) bs ppr_item II64 _ = case platformOS platform of @@ -438,10 +438,10 @@ pprDataItem platform lit (fromIntegral (x `shiftR` 32) :: Word32))] _ -> panic "X86.Ppr.ppr_item: no match for II64" | otherwise -> - [ptext (sLit "\t.quad\t") <> pprImm imm] + [ptext (sLit "\t.quad\t") <> pprImm platform imm] _ | target32Bit platform -> - [ptext (sLit "\t.quad\t") <> pprImm imm] + [ptext (sLit "\t.quad\t") <> pprImm platform imm] | otherwise -> -- x86_64: binutils can't handle the R_X86_64_PC64 -- relocation type, which means we can't do @@ -456,10 +456,10 @@ pprDataItem platform lit case lit of -- A relative relocation: CmmLabelDiffOff _ _ _ -> - [ptext (sLit "\t.long\t") <> pprImm imm, + [ptext (sLit "\t.long\t") <> pprImm platform imm, ptext (sLit "\t.long\t0")] _ -> - [ptext (sLit "\t.quad\t") <> pprImm imm] + [ptext (sLit "\t.quad\t") <> pprImm platform imm] ppr_item _ _ = panic "X86.Ppr.ppr_item: no match" @@ -591,16 +591,16 @@ pprInstr _ (CLTD II64) = ptext (sLit "\tcqto") pprInstr platform (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand platform II8 op) -pprInstr _ (JXX cond blockid) - = pprCondInstr (sLit "j") cond (pprCLabel_asm lab) +pprInstr platform (JXX cond blockid) + = pprCondInstr (sLit "j") cond (pprCLabel_asm platform lab) where lab = mkAsmTempLabel (getUnique blockid) -pprInstr _ (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm) +pprInstr platform (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm platform imm) -pprInstr _ (JMP (OpImm imm)) = (<>) (ptext (sLit "\tjmp ")) (pprImm imm) +pprInstr platform (JMP (OpImm imm)) = (<>) (ptext (sLit "\tjmp ")) (pprImm platform 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 (Left imm) _) = (<>) (ptext (sLit "\tcall ")) (pprImm platform imm) pprInstr platform (CALL (Right reg) _) = (<>) (ptext (sLit "\tcall *")) (pprReg platform archWordSize reg) pprInstr platform (IDIV sz op) = pprSizeOp platform (sLit "idiv") sz op @@ -779,13 +779,13 @@ pprInstr platform g@(GSQRT sz src dst) hcat [gtab, gcoerceto sz, gpop dst 1]) pprInstr platform g@(GSIN sz l1 l2 src dst) - = pprG platform g (pprTrigOp "fsin" False l1 l2 src dst sz) + = pprG platform g (pprTrigOp platform "fsin" 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) + = pprG platform g (pprTrigOp platform "fcos" False 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) + = pprG platform g (pprTrigOp platform "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 @@ -860,8 +860,10 @@ pprInstr _ _ = panic "X86.Ppr.pprInstr: no match" -pprTrigOp :: String -> Bool -> CLabel -> CLabel -> Reg -> Reg -> Size -> Doc -pprTrigOp op -- fsin, fcos or fptan +pprTrigOp :: Platform -> String -> Bool -> CLabel -> CLabel + -> Reg -> Reg -> Size -> Doc +pprTrigOp platform + op -- fsin, fcos or fptan isTan -- we need a couple of extra steps if we're doing tan l1 l2 -- internal labels for us to use src dst sz @@ -875,7 +877,7 @@ pprTrigOp op -- fsin, fcos or fptan hcat [gtab, text "fnstsw %ax"] $$ hcat [gtab, text "test $0x400,%eax"] $$ -- If we were in bounds then jump to the end - hcat [gtab, text "je " <> pprCLabel_asm l1] $$ + hcat [gtab, text "je " <> pprCLabel_asm platform l1] $$ -- Otherwise we need to shrink the value. Start by -- loading pi, doubleing it (by adding it to itself), -- and then swapping pi with the value, so the value we @@ -885,16 +887,16 @@ pprTrigOp op -- fsin, fcos or fptan hcat [gtab, text "fxch %st(1)"] $$ -- Now we have a loop in which we make the value smaller, -- see if it's small enough, and loop if not - (pprCLabel_asm l2 <> char ':') $$ + (pprCLabel_asm platform l2 <> char ':') $$ hcat [gtab, text "fprem1"] $$ -- My Debian libc uses fstsw here for the tan code, but I can't -- see any reason why it should need to be different for tan. hcat [gtab, text "fnstsw %ax"] $$ hcat [gtab, text "test $0x400,%eax"] $$ - hcat [gtab, text "jne " <> pprCLabel_asm l2] $$ + hcat [gtab, text "jne " <> pprCLabel_asm platform l2] $$ hcat [gtab, text "fstp %st(1)"] $$ hcat [gtab, text op] $$ - (pprCLabel_asm l1 <> char ':') $$ + (pprCLabel_asm platform l1 <> char ':') $$ -- Pop the 1.0 tan gave us (if isTan then hcat [gtab, text "fstp %st(0)"] else empty) $$ -- Restore %eax @@ -970,13 +972,13 @@ pprGInstr platform (GDIV sz src1 src2 dst) = pprSizeRegRegReg platform (sLit "gd pprGInstr _ _ = panic "X86.Ppr.pprGInstr: no match" -pprDollImm :: Imm -> Doc -pprDollImm i = ptext (sLit "$") <> pprImm i +pprDollImm :: Platform -> Imm -> Doc +pprDollImm platform i = ptext (sLit "$") <> pprImm platform i pprOperand :: Platform -> Size -> Operand -> Doc pprOperand platform s (OpReg r) = pprReg platform s r -pprOperand _ _ (OpImm i) = pprDollImm i +pprOperand platform _ (OpImm i) = pprDollImm platform i pprOperand platform _ (OpAddr ea) = pprAddr platform ea @@ -995,7 +997,7 @@ pprSizeImmOp platform name size imm op1 = hcat [ pprMnemonic name size, char '$', - pprImm imm, + pprImm platform imm, comma, pprOperand platform size op1 ] diff --git a/compiler/profiling/ProfInit.hs b/compiler/profiling/ProfInit.hs index 7e223f80e9..fa99a752d1 100644 --- a/compiler/profiling/ProfInit.hs +++ b/compiler/profiling/ProfInit.hs @@ -11,6 +11,7 @@ module ProfInit (profilingInitCode) where import CLabel import CostCentre import Outputable +import Platform import StaticFlags import FastString import Module @@ -21,8 +22,8 @@ import Module -- We must produce declarations for the cost-centres defined in this -- module; -profilingInitCode :: Module -> CollectedCCs -> SDoc -profilingInitCode this_mod (local_CCs, ___extern_CCs, singleton_CCSs) +profilingInitCode :: Platform -> Module -> CollectedCCs -> SDoc +profilingInitCode platform this_mod (local_CCs, ___extern_CCs, singleton_CCSs) | not opt_SccProfilingOn = empty | otherwise = vcat @@ -38,8 +39,8 @@ profilingInitCode this_mod (local_CCs, ___extern_CCs, singleton_CCSs) emitRegisterCC cc = ptext (sLit "extern CostCentre ") <> cc_lbl <> ptext (sLit "[];") $$ ptext (sLit "REGISTER_CC(") <> cc_lbl <> char ')' <> semi - where cc_lbl = ppr (mkCCLabel cc) + where cc_lbl = pprPlatform platform (mkCCLabel cc) emitRegisterCCS ccs = ptext (sLit "extern CostCentreStack ") <> ccs_lbl <> ptext (sLit "[];") $$ ptext (sLit "REGISTER_CCS(") <> ccs_lbl <> char ')' <> semi - where ccs_lbl = ppr (mkCCSLabel ccs) + where ccs_lbl = pprPlatform platform (mkCCSLabel ccs) diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index 136a1a2151..cd5d2f8531 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -622,6 +622,8 @@ instance Outputable Bool where instance Outputable Int where ppr n = int n +instance PlatformOutputable Int where + pprPlatform _ = ppr instance Outputable Word16 where ppr n = integer $ fromIntegral n @@ -651,6 +653,9 @@ instance (PlatformOutputable a, PlatformOutputable b) => PlatformOutputable (a, instance Outputable a => Outputable (Maybe a) where ppr Nothing = ptext (sLit "Nothing") ppr (Just x) = ptext (sLit "Just") <+> ppr x +instance PlatformOutputable a => PlatformOutputable (Maybe a) where + pprPlatform _ Nothing = ptext (sLit "Nothing") + pprPlatform platform (Just x) = ptext (sLit "Just") <+> pprPlatform platform x instance (Outputable a, Outputable b) => Outputable (Either a b) where ppr (Left x) = ptext (sLit "Left") <+> ppr x diff --git a/compiler/utils/Platform.hs b/compiler/utils/Platform.hs index 28532aa7f0..362d7822d0 100644 --- a/compiler/utils/Platform.hs +++ b/compiler/utils/Platform.hs @@ -28,6 +28,7 @@ data Platform = Platform { platformArch :: Arch , platformOS :: OS } + deriving (Show, Eq) -- | Architectures that the native code generator knows about. |