summaryrefslogtreecommitdiff
path: root/compiler/cmm
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/cmm')
-rw-r--r--compiler/cmm/Bitmap.hs45
-rw-r--r--compiler/cmm/CLabel.hs33
-rw-r--r--compiler/cmm/CmmBuildInfoTables.hs59
-rw-r--r--compiler/cmm/CmmCallConv.hs86
-rw-r--r--compiler/cmm/CmmExpr.hs188
-rw-r--r--compiler/cmm/CmmInfo.hs56
-rw-r--r--compiler/cmm/CmmLayoutStack.hs169
-rw-r--r--compiler/cmm/CmmLint.hs76
-rw-r--r--compiler/cmm/CmmMachOp.hs153
-rw-r--r--compiler/cmm/CmmNode.hs9
-rw-r--r--compiler/cmm/CmmOpt.hs85
-rw-r--r--compiler/cmm/CmmParse.y42
-rw-r--r--compiler/cmm/CmmPipeline.hs9
-rw-r--r--compiler/cmm/CmmRewriteAssignments.hs46
-rw-r--r--compiler/cmm/CmmSink.hs40
-rw-r--r--compiler/cmm/CmmType.hs44
-rw-r--r--compiler/cmm/CmmUtils.hs349
-rw-r--r--compiler/cmm/MkGraph.hs10
-rw-r--r--compiler/cmm/OldCmmLint.hs115
-rw-r--r--compiler/cmm/OldCmmUtils.hs17
-rw-r--r--compiler/cmm/OldPprCmm.hs7
-rw-r--r--compiler/cmm/PprC.hs207
-rw-r--r--compiler/cmm/PprCmm.hs3
-rw-r--r--compiler/cmm/PprCmmExpr.hs10
-rw-r--r--compiler/cmm/SMRep.lhs17
25 files changed, 977 insertions, 898 deletions
diff --git a/compiler/cmm/Bitmap.hs b/compiler/cmm/Bitmap.hs
index 642ae40fdb..93217d5192 100644
--- a/compiler/cmm/Bitmap.hs
+++ b/compiler/cmm/Bitmap.hs
@@ -24,7 +24,7 @@ module Bitmap (
#include "../includes/MachDeps.h"
import SMRep
-import Constants
+import DynFlags
import Util
import Data.Bits
@@ -37,10 +37,10 @@ generated code which need to be emitted as sequences of StgWords.
type Bitmap = [StgWord]
-- | Make a bitmap from a sequence of bits
-mkBitmap :: [Bool] -> Bitmap
-mkBitmap [] = []
-mkBitmap stuff = chunkToBitmap chunk : mkBitmap rest
- where (chunk, rest) = splitAt wORD_SIZE_IN_BITS stuff
+mkBitmap :: DynFlags -> [Bool] -> Bitmap
+mkBitmap _ [] = []
+mkBitmap dflags stuff = chunkToBitmap chunk : mkBitmap dflags rest
+ where (chunk, rest) = splitAt (wORD_SIZE_IN_BITS dflags) stuff
chunkToBitmap :: [Bool] -> StgWord
chunkToBitmap chunk =
@@ -50,31 +50,31 @@ chunkToBitmap chunk =
-- eg. @[0,1,3], size 4 ==> 0xb@.
--
-- The list of @Int@s /must/ be already sorted.
-intsToBitmap :: Int -> [Int] -> Bitmap
-intsToBitmap size slots{- must be sorted -}
+intsToBitmap :: DynFlags -> Int -> [Int] -> Bitmap
+intsToBitmap dflags size slots{- must be sorted -}
| size <= 0 = []
| otherwise =
(foldr (.|.) 0 (map (1 `shiftL`) these)) :
- intsToBitmap (size - wORD_SIZE_IN_BITS)
- (map (\x -> x - wORD_SIZE_IN_BITS) rest)
- where (these,rest) = span (<wORD_SIZE_IN_BITS) slots
+ intsToBitmap dflags (size - wORD_SIZE_IN_BITS dflags)
+ (map (\x -> x - wORD_SIZE_IN_BITS dflags) rest)
+ where (these,rest) = span (< wORD_SIZE_IN_BITS dflags) slots
-- | Make a bitmap where the slots specified are the /zeros/ in the bitmap.
-- eg. @[0,1,3], size 4 ==> 0x4@ (we leave any bits outside the size as zero,
-- just to make the bitmap easier to read).
--
-- The list of @Int@s /must/ be already sorted and duplicate-free.
-intsToReverseBitmap :: Int -> [Int] -> Bitmap
-intsToReverseBitmap size slots{- must be sorted -}
+intsToReverseBitmap :: DynFlags -> Int -> [Int] -> Bitmap
+intsToReverseBitmap dflags size slots{- must be sorted -}
| size <= 0 = []
| otherwise =
- (foldr xor init (map (1 `shiftL`) these)) :
- intsToReverseBitmap (size - wORD_SIZE_IN_BITS)
- (map (\x -> x - wORD_SIZE_IN_BITS) rest)
- where (these,rest) = span (<wORD_SIZE_IN_BITS) slots
- init
- | size >= wORD_SIZE_IN_BITS = complement 0
- | otherwise = (1 `shiftL` size) - 1
+ (foldr xor init (map (1 `shiftL`) these)) :
+ intsToReverseBitmap dflags (size - wORD_SIZE_IN_BITS dflags)
+ (map (\x -> x - wORD_SIZE_IN_BITS dflags) rest)
+ where (these,rest) = span (< wORD_SIZE_IN_BITS dflags) slots
+ init
+ | size >= wORD_SIZE_IN_BITS dflags = complement 0
+ | otherwise = (1 `shiftL` size) - 1
{- |
Magic number, must agree with @BITMAP_BITS_SHIFT@ in InfoTables.h.
@@ -83,9 +83,10 @@ possible, or fall back to an external pointer when the bitmap is too
large. This value represents the largest size of bitmap that can be
packed into a single word.
-}
-mAX_SMALL_BITMAP_SIZE :: Int
-mAX_SMALL_BITMAP_SIZE | wORD_SIZE == 4 = 27
- | otherwise = 58
+mAX_SMALL_BITMAP_SIZE :: DynFlags -> Int
+mAX_SMALL_BITMAP_SIZE dflags
+ | wORD_SIZE dflags == 4 = 27
+ | otherwise = 58
seqBitmap :: Bitmap -> a -> a
seqBitmap = seqList
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index 6ffbbc774d..907f8521e1 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -13,6 +13,7 @@ module CLabel (
mkClosureLabel,
mkSRTLabel,
+ mkModSRTLabel,
mkInfoTableLabel,
mkEntryLabel,
mkSlowEntryLabel,
@@ -104,7 +105,6 @@ module CLabel (
) where
import IdInfo
-import StaticFlags
import BasicTypes
import Packages
import DataCon
@@ -120,6 +120,8 @@ import DynFlags
import Platform
import UniqSet
+import Data.Maybe (isJust)
+
-- -----------------------------------------------------------------------------
-- The CLabel type
@@ -215,6 +217,9 @@ data CLabel
-- | Per-module table of tick locations
| HpcTicksLabel Module
+ -- | Static reference table
+ | SRTLabel (Maybe Module) !Unique
+
-- | Label of an StgLargeSRT
| LargeSRTLabel
{-# UNPACK #-} !Unique
@@ -272,7 +277,9 @@ pprDebugCLabel lbl
data IdLabelInfo
= Closure -- ^ Label for closure
- | SRT -- ^ Static reference table
+ | SRT -- ^ Static reference table (TODO: could be removed
+ -- with the old code generator, but might be needed
+ -- when we implement the New SRT Plan)
| InfoTable -- ^ Info tables for closures; always read-only
| Entry -- ^ Entry point
| Slow -- ^ Slow entry point
@@ -348,6 +355,9 @@ data DynamicLinkerLabelInfo
mkSlowEntryLabel :: Name -> CafInfo -> CLabel
mkSlowEntryLabel name c = IdLabel name c Slow
+mkModSRTLabel :: Maybe Module -> Unique -> CLabel
+mkModSRTLabel mb_mod u = SRTLabel mb_mod u
+
mkSRTLabel :: Name -> CafInfo -> CLabel
mkRednCountsLabel :: Name -> CafInfo -> CLabel
mkSRTLabel name c = IdLabel name c SRT
@@ -582,7 +592,7 @@ needsCDecl :: CLabel -> Bool
-- False <=> it's pre-declared; don't bother
-- don't bother declaring SRT & Bitmap labels, we always make sure
-- they are defined before use.
-needsCDecl (IdLabel _ _ SRT) = False
+needsCDecl (SRTLabel _ _) = False
needsCDecl (LargeSRTLabel _) = False
needsCDecl (LargeBitmapLabel _) = False
needsCDecl (IdLabel _ _ _) = True
@@ -730,6 +740,7 @@ externallyVisibleCLabel (CCS_Label _) = True
externallyVisibleCLabel (DynamicLinkerLabel _ _) = False
externallyVisibleCLabel (HpcTicksLabel _) = True
externallyVisibleCLabel (LargeBitmapLabel _) = False
+externallyVisibleCLabel (SRTLabel mb_mod _) = isJust mb_mod
externallyVisibleCLabel (LargeSRTLabel _) = False
externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel"
externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer"
@@ -777,6 +788,7 @@ labelType (RtsLabel (RtsApFast _)) = CodeLabel
labelType (CaseLabel _ CaseReturnInfo) = DataLabel
labelType (CaseLabel _ _) = CodeLabel
labelType (PlainModuleInitLabel _) = CodeLabel
+labelType (SRTLabel _ _) = CodeLabel
labelType (LargeSRTLabel _) = DataLabel
labelType (LargeBitmapLabel _) = DataLabel
labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel
@@ -808,15 +820,15 @@ labelDynamic :: DynFlags -> PackageId -> CLabel -> Bool
labelDynamic dflags this_pkg lbl =
case lbl of
-- is the RTS in a DLL or not?
- RtsLabel _ -> not opt_Static && (this_pkg /= rtsPackageId)
+ RtsLabel _ -> not (dopt Opt_Static dflags) && (this_pkg /= rtsPackageId)
- IdLabel n _ _ -> isDllName this_pkg n
+ IdLabel n _ _ -> isDllName dflags this_pkg n
-- When compiling in the "dyn" way, each package is to be linked into
-- its own shared library.
CmmLabel pkg _ _
| os == OSMinGW32 ->
- not opt_Static && (this_pkg /= pkg)
+ not (dopt Opt_Static dflags) && (this_pkg /= pkg)
| otherwise ->
True
@@ -834,14 +846,14 @@ labelDynamic dflags this_pkg lbl =
-- When compiling in the "dyn" way, each package is to be
-- linked into its own DLL.
ForeignLabelInPackage pkgId ->
- (not opt_Static) && (this_pkg /= pkgId)
+ (not (dopt Opt_Static dflags)) && (this_pkg /= pkgId)
else -- On Mac OS X and on ELF platforms, false positives are OK,
-- so we claim that all foreign imports come from dynamic
-- libraries
True
- PlainModuleInitLabel m -> not opt_Static && this_pkg /= (modulePackageId m)
+ PlainModuleInitLabel m -> not (dopt Opt_Static dflags) && this_pkg /= (modulePackageId m)
-- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.
_ -> False
@@ -979,6 +991,11 @@ pprCLbl (CaseLabel u (CaseAlt tag))
pprCLbl (CaseLabel u CaseDefault)
= hcat [pprUnique u, ptext (sLit "_dflt")]
+pprCLbl (SRTLabel mb_mod u)
+ = pp_mod <> pprUnique u <> pp_cSEP <> ptext (sLit "srt")
+ where pp_mod | Just mod <- mb_mod = ppr mod <> pp_cSEP
+ | otherwise = empty
+
pprCLbl (LargeSRTLabel u) = pprUnique u <> pp_cSEP <> ptext (sLit "srtd")
pprCLbl (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLit "btm")
-- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7')
diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index 309536b963..30e0addbdc 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -32,10 +32,10 @@ import Bitmap
import CLabel
import Cmm
import CmmUtils
-import IdInfo
import Data.List
+import DynFlags
import Maybes
-import Name
+import Module
import Outputable
import SMRep
import UniqSupply
@@ -137,9 +137,9 @@ instance Outputable TopSRT where
<+> ppr elts
<+> ppr eltmap
-emptySRT :: MonadUnique m => m TopSRT
-emptySRT =
- do top_lbl <- getUniqueM >>= \ u -> return $ mkSRTLabel (mkFCallName u "srt") NoCafRefs
+emptySRT :: MonadUnique m => Maybe Module -> m TopSRT
+emptySRT mb_mod =
+ do top_lbl <- getUniqueM >>= \ u -> return $ mkModSRTLabel mb_mod u
return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = Map.empty }
cafMember :: TopSRT -> CLabel -> Bool
@@ -167,17 +167,17 @@ srtToData srt = [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)]
-- in the SRT. Then, if the number of CAFs is small enough to fit in a bitmap,
-- we make sure they're all close enough to the bottom of the table that the
-- bitmap will be able to cover all of them.
-buildSRT :: TopSRT -> CAFSet -> UniqSM (TopSRT, Maybe CmmDecl, C_SRT)
-buildSRT topSRT cafs =
+buildSRT :: DynFlags -> TopSRT -> CAFSet -> UniqSM (TopSRT, Maybe CmmDecl, C_SRT)
+buildSRT dflags topSRT cafs =
do let
-- For each label referring to a function f without a static closure,
-- replace it with the CAFs that are reachable from f.
sub_srt topSRT localCafs =
let cafs = Set.elems localCafs
mkSRT topSRT =
- do localSRTs <- procpointSRT (lbl topSRT) (elt_map topSRT) cafs
+ do localSRTs <- procpointSRT dflags (lbl topSRT) (elt_map topSRT) cafs
return (topSRT, localSRTs)
- in if length cafs > maxBmpSize then
+ in if length cafs > maxBmpSize dflags then
mkSRT (foldl add_if_missing topSRT cafs)
else -- make sure all the cafs are near the bottom of the srt
mkSRT (add_if_too_far topSRT cafs)
@@ -197,7 +197,7 @@ buildSRT topSRT cafs =
add srt [] = srt
add srt@(TopSRT {next_elt = next}) (caf : rst) =
case cafOffset srt caf of
- Just ix -> if next - ix > maxBmpSize then
+ Just ix -> if next - ix > maxBmpSize dflags then
add (addCAF caf srt) rst
else srt
Nothing -> add (addCAF caf srt) rst
@@ -207,12 +207,12 @@ buildSRT topSRT cafs =
-- Construct an SRT bitmap.
-- Adapted from simpleStg/SRT.lhs, which expects Id's.
-procpointSRT :: CLabel -> Map CLabel Int -> [CLabel] ->
+procpointSRT :: DynFlags -> CLabel -> Map CLabel Int -> [CLabel] ->
UniqSM (Maybe CmmDecl, C_SRT)
-procpointSRT _ _ [] =
+procpointSRT _ _ _ [] =
return (Nothing, NoC_SRT)
-procpointSRT top_srt top_table entries =
- do (top, srt) <- bitmap `seq` to_SRT top_srt offset len bitmap
+procpointSRT dflags top_srt top_table entries =
+ do (top, srt) <- bitmap `seq` to_SRT dflags top_srt offset len bitmap
return (top, srt)
where
ints = map (expectJust "constructSRT" . flip Map.lookup top_table) entries
@@ -220,22 +220,22 @@ procpointSRT top_srt top_table entries =
offset = head sorted_ints
bitmap_entries = map (subtract offset) sorted_ints
len = P.last bitmap_entries + 1
- bitmap = intsToBitmap len bitmap_entries
+ bitmap = intsToBitmap dflags len bitmap_entries
-maxBmpSize :: Int
-maxBmpSize = widthInBits wordWidth `div` 2
+maxBmpSize :: DynFlags -> Int
+maxBmpSize dflags = widthInBits (wordWidth dflags) `div` 2
-- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT.
-to_SRT :: CLabel -> Int -> Int -> Bitmap -> UniqSM (Maybe CmmDecl, C_SRT)
-to_SRT top_srt off len bmp
- | len > maxBmpSize || bmp == [fromIntegral srt_escape]
+to_SRT :: DynFlags -> CLabel -> Int -> Int -> Bitmap -> UniqSM (Maybe CmmDecl, C_SRT)
+to_SRT dflags top_srt off len bmp
+ | len > maxBmpSize dflags || bmp == [fromIntegral srt_escape]
= do id <- getUniqueM
let srt_desc_lbl = mkLargeSRTLabel id
tbl = CmmData RelocatableReadOnlyData $
Statics srt_desc_lbl $ map CmmStaticLit
- ( cmmLabelOffW top_srt off
- : mkWordCLit (fromIntegral len)
- : map mkWordCLit bmp)
+ ( cmmLabelOffW dflags top_srt off
+ : mkWordCLit dflags (fromIntegral len)
+ : map (mkWordCLit dflags) bmp)
return (Just tbl, C_SRT srt_desc_lbl 0 srt_escape)
| otherwise
= return (Nothing, C_SRT top_srt off (fromIntegral (head bmp)))
@@ -319,11 +319,12 @@ flattenCAFSets cpsdecls = zipWith (bundle flatmap) zipped localCAFs
localCAFs = unzipWith localCAFInfo zipped
flatmap = mkTopCAFInfo localCAFs -- transitive closure of localCAFs
-doSRTs :: TopSRT
+doSRTs :: DynFlags
+ -> TopSRT
-> [(CAFEnv, [CmmDecl])]
-> IO (TopSRT, [CmmDecl])
-doSRTs topSRT tops
+doSRTs dflags topSRT tops
= do
let caf_decls = flattenCAFSets tops
us <- mkSplitUniqSupply 'u'
@@ -331,19 +332,19 @@ doSRTs topSRT tops
return (topSRT', reverse gs' {- Note [reverse gs] -})
where
setSRT (topSRT, rst) (caf_map, decl@(CmmProc{})) = do
- (topSRT, srt_tables, srt_env) <- buildSRTs topSRT caf_map
+ (topSRT, srt_tables, srt_env) <- buildSRTs dflags topSRT caf_map
let decl' = updInfoSRTs srt_env decl
return (topSRT, decl': srt_tables ++ rst)
setSRT (topSRT, rst) (_, decl) =
return (topSRT, decl : rst)
-buildSRTs :: TopSRT -> BlockEnv CAFSet
+buildSRTs :: DynFlags -> TopSRT -> BlockEnv CAFSet
-> UniqSM (TopSRT, [CmmDecl], BlockEnv C_SRT)
-buildSRTs top_srt caf_map
+buildSRTs dflags top_srt caf_map
= foldM doOne (top_srt, [], mapEmpty) (mapToList caf_map)
where
doOne (top_srt, decls, srt_env) (l, cafs)
- = do (top_srt, mb_decl, srt) <- buildSRT top_srt cafs
+ = do (top_srt, mb_decl, srt) <- buildSRT dflags top_srt cafs
return ( top_srt, maybeToList mb_decl ++ decls
, mapInsert l srt srt_env )
diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs
index dd1b6af643..235fe7f911 100644
--- a/compiler/cmm/CmmCallConv.hs
+++ b/compiler/cmm/CmmCallConv.hs
@@ -18,7 +18,6 @@ import SMRep
import Cmm (Convention(..))
import PprCmm ()
-import Constants
import qualified Data.List as L
import DynFlags
import Outputable
@@ -46,12 +45,12 @@ assignArgumentsPos dflags conv arg_ty reps = assignments
regs = case (reps, conv) of
(_, NativeNodeCall) -> getRegsWithNode dflags
(_, NativeDirectCall) -> getRegsWithoutNode dflags
- ([_], NativeReturn) -> allRegs
+ ([_], NativeReturn) -> allRegs dflags
(_, NativeReturn) -> getRegsWithNode dflags
-- GC calling convention *must* put values in registers
- (_, GC) -> allRegs
- (_, PrimOpCall) -> allRegs
- ([_], PrimOpReturn) -> allRegs
+ (_, GC) -> allRegs dflags
+ (_, PrimOpCall) -> allRegs dflags
+ ([_], PrimOpReturn) -> allRegs dflags
(_, PrimOpReturn) -> getRegsWithNode dflags
(_, Slow) -> noRegs
-- The calling conventions first assign arguments to registers,
@@ -78,9 +77,9 @@ assignArgumentsPos dflags conv arg_ty reps = assignments
_ -> (assts, (r:rs))
int = case (w, regs) of
(W128, _) -> panic "W128 unsupported register type"
- (_, (v:vs, fs, ds, ls)) | widthInBits w <= widthInBits wordWidth
+ (_, (v:vs, fs, ds, ls)) | widthInBits w <= widthInBits (wordWidth dflags)
-> k (RegisterParam (v gcp), (vs, fs, ds, ls))
- (_, (vs, fs, ds, l:ls)) | widthInBits w > widthInBits wordWidth
+ (_, (vs, fs, ds, l:ls)) | widthInBits w > widthInBits (wordWidth dflags)
-> k (RegisterParam l, (vs, fs, ds, ls))
_ -> (assts, (r:rs))
k (asst, regs') = assign_regs ((r, asst) : assts) rs regs'
@@ -92,7 +91,7 @@ assignArgumentsPos dflags conv arg_ty reps = assignments
assign_stk _ assts [] = assts
assign_stk offset assts (r:rs) = assign_stk off' ((r, StackParam off') : assts) rs
where w = typeWidth (arg_ty r)
- size = (((widthInBytes w - 1) `div` wORD_SIZE) + 1) * wORD_SIZE
+ size = (((widthInBytes w - 1) `div` wORD_SIZE dflags) + 1) * wORD_SIZE dflags
off' = offset + size
-----------------------------------------------------------------------------
@@ -111,46 +110,51 @@ type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs.
-- that are guaranteed to map to machine registers.
getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs
-getRegsWithoutNode _dflags =
- ( filter (\r -> r VGcPtr /= node) realVanillaRegs
- , realFloatRegs
- , realDoubleRegs
- , realLongRegs )
+getRegsWithoutNode dflags =
+ ( filter (\r -> r VGcPtr /= node) (realVanillaRegs dflags)
+ , realFloatRegs dflags
+ , realDoubleRegs dflags
+ , realLongRegs dflags)
-- getRegsWithNode uses R1/node even if it isn't a register
-getRegsWithNode _dflags =
- ( if null realVanillaRegs then [VanillaReg 1] else realVanillaRegs
- , realFloatRegs
- , realDoubleRegs
- , realLongRegs )
-
-allFloatRegs, allDoubleRegs, allLongRegs :: [GlobalReg]
-allVanillaRegs :: [VGcPtr -> GlobalReg]
-
-allVanillaRegs = map VanillaReg $ regList mAX_Vanilla_REG
-allFloatRegs = map FloatReg $ regList mAX_Float_REG
-allDoubleRegs = map DoubleReg $ regList mAX_Double_REG
-allLongRegs = map LongReg $ regList mAX_Long_REG
-
-realFloatRegs, realDoubleRegs, realLongRegs :: [GlobalReg]
-realVanillaRegs :: [VGcPtr -> GlobalReg]
-
-realVanillaRegs = map VanillaReg $ regList mAX_Real_Vanilla_REG
-realFloatRegs = map FloatReg $ regList mAX_Real_Float_REG
-realDoubleRegs = map DoubleReg $ regList mAX_Real_Double_REG
-realLongRegs = map LongReg $ regList mAX_Real_Long_REG
+getRegsWithNode dflags =
+ ( if null (realVanillaRegs dflags)
+ then [VanillaReg 1]
+ else realVanillaRegs dflags
+ , realFloatRegs dflags
+ , realDoubleRegs dflags
+ , realLongRegs dflags)
+
+allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg]
+allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]
+
+allVanillaRegs dflags = map VanillaReg $ regList (mAX_Vanilla_REG dflags)
+allFloatRegs dflags = map FloatReg $ regList (mAX_Float_REG dflags)
+allDoubleRegs dflags = map DoubleReg $ regList (mAX_Double_REG dflags)
+allLongRegs dflags = map LongReg $ regList (mAX_Long_REG dflags)
+
+realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg]
+realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]
+
+realVanillaRegs dflags = map VanillaReg $ regList (mAX_Real_Vanilla_REG dflags)
+realFloatRegs dflags = map FloatReg $ regList (mAX_Real_Float_REG dflags)
+realDoubleRegs dflags = map DoubleReg $ regList (mAX_Real_Double_REG dflags)
+realLongRegs dflags = map LongReg $ regList (mAX_Real_Long_REG dflags)
regList :: Int -> [Int]
regList n = [1 .. n]
-allRegs :: AvailRegs
-allRegs = (allVanillaRegs, allFloatRegs, allDoubleRegs, allLongRegs)
+allRegs :: DynFlags -> AvailRegs
+allRegs dflags = (allVanillaRegs dflags,
+ allFloatRegs dflags,
+ allDoubleRegs dflags,
+ allLongRegs dflags)
noRegs :: AvailRegs
noRegs = ([], [], [], [])
-globalArgRegs :: [GlobalReg]
-globalArgRegs = map ($VGcPtr) allVanillaRegs ++
- allFloatRegs ++
- allDoubleRegs ++
- allLongRegs
+globalArgRegs :: DynFlags -> [GlobalReg]
+globalArgRegs dflags = map ($ VGcPtr) (allVanillaRegs dflags) ++
+ allFloatRegs dflags ++
+ allDoubleRegs dflags ++
+ allLongRegs dflags
diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs
index a6b9b11e5f..128eb1ca62 100644
--- a/compiler/cmm/CmmExpr.hs
+++ b/compiler/cmm/CmmExpr.hs
@@ -1,18 +1,11 @@
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
module CmmExpr
( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr
, CmmReg(..), cmmRegType
, CmmLit(..), cmmLitType
, LocalReg(..), localRegType
, GlobalReg(..), globalRegType, spReg, hpReg, spLimReg, nodeReg, node, baseReg
- , VGcPtr(..), vgcFlag -- Temporary!
+ , VGcPtr(..), vgcFlag -- Temporary!
, DefinerOfLocalRegs, UserOfLocalRegs, foldRegsDefd, foldRegsUsed, filterRegsUsed
, RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
, plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet
@@ -30,13 +23,14 @@ import CmmType
import CmmMachOp
import BlockId
import CLabel
+import DynFlags
import Unique
import Data.Set (Set)
import qualified Data.Set as Set
-----------------------------------------------------------------------------
--- CmmExpr
+-- CmmExpr
-- An expression. Expressions have no side effects.
-----------------------------------------------------------------------------
@@ -48,21 +42,21 @@ data CmmExpr
| CmmStackSlot Area {-# UNPACK #-} !Int
-- addressing expression of a stack slot
| CmmRegOff !CmmReg Int
- -- CmmRegOff reg i
- -- ** is shorthand only, meaning **
- -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]
- -- where rep = typeWidth (cmmRegType reg)
-
-instance Eq CmmExpr where -- Equality ignores the types
- CmmLit l1 == CmmLit l2 = l1==l2
- CmmLoad e1 _ == CmmLoad e2 _ = e1==e2
- CmmReg r1 == CmmReg r2 = r1==r2
- CmmRegOff r1 i1 == CmmRegOff r2 i2 = r1==r2 && i1==i2
- CmmMachOp op1 es1 == CmmMachOp op2 es2 = op1==op2 && es1==es2
+ -- CmmRegOff reg i
+ -- ** is shorthand only, meaning **
+ -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]
+ -- where rep = typeWidth (cmmRegType reg)
+
+instance Eq CmmExpr where -- Equality ignores the types
+ CmmLit l1 == CmmLit l2 = l1==l2
+ CmmLoad e1 _ == CmmLoad e2 _ = e1==e2
+ CmmReg r1 == CmmReg r2 = r1==r2
+ CmmRegOff r1 i1 == CmmRegOff r2 i2 = r1==r2 && i1==i2
+ CmmMachOp op1 es1 == CmmMachOp op2 es2 = op1==op2 && es1==es2
CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2
- _e1 == _e2 = False
+ _e1 == _e2 = False
-data CmmReg
+data CmmReg
= CmmLocal {-# UNPACK #-} !LocalReg
| CmmGlobal GlobalReg
deriving( Eq, Ord )
@@ -75,14 +69,14 @@ data Area
-- See Note [Continuation BlockId] in CmmNode.
deriving (Eq, Ord)
-{- Note [Old Area]
+{- Note [Old Area]
~~~~~~~~~~~~~~~~~~
There is a single call area 'Old', allocated at the extreme old
end of the stack frame (ie just younger than the return address)
which holds:
- * incoming (overflow) parameters,
+ * incoming (overflow) parameters,
* outgoing (overflow) parameter to tail calls,
- * outgoing (overflow) result values
+ * outgoing (overflow) result values
* the update frame (if any)
Its size is the max of all these requirements. On entry, the stack
@@ -93,22 +87,22 @@ End of note -}
data CmmLit
= CmmInt !Integer Width
- -- Interpretation: the 2's complement representation of the value
- -- is truncated to the specified size. This is easier than trying
- -- to keep the value within range, because we don't know whether
- -- it will be used as a signed or unsigned value (the CmmType doesn't
- -- distinguish between signed & unsigned).
+ -- Interpretation: the 2's complement representation of the value
+ -- is truncated to the specified size. This is easier than trying
+ -- to keep the value within range, because we don't know whether
+ -- it will be used as a signed or unsigned value (the CmmType doesn't
+ -- distinguish between signed & unsigned).
| CmmFloat Rational Width
- | CmmLabel CLabel -- Address of label
- | CmmLabelOff CLabel Int -- Address of label + byte offset
-
+ | CmmLabel CLabel -- Address of label
+ | CmmLabelOff CLabel Int -- Address of label + byte offset
+
-- Due to limitations in the C backend, the following
-- MUST ONLY be used inside the info table indicated by label2
-- (label2 must be the info label), and label1 must be an
-- SRT, a slow entrypoint or a large bitmap (see the Mangler)
-- Don't use it at all unless tablesNextToCode.
-- It is also used inside the NCG during when generating
- -- position-independent code.
+ -- position-independent code.
| CmmLabelDiffOff CLabel CLabel Int -- label1 - label2 + offset
| CmmBlock {-# UNPACK #-} !BlockId -- Code label
@@ -118,31 +112,32 @@ data CmmLit
| CmmHighStackMark -- stands for the max stack space used during a procedure
deriving Eq
-cmmExprType :: CmmExpr -> CmmType
-cmmExprType (CmmLit lit) = cmmLitType lit
-cmmExprType (CmmLoad _ rep) = rep
-cmmExprType (CmmReg reg) = cmmRegType reg
-cmmExprType (CmmMachOp op args) = machOpResultType op (map cmmExprType args)
-cmmExprType (CmmRegOff reg _) = cmmRegType reg
-cmmExprType (CmmStackSlot _ _) = bWord -- an address
+cmmExprType :: DynFlags -> CmmExpr -> CmmType
+cmmExprType dflags (CmmLit lit) = cmmLitType dflags lit
+cmmExprType _ (CmmLoad _ rep) = rep
+cmmExprType dflags (CmmReg reg) = cmmRegType dflags reg
+cmmExprType dflags (CmmMachOp op args) = machOpResultType dflags op (map (cmmExprType dflags) args)
+cmmExprType dflags (CmmRegOff reg _) = cmmRegType dflags reg
+cmmExprType dflags (CmmStackSlot _ _) = bWord dflags -- an address
-- Careful though: what is stored at the stack slot may be bigger than
-- an address
-cmmLitType :: CmmLit -> CmmType
-cmmLitType (CmmInt _ width) = cmmBits width
-cmmLitType (CmmFloat _ width) = cmmFloat width
-cmmLitType (CmmLabel lbl) = cmmLabelType lbl
-cmmLitType (CmmLabelOff lbl _) = cmmLabelType lbl
-cmmLitType (CmmLabelDiffOff {}) = bWord
-cmmLitType (CmmBlock _) = bWord
-cmmLitType (CmmHighStackMark) = bWord
+cmmLitType :: DynFlags -> CmmLit -> CmmType
+cmmLitType _ (CmmInt _ width) = cmmBits width
+cmmLitType _ (CmmFloat _ width) = cmmFloat width
+cmmLitType dflags (CmmLabel lbl) = cmmLabelType dflags lbl
+cmmLitType dflags (CmmLabelOff lbl _) = cmmLabelType dflags lbl
+cmmLitType dflags (CmmLabelDiffOff {}) = bWord dflags
+cmmLitType dflags (CmmBlock _) = bWord dflags
+cmmLitType dflags (CmmHighStackMark) = bWord dflags
-cmmLabelType :: CLabel -> CmmType
-cmmLabelType lbl | isGcPtrLabel lbl = gcWord
- | otherwise = bWord
+cmmLabelType :: DynFlags -> CLabel -> CmmType
+cmmLabelType dflags lbl
+ | isGcPtrLabel lbl = gcWord dflags
+ | otherwise = bWord dflags
-cmmExprWidth :: CmmExpr -> Width
-cmmExprWidth e = typeWidth (cmmExprType e)
+cmmExprWidth :: DynFlags -> CmmExpr -> Width
+cmmExprWidth dflags e = typeWidth (cmmExprType dflags e)
--------
--- Negation for conditional branches
@@ -153,7 +148,7 @@ maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op
maybeInvertCmmExpr _ = Nothing
-----------------------------------------------------------------------------
--- Local registers
+-- Local registers
-----------------------------------------------------------------------------
data LocalReg
@@ -171,15 +166,15 @@ instance Ord LocalReg where
instance Uniquable LocalReg where
getUnique (LocalReg uniq _) = uniq
-cmmRegType :: CmmReg -> CmmType
-cmmRegType (CmmLocal reg) = localRegType reg
-cmmRegType (CmmGlobal reg) = globalRegType reg
+cmmRegType :: DynFlags -> CmmReg -> CmmType
+cmmRegType _ (CmmLocal reg) = localRegType reg
+cmmRegType dflags (CmmGlobal reg) = globalRegType dflags reg
localRegType :: LocalReg -> CmmType
localRegType (LocalReg _ rep) = rep
-----------------------------------------------------------------------------
--- Register-use information for expressions and other types
+-- Register-use information for expressions and other types
-----------------------------------------------------------------------------
-- | Sets of local registers
@@ -270,58 +265,58 @@ instance DefinerOfLocalRegs a => DefinerOfLocalRegs (Maybe a) where
-- Another reg utility
regUsedIn :: CmmReg -> CmmExpr -> Bool
-_ `regUsedIn` CmmLit _ = False
-reg `regUsedIn` CmmLoad e _ = reg `regUsedIn` e
-reg `regUsedIn` CmmReg reg' = reg == reg'
+_ `regUsedIn` CmmLit _ = False
+reg `regUsedIn` CmmLoad e _ = reg `regUsedIn` e
+reg `regUsedIn` CmmReg reg' = reg == reg'
reg `regUsedIn` CmmRegOff reg' _ = reg == reg'
reg `regUsedIn` CmmMachOp _ es = any (reg `regUsedIn`) es
_ `regUsedIn` CmmStackSlot _ _ = False
-----------------------------------------------------------------------------
--- Global STG registers
+-- Global STG registers
-----------------------------------------------------------------------------
data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show )
- -- TEMPORARY!!!
+ -- TEMPORARY!!!
-----------------------------------------------------------------------------
--- Global STG registers
+-- Global STG registers
-----------------------------------------------------------------------------
vgcFlag :: CmmType -> VGcPtr
vgcFlag ty | isGcPtrType ty = VGcPtr
- | otherwise = VNonGcPtr
+ | otherwise = VNonGcPtr
data GlobalReg
-- Argument and return registers
- = VanillaReg -- pointers, unboxed ints and chars
- {-# UNPACK #-} !Int -- its number
- VGcPtr
+ = VanillaReg -- pointers, unboxed ints and chars
+ {-# UNPACK #-} !Int -- its number
+ VGcPtr
- | FloatReg -- single-precision floating-point registers
- {-# UNPACK #-} !Int -- its number
+ | FloatReg -- single-precision floating-point registers
+ {-# UNPACK #-} !Int -- its number
- | DoubleReg -- double-precision floating-point registers
- {-# UNPACK #-} !Int -- its number
+ | DoubleReg -- double-precision floating-point registers
+ {-# UNPACK #-} !Int -- its number
- | LongReg -- long int registers (64-bit, really)
- {-# UNPACK #-} !Int -- its number
+ | LongReg -- long int registers (64-bit, really)
+ {-# UNPACK #-} !Int -- its number
-- STG registers
- | Sp -- Stack ptr; points to last occupied stack location.
- | SpLim -- Stack limit
- | Hp -- Heap ptr; points to last occupied heap location.
- | HpLim -- Heap limit register
+ | Sp -- Stack ptr; points to last occupied stack location.
+ | SpLim -- Stack limit
+ | Hp -- Heap ptr; points to last occupied heap location.
+ | HpLim -- Heap limit register
| CCCS -- Current cost-centre stack
| CurrentTSO -- pointer to current thread's TSO
- | CurrentNursery -- pointer to allocation area
- | HpAlloc -- allocation count for heap check failure
+ | CurrentNursery -- pointer to allocation area
+ | HpAlloc -- allocation count for heap check failure
- -- We keep the address of some commonly-called
- -- functions in the register table, to keep code
- -- size down:
+ -- We keep the address of some commonly-called
+ -- functions in the register table, to keep code
+ -- size down:
| EagerBlackholeInfo -- stg_EAGER_BLACKHOLE_info
- | GCEnter1 -- stg_gc_enter_1
- | GCFun -- stg_gc_fun
+ | GCEnter1 -- stg_gc_enter_1
+ | GCFun -- stg_gc_fun
-- Base offset for the register table, used for accessing registers
-- which do not have real registers assigned to them. This register
@@ -337,7 +332,7 @@ data GlobalReg
deriving( Show )
instance Eq GlobalReg where
- VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes
+ VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes
FloatReg i == FloatReg j = i==j
DoubleReg i == DoubleReg j = i==j
LongReg i == LongReg j = i==j
@@ -419,12 +414,13 @@ nodeReg = CmmGlobal node
node :: GlobalReg
node = VanillaReg 1 VGcPtr
-globalRegType :: GlobalReg -> CmmType
-globalRegType (VanillaReg _ VGcPtr) = gcWord
-globalRegType (VanillaReg _ VNonGcPtr) = bWord
-globalRegType (FloatReg _) = cmmFloat W32
-globalRegType (DoubleReg _) = cmmFloat W64
-globalRegType (LongReg _) = cmmBits W64
-globalRegType Hp = gcWord -- The initialiser for all
- -- dynamically allocated closures
-globalRegType _ = bWord
+globalRegType :: DynFlags -> GlobalReg -> CmmType
+globalRegType dflags (VanillaReg _ VGcPtr) = gcWord dflags
+globalRegType dflags (VanillaReg _ VNonGcPtr) = bWord dflags
+globalRegType _ (FloatReg _) = cmmFloat W32
+globalRegType _ (DoubleReg _) = cmmFloat W64
+globalRegType _ (LongReg _) = cmmBits W64
+globalRegType dflags Hp = gcWord dflags
+ -- The initialiser for all
+ -- dynamically allocated closures
+globalRegType dflags _ = bWord dflags
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index 29affaef0b..0735937754 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -24,7 +24,6 @@ import qualified Stream
import Hoopl
import Maybes
-import Constants
import DynFlags
import Panic
import UniqSupply
@@ -114,8 +113,8 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks)
-- Use a zero place-holder in place of the
-- entry-label in the info table
return (top_decls ++
- [mkRODataLits info_lbl (zeroCLit : rel_std_info ++
- rel_extra_bits)])
+ [mkRODataLits info_lbl (zeroCLit dflags : rel_std_info ++
+ rel_extra_bits)])
_nonempty ->
-- Separately emit info table (with the function entry
-- point as first entry) and the entry code
@@ -172,9 +171,9 @@ mkInfoTableContents dflags
-- (which in turn came from a handwritten .cmm file)
| StackRep frame <- smrep
- = do { (prof_lits, prof_data) <- mkProfLits prof
- ; let (srt_label, srt_bitmap) = mkSRTLit srt
- ; (liveness_lit, liveness_data) <- mkLivenessBits frame
+ = do { (prof_lits, prof_data) <- mkProfLits dflags prof
+ ; let (srt_label, srt_bitmap) = mkSRTLit dflags srt
+ ; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame
; let
std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit
rts_tag | Just tag <- mb_rts_tag = tag
@@ -184,9 +183,9 @@ mkInfoTableContents dflags
; return (prof_data ++ liveness_data, (std_info, srt_label)) }
| HeapRep _ ptrs nonptrs closure_type <- smrep
- = do { let layout = packHalfWordsCLit ptrs nonptrs
- ; (prof_lits, prof_data) <- mkProfLits prof
- ; let (srt_label, srt_bitmap) = mkSRTLit srt
+ = do { let layout = packHalfWordsCLit dflags ptrs nonptrs
+ ; (prof_lits, prof_data) <- mkProfLits dflags prof
+ ; let (srt_label, srt_bitmap) = mkSRTLit dflags srt
; (mb_srt_field, mb_layout, extra_bits, ct_data)
<- mk_pieces closure_type srt_label
; let std_info = mkStdInfoTable dflags prof_lits
@@ -208,24 +207,24 @@ mkInfoTableContents dflags
= return (Nothing, Nothing, srt_label, [])
mk_pieces (ThunkSelector offset) _no_srt
- = return (Just 0, Just (mkWordCLit offset), [], [])
+ = return (Just 0, Just (mkWordCLit dflags offset), [], [])
-- Layout known (one free var); we use the layout field for offset
mk_pieces (Fun arity (ArgSpec fun_type)) srt_label
- = do { let extra_bits = packHalfWordsCLit fun_type arity : srt_label
+ = do { let extra_bits = packHalfWordsCLit dflags fun_type arity : srt_label
; return (Nothing, Nothing, extra_bits, []) }
mk_pieces (Fun arity (ArgGen arg_bits)) srt_label
- = do { (liveness_lit, liveness_data) <- mkLivenessBits arg_bits
+ = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits
; let fun_type | null liveness_data = aRG_GEN
| otherwise = aRG_GEN_BIG
- extra_bits = [ packHalfWordsCLit fun_type arity
+ extra_bits = [ packHalfWordsCLit dflags fun_type arity
, srt_lit, liveness_lit, slow_entry ]
; return (Nothing, Nothing, extra_bits, liveness_data) }
where
slow_entry = CmmLabel (toSlowEntryLbl info_lbl)
srt_lit = case srt_label of
- [] -> mkIntCLit 0
+ [] -> mkIntCLit dflags 0
(lit:_rest) -> ASSERT( null _rest ) lit
mk_pieces BlackHole _ = panic "mk_pieces: BlackHole"
@@ -233,11 +232,12 @@ mkInfoTableContents dflags
mkInfoTableContents _ _ _ = panic "mkInfoTableContents" -- NonInfoTable dealt with earlier
-mkSRTLit :: C_SRT
+mkSRTLit :: DynFlags
+ -> C_SRT
-> ([CmmLit], -- srt_label, if any
StgHalfWord) -- srt_bitmap
-mkSRTLit NoC_SRT = ([], 0)
-mkSRTLit (C_SRT lbl off bitmap) = ([cmmLabelOffW lbl off], bitmap)
+mkSRTLit _ NoC_SRT = ([], 0)
+mkSRTLit dflags (C_SRT lbl off bitmap) = ([cmmLabelOffW dflags lbl off], bitmap)
-------------------------------------------------------------------------
@@ -297,34 +297,34 @@ makeRelativeRefTo _ _ lit = lit
-- The head of the stack layout is the top of the stack and
-- the least-significant bit.
-mkLivenessBits :: Liveness -> UniqSM (CmmLit, [RawCmmDecl])
+mkLivenessBits :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl])
-- ^ Returns:
-- 1. The bitmap (literal value or label)
-- 2. Large bitmap CmmData if needed
-mkLivenessBits liveness
- | n_bits > mAX_SMALL_BITMAP_SIZE -- does not fit in one word
+mkLivenessBits dflags liveness
+ | n_bits > mAX_SMALL_BITMAP_SIZE dflags -- does not fit in one word
= do { uniq <- getUniqueUs
; let bitmap_lbl = mkBitmapLabel uniq
; return (CmmLabel bitmap_lbl,
[mkRODataLits bitmap_lbl lits]) }
| otherwise -- Fits in one word
- = return (mkWordCLit bitmap_word, [])
+ = return (mkWordCLit dflags bitmap_word, [])
where
n_bits = length liveness
bitmap :: Bitmap
- bitmap = mkBitmap liveness
+ bitmap = mkBitmap dflags liveness
small_bitmap = case bitmap of
[] -> 0
[b] -> b
_ -> panic "mkLiveness"
bitmap_word = fromIntegral n_bits
- .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT)
+ .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags)
- lits = mkWordCLit (fromIntegral n_bits) : map mkWordCLit bitmap
+ lits = mkWordCLit dflags (fromIntegral n_bits) : map (mkWordCLit dflags) bitmap
-- The first word is the size. The structure must match
-- StgLargeBitmap in includes/rts/storage/InfoTable.h
@@ -361,7 +361,7 @@ mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit
| dopt Opt_SccProfilingOn dflags = [type_descr, closure_descr]
| otherwise = []
- type_lit = packHalfWordsCLit cl_type srt_len
+ type_lit = packHalfWordsCLit dflags cl_type srt_len
-------------------------------------------------------------------------
--
@@ -369,9 +369,9 @@ mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit
--
-------------------------------------------------------------------------
-mkProfLits :: ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])
-mkProfLits NoProfilingInfo = return ((zeroCLit, zeroCLit), [])
-mkProfLits (ProfilingInfo td cd)
+mkProfLits :: DynFlags -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])
+mkProfLits dflags NoProfilingInfo = return ((zeroCLit dflags, zeroCLit dflags), [])
+mkProfLits _ (ProfilingInfo td cd)
= do { (td_lit, td_decl) <- newStringLit td
; (cd_lit, cd_decl) <- newStringLit cd
; return ((td_lit,cd_lit), [td_decl,cd_decl]) }
diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index 98008d5d0d..5505b92f5a 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -17,7 +17,6 @@ import CmmLive
import CmmProcPoint
import SMRep
import Hoopl
-import Constants
import UniqSupply
import Maybes
import UniqFM
@@ -120,7 +119,7 @@ cmmLayoutStack dflags procpoints entry_args
(final_stackmaps, _final_high_sp, new_blocks) <-
mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->
- layout procpoints liveness entry entry_args
+ layout dflags procpoints liveness entry entry_args
rec_stackmaps rec_high_sp blocks
new_blocks' <- mapM (lowerSafeForeignCall dflags) new_blocks
@@ -130,7 +129,8 @@ cmmLayoutStack dflags procpoints entry_args
-layout :: BlockSet -- proc points
+layout :: DynFlags
+ -> BlockSet -- proc points
-> BlockEnv CmmLive -- liveness
-> BlockId -- entry
-> ByteOff -- stack args on entry
@@ -146,7 +146,7 @@ layout :: BlockSet -- proc points
, [CmmBlock] -- [out] new blocks
)
-layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks
+layout dflags procpoints liveness entry entry_args final_stackmaps final_hwm blocks
= go blocks init_stackmap entry_args []
where
(updfr, cont_info) = collectContInfo blocks
@@ -187,7 +187,7 @@ layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks
-- each of the successor blocks. See handleLastNode for
-- details.
(middle2, sp_off, last1, fixup_blocks, out)
- <- handleLastNode procpoints liveness cont_info
+ <- handleLastNode dflags procpoints liveness cont_info
acc_stackmaps stack1 middle0 last0
-- pprTrace "layout(out)" (ppr out) $ return ()
@@ -210,7 +210,7 @@ layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks
-- beginning of a proc, and we don't modify Sp before the
-- check.
- final_blocks = manifestSp final_stackmaps stack0 sp0 sp_high entry0
+ final_blocks = manifestSp dflags final_stackmaps stack0 sp0 sp_high entry0
middle_pre sp_off last1 fixup_blocks
acc_stackmaps' = mapUnion acc_stackmaps out
@@ -317,7 +317,7 @@ getStackLoc (Young l) n stackmaps =
-- extra code that goes *after* the Sp adjustment.
handleLastNode
- :: ProcPointSet -> BlockEnv CmmLive -> BlockEnv ByteOff
+ :: DynFlags -> ProcPointSet -> BlockEnv CmmLive -> BlockEnv ByteOff
-> BlockEnv StackMap -> StackMap
-> Block CmmNode O O
-> CmmNode O C
@@ -329,7 +329,7 @@ handleLastNode
, BlockEnv StackMap -- stackmaps for the continuations
)
-handleLastNode procpoints liveness cont_info stackmaps
+handleLastNode dflags procpoints liveness cont_info stackmaps
stack0@StackMap { sm_sp = sp0 } middle last
= case last of
-- At each return / tail call,
@@ -344,7 +344,7 @@ handleLastNode procpoints liveness cont_info stackmaps
return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off
CmmForeignCall{ succ = cont_lbl, .. } -> do
- return $ lastCall cont_lbl wORD_SIZE wORD_SIZE (sm_ret_off stack0)
+ return $ lastCall cont_lbl (wORD_SIZE dflags) (wORD_SIZE dflags) (sm_ret_off stack0)
-- one word each for args and results: the return address
CmmBranch{..} -> handleBranches
@@ -380,7 +380,7 @@ handleLastNode procpoints liveness cont_info stackmaps
= (save_assignments, new_cont_stack)
where
(new_cont_stack, save_assignments)
- = setupStackFrame lbl liveness cml_ret_off cml_ret_args stack0
+ = setupStackFrame dflags lbl liveness cml_ret_off cml_ret_args stack0
-- For other last nodes (branches), if any of the targets is a
@@ -403,7 +403,7 @@ handleLastNode procpoints liveness cont_info stackmaps
out = mapFromList [ (l', cont_stack)
| l' <- successors last ]
return ( assigs
- , spOffsetForCall sp0 cont_stack wORD_SIZE
+ , spOffsetForCall sp0 cont_stack (wORD_SIZE dflags)
, last
, []
, out)
@@ -428,7 +428,7 @@ handleLastNode procpoints liveness cont_info stackmaps
| Just stack2 <- mapLookup l stackmaps
= do
let assigs = fixupStack stack0 stack2
- (tmp_lbl, block) <- makeFixupBlock sp0 l stack2 assigs
+ (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 assigs
return (l, tmp_lbl, stack2, block)
-- (b) if the successor is a proc point, save everything
@@ -439,10 +439,10 @@ handleLastNode procpoints liveness cont_info stackmaps
(stack2, assigs) =
--pprTrace "first visit to proc point"
-- (ppr l <+> ppr stack1) $
- setupStackFrame l liveness (sm_ret_off stack0)
+ setupStackFrame dflags l liveness (sm_ret_off stack0)
cont_args stack0
--
- (tmp_lbl, block) <- makeFixupBlock sp0 l stack2 assigs
+ (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 assigs
return (l, tmp_lbl, stack2, block)
-- (c) otherwise, the current StackMap is the StackMap for
@@ -456,14 +456,15 @@ handleLastNode procpoints liveness cont_info stackmaps
is_live (r,_) = r `elemRegSet` live
-makeFixupBlock :: ByteOff -> Label -> StackMap -> [CmmNode O O] -> UniqSM (Label, [CmmBlock])
-makeFixupBlock sp0 l stack assigs
+makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap -> [CmmNode O O]
+ -> UniqSM (Label, [CmmBlock])
+makeFixupBlock dflags sp0 l stack assigs
| null assigs && sp0 == sm_sp stack = return (l, [])
| otherwise = do
tmp_lbl <- liftM mkBlockId $ getUniqueM
let sp_off = sp0 - sm_sp stack
block = blockJoin (CmmEntry tmp_lbl)
- (maybeAddSpAdj sp_off (blockFromList assigs))
+ (maybeAddSpAdj dflags sp_off (blockFromList assigs))
(CmmBranch l)
return (tmp_lbl, [block])
@@ -494,14 +495,15 @@ fixupStack old_stack new_stack = concatMap move new_locs
setupStackFrame
- :: BlockId -- label of continuation
+ :: DynFlags
+ -> BlockId -- label of continuation
-> BlockEnv CmmLive -- liveness
-> ByteOff -- updfr
-> ByteOff -- bytes of return values on stack
-> StackMap -- current StackMap
-> (StackMap, [CmmNode O O])
-setupStackFrame lbl liveness updfr_off ret_args stack0
+setupStackFrame dflags lbl liveness updfr_off ret_args stack0
= (cont_stack, assignments)
where
-- get the set of LocalRegs live in the continuation
@@ -517,7 +519,7 @@ setupStackFrame lbl liveness updfr_off ret_args stack0
-- everything up to updfr_off is off-limits
-- stack1 contains updfr_off, plus everything we need to save
- (stack1, assignments) = allocate updfr_off live stack0
+ (stack1, assignments) = allocate dflags updfr_off live stack0
-- And the Sp at the continuation is:
-- sm_sp stack1 + ret_args
@@ -598,9 +600,10 @@ futureContinuation middle = foldBlockNodesB f middle Nothing
-- on the stack and return the new StackMap and the assignments to do
-- the saving.
--
-allocate :: ByteOff -> RegSet -> StackMap -> (StackMap, [CmmNode O O])
-allocate ret_off live stackmap@StackMap{ sm_sp = sp0
- , sm_regs = regs0 }
+allocate :: DynFlags -> ByteOff -> RegSet -> StackMap
+ -> (StackMap, [CmmNode O O])
+allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0
+ , sm_regs = regs0 }
=
-- pprTrace "allocate" (ppr live $$ ppr stackmap) $
@@ -611,37 +614,37 @@ allocate ret_off live stackmap@StackMap{ sm_sp = sp0
-- make a map of the stack
let stack = reverse $ Array.elems $
- accumArray (\_ x -> x) Empty (1, toWords (max sp0 ret_off)) $
+ accumArray (\_ x -> x) Empty (1, toWords dflags (max sp0 ret_off)) $
ret_words ++ live_words
where ret_words =
[ (x, Occupied)
- | x <- [ 1 .. toWords ret_off] ]
+ | x <- [ 1 .. toWords dflags ret_off] ]
live_words =
- [ (toWords x, Occupied)
+ [ (toWords dflags x, Occupied)
| (r,off) <- eltsUFM regs1,
- let w = localRegBytes r,
- x <- [ off, off-wORD_SIZE .. off - w + 1] ]
+ let w = localRegBytes dflags r,
+ x <- [ off, off - wORD_SIZE dflags .. off - w + 1] ]
in
-- Pass over the stack: find slots to save all the new live variables,
-- choosing the oldest slots first (hence a foldr).
let
save slot ([], stack, n, assigs, regs) -- no more regs to save
- = ([], slot:stack, n `plusW` 1, assigs, regs)
+ = ([], slot:stack, plusW dflags n 1, assigs, regs)
save slot (to_save, stack, n, assigs, regs)
= case slot of
- Occupied -> (to_save, Occupied:stack, n `plusW` 1, assigs, regs)
+ Occupied -> (to_save, Occupied:stack, plusW dflags n 1, assigs, regs)
Empty
| Just (stack', r, to_save') <-
select_save to_save (slot:stack)
-> let assig = CmmStore (CmmStackSlot Old n')
(CmmReg (CmmLocal r))
- n' = n `plusW` 1
+ n' = plusW dflags n 1
in
(to_save', stack', n', assig : assigs, (r,(r,n')):regs)
| otherwise
- -> (to_save, slot:stack, n `plusW` 1, assigs, regs)
+ -> (to_save, slot:stack, plusW dflags n 1, assigs, regs)
-- we should do better here: right now we'll fit the smallest first,
-- but it would make more sense to fit the biggest first.
@@ -654,7 +657,7 @@ allocate ret_off live stackmap@StackMap{ sm_sp = sp0
= Just (replicate words Occupied ++ rest, r, rs++no_fit)
| otherwise
= go rs (r:no_fit)
- where words = localRegWords r
+ where words = localRegWords dflags r
-- fill in empty slots as much as possible
(still_to_save, save_stack, n, save_assigs, save_regs)
@@ -667,14 +670,14 @@ allocate ret_off live stackmap@StackMap{ sm_sp = sp0
push r (n, assigs, regs)
= (n', assig : assigs, (r,(r,n')) : regs)
where
- n' = n + localRegBytes r
+ n' = n + localRegBytes dflags r
assig = CmmStore (CmmStackSlot Old n')
(CmmReg (CmmLocal r))
trim_sp
| not (null push_regs) = push_sp
| otherwise
- = n `plusW` (- length (takeWhile isEmpty save_stack))
+ = plusW dflags n (- length (takeWhile isEmpty save_stack))
final_regs = regs1 `addListToUFM` push_regs
`addListToUFM` save_regs
@@ -683,7 +686,7 @@ allocate ret_off live stackmap@StackMap{ sm_sp = sp0
-- XXX should be an assert
if ( n /= max sp0 ret_off ) then pprPanic "allocate" (ppr n <+> ppr sp0 <+> ppr ret_off) else
- if (trim_sp .&. (wORD_SIZE - 1)) /= 0 then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else
+ if (trim_sp .&. (wORD_SIZE dflags - 1)) /= 0 then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else
( stackmap { sm_regs = final_regs , sm_sp = trim_sp }
, push_assigs ++ save_assigs )
@@ -705,7 +708,8 @@ allocate ret_off live stackmap@StackMap{ sm_sp = sp0
-- middle_post, because the Sp adjustment intervenes.
--
manifestSp
- :: BlockEnv StackMap -- StackMaps for other blocks
+ :: DynFlags
+ -> BlockEnv StackMap -- StackMaps for other blocks
-> StackMap -- StackMap for this block
-> ByteOff -- Sp on entry to the block
-> ByteOff -- SpHigh
@@ -716,17 +720,17 @@ manifestSp
-> [CmmBlock] -- new blocks
-> [CmmBlock] -- final blocks with Sp manifest
-manifestSp stackmaps stack0 sp0 sp_high
+manifestSp dflags stackmaps stack0 sp0 sp_high
first middle_pre sp_off last fixup_blocks
= final_block : fixup_blocks'
where
area_off = getAreaOff stackmaps
adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x
- adj_pre_sp = mapExpDeep (areaToSp sp0 sp_high area_off)
- adj_post_sp = mapExpDeep (areaToSp (sp0 - sp_off) sp_high area_off)
+ adj_pre_sp = mapExpDeep (areaToSp dflags sp0 sp_high area_off)
+ adj_post_sp = mapExpDeep (areaToSp dflags (sp0 - sp_off) sp_high area_off)
- final_middle = maybeAddSpAdj sp_off $
+ final_middle = maybeAddSpAdj dflags sp_off $
blockFromList $
map adj_pre_sp $
elimStackStores stack0 stackmaps area_off $
@@ -747,10 +751,10 @@ getAreaOff stackmaps (Young l) =
Nothing -> pprPanic "getAreaOff" (ppr l)
-maybeAddSpAdj :: ByteOff -> Block CmmNode O O -> Block CmmNode O O
-maybeAddSpAdj 0 block = block
-maybeAddSpAdj sp_off block
- = block `blockSnoc` CmmAssign spReg (cmmOffset (CmmReg spReg) sp_off)
+maybeAddSpAdj :: DynFlags -> ByteOff -> Block CmmNode O O -> Block CmmNode O O
+maybeAddSpAdj _ 0 block = block
+maybeAddSpAdj dflags sp_off block
+ = block `blockSnoc` CmmAssign spReg (cmmOffset dflags (CmmReg spReg) sp_off)
{-
@@ -770,16 +774,16 @@ arguments.
to be Sp + Sp(L) - Sp(L')
-}
-areaToSp :: ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
-areaToSp sp_old _sp_hwm area_off (CmmStackSlot area n) =
- cmmOffset (CmmReg spReg) (sp_old - area_off area - n)
-areaToSp _ sp_hwm _ (CmmLit CmmHighStackMark) = CmmLit (mkIntCLit sp_hwm)
-areaToSp _ _ _ (CmmMachOp (MO_U_Lt _) -- Note [null stack check]
- [CmmMachOp (MO_Sub _)
- [ CmmReg (CmmGlobal Sp)
- , CmmLit (CmmInt 0 _)],
- CmmReg (CmmGlobal SpLim)]) = CmmLit (CmmInt 0 wordWidth)
-areaToSp _ _ _ other = other
+areaToSp :: DynFlags -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
+areaToSp dflags sp_old _sp_hwm area_off (CmmStackSlot area n) =
+ cmmOffset dflags (CmmReg spReg) (sp_old - area_off area - n)
+areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark) = mkIntExpr dflags sp_hwm
+areaToSp dflags _ _ _ (CmmMachOp (MO_U_Lt _) -- Note [null stack check]
+ [CmmMachOp (MO_Sub _)
+ [ CmmReg (CmmGlobal Sp)
+ , CmmLit (CmmInt 0 _)],
+ CmmReg (CmmGlobal SpLim)]) = zeroExpr dflags
+areaToSp _ _ _ _ other = other
-- -----------------------------------------------------------------------------
-- Note [null stack check]
@@ -840,8 +844,8 @@ elimStackStores stackmap stackmaps area_off nodes
-- Update info tables to include stack liveness
-setInfoTableStackMap :: BlockEnv StackMap -> CmmDecl -> CmmDecl
-setInfoTableStackMap stackmaps (CmmProc top_info@TopInfo{..} l g)
+setInfoTableStackMap :: DynFlags -> BlockEnv StackMap -> CmmDecl -> CmmDecl
+setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l g)
= CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l g
where
fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } =
@@ -852,18 +856,18 @@ setInfoTableStackMap stackmaps (CmmProc top_info@TopInfo{..} l g)
get_liveness lbl
= case mapLookup lbl stackmaps of
Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> ppr info_tbls)
- Just sm -> stackMapToLiveness sm
+ Just sm -> stackMapToLiveness dflags sm
-setInfoTableStackMap _ d = d
+setInfoTableStackMap _ _ d = d
-stackMapToLiveness :: StackMap -> Liveness
-stackMapToLiveness StackMap{..} =
+stackMapToLiveness :: DynFlags -> StackMap -> Liveness
+stackMapToLiveness dflags StackMap{..} =
reverse $ Array.elems $
- accumArray (\_ x -> x) True (toWords sm_ret_off + 1,
- toWords (sm_sp - sm_args)) live_words
+ accumArray (\_ x -> x) True (toWords dflags sm_ret_off + 1,
+ toWords dflags (sm_sp - sm_args)) live_words
where
- live_words = [ (toWords off, False)
+ live_words = [ (toWords dflags off, False)
| (r,off) <- eltsUFM sm_regs, isGcPtrType (localRegType r) ]
@@ -910,14 +914,14 @@ lowerSafeForeignCall dflags block
= do
-- Both 'id' and 'new_base' are KindNonPtr because they're
-- RTS-only objects and are not subject to garbage collection
- id <- newTemp bWord
- new_base <- newTemp (cmmRegType (CmmGlobal BaseReg))
+ id <- newTemp (bWord dflags)
+ new_base <- newTemp (cmmRegType dflags (CmmGlobal BaseReg))
let (caller_save, caller_load) = callerSaveVolatileRegs dflags
- load_tso <- newTemp gcWord
- load_stack <- newTemp gcWord
+ load_tso <- newTemp (gcWord dflags)
+ load_stack <- newTemp (gcWord dflags)
let suspend = saveThreadState dflags <*>
caller_save <*>
- mkMiddle (callSuspendThread id intrbl)
+ mkMiddle (callSuspendThread dflags id intrbl)
midCall = mkUnsafeCall tgt res args
resume = mkMiddle (callResumeThread new_base id) <*>
-- Assign the result to BaseReg: we
@@ -935,10 +939,10 @@ lowerSafeForeignCall dflags block
-- received an exception during the call, then the stack might be
-- different. Hence we continue by jumping to the top stack frame,
-- not by jumping to succ.
- jump = CmmCall { cml_target = CmmLoad (CmmReg spReg) bWord
+ jump = CmmCall { cml_target = CmmLoad (CmmReg spReg) (bWord dflags)
, cml_cont = Just succ
, cml_args_regs = regs
- , cml_args = widthInBytes wordWidth
+ , cml_args = widthInBytes (wordWidth dflags)
, cml_ret_args = ret_args
, cml_ret_off = updfr }
@@ -963,12 +967,12 @@ foreignLbl name = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId name))
newTemp :: CmmType -> UniqSM LocalReg
newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep)
-callSuspendThread :: LocalReg -> Bool -> CmmNode O O
-callSuspendThread id intrbl =
+callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O
+callSuspendThread dflags id intrbl =
CmmUnsafeForeignCall
(ForeignTarget (foreignLbl (fsLit "suspendThread"))
(ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint]))
- [id] [CmmReg (CmmGlobal BaseReg), CmmLit (mkIntCLit (fromEnum intrbl))]
+ [id] [CmmReg (CmmGlobal BaseReg), mkIntExpr dflags (fromEnum intrbl)]
callResumeThread :: LocalReg -> LocalReg -> CmmNode O O
callResumeThread new_base id =
@@ -979,8 +983,8 @@ callResumeThread new_base id =
-- -----------------------------------------------------------------------------
-plusW :: ByteOff -> WordOff -> ByteOff
-plusW b w = b + w * wORD_SIZE
+plusW :: DynFlags -> ByteOff -> WordOff -> ByteOff
+plusW dflags b w = b + w * wORD_SIZE dflags
dropEmpty :: WordOff -> [StackSlot] -> Maybe [StackSlot]
dropEmpty 0 ss = Just ss
@@ -991,14 +995,15 @@ isEmpty :: StackSlot -> Bool
isEmpty Empty = True
isEmpty _ = False
-localRegBytes :: LocalReg -> ByteOff
-localRegBytes r = roundUpToWords (widthInBytes (typeWidth (localRegType r)))
+localRegBytes :: DynFlags -> LocalReg -> ByteOff
+localRegBytes dflags r
+ = roundUpToWords dflags (widthInBytes (typeWidth (localRegType r)))
-localRegWords :: LocalReg -> WordOff
-localRegWords = toWords . localRegBytes
+localRegWords :: DynFlags -> LocalReg -> WordOff
+localRegWords dflags = toWords dflags . localRegBytes dflags
-toWords :: ByteOff -> WordOff
-toWords x = x `quot` wORD_SIZE
+toWords :: DynFlags -> ByteOff -> WordOff
+toWords dflags x = x `quot` wORD_SIZE dflags
insertReloads :: StackMap -> [CmmNode O O]
diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
index 47c30b1a0f..87a3ebfb5e 100644
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -18,7 +18,7 @@ import PprCmm ()
import BlockId
import FastString
import Outputable
-import Constants
+import DynFlags
import Data.Maybe
@@ -31,15 +31,15 @@ import Data.Maybe
-- Exported entry points:
cmmLint :: (Outputable d, Outputable h)
- => GenCmmGroup d h CmmGraph -> Maybe SDoc
-cmmLint tops = runCmmLint (mapM_ lintCmmDecl) tops
+ => DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc
+cmmLint dflags tops = runCmmLint dflags (mapM_ lintCmmDecl) tops
-cmmLintGraph :: CmmGraph -> Maybe SDoc
-cmmLintGraph g = runCmmLint lintCmmGraph g
+cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc
+cmmLintGraph dflags g = runCmmLint dflags lintCmmGraph g
-runCmmLint :: Outputable a => (a -> CmmLint b) -> a -> Maybe SDoc
-runCmmLint l p =
- case unCL (l p) of
+runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc
+runCmmLint dflags l p =
+ case unCL (l p) dflags of
Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"),
nest 2 err,
ptext $ sLit ("Program was:"),
@@ -85,24 +85,29 @@ lintCmmExpr (CmmLoad expr rep) = do
-- cmmCheckWordAddress expr
return rep
lintCmmExpr expr@(CmmMachOp op args) = do
+ dflags <- getDynFlags
tys <- mapM lintCmmExpr args
- if map (typeWidth . cmmExprType) args == machOpArgReps op
+ if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op
then cmmCheckMachOp op args tys
- else cmmLintMachOpErr expr (map cmmExprType args) (machOpArgReps op)
+ else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op)
lintCmmExpr (CmmRegOff reg offset)
- = lintCmmExpr (CmmMachOp (MO_Add rep)
+ = do dflags <- getDynFlags
+ let rep = typeWidth (cmmRegType dflags reg)
+ lintCmmExpr (CmmMachOp (MO_Add rep)
[CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
- where rep = typeWidth (cmmRegType reg)
lintCmmExpr expr =
- return (cmmExprType expr)
+ do dflags <- getDynFlags
+ return (cmmExprType dflags expr)
-- Check for some common byte/word mismatches (eg. Sp + 1)
cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
= cmmCheckMachOp op [reg, lit] tys
cmmCheckMachOp op _ tys
- = return (machOpResultType op tys)
+ = do dflags <- getDynFlags
+ return (machOpResultType dflags op tys)
+{-
isOffsetOp :: MachOp -> Bool
isOffsetOp (MO_Add _) = True
isOffsetOp (MO_Sub _) = True
@@ -112,10 +117,10 @@ isOffsetOp _ = False
-- check for funny-looking sub-word offsets.
_cmmCheckWordAddress :: CmmExpr -> CmmLint ()
_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
- | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
+ | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0
= cmmLintDubiousWordOffset e
_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
- | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
+ | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0
= cmmLintDubiousWordOffset e
_cmmCheckWordAddress _
= return ()
@@ -125,14 +130,16 @@ _cmmCheckWordAddress _
notNodeReg :: CmmExpr -> Bool
notNodeReg (CmmReg reg) | reg == nodeReg = False
notNodeReg _ = True
+-}
lintCmmMiddle :: CmmNode O O -> CmmLint ()
lintCmmMiddle node = case node of
CmmComment _ -> return ()
CmmAssign reg expr -> do
+ dflags <- getDynFlags
erep <- lintCmmExpr expr
- let reg_ty = cmmRegType reg
+ let reg_ty = cmmRegType dflags reg
if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
then return ()
else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
@@ -152,14 +159,16 @@ lintCmmLast labels node = case node of
CmmBranch id -> checkTarget id
CmmCondBranch e t f -> do
+ dflags <- getDynFlags
mapM_ checkTarget [t,f]
_ <- lintCmmExpr e
- checkCond e
+ checkCond dflags e
CmmSwitch e branches -> do
+ dflags <- getDynFlags
mapM_ checkTarget $ catMaybes branches
erep <- lintCmmExpr e
- if (erep `cmmEqType_ignoring_ptrhood` bWord)
+ if (erep `cmmEqType_ignoring_ptrhood` bWord dflags)
then return ()
else cmmLintErr (text "switch scrutinee is not a word: " <>
ppr e <> text " :: " <> ppr erep)
@@ -183,10 +192,10 @@ lintTarget (ForeignTarget e _) = lintCmmExpr e >> return ()
lintTarget (PrimTarget {}) = 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
+checkCond :: DynFlags -> CmmExpr -> CmmLint ()
+checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()
+checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values
+checkCond _ expr
= cmmLintErr (hang (text "expression is not a conditional:") 2
(ppr expr))
@@ -195,20 +204,24 @@ checkCond expr
-- just a basic error monad:
-newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
+newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a }
instance Monad CmmLint where
- CmmLint m >>= k = CmmLint $ case m of
+ CmmLint m >>= k = CmmLint $ \dflags ->
+ case m dflags of
Left e -> Left e
- Right a -> unCL (k a)
- return a = CmmLint (Right a)
+ Right a -> unCL (k a) dflags
+ return a = CmmLint (\_ -> Right a)
+
+instance HasDynFlags CmmLint where
+ getDynFlags = CmmLint (\dflags -> Right dflags)
cmmLintErr :: SDoc -> CmmLint a
-cmmLintErr msg = CmmLint (Left msg)
+cmmLintErr msg = CmmLint (\_ -> Left msg)
addLintInfo :: SDoc -> CmmLint a -> CmmLint a
-addLintInfo info thing = CmmLint $
- case unCL thing of
+addLintInfo info thing = CmmLint $ \dflags ->
+ case unCL thing dflags of
Left err -> Left (hang info 2 err)
Right a -> Right a
@@ -227,7 +240,10 @@ cmmLintAssignErr stmt e_ty r_ty
text "Rhs ty:" <+> ppr e_ty]))
+{-
cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
cmmLintDubiousWordOffset expr
= cmmLintErr (text "offset is not a multiple of words: " $$
nest 2 (ppr expr))
+-}
+
diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs
index f42626f638..520c7e7a7d 100644
--- a/compiler/cmm/CmmMachOp.hs
+++ b/compiler/cmm/CmmMachOp.hs
@@ -13,7 +13,7 @@ module CmmMachOp
, mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr
, mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32
, mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord
- , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32
+ , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64
-- CallishMachOp
, CallishMachOp(..)
@@ -25,6 +25,7 @@ where
import CmmType
import Outputable
+import DynFlags
-----------------------------------------------------------------------------
-- MachOp
@@ -122,58 +123,62 @@ mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot
, mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe
, mo_wordULe, mo_wordUGt, mo_wordULt
, mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr
- , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32
, mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord
- , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32
+ , mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64
+ :: DynFlags -> MachOp
+
+mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32
+ , mo_32To8, mo_32To16
:: MachOp
-mo_wordAdd = MO_Add wordWidth
-mo_wordSub = MO_Sub wordWidth
-mo_wordEq = MO_Eq wordWidth
-mo_wordNe = MO_Ne wordWidth
-mo_wordMul = MO_Mul wordWidth
-mo_wordSQuot = MO_S_Quot wordWidth
-mo_wordSRem = MO_S_Rem wordWidth
-mo_wordSNeg = MO_S_Neg wordWidth
-mo_wordUQuot = MO_U_Quot wordWidth
-mo_wordURem = MO_U_Rem wordWidth
-
-mo_wordSGe = MO_S_Ge wordWidth
-mo_wordSLe = MO_S_Le wordWidth
-mo_wordSGt = MO_S_Gt wordWidth
-mo_wordSLt = MO_S_Lt wordWidth
-
-mo_wordUGe = MO_U_Ge wordWidth
-mo_wordULe = MO_U_Le wordWidth
-mo_wordUGt = MO_U_Gt wordWidth
-mo_wordULt = MO_U_Lt wordWidth
-
-mo_wordAnd = MO_And wordWidth
-mo_wordOr = MO_Or wordWidth
-mo_wordXor = MO_Xor wordWidth
-mo_wordNot = MO_Not wordWidth
-mo_wordShl = MO_Shl wordWidth
-mo_wordSShr = MO_S_Shr wordWidth
-mo_wordUShr = MO_U_Shr wordWidth
-
-mo_u_8To32 = MO_UU_Conv W8 W32
-mo_s_8To32 = MO_SS_Conv W8 W32
-mo_u_16To32 = MO_UU_Conv W16 W32
-mo_s_16To32 = MO_SS_Conv W16 W32
-
-mo_u_8ToWord = MO_UU_Conv W8 wordWidth
-mo_s_8ToWord = MO_SS_Conv W8 wordWidth
-mo_u_16ToWord = MO_UU_Conv W16 wordWidth
-mo_s_16ToWord = MO_SS_Conv W16 wordWidth
-mo_s_32ToWord = MO_SS_Conv W32 wordWidth
-mo_u_32ToWord = MO_UU_Conv W32 wordWidth
-
-mo_WordTo8 = MO_UU_Conv wordWidth W8
-mo_WordTo16 = MO_UU_Conv wordWidth W16
-mo_WordTo32 = MO_UU_Conv wordWidth W32
-
-mo_32To8 = MO_UU_Conv W32 W8
-mo_32To16 = MO_UU_Conv W32 W16
+mo_wordAdd dflags = MO_Add (wordWidth dflags)
+mo_wordSub dflags = MO_Sub (wordWidth dflags)
+mo_wordEq dflags = MO_Eq (wordWidth dflags)
+mo_wordNe dflags = MO_Ne (wordWidth dflags)
+mo_wordMul dflags = MO_Mul (wordWidth dflags)
+mo_wordSQuot dflags = MO_S_Quot (wordWidth dflags)
+mo_wordSRem dflags = MO_S_Rem (wordWidth dflags)
+mo_wordSNeg dflags = MO_S_Neg (wordWidth dflags)
+mo_wordUQuot dflags = MO_U_Quot (wordWidth dflags)
+mo_wordURem dflags = MO_U_Rem (wordWidth dflags)
+
+mo_wordSGe dflags = MO_S_Ge (wordWidth dflags)
+mo_wordSLe dflags = MO_S_Le (wordWidth dflags)
+mo_wordSGt dflags = MO_S_Gt (wordWidth dflags)
+mo_wordSLt dflags = MO_S_Lt (wordWidth dflags)
+
+mo_wordUGe dflags = MO_U_Ge (wordWidth dflags)
+mo_wordULe dflags = MO_U_Le (wordWidth dflags)
+mo_wordUGt dflags = MO_U_Gt (wordWidth dflags)
+mo_wordULt dflags = MO_U_Lt (wordWidth dflags)
+
+mo_wordAnd dflags = MO_And (wordWidth dflags)
+mo_wordOr dflags = MO_Or (wordWidth dflags)
+mo_wordXor dflags = MO_Xor (wordWidth dflags)
+mo_wordNot dflags = MO_Not (wordWidth dflags)
+mo_wordShl dflags = MO_Shl (wordWidth dflags)
+mo_wordSShr dflags = MO_S_Shr (wordWidth dflags)
+mo_wordUShr dflags = MO_U_Shr (wordWidth dflags)
+
+mo_u_8To32 = MO_UU_Conv W8 W32
+mo_s_8To32 = MO_SS_Conv W8 W32
+mo_u_16To32 = MO_UU_Conv W16 W32
+mo_s_16To32 = MO_SS_Conv W16 W32
+
+mo_u_8ToWord dflags = MO_UU_Conv W8 (wordWidth dflags)
+mo_s_8ToWord dflags = MO_SS_Conv W8 (wordWidth dflags)
+mo_u_16ToWord dflags = MO_UU_Conv W16 (wordWidth dflags)
+mo_s_16ToWord dflags = MO_SS_Conv W16 (wordWidth dflags)
+mo_s_32ToWord dflags = MO_SS_Conv W32 (wordWidth dflags)
+mo_u_32ToWord dflags = MO_UU_Conv W32 (wordWidth dflags)
+
+mo_WordTo8 dflags = MO_UU_Conv (wordWidth dflags) W8
+mo_WordTo16 dflags = MO_UU_Conv (wordWidth dflags) W16
+mo_WordTo32 dflags = MO_UU_Conv (wordWidth dflags) W32
+mo_WordTo64 dflags = MO_UU_Conv (wordWidth dflags) W64
+
+mo_32To8 = MO_UU_Conv W32 W8
+mo_32To16 = MO_UU_Conv W32 W16
-- ----------------------------------------------------------------------------
@@ -282,8 +287,8 @@ maybeInvertComparison op
{- |
Returns the MachRep of the result of a MachOp.
-}
-machOpResultType :: MachOp -> [CmmType] -> CmmType
-machOpResultType mop tys =
+machOpResultType :: DynFlags -> MachOp -> [CmmType] -> CmmType
+machOpResultType dflags mop tys =
case mop of
MO_Add {} -> ty1 -- Preserve GC-ptr-hood
MO_Sub {} -> ty1 -- of first arg
@@ -296,29 +301,29 @@ machOpResultType mop tys =
MO_U_Quot r -> cmmBits r
MO_U_Rem r -> cmmBits r
- MO_Eq {} -> comparisonResultRep
- MO_Ne {} -> comparisonResultRep
- MO_S_Ge {} -> comparisonResultRep
- MO_S_Le {} -> comparisonResultRep
- MO_S_Gt {} -> comparisonResultRep
- MO_S_Lt {} -> comparisonResultRep
+ MO_Eq {} -> comparisonResultRep dflags
+ MO_Ne {} -> comparisonResultRep dflags
+ MO_S_Ge {} -> comparisonResultRep dflags
+ MO_S_Le {} -> comparisonResultRep dflags
+ MO_S_Gt {} -> comparisonResultRep dflags
+ MO_S_Lt {} -> comparisonResultRep dflags
- MO_U_Ge {} -> comparisonResultRep
- MO_U_Le {} -> comparisonResultRep
- MO_U_Gt {} -> comparisonResultRep
- MO_U_Lt {} -> comparisonResultRep
+ MO_U_Ge {} -> comparisonResultRep dflags
+ MO_U_Le {} -> comparisonResultRep dflags
+ MO_U_Gt {} -> comparisonResultRep dflags
+ MO_U_Lt {} -> comparisonResultRep dflags
MO_F_Add r -> cmmFloat r
MO_F_Sub r -> cmmFloat r
MO_F_Mul r -> cmmFloat r
MO_F_Quot r -> cmmFloat r
MO_F_Neg r -> cmmFloat r
- MO_F_Eq {} -> comparisonResultRep
- MO_F_Ne {} -> comparisonResultRep
- MO_F_Ge {} -> comparisonResultRep
- MO_F_Le {} -> comparisonResultRep
- MO_F_Gt {} -> comparisonResultRep
- MO_F_Lt {} -> comparisonResultRep
+ MO_F_Eq {} -> comparisonResultRep dflags
+ MO_F_Ne {} -> comparisonResultRep dflags
+ MO_F_Ge {} -> comparisonResultRep dflags
+ MO_F_Le {} -> comparisonResultRep dflags
+ MO_F_Gt {} -> comparisonResultRep dflags
+ MO_F_Lt {} -> comparisonResultRep dflags
MO_And {} -> ty1 -- Used for pointer masking
MO_Or {} -> ty1
@@ -336,7 +341,7 @@ machOpResultType mop tys =
where
(ty1:_) = tys
-comparisonResultRep :: CmmType
+comparisonResultRep :: DynFlags -> CmmType
comparisonResultRep = bWord -- is it?
@@ -348,8 +353,8 @@ comparisonResultRep = bWord -- is it?
-- its arguments are the same as the MachOp expects. This is used when
-- linting a CmmExpr.
-machOpArgReps :: MachOp -> [Width]
-machOpArgReps op =
+machOpArgReps :: DynFlags -> MachOp -> [Width]
+machOpArgReps dflags op =
case op of
MO_Add r -> [r,r]
MO_Sub r -> [r,r]
@@ -390,9 +395,9 @@ machOpArgReps op =
MO_Or r -> [r,r]
MO_Xor r -> [r,r]
MO_Not r -> [r]
- MO_Shl r -> [r,wordWidth]
- MO_U_Shr r -> [r,wordWidth]
- MO_S_Shr r -> [r,wordWidth]
+ MO_Shl r -> [r, wordWidth dflags]
+ MO_U_Shr r -> [r, wordWidth dflags]
+ MO_S_Shr r -> [r, wordWidth dflags]
MO_SS_Conv from _ -> [from]
MO_UU_Conv from _ -> [from]
diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs
index fa41ed5f42..ae7ac091de 100644
--- a/compiler/cmm/CmmNode.hs
+++ b/compiler/cmm/CmmNode.hs
@@ -395,14 +395,7 @@ foldExp f (CmmCall {cml_target=tgt}) z = f tgt z
foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args
foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
-foldExpDeep f = foldExp go
- where -- go :: CmmExpr -> z -> z
- go e@(CmmMachOp _ es) z = gos es $! f e z
- go e@(CmmLoad addr _) z = go addr $! f e z
- go e z = f e z
-
- gos [] z = z
- gos (e:es) z = gos es $! f e z
+foldExpDeep f = foldExp (wrapRecExpf f)
-- -----------------------------------------------------------------------------
diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs
index 5f208244f8..0df24a6a66 100644
--- a/compiler/cmm/CmmOpt.hs
+++ b/compiler/cmm/CmmOpt.hs
@@ -183,8 +183,7 @@ cmmMiniInlineStmts dflags uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr)
-- not CmmLocal: that might invalidate the usage analysis results
isTiny _ = False
- platform = targetPlatform dflags
- foldExp (CmmMachOp op args) = cmmMachOpFold platform op args
+ foldExp (CmmMachOp op args) = cmmMachOpFold dflags op args
foldExp e = e
ncgDebugTrace str x = if ncgDebugIsOn then trace str x else x
@@ -302,17 +301,17 @@ inlineExpr _ _ other_expr = other_expr
-- been optimized and folded.
cmmMachOpFold
- :: Platform
+ :: DynFlags
-> MachOp -- The operation from an CmmMachOp
-> [CmmExpr] -- The optimized arguments
-> CmmExpr
-cmmMachOpFold platform op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM platform op args)
+cmmMachOpFold dflags op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM dflags op args)
-- Returns Nothing if no changes, useful for Hoopl, also reduces
-- allocation!
cmmMachOpFoldM
- :: Platform
+ :: DynFlags
-> MachOp
-> [CmmExpr]
-> Maybe CmmExpr
@@ -338,7 +337,7 @@ cmmMachOpFoldM _ (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = Just x
cmmMachOpFoldM _ (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = Just x
-- Eliminate nested conversions where possible
-cmmMachOpFoldM platform conv_outer [CmmMachOp conv_inner [x]]
+cmmMachOpFoldM dflags conv_outer [CmmMachOp conv_inner [x]]
| Just (rep1,rep2,signed1) <- isIntConversion conv_inner,
Just (_, rep3,signed2) <- isIntConversion conv_outer
= case () of
@@ -348,13 +347,13 @@ cmmMachOpFoldM platform conv_outer [CmmMachOp conv_inner [x]]
-- but remember to use the signedness from the widening, just in case
-- the final conversion is a widen.
| rep1 < rep2 && rep2 > rep3 ->
- Just $ cmmMachOpFold platform (intconv signed1 rep1 rep3) [x]
+ Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x]
-- Nested widenings: collapse if the signedness is the same
| rep1 < rep2 && rep2 < rep3 && signed1 == signed2 ->
- Just $ cmmMachOpFold platform (intconv signed1 rep1 rep3) [x]
+ Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x]
-- Nested narrowings: collapse
| rep1 > rep2 && rep2 > rep3 ->
- Just $ cmmMachOpFold platform (MO_UU_Conv rep1 rep3) [x]
+ Just $ cmmMachOpFold dflags (MO_UU_Conv rep1 rep3) [x]
| otherwise ->
Nothing
where
@@ -371,22 +370,22 @@ cmmMachOpFoldM platform conv_outer [CmmMachOp conv_inner [x]]
-- but what if the architecture only supports word-sized loads, should
-- we do the transformation anyway?
-cmmMachOpFoldM _ mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]
+cmmMachOpFoldM dflags mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]
= case mop of
-- for comparisons: don't forget to narrow the arguments before
-- comparing, since they might be out of range.
- MO_Eq _ -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) wordWidth)
- MO_Ne _ -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) wordWidth)
+ MO_Eq _ -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth dflags))
+ MO_Ne _ -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth dflags))
- MO_U_Gt _ -> Just $ CmmLit (CmmInt (if x_u > y_u then 1 else 0) wordWidth)
- MO_U_Ge _ -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) wordWidth)
- MO_U_Lt _ -> Just $ CmmLit (CmmInt (if x_u < y_u then 1 else 0) wordWidth)
- MO_U_Le _ -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) wordWidth)
+ MO_U_Gt _ -> Just $ CmmLit (CmmInt (if x_u > y_u then 1 else 0) (wordWidth dflags))
+ MO_U_Ge _ -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth dflags))
+ MO_U_Lt _ -> Just $ CmmLit (CmmInt (if x_u < y_u then 1 else 0) (wordWidth dflags))
+ MO_U_Le _ -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth dflags))
- MO_S_Gt _ -> Just $ CmmLit (CmmInt (if x_s > y_s then 1 else 0) wordWidth)
- MO_S_Ge _ -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) wordWidth)
- MO_S_Lt _ -> Just $ CmmLit (CmmInt (if x_s < y_s then 1 else 0) wordWidth)
- MO_S_Le _ -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) wordWidth)
+ MO_S_Gt _ -> Just $ CmmLit (CmmInt (if x_s > y_s then 1 else 0) (wordWidth dflags))
+ MO_S_Ge _ -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth dflags))
+ MO_S_Lt _ -> Just $ CmmLit (CmmInt (if x_s < y_s then 1 else 0) (wordWidth dflags))
+ MO_S_Le _ -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth dflags))
MO_Add r -> Just $ CmmLit (CmmInt (x + y) r)
MO_Sub r -> Just $ CmmLit (CmmInt (x - y) r)
@@ -418,9 +417,9 @@ cmmMachOpFoldM _ mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]
-- also assume that constants have been shifted to the right when
-- possible.
-cmmMachOpFoldM platform op [x@(CmmLit _), y]
+cmmMachOpFoldM dflags op [x@(CmmLit _), y]
| not (isLit y) && isCommutableMachOp op
- = Just (cmmMachOpFold platform op [y, x])
+ = Just (cmmMachOpFold dflags op [y, x])
-- Turn (a+b)+c into a+(b+c) where possible. Because literals are
-- moved to the right, it is more likely that we will find
@@ -438,19 +437,19 @@ cmmMachOpFoldM platform op [x@(CmmLit _), y]
-- Also don't do it if arg1 is PicBaseReg, so that we don't separate the
-- PicBaseReg from the corresponding label (or label difference).
--
-cmmMachOpFoldM platform mop1 [CmmMachOp mop2 [arg1,arg2], arg3]
+cmmMachOpFoldM dflags mop1 [CmmMachOp mop2 [arg1,arg2], arg3]
| mop2 `associates_with` mop1
&& not (isLit arg1) && not (isPicReg arg1)
- = Just (cmmMachOpFold platform mop2 [arg1, cmmMachOpFold platform mop1 [arg2,arg3]])
+ = Just (cmmMachOpFold dflags mop2 [arg1, cmmMachOpFold dflags mop1 [arg2,arg3]])
where
MO_Add{} `associates_with` MO_Sub{} = True
mop1 `associates_with` mop2 =
mop1 == mop2 && isAssociativeMachOp mop1
-- special case: (a - b) + c ==> a + (c - b)
-cmmMachOpFoldM platform mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3]
+cmmMachOpFoldM dflags mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3]
| not (isLit arg1) && not (isPicReg arg1)
- = Just (cmmMachOpFold platform mop1 [arg1, cmmMachOpFold platform mop2 [arg3,arg2]])
+ = Just (cmmMachOpFold dflags mop1 [arg1, cmmMachOpFold dflags mop2 [arg3,arg2]])
-- Make a RegOff if we can
cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)]
@@ -479,9 +478,9 @@ cmmMachOpFoldM _ (MO_Sub _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)]
-- narrowing throws away bits from the operand, there's no way to do
-- the same comparison at the larger size.
-cmmMachOpFoldM platform cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]
+cmmMachOpFoldM dflags cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]
| -- powerPC NCG has a TODO for I8/I16 comparisons, so don't try
- platformArch platform `elem` [ArchX86, ArchX86_64],
+ platformArch (targetPlatform dflags) `elem` [ArchX86, ArchX86_64],
-- if the operand is widened:
Just (rep, signed, narrow_fn) <- maybe_conversion conv,
-- and this is a comparison operation:
@@ -489,7 +488,7 @@ cmmMachOpFoldM platform cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]
-- and the literal fits in the smaller size:
i == narrow_fn rep i
-- then we can do the comparison at the smaller size
- = Just (cmmMachOpFold platform narrow_cmp [x, CmmLit (CmmInt i rep)])
+ = Just (cmmMachOpFold dflags narrow_cmp [x, CmmLit (CmmInt i rep)])
where
maybe_conversion (MO_UU_Conv from to)
| to > from
@@ -522,7 +521,7 @@ cmmMachOpFoldM platform cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]
-- We can often do something with constants of 0 and 1 ...
-cmmMachOpFoldM _ mop [x, y@(CmmLit (CmmInt 0 _))]
+cmmMachOpFoldM dflags mop [x, y@(CmmLit (CmmInt 0 _))]
= case mop of
MO_Add _ -> Just x
MO_Sub _ -> Just x
@@ -537,15 +536,15 @@ cmmMachOpFoldM _ mop [x, y@(CmmLit (CmmInt 0 _))]
MO_Eq _ | Just x' <- maybeInvertCmmExpr x -> Just x'
MO_U_Gt _ | isComparisonExpr x -> Just x
MO_S_Gt _ | isComparisonExpr x -> Just x
- MO_U_Lt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 wordWidth)
- MO_S_Lt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 wordWidth)
- MO_U_Ge _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 wordWidth)
- MO_S_Ge _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 wordWidth)
+ MO_U_Lt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 (wordWidth dflags))
+ MO_S_Lt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 (wordWidth dflags))
+ MO_U_Ge _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 (wordWidth dflags))
+ MO_S_Ge _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 (wordWidth dflags))
MO_U_Le _ | Just x' <- maybeInvertCmmExpr x -> Just x'
MO_S_Le _ | Just x' <- maybeInvertCmmExpr x -> Just x'
_ -> Nothing
-cmmMachOpFoldM _ mop [x, (CmmLit (CmmInt 1 rep))]
+cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt 1 rep))]
= case mop of
MO_Mul _ -> Just x
MO_S_Quot _ -> Just x
@@ -556,24 +555,24 @@ cmmMachOpFoldM _ mop [x, (CmmLit (CmmInt 1 rep))]
MO_Eq _ | isComparisonExpr x -> Just x
MO_U_Lt _ | Just x' <- maybeInvertCmmExpr x -> Just x'
MO_S_Lt _ | Just x' <- maybeInvertCmmExpr x -> Just x'
- MO_U_Gt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 wordWidth)
- MO_S_Gt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 wordWidth)
- MO_U_Le _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 wordWidth)
- MO_S_Le _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 wordWidth)
+ MO_U_Gt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 (wordWidth dflags))
+ MO_S_Gt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 (wordWidth dflags))
+ MO_U_Le _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 (wordWidth dflags))
+ MO_S_Le _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 (wordWidth dflags))
MO_U_Ge _ | isComparisonExpr x -> Just x
MO_S_Ge _ | isComparisonExpr x -> Just x
_ -> Nothing
-- Now look for multiplication/division by powers of 2 (integers).
-cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt n _))]
+cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt n _))]
= case mop of
MO_Mul rep
| Just p <- exactLog2 n ->
- Just (cmmMachOpFold platform (MO_Shl rep) [x, CmmLit (CmmInt p rep)])
+ Just (cmmMachOpFold dflags (MO_Shl rep) [x, CmmLit (CmmInt p rep)])
MO_U_Quot rep
| Just p <- exactLog2 n ->
- Just (cmmMachOpFold platform (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)])
+ Just (cmmMachOpFold dflags (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)])
MO_S_Quot rep
| Just p <- exactLog2 n,
CmmReg _ <- x -> -- We duplicate x below, hence require
@@ -601,7 +600,7 @@ cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt n _))]
CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)]
x3 = CmmMachOp (MO_Add rep) [x, x2]
in
- Just (cmmMachOpFold platform (MO_S_Shr rep) [x3, CmmLit (CmmInt p rep)])
+ Just (cmmMachOpFold dflags (MO_S_Shr rep) [x3, CmmLit (CmmInt p rep)])
_ -> Nothing
-- ToDo (#7116): optimise floating-point multiplication, e.g. x*2.0 -> x+x
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 8a10724524..3061062a4c 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -340,9 +340,10 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals_without_hints0 ')'
-- closure type, live regs
{% withThisPackage $ \pkg ->
- do live <- sequence (map (liftM Just) $7)
+ do dflags <- getDynFlags
+ live <- sequence (map (liftM Just) $7)
let prof = NoProfilingInfo
- bitmap = mkLiveness live
+ bitmap = mkLiveness dflags live
rep = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap
return (mkCmmRetLabel pkg $3,
CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
@@ -522,7 +523,7 @@ expr0 :: { ExtFCode CmmExpr }
-- leaving out the type of a literal gives you the native word size in C--
maybe_ty :: { CmmType }
- : {- empty -} { bWord }
+ : {- empty -} {% do dflags <- getDynFlags; return $ bWord dflags }
| '::' type { $2 }
maybe_actuals :: { [ExtFCode HintedCmmActual] }
@@ -611,7 +612,7 @@ typenot8 :: { CmmType }
| 'bits64' { b64 }
| 'float32' { f32 }
| 'float64' { f64 }
- | 'gcptr' { gcWord }
+ | 'gcptr' {% do dflags <- getDynFlags; return $ gcWord dflags }
{
section :: String -> Section
section "text" = Text
@@ -630,8 +631,9 @@ mkString s = CmmString (map (fromIntegral.ord) s)
-- the op.
mkMachOp :: (Width -> MachOp) -> [ExtFCode CmmExpr] -> ExtFCode CmmExpr
mkMachOp fn args = do
+ dflags <- getDynFlags
arg_exprs <- sequence args
- return (CmmMachOp (fn (typeWidth (cmmExprType (head arg_exprs)))) arg_exprs)
+ return (CmmMachOp (fn (typeWidth (cmmExprType dflags (head arg_exprs)))) arg_exprs)
getLit :: CmmExpr -> CmmLit
getLit (CmmLit l) = l
@@ -658,12 +660,12 @@ exprOp name args_code = do
exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr)
exprMacros dflags = listToUFM [
( fsLit "ENTRY_CODE", \ [x] -> entryCode dflags x ),
- ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr x ),
+ ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr dflags x ),
( fsLit "STD_INFO", \ [x] -> infoTable dflags x ),
( fsLit "FUN_INFO", \ [x] -> funInfoTable dflags x ),
- ( fsLit "GET_ENTRY", \ [x] -> entryCode dflags (closureInfoPtr x) ),
- ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr x) ),
- ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr x) ),
+ ( fsLit "GET_ENTRY", \ [x] -> entryCode dflags (closureInfoPtr dflags x) ),
+ ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ),
+ ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ),
( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType dflags x ),
( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs dflags x ),
( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs dflags x )
@@ -868,7 +870,7 @@ foreignCall conv_string results_code expr_code args_code vols safety ret
-- Temporary hack so at least some functions are CmmSafe
CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args ret))
_ ->
- let expr' = adjCallTarget platform convention expr args in
+ let expr' = adjCallTarget dflags convention expr args in
case safety of
CmmUnsafe ->
code (emitForeignCall' PlayRisky results
@@ -880,13 +882,14 @@ foreignCall conv_string results_code expr_code args_code vols safety ret
code (emitForeignCall' PlayInterruptible results
(CmmCallee expr' convention) args vols NoC_SRT ret)
-adjCallTarget :: Platform -> CCallConv -> CmmExpr -> [CmmHinted CmmExpr]
+adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [CmmHinted CmmExpr]
-> CmmExpr
-- On Windows, we have to add the '@N' suffix to the label when making
-- a call with the stdcall calling convention.
-adjCallTarget (Platform { platformOS = OSMinGW32 }) StdCallConv (CmmLit (CmmLabel lbl)) args
+adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args
+ | platformOS (targetPlatform dflags) == OSMinGW32
= CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
- where size (CmmHinted e _) = max wORD_SIZE (widthInBytes (typeWidth (cmmExprType e)))
+ where size (CmmHinted e _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e)))
-- c.f. CgForeignCall.emitForeignCall
adjCallTarget _ _ expr _
= expr
@@ -917,14 +920,15 @@ primCall results_code name args_code vols safety
doStore :: CmmType -> ExtFCode CmmExpr -> ExtFCode CmmExpr -> ExtCode
doStore rep addr_code val_code
- = do addr <- addr_code
+ = do dflags <- getDynFlags
+ addr <- addr_code
val <- val_code
-- if the specified store type does not match the type of the expr
-- on the rhs, then we insert a coercion that will cause the type
-- mismatch to be flagged by cmm-lint. If we don't do this, then
-- the store will happen at the wrong type, and the error will not
-- be noticed.
- let val_width = typeWidth (cmmExprType val)
+ let val_width = typeWidth (cmmExprType dflags val)
rep_width = typeWidth rep
let coerce_val
| val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
@@ -940,8 +944,8 @@ emitRetUT args = do
emitSimultaneously stmts -- NB. the args might overlap with the stack slots
-- or regs that we assign to, so better use
-- simultaneous assignments here (#3546)
- when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
- stmtC $ CmmJump (entryCode dflags (CmmLoad (cmmRegOffW spReg sp) bWord)) (Just live)
+ when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW dflags spReg (-sp)))
+ stmtC $ CmmJump (entryCode dflags (CmmLoad (cmmRegOffW dflags spReg sp) (bWord dflags))) (Just live)
-- -----------------------------------------------------------------------------
-- If-then-else and boolean expressions
@@ -1050,9 +1054,9 @@ doSwitch mb_range scrut arms deflt
initEnv :: DynFlags -> Env
initEnv dflags = listToUFM [
( fsLit "SIZEOF_StgHeader",
- VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags * wORD_SIZE)) wordWidth) )),
+ VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags * wORD_SIZE dflags)) (wordWidth dflags)) )),
( fsLit "SIZEOF_StgInfoTable",
- VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) wordWidth) ))
+ VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) ))
]
parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)
diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs
index b3b4af712d..76927266ad 100644
--- a/compiler/cmm/CmmPipeline.hs
+++ b/compiler/cmm/CmmPipeline.hs
@@ -43,7 +43,7 @@ cmmPipeline hsc_env topSRT prog =
tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog
- (topSRT, cmms) <- {-# SCC "toTops" #-} doSRTs topSRT tops
+ (topSRT, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags topSRT tops
dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
return (topSRT, cmms)
@@ -105,6 +105,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
------------- CAF analysis ----------------------------------------------
let cafEnv = {-# SCC "cafAnal" #-} cafAnal g
+ dumpIfSet_dyn dflags Opt_D_dump_cmmz "CAFEnv" (ppr cafEnv)
if splitting_proc_points
then do
@@ -118,7 +119,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
------------- Populate info tables with stack info -----------------
gs <- {-# SCC "setInfoTableStackMap" #-}
- return $ map (setInfoTableStackMap stackmaps) gs
+ return $ map (setInfoTableStackMap dflags stackmaps) gs
dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs
----------- Control-flow optimisations -----------------------------
@@ -136,7 +137,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
------------- Populate info tables with stack info -----------------
g <- {-# SCC "setInfoTableStackMap" #-}
- return $ setInfoTableStackMap stackmaps g
+ return $ setInfoTableStackMap dflags stackmaps g
dump' Opt_D_dump_cmmz_info "after setInfoTableStackMap" g
----------- Control-flow optimisations -----------------------------
@@ -182,7 +183,7 @@ dumpGraph dflags flag name g = do
when (dopt Opt_DoCmmLinting dflags) $ do_lint g
dumpWith dflags flag name g
where
- do_lint g = case cmmLintGraph g of
+ do_lint g = case cmmLintGraph dflags g of
Just err -> do { fatalErrorMsg dflags err
; ghcExit dflags 1
}
diff --git a/compiler/cmm/CmmRewriteAssignments.hs b/compiler/cmm/CmmRewriteAssignments.hs
index a5b7602078..585d78e95b 100644
--- a/compiler/cmm/CmmRewriteAssignments.hs
+++ b/compiler/cmm/CmmRewriteAssignments.hs
@@ -20,8 +20,8 @@ import CmmUtils
import CmmOpt
import StgCmmUtils
+import DynFlags
import UniqSupply
-import Platform
import UniqFM
import Unique
import BlockId
@@ -35,8 +35,8 @@ import Prelude hiding (succ, zip)
----------------------------------------------------------------
--- Main function
-rewriteAssignments :: Platform -> CmmGraph -> UniqSM CmmGraph
-rewriteAssignments platform g = do
+rewriteAssignments :: DynFlags -> CmmGraph -> UniqSM CmmGraph
+rewriteAssignments dflags g = do
-- Because we need to act on forwards and backwards information, we
-- first perform usage analysis and bake this information into the
-- graph (backwards transform), and then do a forwards transform
@@ -44,8 +44,8 @@ rewriteAssignments platform g = do
g' <- annotateUsage g
g'' <- liftM fst $ dataflowPassFwd g' [(g_entry g, fact_bot assignmentLattice)] $
analRewFwd assignmentLattice
- (assignmentTransfer platform)
- (assignmentRewrite `thenFwdRw` machOpFoldRewrite platform)
+ (assignmentTransfer dflags)
+ (assignmentRewrite `thenFwdRw` machOpFoldRewrite dflags)
return (modifyGraph eraseRegUsage g'')
----------------------------------------------------------------
@@ -309,7 +309,7 @@ invalidateUsersOf reg = mapUFM (invalidateUsers' reg)
-- optimize; we need an algorithmic change to prevent us from having to
-- traverse the /entire/ map continually.
-middleAssignment :: Platform -> WithRegUsage CmmNode O O -> AssignmentMap
+middleAssignment :: DynFlags -> WithRegUsage CmmNode O O -> AssignmentMap
-> AssignmentMap
-- Algorithm for annotated assignments:
@@ -349,10 +349,10 @@ middleAssignment _ (Plain (CmmAssign (CmmLocal _) _)) assign = assign
-- 1. Delete any sinking assignments that were used by this instruction
-- 2. Look for all assignments that load from memory locations that
-- were clobbered by this store and invalidate them.
-middleAssignment _ (Plain n@(CmmStore lhs rhs)) assign
+middleAssignment dflags (Plain n@(CmmStore lhs rhs)) assign
= let m = deleteSinks n assign
in foldUFM_Directly f m m -- [foldUFM performance]
- where f u (xassign -> Just x) m | (lhs, rhs) `clobbers` (u, x) = addToUFM_Directly m u NeverOptimize
+ where f u (xassign -> Just x) m | clobbers dflags (lhs, rhs) (u, x) = addToUFM_Directly m u NeverOptimize
f _ _ m = m
{- Also leaky
= mapUFM_Directly p . deleteSinks n $ assign
@@ -371,7 +371,7 @@ middleAssignment _ (Plain n@(CmmStore lhs rhs)) assign
-- This is kind of expensive. (One way to optimize this might be to
-- store extra information about expressions that allow this and other
-- checks to be done cheaply.)
-middleAssignment platform (Plain n@(CmmUnsafeForeignCall{})) assign
+middleAssignment dflags (Plain n@(CmmUnsafeForeignCall{})) assign
= deleteCallerSaves (foldRegsDefd (\m r -> addToUFM m r NeverOptimize) (deleteSinks n assign) n)
where deleteCallerSaves m = foldUFM_Directly f m m
f u (xassign -> Just x) m | wrapRecExpf g x False = addToUFM_Directly m u NeverOptimize
@@ -379,6 +379,7 @@ middleAssignment platform (Plain n@(CmmUnsafeForeignCall{})) assign
g (CmmReg (CmmGlobal r)) _ | callerSaves platform r = True
g (CmmRegOff (CmmGlobal r) _) _ | callerSaves platform r = True
g _ b = b
+ platform = targetPlatform dflags
middleAssignment _ (Plain (CmmComment {})) assign
= assign
@@ -398,17 +399,18 @@ middleAssignment _ (Plain (CmmComment {})) assign
-- the next spill.)
-- * Non stack-slot stores always conflict with each other. (This is
-- not always the case; we could probably do something special for Hp)
-clobbers :: (CmmExpr, CmmExpr) -- (lhs, rhs) of clobbering CmmStore
+clobbers :: DynFlags
+ -> (CmmExpr, CmmExpr) -- (lhs, rhs) of clobbering CmmStore
-> (Unique, CmmExpr) -- (register, expression) that may be clobbered
-> Bool
-clobbers (CmmRegOff (CmmGlobal Hp) _, _) (_, _) = False
-clobbers (CmmReg (CmmGlobal Hp), _) (_, _) = False
+clobbers _ (CmmRegOff (CmmGlobal Hp) _, _) (_, _) = False
+clobbers _ (CmmReg (CmmGlobal Hp), _) (_, _) = False
-- ToDo: Also catch MachOp case
-clobbers (ss@CmmStackSlot{}, CmmReg (CmmLocal r)) (u, CmmLoad (ss'@CmmStackSlot{}) _)
+clobbers _ (ss@CmmStackSlot{}, CmmReg (CmmLocal r)) (u, CmmLoad (ss'@CmmStackSlot{}) _)
| getUnique r == u, ss == ss' = False -- No-op on the stack slot (XXX: Do we need this special case?)
-clobbers (CmmStackSlot a o, rhs) (_, expr) = f expr
+clobbers dflags (CmmStackSlot a o, rhs) (_, expr) = f expr
where f (CmmLoad (CmmStackSlot a' o') t)
- = (a, o, widthInBytes (cmmExprWidth rhs)) `overlaps` (a', o', widthInBytes (typeWidth t))
+ = (a, o, widthInBytes (cmmExprWidth dflags rhs)) `overlaps` (a', o', widthInBytes (typeWidth t))
f (CmmLoad e _) = containsStackSlot e
f (CmmMachOp _ es) = or (map f es)
f _ = False
@@ -418,7 +420,7 @@ clobbers (CmmStackSlot a o, rhs) (_, expr) = f expr
containsStackSlot (CmmMachOp _ es) = or (map containsStackSlot es)
containsStackSlot (CmmStackSlot{}) = True
containsStackSlot _ = False
-clobbers _ (_, e) = f e
+clobbers _ _ (_, e) = f e
where f (CmmLoad (CmmStackSlot _ _) _) = False
f (CmmLoad{}) = True -- conservative
f (CmmMachOp _ es) = or (map f es)
@@ -463,11 +465,11 @@ invalidateVolatile k m = mapUFM p m
exp _ = False
p _ = NeverOptimize -- probably shouldn't happen with AlwaysSink
-assignmentTransfer :: Platform
+assignmentTransfer :: DynFlags
-> FwdTransfer (WithRegUsage CmmNode) AssignmentMap
-assignmentTransfer platform
+assignmentTransfer dflags
= mkFTransfer3 (flip const)
- (middleAssignment platform)
+ (middleAssignment dflags)
((mkFactBase assignmentLattice .) . lastAssignment)
-- Note [Soundness of inlining]
@@ -611,8 +613,8 @@ assignmentRewrite = mkFRewrite3 first middle last
-- in literals, which we can inline more aggressively, and inlining
-- gives us opportunities for more folding. However, we don't need any
-- facts to do MachOp folding.
-machOpFoldRewrite :: Platform -> FwdRewrite UniqSM (WithRegUsage CmmNode) a
-machOpFoldRewrite platform = mkFRewrite3 first middle last
+machOpFoldRewrite :: DynFlags -> FwdRewrite UniqSM (WithRegUsage CmmNode) a
+machOpFoldRewrite dflags = mkFRewrite3 first middle last
where first _ _ = return Nothing
middle :: WithRegUsage CmmNode O O -> a -> GenCmmReplGraph (WithRegUsage CmmNode) O O
middle (Plain m) _ = return (fmap (mkMiddle . Plain) (foldNode m))
@@ -622,7 +624,7 @@ machOpFoldRewrite platform = mkFRewrite3 first middle last
last (Plain l) _ = return (fmap (mkLast . Plain) (foldNode l))
foldNode :: CmmNode e x -> Maybe (CmmNode e x)
foldNode n = mapExpDeepM foldExp n
- foldExp (CmmMachOp op args) = cmmMachOpFoldM platform op args
+ foldExp (CmmMachOp op args) = cmmMachOpFoldM dflags op args
foldExp _ = Nothing
-- ToDo: Outputable instance for UsageMap and AssignmentMap
diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs
index 71ed4f09f8..8c5c99d469 100644
--- a/compiler/cmm/CmmSink.hs
+++ b/compiler/cmm/CmmSink.hs
@@ -237,8 +237,8 @@ walk dflags nodes assigs = go nodes emptyBlock assigs
go [] block as = (block, as)
go ((live,node):ns) block as
| shouldDiscard node live = go ns block as
- | Just a <- shouldSink node1 = go ns block (a : as1)
- | otherwise = go ns block' as'
+ | Just a <- shouldSink dflags node1 = go ns block (a : as1)
+ | otherwise = go ns block' as'
where
(node1, as1) = tryToInline dflags live node as
@@ -251,10 +251,10 @@ walk dflags nodes assigs = go nodes emptyBlock assigs
-- be profitable to sink assignments to global regs too, but the
-- liveness analysis doesn't track those (yet) so we can't.
--
-shouldSink :: CmmNode e x -> Maybe Assignment
-shouldSink (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprMem e)
+shouldSink :: DynFlags -> CmmNode e x -> Maybe Assignment
+shouldSink dflags (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprMem dflags e)
where no_local_regs = True -- foldRegsUsed (\_ _ -> False) True e
-shouldSink _other = Nothing
+shouldSink _ _other = Nothing
--
-- discard dead assignments. This doesn't do as good a job as
@@ -342,7 +342,7 @@ tryToInline dflags live node assigs = go usages node [] assigs
node' = mapExpDeep inline node
where inline (CmmReg (CmmLocal l')) | l == l' = rhs
inline (CmmRegOff (CmmLocal l') off) | l == l'
- = cmmOffset rhs off
+ = cmmOffset dflags rhs off
inline other = other
go usages node skipped (assig@(l,rhs,_) : rest)
@@ -407,7 +407,7 @@ conflicts dflags (r, rhs, addr) node
| foldRegsUsed (\b r' -> r == r' || b) False node = True
-- (2) a store to an address conflicts with a read of the same memory
- | CmmStore addr' e <- node, memConflicts addr (loadAddr addr' (cmmExprWidth e)) = True
+ | CmmStore addr' e <- node, memConflicts addr (loadAddr dflags addr' (cmmExprWidth dflags e)) = True
-- (3) an assignment to Hp/Sp conflicts with a heap/stack read respectively
| HeapMem <- addr, CmmAssign (CmmGlobal Hp) _ <- node = True
@@ -480,21 +480,21 @@ memConflicts (SpMem o1 w1) (SpMem o2 w2)
| otherwise = o2 + w2 > o1
memConflicts _ _ = True
-exprMem :: CmmExpr -> AbsMem
-exprMem (CmmLoad addr w) = bothMems (loadAddr addr (typeWidth w)) (exprMem addr)
-exprMem (CmmMachOp _ es) = foldr bothMems NoMem (map exprMem es)
-exprMem _ = NoMem
+exprMem :: DynFlags -> CmmExpr -> AbsMem
+exprMem dflags (CmmLoad addr w) = bothMems (loadAddr dflags addr (typeWidth w)) (exprMem dflags addr)
+exprMem dflags (CmmMachOp _ es) = foldr bothMems NoMem (map (exprMem dflags) es)
+exprMem _ _ = NoMem
-loadAddr :: CmmExpr -> Width -> AbsMem
-loadAddr e w =
+loadAddr :: DynFlags -> CmmExpr -> Width -> AbsMem
+loadAddr dflags e w =
case e of
- CmmReg r -> regAddr r 0 w
- CmmRegOff r i -> regAddr r i w
+ CmmReg r -> regAddr dflags r 0 w
+ CmmRegOff r i -> regAddr dflags r i w
_other | CmmGlobal Sp `regUsedIn` e -> StackMem
| otherwise -> AnyMem
-regAddr :: CmmReg -> Int -> Width -> AbsMem
-regAddr (CmmGlobal Sp) i w = SpMem i (widthInBytes w)
-regAddr (CmmGlobal Hp) _ _ = HeapMem
-regAddr r _ _ | isGcPtrType (cmmRegType r) = HeapMem -- yay! GCPtr pays for itself
-regAddr _ _ _ = AnyMem
+regAddr :: DynFlags -> CmmReg -> Int -> Width -> AbsMem
+regAddr _ (CmmGlobal Sp) i w = SpMem i (widthInBytes w)
+regAddr _ (CmmGlobal Hp) _ _ = HeapMem
+regAddr dflags r _ _ | isGcPtrType (cmmRegType dflags r) = HeapMem -- yay! GCPtr pays for itself
+regAddr _ _ _ _ = AnyMem
diff --git a/compiler/cmm/CmmType.hs b/compiler/cmm/CmmType.hs
index 59455d3b54..c0ce9e3d88 100644
--- a/compiler/cmm/CmmType.hs
+++ b/compiler/cmm/CmmType.hs
@@ -17,7 +17,7 @@ where
#include "HsVersions.h"
-import Constants
+import DynFlags
import FastString
import Outputable
@@ -95,10 +95,14 @@ f32 = cmmFloat W32
f64 = cmmFloat W64
-- CmmTypes of native word widths
-bWord, bHalfWord, gcWord :: CmmType
-bWord = cmmBits wordWidth
-bHalfWord = cmmBits halfWordWidth
-gcWord = CmmType GcPtrCat wordWidth
+bWord :: DynFlags -> CmmType
+bWord dflags = cmmBits (wordWidth dflags)
+
+bHalfWord :: DynFlags -> CmmType
+bHalfWord dflags = cmmBits (halfWordWidth dflags)
+
+gcWord :: DynFlags -> CmmType
+gcWord dflags = CmmType GcPtrCat (wordWidth dflags)
cInt, cLong :: CmmType
cInt = cmmBits cIntWidth
@@ -155,19 +159,23 @@ mrStr W80 = sLit("W80")
-------- Common Widths ------------
-wordWidth, halfWordWidth :: Width
-wordWidth | wORD_SIZE == 4 = W32
- | wORD_SIZE == 8 = W64
- | otherwise = panic "MachOp.wordRep: Unknown word size"
-
-halfWordWidth | wORD_SIZE == 4 = W16
- | wORD_SIZE == 8 = W32
- | otherwise = panic "MachOp.halfWordRep: Unknown word size"
-
-halfWordMask :: Integer
-halfWordMask | wORD_SIZE == 4 = 0xFFFF
- | wORD_SIZE == 8 = 0xFFFFFFFF
- | otherwise = panic "MachOp.halfWordMask: Unknown word size"
+wordWidth :: DynFlags -> Width
+wordWidth dflags
+ | wORD_SIZE dflags == 4 = W32
+ | wORD_SIZE dflags == 8 = W64
+ | otherwise = panic "MachOp.wordRep: Unknown word size"
+
+halfWordWidth :: DynFlags -> Width
+halfWordWidth dflags
+ | wORD_SIZE dflags == 4 = W16
+ | wORD_SIZE dflags == 8 = W32
+ | otherwise = panic "MachOp.halfWordRep: Unknown word size"
+
+halfWordMask :: DynFlags -> Integer
+halfWordMask dflags
+ | wORD_SIZE dflags == 4 = 0xFFFF
+ | wORD_SIZE dflags == 8 = 0xFFFFFFFF
+ | otherwise = panic "MachOp.halfWordMask: Unknown word size"
-- cIntRep is the Width for a C-language 'int'
cIntWidth, cLongWidth :: Width
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
index 615e2fd625..bff4804fc2 100644
--- a/compiler/cmm/CmmUtils.hs
+++ b/compiler/cmm/CmmUtils.hs
@@ -1,10 +1,4 @@
{-# LANGUAGE GADTs #-}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
{-# OPTIONS_GHC -fno-warn-deprecations #-}
-- Warnings from deprecated blockToNodeList
@@ -18,36 +12,37 @@
--
-----------------------------------------------------------------------------
-module CmmUtils(
+module CmmUtils(
-- CmmType
- primRepCmmType, primRepForeignHint,
- typeCmmType, typeForeignHint,
+ primRepCmmType, primRepForeignHint,
+ typeCmmType, typeForeignHint,
- -- CmmLit
- zeroCLit, mkIntCLit,
- mkWordCLit, packHalfWordsCLit,
- mkByteStringCLit,
+ -- CmmLit
+ zeroCLit, mkIntCLit,
+ mkWordCLit, packHalfWordsCLit,
+ mkByteStringCLit,
mkDataLits, mkRODataLits,
- -- CmmExpr
- mkLblExpr,
- cmmRegOff, cmmOffset, cmmLabelOff, cmmOffsetLit, cmmOffsetExpr,
- cmmRegOffB, cmmOffsetB, cmmLabelOffB, cmmOffsetLitB, cmmOffsetExprB,
- cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW,
- cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW,
- cmmNegate,
- cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord,
- cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord,
- cmmUShrWord, cmmAddWord, cmmMulWord,
-
- isTrivialCmmExpr, hasNoGlobalRegs,
-
- -- Statics
- blankWord,
-
- -- Tagging
- cmmTagMask, cmmPointerMask, cmmUntag, cmmGetTag, cmmIsTagged,
- cmmConstrTag, cmmConstrTag1,
+ -- CmmExpr
+ mkIntExpr, zeroExpr,
+ mkLblExpr,
+ cmmRegOff, cmmOffset, cmmLabelOff, cmmOffsetLit, cmmOffsetExpr,
+ cmmRegOffB, cmmOffsetB, cmmLabelOffB, cmmOffsetLitB, cmmOffsetExprB,
+ cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW,
+ cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW,
+ cmmNegate,
+ cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord,
+ cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord,
+ cmmUShrWord, cmmAddWord, cmmMulWord, cmmQuotWord,
+
+ isTrivialCmmExpr, hasNoGlobalRegs,
+
+ -- Statics
+ blankWord,
+
+ -- Tagging
+ cmmTagMask, cmmPointerMask, cmmUntag, cmmGetTag, cmmIsTagged,
+ cmmConstrTag, cmmConstrTag1,
-- Liveness and bitmaps
mkLiveness,
@@ -59,7 +54,7 @@ module CmmUtils(
ofBlockMap, toBlockMap, insertBlock,
ofBlockList, toBlockList, bodyToBlockList,
foldGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1,
-
+
analFwd, analBwd, analRewFwd, analRewBwd,
dataflowPassFwd, dataflowPassBwd, dataflowAnalFwd, dataflowAnalBwd,
dataflowAnalFwdBlocks
@@ -67,8 +62,8 @@ module CmmUtils(
#include "HsVersions.h"
-import TyCon ( PrimRep(..) )
-import Type ( UnaryType, typePrimRep )
+import TyCon ( PrimRep(..) )
+import Type ( UnaryType, typePrimRep )
import SMRep
import Cmm
@@ -77,7 +72,7 @@ import CLabel
import Outputable
import Unique
import UniqSupply
-import Constants( wORD_SIZE, tAG_MASK )
+import DynFlags
import Util
import Data.Word
@@ -87,52 +82,58 @@ import Hoopl
---------------------------------------------------
--
--- CmmTypes
+-- CmmTypes
--
---------------------------------------------------
-primRepCmmType :: PrimRep -> CmmType
-primRepCmmType VoidRep = panic "primRepCmmType:VoidRep"
-primRepCmmType PtrRep = gcWord
-primRepCmmType IntRep = bWord
-primRepCmmType WordRep = bWord
-primRepCmmType Int64Rep = b64
-primRepCmmType Word64Rep = b64
-primRepCmmType AddrRep = bWord
-primRepCmmType FloatRep = f32
-primRepCmmType DoubleRep = f64
+primRepCmmType :: DynFlags -> PrimRep -> CmmType
+primRepCmmType _ VoidRep = panic "primRepCmmType:VoidRep"
+primRepCmmType dflags PtrRep = gcWord dflags
+primRepCmmType dflags IntRep = bWord dflags
+primRepCmmType dflags WordRep = bWord dflags
+primRepCmmType _ Int64Rep = b64
+primRepCmmType _ Word64Rep = b64
+primRepCmmType dflags AddrRep = bWord dflags
+primRepCmmType _ FloatRep = f32
+primRepCmmType _ DoubleRep = f64
-typeCmmType :: UnaryType -> CmmType
-typeCmmType ty = primRepCmmType (typePrimRep ty)
+typeCmmType :: DynFlags -> UnaryType -> CmmType
+typeCmmType dflags ty = primRepCmmType dflags (typePrimRep ty)
primRepForeignHint :: PrimRep -> ForeignHint
-primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep"
-primRepForeignHint PtrRep = AddrHint
-primRepForeignHint IntRep = SignedHint
-primRepForeignHint WordRep = NoHint
-primRepForeignHint Int64Rep = SignedHint
-primRepForeignHint Word64Rep = NoHint
+primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep"
+primRepForeignHint PtrRep = AddrHint
+primRepForeignHint IntRep = SignedHint
+primRepForeignHint WordRep = NoHint
+primRepForeignHint Int64Rep = SignedHint
+primRepForeignHint Word64Rep = NoHint
primRepForeignHint AddrRep = AddrHint -- NB! AddrHint, but NonPtrArg
-primRepForeignHint FloatRep = NoHint
-primRepForeignHint DoubleRep = NoHint
+primRepForeignHint FloatRep = NoHint
+primRepForeignHint DoubleRep = NoHint
typeForeignHint :: UnaryType -> ForeignHint
typeForeignHint = primRepForeignHint . typePrimRep
---------------------------------------------------
--
--- CmmLit
+-- CmmLit
--
---------------------------------------------------
-mkIntCLit :: Int -> CmmLit
-mkIntCLit i = CmmInt (toInteger i) wordWidth
+mkIntCLit :: DynFlags -> Int -> CmmLit
+mkIntCLit dflags i = CmmInt (toInteger i) (wordWidth dflags)
-zeroCLit :: CmmLit
-zeroCLit = CmmInt 0 wordWidth
+mkIntExpr :: DynFlags -> Int -> CmmExpr
+mkIntExpr dflags i = CmmLit $! mkIntCLit dflags i
+
+zeroCLit :: DynFlags -> CmmLit
+zeroCLit dflags = CmmInt 0 (wordWidth dflags)
+
+zeroExpr :: DynFlags -> CmmExpr
+zeroExpr dflags = CmmLit (zeroCLit dflags)
mkByteStringCLit :: Unique -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt)
--- We have to make a top-level decl for the string,
+-- We have to make a top-level decl for the string,
-- and return a literal pointing to it
mkByteStringCLit uniq bytes
= (CmmLabel lbl, CmmData ReadOnlyData $ Statics lbl [CmmString bytes])
@@ -147,44 +148,44 @@ mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
-- Build a read-only data block
mkRODataLits lbl lits
= mkDataLits section lbl lits
- where
+ where
section | any needsRelocation lits = RelocatableReadOnlyData
| otherwise = ReadOnlyData
needsRelocation (CmmLabel _) = True
needsRelocation (CmmLabelOff _ _) = True
needsRelocation _ = False
-mkWordCLit :: StgWord -> CmmLit
-mkWordCLit wd = CmmInt (fromIntegral wd) wordWidth
+mkWordCLit :: DynFlags -> StgWord -> CmmLit
+mkWordCLit dflags wd = CmmInt (fromIntegral wd) (wordWidth dflags)
-packHalfWordsCLit :: (Integral a, Integral b) => a -> b -> CmmLit
+packHalfWordsCLit :: (Integral a, Integral b) => DynFlags -> a -> b -> CmmLit
-- Make a single word literal in which the lower_half_word is
--- at the lower address, and the upper_half_word is at the
+-- at the lower address, and the upper_half_word is at the
-- higher address
-- ToDo: consider using half-word lits instead
--- but be careful: that's vulnerable when reversed
-packHalfWordsCLit lower_half_word upper_half_word
+-- but be careful: that's vulnerable when reversed
+packHalfWordsCLit dflags lower_half_word upper_half_word
#ifdef WORDS_BIGENDIAN
- = mkWordCLit ((fromIntegral lower_half_word `shiftL` hALF_WORD_SIZE_IN_BITS)
- .|. fromIntegral upper_half_word)
-#else
- = mkWordCLit ((fromIntegral lower_half_word)
- .|. (fromIntegral upper_half_word `shiftL` hALF_WORD_SIZE_IN_BITS))
+ = mkWordCLit dflags ((fromIntegral lower_half_word `shiftL` hALF_WORD_SIZE_IN_BITS)
+ .|. fromIntegral upper_half_word)
+#else
+ = mkWordCLit dflags ((fromIntegral lower_half_word)
+ .|. (fromIntegral upper_half_word `shiftL` hALF_WORD_SIZE_IN_BITS))
#endif
---------------------------------------------------
--
--- CmmExpr
+-- CmmExpr
--
---------------------------------------------------
mkLblExpr :: CLabel -> CmmExpr
mkLblExpr lbl = CmmLit (CmmLabel lbl)
-cmmOffsetExpr :: CmmExpr -> CmmExpr -> CmmExpr
+cmmOffsetExpr :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
-- assumes base and offset have the same CmmType
-cmmOffsetExpr e (CmmLit (CmmInt n _)) = cmmOffset e (fromInteger n)
-cmmOffsetExpr e byte_off = CmmMachOp (MO_Add (cmmExprWidth e)) [e, byte_off]
+cmmOffsetExpr dflags e (CmmLit (CmmInt n _)) = cmmOffset dflags e (fromInteger n)
+cmmOffsetExpr dflags e byte_off = CmmMachOp (MO_Add (cmmExprWidth dflags e)) [e, byte_off]
-- NB. Do *not* inspect the value of the offset in these smart constructors!!!
-- because the offset is sometimes involved in a loop in the code generator
@@ -193,28 +194,28 @@ cmmOffsetExpr e byte_off = CmmMachOp (MO_Add (cmmExprWidth e)) [e, byte_off]
-- stage; they're eliminated later instead (either during printing or
-- a later optimisation step on Cmm).
--
-cmmOffset :: CmmExpr -> Int -> CmmExpr
-cmmOffset e 0 = e
-cmmOffset (CmmReg reg) byte_off = cmmRegOff reg byte_off
-cmmOffset (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off)
-cmmOffset (CmmLit lit) byte_off = CmmLit (cmmOffsetLit lit byte_off)
-cmmOffset (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2
- = CmmMachOp (MO_Add rep)
- [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)]
-cmmOffset expr byte_off
+cmmOffset :: DynFlags -> CmmExpr -> Int -> CmmExpr
+cmmOffset _ e 0 = e
+cmmOffset _ (CmmReg reg) byte_off = cmmRegOff reg byte_off
+cmmOffset _ (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off)
+cmmOffset _ (CmmLit lit) byte_off = CmmLit (cmmOffsetLit lit byte_off)
+cmmOffset _ (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2
+ = CmmMachOp (MO_Add rep)
+ [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)]
+cmmOffset dflags expr byte_off
= CmmMachOp (MO_Add width) [expr, CmmLit (CmmInt (toInteger byte_off) width)]
where
- width = cmmExprWidth expr
+ width = cmmExprWidth dflags expr
-- Smart constructor for CmmRegOff. Same caveats as cmmOffset above.
cmmRegOff :: CmmReg -> Int -> CmmExpr
cmmRegOff reg byte_off = CmmRegOff reg byte_off
cmmOffsetLit :: CmmLit -> Int -> CmmLit
-cmmOffsetLit (CmmLabel l) byte_off = cmmLabelOff l byte_off
-cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off)
+cmmOffsetLit (CmmLabel l) byte_off = cmmLabelOff l byte_off
+cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off)
cmmOffsetLit (CmmInt m rep) byte_off = CmmInt (m + fromIntegral byte_off) rep
-cmmOffsetLit _ byte_off = pprPanic "cmmOffsetLit" (ppr byte_off)
+cmmOffsetLit _ byte_off = pprPanic "cmmOffsetLit" (ppr byte_off)
cmmLabelOff :: CLabel -> Int -> CmmLit
-- Smart constructor for CmmLabelOff
@@ -223,35 +224,37 @@ cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off
-- | Useful for creating an index into an array, with a staticaly known offset.
-- The type is the element type; used for making the multiplier
-cmmIndex :: Width -- Width w
- -> CmmExpr -- Address of vector of items of width w
- -> Int -- Which element of the vector (0 based)
- -> CmmExpr -- Address of i'th element
-cmmIndex width base idx = cmmOffset base (idx * widthInBytes width)
+cmmIndex :: DynFlags
+ -> Width -- Width w
+ -> CmmExpr -- Address of vector of items of width w
+ -> Int -- Which element of the vector (0 based)
+ -> CmmExpr -- Address of i'th element
+cmmIndex dflags width base idx = cmmOffset dflags base (idx * widthInBytes width)
-- | Useful for creating an index into an array, with an unknown offset.
-cmmIndexExpr :: Width -- Width w
- -> CmmExpr -- Address of vector of items of width w
- -> CmmExpr -- Which element of the vector (0 based)
- -> CmmExpr -- Address of i'th element
-cmmIndexExpr width base (CmmLit (CmmInt n _)) = cmmIndex width base (fromInteger n)
-cmmIndexExpr width base idx =
- cmmOffsetExpr base byte_off
+cmmIndexExpr :: DynFlags
+ -> Width -- Width w
+ -> CmmExpr -- Address of vector of items of width w
+ -> CmmExpr -- Which element of the vector (0 based)
+ -> CmmExpr -- Address of i'th element
+cmmIndexExpr dflags width base (CmmLit (CmmInt n _)) = cmmIndex dflags width base (fromInteger n)
+cmmIndexExpr dflags width base idx =
+ cmmOffsetExpr dflags base byte_off
where
- idx_w = cmmExprWidth idx
- byte_off = CmmMachOp (MO_Shl idx_w) [idx, CmmLit (mkIntCLit (widthInLog width))]
+ idx_w = cmmExprWidth dflags idx
+ byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr dflags (widthInLog width)]
-cmmLoadIndex :: CmmType -> CmmExpr -> Int -> CmmExpr
-cmmLoadIndex ty expr ix = CmmLoad (cmmIndex (typeWidth ty) expr ix) ty
+cmmLoadIndex :: DynFlags -> CmmType -> CmmExpr -> Int -> CmmExpr
+cmmLoadIndex dflags ty expr ix = CmmLoad (cmmIndex dflags (typeWidth ty) expr ix) ty
-- The "B" variants take byte offsets
cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
cmmRegOffB = cmmRegOff
-cmmOffsetB :: CmmExpr -> ByteOff -> CmmExpr
+cmmOffsetB :: DynFlags -> CmmExpr -> ByteOff -> CmmExpr
cmmOffsetB = cmmOffset
-cmmOffsetExprB :: CmmExpr -> CmmExpr -> CmmExpr
+cmmOffsetExprB :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmOffsetExprB = cmmOffsetExpr
cmmLabelOffB :: CLabel -> ByteOff -> CmmLit
@@ -262,103 +265,103 @@ cmmOffsetLitB = cmmOffsetLit
-----------------------
-- The "W" variants take word offsets
-cmmOffsetExprW :: CmmExpr -> CmmExpr -> CmmExpr
+cmmOffsetExprW :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
-- The second arg is a *word* offset; need to change it to bytes
-cmmOffsetExprW e (CmmLit (CmmInt n _)) = cmmOffsetW e (fromInteger n)
-cmmOffsetExprW e wd_off = cmmIndexExpr wordWidth e wd_off
+cmmOffsetExprW dflags e (CmmLit (CmmInt n _)) = cmmOffsetW dflags e (fromInteger n)
+cmmOffsetExprW dflags e wd_off = cmmIndexExpr dflags (wordWidth dflags) e wd_off
-cmmOffsetW :: CmmExpr -> WordOff -> CmmExpr
-cmmOffsetW e n = cmmOffsetB e (wORD_SIZE * n)
+cmmOffsetW :: DynFlags -> CmmExpr -> WordOff -> CmmExpr
+cmmOffsetW dflags e n = cmmOffsetB dflags e (wORD_SIZE dflags * n)
-cmmRegOffW :: CmmReg -> WordOff -> CmmExpr
-cmmRegOffW reg wd_off = cmmRegOffB reg (wd_off * wORD_SIZE)
+cmmRegOffW :: DynFlags -> CmmReg -> WordOff -> CmmExpr
+cmmRegOffW dflags reg wd_off = cmmRegOffB reg (wd_off * wORD_SIZE dflags)
-cmmOffsetLitW :: CmmLit -> WordOff -> CmmLit
-cmmOffsetLitW lit wd_off = cmmOffsetLitB lit (wORD_SIZE * wd_off)
+cmmOffsetLitW :: DynFlags -> CmmLit -> WordOff -> CmmLit
+cmmOffsetLitW dflags lit wd_off = cmmOffsetLitB lit (wORD_SIZE dflags * wd_off)
-cmmLabelOffW :: CLabel -> WordOff -> CmmLit
-cmmLabelOffW lbl wd_off = cmmLabelOffB lbl (wORD_SIZE * wd_off)
+cmmLabelOffW :: DynFlags -> CLabel -> WordOff -> CmmLit
+cmmLabelOffW dflags lbl wd_off = cmmLabelOffB lbl (wORD_SIZE dflags * wd_off)
-cmmLoadIndexW :: CmmExpr -> Int -> CmmType -> CmmExpr
-cmmLoadIndexW base off ty = CmmLoad (cmmOffsetW base off) ty
+cmmLoadIndexW :: DynFlags -> CmmExpr -> Int -> CmmType -> CmmExpr
+cmmLoadIndexW dflags base off ty = CmmLoad (cmmOffsetW dflags base off) ty
-----------------------
cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord,
cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord,
- cmmUShrWord, cmmAddWord, cmmMulWord
- :: CmmExpr -> CmmExpr -> CmmExpr
-cmmOrWord e1 e2 = CmmMachOp mo_wordOr [e1, e2]
-cmmAndWord e1 e2 = CmmMachOp mo_wordAnd [e1, e2]
-cmmNeWord e1 e2 = CmmMachOp mo_wordNe [e1, e2]
-cmmEqWord e1 e2 = CmmMachOp mo_wordEq [e1, e2]
-cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2]
-cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2]
-cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2]
---cmmShlWord e1 e2 = CmmMachOp mo_wordShl [e1, e2]
-cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2]
-cmmAddWord e1 e2 = CmmMachOp mo_wordAdd [e1, e2]
-cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2]
-cmmMulWord e1 e2 = CmmMachOp mo_wordMul [e1, e2]
-
-cmmNegate :: CmmExpr -> CmmExpr
-cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
-cmmNegate e = CmmMachOp (MO_S_Neg (cmmExprWidth e)) [e]
-
-blankWord :: CmmStatic
-blankWord = CmmUninitialised wORD_SIZE
+ cmmUShrWord, cmmAddWord, cmmMulWord, cmmQuotWord
+ :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
+cmmOrWord dflags e1 e2 = CmmMachOp (mo_wordOr dflags) [e1, e2]
+cmmAndWord dflags e1 e2 = CmmMachOp (mo_wordAnd dflags) [e1, e2]
+cmmNeWord dflags e1 e2 = CmmMachOp (mo_wordNe dflags) [e1, e2]
+cmmEqWord dflags e1 e2 = CmmMachOp (mo_wordEq dflags) [e1, e2]
+cmmULtWord dflags e1 e2 = CmmMachOp (mo_wordULt dflags) [e1, e2]
+cmmUGeWord dflags e1 e2 = CmmMachOp (mo_wordUGe dflags) [e1, e2]
+cmmUGtWord dflags e1 e2 = CmmMachOp (mo_wordUGt dflags) [e1, e2]
+--cmmShlWord dflags e1 e2 = CmmMachOp (mo_wordShl dflags) [e1, e2]
+cmmUShrWord dflags e1 e2 = CmmMachOp (mo_wordUShr dflags) [e1, e2]
+cmmAddWord dflags e1 e2 = CmmMachOp (mo_wordAdd dflags) [e1, e2]
+cmmSubWord dflags e1 e2 = CmmMachOp (mo_wordSub dflags) [e1, e2]
+cmmMulWord dflags e1 e2 = CmmMachOp (mo_wordMul dflags) [e1, e2]
+cmmQuotWord dflags e1 e2 = CmmMachOp (mo_wordUQuot dflags) [e1, e2]
+
+cmmNegate :: DynFlags -> CmmExpr -> CmmExpr
+cmmNegate _ (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
+cmmNegate dflags e = CmmMachOp (MO_S_Neg (cmmExprWidth dflags e)) [e]
+
+blankWord :: DynFlags -> CmmStatic
+blankWord dflags = CmmUninitialised (wORD_SIZE dflags)
---------------------------------------------------
--
--- CmmExpr predicates
+-- CmmExpr predicates
--
---------------------------------------------------
isTrivialCmmExpr :: CmmExpr -> Bool
-isTrivialCmmExpr (CmmLoad _ _) = False
-isTrivialCmmExpr (CmmMachOp _ _) = False
-isTrivialCmmExpr (CmmLit _) = True
-isTrivialCmmExpr (CmmReg _) = True
-isTrivialCmmExpr (CmmRegOff _ _) = True
+isTrivialCmmExpr (CmmLoad _ _) = False
+isTrivialCmmExpr (CmmMachOp _ _) = False
+isTrivialCmmExpr (CmmLit _) = True
+isTrivialCmmExpr (CmmReg _) = True
+isTrivialCmmExpr (CmmRegOff _ _) = True
isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot"
hasNoGlobalRegs :: CmmExpr -> Bool
-hasNoGlobalRegs (CmmLoad e _) = hasNoGlobalRegs e
-hasNoGlobalRegs (CmmMachOp _ es) = all hasNoGlobalRegs es
-hasNoGlobalRegs (CmmLit _) = True
+hasNoGlobalRegs (CmmLoad e _) = hasNoGlobalRegs e
+hasNoGlobalRegs (CmmMachOp _ es) = all hasNoGlobalRegs es
+hasNoGlobalRegs (CmmLit _) = True
hasNoGlobalRegs (CmmReg (CmmLocal _)) = True
hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True
hasNoGlobalRegs _ = False
---------------------------------------------------
--
--- Tagging
+-- Tagging
--
---------------------------------------------------
-- Tag bits mask
--cmmTagBits = CmmLit (mkIntCLit tAG_BITS)
-cmmTagMask, cmmPointerMask :: CmmExpr
-cmmTagMask = CmmLit (mkIntCLit tAG_MASK)
-cmmPointerMask = CmmLit (mkIntCLit (complement tAG_MASK))
+cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr
+cmmTagMask dflags = mkIntExpr dflags (tAG_MASK dflags)
+cmmPointerMask dflags = mkIntExpr dflags (complement (tAG_MASK dflags))
-- Used to untag a possibly tagged pointer
-- A static label need not be untagged
-cmmUntag, cmmGetTag :: CmmExpr -> CmmExpr
-cmmUntag e@(CmmLit (CmmLabel _)) = e
+cmmUntag, cmmGetTag :: DynFlags -> CmmExpr -> CmmExpr
+cmmUntag _ e@(CmmLit (CmmLabel _)) = e
-- Default case
-cmmUntag e = (e `cmmAndWord` cmmPointerMask)
+cmmUntag dflags e = cmmAndWord dflags e (cmmPointerMask dflags)
-cmmGetTag e = (e `cmmAndWord` cmmTagMask)
+cmmGetTag dflags e = cmmAndWord dflags e (cmmTagMask dflags)
-- Test if a closure pointer is untagged
-cmmIsTagged :: CmmExpr -> CmmExpr
-cmmIsTagged e = (e `cmmAndWord` cmmTagMask)
- `cmmNeWord` CmmLit zeroCLit
+cmmIsTagged :: DynFlags -> CmmExpr -> CmmExpr
+cmmIsTagged dflags e = cmmNeWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (zeroExpr dflags)
-cmmConstrTag, cmmConstrTag1 :: CmmExpr -> CmmExpr
-cmmConstrTag e = (e `cmmAndWord` cmmTagMask) `cmmSubWord` (CmmLit (mkIntCLit 1))
+cmmConstrTag, cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr
+cmmConstrTag dflags e = cmmSubWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (mkIntExpr dflags 1)
-- Get constructor tag, but one based.
-cmmConstrTag1 e = e `cmmAndWord` cmmTagMask
+cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags)
--------------------------------------------
@@ -367,15 +370,15 @@ cmmConstrTag1 e = e `cmmAndWord` cmmTagMask
--
---------------------------------------------
-mkLiveness :: [Maybe LocalReg] -> Liveness
-mkLiveness [] = []
-mkLiveness (reg:regs)
- = take sizeW bits ++ mkLiveness regs
+mkLiveness :: DynFlags -> [Maybe LocalReg] -> Liveness
+mkLiveness _ [] = []
+mkLiveness dflags (reg:regs)
+ = take sizeW bits ++ mkLiveness dflags regs
where
sizeW = case reg of
Nothing -> 1
- Just r -> (widthInBytes (typeWidth (localRegType r)) + wORD_SIZE - 1)
- `quot` wORD_SIZE
+ Just r -> (widthInBytes (typeWidth (localRegType r)) + wORD_SIZE dflags - 1)
+ `quot` wORD_SIZE dflags
-- number of words, rounded up
bits = repeat $ is_non_ptr reg -- True <=> Non Ptr
diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs
index 8952ba1803..3233dbed8c 100644
--- a/compiler/cmm/MkGraph.hs
+++ b/compiler/cmm/MkGraph.hs
@@ -231,7 +231,7 @@ mkReturn dflags e actuals updfr_off =
mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkReturnSimple dflags actuals updfr_off =
mkReturn dflags e actuals updfr_off
- where e = CmmLoad (CmmStackSlot Old updfr_off) gcWord
+ where e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags)
mkBranch :: BlockId -> CmmAGraph
mkBranch bid = mkLast (CmmBranch bid)
@@ -306,7 +306,7 @@ copyIn dflags oflow conv area formals =
where ci (reg, RegisterParam r) (n, ms) =
(n, CmmAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) : ms)
ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms)
- init_offset = widthInBytes wordWidth -- infotable
+ init_offset = widthInBytes (wordWidth dflags) -- infotable
args = assignArgumentsPos dflags conv localRegType formals
args' = foldl adjust [] args
where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
@@ -356,10 +356,10 @@ copyOutOflow dflags conv transfer area actuals updfr_off
case transfer of
Call ->
([(CmmLit (CmmBlock id), StackParam init_offset)],
- widthInBytes wordWidth)
+ widthInBytes (wordWidth dflags))
JumpRet ->
([],
- widthInBytes wordWidth)
+ widthInBytes (wordWidth dflags))
_other ->
([], 0)
Old -> ([], updfr_off)
@@ -367,7 +367,7 @@ copyOutOflow dflags conv transfer area actuals updfr_off
arg_offset = init_offset + extra_stack_off
args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it
- args = assignArgumentsPos dflags conv cmmExprType actuals
+ args = assignArgumentsPos dflags conv (cmmExprType dflags) actuals
args' = foldl adjust setRA args
where adjust rst (v, StackParam off) = (v, StackParam (off + arg_offset)) : rst
diff --git a/compiler/cmm/OldCmmLint.hs b/compiler/cmm/OldCmmLint.hs
index 72e40ce4f8..5dd3209892 100644
--- a/compiler/cmm/OldCmmLint.hs
+++ b/compiler/cmm/OldCmmLint.hs
@@ -22,9 +22,8 @@ import OldCmm
import CLabel
import Outputable
import OldPprCmm()
-import Constants
import FastString
-import Platform
+import DynFlags
import Data.Maybe
@@ -32,15 +31,15 @@ import Data.Maybe
-- Exported entry points:
cmmLint :: (Outputable d, Outputable h)
- => Platform -> GenCmmGroup d h (ListGraph CmmStmt) -> Maybe SDoc
-cmmLint platform tops = runCmmLint platform (mapM_ (lintCmmDecl platform)) tops
+ => DynFlags -> GenCmmGroup d h (ListGraph CmmStmt) -> Maybe SDoc
+cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops
cmmLintTop :: (Outputable d, Outputable h)
- => Platform -> GenCmmDecl d h (ListGraph CmmStmt) -> Maybe SDoc
-cmmLintTop platform top = runCmmLint platform (lintCmmDecl platform) top
+ => DynFlags -> GenCmmDecl d h (ListGraph CmmStmt) -> Maybe SDoc
+cmmLintTop dflags top = runCmmLint dflags (lintCmmDecl dflags) top
runCmmLint :: Outputable a
- => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc
+ => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc
runCmmLint _ l p =
case unCL (l p) of
Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"),
@@ -49,19 +48,20 @@ runCmmLint _ l p =
nest 2 (ppr p)])
Right _ -> Nothing
-lintCmmDecl :: Platform -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint ()
-lintCmmDecl platform (CmmProc _ lbl (ListGraph blocks))
+lintCmmDecl :: DynFlags -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint ()
+lintCmmDecl dflags (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 platform labels) blocks
+ in mapM_ (lintCmmBlock dflags labels) blocks
+ where platform = targetPlatform dflags
lintCmmDecl _ (CmmData {})
= return ()
-lintCmmBlock :: Platform -> BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
-lintCmmBlock platform labels (BasicBlock id stmts)
+lintCmmBlock :: DynFlags -> BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
+lintCmmBlock dflags labels (BasicBlock id stmts)
= addLintInfo (text "in basic block " <> ppr id) $
- mapM_ (lintCmmStmt platform labels) stmts
+ mapM_ (lintCmmStmt dflags labels) stmts
-- -----------------------------------------------------------------------------
-- lintCmmExpr
@@ -69,33 +69,34 @@ lintCmmBlock platform labels (BasicBlock id stmts)
-- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
-- byte/word mismatches.
-lintCmmExpr :: Platform -> CmmExpr -> CmmLint CmmType
-lintCmmExpr platform (CmmLoad expr rep) = do
- _ <- lintCmmExpr platform expr
+lintCmmExpr :: DynFlags -> CmmExpr -> CmmLint CmmType
+lintCmmExpr dflags (CmmLoad expr rep) = do
+ _ <- lintCmmExpr dflags 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 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 platform (CmmRegOff reg offset)
- = lintCmmExpr platform (CmmMachOp (MO_Add rep)
+lintCmmExpr dflags expr@(CmmMachOp op args) = do
+ tys <- mapM (lintCmmExpr dflags) args
+ if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op
+ then cmmCheckMachOp dflags op args tys
+ else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op)
+lintCmmExpr dflags (CmmRegOff reg offset)
+ = lintCmmExpr dflags (CmmMachOp (MO_Add rep)
[CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
- where rep = typeWidth (cmmRegType reg)
-lintCmmExpr _ expr =
- return (cmmExprType expr)
+ where rep = typeWidth (cmmRegType dflags reg)
+lintCmmExpr dflags expr =
+ return (cmmExprType dflags expr)
-- Check for some common byte/word mismatches (eg. Sp + 1)
-cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
-cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
- = cmmCheckMachOp op [reg, lit] tys
-cmmCheckMachOp op _ tys
- = return (machOpResultType op tys)
+cmmCheckMachOp :: DynFlags -> MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
+cmmCheckMachOp dflags op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
+ = cmmCheckMachOp dflags op [reg, lit] tys
+cmmCheckMachOp dflags op _ tys
+ = return (machOpResultType dflags op tys)
+{-
isOffsetOp :: MachOp -> Bool
isOffsetOp (MO_Add _) = True
isOffsetOp (MO_Sub _) = True
@@ -105,10 +106,10 @@ isOffsetOp _ = False
-- check for funny-looking sub-word offsets.
_cmmCheckWordAddress :: CmmExpr -> CmmLint ()
_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
- | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
+ | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0
= cmmLintDubiousWordOffset e
_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
- | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
+ | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0
= cmmLintDubiousWordOffset e
_cmmCheckWordAddress _
= return ()
@@ -118,50 +119,51 @@ _cmmCheckWordAddress _
notNodeReg :: CmmExpr -> Bool
notNodeReg (CmmReg reg) | reg == nodeReg = False
notNodeReg _ = True
+-}
-lintCmmStmt :: Platform -> BlockSet -> CmmStmt -> CmmLint ()
-lintCmmStmt platform labels = lint
+lintCmmStmt :: DynFlags -> BlockSet -> CmmStmt -> CmmLint ()
+lintCmmStmt dflags labels = lint
where lint (CmmNop) = return ()
lint (CmmComment {}) = return ()
lint stmt@(CmmAssign reg expr) = do
- erep <- lintCmmExpr platform expr
- let reg_ty = cmmRegType reg
+ erep <- lintCmmExpr dflags expr
+ let reg_ty = cmmRegType dflags reg
if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
then return ()
else cmmLintAssignErr stmt erep reg_ty
lint (CmmStore l r) = do
- _ <- lintCmmExpr platform l
- _ <- lintCmmExpr platform r
+ _ <- lintCmmExpr dflags l
+ _ <- lintCmmExpr dflags r
return ()
lint (CmmCall target _res args _) =
- do lintTarget platform labels target
- mapM_ (lintCmmExpr platform . hintlessCmm) args
- lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr platform e >> checkCond e
+ do lintTarget dflags labels target
+ mapM_ (lintCmmExpr dflags . hintlessCmm) args
+ lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr dflags e >> checkCond dflags e
lint (CmmSwitch e branches) = do
mapM_ checkTarget $ catMaybes branches
- erep <- lintCmmExpr platform e
- if (erep `cmmEqType_ignoring_ptrhood` bWord)
+ erep <- lintCmmExpr dflags e
+ if (erep `cmmEqType_ignoring_ptrhood` bWord dflags)
then return ()
else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e <>
text " :: " <> ppr erep)
- lint (CmmJump e _) = lintCmmExpr platform e >> return ()
+ lint (CmmJump e _) = lintCmmExpr dflags e >> return ()
lint (CmmReturn) = return ()
lint (CmmBranch id) = checkTarget id
checkTarget id = if setMember id labels then return ()
else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
-lintTarget :: Platform -> BlockSet -> CmmCallTarget -> CmmLint ()
-lintTarget platform _ (CmmCallee e _) = do _ <- lintCmmExpr platform e
- return ()
-lintTarget _ _ (CmmPrim _ Nothing) = return ()
-lintTarget platform labels (CmmPrim _ (Just stmts))
- = mapM_ (lintCmmStmt platform labels) stmts
+lintTarget :: DynFlags -> BlockSet -> CmmCallTarget -> CmmLint ()
+lintTarget dflags _ (CmmCallee e _) = do _ <- lintCmmExpr dflags e
+ return ()
+lintTarget _ _ (CmmPrim _ Nothing) = return ()
+lintTarget dflags labels (CmmPrim _ (Just stmts))
+ = mapM_ (lintCmmStmt dflags labels) stmts
-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
+checkCond :: DynFlags -> CmmExpr -> CmmLint ()
+checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()
+checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values
+checkCond _ expr
= cmmLintErr (hang (text "expression is not a conditional:") 2
(ppr expr))
@@ -203,7 +205,10 @@ cmmLintAssignErr stmt e_ty r_ty
+{-
cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
cmmLintDubiousWordOffset expr
= cmmLintErr (text "offset is not a multiple of words: " $$
nest 2 (ppr expr))
+-}
+
diff --git a/compiler/cmm/OldCmmUtils.hs b/compiler/cmm/OldCmmUtils.hs
index 0ec7a25f15..fe6ccee642 100644
--- a/compiler/cmm/OldCmmUtils.hs
+++ b/compiler/cmm/OldCmmUtils.hs
@@ -20,6 +20,7 @@ module OldCmmUtils(
import OldCmm
import CmmUtils
import OrdList
+import DynFlags
import Unique
---------------------------------------------------
@@ -77,23 +78,23 @@ cheapEqReg _ _ = False
--
---------------------------------------------------
-loadArgsIntoTemps :: [Unique]
+loadArgsIntoTemps :: DynFlags -> [Unique]
-> [HintedCmmActual]
-> ([Unique], [CmmStmt], [HintedCmmActual])
-loadArgsIntoTemps uniques [] = (uniques, [], [])
-loadArgsIntoTemps uniques ((CmmHinted e hint):args) =
+loadArgsIntoTemps _ uniques [] = (uniques, [], [])
+loadArgsIntoTemps dflags uniques ((CmmHinted e hint):args) =
(uniques'',
new_stmts ++ remaining_stmts,
(CmmHinted new_e hint) : remaining_e)
where
- (uniques', new_stmts, new_e) = maybeAssignTemp uniques e
+ (uniques', new_stmts, new_e) = maybeAssignTemp dflags uniques e
(uniques'', remaining_stmts, remaining_e) =
- loadArgsIntoTemps uniques' args
+ loadArgsIntoTemps dflags uniques' args
-maybeAssignTemp :: [Unique] -> CmmExpr -> ([Unique], [CmmStmt], CmmExpr)
-maybeAssignTemp uniques e
+maybeAssignTemp :: DynFlags -> [Unique] -> CmmExpr -> ([Unique], [CmmStmt], CmmExpr)
+maybeAssignTemp dflags uniques e
| hasNoGlobalRegs e = (uniques, [], e)
| otherwise = (tail uniques, [CmmAssign local e], CmmReg local)
- where local = CmmLocal (LocalReg (head uniques) (cmmExprType e))
+ where local = CmmLocal (LocalReg (head uniques) (cmmExprType dflags e))
diff --git a/compiler/cmm/OldPprCmm.hs b/compiler/cmm/OldPprCmm.hs
index 9605cb9bdf..a3857d4e47 100644
--- a/compiler/cmm/OldPprCmm.hs
+++ b/compiler/cmm/OldPprCmm.hs
@@ -93,9 +93,10 @@ pprStmt stmt = case stmt of
CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
-- rep[lv] = expr;
- CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
- where
- rep = ppr ( cmmExprType expr )
+ CmmStore lv expr ->
+ sdocWithDynFlags $ \dflags ->
+ let rep = ppr ( cmmExprType dflags expr )
+ in rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
-- call "ccall" foo(x, y)[r1, r2];
-- ToDo ppr volatile
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index dd71ac655e..bb2f189e14 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -31,7 +31,6 @@ import OldCmm
import OldPprCmm ()
-- Utils
-import Constants
import CPrim
import DynFlags
import FastString
@@ -149,9 +148,10 @@ pprBBlock (BasicBlock lbl stmts) =
pprWordArray :: CLabel -> [CmmStatic] -> SDoc
pprWordArray lbl ds
- = hcat [ pprLocalness lbl, ptext (sLit "StgWord")
+ = sdocWithDynFlags $ \dflags ->
+ hcat [ pprLocalness lbl, ptext (sLit "StgWord")
, space, ppr lbl, ptext (sLit "[] = {") ]
- $$ nest 8 (commafy (pprStatics ds))
+ $$ nest 8 (commafy (pprStatics dflags ds))
$$ ptext (sLit "};")
--
@@ -167,7 +167,9 @@ pprLocalness lbl | not $ externallyVisibleCLabel lbl = ptext (sLit "static ")
pprStmt :: CmmStmt -> SDoc
-pprStmt stmt = case stmt of
+pprStmt stmt =
+ sdocWithDynFlags $ \dflags ->
+ 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 "*/")
@@ -176,10 +178,10 @@ 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 dflags dest src
CmmStore dest src
- | typeWidth rep == W64 && wordWidth /= W64
+ | typeWidth rep == W64 && wordWidth dflags /= W64
-> (if isFloatType rep then ptext (sLit "ASSIGN_DBL")
else ptext (sLit ("ASSIGN_Word64"))) <>
parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi
@@ -187,7 +189,7 @@ pprStmt stmt = case stmt of
| otherwise
-> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ]
where
- rep = cmmExprType src
+ rep = cmmExprType dflags src
CmmCall (CmmCallee fn cconv) results args ret ->
maybe_proto $$
@@ -246,7 +248,8 @@ pprStmt stmt = case stmt of
CmmBranch ident -> pprBranch ident
CmmCondBranch expr ident -> pprCondBranch expr ident
CmmJump lbl _ -> mkJMP_(pprExpr lbl) <> semi
- CmmSwitch arg ids -> pprSwitch arg ids
+ CmmSwitch arg ids -> sdocWithDynFlags $ \dflags ->
+ pprSwitch dflags arg ids
pprForeignCall :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual]
-> (SDoc, SDoc)
@@ -262,15 +265,15 @@ pprForeignCall fn cconv results args = (proto, fn_call)
pprCFunType :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc
pprCFunType ppr_fn cconv ress args
- = res_type ress <+>
- parens (ccallConvAttribute cconv <> ppr_fn) <>
- parens (commafy (map arg_type args))
- where
- res_type [] = ptext (sLit "void")
+ = sdocWithDynFlags $ \dflags ->
+ let res_type [] = ptext (sLit "void")
res_type [CmmHinted one hint] = machRepHintCType (localRegType one) hint
res_type _ = panic "pprCFunType: only void or 1 return value supported"
- arg_type (CmmHinted expr hint) = machRepHintCType (cmmExprType expr) hint
+ arg_type (CmmHinted expr hint) = machRepHintCType (cmmExprType dflags expr) hint
+ in res_type ress <+>
+ parens (ccallConvAttribute cconv <> ppr_fn) <>
+ parens (commafy (map arg_type args))
-- ---------------------------------------------------------------------
-- unconditional branches
@@ -295,8 +298,8 @@ 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 :: DynFlags -> CmmExpr -> [ Maybe BlockId ] -> SDoc
+pprSwitch dflags 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
@@ -311,11 +314,11 @@ pprSwitch e maybe_ids
caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix
where
do_fallthrough ix =
- hsep [ ptext (sLit "case") , pprHexVal ix wordWidth <> colon ,
+ hsep [ ptext (sLit "case") , pprHexVal ix (wordWidth dflags) <> colon ,
ptext (sLit "/* fall through */") ]
final_branch ix =
- hsep [ ptext (sLit "case") , pprHexVal ix wordWidth <> colon ,
+ hsep [ ptext (sLit "case") , pprHexVal ix (wordWidth dflags) <> colon ,
ptext (sLit "goto") , (pprBlockId ident) <> semi ]
caseify (_ , _ ) = panic "pprSwtich: swtich with no cases!"
@@ -339,7 +342,7 @@ pprExpr e = case e of
CmmLit lit -> pprLit lit
- CmmLoad e ty -> pprLoad e ty
+ CmmLoad e ty -> sdocWithDynFlags $ \dflags -> pprLoad dflags e ty
CmmReg reg -> pprCastReg reg
CmmRegOff reg 0 -> pprCastReg reg
@@ -354,26 +357,26 @@ pprExpr e = case e of
CmmStackSlot _ _ -> panic "pprExpr: CmmStackSlot not supported!"
-pprLoad :: CmmExpr -> CmmType -> SDoc
-pprLoad e ty
- | width == W64, wordWidth /= W64
+pprLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc
+pprLoad dflags e ty
+ | width == W64, wordWidth dflags /= W64
= (if isFloatType ty then ptext (sLit "PK_DBL")
else ptext (sLit "PK_Word64"))
<> parens (mkP_ <> pprExpr1 e)
| otherwise
= case e of
- CmmReg r | isPtrReg r && width == wordWidth && not (isFloatType ty)
+ CmmReg r | isPtrReg r && width == wordWidth dflags && not (isFloatType ty)
-> char '*' <> pprAsPtrReg r
- CmmRegOff r 0 | isPtrReg r && width == wordWidth && not (isFloatType ty)
+ CmmRegOff r 0 | isPtrReg r && width == wordWidth dflags && not (isFloatType ty)
-> char '*' <> pprAsPtrReg r
- CmmRegOff r off | isPtrReg r && width == wordWidth
- , off `rem` wORD_SIZE == 0 && not (isFloatType ty)
+ CmmRegOff r off | isPtrReg r && width == wordWidth dflags
+ , off `rem` wORD_SIZE dflags == 0 && not (isFloatType ty)
-- ToDo: check that the offset is a word multiple?
-- (For tagging to work, I had to avoid unaligned loads. --ARY)
- -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift))
+ -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift dflags))
_other -> cLoad e ty
where
@@ -423,8 +426,10 @@ 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
+ pprArg e | signedOp mop = sdocWithDynFlags $ \dflags ->
+ cCast (machRep_S_CType (typeWidth (cmmExprType dflags e))) e
+ | needsFCasts mop = sdocWithDynFlags $ \dflags ->
+ cCast (machRep_F_CType (typeWidth (cmmExprType dflags e))) e
| otherwise = pprExpr1 e
needsFCasts (MO_F_Eq _) = False
needsFCasts (MO_F_Ne _) = False
@@ -470,37 +475,38 @@ pprLit1 other = pprLit other
-- ---------------------------------------------------------------------------
-- Static data
-pprStatics :: [CmmStatic] -> [SDoc]
-pprStatics [] = []
-pprStatics (CmmStaticLit (CmmFloat f W32) : rest)
+pprStatics :: DynFlags -> [CmmStatic] -> [SDoc]
+pprStatics _ [] = []
+pprStatics dflags (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'
- | wORD_SIZE == 4
- = pprLit1 (floatToWord f) : pprStatics rest
+ | wORD_SIZE dflags == 8, CmmStaticLit (CmmInt 0 W32) : rest' <- rest
+ = pprLit1 (floatToWord dflags f) : pprStatics dflags rest'
+ | wORD_SIZE dflags == 4
+ = pprLit1 (floatToWord dflags f) : pprStatics dflags rest
| otherwise
= pprPanic "pprStatics: float" (vcat (map ppr' rest))
- where ppr' (CmmStaticLit l) = ppr (cmmLitType l)
+ where ppr' (CmmStaticLit l) = sdocWithDynFlags $ \dflags ->
+ ppr (cmmLitType dflags 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)
- | wordWidth == W32
+pprStatics dflags (CmmStaticLit (CmmFloat f W64) : rest)
+ = map pprLit1 (doubleToWords dflags f) ++ pprStatics dflags rest
+pprStatics dflags (CmmStaticLit (CmmInt i W64) : rest)
+ | wordWidth dflags == W32
#ifdef WORDS_BIGENDIAN
- = pprStatics (CmmStaticLit (CmmInt q W32) :
- CmmStaticLit (CmmInt r W32) : rest)
+ = pprStatics dflags (CmmStaticLit (CmmInt q W32) :
+ CmmStaticLit (CmmInt r W32) : rest)
#else
- = pprStatics (CmmStaticLit (CmmInt r W32) :
- CmmStaticLit (CmmInt q W32) : rest)
+ = pprStatics dflags (CmmStaticLit (CmmInt r W32) :
+ CmmStaticLit (CmmInt q W32) : rest)
#endif
where r = i .&. 0xffffffff
q = i `shiftR` 32
-pprStatics (CmmStaticLit (CmmInt _ w) : _)
- | w /= wordWidth
+pprStatics dflags (CmmStaticLit (CmmInt _ w) : _)
+ | w /= wordWidth dflags
= panic "pprStatics: cannot emit a non-word-sized static literal"
-pprStatics (CmmStaticLit lit : rest)
- = pprLit1 lit : pprStatics rest
-pprStatics (other : _)
+pprStatics dflags (CmmStaticLit lit : rest)
+ = pprLit1 lit : pprStatics dflags rest
+pprStatics _ (other : _)
= pprPanic "pprWord" (pprStatic other)
pprStatic :: CmmStatic -> SDoc
@@ -705,19 +711,19 @@ mkP_ = ptext (sLit "(P_)") -- StgWord*
--
-- Generating assignments is what we're all about, here
--
-pprAssign :: CmmReg -> CmmExpr -> SDoc
+pprAssign :: DynFlags -> 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)
- | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE == 0)
+pprAssign dflags r1 (CmmRegOff r2 off)
+ | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE dflags == 0)
= hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ]
where
- off1 = off `shiftR` wordShift
+ off1 = off `shiftR` wordShift dflags
(op,off') | off >= 0 = (char '+', off1)
| otherwise = (char '-', -off1)
@@ -725,7 +731,7 @@ 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
+pprAssign _ r1 r2
| isFixedPtrReg r1 = mkAssign (mkP_ <> pprExpr1 r2)
| Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 r2)
| otherwise = mkAssign (pprExpr r2)
@@ -846,7 +852,8 @@ pprCall ppr_fn cconv results args
= cCast (ptext (sLit "void *")) expr
-- see comment by machRepHintCType below
pprArg (CmmHinted expr SignedHint)
- = cCast (machRep_S_CType $ typeWidth $ cmmExprType expr) expr
+ = sdocWithDynFlags $ \dflags ->
+ cCast (machRep_S_CType $ typeWidth $ cmmExprType dflags expr) expr
pprArg (CmmHinted expr _other)
= pprExpr expr
@@ -901,9 +908,9 @@ pprExternDecl _in_srt lbl
-- If the label we want to refer to is a stdcall function (on Windows) then
-- 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 =
+ stdcall_decl sz = sdocWithDynFlags $ \dflags ->
ptext (sLit "extern __attribute__((stdcall)) void ") <> ppr lbl
- <> parens (commafy (replicate (sz `quot` wORD_SIZE) (machRep_U_CType wordWidth)))
+ <> parens (commafy (replicate (sz `quot` wORD_SIZE dflags) (machRep_U_CType (wordWidth dflags))))
<> semi
type TEState = (UniqSet LocalReg, Map CLabel ())
@@ -984,10 +991,10 @@ cLoad expr rep
bewareLoadStoreAlignment (ArchARM {}) = True
bewareLoadStoreAlignment _ = False
-isCmmWordType :: CmmType -> Bool
+isCmmWordType :: DynFlags -> CmmType -> Bool
-- True of GcPtrReg/NonGcReg of native word size
-isCmmWordType ty = not (isFloatType ty)
- && typeWidth ty == wordWidth
+isCmmWordType dflags ty = not (isFloatType ty)
+ && typeWidth ty == wordWidth dflags
-- This is for finding the types of foreign call arguments. For a pointer
-- argument, we always cast the argument to (void *), to avoid warnings from
@@ -998,8 +1005,10 @@ machRepHintCType rep SignedHint = machRep_S_CType (typeWidth rep)
machRepHintCType rep _other = machRepCType rep
machRepPtrCType :: CmmType -> SDoc
-machRepPtrCType r | isCmmWordType r = ptext (sLit "P_")
- | otherwise = machRepCType r <> char '*'
+machRepPtrCType r
+ = sdocWithDynFlags $ \dflags ->
+ if isCmmWordType dflags r then ptext (sLit "P_")
+ else machRepCType r <> char '*'
machRepCType :: CmmType -> SDoc
machRepCType ty | isFloatType ty = machRep_F_CType w
@@ -1013,20 +1022,26 @@ machRep_F_CType W64 = ptext (sLit "StgDouble")
machRep_F_CType _ = panic "machRep_F_CType"
machRep_U_CType :: Width -> SDoc
-machRep_U_CType w | w == wordWidth = ptext (sLit "W_")
-machRep_U_CType W8 = ptext (sLit "StgWord8")
-machRep_U_CType W16 = ptext (sLit "StgWord16")
-machRep_U_CType W32 = ptext (sLit "StgWord32")
-machRep_U_CType W64 = ptext (sLit "StgWord64")
-machRep_U_CType _ = panic "machRep_U_CType"
+machRep_U_CType w
+ = sdocWithDynFlags $ \dflags ->
+ case w of
+ _ | w == wordWidth dflags -> ptext (sLit "W_")
+ W8 -> ptext (sLit "StgWord8")
+ W16 -> ptext (sLit "StgWord16")
+ W32 -> ptext (sLit "StgWord32")
+ W64 -> ptext (sLit "StgWord64")
+ _ -> panic "machRep_U_CType"
machRep_S_CType :: Width -> SDoc
-machRep_S_CType w | w == wordWidth = ptext (sLit "I_")
-machRep_S_CType W8 = ptext (sLit "StgInt8")
-machRep_S_CType W16 = ptext (sLit "StgInt16")
-machRep_S_CType W32 = ptext (sLit "StgInt32")
-machRep_S_CType W64 = ptext (sLit "StgInt64")
-machRep_S_CType _ = panic "machRep_S_CType"
+machRep_S_CType w
+ = sdocWithDynFlags $ \dflags ->
+ case w of
+ _ | w == wordWidth dflags -> ptext (sLit "I_")
+ W8 -> ptext (sLit "StgInt8")
+ W16 -> ptext (sLit "StgInt16")
+ W32 -> ptext (sLit "StgInt32")
+ W64 -> ptext (sLit "StgInt64")
+ _ -> panic "machRep_S_CType"
-- ---------------------------------------------------------------------
@@ -1043,10 +1058,10 @@ pprStringInCStyle s = doubleQuotes (text (concatMap charToC s))
-- This is a hack to turn the floating point numbers into ints that we
-- can safely initialise to static locations.
-big_doubles :: Bool
-big_doubles
- | widthInBytes W64 == 2 * wORD_SIZE = True
- | widthInBytes W64 == wORD_SIZE = False
+big_doubles :: DynFlags -> Bool
+big_doubles dflags
+ | widthInBytes W64 == 2 * wORD_SIZE dflags = True
+ | widthInBytes W64 == wORD_SIZE dflags = False
| otherwise = panic "big_doubles"
castFloatToIntArray :: STUArray s Int Float -> ST s (STUArray s Int Int)
@@ -1056,27 +1071,27 @@ castDoubleToIntArray :: STUArray s Int Double -> ST s (STUArray s Int Int)
castDoubleToIntArray = castSTUArray
-- floats are always 1 word
-floatToWord :: Rational -> CmmLit
-floatToWord r
+floatToWord :: DynFlags -> Rational -> CmmLit
+floatToWord dflags r
= runST (do
arr <- newArray_ ((0::Int),0)
writeArray arr 0 (fromRational r)
arr' <- castFloatToIntArray arr
i <- readArray arr' 0
- return (CmmInt (toInteger i) wordWidth)
+ return (CmmInt (toInteger i) (wordWidth dflags))
)
-doubleToWords :: Rational -> [CmmLit]
-doubleToWords r
- | big_doubles -- doubles are 2 words
+doubleToWords :: DynFlags -> Rational -> [CmmLit]
+doubleToWords dflags r
+ | big_doubles dflags -- doubles are 2 words
= runST (do
arr <- newArray_ ((0::Int),1)
writeArray arr 0 (fromRational r)
arr' <- castDoubleToIntArray arr
i1 <- readArray arr' 0
i2 <- readArray arr' 1
- return [ CmmInt (toInteger i1) wordWidth
- , CmmInt (toInteger i2) wordWidth
+ return [ CmmInt (toInteger i1) (wordWidth dflags)
+ , CmmInt (toInteger i2) (wordWidth dflags)
]
)
| otherwise -- doubles are 1 word
@@ -1085,14 +1100,14 @@ doubleToWords r
writeArray arr 0 (fromRational r)
arr' <- castDoubleToIntArray arr
i <- readArray arr' 0
- return [ CmmInt (toInteger i) wordWidth ]
+ return [ CmmInt (toInteger i) (wordWidth dflags) ]
)
-- ---------------------------------------------------------------------------
-- Utils
-wordShift :: Int
-wordShift = widthInLog wordWidth
+wordShift :: DynFlags -> Int
+wordShift dflags = widthInLog (wordWidth dflags)
commafy :: [SDoc] -> SDoc
commafy xs = hsep $ punctuate comma xs
@@ -1110,11 +1125,11 @@ pprHexVal w rep
-- times values are unsigned. This also helps eliminate occasional
-- warnings about integer overflow from gcc.
- repsuffix W64
- | cINT_SIZE == 8 = char 'U'
- | cLONG_SIZE == 8 = ptext (sLit "UL")
- | cLONG_LONG_SIZE == 8 = ptext (sLit "ULL")
- | otherwise = panic "pprHexVal: Can't find a 64-bit type"
+ repsuffix W64 = sdocWithDynFlags $ \dflags ->
+ if cINT_SIZE dflags == 8 then char 'U'
+ else if cLONG_SIZE dflags == 8 then ptext (sLit "UL")
+ else if cLONG_LONG_SIZE dflags == 8 then ptext (sLit "ULL")
+ else panic "pprHexVal: Can't find a 64-bit type"
repsuffix _ = char 'U'
go 0 = empty
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index 58866979f8..423bcd5504 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -185,7 +185,8 @@ pprNode node = pp_node <+> pp_debug
-- rep[lv] = expr;
CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
where
- rep = ppr ( cmmExprType expr )
+ rep = sdocWithDynFlags $ \dflags ->
+ ppr ( cmmExprType dflags expr )
-- call "ccall" foo(x, y)[r1, r2];
-- ToDo ppr volatile
diff --git a/compiler/cmm/PprCmmExpr.hs b/compiler/cmm/PprCmmExpr.hs
index 2f25b028d1..7d2f4824ef 100644
--- a/compiler/cmm/PprCmmExpr.hs
+++ b/compiler/cmm/PprCmmExpr.hs
@@ -73,11 +73,12 @@ instance Outputable GlobalReg where
pprExpr :: CmmExpr -> SDoc
pprExpr e
- = case e of
+ = sdocWithDynFlags $ \dflags ->
+ case e of
CmmRegOff reg i ->
pprExpr (CmmMachOp (MO_Add rep)
[CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
- where rep = typeWidth (cmmRegType reg)
+ where rep = typeWidth (cmmRegType dflags reg)
CmmLit lit -> pprLit lit
_other -> pprExpr1 e
@@ -186,10 +187,11 @@ infixMachOp mop
-- has the natural machine word size, we do not append the type
--
pprLit :: CmmLit -> SDoc
-pprLit lit = case lit of
+pprLit lit = sdocWithDynFlags $ \dflags ->
+ case lit of
CmmInt i rep ->
hcat [ (if i < 0 then parens else id)(integer i)
- , ppUnless (rep == wordWidth) $
+ , ppUnless (rep == wordWidth dflags) $
space <> dcolon <+> ppr rep ]
CmmFloat f rep -> hsep [ double (fromRat f), dcolon, ppr rep ]
diff --git a/compiler/cmm/SMRep.lhs b/compiler/cmm/SMRep.lhs
index 1d5574ae8f..2c9cb32ec0 100644
--- a/compiler/cmm/SMRep.lhs
+++ b/compiler/cmm/SMRep.lhs
@@ -45,7 +45,6 @@ module SMRep (
#include "../includes/MachDeps.h"
import DynFlags
-import Constants
import Outputable
import FastString
@@ -65,8 +64,8 @@ import Data.Bits
type WordOff = Int -- Word offset, or word count
type ByteOff = Int -- Byte offset, or byte count
-roundUpToWords :: ByteOff -> ByteOff
-roundUpToWords n = (n + (wORD_SIZE - 1)) .&. (complement (wORD_SIZE - 1))
+roundUpToWords :: DynFlags -> ByteOff -> ByteOff
+roundUpToWords dflags n = (n + (wORD_SIZE dflags - 1)) .&. (complement (wORD_SIZE dflags - 1))
\end{code}
StgWord is a type representing an StgWord on the target platform.
@@ -219,33 +218,33 @@ isStaticNoCafCon _ = False
-- | Size of a closure header (StgHeader in includes/rts/storage/Closures.h)
fixedHdrSize :: DynFlags -> WordOff
-fixedHdrSize dflags = sTD_HDR_SIZE + profHdrSize dflags
+fixedHdrSize dflags = sTD_HDR_SIZE dflags + profHdrSize dflags
-- | Size of the profiling part of a closure header
-- (StgProfHeader in includes/rts/storage/Closures.h)
profHdrSize :: DynFlags -> WordOff
profHdrSize dflags
- | dopt Opt_SccProfilingOn dflags = pROF_HDR_SIZE
+ | dopt Opt_SccProfilingOn dflags = pROF_HDR_SIZE dflags
| otherwise = 0
-- | The garbage collector requires that every closure is at least as
-- big as this.
minClosureSize :: DynFlags -> WordOff
-minClosureSize dflags = fixedHdrSize dflags + mIN_PAYLOAD_SIZE
+minClosureSize dflags = fixedHdrSize dflags + mIN_PAYLOAD_SIZE dflags
arrWordsHdrSize :: DynFlags -> ByteOff
arrWordsHdrSize dflags
- = fixedHdrSize dflags * wORD_SIZE + sIZEOF_StgArrWords_NoHdr
+ = fixedHdrSize dflags * wORD_SIZE dflags + sIZEOF_StgArrWords_NoHdr dflags
arrPtrsHdrSize :: DynFlags -> ByteOff
arrPtrsHdrSize dflags
- = fixedHdrSize dflags * wORD_SIZE + sIZEOF_StgMutArrPtrs_NoHdr
+ = fixedHdrSize dflags * wORD_SIZE dflags + sIZEOF_StgMutArrPtrs_NoHdr dflags
-- Thunks have an extra header word on SMP, so the update doesn't
-- splat the payload.
thunkHdrSize :: DynFlags -> WordOff
thunkHdrSize dflags = fixedHdrSize dflags + smp_hdr
- where smp_hdr = sIZEOF_StgSMPThunkHeader `quot` wORD_SIZE
+ where smp_hdr = sIZEOF_StgSMPThunkHeader dflags `quot` wORD_SIZE dflags
nonHdrSize :: SMRep -> WordOff
View Lorry Controller Status