Skip to content

GitLab

Glasgow Haskell Compiler
Glasgow Haskell Compiler
Commit ac7a7eb9 authored by Ian Lynagh's avatar Ian Lynagh
Browse files
Options

More CPP removal: pprDynamicLinkerAsmLabel in CLabel 

And some knock-on changes
parent d8d16174
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 1047 additions and 979 deletions
compiler/cmm/CLabel.hs
View file @ ac7a7eb9
......@@ -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
compiler/cmm/CmmBuildInfoTables.hs
View file @ ac7a7eb9
......@@ -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
......
compiler/cmm/CmmInfo.hs
View file @ ac7a7eb9
......@@ -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
......
compiler/cmm/CmmLint.hs
View file @ ac7a7eb9
......@@ -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))
compiler/cmm/CmmPipeline.hs
View file @ ac7a7eb9
......@@ -70,7 +70,8 @@ cmmPipeline hsc_env (topSRT, rst) prog =
-- folding over the groups
(topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops