diff options
170 files changed, 4498 insertions, 4059 deletions
diff --git a/aclocal.m4 b/aclocal.m4 index b4e155b3fd..645f7777b9 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -226,7 +226,10 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS], haiku) test -z "[$]2" || eval "[$]2=OSHaiku" ;; - dragonfly|osf1|osf3|hpux|linuxaout|freebsd2|cygwin32|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix) + osf3) + test -z "[$]2" || eval "[$]2=OSOsf3" + ;; + dragonfly|osf1|hpux|linuxaout|freebsd2|cygwin32|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix) test -z "[$]2" || eval "[$]2=OSUnknown" ;; *) diff --git a/compiler/cmm/Bitmap.hs b/compiler/cmm/Bitmap.hs index 642ae40fdb..f4cfe3f401 100644 --- a/compiler/cmm/Bitmap.hs +++ b/compiler/cmm/Bitmap.hs @@ -25,6 +25,7 @@ module Bitmap ( import SMRep import Constants +import DynFlags import Util import Data.Bits @@ -37,10 +38,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 +51,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. diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index 0cfcc0d5be..37354193f8 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -33,6 +33,7 @@ import CLabel import Cmm import CmmUtils import Data.List +import DynFlags import Maybes import Module import Outputable @@ -166,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) @@ -196,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 @@ -206,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 @@ -219,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) + : 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))) @@ -318,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' @@ -330,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..fb6c27c66b 100644 --- a/compiler/cmm/CmmCallConv.hs +++ b/compiler/cmm/CmmCallConv.hs @@ -46,12 +46,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 +78,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' @@ -111,46 +111,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 e57c6eca4c..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,19 +42,19 @@ 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 = CmmLocal {-# UNPACK #-} !LocalReg @@ -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..10e37bb095 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -114,8 +114,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 +172,9 @@ mkInfoTableContents dflags -- (which in turn came from a handwritten .cmm file) | StackRep frame <- smrep - = do { (prof_lits, prof_data) <- mkProfLits prof + = do { (prof_lits, prof_data) <- mkProfLits dflags prof ; let (srt_label, srt_bitmap) = mkSRTLit srt - ; (liveness_lit, liveness_data) <- mkLivenessBits frame + ; (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,8 +184,8 @@ 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 + = do { let layout = packHalfWordsCLit dflags ptrs nonptrs + ; (prof_lits, prof_data) <- mkProfLits dflags prof ; let (srt_label, srt_bitmap) = mkSRTLit srt ; (mb_srt_field, mb_layout, extra_bits, ct_data) <- mk_pieces closure_type srt_label @@ -208,24 +208,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" @@ -297,12 +297,12 @@ 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 +mkLivenessBits dflags liveness | n_bits > mAX_SMALL_BITMAP_SIZE -- does not fit in one word = do { uniq <- getUniqueUs ; let bitmap_lbl = mkBitmapLabel uniq @@ -310,12 +310,12 @@ mkLivenessBits liveness [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 @@ -324,7 +324,7 @@ mkLivenessBits liveness bitmap_word = fromIntegral n_bits .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT) - 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 49a0176b45..ea9a4bb7ba 100644 --- a/compiler/cmm/CmmLayoutStack.hs +++ b/compiler/cmm/CmmLayoutStack.hs @@ -120,7 +120,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 +130,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 +147,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 +188,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 +211,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 +318,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 +330,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, @@ -428,7 +429,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 @@ -442,7 +443,7 @@ handleLastNode procpoints liveness cont_info stackmaps setupStackFrame 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 +457,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]) @@ -705,7 +707,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 +719,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 +750,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 +773,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) = mkIntExpr sp_hwm -areaToSp _ _ _ (CmmMachOp (MO_U_Lt _) -- Note [null stack check] - [CmmMachOp (MO_Sub _) - [ CmmReg (CmmGlobal Sp) - , CmmLit (CmmInt 0 _)], - CmmReg (CmmGlobal SpLim)]) = zeroExpr -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] @@ -910,14 +913,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 +938,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 +966,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), mkIntExpr (fromEnum intrbl)] + [id] [CmmReg (CmmGlobal BaseReg), mkIntExpr dflags (fromEnum intrbl)] callResumeThread :: LocalReg -> LocalReg -> CmmNode O O callResumeThread new_base id = diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 47c30b1a0f..0afe2a3b50 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -19,6 +19,7 @@ import BlockId import FastString import Outputable import Constants +import DynFlags import Data.Maybe @@ -31,15 +32,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,23 +86,27 @@ 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 @@ -131,8 +136,9 @@ 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 +158,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 +191,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 +203,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 diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs index d53f4855da..520c7e7a7d 100644 --- a/compiler/cmm/CmmMachOp.hs +++ b/compiler/cmm/CmmMachOp.hs @@ -25,6 +25,7 @@ where import CmmType import Outputable +import DynFlags ----------------------------------------------------------------------------- -- MachOp @@ -122,59 +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_WordTo64 + , 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_WordTo64 = MO_UU_Conv wordWidth W64 - -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 -- ---------------------------------------------------------------------------- @@ -283,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 @@ -297,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 @@ -337,7 +341,7 @@ machOpResultType mop tys = where (ty1:_) = tys -comparisonResultRep :: CmmType +comparisonResultRep :: DynFlags -> CmmType comparisonResultRep = bWord -- is it? @@ -349,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] @@ -391,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/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..7937b88ea3 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -522,7 +522,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 +611,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 +630,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 +659,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 +869,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 +881,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 (widthInBytes (typeWidth (cmmExprType dflags e))) -- c.f. CgForeignCall.emitForeignCall adjCallTarget _ _ expr _ = expr @@ -917,14 +919,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] @@ -941,7 +944,7 @@ emitRetUT args = do -- 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) + stmtC $ CmmJump (entryCode dflags (CmmLoad (cmmRegOffW spReg sp) (bWord dflags))) (Just live) -- ----------------------------------------------------------------------------- -- If-then-else and boolean expressions @@ -1050,9 +1053,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)) (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 0c075b8476..6ee40d9a74 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 "doSRTs" #-} 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) @@ -183,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..66b4c8302b 100644 --- a/compiler/cmm/CmmType.hs +++ b/compiler/cmm/CmmType.hs @@ -18,6 +18,7 @@ where #include "HsVersions.h" import Constants +import DynFlags import FastString import Outputable @@ -95,10 +96,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 +160,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 _ + | wORD_SIZE == 4 = W32 + | wORD_SIZE == 8 = W64 + | otherwise = panic "MachOp.wordRep: Unknown word size" + +halfWordWidth :: DynFlags -> Width +halfWordWidth _ + | wORD_SIZE == 4 = W16 + | wORD_SIZE == 8 = W32 + | otherwise = panic "MachOp.halfWordRep: Unknown word size" + +halfWordMask :: DynFlags -> Integer +halfWordMask _ + | wORD_SIZE == 4 = 0xFFFF + | wORD_SIZE == 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 93158848f3..75bdf61ee4 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,37 +12,37 @@ -- ----------------------------------------------------------------------------- -module CmmUtils( +module CmmUtils( -- CmmType - primRepCmmType, primRepForeignHint, - typeCmmType, typeForeignHint, + primRepCmmType, primRepForeignHint, + typeCmmType, typeForeignHint, - -- CmmLit + -- CmmLit zeroCLit, mkIntCLit, - mkWordCLit, packHalfWordsCLit, - mkByteStringCLit, + mkWordCLit, packHalfWordsCLit, + mkByteStringCLit, mkDataLits, mkRODataLits, - -- CmmExpr + -- 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, + 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, + isTrivialCmmExpr, hasNoGlobalRegs, - -- Tagging - cmmTagMask, cmmPointerMask, cmmUntag, cmmGetTag, cmmIsTagged, - cmmConstrTag, cmmConstrTag1, + -- Statics + blankWord, + + -- Tagging + cmmTagMask, cmmPointerMask, cmmUntag, cmmGetTag, cmmIsTagged, + cmmConstrTag, cmmConstrTag1, -- Liveness and bitmaps mkLiveness, @@ -60,7 +54,7 @@ module CmmUtils( ofBlockMap, toBlockMap, insertBlock, ofBlockList, toBlockList, bodyToBlockList, foldGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1, - + analFwd, analBwd, analRewFwd, analRewBwd, dataflowPassFwd, dataflowPassBwd, dataflowAnalFwd, dataflowAnalBwd, dataflowAnalFwdBlocks @@ -68,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 @@ -79,6 +73,7 @@ import Outputable import Unique import UniqSupply import Constants( wORD_SIZE, tAG_MASK ) +import DynFlags import Util import Data.Word @@ -88,58 +83,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) -mkIntExpr :: Int -> CmmExpr -mkIntExpr i = CmmLit $! mkIntCLit i +mkIntExpr :: DynFlags -> Int -> CmmExpr +mkIntExpr dflags i = CmmLit $! mkIntCLit dflags i -zeroCLit :: CmmLit -zeroCLit = CmmInt 0 wordWidth +zeroCLit :: DynFlags -> CmmLit +zeroCLit dflags = CmmInt 0 (wordWidth dflags) -zeroExpr :: CmmExpr -zeroExpr = CmmLit zeroCLit +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]) @@ -154,44 +149,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 @@ -200,28 +195,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 @@ -230,35 +225,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, mkIntExpr (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 @@ -269,13 +266,13 @@ 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 * n) cmmRegOffW :: CmmReg -> WordOff -> CmmExpr cmmRegOffW reg wd_off = cmmRegOffB reg (wd_off * wORD_SIZE) @@ -286,87 +283,86 @@ cmmOffsetLitW lit wd_off = cmmOffsetLitB lit (wORD_SIZE * wd_off) cmmLabelOffW :: CLabel -> WordOff -> CmmLit cmmLabelOffW lbl wd_off = cmmLabelOffB lbl (wORD_SIZE * 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, cmmQuotWord - :: 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] -cmmQuotWord e1 e2 = CmmMachOp mo_wordUQuot [e1, e2] - -cmmNegate :: CmmExpr -> CmmExpr -cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep) -cmmNegate e = CmmMachOp (MO_S_Neg (cmmExprWidth e)) [e] + :: 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 :: CmmStatic blankWord = CmmUninitialised wORD_SIZE --------------------------------------------------- -- --- 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 = mkIntExpr tAG_MASK -cmmPointerMask = mkIntExpr (complement tAG_MASK) +cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr +cmmTagMask dflags = mkIntExpr dflags tAG_MASK +cmmPointerMask dflags = mkIntExpr dflags (complement tAG_MASK) -- 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` zeroExpr +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` mkIntExpr 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) -------------------------------------------- @@ -377,8 +373,8 @@ cmmConstrTag1 e = e `cmmAndWord` cmmTagMask mkLiveness :: [Maybe LocalReg] -> Liveness mkLiveness [] = [] -mkLiveness (reg:regs) - = take sizeW bits ++ mkLiveness regs +mkLiveness (reg:regs) + = take sizeW bits ++ mkLiveness regs where sizeW = case reg of Nothing -> 1 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..9146aa74a3 100644 --- a/compiler/cmm/OldCmmLint.hs +++ b/compiler/cmm/OldCmmLint.hs @@ -24,7 +24,7 @@ import Outputable import OldPprCmm() import Constants import FastString -import Platform +import DynFlags import Data.Maybe @@ -32,15 +32,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 +49,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,32 +70,32 @@ 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 @@ -119,49 +120,49 @@ 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)) 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..b40b34aaa5 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -149,9 +149,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 +168,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 +179,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 +190,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 +249,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 +266,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 +299,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 +315,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 +343,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 +358,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 + CmmRegOff r off | isPtrReg r && width == wordWidth dflags , off `rem` wORD_SIZE == 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 +427,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 +476,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' + = pprLit1 (floatToWord dflags f) : pprStatics dflags rest' | wORD_SIZE == 4 - = pprLit1 (floatToWord f) : pprStatics rest + = 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 +712,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) +pprAssign dflags r1 (CmmRegOff r2 off) | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE == 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 +732,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 +853,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 +909,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) (machRep_U_CType (wordWidth dflags)))) <> semi type TEState = (UniqSet LocalReg, Map CLabel ()) @@ -984,10 +992,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 +1006,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 +1023,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" -- --------------------------------------------------------------------- @@ -1056,18 +1072,18 @@ 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 +doubleToWords :: DynFlags -> Rational -> [CmmLit] +doubleToWords dflags r | big_doubles -- doubles are 2 words = runST (do arr <- newArray_ ((0::Int),1) @@ -1075,8 +1091,8 @@ doubleToWords 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 +1101,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 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..79e19105a9 100644 --- a/compiler/cmm/SMRep.lhs +++ b/compiler/cmm/SMRep.lhs @@ -219,33 +219,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 + sIZEOF_StgArrWords_NoHdr dflags arrPtrsHdrSize :: DynFlags -> ByteOff arrPtrsHdrSize dflags - = fixedHdrSize dflags * wORD_SIZE + sIZEOF_StgMutArrPtrs_NoHdr + = fixedHdrSize dflags * wORD_SIZE + 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 nonHdrSize :: SMRep -> WordOff diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs index 0efc99d370..7fe79804fa 100644 --- a/compiler/codeGen/CgBindery.lhs +++ b/compiler/codeGen/CgBindery.lhs @@ -205,10 +205,17 @@ untagNodeIdInfo id offset lf_info tag idInfoToAmode :: CgIdInfo -> FCode CmmExpr -idInfoToAmode info - = case cg_vol info of { +idInfoToAmode info = do + dflags <- getDynFlags + let mach_rep = argMachRep dflags (cg_rep info) + + maybeTag amode -- add the tag, if we have one + | tag == 0 = amode + | otherwise = cmmOffsetB dflags amode tag + where tag = cg_tag info + case cg_vol info of { RegLoc reg -> returnFC (CmmReg reg) ; - VirNodeLoc nd_off -> returnFC (CmmLoad (cmmOffsetB (CmmReg nodeReg) nd_off) + VirNodeLoc nd_off -> returnFC (CmmLoad (cmmOffsetB dflags (CmmReg nodeReg) nd_off) mach_rep) ; VirHpLoc hp_off -> do { off <- getHpRelOffset hp_off ; return $! maybeTag off }; @@ -228,13 +235,6 @@ idInfoToAmode info NoStableLoc -> pprPanic "idInfoToAmode: no loc" (ppr (cg_id info)) } - where - mach_rep = argMachRep (cg_rep info) - - maybeTag amode -- add the tag, if we have one - | tag == 0 = amode - | otherwise = cmmOffsetB amode tag - where tag = cg_tag info cgIdInfoId :: CgIdInfo -> Id cgIdInfoId = cg_id @@ -451,13 +451,13 @@ bindNewToUntagNode id offset lf_info tag -- temporary. bindNewToTemp :: Id -> FCode LocalReg bindNewToTemp id - = do addBindC id (regIdInfo id (CmmLocal temp_reg) lf_info) + = do dflags <- getDynFlags + let uniq = getUnique id + temp_reg = LocalReg uniq (argMachRep dflags (idCgRep id)) + lf_info = mkLFArgument id -- Always used of things we + -- know nothing about + addBindC id (regIdInfo id (CmmLocal temp_reg) lf_info) return temp_reg - where - uniq = getUnique id - temp_reg = LocalReg uniq (argMachRep (idCgRep id)) - lf_info = mkLFArgument id -- Always used of things we - -- know nothing about bindNewToReg :: Id -> CmmReg -> LambdaFormInfo -> Code bindNewToReg name reg lf_info diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs index 9443e0e936..2be57893dd 100644 --- a/compiler/codeGen/CgCallConv.hs +++ b/compiler/codeGen/CgCallConv.hs @@ -34,7 +34,6 @@ import SMRep import OldCmm import CLabel -import Constants import CgStackery import ClosureInfo( CgRep(..), nonVoidArg, idCgRep, cgRepSizeW, isFollowableArg ) import OldCmmUtils @@ -226,8 +225,9 @@ getSequelAmode :: FCode CmmExpr getSequelAmode = do { EndOfBlockInfo virt_sp sequel <- getEndOfBlockInfo ; case sequel of - OnStack -> do { sp_rel <- getSpRelOffset virt_sp - ; returnFC (CmmLoad sp_rel bWord) } + OnStack -> do { dflags <- getDynFlags + ; sp_rel <- getSpRelOffset virt_sp + ; returnFC (CmmLoad sp_rel (bWord dflags)) } CaseAlts lbl _ _ -> returnFC (CmmLit (CmmLabel lbl)) } @@ -263,7 +263,7 @@ type AssignRegs a = [(CgRep,a)] -- Arg or result values to assign [(CgRep,a)]) -- Leftover arg or result values assignCallRegs :: DynFlags -> AssignRegs a -assignPrimOpCallRegs :: AssignRegs a +assignPrimOpCallRegs :: DynFlags -> AssignRegs a assignReturnRegs :: DynFlags -> AssignRegs a assignCallRegs dflags args @@ -272,8 +272,8 @@ assignCallRegs dflags args -- never uses Node for argument passing; instead -- Node points to the function closure itself -assignPrimOpCallRegs args - = assign_regs args (mkRegTbl_allRegs []) +assignPrimOpCallRegs dflags args + = assign_regs args (mkRegTbl_allRegs dflags []) -- For primops, *all* arguments must be passed in registers assignReturnRegs dflags args @@ -333,19 +333,19 @@ assign_reg _ _ = Nothing useVanillaRegs :: DynFlags -> Int useVanillaRegs dflags | platformUnregisterised (targetPlatform dflags) = 0 - | otherwise = mAX_Real_Vanilla_REG + | otherwise = mAX_Real_Vanilla_REG dflags useFloatRegs :: DynFlags -> Int useFloatRegs dflags | platformUnregisterised (targetPlatform dflags) = 0 - | otherwise = mAX_Real_Float_REG + | otherwise = mAX_Real_Float_REG dflags useDoubleRegs :: DynFlags -> Int useDoubleRegs dflags | platformUnregisterised (targetPlatform dflags) = 0 - | otherwise = mAX_Real_Double_REG + | otherwise = mAX_Real_Double_REG dflags useLongRegs :: DynFlags -> Int useLongRegs dflags | platformUnregisterised (targetPlatform dflags) = 0 - | otherwise = mAX_Real_Long_REG + | otherwise = mAX_Real_Long_REG dflags vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: DynFlags -> [Int] vanillaRegNos dflags = regList $ useVanillaRegs dflags @@ -353,11 +353,12 @@ floatRegNos dflags = regList $ useFloatRegs dflags doubleRegNos dflags = regList $ useDoubleRegs dflags longRegNos dflags = regList $ useLongRegs dflags -allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int] -allVanillaRegNos = regList mAX_Vanilla_REG -allFloatRegNos = regList mAX_Float_REG -allDoubleRegNos = regList mAX_Double_REG -allLongRegNos = regList mAX_Long_REG +allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos + :: DynFlags -> [Int] +allVanillaRegNos dflags = regList $ mAX_Vanilla_REG dflags +allFloatRegNos dflags = regList $ mAX_Float_REG dflags +allDoubleRegNos dflags = regList $ mAX_Double_REG dflags +allLongRegNos dflags = regList $ mAX_Long_REG dflags regList :: Int -> [Int] regList n = [1 .. n] @@ -370,25 +371,29 @@ type AvailRegs = ( [Int] -- available vanilla regs. mkRegTbl :: DynFlags -> [GlobalReg] -> AvailRegs mkRegTbl dflags regs_in_use - = mkRegTbl' regs_in_use (vanillaRegNos dflags) - (floatRegNos dflags) - (doubleRegNos dflags) - (longRegNos dflags) - -mkRegTbl_allRegs :: [GlobalReg] -> AvailRegs -mkRegTbl_allRegs regs_in_use - = mkRegTbl' regs_in_use allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos - -mkRegTbl' :: [GlobalReg] -> [Int] -> [Int] -> [Int] -> [Int] + = mkRegTbl' dflags regs_in_use + vanillaRegNos floatRegNos doubleRegNos longRegNos + +mkRegTbl_allRegs :: DynFlags -> [GlobalReg] -> AvailRegs +mkRegTbl_allRegs dflags regs_in_use + = mkRegTbl' dflags regs_in_use + allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos + +mkRegTbl' :: DynFlags -> [GlobalReg] + -> (DynFlags -> [Int]) + -> (DynFlags -> [Int]) + -> (DynFlags -> [Int]) + -> (DynFlags -> [Int]) -> ([Int], [Int], [Int], [Int]) -mkRegTbl' regs_in_use vanillas floats doubles longs +mkRegTbl' dflags regs_in_use vanillas floats doubles longs = (ok_vanilla, ok_float, ok_double, ok_long) where - ok_vanilla = mapCatMaybes (select (\i -> VanillaReg i VNonGcPtr)) vanillas + ok_vanilla = mapCatMaybes (select (\i -> VanillaReg i VNonGcPtr)) + (vanillas dflags) -- ptrhood isn't looked at, hence we can use any old rep. - ok_float = mapCatMaybes (select FloatReg) floats - ok_double = mapCatMaybes (select DoubleReg) doubles - ok_long = mapCatMaybes (select LongReg) longs + ok_float = mapCatMaybes (select FloatReg) (floats dflags) + ok_double = mapCatMaybes (select DoubleReg) (doubles dflags) + ok_long = mapCatMaybes (select LongReg) (longs dflags) select :: (Int -> GlobalReg) -> Int{-cand-} -> Maybe Int -- one we've unboxed the Int, we make a GlobalReg diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs index ef51aaa620..0d86319057 100644 --- a/compiler/codeGen/CgCase.lhs +++ b/compiler/codeGen/CgCase.lhs @@ -370,10 +370,11 @@ cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts -- (avoiding it avoids the assignment) -- The deadness info is set by StgVarInfo ; whenC (not (isDeadBinder bndr)) - (do { tmp_reg <- bindNewToTemp bndr + (do { dflags <- getDynFlags + ; tmp_reg <- bindNewToTemp bndr ; stmtC (CmmAssign (CmmLocal tmp_reg) - (tagToClosure tycon tag_amode)) }) + (tagToClosure dflags tycon tag_amode)) }) -- Compile the alts ; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-} @@ -390,7 +391,8 @@ cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts (_,e) <- getArgAmode arg return e do_enum_primop primop - = do tmp <- newTemp bWord + = do dflags <- getDynFlags + tmp <- newTemp (bWord dflags) cgPrimOp [tmp] primop args live_in_alts returnFC (CmmReg (CmmLocal tmp)) @@ -663,8 +665,9 @@ saveCurrentCostCentre restoreCurrentCostCentre :: Maybe VirtualSpOffset -> Bool -> Code restoreCurrentCostCentre Nothing _freeit = nopC restoreCurrentCostCentre (Just slot) freeit - = do { sp_rel <- getSpRelOffset slot + = do { dflags <- getDynFlags + ; sp_rel <- getSpRelOffset slot ; whenC freeit (freeStackSlots [slot]) - ; stmtC (storeCurCCS (CmmLoad sp_rel bWord)) } + ; stmtC (storeCurCCS (CmmLoad sp_rel (bWord dflags))) } \end{code} diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs index ede235a00a..fce910489e 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -320,10 +320,11 @@ mkFunEntryCode cl_info cc reg_args stk_args sp_top reg_save_code body = do -- Do the business ; funWrapper cl_info reg_args reg_save_code $ do - { tickyEnterFun cl_info + { dflags <- getDynFlags + ; tickyEnterFun cl_info ; enterCostCentreFun cc - (CmmMachOp mo_wordSub [ CmmReg nodeReg - , mkIntExpr (funTag cl_info) ]) + (CmmMachOp (mo_wordSub dflags) [ CmmReg nodeReg + , mkIntExpr dflags (funTag cl_info) ]) (node : map snd reg_args) -- live regs ; cgExpr body } @@ -371,11 +372,11 @@ mkSlowEntryCode dflags cl_info reg_args load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg) (CmmLoad (cmmRegOffW spReg offset) - (argMachRep rep)) + (argMachRep dflags rep)) save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets - mk_save (rep,reg) offset = ASSERT( argMachRep rep `cmmEqType` globalRegType reg ) - CmmStore (cmmRegOffW spReg offset) + mk_save (rep,reg) offset = ASSERT( argMachRep dflags rep `cmmEqType` globalRegType dflags reg ) + CmmStore (cmmRegOffW spReg offset) (CmmReg (CmmGlobal reg)) stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset) @@ -429,7 +430,7 @@ funWrapper closure_info arg_regs reg_save_code fun_body = do ; whenC (tag /= 0 && node_points) $ do l <- newLabelC stmtC (CmmCondBranch (CmmMachOp mo_wordEq [cmmGetTag (CmmReg nodeReg), - mkIntExpr tag)]) l) + mkIntExpr dflags tag)]) l) stmtC (CmmStore (CmmLit (mkWordCLit 0)) (mkWordExpr 0)) labelC l -} @@ -490,7 +491,7 @@ emitBlackHoleCode is_single_entry = do whenC eager_blackholing $ do tickyBlackHole (not is_single_entry) stmtsC [ - CmmStore (cmmOffsetW (CmmReg nodeReg) (fixedHdrSize dflags)) + CmmStore (cmmOffsetW dflags (CmmReg nodeReg) (fixedHdrSize dflags)) (CmmReg (CmmGlobal CurrentTSO)), CmmCall (CmmPrim MO_WriteBarrier Nothing) [] [] CmmMayReturn, CmmStore (CmmReg nodeReg) (CmmReg (CmmGlobal EagerBlackholeInfo)) @@ -576,11 +577,11 @@ link_caf :: ClosureInfo -- is that we only want to update dynamic heap objects, not static ones, -- so that generational GC is easier. link_caf cl_info _is_upd = do - { -- Alloc black hole specifying CC_HDR(Node) as the cost centre - ; let use_cc = costCentreFrom (CmmReg nodeReg) + { dflags <- getDynFlags + -- Alloc black hole specifying CC_HDR(Node) as the cost centre + ; let use_cc = costCentreFrom dflags (CmmReg nodeReg) blame_cc = use_cc tso = CmmReg (CmmGlobal CurrentTSO) - ; dflags <- getDynFlags ; hp_offset <- allocDynClosure bh_cl_info use_cc blame_cc [(tso, fixedHdrSize dflags)] ; hp_rel <- getHpRelOffset hp_offset @@ -589,7 +590,7 @@ link_caf cl_info _is_upd = do -- so that the garbage collector can find them -- This must be done *before* the info table pointer is overwritten, -- because the old info table ptr is needed for reversion - ; ret <- newTemp bWord + ; ret <- newTemp (bWord dflags) ; emitRtsCallGen [CmmHinted ret NoHint] rtsPackageId (fsLit "newCAF") [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint, CmmHinted (CmmReg nodeReg) AddrHint, @@ -598,11 +599,11 @@ link_caf cl_info _is_upd = do -- node is live, so save it. -- see Note [atomic CAF entry] in rts/sm/Storage.c - ; emitIf (CmmMachOp mo_wordEq [ CmmReg (CmmLocal ret), zeroExpr]) $ + ; emitIf (CmmMachOp (mo_wordEq dflags) [ CmmReg (CmmLocal ret), zeroExpr dflags]) $ -- re-enter R1. Doing this directly is slightly dodgy; we're -- assuming lots of things, like the stack pointer hasn't -- moved since we entered the CAF. - let target = entryCode dflags (closureInfoPtr (CmmReg nodeReg)) in + let target = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg)) in stmtC (CmmJump target $ Just [node]) ; returnFC hp_rel } diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs index 4c451ec339..8afbc8f64e 100644 --- a/compiler/codeGen/CgCon.lhs +++ b/compiler/codeGen/CgCon.lhs @@ -36,7 +36,6 @@ import OldCmmUtils import OldCmm import SMRep import CostCentre -import Constants import TyCon import DataCon import Id @@ -189,9 +188,9 @@ buildDynCon' dflags platform binder _ con [arg_amode] , platformOS platform /= OSMinGW32 || not (dopt Opt_PIC dflags) , (_, CmmLit (CmmInt val _)) <- arg_amode , let val_int = (fromIntegral val) :: Int - , val_int <= mAX_INTLIKE && val_int >= mIN_INTLIKE + , val_int <= mAX_INTLIKE dflags && val_int >= mIN_INTLIKE dflags = do { let intlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_INTLIKE_closure") - offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize dflags + 1) + offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSize dflags + 1) -- INTLIKE closures consist of a header and one word payload intlike_amode = CmmLit (cmmLabelOffW intlike_lbl offsetW) ; returnFC (taggedStableIdInfo binder intlike_amode (mkConLFInfo con) con) } @@ -201,9 +200,9 @@ buildDynCon' dflags platform binder _ con [arg_amode] , platformOS platform /= OSMinGW32 || not (dopt Opt_PIC dflags) , (_, CmmLit (CmmInt val _)) <- arg_amode , let val_int = (fromIntegral val) :: Int - , val_int <= mAX_CHARLIKE && val_int >= mIN_CHARLIKE + , val_int <= mAX_CHARLIKE dflags && val_int >= mIN_CHARLIKE dflags = do { let charlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_CHARLIKE_closure") - offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize dflags + 1) + offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSize dflags + 1) -- CHARLIKE closures consist of a header and one word payload charlike_amode = CmmLit (cmmLabelOffW charlike_lbl offsetW) ; returnFC (taggedStableIdInfo binder charlike_amode (mkConLFInfo con) con) } @@ -355,8 +354,8 @@ cgReturnDataCon con amodes = do where node_live = Just [node] enter_it dflags - = stmtsC [ CmmAssign nodeReg (cmmUntag (CmmReg nodeReg)), - CmmJump (entryCode dflags $ closureInfoPtr $ CmmReg nodeReg) + = stmtsC [ CmmAssign nodeReg (cmmUntag dflags (CmmReg nodeReg)), + CmmJump (entryCode dflags $ closureInfoPtr dflags $ CmmReg nodeReg) node_live ] jump_to lbl = stmtC $ CmmJump (CmmLit lbl) node_live @@ -478,7 +477,7 @@ cgDataCon data_con tickyReturnOldCon (length arg_things) -- The case continuation code is expecting a tagged pointer ; stmtC (CmmAssign nodeReg - (tagCons data_con (CmmReg nodeReg))) + (tagCons dflags data_con (CmmReg nodeReg))) ; performReturn $ emitReturnInstr (Just []) } -- noStmts: Ptr to thing already in Node diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs index 0a4466292e..151947665f 100644 --- a/compiler/codeGen/CgExpr.lhs +++ b/compiler/codeGen/CgExpr.lhs @@ -15,7 +15,6 @@ module CgExpr ( cgExpr ) where #include "HsVersions.h" -import Constants import StgSyn import CgMonad @@ -146,10 +145,11 @@ cgExpr (StgOpApp (StgFCallOp fcall _) stg_args res_ty) = do cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty) = ASSERT(isEnumerationTyCon tycon) - do { (_rep,amode) <- getArgAmode arg + do { dflags <- getDynFlags + ; (_rep,amode) <- getArgAmode arg ; amode' <- assignTemp amode -- We're going to use it twice, -- so save in a temp if non-trivial - ; stmtC (CmmAssign nodeReg (tagToClosure tycon amode')) + ; stmtC (CmmAssign nodeReg (tagToClosure dflags tycon amode')) ; performReturn $ emitReturnInstr (Just [node]) } where -- If you're reading this code in the attempt to figure @@ -177,7 +177,8 @@ cgExpr (StgOpApp (StgPrimOp primop) args res_ty) performReturn $ emitReturnInstr (Just []) | ReturnsPrim rep <- result_info - = do res <- newTemp (typeCmmType res_ty) + = do dflags <- getDynFlags + res <- newTemp (typeCmmType dflags res_ty) cgPrimOp [res] primop args emptyVarSet performPrimReturn (primRepToCgRep rep) (CmmReg (CmmLocal res)) @@ -188,10 +189,11 @@ cgExpr (StgOpApp (StgPrimOp primop) args res_ty) | ReturnsAlg tycon <- result_info, isEnumerationTyCon tycon -- c.f. cgExpr (...TagToEnumOp...) - = do tag_reg <- newTemp bWord -- The tag is a word + = do dflags <- getDynFlags + tag_reg <- newTemp (bWord dflags) -- The tag is a word cgPrimOp [tag_reg] primop args emptyVarSet stmtC (CmmAssign nodeReg - (tagToClosure tycon + (tagToClosure dflags tycon (CmmReg (CmmLocal tag_reg)))) -- ToDo: STG Live -- worried about this performReturn $ emitReturnInstr (Just [node]) @@ -349,7 +351,7 @@ mkRhsClosure dflags bndr cc bi (StgApp selectee [{-no args-}]))]) | the_fv == scrutinee -- Scrutinee is the only free variable && maybeToBool maybe_offset -- Selectee is a component of the tuple - && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough + && offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough = -- NOT TRUE: ASSERT(is_single_constructor) -- The simplifier may have statically determined that the single alternative -- is the only possible case and eliminated the others, even if there are @@ -393,7 +395,7 @@ mkRhsClosure dflags bndr cc bi | args `lengthIs` (arity-1) && all isFollowableArg (map idCgRep fvs) && isUpdatable upd_flag - && arity <= mAX_SPEC_AP_SIZE + && arity <= mAX_SPEC_AP_SIZE dflags && not (dopt Opt_SccProfilingOn dflags) -- not when profiling: we don't want to -- lose information about this particular @@ -481,14 +483,14 @@ Little helper for primitives that return unboxed tuples. \begin{code} newUnboxedTupleRegs :: Type -> FCode ([CgRep], [LocalReg], [ForeignHint]) -newUnboxedTupleRegs res_ty = +newUnboxedTupleRegs res_ty = do + dflags <- getDynFlags let UbxTupleRep ty_args = repType res_ty (reps,hints) = unzip [ (rep, typeForeignHint ty) | ty <- ty_args, let rep = typeCgRep ty, nonVoidArg rep ] - make_new_temp rep = newTemp (argMachRep rep) - in do + make_new_temp rep = newTemp (argMachRep dflags rep) regs <- mapM make_new_temp reps return (reps,regs,hints) \end{code} diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs index 801d8a31c6..435fbb0558 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -70,13 +70,9 @@ emitForeignCall -> StgLiveVars -- live vars, in case we need to save them -> Code -emitForeignCall results (CCall (CCallSpec target cconv safety)) args live - = do vols <- getVolatileRegs live - srt <- getSRTInfo - emitForeignCall' safety results - (CmmCallee cmm_target cconv) call_args (Just vols) srt CmmMayReturn - where - (call_args, cmm_target) +emitForeignCall results (CCall (CCallSpec target cconv safety)) args live = do + dflags <- getDynFlags + let (call_args, cmm_target) = case target of StaticTarget _ _ False -> panic "emitForeignCall: unexpected FFI value import" @@ -103,11 +99,15 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live -- attach this info to the CLabel here, and the CLabel pretty printer -- will generate the suffix when the label is printed. call_size - | StdCallConv <- cconv = Just (sum (map (arg_size.cmmExprType.hintlessCmm) args)) + | StdCallConv <- cconv = Just (sum (map (arg_size . cmmExprType dflags . hintlessCmm) args)) | otherwise = Nothing -- ToDo: this might not be correct for 64-bit API arg_size rep = max (widthInBytes (typeWidth rep)) wORD_SIZE + vols <- getVolatileRegs live + srt <- getSRTInfo + emitForeignCall' safety results + (CmmCallee cmm_target cconv) call_args (Just vols) srt CmmMayReturn -- alternative entry point, used by CmmParse @@ -137,8 +137,8 @@ emitForeignCall' safety results target args vols _srt ret dflags <- getDynFlags -- Both 'id' and 'new_base' are GCKindNonPtr 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)) temp_args <- load_args_into_temps args temp_target <- load_target_into_temp target let (caller_save, caller_load) = callerSaveVolatileRegs dflags vols @@ -152,7 +152,7 @@ emitForeignCall' safety results target args vols _srt ret stmtC (CmmCall (CmmCallee suspendThread CCallConv) [ CmmHinted id AddrHint ] [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint - , CmmHinted (CmmLit (CmmInt (fromIntegral (fromEnum (playInterruptible safety))) wordWidth)) NoHint] + , CmmHinted (CmmLit (CmmInt (fromIntegral (fromEnum (playInterruptible safety))) (wordWidth dflags))) NoHint] ret) stmtC (CmmCall temp_target results temp_args ret) stmtC (CmmCall (CmmCallee resumeThread CCallConv) @@ -194,10 +194,11 @@ maybe_assign_temp :: CmmExpr -> FCode CmmExpr maybe_assign_temp e | hasNoGlobalRegs e = return e | otherwise = do + dflags <- getDynFlags -- don't use assignTemp, it uses its own notion of "trivial" -- expressions, which are wrong here. -- this is a NonPtr because it only duplicates an existing - reg <- newTemp (cmmExprType e) --TODO FIXME NOW + reg <- newTemp (cmmExprType dflags e) --TODO FIXME NOW stmtC (CmmAssign (CmmLocal reg) e) return (CmmReg (CmmLocal reg)) @@ -211,75 +212,78 @@ emitSaveThreadState :: Code emitSaveThreadState = do dflags <- getDynFlags -- CurrentTSO->stackobj->sp = Sp; - stmtC $ CmmStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO (tso_stackobj dflags)) bWord) + stmtC $ CmmStore (cmmOffset dflags (CmmLoad (cmmOffset dflags stgCurrentTSO (tso_stackobj dflags)) (bWord dflags)) (stack_SP dflags)) stgSp emitCloseNursery -- and save the current cost centre stack in the TSO when profiling: when (dopt Opt_SccProfilingOn dflags) $ - stmtC (CmmStore (cmmOffset stgCurrentTSO (tso_CCCS dflags)) curCCS) + stmtC (CmmStore (cmmOffset dflags stgCurrentTSO (tso_CCCS dflags)) curCCS) -- CurrentNursery->free = Hp+1; emitCloseNursery :: Code -emitCloseNursery = stmtC $ CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1) +emitCloseNursery = do dflags <- getDynFlags + stmtC $ CmmStore (nursery_bdescr_free dflags) (cmmOffsetW dflags stgHp 1) emitLoadThreadState :: Code emitLoadThreadState = do dflags <- getDynFlags - tso <- newTemp bWord -- TODO FIXME NOW - stack <- newTemp bWord -- TODO FIXME NOW + tso <- newTemp (bWord dflags) -- TODO FIXME NOW + stack <- newTemp (bWord dflags) -- TODO FIXME NOW stmtsC [ -- tso = CurrentTSO CmmAssign (CmmLocal tso) stgCurrentTSO, -- stack = tso->stackobj - CmmAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) bWord), + CmmAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)), -- Sp = stack->sp; - CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) (stack_SP dflags)) - bWord), + CmmAssign sp (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) + (bWord dflags)), -- SpLim = stack->stack + RESERVED_STACK_WORDS; - CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) (stack_STACK dflags)) - rESERVED_STACK_WORDS), + CmmAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags)) + (rESERVED_STACK_WORDS dflags)), -- HpAlloc = 0; -- HpAlloc is assumed to be set to non-zero only by a failed -- a heap check, see HeapStackCheck.cmm:GC_GENERIC - CmmAssign hpAlloc (CmmLit zeroCLit) + CmmAssign hpAlloc (CmmLit (zeroCLit dflags)) ] emitOpenNursery -- and load the current cost centre stack from the TSO when profiling: when (dopt Opt_SccProfilingOn dflags) $ stmtC $ storeCurCCS $ - CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) bWord + CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) (bWord dflags) emitOpenNursery :: Code -emitOpenNursery = stmtsC [ +emitOpenNursery = + do dflags <- getDynFlags + stmtsC [ -- Hp = CurrentNursery->free - 1; - CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free gcWord) (-1)), + CmmAssign hp (cmmOffsetW dflags (CmmLoad (nursery_bdescr_free dflags) (gcWord dflags)) (-1)), -- HpLim = CurrentNursery->start + -- CurrentNursery->blocks*BLOCK_SIZE_W - 1; CmmAssign hpLim - (cmmOffsetExpr - (CmmLoad nursery_bdescr_start bWord) - (cmmOffset - (CmmMachOp mo_wordMul [ - CmmMachOp (MO_SS_Conv W32 wordWidth) - [CmmLoad nursery_bdescr_blocks b32], - mkIntExpr bLOCK_SIZE + (cmmOffsetExpr dflags + (CmmLoad (nursery_bdescr_start dflags) (bWord dflags)) + (cmmOffset dflags + (CmmMachOp (mo_wordMul dflags) [ + CmmMachOp (MO_SS_Conv W32 (wordWidth dflags)) + [CmmLoad (nursery_bdescr_blocks dflags) b32], + mkIntExpr dflags (bLOCK_SIZE dflags) ]) (-1) ) ) - ] + ] -nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr -nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free -nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start -nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks +nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: DynFlags -> CmmExpr +nursery_bdescr_free dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_free dflags) +nursery_bdescr_start dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_start dflags) +nursery_bdescr_blocks dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_blocks dflags) tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: DynFlags -> ByteOff -tso_stackobj dflags = closureField dflags oFFSET_StgTSO_stackobj -tso_CCCS dflags = closureField dflags oFFSET_StgTSO_cccs -stack_STACK dflags = closureField dflags oFFSET_StgStack_stack -stack_SP dflags = closureField dflags oFFSET_StgStack_sp +tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags) +tso_CCCS dflags = closureField dflags (oFFSET_StgTSO_cccs dflags) +stack_STACK dflags = closureField dflags (oFFSET_StgStack_stack dflags) +stack_SP dflags = closureField dflags (oFFSET_StgStack_sp dflags) closureField :: DynFlags -> ByteOff -> ByteOff closureField dflags off = off + fixedHdrSize dflags * wORD_SIZE @@ -307,10 +311,10 @@ hpAlloc = CmmGlobal HpAlloc shimForeignCallArg :: DynFlags -> StgArg -> CmmExpr -> CmmExpr shimForeignCallArg dflags arg expr | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon - = cmmOffsetB expr (arrPtrsHdrSize dflags) + = cmmOffsetB dflags expr (arrPtrsHdrSize dflags) | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon - = cmmOffsetB expr (arrWordsHdrSize dflags) + = cmmOffsetB dflags expr (arrWordsHdrSize dflags) | otherwise = expr where diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs index 98d08f9ea1..f3cb7796f4 100644 --- a/compiler/codeGen/CgHeapery.lhs +++ b/compiler/codeGen/CgHeapery.lhs @@ -208,29 +208,29 @@ mkStaticClosureFields dflags cl_info ccs caf_refs payload padding_wds | not is_caf = [] - | otherwise = ASSERT(null payload) [mkIntCLit 0] + | otherwise = ASSERT(null payload) [mkIntCLit dflags 0] static_link_field | is_caf || staticClosureNeedsLink cl_info = [static_link_value] | otherwise = [] saved_info_field - | is_caf = [mkIntCLit 0] + | is_caf = [mkIntCLit dflags 0] | otherwise = [] -- for a static constructor which has NoCafRefs, we set the -- static link field to a non-zero value so the garbage -- collector will ignore it. static_link_value - | caf_refs = mkIntCLit 0 - | otherwise = mkIntCLit 1 + | caf_refs = mkIntCLit dflags 0 + | otherwise = mkIntCLit dflags 1 mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] mkStaticClosure dflags info_lbl ccs payload padding_wds static_link_field saved_info_field = [CmmLabel info_lbl] ++ variable_header_words - ++ concatMap padLitToWord payload + ++ concatMap (padLitToWord dflags) payload ++ padding_wds ++ static_link_field ++ saved_info_field @@ -241,9 +241,9 @@ mkStaticClosure dflags info_lbl ccs payload padding_wds static_link_field saved_ ++ staticProfHdr dflags ccs ++ staticTickyHdr -padLitToWord :: CmmLit -> [CmmLit] -padLitToWord lit = lit : padding pad_length - where width = typeWidth (cmmLitType lit) +padLitToWord :: DynFlags -> CmmLit -> [CmmLit] +padLitToWord dflags lit = lit : padding pad_length + where width = typeWidth (cmmLitType dflags lit) pad_length = wORD_SIZE - widthInBytes width :: Int padding n | n <= 0 = [] @@ -412,18 +412,18 @@ unbxTupleHeapCheck regs ptrs nptrs fail_code code | ptrs > 255 || nptrs > 255 = panic "altHeapCheck" | otherwise = initHeapUsage $ \ hpHw -> do - { codeOnly $ do { do_checks 0 {- no stack check -} hpHw + { dflags <- getDynFlags + ; let full_fail_code = fail_code `plusStmts` oneStmt assign_liveness + assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9 VNonGcPtr)) -- Ho ho ho! + (CmmLit (mkWordCLit dflags liveness)) + liveness = mkRegLiveness regs ptrs nptrs + live = Just $ map snd regs + rts_label = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_ut"))) + ; codeOnly $ do { do_checks 0 {- no stack check -} hpHw full_fail_code rts_label live ; tickyAllocHeap hpHw } ; setRealHp hpHw ; code } - where - full_fail_code = fail_code `plusStmts` oneStmt assign_liveness - assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9 VNonGcPtr)) -- Ho ho ho! - (CmmLit (mkWordCLit liveness)) - liveness = mkRegLiveness regs ptrs nptrs - live = Just $ map snd regs - rts_label = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_ut"))) \end{code} @@ -452,25 +452,37 @@ do_checks :: WordOff -- Stack headroom -> Code do_checks 0 0 _ _ _ = nopC -do_checks _ hp _ _ _ - | hp > bLOCKS_PER_MBLOCK * bLOCK_SIZE_W - = sorry (unlines [ - "Trying to allocate more than " ++ show (bLOCKS_PER_MBLOCK * bLOCK_SIZE) ++ " bytes.", - "", - "See: http://hackage.haskell.org/trac/ghc/ticket/4505", - "Suggestion: read data from a file instead of having large static data", - "structures in the code."]) - do_checks stk hp reg_save_code rts_lbl live - = do_checks' (mkIntExpr (stk*wORD_SIZE)) - (mkIntExpr (hp*wORD_SIZE)) - (stk /= 0) (hp /= 0) reg_save_code rts_lbl live + = do dflags <- getDynFlags + if hp > bLOCKS_PER_MBLOCK dflags * bLOCK_SIZE_W dflags + then sorry (unlines [ + "Trying to allocate more than " ++ show (bLOCKS_PER_MBLOCK dflags * bLOCK_SIZE dflags) ++ " bytes.", + "", + "See: http://hackage.haskell.org/trac/ghc/ticket/4505", + "Suggestion: read data from a file instead of having large static data", + "structures in the code."]) + else do_checks' (mkIntExpr dflags (stk * wORD_SIZE)) + (mkIntExpr dflags (hp * wORD_SIZE)) + (stk /= 0) (hp /= 0) reg_save_code rts_lbl live -- The offsets are now in *bytes* do_checks' :: CmmExpr -> CmmExpr -> Bool -> Bool -> CmmStmts -> CmmExpr -> Maybe [GlobalReg] -> Code do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl live - = do { doGranAllocate hp_expr + = do { dflags <- getDynFlags + + -- Stk overflow if (Sp - stk_bytes < SpLim) + ; let stk_oflo = CmmMachOp (mo_wordULt dflags) + [CmmMachOp (mo_wordSub dflags) [CmmReg spReg, stk_expr], + CmmReg (CmmGlobal SpLim)] + + -- Hp overflow if (Hp > HpLim) + -- (Hp has been incremented by now) + -- HpLim points to the LAST WORD of valid allocation space. + hp_oflo = CmmMachOp (mo_wordUGt dflags) + [CmmReg hpReg, CmmReg (CmmGlobal HpLim)] + + ; doGranAllocate hp_expr -- The failure block: this saves the registers and jumps to -- the appropriate RTS stub. @@ -496,7 +508,7 @@ do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl live ; whenC hp_nonzero (stmtsC [CmmAssign hpReg - (cmmOffsetExprB (CmmReg hpReg) hp_expr), + (cmmOffsetExprB dflags (CmmReg hpReg) hp_expr), CmmCondBranch hp_oflo hp_blk_id]) -- Bump heap pointer, and test for heap exhaustion -- Note that we don't move the heap pointer unless the @@ -504,17 +516,6 @@ do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl live -- with slop at the end of the current block, which can -- confuse the LDV profiler. } - where - -- Stk overflow if (Sp - stk_bytes < SpLim) - stk_oflo = CmmMachOp mo_wordULt - [CmmMachOp mo_wordSub [CmmReg spReg, stk_expr], - CmmReg (CmmGlobal SpLim)] - - -- Hp overflow if (Hp > HpLim) - -- (Hp has been incremented by now) - -- HpLim points to the LAST WORD of valid allocation space. - hp_oflo = CmmMachOp mo_wordUGt - [CmmReg hpReg, CmmReg (CmmGlobal HpLim)] \end{code} %************************************************************************ @@ -528,38 +529,38 @@ hpChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code hpChkGen bytes liveness reentry = do dflags <- getDynFlags let platform = targetPlatform dflags - do_checks' zeroExpr bytes False True assigns + assigns = mkStmts [ mk_vanilla_assignment dflags 9 liveness, + mk_vanilla_assignment dflags 10 reentry ] + do_checks' (zeroExpr dflags) bytes False True assigns stg_gc_gen (Just (activeStgRegs platform)) - where - assigns = mkStmts [ mk_vanilla_assignment 9 liveness, - mk_vanilla_assignment 10 reentry ] -- a heap check where R1 points to the closure to enter on return, and -- we want to assign to Sp[0] on failure (used in AutoApply.cmm:BUILD_PAP). hpChkNodePointsAssignSp0 :: CmmExpr -> CmmExpr -> Code hpChkNodePointsAssignSp0 bytes sp0 - = do_checks' zeroExpr bytes False True assign - stg_gc_enter1 (Just [node]) + = do dflags <- getDynFlags + do_checks' (zeroExpr dflags) bytes False True assign + stg_gc_enter1 (Just [node]) where assign = oneStmt (CmmStore (CmmReg spReg) sp0) stkChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code stkChkGen bytes liveness reentry = do dflags <- getDynFlags let platform = targetPlatform dflags - do_checks' bytes zeroExpr True False assigns + assigns = mkStmts [ mk_vanilla_assignment dflags 9 liveness, + mk_vanilla_assignment dflags 10 reentry ] + do_checks' bytes (zeroExpr dflags) True False assigns stg_gc_gen (Just (activeStgRegs platform)) - where - assigns = mkStmts [ mk_vanilla_assignment 9 liveness, - mk_vanilla_assignment 10 reentry ] -mk_vanilla_assignment :: Int -> CmmExpr -> CmmStmt -mk_vanilla_assignment n e - = CmmAssign (CmmGlobal (VanillaReg n (vgcFlag (cmmExprType e)))) e +mk_vanilla_assignment :: DynFlags -> Int -> CmmExpr -> CmmStmt +mk_vanilla_assignment dflags n e + = CmmAssign (CmmGlobal (VanillaReg n (vgcFlag (cmmExprType dflags e)))) e stkChkNodePoints :: CmmExpr -> Code stkChkNodePoints bytes - = do_checks' bytes zeroExpr True False noStmts - stg_gc_enter1 (Just [node]) + = do dflags <- getDynFlags + do_checks' bytes (zeroExpr dflags) True False noStmts + stg_gc_enter1 (Just [node]) stg_gc_gen :: CmmExpr stg_gc_gen = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_gen"))) @@ -630,8 +631,9 @@ initDynHdr dflags info_ptr cc hpStore :: CmmExpr -> [(CmmExpr, VirtualHpOffset)] -> Code -- Store the item (expr,off) in base[off] hpStore base es - = stmtsC [ CmmStore (cmmOffsetW base off) val - | (val, off) <- es ] + = do dflags <- getDynFlags + stmtsC [ CmmStore (cmmOffsetW dflags base off) val + | (val, off) <- es ] emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> Code emitSetDynHdr base info_ptr ccs diff --git a/compiler/codeGen/CgHpc.hs b/compiler/codeGen/CgHpc.hs index a134f00067..407de7b647 100644 --- a/compiler/codeGen/CgHpc.hs +++ b/compiler/codeGen/CgHpc.hs @@ -18,7 +18,8 @@ import HscTypes cgTickBox :: Module -> Int -> Code cgTickBox mod n = do - let tick_box = (cmmIndex W64 + dflags <- getDynFlags + let tick_box = (cmmIndex dflags W64 (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod) n ) diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index 3f8e6c0222..ce4228e0fc 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -151,6 +151,7 @@ is not present in the list (it is always assumed). -} mkStackLayout :: FCode [Maybe LocalReg] mkStackLayout = do + dflags <- getDynFlags StackUsage { realSp = real_sp, frameSp = frame_sp } <- getStkUsage binds <- getLiveStackBindings @@ -162,21 +163,22 @@ mkStackLayout = do WARN( not (all (\bind -> fst bind >= 0) rel_binds), ppr binds $$ ppr rel_binds $$ ppr frame_size $$ ppr real_sp $$ ppr frame_sp ) - return $ stack_layout rel_binds frame_size + return $ stack_layout dflags rel_binds frame_size -stack_layout :: [(VirtualSpOffset, CgIdInfo)] +stack_layout :: DynFlags + -> [(VirtualSpOffset, CgIdInfo)] -> WordOff -> [Maybe LocalReg] -stack_layout [] sizeW = replicate sizeW Nothing -stack_layout ((off, bind):binds) sizeW | off == sizeW - 1 = - (Just stack_bind) : (stack_layout binds (sizeW - rep_size)) +stack_layout _ [] sizeW = replicate sizeW Nothing +stack_layout dflags ((off, bind):binds) sizeW | off == sizeW - 1 = + (Just stack_bind) : (stack_layout dflags binds (sizeW - rep_size)) where rep_size = cgRepSizeW (cgIdInfoArgRep bind) stack_bind = LocalReg unique machRep unique = getUnique (cgIdInfoId bind) - machRep = argMachRep (cgIdInfoArgRep bind) -stack_layout binds@(_:_) sizeW | otherwise = - Nothing : (stack_layout binds (sizeW - 1)) + machRep = argMachRep dflags (cgIdInfoArgRep bind) +stack_layout dflags binds@(_:_) sizeW | otherwise = + Nothing : (stack_layout dflags binds (sizeW - 1)) {- Another way to write the function that might be less error prone (untested) stack_layout offsets sizeW = result @@ -212,15 +214,15 @@ emitAlgReturnTarget -> FCode (CLabel, SemiTaggingStuff) emitAlgReturnTarget name branches mb_deflt fam_sz - = do { blks <- getCgStmts $ + = do { blks <- getCgStmts $ do -- is the constructor tag in the node reg? + dflags <- getDynFlags if isSmallFamily fam_sz then do -- yes, node has constr. tag - let tag_expr = cmmConstrTag1 (CmmReg nodeReg) + let tag_expr = cmmConstrTag1 dflags (CmmReg nodeReg) branches' = [(tag+1,branch)|(tag,branch)<-branches] emitSwitch tag_expr branches' mb_deflt 1 fam_sz else do -- no, get tag from info table - dflags <- getDynFlags let -- Note that ptr _always_ has tag 1 -- when the family size is big enough untagged_ptr = cmmRegOffB nodeReg (-1) @@ -277,16 +279,16 @@ stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2*wORD_SIZE + hALF_WORD_SIZ -- ------------------------------------------------------------------------- -closureInfoPtr :: CmmExpr -> CmmExpr +closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr -- Takes a closure pointer and returns the info table pointer -closureInfoPtr e = CmmLoad e bWord +closureInfoPtr dflags e = CmmLoad e (bWord dflags) entryCode :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info pointer (the first word of a closure) -- and returns its entry code entryCode dflags e | tablesNextToCode dflags = e - | otherwise = CmmLoad e bWord + | otherwise = CmmLoad e (bWord dflags) getConstrTag :: DynFlags -> CmmExpr -> CmmExpr -- Takes a closure pointer, and return the *zero-indexed* @@ -294,25 +296,25 @@ getConstrTag :: DynFlags -> CmmExpr -> CmmExpr -- This lives in the SRT field of the info table -- (constructors don't need SRTs). getConstrTag dflags closure_ptr - = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableConstrTag dflags info_table] + = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table] where - info_table = infoTable dflags (closureInfoPtr closure_ptr) + info_table = infoTable dflags (closureInfoPtr dflags closure_ptr) cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr -- Takes a closure pointer, and return the closure type -- obtained from the info table cmmGetClosureType dflags closure_ptr - = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableClosureType dflags info_table] + = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table] where - info_table = infoTable dflags (closureInfoPtr closure_ptr) + info_table = infoTable dflags (closureInfoPtr dflags closure_ptr) infoTable :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info pointer (the first word of a closure) -- and returns a pointer to the first word of the standard-form -- info table, excluding the entry-code word (if present) infoTable dflags info_ptr - | tablesNextToCode dflags = cmmOffsetB info_ptr (- stdInfoTableSizeB dflags) - | otherwise = cmmOffsetW info_ptr 1 -- Past the entry code pointer + | tablesNextToCode dflags = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags) + | otherwise = cmmOffsetW dflags info_ptr 1 -- Past the entry code pointer infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the constr tag @@ -323,21 +325,21 @@ infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the srt_bitmap -- field of the info table infoTableSrtBitmap dflags info_tbl - = CmmLoad (cmmOffsetB info_tbl (stdSrtBitmapOffset dflags)) bHalfWord + = CmmLoad (cmmOffsetB dflags info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord dflags) infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the closure type -- field of the info table. infoTableClosureType dflags info_tbl - = CmmLoad (cmmOffsetB info_tbl (stdClosureTypeOffset dflags)) bHalfWord + = CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags) infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr infoTablePtrs dflags info_tbl - = CmmLoad (cmmOffsetB info_tbl (stdPtrsOffset dflags)) bHalfWord + = CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags) infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr infoTableNonPtrs dflags info_tbl - = CmmLoad (cmmOffsetB info_tbl (stdNonPtrsOffset dflags)) bHalfWord + = CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags) funInfoTable :: DynFlags -> CmmExpr -> CmmExpr -- Takes the info pointer of a function, @@ -345,9 +347,9 @@ funInfoTable :: DynFlags -> CmmExpr -> CmmExpr -- in the info table. funInfoTable dflags info_ptr | tablesNextToCode dflags - = cmmOffsetB info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev) + = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags) | otherwise - = cmmOffsetW info_ptr (1 + stdInfoTableSizeW dflags) + = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags) -- Past the entry code pointer ------------------------------------------------------------------------- diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index 88d60b654d..854a81a101 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -46,12 +46,14 @@ cgPrimOp :: [CmmFormal] -- where to put the results -> Code cgPrimOp results op args live - = do arg_exprs <- getArgAmodes args + = do dflags <- getDynFlags + arg_exprs <- getArgAmodes args let non_void_args = [ e | (r,e) <- arg_exprs, nonVoidArg r ] - emitPrimOp results op non_void_args live + emitPrimOp dflags results op non_void_args live -emitPrimOp :: [CmmFormal] -- where to put the results +emitPrimOp :: DynFlags + -> [CmmFormal] -- where to put the results -> PrimOp -- the op -> [CmmExpr] -- arguments -> StgLiveVars -- live vars, in case we need to save them @@ -60,7 +62,7 @@ emitPrimOp :: [CmmFormal] -- where to put the results -- First we handle various awkward cases specially. The remaining -- easy cases are then handled by translateOp, defined below. -emitPrimOp [res_r,res_c] IntAddCOp [aa,bb] _ +emitPrimOp dflags [res_r,res_c] IntAddCOp [aa,bb] _ {- With some bit-twiddling, we can define int{Add,Sub}Czh portably in C, and without needing any comparisons. This may not be the @@ -82,19 +84,19 @@ emitPrimOp [res_r,res_c] IntAddCOp [aa,bb] _ -} = stmtsC [ - CmmAssign (CmmLocal res_r) (CmmMachOp mo_wordAdd [aa,bb]), + CmmAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]), CmmAssign (CmmLocal res_c) $ - CmmMachOp mo_wordUShr [ - CmmMachOp mo_wordAnd [ - CmmMachOp mo_wordNot [CmmMachOp mo_wordXor [aa,bb]], - CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)] + CmmMachOp (mo_wordUShr dflags) [ + CmmMachOp (mo_wordAnd dflags) [ + CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]], + CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] ], - mkIntExpr (wORD_SIZE_IN_BITS - 1) + mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) ] ] -emitPrimOp [res_r,res_c] IntSubCOp [aa,bb] _ +emitPrimOp dflags [res_r,res_c] IntSubCOp [aa,bb] _ {- Similarly: #define subIntCzh(r,c,a,b) \ { r = ((I_)(a)) - ((I_)(b)); \ @@ -105,19 +107,19 @@ emitPrimOp [res_r,res_c] IntSubCOp [aa,bb] _ c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1) -} = stmtsC [ - CmmAssign (CmmLocal res_r) (CmmMachOp mo_wordSub [aa,bb]), + CmmAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]), CmmAssign (CmmLocal res_c) $ - CmmMachOp mo_wordUShr [ - CmmMachOp mo_wordAnd [ - CmmMachOp mo_wordXor [aa,bb], - CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)] + CmmMachOp (mo_wordUShr dflags) [ + CmmMachOp (mo_wordAnd dflags) [ + CmmMachOp (mo_wordXor dflags) [aa,bb], + CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] ], - mkIntExpr (wORD_SIZE_IN_BITS - 1) + mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) ] ] -emitPrimOp [res] ParOp [arg] live +emitPrimOp _ [res] ParOp [arg] live = do -- for now, just implement this in a C function -- later, we might want to inline it. @@ -133,15 +135,15 @@ emitPrimOp [res] ParOp [arg] live where newspark = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))) -emitPrimOp [res] SparkOp [arg] live = do +emitPrimOp dflags [res] SparkOp [arg] live = do -- returns the value of arg in res. We're going to therefore -- refer to arg twice (once to pass to newSpark(), and once to -- assign to res), so put it in a temporary. - tmp <- newTemp bWord + tmp <- newTemp (bWord dflags) stmtC (CmmAssign (CmmLocal tmp) arg) vols <- getVolatileRegs live - res' <- newTemp bWord + res' <- newTemp (bWord dflags) emitForeignCall' PlayRisky [CmmHinted res' NoHint] (CmmCallee newspark CCallConv) @@ -154,24 +156,21 @@ emitPrimOp [res] SparkOp [arg] live = do where newspark = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))) -emitPrimOp [res] GetCCSOfOp [arg] _live - = do dflags <- getDynFlags - stmtC (CmmAssign (CmmLocal res) (val dflags)) +emitPrimOp dflags [res] GetCCSOfOp [arg] _live + = stmtC (CmmAssign (CmmLocal res) val) where - val dflags - | dopt Opt_SccProfilingOn dflags = costCentreFrom (cmmUntag arg) - | otherwise = CmmLit zeroCLit + val + | dopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg) + | otherwise = CmmLit (zeroCLit dflags) -emitPrimOp [res] GetCurrentCCSOp [_dummy_arg] _live +emitPrimOp _ [res] GetCurrentCCSOp [_dummy_arg] _live = stmtC (CmmAssign (CmmLocal res) curCCS) -emitPrimOp [res] ReadMutVarOp [mutv] _ - = do dflags <- getDynFlags - stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW mutv (fixedHdrSize dflags) gcWord)) +emitPrimOp dflags [res] ReadMutVarOp [mutv] _ + = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSize dflags) (gcWord dflags))) -emitPrimOp [] WriteMutVarOp [mutv,var] live - = do dflags <- getDynFlags - stmtC (CmmStore (cmmOffsetW mutv (fixedHdrSize dflags)) var) +emitPrimOp dflags [] WriteMutVarOp [mutv,var] live + = do stmtC (CmmStore (cmmOffsetW dflags mutv (fixedHdrSize dflags)) var) vols <- getVolatileRegs live emitForeignCall' PlayRisky [{-no results-}] @@ -185,54 +184,49 @@ emitPrimOp [] WriteMutVarOp [mutv,var] live -- #define sizzeofByteArrayzh(r,a) \ -- r = ((StgArrWords *)(a))->bytes -emitPrimOp [res] SizeofByteArrayOp [arg] _ - = do dflags <- getDynFlags - stmtC $ - CmmAssign (CmmLocal res) - (cmmLoadIndexW arg (fixedHdrSize dflags) bWord) +emitPrimOp dflags [res] SizeofByteArrayOp [arg] _ + = stmtC $ + CmmAssign (CmmLocal res) + (cmmLoadIndexW dflags arg (fixedHdrSize dflags) (bWord dflags)) -- #define sizzeofMutableByteArrayzh(r,a) \ -- r = ((StgArrWords *)(a))->bytes -emitPrimOp [res] SizeofMutableByteArrayOp [arg] live - = emitPrimOp [res] SizeofByteArrayOp [arg] live +emitPrimOp dflags [res] SizeofMutableByteArrayOp [arg] live + = emitPrimOp dflags [res] SizeofByteArrayOp [arg] live -- #define touchzh(o) /* nothing */ -emitPrimOp [] TouchOp [_] _ +emitPrimOp _ [] TouchOp [_] _ = nopC -- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) -emitPrimOp [res] ByteArrayContents_Char [arg] _ - = do dflags <- getDynFlags - stmtC (CmmAssign (CmmLocal res) (cmmOffsetB arg (arrWordsHdrSize dflags))) +emitPrimOp dflags [res] ByteArrayContents_Char [arg] _ + = stmtC (CmmAssign (CmmLocal res) (cmmOffsetB dflags arg (arrWordsHdrSize dflags))) -- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn) -emitPrimOp [res] StableNameToIntOp [arg] _ - = do dflags <- getDynFlags - stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize dflags) bWord)) +emitPrimOp dflags [res] StableNameToIntOp [arg] _ + = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSize dflags) (bWord dflags))) -- #define eqStableNamezh(r,sn1,sn2) \ -- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn)) -emitPrimOp [res] EqStableNameOp [arg1,arg2] _ - = do dflags <- getDynFlags - stmtC (CmmAssign (CmmLocal res) (CmmMachOp mo_wordEq [ - cmmLoadIndexW arg1 (fixedHdrSize dflags) bWord, - cmmLoadIndexW arg2 (fixedHdrSize dflags) bWord - ])) +emitPrimOp dflags [res] EqStableNameOp [arg1,arg2] _ + = stmtC (CmmAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [ + cmmLoadIndexW dflags arg1 (fixedHdrSize dflags) (bWord dflags), + cmmLoadIndexW dflags arg2 (fixedHdrSize dflags) (bWord dflags) + ])) -emitPrimOp [res] ReallyUnsafePtrEqualityOp [arg1,arg2] _ - = stmtC (CmmAssign (CmmLocal res) (CmmMachOp mo_wordEq [arg1,arg2])) +emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2] _ + = stmtC (CmmAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2])) -- #define addrToHValuezh(r,a) r=(P_)a -emitPrimOp [res] AddrToAnyOp [arg] _ +emitPrimOp _ [res] AddrToAnyOp [arg] _ = stmtC (CmmAssign (CmmLocal res) arg) -- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info)) -- Note: argument may be tagged! -emitPrimOp [res] DataToTagOp [arg] _ - = do dflags <- getDynFlags - stmtC (CmmAssign (CmmLocal res) (getConstrTag dflags (cmmUntag arg))) +emitPrimOp dflags [res] DataToTagOp [arg] _ + = stmtC (CmmAssign (CmmLocal res) (getConstrTag dflags (cmmUntag dflags arg))) {- Freezing arrays-of-ptrs requires changing an info table, for the benefit of the generational collector. It needs to scavenge mutable @@ -244,184 +238,183 @@ emitPrimOp [res] DataToTagOp [arg] _ -- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN0_info); -- r = a; -- } -emitPrimOp [res] UnsafeFreezeArrayOp [arg] _ +emitPrimOp _ [res] UnsafeFreezeArrayOp [arg] _ = stmtsC [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)), CmmAssign (CmmLocal res) arg ] -emitPrimOp [res] UnsafeFreezeArrayArrayOp [arg] _ +emitPrimOp _ [res] UnsafeFreezeArrayArrayOp [arg] _ = stmtsC [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)), CmmAssign (CmmLocal res) arg ] -- #define unsafeFreezzeByteArrayzh(r,a) r=(a) -emitPrimOp [res] UnsafeFreezeByteArrayOp [arg] _ +emitPrimOp _ [res] UnsafeFreezeByteArrayOp [arg] _ = stmtC (CmmAssign (CmmLocal res) arg) -emitPrimOp [] CopyArrayOp [src,src_off,dst,dst_off,n] live = +emitPrimOp _ [] CopyArrayOp [src,src_off,dst,dst_off,n] live = doCopyArrayOp src src_off dst dst_off n live -emitPrimOp [] CopyMutableArrayOp [src,src_off,dst,dst_off,n] live = +emitPrimOp _ [] CopyMutableArrayOp [src,src_off,dst,dst_off,n] live = doCopyMutableArrayOp src src_off dst dst_off n live -emitPrimOp [res] CloneArrayOp [src,src_off,n] live = +emitPrimOp _ [res] CloneArrayOp [src,src_off,n] live = emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n live -emitPrimOp [res] CloneMutableArrayOp [src,src_off,n] live = +emitPrimOp _ [res] CloneMutableArrayOp [src,src_off,n] live = emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n live -emitPrimOp [res] FreezeArrayOp [src,src_off,n] live = +emitPrimOp _ [res] FreezeArrayOp [src,src_off,n] live = emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n live -emitPrimOp [res] ThawArrayOp [src,src_off,n] live = +emitPrimOp _ [res] ThawArrayOp [src,src_off,n] live = emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n live -emitPrimOp [] CopyArrayArrayOp [src,src_off,dst,dst_off,n] live = +emitPrimOp _ [] CopyArrayArrayOp [src,src_off,dst,dst_off,n] live = doCopyArrayOp src src_off dst dst_off n live -emitPrimOp [] CopyMutableArrayArrayOp [src,src_off,dst,dst_off,n] live = +emitPrimOp _ [] CopyMutableArrayArrayOp [src,src_off,dst,dst_off,n] live = doCopyMutableArrayOp src src_off dst dst_off n live -- Reading/writing pointer arrays -emitPrimOp [r] ReadArrayOp [obj,ix] _ = doReadPtrArrayOp r obj ix -emitPrimOp [r] IndexArrayOp [obj,ix] _ = doReadPtrArrayOp r obj ix -emitPrimOp [] WriteArrayOp [obj,ix,v] _ = doWritePtrArrayOp obj ix v - -emitPrimOp [r] IndexArrayArrayOp_ByteArray [obj,ix] _ = doReadPtrArrayOp r obj ix -emitPrimOp [r] IndexArrayArrayOp_ArrayArray [obj,ix] _ = doReadPtrArrayOp r obj ix -emitPrimOp [r] ReadArrayArrayOp_ByteArray [obj,ix] _ = doReadPtrArrayOp r obj ix -emitPrimOp [r] ReadArrayArrayOp_MutableByteArray [obj,ix] _ = doReadPtrArrayOp r obj ix -emitPrimOp [r] ReadArrayArrayOp_ArrayArray [obj,ix] _ = doReadPtrArrayOp r obj ix -emitPrimOp [r] ReadArrayArrayOp_MutableArrayArray [obj,ix] _ = doReadPtrArrayOp r obj ix -emitPrimOp [] WriteArrayArrayOp_ByteArray [obj,ix,v] _ = doWritePtrArrayOp obj ix v -emitPrimOp [] WriteArrayArrayOp_MutableByteArray [obj,ix,v] _ = doWritePtrArrayOp obj ix v -emitPrimOp [] WriteArrayArrayOp_ArrayArray [obj,ix,v] _ = doWritePtrArrayOp obj ix v -emitPrimOp [] WriteArrayArrayOp_MutableArrayArray [obj,ix,v] _ = doWritePtrArrayOp obj ix v - -emitPrimOp [res] SizeofArrayOp [arg] _ - = do dflags <- getDynFlags - stmtC $ CmmAssign (CmmLocal res) - (cmmLoadIndexW arg (fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs) bWord) -emitPrimOp [res] SizeofMutableArrayOp [arg] live - = emitPrimOp [res] SizeofArrayOp [arg] live -emitPrimOp [res] SizeofArrayArrayOp [arg] live - = emitPrimOp [res] SizeofArrayOp [arg] live -emitPrimOp [res] SizeofMutableArrayArrayOp [arg] live - = emitPrimOp [res] SizeofArrayOp [arg] live +emitPrimOp _ [r] ReadArrayOp [obj,ix] _ = doReadPtrArrayOp r obj ix +emitPrimOp _ [r] IndexArrayOp [obj,ix] _ = doReadPtrArrayOp r obj ix +emitPrimOp _ [] WriteArrayOp [obj,ix,v] _ = doWritePtrArrayOp obj ix v + +emitPrimOp _ [r] IndexArrayArrayOp_ByteArray [obj,ix] _ = doReadPtrArrayOp r obj ix +emitPrimOp _ [r] IndexArrayArrayOp_ArrayArray [obj,ix] _ = doReadPtrArrayOp r obj ix +emitPrimOp _ [r] ReadArrayArrayOp_ByteArray [obj,ix] _ = doReadPtrArrayOp r obj ix +emitPrimOp _ [r] ReadArrayArrayOp_MutableByteArray [obj,ix] _ = doReadPtrArrayOp r obj ix +emitPrimOp _ [r] ReadArrayArrayOp_ArrayArray [obj,ix] _ = doReadPtrArrayOp r obj ix +emitPrimOp _ [r] ReadArrayArrayOp_MutableArrayArray [obj,ix] _ = doReadPtrArrayOp r obj ix +emitPrimOp _ [] WriteArrayArrayOp_ByteArray [obj,ix,v] _ = doWritePtrArrayOp obj ix v +emitPrimOp _ [] WriteArrayArrayOp_MutableByteArray [obj,ix,v] _ = doWritePtrArrayOp obj ix v +emitPrimOp _ [] WriteArrayArrayOp_ArrayArray [obj,ix,v] _ = doWritePtrArrayOp obj ix v +emitPrimOp _ [] WriteArrayArrayOp_MutableArrayArray [obj,ix,v] _ = doWritePtrArrayOp obj ix v + +emitPrimOp dflags [res] SizeofArrayOp [arg] _ + = stmtC $ CmmAssign (CmmLocal res) + (cmmLoadIndexW dflags arg (fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags) (bWord dflags)) +emitPrimOp dflags [res] SizeofMutableArrayOp [arg] live + = emitPrimOp dflags [res] SizeofArrayOp [arg] live +emitPrimOp dflags [res] SizeofArrayArrayOp [arg] live + = emitPrimOp dflags [res] SizeofArrayOp [arg] live +emitPrimOp dflags [res] SizeofMutableArrayArrayOp [arg] live + = emitPrimOp dflags [res] SizeofArrayOp [arg] live -- IndexXXXoffAddr -emitPrimOp res IndexOffAddrOp_Char args _ = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res IndexOffAddrOp_WideChar args _ = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res IndexOffAddrOp_Int args _ = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res IndexOffAddrOp_Word args _ = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res IndexOffAddrOp_Addr args _ = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res IndexOffAddrOp_Float args _ = doIndexOffAddrOp Nothing f32 res args -emitPrimOp res IndexOffAddrOp_Double args _ = doIndexOffAddrOp Nothing f64 res args -emitPrimOp res IndexOffAddrOp_StablePtr args _ = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res IndexOffAddrOp_Int8 args _ = doIndexOffAddrOp (Just mo_s_8ToWord) b8 res args -emitPrimOp res IndexOffAddrOp_Int16 args _ = doIndexOffAddrOp (Just mo_s_16ToWord) b16 res args -emitPrimOp res IndexOffAddrOp_Int32 args _ = doIndexOffAddrOp (Just mo_s_32ToWord) b32 res args -emitPrimOp res IndexOffAddrOp_Int64 args _ = doIndexOffAddrOp Nothing b64 res args -emitPrimOp res IndexOffAddrOp_Word8 args _ = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res IndexOffAddrOp_Word16 args _ = doIndexOffAddrOp (Just mo_u_16ToWord) b16 res args -emitPrimOp res IndexOffAddrOp_Word32 args _ = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res IndexOffAddrOp_Word64 args _ = doIndexOffAddrOp Nothing b64 res args +emitPrimOp dflags res IndexOffAddrOp_Char args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexOffAddrOp_WideChar args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp dflags res IndexOffAddrOp_Int args _ = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexOffAddrOp_Word args _ = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexOffAddrOp_Addr args _ = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp _ res IndexOffAddrOp_Float args _ = doIndexOffAddrOp Nothing f32 res args +emitPrimOp _ res IndexOffAddrOp_Double args _ = doIndexOffAddrOp Nothing f64 res args +emitPrimOp dflags res IndexOffAddrOp_StablePtr args _ = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexOffAddrOp_Int8 args _ = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexOffAddrOp_Int16 args _ = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexOffAddrOp_Int32 args _ = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args +emitPrimOp _ res IndexOffAddrOp_Int64 args _ = doIndexOffAddrOp Nothing b64 res args +emitPrimOp dflags res IndexOffAddrOp_Word8 args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexOffAddrOp_Word16 args _ = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexOffAddrOp_Word32 args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp _ res IndexOffAddrOp_Word64 args _ = doIndexOffAddrOp Nothing b64 res args -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr. -emitPrimOp res ReadOffAddrOp_Char args _ = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res ReadOffAddrOp_WideChar args _ = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res ReadOffAddrOp_Int args _ = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res ReadOffAddrOp_Word args _ = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res ReadOffAddrOp_Addr args _ = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res ReadOffAddrOp_Float args _ = doIndexOffAddrOp Nothing f32 res args -emitPrimOp res ReadOffAddrOp_Double args _ = doIndexOffAddrOp Nothing f64 res args -emitPrimOp res ReadOffAddrOp_StablePtr args _ = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res ReadOffAddrOp_Int8 args _ = doIndexOffAddrOp (Just mo_s_8ToWord) b8 res args -emitPrimOp res ReadOffAddrOp_Int16 args _ = doIndexOffAddrOp (Just mo_s_16ToWord) b16 res args -emitPrimOp res ReadOffAddrOp_Int32 args _ = doIndexOffAddrOp (Just mo_s_32ToWord) b32 res args -emitPrimOp res ReadOffAddrOp_Int64 args _ = doIndexOffAddrOp Nothing b64 res args -emitPrimOp res ReadOffAddrOp_Word8 args _ = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res ReadOffAddrOp_Word16 args _ = doIndexOffAddrOp (Just mo_u_16ToWord) b16 res args -emitPrimOp res ReadOffAddrOp_Word32 args _ = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res ReadOffAddrOp_Word64 args _ = doIndexOffAddrOp Nothing b64 res args +emitPrimOp dflags res ReadOffAddrOp_Char args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadOffAddrOp_WideChar args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp dflags res ReadOffAddrOp_Int args _ = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadOffAddrOp_Word args _ = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadOffAddrOp_Addr args _ = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp _ res ReadOffAddrOp_Float args _ = doIndexOffAddrOp Nothing f32 res args +emitPrimOp _ res ReadOffAddrOp_Double args _ = doIndexOffAddrOp Nothing f64 res args +emitPrimOp dflags res ReadOffAddrOp_StablePtr args _ = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadOffAddrOp_Int8 args _ = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadOffAddrOp_Int16 args _ = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadOffAddrOp_Int32 args _ = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args +emitPrimOp _ res ReadOffAddrOp_Int64 args _ = doIndexOffAddrOp Nothing b64 res args +emitPrimOp dflags res ReadOffAddrOp_Word8 args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadOffAddrOp_Word16 args _ = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadOffAddrOp_Word32 args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp _ res ReadOffAddrOp_Word64 args _ = doIndexOffAddrOp Nothing b64 res args -- IndexXXXArray -emitPrimOp res IndexByteArrayOp_Char args _ = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res IndexByteArrayOp_WideChar args _ = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res IndexByteArrayOp_Int args _ = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res IndexByteArrayOp_Word args _ = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res IndexByteArrayOp_Addr args _ = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res IndexByteArrayOp_Float args _ = doIndexByteArrayOp Nothing f32 res args -emitPrimOp res IndexByteArrayOp_Double args _ = doIndexByteArrayOp Nothing f64 res args -emitPrimOp res IndexByteArrayOp_StablePtr args _ = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res IndexByteArrayOp_Int8 args _ = doIndexByteArrayOp (Just mo_s_8ToWord) b8 res args -emitPrimOp res IndexByteArrayOp_Int16 args _ = doIndexByteArrayOp (Just mo_s_16ToWord) b16 res args -emitPrimOp res IndexByteArrayOp_Int32 args _ = doIndexByteArrayOp (Just mo_s_32ToWord) b32 res args -emitPrimOp res IndexByteArrayOp_Int64 args _ = doIndexByteArrayOp Nothing b64 res args -emitPrimOp res IndexByteArrayOp_Word8 args _ = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res IndexByteArrayOp_Word16 args _ = doIndexByteArrayOp (Just mo_u_16ToWord) b16 res args -emitPrimOp res IndexByteArrayOp_Word32 args _ = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res IndexByteArrayOp_Word64 args _ = doIndexByteArrayOp Nothing b64 res args +emitPrimOp dflags res IndexByteArrayOp_Char args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexByteArrayOp_WideChar args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp dflags res IndexByteArrayOp_Int args _ = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexByteArrayOp_Word args _ = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexByteArrayOp_Addr args _ = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp _ res IndexByteArrayOp_Float args _ = doIndexByteArrayOp Nothing f32 res args +emitPrimOp _ res IndexByteArrayOp_Double args _ = doIndexByteArrayOp Nothing f64 res args +emitPrimOp dflags res IndexByteArrayOp_StablePtr args _ = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexByteArrayOp_Int8 args _ = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexByteArrayOp_Int16 args _ = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexByteArrayOp_Int32 args _ = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args +emitPrimOp _ res IndexByteArrayOp_Int64 args _ = doIndexByteArrayOp Nothing b64 res args +emitPrimOp dflags res IndexByteArrayOp_Word8 args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexByteArrayOp_Word16 args _ = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexByteArrayOp_Word32 args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp _ res IndexByteArrayOp_Word64 args _ = doIndexByteArrayOp Nothing b64 res args -- ReadXXXArray, identical to IndexXXXArray. -emitPrimOp res ReadByteArrayOp_Char args _ = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res ReadByteArrayOp_WideChar args _ = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res ReadByteArrayOp_Int args _ = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res ReadByteArrayOp_Word args _ = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res ReadByteArrayOp_Addr args _ = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res ReadByteArrayOp_Float args _ = doIndexByteArrayOp Nothing f32 res args -emitPrimOp res ReadByteArrayOp_Double args _ = doIndexByteArrayOp Nothing f64 res args -emitPrimOp res ReadByteArrayOp_StablePtr args _ = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res ReadByteArrayOp_Int8 args _ = doIndexByteArrayOp (Just mo_s_8ToWord) b8 res args -emitPrimOp res ReadByteArrayOp_Int16 args _ = doIndexByteArrayOp (Just mo_s_16ToWord) b16 res args -emitPrimOp res ReadByteArrayOp_Int32 args _ = doIndexByteArrayOp (Just mo_s_32ToWord) b32 res args -emitPrimOp res ReadByteArrayOp_Int64 args _ = doIndexByteArrayOp Nothing b64 res args -emitPrimOp res ReadByteArrayOp_Word8 args _ = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res ReadByteArrayOp_Word16 args _ = doIndexByteArrayOp (Just mo_u_16ToWord) b16 res args -emitPrimOp res ReadByteArrayOp_Word32 args _ = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res ReadByteArrayOp_Word64 args _ = doIndexByteArrayOp Nothing b64 res args +emitPrimOp dflags res ReadByteArrayOp_Char args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadByteArrayOp_WideChar args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp dflags res ReadByteArrayOp_Int args _ = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadByteArrayOp_Word args _ = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadByteArrayOp_Addr args _ = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp _ res ReadByteArrayOp_Float args _ = doIndexByteArrayOp Nothing f32 res args +emitPrimOp _ res ReadByteArrayOp_Double args _ = doIndexByteArrayOp Nothing f64 res args +emitPrimOp dflags res ReadByteArrayOp_StablePtr args _ = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadByteArrayOp_Int8 args _ = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadByteArrayOp_Int16 args _ = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadByteArrayOp_Int32 args _ = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args +emitPrimOp _ res ReadByteArrayOp_Int64 args _ = doIndexByteArrayOp Nothing b64 res args +emitPrimOp dflags res ReadByteArrayOp_Word8 args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadByteArrayOp_Word16 args _ = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadByteArrayOp_Word32 args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp _ res ReadByteArrayOp_Word64 args _ = doIndexByteArrayOp Nothing b64 res args -- WriteXXXoffAddr -emitPrimOp res WriteOffAddrOp_Char args _ = doWriteOffAddrOp (Just mo_WordTo8) b8 res args -emitPrimOp res WriteOffAddrOp_WideChar args _ = doWriteOffAddrOp (Just mo_WordTo32) b32 res args -emitPrimOp res WriteOffAddrOp_Int args _ = doWriteOffAddrOp Nothing bWord res args -emitPrimOp res WriteOffAddrOp_Word args _ = doWriteOffAddrOp Nothing bWord res args -emitPrimOp res WriteOffAddrOp_Addr args _ = doWriteOffAddrOp Nothing bWord res args -emitPrimOp res WriteOffAddrOp_Float args _ = doWriteOffAddrOp Nothing f32 res args -emitPrimOp res WriteOffAddrOp_Double args _ = doWriteOffAddrOp Nothing f64 res args -emitPrimOp res WriteOffAddrOp_StablePtr args _ = doWriteOffAddrOp Nothing bWord res args -emitPrimOp res WriteOffAddrOp_Int8 args _ = doWriteOffAddrOp (Just mo_WordTo8) b8 res args -emitPrimOp res WriteOffAddrOp_Int16 args _ = doWriteOffAddrOp (Just mo_WordTo16) b16 res args -emitPrimOp res WriteOffAddrOp_Int32 args _ = doWriteOffAddrOp (Just mo_WordTo32) b32 res args -emitPrimOp res WriteOffAddrOp_Int64 args _ = doWriteOffAddrOp Nothing b64 res args -emitPrimOp res WriteOffAddrOp_Word8 args _ = doWriteOffAddrOp (Just mo_WordTo8) b8 res args -emitPrimOp res WriteOffAddrOp_Word16 args _ = doWriteOffAddrOp (Just mo_WordTo16) b16 res args -emitPrimOp res WriteOffAddrOp_Word32 args _ = doWriteOffAddrOp (Just mo_WordTo32) b32 res args -emitPrimOp res WriteOffAddrOp_Word64 args _ = doWriteOffAddrOp Nothing b64 res args +emitPrimOp dflags res WriteOffAddrOp_Char args _ = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args +emitPrimOp dflags res WriteOffAddrOp_WideChar args _ = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args +emitPrimOp dflags res WriteOffAddrOp_Int args _ = doWriteOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res WriteOffAddrOp_Word args _ = doWriteOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res WriteOffAddrOp_Addr args _ = doWriteOffAddrOp Nothing (bWord dflags) res args +emitPrimOp _ res WriteOffAddrOp_Float args _ = doWriteOffAddrOp Nothing f32 res args +emitPrimOp _ res WriteOffAddrOp_Double args _ = doWriteOffAddrOp Nothing f64 res args +emitPrimOp dflags res WriteOffAddrOp_StablePtr args _ = doWriteOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res WriteOffAddrOp_Int8 args _ = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args +emitPrimOp dflags res WriteOffAddrOp_Int16 args _ = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args +emitPrimOp dflags res WriteOffAddrOp_Int32 args _ = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args +emitPrimOp _ res WriteOffAddrOp_Int64 args _ = doWriteOffAddrOp Nothing b64 res args +emitPrimOp dflags res WriteOffAddrOp_Word8 args _ = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args +emitPrimOp dflags res WriteOffAddrOp_Word16 args _ = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args +emitPrimOp dflags res WriteOffAddrOp_Word32 args _ = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args +emitPrimOp _ res WriteOffAddrOp_Word64 args _ = doWriteOffAddrOp Nothing b64 res args -- WriteXXXArray -emitPrimOp res WriteByteArrayOp_Char args _ = doWriteByteArrayOp (Just mo_WordTo8) b8 res args -emitPrimOp res WriteByteArrayOp_WideChar args _ = doWriteByteArrayOp (Just mo_WordTo32) b32 res args -emitPrimOp res WriteByteArrayOp_Int args _ = doWriteByteArrayOp Nothing bWord res args -emitPrimOp res WriteByteArrayOp_Word args _ = doWriteByteArrayOp Nothing bWord res args -emitPrimOp res WriteByteArrayOp_Addr args _ = doWriteByteArrayOp Nothing bWord res args -emitPrimOp res WriteByteArrayOp_Float args _ = doWriteByteArrayOp Nothing f32 res args -emitPrimOp res WriteByteArrayOp_Double args _ = doWriteByteArrayOp Nothing f64 res args -emitPrimOp res WriteByteArrayOp_StablePtr args _ = doWriteByteArrayOp Nothing bWord res args -emitPrimOp res WriteByteArrayOp_Int8 args _ = doWriteByteArrayOp (Just mo_WordTo8) b8 res args -emitPrimOp res WriteByteArrayOp_Int16 args _ = doWriteByteArrayOp (Just mo_WordTo16) b16 res args -emitPrimOp res WriteByteArrayOp_Int32 args _ = doWriteByteArrayOp (Just mo_WordTo32) b32 res args -emitPrimOp res WriteByteArrayOp_Int64 args _ = doWriteByteArrayOp Nothing b64 res args -emitPrimOp res WriteByteArrayOp_Word8 args _ = doWriteByteArrayOp (Just mo_WordTo8) b8 res args -emitPrimOp res WriteByteArrayOp_Word16 args _ = doWriteByteArrayOp (Just mo_WordTo16) b16 res args -emitPrimOp res WriteByteArrayOp_Word32 args _ = doWriteByteArrayOp (Just mo_WordTo32) b32 res args -emitPrimOp res WriteByteArrayOp_Word64 args _ = doWriteByteArrayOp Nothing b64 res args +emitPrimOp dflags res WriteByteArrayOp_Char args _ = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args +emitPrimOp dflags res WriteByteArrayOp_WideChar args _ = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args +emitPrimOp dflags res WriteByteArrayOp_Int args _ = doWriteByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res WriteByteArrayOp_Word args _ = doWriteByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res WriteByteArrayOp_Addr args _ = doWriteByteArrayOp Nothing (bWord dflags) res args +emitPrimOp _ res WriteByteArrayOp_Float args _ = doWriteByteArrayOp Nothing f32 res args +emitPrimOp _ res WriteByteArrayOp_Double args _ = doWriteByteArrayOp Nothing f64 res args +emitPrimOp dflags res WriteByteArrayOp_StablePtr args _ = doWriteByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res WriteByteArrayOp_Int8 args _ = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args +emitPrimOp dflags res WriteByteArrayOp_Int16 args _ = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args +emitPrimOp dflags res WriteByteArrayOp_Int32 args _ = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args +emitPrimOp _ res WriteByteArrayOp_Int64 args _ = doWriteByteArrayOp Nothing b64 res args +emitPrimOp dflags res WriteByteArrayOp_Word8 args _ = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args +emitPrimOp dflags res WriteByteArrayOp_Word16 args _ = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args +emitPrimOp dflags res WriteByteArrayOp_Word32 args _ = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args +emitPrimOp _ res WriteByteArrayOp_Word64 args _ = doWriteByteArrayOp Nothing b64 res args -- Copying and setting byte arrays -emitPrimOp [] CopyByteArrayOp [src,src_off,dst,dst_off,n] live = +emitPrimOp _ [] CopyByteArrayOp [src,src_off,dst,dst_off,n] live = doCopyByteArrayOp src src_off dst dst_off n live -emitPrimOp [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] live = +emitPrimOp _ [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] live = doCopyMutableByteArrayOp src src_off dst dst_off n live -emitPrimOp [] SetByteArrayOp [ba,off,len,c] live = +emitPrimOp _ [] SetByteArrayOp [ba,off,len,c] live = doSetByteArrayOp ba off len c live -- Population count. @@ -429,27 +422,27 @@ emitPrimOp [] SetByteArrayOp [ba,off,len,c] live = -- to the correct width before calling the primop. Otherwise this can result -- in a crash e.g. when calling the helper hs_popcnt8() which assumes that the -- argument is <=0xff. -emitPrimOp [res] PopCnt8Op [w] live = - emitPopCntCall res (CmmMachOp mo_WordTo8 [w]) W8 live -emitPrimOp [res] PopCnt16Op [w] live = - emitPopCntCall res (CmmMachOp mo_WordTo16 [w]) W16 live -emitPrimOp [res] PopCnt32Op [w] live = - emitPopCntCall res (CmmMachOp mo_WordTo32 [w]) W32 live -emitPrimOp [res] PopCnt64Op [w] live = - emitPopCntCall res (CmmMachOp mo_WordTo64 [w]) W64 live -emitPrimOp [res] PopCntOp [w] live = - emitPopCntCall res w wordWidth live +emitPrimOp dflags [res] PopCnt8Op [w] live = + emitPopCntCall res (CmmMachOp (mo_WordTo8 dflags) [w]) W8 live +emitPrimOp dflags [res] PopCnt16Op [w] live = + emitPopCntCall res (CmmMachOp (mo_WordTo16 dflags) [w]) W16 live +emitPrimOp dflags [res] PopCnt32Op [w] live = + emitPopCntCall res (CmmMachOp (mo_WordTo32 dflags) [w]) W32 live +emitPrimOp dflags [res] PopCnt64Op [w] live = + emitPopCntCall res (CmmMachOp (mo_WordTo64 dflags) [w]) W64 live +emitPrimOp dflags [res] PopCntOp [w] live = + emitPopCntCall res w (wordWidth dflags) live -- The rest just translate straightforwardly -emitPrimOp [res] op [arg] _ +emitPrimOp dflags [res] op [arg] _ | nopOp op = stmtC (CmmAssign (CmmLocal res) arg) | Just (mop,rep) <- narrowOp op = stmtC (CmmAssign (CmmLocal res) $ - CmmMachOp (mop rep wordWidth) [CmmMachOp (mop wordWidth rep) [arg]]) + CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]]) -emitPrimOp [res] op args live +emitPrimOp dflags [res] op args live | Just prim <- callishOp op = do vols <- getVolatileRegs live emitForeignCall' PlayRisky @@ -460,49 +453,49 @@ emitPrimOp [res] op args live NoC_SRT -- No SRT b/c we do PlayRisky CmmMayReturn - | Just mop <- translateOp op + | Just mop <- translateOp dflags op = let stmt = CmmAssign (CmmLocal res) (CmmMachOp mop args) in stmtC stmt -emitPrimOp [res_q, res_r] IntQuotRemOp [arg_x, arg_y] _ +emitPrimOp dflags [res_q, res_r] IntQuotRemOp [arg_x, arg_y] _ = let genericImpl = [CmmAssign (CmmLocal res_q) - (CmmMachOp (MO_S_Quot wordWidth) [arg_x, arg_y]), + (CmmMachOp (MO_S_Quot (wordWidth dflags)) [arg_x, arg_y]), CmmAssign (CmmLocal res_r) - (CmmMachOp (MO_S_Rem wordWidth) [arg_x, arg_y])] - stmt = CmmCall (CmmPrim (MO_S_QuotRem wordWidth) (Just genericImpl)) + (CmmMachOp (MO_S_Rem (wordWidth dflags)) [arg_x, arg_y])] + stmt = CmmCall (CmmPrim (MO_S_QuotRem (wordWidth dflags)) (Just genericImpl)) [CmmHinted res_q NoHint, CmmHinted res_r NoHint] [CmmHinted arg_x NoHint, CmmHinted arg_y NoHint] CmmMayReturn in stmtC stmt -emitPrimOp [res_q, res_r] WordQuotRemOp [arg_x, arg_y] _ +emitPrimOp dflags [res_q, res_r] WordQuotRemOp [arg_x, arg_y] _ = let genericImpl = [CmmAssign (CmmLocal res_q) - (CmmMachOp (MO_U_Quot wordWidth) [arg_x, arg_y]), + (CmmMachOp (MO_U_Quot (wordWidth dflags)) [arg_x, arg_y]), CmmAssign (CmmLocal res_r) - (CmmMachOp (MO_U_Rem wordWidth) [arg_x, arg_y])] - stmt = CmmCall (CmmPrim (MO_U_QuotRem wordWidth) (Just genericImpl)) + (CmmMachOp (MO_U_Rem (wordWidth dflags)) [arg_x, arg_y])] + stmt = CmmCall (CmmPrim (MO_U_QuotRem (wordWidth dflags)) (Just genericImpl)) [CmmHinted res_q NoHint, CmmHinted res_r NoHint] [CmmHinted arg_x NoHint, CmmHinted arg_y NoHint] CmmMayReturn in stmtC stmt -emitPrimOp [res_q, res_r] WordQuotRem2Op [arg_x_high, arg_x_low, arg_y] _ - = do let ty = cmmExprType arg_x_high - shl x i = CmmMachOp (MO_Shl wordWidth) [x, i] - shr x i = CmmMachOp (MO_U_Shr wordWidth) [x, i] - or x y = CmmMachOp (MO_Or wordWidth) [x, y] - ge x y = CmmMachOp (MO_U_Ge wordWidth) [x, y] - ne x y = CmmMachOp (MO_Ne wordWidth) [x, y] - minus x y = CmmMachOp (MO_Sub wordWidth) [x, y] - times x y = CmmMachOp (MO_Mul wordWidth) [x, y] +emitPrimOp dflags [res_q, res_r] WordQuotRem2Op [arg_x_high, arg_x_low, arg_y] _ + = do let ty = cmmExprType dflags arg_x_high + shl x i = CmmMachOp (MO_Shl (wordWidth dflags)) [x, i] + shr x i = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, i] + or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] + ge x y = CmmMachOp (MO_U_Ge (wordWidth dflags)) [x, y] + ne x y = CmmMachOp (MO_Ne (wordWidth dflags)) [x, y] + minus x y = CmmMachOp (MO_Sub (wordWidth dflags)) [x, y] + times x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y] zero = lit 0 one = lit 1 - negone = lit (fromIntegral (widthInBits wordWidth) - 1) - lit i = CmmLit (CmmInt i wordWidth) + negone = lit (fromIntegral (widthInBits (wordWidth dflags)) - 1) + lit i = CmmLit (CmmInt i (wordWidth dflags)) f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode [CmmStmt] f 0 acc high _ = return [CmmAssign (CmmLocal res_q) acc, CmmAssign (CmmLocal res_r) high] @@ -533,8 +526,8 @@ emitPrimOp [res_q, res_r] WordQuotRem2Op [arg_x_high, arg_x_low, arg_y] _ (CmmReg (CmmLocal rhigh'')) (CmmReg (CmmLocal rlow')) return (this ++ rest) - genericImpl <- f (widthInBits wordWidth) zero arg_x_high arg_x_low - let stmt = CmmCall (CmmPrim (MO_U_QuotRem2 wordWidth) (Just genericImpl)) + genericImpl <- f (widthInBits (wordWidth dflags)) zero arg_x_high arg_x_low + let stmt = CmmCall (CmmPrim (MO_U_QuotRem2 (wordWidth dflags)) (Just genericImpl)) [CmmHinted res_q NoHint, CmmHinted res_r NoHint] [CmmHinted arg_x_high NoHint, @@ -543,9 +536,9 @@ emitPrimOp [res_q, res_r] WordQuotRem2Op [arg_x_high, arg_x_low, arg_y] _ CmmMayReturn stmtC stmt -emitPrimOp [res_h, res_l] WordAdd2Op [arg_x, arg_y] _ - = do r1 <- newLocalReg (cmmExprType arg_x) - r2 <- newLocalReg (cmmExprType arg_x) +emitPrimOp dflags [res_h, res_l] WordAdd2Op [arg_x, arg_y] _ + = do r1 <- newLocalReg (cmmExprType dflags arg_x) + r2 <- newLocalReg (cmmExprType dflags arg_x) -- This generic implementation is very simple and slow. We might -- well be able to do better, but for now this at least works. let genericImpl @@ -559,23 +552,23 @@ emitPrimOp [res_h, res_l] WordAdd2Op [arg_x, arg_y] _ CmmAssign (CmmLocal res_l) (or (toTopHalf (CmmReg (CmmLocal r2))) (bottomHalf (CmmReg (CmmLocal r1))))] - where topHalf x = CmmMachOp (MO_U_Shr wordWidth) [x, hww] - toTopHalf x = CmmMachOp (MO_Shl wordWidth) [x, hww] - bottomHalf x = CmmMachOp (MO_And wordWidth) [x, hwm] - add x y = CmmMachOp (MO_Add wordWidth) [x, y] - or x y = CmmMachOp (MO_Or wordWidth) [x, y] - hww = CmmLit (CmmInt (fromIntegral (widthInBits halfWordWidth)) - wordWidth) - hwm = CmmLit (CmmInt halfWordMask wordWidth) - stmt = CmmCall (CmmPrim (MO_Add2 wordWidth) (Just genericImpl)) + where topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww] + toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww] + bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm] + add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y] + or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] + hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags))) + (wordWidth dflags)) + hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags)) + stmt = CmmCall (CmmPrim (MO_Add2 (wordWidth dflags)) (Just genericImpl)) [CmmHinted res_h NoHint, CmmHinted res_l NoHint] [CmmHinted arg_x NoHint, CmmHinted arg_y NoHint] CmmMayReturn stmtC stmt -emitPrimOp [res_h, res_l] WordMul2Op [arg_x, arg_y] _ - = do let t = cmmExprType arg_x +emitPrimOp dflags [res_h, res_l] WordMul2Op [arg_x, arg_y] _ + = do let t = cmmExprType dflags arg_x xlyl <- liftM CmmLocal $ newLocalReg t xlyh <- liftM CmmLocal $ newLocalReg t xhyl <- liftM CmmLocal $ newLocalReg t @@ -601,17 +594,17 @@ emitPrimOp [res_h, res_l] WordMul2Op [arg_x, arg_y] _ topHalf (CmmReg xhyl), topHalf (CmmReg xlyh), topHalf (CmmReg r)])] - where topHalf x = CmmMachOp (MO_U_Shr wordWidth) [x, hww] - toTopHalf x = CmmMachOp (MO_Shl wordWidth) [x, hww] - bottomHalf x = CmmMachOp (MO_And wordWidth) [x, hwm] - add x y = CmmMachOp (MO_Add wordWidth) [x, y] + where topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww] + toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww] + bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm] + add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y] sum = foldl1 add - mul x y = CmmMachOp (MO_Mul wordWidth) [x, y] - or x y = CmmMachOp (MO_Or wordWidth) [x, y] - hww = CmmLit (CmmInt (fromIntegral (widthInBits halfWordWidth)) - wordWidth) - hwm = CmmLit (CmmInt halfWordMask wordWidth) - stmt = CmmCall (CmmPrim (MO_U_Mul2 wordWidth) (Just genericImpl)) + mul x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y] + or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] + hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags))) + (wordWidth dflags)) + hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags)) + stmt = CmmCall (CmmPrim (MO_U_Mul2 (wordWidth dflags)) (Just genericImpl)) [CmmHinted res_h NoHint, CmmHinted res_l NoHint] [CmmHinted arg_x NoHint, @@ -619,7 +612,7 @@ emitPrimOp [res_h, res_l] WordMul2Op [arg_x, arg_y] _ CmmMayReturn stmtC stmt -emitPrimOp _ op _ _ +emitPrimOp _ _ op _ _ = pprPanic "emitPrimOp: can't translate PrimOp" (ppr op) newLocalReg :: CmmType -> FCode LocalReg @@ -650,125 +643,125 @@ narrowOp _ = Nothing -- Native word signless ops -translateOp :: PrimOp -> Maybe MachOp -translateOp IntAddOp = Just mo_wordAdd -translateOp IntSubOp = Just mo_wordSub -translateOp WordAddOp = Just mo_wordAdd -translateOp WordSubOp = Just mo_wordSub -translateOp AddrAddOp = Just mo_wordAdd -translateOp AddrSubOp = Just mo_wordSub - -translateOp IntEqOp = Just mo_wordEq -translateOp IntNeOp = Just mo_wordNe -translateOp WordEqOp = Just mo_wordEq -translateOp WordNeOp = Just mo_wordNe -translateOp AddrEqOp = Just mo_wordEq -translateOp AddrNeOp = Just mo_wordNe - -translateOp AndOp = Just mo_wordAnd -translateOp OrOp = Just mo_wordOr -translateOp XorOp = Just mo_wordXor -translateOp NotOp = Just mo_wordNot -translateOp SllOp = Just mo_wordShl -translateOp SrlOp = Just mo_wordUShr - -translateOp AddrRemOp = Just mo_wordURem +translateOp :: DynFlags -> PrimOp -> Maybe MachOp +translateOp dflags IntAddOp = Just (mo_wordAdd dflags) +translateOp dflags IntSubOp = Just (mo_wordSub dflags) +translateOp dflags WordAddOp = Just (mo_wordAdd dflags) +translateOp dflags WordSubOp = Just (mo_wordSub dflags) +translateOp dflags AddrAddOp = Just (mo_wordAdd dflags) +translateOp dflags AddrSubOp = Just (mo_wordSub dflags) + +translateOp dflags IntEqOp = Just (mo_wordEq dflags) +translateOp dflags IntNeOp = Just (mo_wordNe dflags) +translateOp dflags WordEqOp = Just (mo_wordEq dflags) +translateOp dflags WordNeOp = Just (mo_wordNe dflags) +translateOp dflags AddrEqOp = Just (mo_wordEq dflags) +translateOp dflags AddrNeOp = Just (mo_wordNe dflags) + +translateOp dflags AndOp = Just (mo_wordAnd dflags) +translateOp dflags OrOp = Just (mo_wordOr dflags) +translateOp dflags XorOp = Just (mo_wordXor dflags) +translateOp dflags NotOp = Just (mo_wordNot dflags) +translateOp dflags SllOp = Just (mo_wordShl dflags) +translateOp dflags SrlOp = Just (mo_wordUShr dflags) + +translateOp dflags AddrRemOp = Just (mo_wordURem dflags) -- Native word signed ops -translateOp IntMulOp = Just mo_wordMul -translateOp IntMulMayOfloOp = Just (MO_S_MulMayOflo wordWidth) -translateOp IntQuotOp = Just mo_wordSQuot -translateOp IntRemOp = Just mo_wordSRem -translateOp IntNegOp = Just mo_wordSNeg +translateOp dflags IntMulOp = Just (mo_wordMul dflags) +translateOp dflags IntMulMayOfloOp = Just (MO_S_MulMayOflo (wordWidth dflags)) +translateOp dflags IntQuotOp = Just (mo_wordSQuot dflags) +translateOp dflags IntRemOp = Just (mo_wordSRem dflags) +translateOp dflags IntNegOp = Just (mo_wordSNeg dflags) -translateOp IntGeOp = Just mo_wordSGe -translateOp IntLeOp = Just mo_wordSLe -translateOp IntGtOp = Just mo_wordSGt -translateOp IntLtOp = Just mo_wordSLt +translateOp dflags IntGeOp = Just (mo_wordSGe dflags) +translateOp dflags IntLeOp = Just (mo_wordSLe dflags) +translateOp dflags IntGtOp = Just (mo_wordSGt dflags) +translateOp dflags IntLtOp = Just (mo_wordSLt dflags) -translateOp ISllOp = Just mo_wordShl -translateOp ISraOp = Just mo_wordSShr -translateOp ISrlOp = Just mo_wordUShr +translateOp dflags ISllOp = Just (mo_wordShl dflags) +translateOp dflags ISraOp = Just (mo_wordSShr dflags) +translateOp dflags ISrlOp = Just (mo_wordUShr dflags) -- Native word unsigned ops -translateOp WordGeOp = Just mo_wordUGe -translateOp WordLeOp = Just mo_wordULe -translateOp WordGtOp = Just mo_wordUGt -translateOp WordLtOp = Just mo_wordULt +translateOp dflags WordGeOp = Just (mo_wordUGe dflags) +translateOp dflags WordLeOp = Just (mo_wordULe dflags) +translateOp dflags WordGtOp = Just (mo_wordUGt dflags) +translateOp dflags WordLtOp = Just (mo_wordULt dflags) -translateOp WordMulOp = Just mo_wordMul -translateOp WordQuotOp = Just mo_wordUQuot -translateOp WordRemOp = Just mo_wordURem +translateOp dflags WordMulOp = Just (mo_wordMul dflags) +translateOp dflags WordQuotOp = Just (mo_wordUQuot dflags) +translateOp dflags WordRemOp = Just (mo_wordURem dflags) -translateOp AddrGeOp = Just mo_wordUGe -translateOp AddrLeOp = Just mo_wordULe -translateOp AddrGtOp = Just mo_wordUGt -translateOp AddrLtOp = Just mo_wordULt +translateOp dflags AddrGeOp = Just (mo_wordUGe dflags) +translateOp dflags AddrLeOp = Just (mo_wordULe dflags) +translateOp dflags AddrGtOp = Just (mo_wordUGt dflags) +translateOp dflags AddrLtOp = Just (mo_wordULt dflags) -- Char# ops -translateOp CharEqOp = Just (MO_Eq wordWidth) -translateOp CharNeOp = Just (MO_Ne wordWidth) -translateOp CharGeOp = Just (MO_U_Ge wordWidth) -translateOp CharLeOp = Just (MO_U_Le wordWidth) -translateOp CharGtOp = Just (MO_U_Gt wordWidth) -translateOp CharLtOp = Just (MO_U_Lt wordWidth) +translateOp dflags CharEqOp = Just (MO_Eq (wordWidth dflags)) +translateOp dflags CharNeOp = Just (MO_Ne (wordWidth dflags)) +translateOp dflags CharGeOp = Just (MO_U_Ge (wordWidth dflags)) +translateOp dflags CharLeOp = Just (MO_U_Le (wordWidth dflags)) +translateOp dflags CharGtOp = Just (MO_U_Gt (wordWidth dflags)) +translateOp dflags CharLtOp = Just (MO_U_Lt (wordWidth dflags)) -- Double ops -translateOp DoubleEqOp = Just (MO_F_Eq W64) -translateOp DoubleNeOp = Just (MO_F_Ne W64) -translateOp DoubleGeOp = Just (MO_F_Ge W64) -translateOp DoubleLeOp = Just (MO_F_Le W64) -translateOp DoubleGtOp = Just (MO_F_Gt W64) -translateOp DoubleLtOp = Just (MO_F_Lt W64) +translateOp _ DoubleEqOp = Just (MO_F_Eq W64) +translateOp _ DoubleNeOp = Just (MO_F_Ne W64) +translateOp _ DoubleGeOp = Just (MO_F_Ge W64) +translateOp _ DoubleLeOp = Just (MO_F_Le W64) +translateOp _ DoubleGtOp = Just (MO_F_Gt W64) +translateOp _ DoubleLtOp = Just (MO_F_Lt W64) -translateOp DoubleAddOp = Just (MO_F_Add W64) -translateOp DoubleSubOp = Just (MO_F_Sub W64) -translateOp DoubleMulOp = Just (MO_F_Mul W64) -translateOp DoubleDivOp = Just (MO_F_Quot W64) -translateOp DoubleNegOp = Just (MO_F_Neg W64) +translateOp _ DoubleAddOp = Just (MO_F_Add W64) +translateOp _ DoubleSubOp = Just (MO_F_Sub W64) +translateOp _ DoubleMulOp = Just (MO_F_Mul W64) +translateOp _ DoubleDivOp = Just (MO_F_Quot W64) +translateOp _ DoubleNegOp = Just (MO_F_Neg W64) -- Float ops -translateOp FloatEqOp = Just (MO_F_Eq W32) -translateOp FloatNeOp = Just (MO_F_Ne W32) -translateOp FloatGeOp = Just (MO_F_Ge W32) -translateOp FloatLeOp = Just (MO_F_Le W32) -translateOp FloatGtOp = Just (MO_F_Gt W32) -translateOp FloatLtOp = Just (MO_F_Lt W32) +translateOp _ FloatEqOp = Just (MO_F_Eq W32) +translateOp _ FloatNeOp = Just (MO_F_Ne W32) +translateOp _ FloatGeOp = Just (MO_F_Ge W32) +translateOp _ FloatLeOp = Just (MO_F_Le W32) +translateOp _ FloatGtOp = Just (MO_F_Gt W32) +translateOp _ FloatLtOp = Just (MO_F_Lt W32) -translateOp FloatAddOp = Just (MO_F_Add W32) -translateOp FloatSubOp = Just (MO_F_Sub W32) -translateOp FloatMulOp = Just (MO_F_Mul W32) -translateOp FloatDivOp = Just (MO_F_Quot W32) -translateOp FloatNegOp = Just (MO_F_Neg W32) +translateOp _ FloatAddOp = Just (MO_F_Add W32) +translateOp _ FloatSubOp = Just (MO_F_Sub W32) +translateOp _ FloatMulOp = Just (MO_F_Mul W32) +translateOp _ FloatDivOp = Just (MO_F_Quot W32) +translateOp _ FloatNegOp = Just (MO_F_Neg W32) -- Conversions -translateOp Int2DoubleOp = Just (MO_SF_Conv wordWidth W64) -translateOp Double2IntOp = Just (MO_FS_Conv W64 wordWidth) +translateOp dflags Int2DoubleOp = Just (MO_SF_Conv (wordWidth dflags) W64) +translateOp dflags Double2IntOp = Just (MO_FS_Conv W64 (wordWidth dflags)) -translateOp Int2FloatOp = Just (MO_SF_Conv wordWidth W32) -translateOp Float2IntOp = Just (MO_FS_Conv W32 wordWidth) +translateOp dflags Int2FloatOp = Just (MO_SF_Conv (wordWidth dflags) W32) +translateOp dflags Float2IntOp = Just (MO_FS_Conv W32 (wordWidth dflags)) -translateOp Float2DoubleOp = Just (MO_FF_Conv W32 W64) -translateOp Double2FloatOp = Just (MO_FF_Conv W64 W32) +translateOp _ Float2DoubleOp = Just (MO_FF_Conv W32 W64) +translateOp _ Double2FloatOp = Just (MO_FF_Conv W64 W32) -- Word comparisons masquerading as more exotic things. -translateOp SameMutVarOp = Just mo_wordEq -translateOp SameMVarOp = Just mo_wordEq -translateOp SameMutableArrayOp = Just mo_wordEq -translateOp SameMutableByteArrayOp = Just mo_wordEq -translateOp SameMutableArrayArrayOp= Just mo_wordEq -translateOp SameTVarOp = Just mo_wordEq -translateOp EqStablePtrOp = Just mo_wordEq +translateOp dflags SameMutVarOp = Just (mo_wordEq dflags) +translateOp dflags SameMVarOp = Just (mo_wordEq dflags) +translateOp dflags SameMutableArrayOp = Just (mo_wordEq dflags) +translateOp dflags SameMutableByteArrayOp = Just (mo_wordEq dflags) +translateOp dflags SameMutableArrayArrayOp= Just (mo_wordEq dflags) +translateOp dflags SameTVarOp = Just (mo_wordEq dflags) +translateOp dflags EqStablePtrOp = Just (mo_wordEq dflags) -translateOp _ = Nothing +translateOp _ _ = Nothing -- These primops are implemented by CallishMachOps, because they sometimes -- turn into foreign calls depending on the backend. @@ -825,7 +818,7 @@ doIndexByteArrayOp _ _ _ _ doReadPtrArrayOp :: LocalReg -> CmmExpr -> CmmExpr -> Code doReadPtrArrayOp res addr idx = do dflags <- getDynFlags - mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing gcWord res addr idx + mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr idx doWriteOffAddrOp, doWriteByteArrayOp @@ -845,46 +838,50 @@ doWriteByteArrayOp _ _ _ _ doWritePtrArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> Code doWritePtrArrayOp addr idx val = do dflags <- getDynFlags - mkBasicIndexedWrite (arrPtrsHdrSize dflags) Nothing bWord addr idx val + mkBasicIndexedWrite (arrPtrsHdrSize dflags) Nothing (bWord dflags) addr idx val stmtC (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) -- the write barrier. We must write a byte into the mark table: -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N] stmtC $ CmmStore ( - cmmOffsetExpr - (cmmOffsetExprW (cmmOffsetB addr (arrPtrsHdrSize dflags)) + cmmOffsetExpr dflags + (cmmOffsetExprW dflags (cmmOffsetB dflags addr (arrPtrsHdrSize dflags)) (loadArrPtrsSize dflags addr)) - (card idx) + (card dflags idx) ) (CmmLit (CmmInt 1 W8)) loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr -loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB addr off) bWord - where off = fixedHdrSize dflags * wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs +loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags) + where off = fixedHdrSize dflags * wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs dflags mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType -> LocalReg -> CmmExpr -> CmmExpr -> Code mkBasicIndexedRead off Nothing read_rep res base idx - = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexOffExpr off read_rep base idx)) + = do dflags <- getDynFlags + stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexOffExpr dflags off read_rep base idx)) mkBasicIndexedRead off (Just cast) read_rep res base idx - = stmtC (CmmAssign (CmmLocal res) (CmmMachOp cast [ - cmmLoadIndexOffExpr off read_rep base idx])) + = do dflags <- getDynFlags + stmtC (CmmAssign (CmmLocal res) (CmmMachOp cast [ + cmmLoadIndexOffExpr dflags off read_rep base idx])) mkBasicIndexedWrite :: ByteOff -> Maybe MachOp -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr -> Code mkBasicIndexedWrite off Nothing write_rep base idx val - = stmtC (CmmStore (cmmIndexOffExpr off write_rep base idx) val) + = do dflags <- getDynFlags + stmtC (CmmStore (cmmIndexOffExpr dflags off write_rep base idx) val) mkBasicIndexedWrite off (Just cast) write_rep base idx val - = stmtC (CmmStore (cmmIndexOffExpr off write_rep base idx) (CmmMachOp cast [val])) + = do dflags <- getDynFlags + stmtC (CmmStore (cmmIndexOffExpr dflags off write_rep base idx) (CmmMachOp cast [val])) -- ---------------------------------------------------------------------------- -- Misc utils -cmmIndexOffExpr :: ByteOff -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr -cmmIndexOffExpr off rep base idx - = cmmIndexExpr (typeWidth rep) (cmmOffsetB base off) idx +cmmIndexOffExpr :: DynFlags -> ByteOff -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr +cmmIndexOffExpr dflags off rep base idx + = cmmIndexExpr dflags (typeWidth rep) (cmmOffsetB dflags base off) idx -cmmLoadIndexOffExpr :: ByteOff -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr -cmmLoadIndexOffExpr off rep base idx - = CmmLoad (cmmIndexOffExpr off rep base idx) rep +cmmLoadIndexOffExpr :: DynFlags -> ByteOff -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr +cmmLoadIndexOffExpr dflags off rep base idx + = CmmLoad (cmmIndexOffExpr dflags off rep base idx) rep setInfo :: CmmExpr -> CmmExpr -> CmmStmt setInfo closure_ptr info_ptr = CmmStore closure_ptr info_ptr @@ -903,7 +900,8 @@ doCopyByteArrayOp = emitCopyByteArray copy -- Copy data (we assume the arrays aren't overlapping since -- they're of different types) copy _src _dst dst_p src_p bytes live = - emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit 1)) live + do dflags <- getDynFlags + emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags 1)) live -- | Takes a source 'MutableByteArray#', an offset in the source -- array, a destination 'MutableByteArray#', an offset into the @@ -918,9 +916,10 @@ doCopyMutableByteArrayOp = emitCopyByteArray copy -- we were provided are the same array! -- TODO: Optimize branch for common case of no aliasing. copy src dst dst_p src_p bytes live = - emitIfThenElse (cmmEqWord src dst) - (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit 1)) live) - (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit 1)) live) + do dflags <- getDynFlags + emitIfThenElse (cmmEqWord dflags src dst) + (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit dflags 1)) live) + (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags 1)) live) emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code) @@ -929,8 +928,8 @@ emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> Code emitCopyByteArray copy src src_off dst dst_off n live = do dflags <- getDynFlags - dst_p <- assignTemp $ cmmOffsetExpr (cmmOffsetB dst (arrWordsHdrSize dflags)) dst_off - src_p <- assignTemp $ cmmOffsetExpr (cmmOffsetB src (arrWordsHdrSize dflags)) src_off + dst_p <- assignTemp $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off + src_p <- assignTemp $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off copy src dst dst_p src_p n live -- ---------------------------------------------------------------------------- @@ -943,8 +942,8 @@ doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code doSetByteArrayOp ba off len c live = do dflags <- getDynFlags - p <- assignTemp $ cmmOffsetExpr (cmmOffsetB ba (arrWordsHdrSize dflags)) off - emitMemsetCall p c len (CmmLit (mkIntCLit 1)) live + p <- assignTemp $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off + emitMemsetCall p c len (CmmLit (mkIntCLit dflags 1)) live -- ---------------------------------------------------------------------------- -- Copying pointer arrays @@ -967,7 +966,8 @@ doCopyArrayOp = emitCopyArray copy -- Copy data (we assume the arrays aren't overlapping since -- they're of different types) copy _src _dst dst_p src_p bytes live = - emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) live + do dflags <- getDynFlags + emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags wORD_SIZE)) live -- | Takes a source 'MutableArray#', an offset in the source array, a -- destination 'MutableArray#', an offset into the destination array, @@ -981,9 +981,10 @@ doCopyMutableArrayOp = emitCopyArray copy -- we were provided are the same array! -- TODO: Optimize branch for common case of no aliasing. copy src dst dst_p src_p bytes live = - emitIfThenElse (cmmEqWord src dst) - (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) live) - (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) live) + do dflags <- getDynFlags + emitIfThenElse (cmmEqWord dflags src dst) + (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit dflags wORD_SIZE)) live) + (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags wORD_SIZE)) live) emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code) @@ -1003,15 +1004,15 @@ emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 live = do -- Set the dirty bit in the header. stmtC (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) - dst_elems_p <- assignTemp $ cmmOffsetB dst (arrPtrsHdrSize dflags) - dst_p <- assignTemp $ cmmOffsetExprW dst_elems_p dst_off - src_p <- assignTemp $ cmmOffsetExprW (cmmOffsetB src (arrPtrsHdrSize dflags)) src_off - bytes <- assignTemp $ cmmMulWord n (CmmLit (mkIntCLit wORD_SIZE)) + dst_elems_p <- assignTemp $ cmmOffsetB dflags dst (arrPtrsHdrSize dflags) + dst_p <- assignTemp $ cmmOffsetExprW dflags dst_elems_p dst_off + src_p <- assignTemp $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off + bytes <- assignTemp $ cmmMulWord dflags n (CmmLit (mkIntCLit dflags wORD_SIZE)) copy src dst dst_p src_p bytes live -- The base address of the destination card table - dst_cards_p <- assignTemp $ cmmOffsetExprW dst_elems_p (loadArrPtrsSize dflags dst) + dst_cards_p <- assignTemp $ cmmOffsetExprW dflags dst_elems_p (loadArrPtrsSize dflags dst) emitSetCards dst_off dst_cards_p n live @@ -1023,73 +1024,75 @@ emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code emitCloneArray info_p res_r src0 src_off0 n0 live = do dflags <- getDynFlags + let arrPtrsHdrSizeW dflags = CmmLit $ mkIntCLit dflags $ fixedHdrSize dflags + + (sIZEOF_StgMutArrPtrs_NoHdr dflags `div` wORD_SIZE) + myCapability = cmmSubWord dflags (CmmReg baseReg) + (CmmLit (mkIntCLit dflags (oFFSET_Capability_r dflags))) -- Assign the arguments to temporaries so the code generator can -- calculate liveness for us. src <- assignTemp_ src0 src_off <- assignTemp_ src_off0 n <- assignTemp_ n0 - card_bytes <- assignTemp $ cardRoundUp n - size <- assignTemp $ n `cmmAddWord` bytesToWordsRoundUp card_bytes - words <- assignTemp $ arrPtrsHdrSizeW dflags `cmmAddWord` size + card_bytes <- assignTemp $ cardRoundUp dflags n + size <- assignTemp $ cmmAddWord dflags n (bytesToWordsRoundUp dflags card_bytes) + words <- assignTemp $ cmmAddWord dflags (arrPtrsHdrSizeW dflags) size - arr_r <- newTemp bWord + arr_r <- newTemp (bWord dflags) emitAllocateCall arr_r myCapability words live - tickyAllocPrim (CmmLit (mkIntCLit (arrPtrsHdrSize dflags))) (n `cmmMulWord` wordSize) - (CmmLit $ mkIntCLit 0) + tickyAllocPrim (CmmLit (mkIntCLit dflags (arrPtrsHdrSize dflags))) (cmmMulWord dflags n (wordSize dflags)) + (CmmLit $ mkIntCLit dflags 0) let arr = CmmReg (CmmLocal arr_r) emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCS - stmtC $ CmmStore (cmmOffsetB arr (fixedHdrSize dflags * wORD_SIZE + - oFFSET_StgMutArrPtrs_ptrs)) n - stmtC $ CmmStore (cmmOffsetB arr (fixedHdrSize dflags * wORD_SIZE + - oFFSET_StgMutArrPtrs_size)) size + stmtC $ CmmStore (cmmOffsetB dflags arr (fixedHdrSize dflags * wORD_SIZE + + oFFSET_StgMutArrPtrs_ptrs dflags)) n + stmtC $ CmmStore (cmmOffsetB dflags arr (fixedHdrSize dflags * wORD_SIZE + + oFFSET_StgMutArrPtrs_size dflags)) size - dst_p <- assignTemp $ cmmOffsetB arr (arrPtrsHdrSize dflags) - src_p <- assignTemp $ cmmOffsetExprW (cmmOffsetB src (arrPtrsHdrSize dflags)) + dst_p <- assignTemp $ cmmOffsetB dflags arr (arrPtrsHdrSize dflags) + src_p <- assignTemp $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off - emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize) - (CmmLit (mkIntCLit wORD_SIZE)) live + emitMemcpyCall dst_p src_p (cmmMulWord dflags n (wordSize dflags)) + (CmmLit (mkIntCLit dflags wORD_SIZE)) live - emitMemsetCall (cmmOffsetExprW dst_p n) - (CmmLit (mkIntCLit 1)) + emitMemsetCall (cmmOffsetExprW dflags dst_p n) + (CmmLit (mkIntCLit dflags 1)) card_bytes - (CmmLit (mkIntCLit wORD_SIZE)) + (CmmLit (mkIntCLit dflags wORD_SIZE)) live stmtC $ CmmAssign (CmmLocal res_r) arr - where - arrPtrsHdrSizeW dflags = CmmLit $ mkIntCLit $ fixedHdrSize dflags + - (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE) - myCapability = CmmReg baseReg `cmmSubWord` - CmmLit (mkIntCLit oFFSET_Capability_r) -- | Takes and offset in the destination array, the base address of -- the card table, and the number of elements affected (*not* the -- number of cards). Marks the relevant cards as dirty. emitSetCards :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code emitSetCards dst_start dst_cards_start n live = do - start_card <- assignTemp $ card dst_start - emitMemsetCall (dst_cards_start `cmmAddWord` start_card) - (CmmLit (mkIntCLit 1)) - (cardRoundUp n) - (CmmLit (mkIntCLit 1)) -- no alignment (1 byte) + dflags <- getDynFlags + start_card <- assignTemp $ card dflags dst_start + emitMemsetCall (cmmAddWord dflags dst_cards_start start_card) + (CmmLit (mkIntCLit dflags 1)) + (cardRoundUp dflags n) + (CmmLit (mkIntCLit dflags 1)) -- no alignment (1 byte) live -- Convert an element index to a card index -card :: CmmExpr -> CmmExpr -card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)) +card :: DynFlags -> CmmExpr -> CmmExpr +card dflags i = cmmUShrWord dflags i (CmmLit (mkIntCLit dflags (mUT_ARR_PTRS_CARD_BITS dflags))) -- Convert a number of elements to a number of cards, rounding up -cardRoundUp :: CmmExpr -> CmmExpr -cardRoundUp i = card (i `cmmAddWord` (CmmLit (mkIntCLit ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS) - 1)))) +cardRoundUp :: DynFlags -> CmmExpr -> CmmExpr +cardRoundUp dflags i = card dflags (cmmAddWord dflags i (CmmLit (mkIntCLit dflags ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS dflags) - 1)))) -bytesToWordsRoundUp :: CmmExpr -> CmmExpr -bytesToWordsRoundUp e = (e `cmmAddWord` CmmLit (mkIntCLit (wORD_SIZE - 1))) - `cmmQuotWord` wordSize +bytesToWordsRoundUp :: DynFlags -> CmmExpr -> CmmExpr +bytesToWordsRoundUp dflags e + = cmmQuotWord dflags + (cmmAddWord dflags e (CmmLit (mkIntCLit dflags (wORD_SIZE - 1)))) + (wordSize dflags) -wordSize :: CmmExpr -wordSize = CmmLit (mkIntCLit wORD_SIZE) +wordSize :: DynFlags -> CmmExpr +wordSize dflags = CmmLit (mkIntCLit dflags wORD_SIZE) -- | Emit a call to @memcpy@. emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs index c5f1afa68e..19376b95ca 100644 --- a/compiler/codeGen/CgProf.hs +++ b/compiler/codeGen/CgProf.hs @@ -6,37 +6,30 @@ -- ----------------------------------------------------------------------------- -{-# 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 CgProf ( - mkCCostCentre, mkCCostCentreStack, + mkCCostCentre, mkCCostCentreStack, - -- Cost-centre Profiling + -- Cost-centre Profiling dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf, enterCostCentreThunk, enterCostCentreFun, costCentreFrom, curCCS, storeCurCCS, - emitCostCentreDecl, emitCostCentreStackDecl, + emitCostCentreDecl, emitCostCentreStackDecl, emitSetCCC, - -- Lag/drag/void stuff - ldvEnter, ldvEnterClosure, ldvRecordCreate + -- Lag/drag/void stuff + ldvEnter, ldvEnterClosure, ldvRecordCreate ) where #include "HsVersions.h" #include "../includes/MachDeps.h" -- For WORD_SIZE_IN_BITS only. #include "../includes/rts/Constants.h" - -- For LDV_CREATE_MASK, LDV_STATE_USE - -- which are StgWords + -- For LDV_CREATE_MASK, LDV_STATE_USE + -- which are StgWords #include "../includes/dist-derivedconstants/header/DerivedConstants.h" - -- For REP_xxx constants, which are MachReps + -- For REP_xxx constants, which are MachReps import ClosureInfo import CgUtils @@ -52,7 +45,7 @@ import CostCentre import DynFlags import FastString import Module -import Constants -- Lots of field offsets +import Constants -- Lots of field offsets import Outputable import Data.Char @@ -77,27 +70,30 @@ mkCCostCentre cc = CmmLabel (mkCCLabel cc) mkCCostCentreStack :: CostCentreStack -> CmmLit mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs) -costCentreFrom :: CmmExpr -- A closure pointer - -> CmmExpr -- The cost centre from that closure -costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) bWord +costCentreFrom :: DynFlags + -> CmmExpr -- A closure pointer + -> CmmExpr -- The cost centre from that closure +costCentreFrom dflags cl + = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (bWord dflags) staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit] -- The profiling header words in a static closure -- Was SET_STATIC_PROF_HDR staticProfHdr dflags ccs = ifProfilingL dflags [mkCCostCentreStack ccs, - staticLdvInit] + staticLdvInit dflags] dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr] -- Profiling header words in a dynamic closure -dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit] +dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags] initUpdFrameProf :: CmmExpr -> Code -- Initialise the profiling field of an update frame -initUpdFrameProf frame_amode - = ifProfiling $ -- frame->header.prof.ccs = CCCS - stmtC (CmmStore (cmmOffsetB frame_amode oFFSET_StgHeader_ccs) curCCS) - -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) - -- is unnecessary because it is not used anyhow. +initUpdFrameProf frame_amode + = ifProfiling $ -- frame->header.prof.ccs = CCCS + do dflags <- getDynFlags + stmtC (CmmStore (cmmOffsetB dflags frame_amode (oFFSET_StgHeader_ccs dflags)) curCCS) + -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) + -- is unnecessary because it is not used anyhow. -- ----------------------------------------------------------------------------- -- Recording allocation in a cost centre @@ -108,7 +104,7 @@ profDynAlloc :: ClosureInfo -> CmmExpr -> Code profDynAlloc cl_info ccs = ifProfiling $ do dflags <- getDynFlags - profAlloc (mkIntExpr (closureSize dflags cl_info)) ccs + profAlloc (mkIntExpr dflags (closureSize dflags cl_info)) ccs -- | Record the allocation of a closure (size is given by a CmmExpr) -- The size must be in words, because the allocation counter in a CCS counts @@ -121,30 +117,32 @@ profAlloc words ccs = ifProfiling $ do dflags <- getDynFlags stmtC (addToMemE alloc_rep - (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc) - (CmmMachOp (MO_UU_Conv wordWidth alloc_rep) $ - [CmmMachOp mo_wordSub [words, - mkIntExpr (profHdrSize dflags)]])) + (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags)) + (CmmMachOp (MO_UU_Conv (wordWidth dflags) alloc_rep) $ + [CmmMachOp (mo_wordSub dflags) [words, + mkIntExpr dflags (profHdrSize dflags)]])) -- subtract the "profiling overhead", which is the -- profiling header in a closure. - where + where alloc_rep = typeWidth REP_CostCentreStack_mem_alloc -- ----------------------------------------------------------------------- -- Setting the current cost centre on entry to a closure enterCostCentreThunk :: CmmExpr -> Code -enterCostCentreThunk closure = - ifProfiling $ do - stmtC $ storeCurCCS (costCentreFrom closure) +enterCostCentreThunk closure = + ifProfiling $ do + dflags <- getDynFlags + stmtC $ storeCurCCS (costCentreFrom dflags closure) enterCostCentreFun :: CostCentreStack -> CmmExpr -> [GlobalReg] -> Code enterCostCentreFun ccs closure vols = ifProfiling $ do if isCurrentCCS ccs - then emitRtsCallWithVols rtsPackageId (fsLit "enterFunCCS") - [CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint, - CmmHinted (costCentreFrom closure) AddrHint] vols + then do dflags <- getDynFlags + emitRtsCallWithVols rtsPackageId (fsLit "enterFunCCS") + [CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint, + CmmHinted (costCentreFrom dflags closure) AddrHint] vols else return () -- top-level function, nothing to do ifProfiling :: Code -> Code @@ -163,7 +161,7 @@ ifProfilingL dflags xs emitCostCentreDecl :: CostCentre -> Code -emitCostCentreDecl cc = do +emitCostCentreDecl cc = do -- NB. bytesFS: we want the UTF-8 bytes here (#5559) { label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc) ; modl <- newByteStringCLit (bytesFS $ Module.moduleNameFS @@ -177,46 +175,46 @@ emitCostCentreDecl cc = do showPpr dflags (costCentreSrcSpan cc) -- XXX going via FastString to get UTF-8 encoding is silly ; let - lits = [ zero, -- StgInt ccID, - label, -- char *label, - modl, -- char *module, + is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF + | otherwise = zero dflags + lits = [ zero dflags, -- StgInt ccID, + label, -- char *label, + modl, -- char *module, loc, -- char *srcloc, zero64, -- StgWord64 mem_alloc - zero, -- StgWord time_ticks + zero dflags, -- StgWord time_ticks is_caf, -- StgInt is_caf - zero -- struct _CostCentre *link - ] + zero dflags -- struct _CostCentre *link + ] ; emitDataLits (mkCCLabel cc) lits } - where - is_caf | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF - | otherwise = zero emitCostCentreStackDecl :: CostCentreStack -> Code -emitCostCentreStackDecl ccs +emitCostCentreStackDecl ccs | Just cc <- maybeSingletonCCS ccs = do - { let - -- Note: to avoid making any assumptions about how the - -- C compiler (that compiles the RTS, in particular) does - -- layouts of structs containing long-longs, simply - -- pad out the struct with zero words until we hit the - -- size of the overall struct (which we get via DerivedConstants.h) - -- - lits = zero : mkCCostCentre cc : replicate (sizeof_ccs_words - 2) zero + { dflags <- getDynFlags + ; let + -- Note: to avoid making any assumptions about how the + -- C compiler (that compiles the RTS, in particular) does + -- layouts of structs containing long-longs, simply + -- pad out the struct with zero words until we hit the + -- size of the overall struct (which we get via DerivedConstants.h) + -- + lits = zero dflags : mkCCostCentre cc : replicate (sizeof_ccs_words - 2) (zero dflags) ; emitDataLits (mkCCSLabel ccs) lits } | otherwise = pprPanic "emitCostCentreStackDecl" (ppr ccs) -zero :: CmmLit -zero = mkIntCLit 0 +zero :: DynFlags -> CmmLit +zero dflags = mkIntCLit dflags 0 zero64 :: CmmLit zero64 = CmmInt 0 W64 sizeof_ccs_words :: Int -sizeof_ccs_words +sizeof_ccs_words -- round up to the next word. | ms == 0 = ws | otherwise = ws + 1 @@ -230,51 +228,52 @@ emitSetCCC :: CostCentre -> Bool -> Bool -> Code emitSetCCC cc tick push = do dflags <- getDynFlags if dopt Opt_SccProfilingOn dflags - then do tmp <- newTemp bWord -- TODO FIXME NOW + then do tmp <- newTemp (bWord dflags) -- TODO FIXME NOW pushCostCentre tmp curCCS cc - when tick $ stmtC (bumpSccCount (CmmReg (CmmLocal tmp))) + when tick $ stmtC (bumpSccCount dflags (CmmReg (CmmLocal tmp))) when push $ stmtC (storeCurCCS (CmmReg (CmmLocal tmp))) else nopC pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> Code pushCostCentre result ccs cc = emitRtsCallWithResult result AddrHint - rtsPackageId + rtsPackageId (fsLit "pushCostCentre") [CmmHinted ccs AddrHint, CmmHinted (CmmLit (mkCCostCentre cc)) AddrHint] -bumpSccCount :: CmmExpr -> CmmStmt -bumpSccCount ccs +bumpSccCount :: DynFlags -> CmmExpr -> CmmStmt +bumpSccCount dflags ccs = addToMem (typeWidth REP_CostCentreStack_scc_count) - (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1 + (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1 ----------------------------------------------------------------------------- -- --- Lag/drag/void stuff +-- Lag/drag/void stuff -- ----------------------------------------------------------------------------- -- -- Initial value for the LDV field in a static closure -- -staticLdvInit :: CmmLit +staticLdvInit :: DynFlags -> CmmLit staticLdvInit = zeroCLit -- -- Initial value of the LDV field in a dynamic closure -- -dynLdvInit :: CmmExpr -dynLdvInit = -- (era << LDV_SHIFT) | LDV_STATE_CREATE - CmmMachOp mo_wordOr [ - CmmMachOp mo_wordShl [loadEra, mkIntExpr lDV_SHIFT ], - CmmLit (mkWordCLit lDV_STATE_CREATE) +dynLdvInit :: DynFlags -> CmmExpr +dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE + CmmMachOp (mo_wordOr dflags) [ + CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags lDV_SHIFT ], + CmmLit (mkWordCLit dflags lDV_STATE_CREATE) ] - + -- -- Initialise the LDV word of a new closure -- ldvRecordCreate :: CmmExpr -> Code -ldvRecordCreate closure = stmtC $ CmmStore (ldvWord closure) dynLdvInit +ldvRecordCreate closure = do dflags <- getDynFlags + stmtC $ CmmStore (ldvWord dflags closure) (dynLdvInit dflags) -- -- Called when a closure is entered, marks the closure as having been "used". @@ -283,34 +282,38 @@ ldvRecordCreate closure = stmtC $ CmmStore (ldvWord closure) dynLdvInit -- profiling. -- ldvEnterClosure :: ClosureInfo -> Code -ldvEnterClosure closure_info = ldvEnter (cmmOffsetB (CmmReg nodeReg) (-tag)) +ldvEnterClosure closure_info + = do dflags <- getDynFlags + ldvEnter (cmmOffsetB dflags (CmmReg nodeReg) (-tag)) where tag = funTag closure_info -- don't forget to substract node's tag - + ldvEnter :: CmmExpr -> Code -- Argument is a closure pointer -ldvEnter cl_ptr - = ifProfiling $ +ldvEnter cl_ptr = do + dflags <- getDynFlags + let + -- don't forget to substract node's tag + ldv_wd = ldvWord dflags cl_ptr + new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags)) + (CmmLit (mkWordCLit dflags lDV_CREATE_MASK))) + (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags lDV_STATE_USE))) + ifProfiling $ -- if (era > 0) { -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) | -- era | LDV_STATE_USE } - emitIf (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit]) - (stmtC (CmmStore ldv_wd new_ldv_wd)) - where - -- don't forget to substract node's tag - ldv_wd = ldvWord cl_ptr - new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd bWord) - (CmmLit (mkWordCLit lDV_CREATE_MASK))) - (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE))) + emitIf (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)]) + (stmtC (CmmStore ldv_wd new_ldv_wd)) -loadEra :: CmmExpr -loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth) - [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId $ fsLit("era"))) cInt] +loadEra :: DynFlags -> CmmExpr +loadEra dflags = CmmMachOp (MO_UU_Conv cIntWidth (wordWidth dflags)) + [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId $ fsLit("era"))) cInt] -ldvWord :: CmmExpr -> CmmExpr --- Takes the address of a closure, and returns +ldvWord :: DynFlags -> CmmExpr -> CmmExpr +-- Takes the address of a closure, and returns -- the address of the LDV word in the closure -ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw +ldvWord dflags closure_ptr + = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags) -- LDV constants, from ghc/includes/Constants.h lDV_SHIFT :: Int diff --git a/compiler/codeGen/CgStackery.lhs b/compiler/codeGen/CgStackery.lhs index 217586a9d1..7c4caf4e1d 100644 --- a/compiler/codeGen/CgStackery.lhs +++ b/compiler/codeGen/CgStackery.lhs @@ -289,7 +289,7 @@ pushSpecUpdateFrame lbl updatee code ; MASSERT(case sequel of { OnStack -> True; _ -> False}) } ; dflags <- getDynFlags ; allocStackTop (fixedHdrSize dflags + - sIZEOF_StgUpdateFrame_NoHdr `quot` wORD_SIZE) + sIZEOF_StgUpdateFrame_NoHdr dflags `quot` wORD_SIZE) ; vsp <- getVirtSp ; setStackFrame vsp ; frame_addr <- getSpRelOffset vsp @@ -317,12 +317,12 @@ emitSpecPushUpdateFrame lbl frame_addr updatee = do stmtsC [ -- Set the info word CmmStore frame_addr (mkLblExpr lbl) , -- And the updatee - CmmStore (cmmOffsetB frame_addr (off_updatee dflags)) updatee ] + CmmStore (cmmOffsetB dflags frame_addr (off_updatee dflags)) updatee ] initUpdFrameProf frame_addr off_updatee :: DynFlags -> ByteOff off_updatee dflags - = fixedHdrSize dflags * wORD_SIZE + oFFSET_StgUpdateFrame_updatee + = fixedHdrSize dflags * wORD_SIZE + (oFFSET_StgUpdateFrame_updatee dflags) \end{code} diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs index 6db1b46d77..3e64e6007d 100644 --- a/compiler/codeGen/CgTailCall.lhs +++ b/compiler/codeGen/CgTailCall.lhs @@ -127,7 +127,7 @@ performTailCall fun_info arg_amodes pending_assts -- Node must always point to things we enter EnterIt -> do { emitSimultaneously (node_asst `plusStmts` pending_assts) - ; let target = entryCode dflags (closureInfoPtr (CmmReg nodeReg)) + ; let target = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg)) enterClosure = stmtC (CmmJump target node_live) -- If this is a scrutinee -- let's check if the closure is a constructor @@ -193,7 +193,7 @@ performTailCall fun_info arg_amodes pending_assts fun_name = idName fun_id lf_info = cgIdInfoLF fun_info fun_has_cafs = idCafInfo fun_id - untag_node = CmmAssign nodeReg (cmmUntag (CmmReg nodeReg)) + untag_node dflags = CmmAssign nodeReg (cmmUntag dflags (CmmReg nodeReg)) -- Test if closure is a constructor maybeSwitchOnCons dflags enterClosure eob | EndOfBlockInfo _ (CaseAlts lbl _ _) <- eob, @@ -203,7 +203,7 @@ performTailCall fun_info arg_amodes pending_assts = do { is_constr <- newLabelC -- Is the pointer tagged? -- Yes, jump to switch statement - ; stmtC (CmmCondBranch (cmmIsTagged (CmmReg nodeReg)) + ; stmtC (CmmCondBranch (cmmIsTagged dflags (CmmReg nodeReg)) is_constr) -- No, enter the closure. ; enterClosure @@ -232,7 +232,7 @@ performTailCall fun_info arg_amodes pending_assts -} -- No case expression involved, enter the closure. | otherwise - = do { stmtC untag_node + = do { stmtC $ untag_node dflags ; enterClosure } where @@ -413,11 +413,12 @@ tailCallPrimCall primcall tailCallPrim :: CLabel -> [StgArg] -> Code tailCallPrim lbl args - = do { -- We're going to perform a normal-looking tail call, + = do { dflags <- getDynFlags + -- We're going to perform a normal-looking tail call, -- except that *all* the arguments will be in registers. -- Hence the ASSERT( null leftovers ) - arg_amodes <- getArgAmodes args - ; let (arg_regs, leftovers) = assignPrimOpCallRegs arg_amodes + ; arg_amodes <- getArgAmodes args + ; let (arg_regs, leftovers) = assignPrimOpCallRegs dflags arg_amodes live_regs = Just $ map snd arg_regs jump_to_primop = jumpToLbl lbl live_regs diff --git a/compiler/codeGen/CgTicky.hs b/compiler/codeGen/CgTicky.hs index bc3e26fb47..9e981755be 100644 --- a/compiler/codeGen/CgTicky.hs +++ b/compiler/codeGen/CgTicky.hs @@ -59,7 +59,6 @@ import Id import IdInfo import BasicTypes import FastString -import Constants import Outputable import Module @@ -98,14 +97,14 @@ emitTickyCounter cl_info args on_stk -- krc: note that all the fields are I32 now; some were I16 before, -- but the code generator wasn't handling that properly and it led to chaos, -- panic and disorder. - [ mkIntCLit 0, - mkIntCLit (length args),-- Arity - mkIntCLit on_stk, -- Words passed on stack + [ mkIntCLit dflags 0, + mkIntCLit dflags (length args),-- Arity + mkIntCLit dflags on_stk, -- Words passed on stack fun_descr_lit, arg_descr_lit, - zeroCLit, -- Entry count - zeroCLit, -- Allocs - zeroCLit -- Link + zeroCLit dflags, -- Entry count + zeroCLit dflags, -- Allocs + zeroCLit dflags -- Link ] } where name = closureName cl_info @@ -161,10 +160,11 @@ tickyUpdateBhCaf cl_info tickyEnterFun :: ClosureInfo -> Code tickyEnterFun cl_info = ifTicky $ - do { bumpTickyCounter ctr + do { dflags <- getDynFlags + ; bumpTickyCounter ctr ; fun_ctr_lbl <- getTickyCtrLabel ; registerTickyCtr fun_ctr_lbl - ; bumpTickyCounter' (cmmLabelOffB fun_ctr_lbl oFFSET_StgEntCounter_entry_count) + ; bumpTickyCounter' (cmmLabelOffB fun_ctr_lbl (oFFSET_StgEntCounter_entry_count dflags)) } where ctr | isStaticClosure cl_info = fsLit "ENT_STATIC_FUN_DIRECT_ctr" @@ -177,21 +177,21 @@ registerTickyCtr :: CLabel -> Code -- ticky_entry_ctrs = & (f_ct); /* mark it as "registered" */ -- f_ct.registeredp = 1 } registerTickyCtr ctr_lbl - = emitIf test (stmtsC register_stmts) - where - -- krc: code generator doesn't handle Not, so we test for Eq 0 instead - test = CmmMachOp (MO_Eq wordWidth) - [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl - oFFSET_StgEntCounter_registeredp)) bWord, - CmmLit (mkIntCLit 0)] - register_stmts - = [ CmmStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_link)) - (CmmLoad ticky_entry_ctrs bWord) - , CmmStore ticky_entry_ctrs (mkLblExpr ctr_lbl) - , CmmStore (CmmLit (cmmLabelOffB ctr_lbl - oFFSET_StgEntCounter_registeredp)) - (CmmLit (mkIntCLit 1)) ] - ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs")) + = do dflags <- getDynFlags + let -- krc: code generator doesn't handle Not, so we test for Eq 0 instead + test = CmmMachOp (MO_Eq (wordWidth dflags)) + [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl + (oFFSET_StgEntCounter_registeredp dflags))) (bWord dflags), + CmmLit (mkIntCLit dflags 0)] + register_stmts + = [ CmmStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_link dflags))) + (CmmLoad ticky_entry_ctrs (bWord dflags)) + , CmmStore ticky_entry_ctrs (mkLblExpr ctr_lbl) + , CmmStore (CmmLit (cmmLabelOffB ctr_lbl + (oFFSET_StgEntCounter_registeredp dflags))) + (CmmLit (mkIntCLit dflags 1)) ] + ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs")) + emitIf test (stmtsC register_stmts) tickyReturnOldCon, tickyReturnNewCon :: Arity -> Code tickyReturnOldCon arity @@ -292,14 +292,15 @@ tickyAllocHeap :: VirtualHpOffset -> Code -- Called when doing a heap check [TICK_ALLOC_HEAP] tickyAllocHeap hp = ifTicky $ - do { ticky_ctr <- getTickyCtrLabel + do { dflags <- getDynFlags + ; ticky_ctr <- getTickyCtrLabel ; stmtsC $ if hp == 0 then [] -- Inside the stmtC to avoid control else [ -- dependency on the argument -- Bump the allcoation count in the StgEntCounter addToMem (typeWidth REP_StgEntCounter_allocs) (CmmLit (cmmLabelOffB ticky_ctr - oFFSET_StgEntCounter_allocs)) hp, + (oFFSET_StgEntCounter_allocs dflags))) hp, -- Bump ALLOC_HEAP_ctr addToMemLbl cLongWidth (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_ctr") 1, -- Bump ALLOC_HEAP_tot diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 298143bd08..228c5bd2c6 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -69,7 +69,6 @@ import Util import DynFlags import FastString import Outputable -import Platform import Data.Char import Data.Word @@ -94,33 +93,34 @@ addIdReps ids = [(idCgRep id, id) | id <- ids] cgLit :: Literal -> FCode CmmLit cgLit (MachStr s) = newByteStringCLit (bytesFB s) -cgLit other_lit = return (mkSimpleLit other_lit) - -mkSimpleLit :: Literal -> CmmLit -mkSimpleLit (MachChar c) = CmmInt (fromIntegral (ord c)) wordWidth -mkSimpleLit MachNullAddr = zeroCLit -mkSimpleLit (MachInt i) = CmmInt i wordWidth -mkSimpleLit (MachInt64 i) = CmmInt i W64 -mkSimpleLit (MachWord i) = CmmInt i wordWidth -mkSimpleLit (MachWord64 i) = CmmInt i W64 -mkSimpleLit (MachFloat r) = CmmFloat r W32 -mkSimpleLit (MachDouble r) = CmmFloat r W64 -mkSimpleLit (MachLabel fs ms fod) +cgLit other_lit = do dflags <- getDynFlags + return (mkSimpleLit dflags other_lit) + +mkSimpleLit :: DynFlags -> Literal -> CmmLit +mkSimpleLit dflags (MachChar c) = CmmInt (fromIntegral (ord c)) (wordWidth dflags) +mkSimpleLit dflags MachNullAddr = zeroCLit dflags +mkSimpleLit dflags (MachInt i) = CmmInt i (wordWidth dflags) +mkSimpleLit _ (MachInt64 i) = CmmInt i W64 +mkSimpleLit dflags (MachWord i) = CmmInt i (wordWidth dflags) +mkSimpleLit _ (MachWord64 i) = CmmInt i W64 +mkSimpleLit _ (MachFloat r) = CmmFloat r W32 +mkSimpleLit _ (MachDouble r) = CmmFloat r W64 +mkSimpleLit _ (MachLabel fs ms fod) = CmmLabel (mkForeignLabel fs ms labelSrc fod) where -- TODO: Literal labels might not actually be in the current package... labelSrc = ForeignLabelInThisPackage -mkSimpleLit (MachStr _) = panic "mkSimpleLit: MachStr" +mkSimpleLit _ (MachStr _) = panic "mkSimpleLit: MachStr" -- No LitInteger's should be left by the time this is called. CorePrep -- should have converted them all to a real core representation. -mkSimpleLit (LitInteger {}) = panic "mkSimpleLit: LitInteger" +mkSimpleLit _ (LitInteger {}) = panic "mkSimpleLit: LitInteger" -mkLtOp :: Literal -> MachOp +mkLtOp :: DynFlags -> Literal -> MachOp -- On signed literals we must do a signed comparison -mkLtOp (MachInt _) = MO_S_Lt wordWidth -mkLtOp (MachFloat _) = MO_F_Lt W32 -mkLtOp (MachDouble _) = MO_F_Lt W64 -mkLtOp lit = MO_U_Lt (typeWidth (cmmLitType (mkSimpleLit lit))) +mkLtOp dflags (MachInt _) = MO_S_Lt (wordWidth dflags) +mkLtOp _ (MachFloat _) = MO_F_Lt W32 +mkLtOp _ (MachDouble _) = MO_F_Lt W64 +mkLtOp dflags lit = MO_U_Lt (typeWidth (cmmLitType dflags (mkSimpleLit dflags lit))) --------------------------------------------------- @@ -154,8 +154,8 @@ tagForCon con = tag | otherwise = 1 --Tag an expression, to do: refactor, this appears in some other module. -tagCons :: DataCon -> CmmExpr -> CmmExpr -tagCons con expr = cmmOffsetB expr (tagForCon con) +tagCons :: DynFlags -> DataCon -> CmmExpr -> CmmExpr +tagCons dflags con expr = cmmOffsetB dflags expr (tagForCon con) -------------------------------------------------------------------------- -- @@ -183,9 +183,9 @@ addToMemE width ptr n -- ------------------------------------------------------------------------- -tagToClosure :: TyCon -> CmmExpr -> CmmExpr -tagToClosure tycon tag - = CmmLoad (cmmOffsetExprW closure_tbl tag) gcWord +tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr +tagToClosure dflags tycon tag + = CmmLoad (cmmOffsetExprW dflags closure_tbl tag) (gcWord dflags) where closure_tbl = CmmLit (CmmLabel lbl) lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs @@ -299,23 +299,23 @@ callerSaveVolatileRegs dflags vols = (caller_save, caller_load) vol_list = case vols of Nothing -> all_of_em; Just regs -> regs - all_of_em = [ VanillaReg n VNonGcPtr | n <- [0..mAX_Vanilla_REG] ] + all_of_em = [ VanillaReg n VNonGcPtr | n <- [0 .. mAX_Vanilla_REG dflags] ] -- The VNonGcPtr is a lie, but I don't think it matters - ++ [ FloatReg n | n <- [0..mAX_Float_REG] ] - ++ [ DoubleReg n | n <- [0..mAX_Double_REG] ] - ++ [ LongReg n | n <- [0..mAX_Long_REG] ] + ++ [ FloatReg n | n <- [0 .. mAX_Float_REG dflags] ] + ++ [ DoubleReg n | n <- [0 .. mAX_Double_REG dflags] ] + ++ [ LongReg n | n <- [0 .. mAX_Long_REG dflags] ] callerSaveGlobalReg reg next | callerSaves platform reg = - CmmStore (get_GlobalReg_addr platform reg) + CmmStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg)) : next | otherwise = next callerRestoreGlobalReg reg next | callerSaves platform reg = CmmAssign (CmmGlobal reg) - (CmmLoad (get_GlobalReg_addr platform reg) - (globalRegType reg)) + (CmmLoad (get_GlobalReg_addr dflags reg) + (globalRegType dflags reg)) : next | otherwise = next @@ -323,42 +323,42 @@ callerSaveVolatileRegs dflags vols = (caller_save, caller_load) -- ----------------------------------------------------------------------------- -- Information about global registers -baseRegOffset :: GlobalReg -> Int - -baseRegOffset (VanillaReg 1 _) = oFFSET_StgRegTable_rR1 -baseRegOffset (VanillaReg 2 _) = oFFSET_StgRegTable_rR2 -baseRegOffset (VanillaReg 3 _) = oFFSET_StgRegTable_rR3 -baseRegOffset (VanillaReg 4 _) = oFFSET_StgRegTable_rR4 -baseRegOffset (VanillaReg 5 _) = oFFSET_StgRegTable_rR5 -baseRegOffset (VanillaReg 6 _) = oFFSET_StgRegTable_rR6 -baseRegOffset (VanillaReg 7 _) = oFFSET_StgRegTable_rR7 -baseRegOffset (VanillaReg 8 _) = oFFSET_StgRegTable_rR8 -baseRegOffset (VanillaReg 9 _) = oFFSET_StgRegTable_rR9 -baseRegOffset (VanillaReg 10 _) = oFFSET_StgRegTable_rR10 -baseRegOffset (VanillaReg n _) = panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")") -baseRegOffset (FloatReg 1) = oFFSET_StgRegTable_rF1 -baseRegOffset (FloatReg 2) = oFFSET_StgRegTable_rF2 -baseRegOffset (FloatReg 3) = oFFSET_StgRegTable_rF3 -baseRegOffset (FloatReg 4) = oFFSET_StgRegTable_rF4 -baseRegOffset (FloatReg n) = panic ("Registers above F4 are not supported (tried to use F" ++ show n ++ ")") -baseRegOffset (DoubleReg 1) = oFFSET_StgRegTable_rD1 -baseRegOffset (DoubleReg 2) = oFFSET_StgRegTable_rD2 -baseRegOffset (DoubleReg n) = panic ("Registers above D2 are not supported (tried to use D" ++ show n ++ ")") -baseRegOffset Sp = oFFSET_StgRegTable_rSp -baseRegOffset SpLim = oFFSET_StgRegTable_rSpLim -baseRegOffset (LongReg 1) = oFFSET_StgRegTable_rL1 -baseRegOffset (LongReg n) = panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")") -baseRegOffset Hp = oFFSET_StgRegTable_rHp -baseRegOffset HpLim = oFFSET_StgRegTable_rHpLim -baseRegOffset CCCS = oFFSET_StgRegTable_rCCCS -baseRegOffset CurrentTSO = oFFSET_StgRegTable_rCurrentTSO -baseRegOffset CurrentNursery = oFFSET_StgRegTable_rCurrentNursery -baseRegOffset HpAlloc = oFFSET_StgRegTable_rHpAlloc -baseRegOffset EagerBlackholeInfo = oFFSET_stgEagerBlackholeInfo -baseRegOffset GCEnter1 = oFFSET_stgGCEnter1 -baseRegOffset GCFun = oFFSET_stgGCFun -baseRegOffset BaseReg = panic "baseRegOffset:BaseReg" -baseRegOffset PicBaseReg = panic "baseRegOffset:PicBaseReg" +baseRegOffset :: DynFlags -> GlobalReg -> Int + +baseRegOffset dflags (VanillaReg 1 _) = oFFSET_StgRegTable_rR1 dflags +baseRegOffset dflags (VanillaReg 2 _) = oFFSET_StgRegTable_rR2 dflags +baseRegOffset dflags (VanillaReg 3 _) = oFFSET_StgRegTable_rR3 dflags +baseRegOffset dflags (VanillaReg 4 _) = oFFSET_StgRegTable_rR4 dflags +baseRegOffset dflags (VanillaReg 5 _) = oFFSET_StgRegTable_rR5 dflags +baseRegOffset dflags (VanillaReg 6 _) = oFFSET_StgRegTable_rR6 dflags +baseRegOffset dflags (VanillaReg 7 _) = oFFSET_StgRegTable_rR7 dflags +baseRegOffset dflags (VanillaReg 8 _) = oFFSET_StgRegTable_rR8 dflags +baseRegOffset dflags (VanillaReg 9 _) = oFFSET_StgRegTable_rR9 dflags +baseRegOffset dflags (VanillaReg 10 _) = oFFSET_StgRegTable_rR10 dflags +baseRegOffset _ (VanillaReg n _) = panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")") +baseRegOffset dflags (FloatReg 1) = oFFSET_StgRegTable_rF1 dflags +baseRegOffset dflags (FloatReg 2) = oFFSET_StgRegTable_rF2 dflags +baseRegOffset dflags (FloatReg 3) = oFFSET_StgRegTable_rF3 dflags +baseRegOffset dflags (FloatReg 4) = oFFSET_StgRegTable_rF4 dflags +baseRegOffset _ (FloatReg n) = panic ("Registers above F4 are not supported (tried to use F" ++ show n ++ ")") +baseRegOffset dflags (DoubleReg 1) = oFFSET_StgRegTable_rD1 dflags +baseRegOffset dflags (DoubleReg 2) = oFFSET_StgRegTable_rD2 dflags +baseRegOffset _ (DoubleReg n) = panic ("Registers above D2 are not supported (tried to use D" ++ show n ++ ")") +baseRegOffset dflags Sp = oFFSET_StgRegTable_rSp dflags +baseRegOffset dflags SpLim = oFFSET_StgRegTable_rSpLim dflags +baseRegOffset dflags (LongReg 1) = oFFSET_StgRegTable_rL1 dflags +baseRegOffset _ (LongReg n) = panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")") +baseRegOffset dflags Hp = oFFSET_StgRegTable_rHp dflags +baseRegOffset dflags HpLim = oFFSET_StgRegTable_rHpLim dflags +baseRegOffset dflags CCCS = oFFSET_StgRegTable_rCCCS dflags +baseRegOffset dflags CurrentTSO = oFFSET_StgRegTable_rCurrentTSO dflags +baseRegOffset dflags CurrentNursery = oFFSET_StgRegTable_rCurrentNursery dflags +baseRegOffset dflags HpAlloc = oFFSET_StgRegTable_rHpAlloc dflags +baseRegOffset dflags EagerBlackholeInfo = oFFSET_stgEagerBlackholeInfo dflags +baseRegOffset dflags GCEnter1 = oFFSET_stgGCEnter1 dflags +baseRegOffset dflags GCFun = oFFSET_stgGCFun dflags +baseRegOffset _ BaseReg = panic "baseRegOffset:BaseReg" +baseRegOffset _ PicBaseReg = panic "baseRegOffset:PicBaseReg" ------------------------------------------------------------------------- @@ -402,9 +402,10 @@ assignTemp :: CmmExpr -> FCode CmmExpr -- variable and assign the expression to it assignTemp e | isTrivialCmmExpr e = return e - | otherwise = do { reg <- newTemp (cmmExprType e) - ; stmtC (CmmAssign (CmmLocal reg) e) - ; return (CmmReg (CmmLocal reg)) } + | otherwise = do dflags <- getDynFlags + reg <- newTemp (cmmExprType dflags e) + stmtC (CmmAssign (CmmLocal reg) e) + return (CmmReg (CmmLocal reg)) -- | If the expression is trivial and doesn't refer to a global -- register, return it. Otherwise, assign the expression to a @@ -414,7 +415,8 @@ assignTemp_ :: CmmExpr -> FCode CmmExpr assignTemp_ e | isTrivialCmmExpr e && hasNoGlobalRegs e = return e | otherwise = do - reg <- newTemp (cmmExprType e) + dflags <- getDynFlags + reg <- newTemp (cmmExprType dflags e) stmtC (CmmAssign (CmmLocal reg) e) return (CmmReg (CmmLocal reg)) @@ -477,12 +479,13 @@ mk_switch _tag_expr [(_tag,stmts)] Nothing _lo_tag _hi_tag _via_C -- can't happen, so no need to test -- SINGLETON BRANCH: one equality check to do -mk_switch tag_expr [(tag,stmts)] (Just deflt) _lo_tag _hi_tag _via_C - = return (CmmCondBranch cond deflt `consCgStmt` stmts) - where - cond = cmmNeWord tag_expr (CmmLit (mkIntCLit tag)) +mk_switch tag_expr [(tag,stmts)] (Just deflt) _lo_tag _hi_tag _via_C = do + dflags <- getDynFlags + let + cond = cmmNeWord dflags tag_expr (CmmLit (mkIntCLit dflags tag)) -- We have lo_tag < hi_tag, but there's only one branch, -- so there must be a default + return (CmmCondBranch cond deflt `consCgStmt` stmts) -- ToDo: we might want to check for the two branch case, where one of -- the branches is the tag 0, because comparing '== 0' is likely to be @@ -499,7 +502,8 @@ mk_switch tag_expr [(tag,stmts)] (Just deflt) _lo_tag _hi_tag _via_C -- mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C | use_switch -- Use a switch - = do { branch_ids <- mapM forkCgStmts (map snd branches) + = do { dflags <- getDynFlags + ; branch_ids <- mapM forkCgStmts (map snd branches) ; let tagged_blk_ids = zip (map fst branches) (map Just branch_ids) @@ -511,7 +515,7 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C -- tag of a real branch is real_lo_tag (not lo_tag). arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]] - switch_stmt = CmmSwitch (cmmOffset tag_expr (- real_lo_tag)) arms + switch_stmt = CmmSwitch (cmmOffset dflags tag_expr (- real_lo_tag)) arms ; ASSERT(not (all isNothing arms)) return (oneCgStmt switch_stmt) @@ -519,8 +523,9 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C -- if we can knock off a bunch of default cases with one if, then do so | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches - = do { (assign_tag, tag_expr') <- assignTemp' tag_expr - ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit lowest_branch)) + = do { dflags <- getDynFlags + ; (assign_tag, tag_expr') <- assignTemp' tag_expr + ; let cond = cmmULtWord dflags tag_expr' (CmmLit (mkIntCLit dflags lowest_branch)) branch = CmmCondBranch cond deflt ; stmts <- mk_switch tag_expr' branches mb_deflt lowest_branch hi_tag via_C @@ -528,8 +533,9 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C } | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches - = do { (assign_tag, tag_expr') <- assignTemp' tag_expr - ; let cond = cmmUGtWord tag_expr' (CmmLit (mkIntCLit highest_branch)) + = do { dflags <- getDynFlags + ; (assign_tag, tag_expr') <- assignTemp' tag_expr + ; let cond = cmmUGtWord dflags tag_expr' (CmmLit (mkIntCLit dflags highest_branch)) branch = CmmCondBranch cond deflt ; stmts <- mk_switch tag_expr' branches mb_deflt lo_tag highest_branch via_C @@ -537,14 +543,15 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C } | otherwise -- Use an if-tree - = do { (assign_tag, tag_expr') <- assignTemp' tag_expr + = do { dflags <- getDynFlags + ; (assign_tag, tag_expr') <- assignTemp' tag_expr -- To avoid duplication ; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt lo_tag (mid_tag-1) via_C ; hi_stmts <- mk_switch tag_expr' hi_branches mb_deflt mid_tag hi_tag via_C ; hi_id <- forkCgStmts hi_stmts - ; let cond = cmmUGeWord tag_expr' (CmmLit (mkIntCLit mid_tag)) + ; let cond = cmmUGeWord dflags tag_expr' (CmmLit (mkIntCLit dflags mid_tag)) branch_stmt = CmmCondBranch cond hi_id ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` lo_stmts)) } @@ -604,8 +611,9 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C assignTemp' :: CmmExpr -> FCode (CmmStmt, CmmExpr) assignTemp' e | isTrivialCmmExpr e = return (CmmNop, e) - | otherwise = do { reg <- newTemp (cmmExprType e) - ; return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) } + | otherwise = do dflags <- getDynFlags + reg <- newTemp (cmmExprType dflags e) + return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) emitLitSwitch :: CmmExpr -- Tag to switch on -> [(Literal, CgStmts)] -- Tagged branches @@ -628,19 +636,20 @@ mk_lit_switch :: CmmExpr -> BlockId -> [(Literal,CgStmts)] -> FCode CgStmts mk_lit_switch scrut deflt_blk_id [(lit,blk)] - = return (consCgStmt if_stmt blk) - where - cmm_lit = mkSimpleLit lit - rep = cmmLitType cmm_lit - ne = if isFloatType rep then MO_F_Ne else MO_Ne - cond = CmmMachOp (ne (typeWidth rep)) [scrut, CmmLit cmm_lit] - if_stmt = CmmCondBranch cond deflt_blk_id + = do dflags <- getDynFlags + let cmm_lit = mkSimpleLit dflags lit + rep = cmmLitType dflags cmm_lit + ne = if isFloatType rep then MO_F_Ne else MO_Ne + cond = CmmMachOp (ne (typeWidth rep)) [scrut, CmmLit cmm_lit] + if_stmt = CmmCondBranch cond deflt_blk_id + return (consCgStmt if_stmt blk) mk_lit_switch scrut deflt_blk_id branches - = do { hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches + = do { dflags <- getDynFlags + ; hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches ; lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches ; lo_blk_id <- forkCgStmts lo_blk - ; let if_stmt = CmmCondBranch cond lo_blk_id + ; let if_stmt = CmmCondBranch (cond dflags) lo_blk_id ; return (if_stmt `consCgStmt` hi_blk) } where n_branches = length branches @@ -650,8 +659,8 @@ mk_lit_switch scrut deflt_blk_id branches (lo_branches, hi_branches) = span is_lo branches is_lo (t,_) = t < mid_lit - cond = CmmMachOp (mkLtOp mid_lit) - [scrut, CmmLit (mkSimpleLit mid_lit)] + cond dflags = CmmMachOp (mkLtOp dflags mid_lit) + [scrut, CmmLit (mkSimpleLit dflags mid_lit)] ------------------------------------------------------------------------- -- @@ -687,13 +696,14 @@ emitSimultaneously stmts stmt_list -> doSimultaneously1 (zip [(1::Int)..] stmt_list) doSimultaneously1 :: [CVertex] -> Code -doSimultaneously1 vertices - = let +doSimultaneously1 vertices = do + dflags <- getDynFlags + let edges = [ (vertex, key1, edges_from stmt1) | vertex@(key1, stmt1) <- vertices ] edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices, - stmt1 `mustFollow` stmt2 + mustFollow dflags stmt1 stmt2 ] components = stronglyConnCompFromEdgedVertices edges @@ -712,23 +722,24 @@ doSimultaneously1 vertices ; stmtC from_temp } go_via_temp (CmmAssign dest src) - = do { tmp <- newTemp (cmmRegType dest) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong + = do { dflags <- getDynFlags + ; tmp <- newTemp (cmmRegType dflags dest) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong ; stmtC (CmmAssign (CmmLocal tmp) src) ; return (CmmAssign dest (CmmReg (CmmLocal tmp))) } go_via_temp (CmmStore dest src) - = do { tmp <- newTemp (cmmExprType src) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong + = do { tmp <- newTemp (cmmExprType dflags src) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong ; stmtC (CmmAssign (CmmLocal tmp) src) ; return (CmmStore dest (CmmReg (CmmLocal tmp))) } go_via_temp _ = panic "doSimultaneously1: go_via_temp" - in mapCs do_component components -mustFollow :: CmmStmt -> CmmStmt -> Bool -CmmAssign reg _ `mustFollow` stmt = anySrc (reg `regUsedIn`) stmt -CmmStore loc e `mustFollow` stmt = anySrc (locUsedIn loc (cmmExprType e)) stmt -CmmNop `mustFollow` _ = False -CmmComment _ `mustFollow` _ = False -_ `mustFollow` _ = panic "mustFollow" +mustFollow :: DynFlags -> CmmStmt -> CmmStmt -> Bool +mustFollow dflags x y = x `mustFollow'` y + where CmmAssign reg _ `mustFollow'` stmt = anySrc (reg `regUsedIn`) stmt + CmmStore loc e `mustFollow'` stmt = anySrc (locUsedIn loc (cmmExprType dflags e)) stmt + CmmNop `mustFollow'` _ = False + CmmComment _ `mustFollow'` _ = False + _ `mustFollow'` _ = panic "mustFollow" anySrc :: (CmmExpr -> Bool) -> CmmStmt -> Bool @@ -776,6 +787,7 @@ possiblySameLoc _ _ _ _ = True -- Conservative getSRTInfo :: FCode C_SRT getSRTInfo = do + dflags <- getDynFlags srt_lbl <- getSRTLabel srt <- getSRT case srt of @@ -789,8 +801,8 @@ getSRTInfo = do let srt_desc_lbl = mkLargeSRTLabel id emitRODataLits "getSRTInfo" srt_desc_lbl ( cmmLabelOffW srt_lbl off - : mkWordCLit (fromIntegral len) - : map mkWordCLit bmp) + : mkWordCLit dflags (fromIntegral len) + : map (mkWordCLit dflags) bmp) return (C_SRT srt_desc_lbl 0 srt_escape) | otherwise @@ -810,80 +822,81 @@ srt_escape = -1 -- to real machine registers or stored as offsets from BaseReg. Given -- a GlobalReg, get_GlobalReg_addr always produces the -- register table address for it. -get_GlobalReg_addr :: Platform -> GlobalReg -> CmmExpr -get_GlobalReg_addr _ BaseReg = regTableOffset 0 -get_GlobalReg_addr platform mid - = get_Regtable_addr_from_offset platform - (globalRegType mid) (baseRegOffset mid) +get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr +get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0 +get_GlobalReg_addr dflags mid + = get_Regtable_addr_from_offset dflags + (globalRegType dflags mid) (baseRegOffset dflags mid) -- Calculate a literal representing an offset into the register table. -- Used when we don't have an actual BaseReg to offset from. -regTableOffset :: Int -> CmmExpr -regTableOffset n = - CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n)) +regTableOffset :: DynFlags -> Int -> CmmExpr +regTableOffset dflags n = + CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n)) -get_Regtable_addr_from_offset :: Platform -> CmmType -> Int -> CmmExpr -get_Regtable_addr_from_offset platform _ offset = - if haveRegBase platform +get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr +get_Regtable_addr_from_offset dflags _ offset = + if haveRegBase (targetPlatform dflags) then CmmRegOff (CmmGlobal BaseReg) offset - else regTableOffset offset + else regTableOffset dflags offset -- | Fixup global registers so that they assign to locations within the -- RegTable if they aren't pinned for the current target. -fixStgRegisters :: Platform -> RawCmmDecl -> RawCmmDecl +fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl fixStgRegisters _ top@(CmmData _ _) = top -fixStgRegisters platform (CmmProc info lbl (ListGraph blocks)) = - let blocks' = map (fixStgRegBlock platform) blocks +fixStgRegisters dflags (CmmProc info lbl (ListGraph blocks)) = + let blocks' = map (fixStgRegBlock dflags) blocks in CmmProc info lbl $ ListGraph blocks' -fixStgRegBlock :: Platform -> CmmBasicBlock -> CmmBasicBlock -fixStgRegBlock platform (BasicBlock id stmts) = - let stmts' = map (fixStgRegStmt platform) stmts +fixStgRegBlock :: DynFlags -> CmmBasicBlock -> CmmBasicBlock +fixStgRegBlock dflags (BasicBlock id stmts) = + let stmts' = map (fixStgRegStmt dflags) stmts in BasicBlock id stmts' -fixStgRegStmt :: Platform -> CmmStmt -> CmmStmt -fixStgRegStmt platform stmt +fixStgRegStmt :: DynFlags -> CmmStmt -> CmmStmt +fixStgRegStmt dflags stmt = case stmt of CmmAssign (CmmGlobal reg) src -> - let src' = fixStgRegExpr platform src - baseAddr = get_GlobalReg_addr platform reg + let src' = fixStgRegExpr dflags src + baseAddr = get_GlobalReg_addr dflags reg in case reg `elem` activeStgRegs platform of True -> CmmAssign (CmmGlobal reg) src' False -> CmmStore baseAddr src' CmmAssign reg src -> - let src' = fixStgRegExpr platform src + let src' = fixStgRegExpr dflags src in CmmAssign reg src' - CmmStore addr src -> CmmStore (fixStgRegExpr platform addr) (fixStgRegExpr platform src) + CmmStore addr src -> CmmStore (fixStgRegExpr dflags addr) (fixStgRegExpr dflags src) CmmCall target regs args returns -> let target' = case target of - CmmCallee e conv -> CmmCallee (fixStgRegExpr platform e) conv + CmmCallee e conv -> CmmCallee (fixStgRegExpr dflags e) conv CmmPrim op mStmts -> - CmmPrim op (fmap (map (fixStgRegStmt platform)) mStmts) + CmmPrim op (fmap (map (fixStgRegStmt dflags)) mStmts) args' = map (\(CmmHinted arg hint) -> - (CmmHinted (fixStgRegExpr platform arg) hint)) args + (CmmHinted (fixStgRegExpr dflags arg) hint)) args in CmmCall target' regs args' returns - CmmCondBranch test dest -> CmmCondBranch (fixStgRegExpr platform test) dest + CmmCondBranch test dest -> CmmCondBranch (fixStgRegExpr dflags test) dest - CmmSwitch expr ids -> CmmSwitch (fixStgRegExpr platform expr) ids + CmmSwitch expr ids -> CmmSwitch (fixStgRegExpr dflags expr) ids - CmmJump addr live -> CmmJump (fixStgRegExpr platform addr) live + CmmJump addr live -> CmmJump (fixStgRegExpr dflags addr) live -- CmmNop, CmmComment, CmmBranch, CmmReturn _other -> stmt + where platform = targetPlatform dflags -fixStgRegExpr :: Platform -> CmmExpr -> CmmExpr -fixStgRegExpr platform expr +fixStgRegExpr :: DynFlags -> CmmExpr -> CmmExpr +fixStgRegExpr dflags expr = case expr of - CmmLoad addr ty -> CmmLoad (fixStgRegExpr platform addr) ty + CmmLoad addr ty -> CmmLoad (fixStgRegExpr dflags addr) ty CmmMachOp mop args -> CmmMachOp mop args' - where args' = map (fixStgRegExpr platform) args + where args' = map (fixStgRegExpr dflags) args CmmReg (CmmGlobal reg) -> -- Replace register leaves with appropriate StixTrees for @@ -895,11 +908,11 @@ fixStgRegExpr platform expr case reg `elem` activeStgRegs platform of True -> expr False -> - let baseAddr = get_GlobalReg_addr platform reg + let baseAddr = get_GlobalReg_addr dflags reg in case reg of - BaseReg -> fixStgRegExpr platform baseAddr - _other -> fixStgRegExpr platform - (CmmLoad baseAddr (globalRegType reg)) + BaseReg -> fixStgRegExpr dflags baseAddr + _other -> fixStgRegExpr dflags + (CmmLoad baseAddr (globalRegType dflags reg)) CmmRegOff (CmmGlobal reg) offset -> -- RegOf leaves are just a shorthand form. If the reg maps @@ -907,11 +920,12 @@ fixStgRegExpr platform expr -- expand it and defer to the above code. case reg `elem` activeStgRegs platform of True -> expr - False -> fixStgRegExpr platform (CmmMachOp (MO_Add wordWidth) [ + False -> fixStgRegExpr dflags (CmmMachOp (MO_Add (wordWidth dflags)) [ CmmReg (CmmGlobal reg), CmmLit (CmmInt (fromIntegral offset) - wordWidth)]) + (wordWidth dflags))]) -- CmmLit, CmmReg (CmmLocal), CmmStackSlot _other -> expr + where platform = targetPlatform dflags diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index ae05bffbb8..1b1c360f83 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -265,13 +265,13 @@ instance Outputable CgRep where ppr FloatArg = ptext (sLit "F_") ppr DoubleArg = ptext (sLit "D_") -argMachRep :: CgRep -> CmmType -argMachRep PtrArg = gcWord -argMachRep NonPtrArg = bWord -argMachRep LongArg = b64 -argMachRep FloatArg = f32 -argMachRep DoubleArg = f64 -argMachRep VoidArg = panic "argMachRep:VoidRep" +argMachRep :: DynFlags -> CgRep -> CmmType +argMachRep dflags PtrArg = gcWord dflags +argMachRep dflags NonPtrArg = bWord dflags +argMachRep _ LongArg = b64 +argMachRep _ FloatArg = f32 +argMachRep _ DoubleArg = f64 +argMachRep _ VoidArg = panic "argMachRep:VoidRep" primRepToCgRep :: PrimRep -> CgRep primRepToCgRep VoidRep = VoidArg diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index d74533d76e..65e0103099 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -235,7 +235,7 @@ cgDataCon data_con do { _ <- ticky_code ; ldvEnter (CmmReg nodeReg) ; tickyReturnOldCon (length arg_things) - ; void $ emitReturn [cmmOffsetB (CmmReg nodeReg) + ; void $ emitReturn [cmmOffsetB dflags (CmmReg nodeReg) (tagForCon data_con)] } -- The case continuation code expects a tagged pointer diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 04799a7f0b..aac1abfe0c 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -65,9 +65,10 @@ cgTopRhsClosure :: Id -> FCode (CgIdInfo, FCode ()) cgTopRhsClosure id ccs _ upd_flag args body - = do { lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args + = do { dflags <- getDynFlags + ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args ; let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id) - cg_id_info = litIdInfo id lf_info (CmmLabel closure_label) + cg_id_info = litIdInfo dflags id lf_info (CmmLabel closure_label) ; return (cg_id_info, gen_code lf_info closure_label) } where @@ -242,7 +243,7 @@ mkRhsClosure dflags bndr _cc _bi (StgApp selectee [{-no args-}]))]) | the_fv == scrutinee -- Scrutinee is the only free variable && maybeToBool maybe_offset -- Selectee is a component of the tuple - && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough + && offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough = -- NOT TRUE: ASSERT(is_single_constructor) -- The simplifier may have statically determined that the single alternative -- is the only possible case and eliminated the others, even if there are @@ -271,7 +272,7 @@ mkRhsClosure dflags bndr _cc _bi | args `lengthIs` (arity-1) && all (isGcPtrRep . idPrimRep . stripNV) fvs && isUpdatable upd_flag - && arity <= mAX_SPEC_AP_SIZE + && arity <= mAX_SPEC_AP_SIZE dflags && not (dopt Opt_SccProfilingOn dflags) -- not when profiling: we don't want to -- lose information about this particular @@ -340,7 +341,7 @@ mkRhsClosure _ bndr cc _ fvs upd_flag args body (map toVarArg fv_details) -- RETURN - ; return (mkRhsInit reg lf_info hp_plus_n) } + ; return (mkRhsInit dflags reg lf_info hp_plus_n) } -- Use with care; if used inappropriately, it could break invariants. @@ -381,7 +382,7 @@ cgRhsStdThunk bndr lf_info payload use_cc blame_cc payload_w_offsets -- RETURN - ; return (mkRhsInit reg lf_info hp_plus_n) } + ; return (mkRhsInit dflags reg lf_info hp_plus_n) } mkClosureLFInfo :: Id -- The binder @@ -457,9 +458,9 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details node' = if node_points then Just node else Nothing ; tickyEnterFun cl_info ; enterCostCentreFun cc - (CmmMachOp mo_wordSub + (CmmMachOp (mo_wordSub dflags) [ CmmReg nodeReg - , mkIntExpr (funTag cl_info) ]) + , mkIntExpr dflags (funTag cl_info) ]) ; whenC node_points (ldvEnterClosure cl_info) ; granYield arg_regs node_points @@ -481,7 +482,8 @@ bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) } load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, WordOff)] -> FCode () load_fvs node lf_info = mapM_ (\ (reg, off) -> - emit $ mkTaggedObjectLoad reg node off tag) + do dflags <- getDynFlags + emit $ mkTaggedObjectLoad dflags reg node off tag) where tag = lfDynTag lf_info ----------------------------------------- @@ -506,7 +508,7 @@ mkSlowEntryCode cl_info arg_regs -- function closure is already in `Node' jump = mkDirectJump dflags (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) arg_regs) - initUpdFrameOff + (initUpdFrameOff dflags) emitProcWithConvention Slow Nothing slow_lbl arg_regs jump | otherwise = return () @@ -580,7 +582,7 @@ emitBlackHoleCode is_single_entry = do whenC eager_blackholing $ do tickyBlackHole (not is_single_entry) - emitStore (cmmOffsetW (CmmReg nodeReg) (fixedHdrSize dflags)) + emitStore (cmmOffsetW dflags (CmmReg nodeReg) (fixedHdrSize dflags)) (CmmReg (CmmGlobal CurrentTSO)) emitPrimCall [] MO_WriteBarrier [] emitStore (CmmReg nodeReg) (CmmReg (CmmGlobal EagerBlackholeInfo)) @@ -633,8 +635,8 @@ pushUpdateFrame lbl updatee body dflags <- getDynFlags let hdr = fixedHdrSize dflags * wORD_SIZE - frame = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr - off_updatee = hdr + oFFSET_StgUpdateFrame_updatee + frame = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr dflags + off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags -- emitStore (CmmStackSlot Old frame) (mkLblExpr lbl) emitStore (CmmStackSlot Old (frame - off_updatee)) updatee @@ -686,7 +688,7 @@ link_caf :: LocalReg -- pointer to the closure link_caf node _is_upd = do { dflags <- getDynFlags -- Alloc black hole specifying CC_HDR(Node) as the cost centre - ; let use_cc = costCentreFrom (CmmReg nodeReg) + ; let use_cc = costCentreFrom dflags (CmmReg nodeReg) blame_cc = use_cc tso = CmmReg (CmmGlobal CurrentTSO) @@ -703,7 +705,7 @@ link_caf node _is_upd = do -- so that the garbage collector can find them -- This must be done *before* the info table pointer is overwritten, -- because the old info table ptr is needed for reversion - ; ret <- newTemp bWord + ; ret <- newTemp (bWord dflags) ; emitRtsCallGen [(ret,NoHint)] rtsPackageId (fsLit "newCAF") [ (CmmReg (CmmGlobal BaseReg), AddrHint), (CmmReg (CmmLocal node), AddrHint), @@ -714,11 +716,11 @@ link_caf node _is_upd = do -- see Note [atomic CAF entry] in rts/sm/Storage.c ; updfr <- getUpdFrameOff ; emit =<< mkCmmIfThen - (CmmMachOp mo_wordEq [ CmmReg (CmmLocal ret), CmmLit zeroCLit]) + (CmmMachOp (mo_wordEq dflags) [ CmmReg (CmmLocal ret), CmmLit (zeroCLit dflags)]) -- re-enter R1. Doing this directly is slightly dodgy; we're -- assuming lots of things, like the stack pointer hasn't -- moved since we entered the CAF. - (let target = entryCode dflags (closureInfoPtr (CmmReg (CmmLocal node))) in + (let target = entryCode dflags (closureInfoPtr dflags (CmmReg (CmmLocal node))) in mkJump dflags target [] updfr) ; return hp_rel } diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index 083e615b78..0e0f2f13f8 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -31,7 +31,6 @@ import MkGraph import SMRep import CostCentre import Module -import Constants import DataCon import DynFlags import FastString @@ -56,14 +55,14 @@ cgTopRhsCon :: Id -- Name of thing bound to this RHS -> [StgArg] -- Args -> FCode (CgIdInfo, FCode ()) cgTopRhsCon id con args - = return ( id_info, gen_code ) + = do dflags <- getDynFlags + let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label) + return ( id_info, gen_code ) where name = idName id caffy = idCafInfo id -- any stgArgHasCafRefs args closure_label = mkClosureLabel name caffy - id_info = litIdInfo id (mkConLFInfo con) (CmmLabel closure_label) - gen_code = do { dflags <- getDynFlags ; when (platformOS (targetPlatform dflags) == OSMinGW32) $ @@ -149,8 +148,8 @@ premature looking at the args will cause the compiler to black-hole! -- which have exclusively size-zero (VoidRep) args, we generate no code -- at all. -buildDynCon' _ _ binder _cc con [] - = return (litIdInfo binder (mkConLFInfo con) +buildDynCon' dflags _ binder _cc con [] + = return (litIdInfo dflags binder (mkConLFInfo con) (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))), return mkNop) @@ -184,14 +183,14 @@ buildDynCon' dflags platform binder _cc con [arg] | maybeIntLikeCon con , platformOS platform /= OSMinGW32 || not (dopt Opt_PIC dflags) , StgLitArg (MachInt val) <- arg - , val <= fromIntegral mAX_INTLIKE -- Comparisons at type Integer! - , val >= fromIntegral mIN_INTLIKE -- ...ditto... + , val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer! + , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto... = do { let intlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_INTLIKE_closure") val_int = fromIntegral val :: Int - offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize dflags + 1) + offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSize dflags + 1) -- INTLIKE closures consist of a header and one word payload intlike_amode = cmmLabelOffW intlike_lbl offsetW - ; return ( litIdInfo binder (mkConLFInfo con) intlike_amode + ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode , return mkNop) } buildDynCon' dflags platform binder _cc con [arg] @@ -199,13 +198,13 @@ buildDynCon' dflags platform binder _cc con [arg] , platformOS platform /= OSMinGW32 || not (dopt Opt_PIC dflags) , StgLitArg (MachChar val) <- arg , let val_int = ord val :: Int - , val_int <= mAX_CHARLIKE - , val_int >= mIN_CHARLIKE + , val_int <= mAX_CHARLIKE dflags + , val_int >= mIN_CHARLIKE dflags = do { let charlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_CHARLIKE_closure") - offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize dflags + 1) + offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSize dflags + 1) -- CHARLIKE closures consist of a header and one word payload charlike_amode = cmmLabelOffW charlike_lbl offsetW - ; return ( litIdInfo binder (mkConLFInfo con) charlike_amode + ; return ( litIdInfo dflags binder (mkConLFInfo con) charlike_amode , return mkNop) } -------- buildDynCon': the general case ----------- @@ -225,7 +224,7 @@ buildDynCon' dflags _ binder ccs con args ptr_wds nonptr_wds ; hp_plus_n <- allocDynClosure info_tbl lf_info use_cc blame_cc args_w_offsets - ; return (mkRhsInit reg lf_info hp_plus_n) } + ; return (mkRhsInit dflags reg lf_info hp_plus_n) } where use_cc -- cost-centre to stick in the object | isCurrentCCS ccs = curCCS @@ -255,7 +254,8 @@ bindConArgs (DataAlt con) base args -- when accessing the constructor field. bind_arg :: (NonVoid Id, VirtualHpOffset) -> FCode LocalReg bind_arg (arg, offset) - = do { emit $ mkTaggedObjectLoad (idToReg arg) base offset tag + = do { dflags <- getDynFlags + ; emit $ mkTaggedObjectLoad dflags (idToReg dflags arg) base offset tag ; bindArgToReg arg } bindConArgs _other_con _base args diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs index e4611237cc..664a606091 100644 --- a/compiler/codeGen/StgCmmEnv.hs +++ b/compiler/codeGen/StgCmmEnv.hs @@ -41,6 +41,7 @@ import StgCmmClosure import CLabel +import DynFlags import MkGraph import BlockId import CmmExpr @@ -81,18 +82,18 @@ mkCgIdInfo id lf expr , cg_loc = CmmLoc expr, cg_tag = lfDynTag lf } -litIdInfo :: Id -> LambdaFormInfo -> CmmLit -> CgIdInfo -litIdInfo id lf lit +litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo +litIdInfo dflags id lf lit = CgIdInfo { cg_id = id, cg_lf = lf - , cg_loc = CmmLoc (addDynTag (CmmLit lit) tag) + , cg_loc = CmmLoc (addDynTag dflags (CmmLit lit) tag) , cg_tag = tag } where tag = lfDynTag lf -lneIdInfo :: Id -> [NonVoid Id] -> CgIdInfo -lneIdInfo id regs +lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo +lneIdInfo dflags id regs = CgIdInfo { cg_id = id, cg_lf = lf - , cg_loc = LneLoc blk_id (map idToReg regs) + , cg_loc = LneLoc blk_id (map (idToReg dflags) regs) , cg_tag = lfDynTag lf } where lf = mkLFLetNoEscape @@ -101,12 +102,13 @@ lneIdInfo id regs rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg) rhsIdInfo id lf_info - = do { reg <- newTemp gcWord - ; return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg) } + = do dflags <- getDynFlags + reg <- newTemp (gcWord dflags) + return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg) -mkRhsInit :: LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph -mkRhsInit reg lf_info expr - = mkAssign (CmmLocal reg) (addDynTag expr (lfDynTag lf_info)) +mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph +mkRhsInit dflags reg lf_info expr + = mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag lf_info)) idInfoToAmode :: CgIdInfo -> CmmExpr -- Returns a CmmExpr for the *tagged* pointer @@ -114,9 +116,9 @@ idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e idInfoToAmode cg_info = pprPanic "idInfoToAmode" (ppr (cg_id cg_info)) -- LneLoc -addDynTag :: CmmExpr -> DynTag -> CmmExpr +addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr -- A tag adds a byte offset to the pointer -addDynTag expr tag = cmmOffsetB expr tag +addDynTag dflags expr tag = cmmOffsetB dflags expr tag cgIdInfoId :: CgIdInfo -> Id cgIdInfoId = cg_id @@ -170,7 +172,8 @@ getCgIdInfo id in if isExternalName name then do let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id) - return (litIdInfo id (mkLFImported id) ext_lbl) + dflags <- getDynFlags + return (litIdInfo dflags id (mkLFImported id) ext_lbl) else -- Bug cgLookupPanic id @@ -212,9 +215,10 @@ getNonVoidArgAmodes (arg:args) bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg -- Bind an Id to a fresh LocalReg bindToReg nvid@(NonVoid id) lf_info - = do { let reg = idToReg nvid - ; addBindC id (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg))) - ; return reg } + = do dflags <- getDynFlags + let reg = idToReg dflags nvid + addBindC id (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg))) + return reg rebindToReg :: NonVoid Id -> FCode LocalReg -- Like bindToReg, but the Id is already in scope, so @@ -229,7 +233,7 @@ bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id) bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg] bindArgsToRegs args = mapM bindArgToReg args -idToReg :: NonVoid Id -> LocalReg +idToReg :: DynFlags -> NonVoid Id -> LocalReg -- Make a register from an Id, typically a function argument, -- free variable, or case binder -- @@ -237,8 +241,9 @@ idToReg :: NonVoid Id -> LocalReg -- -- By now the Ids should be uniquely named; else one would worry -- about accidental collision -idToReg (NonVoid id) = LocalReg (idUnique id) +idToReg dflags (NonVoid id) + = LocalReg (idUnique id) (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id) - _ -> primRepCmmType (idPrimRep id)) + _ -> primRepCmmType dflags (idPrimRep id)) diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index bc29c68c37..ccd7d96231 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -61,7 +61,9 @@ cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = cgExpr (StgOpApp op args ty) = cgOpApp op args ty cgExpr (StgConApp con args) = cgConApp con args cgExpr (StgSCC cc tick push expr) = do { emitSetCCC cc tick push; cgExpr expr } -cgExpr (StgTick m n expr) = do { emit (mkTickBox m n); cgExpr expr } +cgExpr (StgTick m n expr) = do dflags <- getDynFlags + emit (mkTickBox dflags m n) + cgExpr expr cgExpr (StgLit lit) = do cmm_lit <- cgLit lit emitReturn [CmmLit cmm_lit] @@ -154,8 +156,9 @@ cgLetNoEscapeClosure -> FCode (CgIdInfo, FCode ()) cgLetNoEscapeClosure bndr cc_slot _unused_cc args body - = return ( lneIdInfo bndr args - , code ) + = do dflags <- getDynFlags + return ( lneIdInfo dflags bndr args + , code ) where code = forkProc $ do { restoreCurrentCostCentre cc_slot @@ -289,9 +292,10 @@ cgCase (StgOpApp (StgPrimOp op) args _) bndr (AlgAlt tycon) alts -- If the binder is not dead, convert the tag to a constructor -- and assign it. ; when (not (isDeadBinder bndr)) $ do - { tmp_reg <- bindArgToReg (NonVoid bndr) + { dflags <- getDynFlags + ; tmp_reg <- bindArgToReg (NonVoid bndr) ; emitAssign (CmmLocal tmp_reg) - (tagToClosure tycon tag_expr) } + (tagToClosure dflags tycon tag_expr) } ; (mb_deflt, branches) <- cgAlgAltRhss (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alts @@ -303,7 +307,8 @@ cgCase (StgOpApp (StgPrimOp op) args _) bndr (AlgAlt tycon) alts do_enum_primop TagToEnumOp [arg] -- No code! = getArgAmode (NonVoid arg) do_enum_primop primop args - = do tmp <- newTemp bWord + = do dflags <- getDynFlags + tmp <- newTemp (bWord dflags) cgPrimOp [tmp] primop args return (CmmReg (CmmLocal tmp)) @@ -362,10 +367,11 @@ cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts | isUnLiftedType (idType v) || reps_compatible = -- assignment suffices for unlifted types - do { when (not reps_compatible) $ + do { dflags <- getDynFlags + ; when (not reps_compatible) $ panic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?" ; v_info <- getCgIdInfo v - ; emitAssign (CmmLocal (idToReg (NonVoid bndr))) (idInfoToAmode v_info) + ; emitAssign (CmmLocal (idToReg dflags (NonVoid bndr))) (idInfoToAmode v_info) ; _ <- bindArgsToRegs [NonVoid bndr] ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts } where @@ -373,8 +379,9 @@ cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts cgCase scrut@(StgApp v []) _ (PrimAlt _) _ = -- fail at run-time, not compile-time - do { mb_cc <- maybeSaveCostCentre True - ; _ <- withSequel (AssignTo [idToReg (NonVoid v)] False) (cgExpr scrut) + do { dflags <- getDynFlags + ; mb_cc <- maybeSaveCostCentre True + ; _ <- withSequel (AssignTo [idToReg dflags (NonVoid v)] False) (cgExpr scrut) ; restoreCurrentCostCentre mb_cc ; emitComment $ mkFastString "should be unreachable code" ; l <- newLabelC @@ -401,9 +408,10 @@ cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts cgCase scrut bndr alt_type alts = -- the general case - do { up_hp_usg <- getVirtHp -- Upstream heap usage + do { dflags <- getDynFlags + ; up_hp_usg <- getVirtHp -- Upstream heap usage ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts - alt_regs = map idToReg ret_bndrs + alt_regs = map (idToReg dflags) ret_bndrs simple_scrut = isSimpleScrut scrut alt_type do_gc | not simple_scrut = True | isSingleton alts = False @@ -481,9 +489,11 @@ cgAlts gc_plan _bndr (UbxTupAlt _) [(_, _, _, rhs)] -- Here bndrs are *already* in scope, so don't rebind them cgAlts gc_plan bndr (PrimAlt _) alts - = do { tagged_cmms <- cgAltRhss gc_plan bndr alts + = do { dflags <- getDynFlags - ; let bndr_reg = CmmLocal (idToReg bndr) + ; tagged_cmms <- cgAltRhss gc_plan bndr alts + + ; let bndr_reg = CmmLocal (idToReg dflags bndr) (DEFAULT,deflt) = head tagged_cmms -- PrimAlts always have a DEFAULT case -- and it always comes first @@ -494,16 +504,18 @@ cgAlts gc_plan bndr (PrimAlt _) alts ; return AssignedDirectly } cgAlts gc_plan bndr (AlgAlt tycon) alts - = do { (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts + = do { dflags <- getDynFlags + + ; (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts ; let fam_sz = tyConFamilySize tycon - bndr_reg = CmmLocal (idToReg bndr) + bndr_reg = CmmLocal (idToReg dflags bndr) -- Is the constructor tag in the node reg? ; if isSmallFamily fam_sz then do let -- Yes, bndr_reg has constr. tag in ls bits - tag_expr = cmmConstrTag1 (CmmReg bndr_reg) + tag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg) branches' = [(tag+1,branch) | (tag,branch) <- branches] emitSwitch tag_expr branches' mb_deflt 1 fam_sz return AssignedDirectly @@ -564,10 +576,10 @@ cgAlgAltRhss gc_plan bndr alts ------------------- cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [StgAlt] -> FCode [(AltCon, CmmAGraph)] -cgAltRhss gc_plan bndr alts - = forkAlts (map cg_alt alts) - where - base_reg = idToReg bndr +cgAltRhss gc_plan bndr alts = do + dflags <- getDynFlags + let + base_reg = idToReg dflags bndr cg_alt :: StgAlt -> FCode (AltCon, CmmAGraph) cg_alt (con, bndrs, _uses, rhs) = getCodeR $ @@ -575,6 +587,7 @@ cgAltRhss gc_plan bndr alts do { _ <- bindConArgs con base_reg bndrs ; _ <- cgExpr rhs ; return con } + forkAlts (map cg_alt alts) maybeAltHeapCheck :: (GcPlan,ReturnKind) -> FCode a -> FCode a maybeAltHeapCheck (NoGcInAlts,_) code = code @@ -673,9 +686,9 @@ emitEnter fun = do -- Right now, we do what the old codegen did, and omit the tag -- test, just generating an enter. Return _ -> do - { let entry = entryCode dflags $ closureInfoPtr $ CmmReg nodeReg + { let entry = entryCode dflags $ closureInfoPtr dflags $ CmmReg nodeReg ; emit $ mkForeignJump dflags NativeNodeCall entry - [cmmUntag fun] updfr_off + [cmmUntag dflags fun] updfr_off ; return AssignedDirectly } @@ -715,11 +728,11 @@ emitEnter fun = do -- refer to fun via nodeReg after the copyout, to avoid having -- both live simultaneously; this sometimes enables fun to be -- inlined in the RHS of the R1 assignment. - ; let entry = entryCode dflags (closureInfoPtr (CmmReg nodeReg)) + ; let entry = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg)) the_call = toCall entry (Just lret) updfr_off off outArgs regs ; emit $ copyout <*> - mkCbranch (cmmIsTagged (CmmReg nodeReg)) lret lcall <*> + mkCbranch (cmmIsTagged dflags (CmmReg nodeReg)) lret lcall <*> outOfLine lcall the_call <*> mkLabel lret <*> copyin diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index cdedd1243c..ca5f49794b 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -55,7 +55,19 @@ cgForeignCall :: ForeignCall -- the op -> FCode ReturnKind cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty - = do { cmm_args <- getFCallArgs stg_args + = do { dflags <- getDynFlags + ; let -- in the stdcall calling convention, the symbol needs @size appended + -- to it, where size is the total number of bytes of arguments. We + -- attach this info to the CLabel here, and the CLabel pretty printer + -- will generate the suffix when the label is printed. + call_size args + | StdCallConv <- cconv = Just (sum (map arg_size args)) + | otherwise = Nothing + + -- ToDo: this might not be correct for 64-bit API + arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType dflags arg) + wORD_SIZE + ; cmm_args <- getFCallArgs stg_args ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty ; let ((call_args, arg_hints), cmm_target) = case target of @@ -98,18 +110,6 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty ; emitReturn (map (CmmReg . CmmLocal) res_regs) } } - where - -- in the stdcall calling convention, the symbol needs @size appended - -- to it, where size is the total number of bytes of arguments. We - -- attach this info to the CLabel here, and the CLabel pretty printer - -- will generate the suffix when the label is printed. - call_size args - | StdCallConv <- cconv = Just (sum (map arg_size args)) - | otherwise = Nothing - - -- ToDo: this might not be correct for 64-bit API - arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType arg) - wORD_SIZE {- Note [safe foreign call convention] @@ -222,7 +222,7 @@ emitForeignCall safety results target args _ret let (off, copyout) = copyInOflow dflags NativeReturn (Young k) results -- see Note [safe foreign call convention] emit $ - ( mkStore (CmmStackSlot (Young k) (widthInBytes wordWidth)) + ( mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags))) (CmmLit (CmmBlock k)) <*> mkLast (CmmForeignCall { tgt = temp_target , res = results @@ -262,10 +262,11 @@ maybe_assign_temp :: CmmExpr -> FCode CmmExpr maybe_assign_temp e | hasNoGlobalRegs e = return e | otherwise = do + dflags <- getDynFlags -- don't use assignTemp, it uses its own notion of "trivial" -- expressions, which are wrong here. -- this is a NonPtr because it only duplicates an existing - reg <- newTemp (cmmExprType e) --TODO FIXME NOW + reg <- newTemp (cmmExprType dflags e) --TODO FIXME NOW emitAssign (CmmLocal reg) e return (CmmReg (CmmLocal reg)) @@ -278,11 +279,11 @@ maybe_assign_temp e saveThreadState :: DynFlags -> CmmAGraph saveThreadState dflags = -- CurrentTSO->stackobj->sp = Sp; - mkStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO (tso_stackobj dflags)) bWord) (stack_SP dflags)) stgSp - <*> closeNursery + mkStore (cmmOffset dflags (CmmLoad (cmmOffset dflags stgCurrentTSO (tso_stackobj dflags)) (bWord dflags)) (stack_SP dflags)) stgSp + <*> closeNursery dflags -- and save the current cost centre stack in the TSO when profiling: <*> if dopt Opt_SccProfilingOn dflags then - mkStore (cmmOffset stgCurrentTSO (tso_CCCS dflags)) curCCS + mkStore (cmmOffset dflags stgCurrentTSO (tso_CCCS dflags)) curCCS else mkNop emitSaveThreadState :: BlockId -> FCode () @@ -290,74 +291,75 @@ emitSaveThreadState bid = do dflags <- getDynFlags -- CurrentTSO->stackobj->sp = Sp; - emitStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO (tso_stackobj dflags)) bWord) (stack_SP dflags)) - (CmmStackSlot (Young bid) (widthInBytes (typeWidth gcWord))) - emit closeNursery + emitStore (cmmOffset dflags (CmmLoad (cmmOffset dflags stgCurrentTSO (tso_stackobj dflags)) (bWord dflags)) (stack_SP dflags)) + (CmmStackSlot (Young bid) (widthInBytes (typeWidth (gcWord dflags)))) + emit $ closeNursery dflags -- and save the current cost centre stack in the TSO when profiling: when (dopt Opt_SccProfilingOn dflags) $ - emitStore (cmmOffset stgCurrentTSO (tso_CCCS dflags)) curCCS + emitStore (cmmOffset dflags stgCurrentTSO (tso_CCCS dflags)) curCCS -- CurrentNursery->free = Hp+1; -closeNursery :: CmmAGraph -closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1) +closeNursery :: DynFlags -> CmmAGraph +closeNursery dflags = mkStore (nursery_bdescr_free dflags) (cmmOffsetW dflags stgHp 1) loadThreadState :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph loadThreadState dflags tso stack = do - -- tso <- newTemp gcWord -- TODO FIXME NOW - -- stack <- newTemp gcWord -- TODO FIXME NOW + -- tso <- newTemp (gcWord dflags) -- TODO FIXME NOW + -- stack <- newTemp (gcWord dflags) -- TODO FIXME NOW catAGraphs [ -- tso = CurrentTSO; mkAssign (CmmLocal tso) stgCurrentTSO, -- stack = tso->stackobj; - mkAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) bWord), + mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)), -- Sp = stack->sp; - mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) (stack_SP dflags)) bWord), + mkAssign sp (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)), -- SpLim = stack->stack + RESERVED_STACK_WORDS; - mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) (stack_STACK dflags)) - rESERVED_STACK_WORDS), - openNursery, + mkAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags)) + (rESERVED_STACK_WORDS dflags)), + openNursery dflags, -- and load the current cost centre stack from the TSO when profiling: if dopt Opt_SccProfilingOn dflags then storeCurCCS - (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) ccsType) + (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) (ccsType dflags)) else mkNop] emitLoadThreadState :: LocalReg -> LocalReg -> FCode () emitLoadThreadState tso stack = do dflags <- getDynFlags emit $ loadThreadState dflags tso stack -openNursery :: CmmAGraph -openNursery = catAGraphs [ +openNursery :: DynFlags -> CmmAGraph +openNursery dflags = catAGraphs [ -- Hp = CurrentNursery->free - 1; - mkAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)), + mkAssign hp (cmmOffsetW dflags (CmmLoad (nursery_bdescr_free dflags) (bWord dflags)) (-1)), -- HpLim = CurrentNursery->start + -- CurrentNursery->blocks*BLOCK_SIZE_W - 1; mkAssign hpLim - (cmmOffsetExpr - (CmmLoad nursery_bdescr_start bWord) - (cmmOffset - (CmmMachOp mo_wordMul [ - CmmMachOp (MO_SS_Conv W32 wordWidth) - [CmmLoad nursery_bdescr_blocks b32], - mkIntExpr bLOCK_SIZE + (cmmOffsetExpr dflags + (CmmLoad (nursery_bdescr_start dflags) (bWord dflags)) + (cmmOffset dflags + (CmmMachOp (mo_wordMul dflags) [ + CmmMachOp (MO_SS_Conv W32 (wordWidth dflags)) + [CmmLoad (nursery_bdescr_blocks dflags) b32], + mkIntExpr dflags (bLOCK_SIZE dflags) ]) (-1) ) ) ] emitOpenNursery :: FCode () -emitOpenNursery = emit openNursery +emitOpenNursery = do dflags <- getDynFlags + emit $ openNursery dflags -nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr -nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free -nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start -nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks +nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: DynFlags -> CmmExpr +nursery_bdescr_free dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_free dflags) +nursery_bdescr_start dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_start dflags) +nursery_bdescr_blocks dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_blocks dflags) tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: DynFlags -> ByteOff -tso_stackobj dflags = closureField dflags oFFSET_StgTSO_stackobj -tso_CCCS dflags = closureField dflags oFFSET_StgTSO_cccs -stack_STACK dflags = closureField dflags oFFSET_StgStack_stack -stack_SP dflags = closureField dflags oFFSET_StgStack_sp +tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags) +tso_CCCS dflags = closureField dflags (oFFSET_StgTSO_cccs dflags) +stack_STACK dflags = closureField dflags (oFFSET_StgStack_stack dflags) +stack_SP dflags = closureField dflags (oFFSET_StgStack_sp dflags) closureField :: DynFlags -> ByteOff -> ByteOff @@ -405,10 +407,10 @@ getFCallArgs args add_shim :: DynFlags -> Type -> CmmExpr -> CmmExpr add_shim dflags arg_ty expr | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon - = cmmOffsetB expr (arrPtrsHdrSize dflags) + = cmmOffsetB dflags expr (arrPtrsHdrSize dflags) | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon - = cmmOffsetB expr (arrWordsHdrSize dflags) + = cmmOffsetB dflags expr (arrWordsHdrSize dflags) | otherwise = expr where diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index b82064e0ec..a19810b6fb 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -140,9 +140,9 @@ emitSetDynHdr base info_ptr ccs hpStore :: CmmExpr -> [CmmExpr] -> [VirtualHpOffset] -> FCode () -- Store the item (expr,off) in base[off] hpStore base vals offs - = emit (catAGraphs (zipWith mk_store vals offs)) - where - mk_store val off = mkStore (cmmOffsetW base off) val + = do dflags <- getDynFlags + let mk_store val off = mkStore (cmmOffsetW dflags base off) val + emit (catAGraphs (zipWith mk_store vals offs)) ----------------------------------------------------------- @@ -181,7 +181,7 @@ mkStaticClosureFields dflags info_tbl ccs caf_refs payload padding | not is_caf = [] - | otherwise = ASSERT(null payload) [mkIntCLit 0] + | otherwise = ASSERT(null payload) [mkIntCLit dflags 0] static_link_field | is_caf || staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl @@ -190,15 +190,15 @@ mkStaticClosureFields dflags info_tbl ccs caf_refs payload = [] saved_info_field - | is_caf = [mkIntCLit 0] + | is_caf = [mkIntCLit dflags 0] | otherwise = [] -- For a static constructor which has NoCafRefs, we set the -- static link field to a non-zero value so the garbage -- collector will ignore it. static_link_value - | mayHaveCafRefs caf_refs = mkIntCLit 0 - | otherwise = mkIntCLit 1 -- No CAF refs + | mayHaveCafRefs caf_refs = mkIntCLit dflags 0 + | otherwise = mkIntCLit dflags 1 -- No CAF refs mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit] @@ -206,7 +206,7 @@ mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit] mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info_field = [CmmLabel info_lbl] ++ variable_header_words - ++ concatMap padLitToWord payload + ++ concatMap (padLitToWord dflags) payload ++ padding ++ static_link_field ++ saved_info_field @@ -219,9 +219,9 @@ mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info -- JD: Simon had ellided this padding, but without it the C back end asserts -- failure. Maybe it's a bad assertion, and this padding is indeed unnecessary? -padLitToWord :: CmmLit -> [CmmLit] -padLitToWord lit = lit : padding pad_length - where width = typeWidth (cmmLitType lit) +padLitToWord :: DynFlags -> CmmLit -> [CmmLit] +padLitToWord dflags lit = lit : padding pad_length + where width = typeWidth (cmmLitType dflags lit) pad_length = wORD_SIZE - widthInBytes width :: Int padding n | n <= 0 = [] @@ -401,9 +401,9 @@ entryHeapCheck cl_info nodeSet arity args code W32 -> Just (sLit "stg_gc_f1") W64 -> Just (sLit "stg_gc_d1") _other -> Nothing - | width == wordWidth = Just (mkGcLabel "stg_gc_unbx_r1") - | width == W64 = Just (mkGcLabel "stg_gc_l1") - | otherwise = Nothing + | width == wordWidth dflags = Just (mkGcLabel "stg_gc_unbx_r1") + | width == W64 = Just (mkGcLabel "stg_gc_l1") + | otherwise = Nothing where ty = localRegType reg width = typeWidth ty @@ -437,11 +437,11 @@ entryHeapCheck cl_info nodeSet arity args code -- else we do a normal call to stg_gc_noregs altHeapCheck :: [LocalReg] -> FCode a -> FCode a -altHeapCheck regs code - = case cannedGCEntryPoint regs of +altHeapCheck regs code = do + dflags <- getDynFlags + case cannedGCEntryPoint dflags regs of Nothing -> genericGC code Just gc -> do - dflags <- getDynFlags lret <- newLabelC let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) regs lcont <- newLabelC @@ -451,9 +451,10 @@ altHeapCheck regs code altHeapCheckReturnsTo :: [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a altHeapCheckReturnsTo regs lret off code - = case cannedGCEntryPoint regs of - Nothing -> genericGC code - Just gc -> cannedGCReturnsTo True gc regs lret off code + = do dflags <- getDynFlags + case cannedGCEntryPoint dflags regs of + Nothing -> genericGC code + Just gc -> cannedGCReturnsTo True gc regs lret off code cannedGCReturnsTo :: Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff -> FCode a @@ -478,8 +479,8 @@ genericGC code call <- mkCall generic_gc (GC, GC) [] [] updfr_sz (0,[]) heapCheck False (call <*> mkBranch lretry) code -cannedGCEntryPoint :: [LocalReg] -> Maybe CmmExpr -cannedGCEntryPoint regs +cannedGCEntryPoint :: DynFlags -> [LocalReg] -> Maybe CmmExpr +cannedGCEntryPoint dflags regs = case regs of [] -> Just (mkGcLabel "stg_gc_noregs") [reg] @@ -489,9 +490,9 @@ cannedGCEntryPoint regs W64 -> Just (mkGcLabel "stg_gc_d1") _ -> Nothing - | width == wordWidth -> Just (mkGcLabel "stg_gc_unbx_r1") - | width == W64 -> Just (mkGcLabel "stg_gc_l1") - | otherwise -> Nothing + | width == wordWidth dflags -> Just (mkGcLabel "stg_gc_unbx_r1") + | width == W64 -> Just (mkGcLabel "stg_gc_l1") + | otherwise -> Nothing where ty = localRegType reg width = typeWidth ty @@ -540,9 +541,27 @@ do_checks :: Bool -- Should we check the stack? -> CmmAGraph -- What to do on failure -> FCode () do_checks checkStack alloc do_gc = do + dflags <- getDynFlags + let + alloc_lit = mkIntExpr dflags (alloc*wORD_SIZE) -- Bytes + bump_hp = cmmOffsetExprB dflags (CmmReg hpReg) alloc_lit + + -- Sp overflow if (Sp - CmmHighStack < SpLim) + sp_oflo = CmmMachOp (mo_wordULt dflags) + [CmmMachOp (MO_Sub (typeWidth (cmmRegType dflags spReg))) + [CmmReg spReg, CmmLit CmmHighStackMark], + CmmReg spLimReg] + + -- Hp overflow if (Hp > HpLim) + -- (Hp has been incremented by now) + -- HpLim points to the LAST WORD of valid allocation space. + hp_oflo = CmmMachOp (mo_wordUGt dflags) + [CmmReg hpReg, CmmReg (CmmGlobal HpLim)] + + alloc_n = mkAssign (CmmGlobal HpAlloc) alloc_lit gc_id <- newLabelC - when checkStack $ + when checkStack $ do emit =<< mkCmmIfGoto sp_oflo gc_id when (alloc /= 0) $ do @@ -558,23 +577,6 @@ do_checks checkStack alloc do_gc = do -- stack check succeeds. Otherwise we might end up -- with slop at the end of the current block, which can -- confuse the LDV profiler. - where - alloc_lit = mkIntExpr (alloc*wORD_SIZE) -- Bytes - bump_hp = cmmOffsetExprB (CmmReg hpReg) alloc_lit - - -- Sp overflow if (Sp - CmmHighStack < SpLim) - sp_oflo = CmmMachOp mo_wordULt - [CmmMachOp (MO_Sub (typeWidth (cmmRegType spReg))) - [CmmReg spReg, CmmLit CmmHighStackMark], - CmmReg spLimReg] - - -- Hp overflow if (Hp > HpLim) - -- (Hp has been incremented by now) - -- HpLim points to the LAST WORD of valid allocation space. - hp_oflo = CmmMachOp mo_wordUGt - [CmmReg hpReg, CmmReg (CmmGlobal HpLim)] - - alloc_n = mkAssign (CmmGlobal HpAlloc) alloc_lit {- diff --git a/compiler/codeGen/StgCmmHpc.hs b/compiler/codeGen/StgCmmHpc.hs index 8f4c8d9223..cb60e9dd71 100644 --- a/compiler/codeGen/StgCmmHpc.hs +++ b/compiler/codeGen/StgCmmHpc.hs @@ -19,14 +19,14 @@ import StgCmmUtils import HscTypes import DynFlags -mkTickBox :: Module -> Int -> CmmAGraph -mkTickBox mod n +mkTickBox :: DynFlags -> Module -> Int -> CmmAGraph +mkTickBox dflags mod n = mkStore tick_box (CmmMachOp (MO_Add W64) [ CmmLoad tick_box b64 , CmmLit (CmmInt 1 W64) ]) where - tick_box = cmmIndex W64 + tick_box = cmmIndex dflags W64 (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod) n diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index e20e4a29bd..a7426284a3 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -527,13 +527,12 @@ emitClosureProcAndInfoTable :: Bool -- top-level? -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body -> FCode () emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body - = do { + = do { dflags <- getDynFlags -- Bind the binder itself, but only if it's not a top-level -- binding. We need non-top let-bindings to refer to the -- top-level binding, which this binding would incorrectly shadow. - ; node <- if top_lvl then return $ idToReg (NonVoid bndr) + ; node <- if top_lvl then return $ idToReg dflags (NonVoid bndr) else bindToReg (NonVoid bndr) lf_info - ; dflags <- getDynFlags ; let node_points = nodeMustPointToIt dflags lf_info ; arg_regs <- bindArgsToRegs args ; let args' = if node_points then (node : arg_regs) else arg_regs @@ -592,16 +591,16 @@ stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2*wORD_SIZE + hALF_WORD_SIZ -- ------------------------------------------------------------------------- -closureInfoPtr :: CmmExpr -> CmmExpr +closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr -- Takes a closure pointer and returns the info table pointer -closureInfoPtr e = CmmLoad e bWord +closureInfoPtr dflags e = CmmLoad e (bWord dflags) entryCode :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info pointer (the first word of a closure) -- and returns its entry code entryCode dflags e | tablesNextToCode dflags = e - | otherwise = CmmLoad e bWord + | otherwise = CmmLoad e (bWord dflags) getConstrTag :: DynFlags -> CmmExpr -> CmmExpr -- Takes a closure pointer, and return the *zero-indexed* @@ -609,25 +608,25 @@ getConstrTag :: DynFlags -> CmmExpr -> CmmExpr -- This lives in the SRT field of the info table -- (constructors don't need SRTs). getConstrTag dflags closure_ptr - = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableConstrTag dflags info_table] + = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table] where - info_table = infoTable dflags (closureInfoPtr closure_ptr) + info_table = infoTable dflags (closureInfoPtr dflags closure_ptr) cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr -- Takes a closure pointer, and return the closure type -- obtained from the info table cmmGetClosureType dflags closure_ptr - = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableClosureType dflags info_table] + = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table] where - info_table = infoTable dflags (closureInfoPtr closure_ptr) + info_table = infoTable dflags (closureInfoPtr dflags closure_ptr) infoTable :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info pointer (the first word of a closure) -- and returns a pointer to the first word of the standard-form -- info table, excluding the entry-code word (if present) infoTable dflags info_ptr - | tablesNextToCode dflags = cmmOffsetB info_ptr (- stdInfoTableSizeB dflags) - | otherwise = cmmOffsetW info_ptr 1 -- Past the entry code pointer + | tablesNextToCode dflags = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags) + | otherwise = cmmOffsetW dflags info_ptr 1 -- Past the entry code pointer infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the constr tag @@ -638,21 +637,21 @@ infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the srt_bitmap -- field of the info table infoTableSrtBitmap dflags info_tbl - = CmmLoad (cmmOffsetB info_tbl (stdSrtBitmapOffset dflags)) bHalfWord + = CmmLoad (cmmOffsetB dflags info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord dflags) infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the closure type -- field of the info table. infoTableClosureType dflags info_tbl - = CmmLoad (cmmOffsetB info_tbl (stdClosureTypeOffset dflags)) bHalfWord + = CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags) infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr infoTablePtrs dflags info_tbl - = CmmLoad (cmmOffsetB info_tbl (stdPtrsOffset dflags)) bHalfWord + = CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags) infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr infoTableNonPtrs dflags info_tbl - = CmmLoad (cmmOffsetB info_tbl (stdNonPtrsOffset dflags)) bHalfWord + = CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags) funInfoTable :: DynFlags -> CmmExpr -> CmmExpr -- Takes the info pointer of a function, @@ -660,8 +659,8 @@ funInfoTable :: DynFlags -> CmmExpr -> CmmExpr -- in the info table. funInfoTable dflags info_ptr | tablesNextToCode dflags - = cmmOffsetB info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev) + = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags) | otherwise - = cmmOffsetW info_ptr (1 + stdInfoTableSizeW dflags) + = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags) -- Past the entry code pointer diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 39bd1feef1..fb290d8e96 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -283,15 +283,15 @@ initCgInfoDown dflags mod = MkCgInfoDown { cgd_dflags = dflags, cgd_mod = mod, cgd_statics = emptyVarEnv, - cgd_updfr_off = initUpdFrameOff, + cgd_updfr_off = initUpdFrameOff dflags, cgd_ticky = mkTopTickyCtrLabel, cgd_sequel = initSequel } initSequel :: Sequel initSequel = Return False -initUpdFrameOff :: UpdFrameOffset -initUpdFrameOff = widthInBytes wordWidth -- space for the RA +initUpdFrameOff :: DynFlags -> UpdFrameOffset +initUpdFrameOff dflags = widthInBytes (wordWidth dflags) -- space for the RA -------------------------------------------------------- @@ -518,11 +518,12 @@ forkClosureBody :: FCode () -> FCode () -- C-- from the fork is incorporated. forkClosureBody body_code - = do { info <- getInfoDown + = do { dflags <- getDynFlags + ; info <- getInfoDown ; us <- newUniqSupply ; state <- getState ; let body_info_down = info { cgd_sequel = initSequel - , cgd_updfr_off = initUpdFrameOff } + , cgd_updfr_off = initUpdFrameOff dflags } fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } ((),fork_state_out) = doFCode body_code body_info_down fork_state_in @@ -534,12 +535,13 @@ forkStatics :: FCode a -> FCode a -- The Abstract~C returned is attached to the current state, but the -- bindings and usage information is otherwise unchanged. forkStatics body_code - = do { info <- getInfoDown + = do { dflags <- getDynFlags + ; info <- getInfoDown ; us <- newUniqSupply ; state <- getState ; let rhs_info_down = info { cgd_statics = cgs_binds state , cgd_sequel = initSequel - , cgd_updfr_off = initUpdFrameOff } + , cgd_updfr_off = initUpdFrameOff dflags } (result, fork_state_out) = doFCode body_code rhs_info_down (initCgState us) ; setState (state `addCodeBlocksFrom` fork_state_out) @@ -680,7 +682,7 @@ emitProcWithConvention conv mb_info lbl args blocks ; us <- newUniqSupply ; let (offset, entry) = mkCallEntry dflags conv args blks = initUs_ us $ lgraphOfAGraph $ entry <*> blocks - ; let sinfo = StackInfo {arg_space = offset, updfr_space = Just initUpdFrameOff} + ; let sinfo = StackInfo {arg_space = offset, updfr_space = Just (initUpdFrameOff dflags)} tinfo = TopInfo {info_tbls = infos, stack_info=sinfo} proc_block = CmmProc tinfo lbl blks diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 6c6005e88a..0d5e3778bf 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -81,10 +81,11 @@ cgOpApp (StgFCallOp fcall _) stg_args res_ty cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty = ASSERT(isEnumerationTyCon tycon) - do { args' <- getNonVoidArgAmodes [arg] + do { dflags <- getDynFlags + ; args' <- getNonVoidArgAmodes [arg] ; let amode = case args' of [amode] -> amode _ -> panic "TagToEnumOp had void arg" - ; emitReturn [tagToClosure tycon amode] } + ; emitReturn [tagToClosure dflags tycon amode] } where -- If you're reading this code in the attempt to figure -- out why the compiler panic'ed here, it is probably because @@ -104,7 +105,8 @@ cgOpApp (StgPrimOp primop) args res_ty emitReturn [] | ReturnsPrim rep <- result_info - = do res <- newTemp (primRepCmmType rep) + = do dflags <- getDynFlags + res <- newTemp (primRepCmmType dflags rep) cgPrimOp [res] primop args emitReturn [CmmReg (CmmLocal res)] @@ -116,10 +118,11 @@ cgOpApp (StgPrimOp primop) args res_ty | ReturnsAlg tycon <- result_info , isEnumerationTyCon tycon -- c.f. cgExpr (...TagToEnumOp...) - = do tag_reg <- newTemp bWord - cgPrimOp [tag_reg] primop args - emitReturn [tagToClosure tycon - (CmmReg (CmmLocal tag_reg))] + = do dflags <- getDynFlags + tag_reg <- newTemp (bWord dflags) + cgPrimOp [tag_reg] primop args + emitReturn [tagToClosure dflags tycon + (CmmReg (CmmLocal tag_reg))] | otherwise = panic "cgPrimop" where @@ -137,15 +140,17 @@ cgPrimOp :: [LocalReg] -- where to put the results -> FCode () cgPrimOp results op args - = do arg_exprs <- getNonVoidArgAmodes args - emitPrimOp results op arg_exprs + = do dflags <- getDynFlags + arg_exprs <- getNonVoidArgAmodes args + emitPrimOp dflags results op arg_exprs ------------------------------------------------------------------------ -- Emitting code for a primop ------------------------------------------------------------------------ -emitPrimOp :: [LocalReg] -- where to put the results +emitPrimOp :: DynFlags + -> [LocalReg] -- where to put the results -> PrimOp -- the op -> [CmmExpr] -- arguments -> FCode () @@ -153,7 +158,7 @@ emitPrimOp :: [LocalReg] -- where to put the results -- First we handle various awkward cases specially. The remaining -- easy cases are then handled by translateOp, defined below. -emitPrimOp [res_r,res_c] IntAddCOp [aa,bb] +emitPrimOp dflags [res_r,res_c] IntAddCOp [aa,bb] {- With some bit-twiddling, we can define int{Add,Sub}Czh portably in C, and without needing any comparisons. This may not be the @@ -175,19 +180,19 @@ emitPrimOp [res_r,res_c] IntAddCOp [aa,bb] -} = emit $ catAGraphs [ - mkAssign (CmmLocal res_r) (CmmMachOp mo_wordAdd [aa,bb]), + mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]), mkAssign (CmmLocal res_c) $ - CmmMachOp mo_wordUShr [ - CmmMachOp mo_wordAnd [ - CmmMachOp mo_wordNot [CmmMachOp mo_wordXor [aa,bb]], - CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)] + CmmMachOp (mo_wordUShr dflags) [ + CmmMachOp (mo_wordAnd dflags) [ + CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]], + CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] ], - mkIntExpr (wORD_SIZE_IN_BITS - 1) + mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) ] ] -emitPrimOp [res_r,res_c] IntSubCOp [aa,bb] +emitPrimOp dflags [res_r,res_c] IntSubCOp [aa,bb] {- Similarly: #define subIntCzh(r,c,a,b) \ { r = ((I_)(a)) - ((I_)(b)); \ @@ -198,19 +203,19 @@ emitPrimOp [res_r,res_c] IntSubCOp [aa,bb] c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1) -} = emit $ catAGraphs [ - mkAssign (CmmLocal res_r) (CmmMachOp mo_wordSub [aa,bb]), + mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]), mkAssign (CmmLocal res_c) $ - CmmMachOp mo_wordUShr [ - CmmMachOp mo_wordAnd [ - CmmMachOp mo_wordXor [aa,bb], - CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)] + CmmMachOp (mo_wordUShr dflags) [ + CmmMachOp (mo_wordAnd dflags) [ + CmmMachOp (mo_wordXor dflags) [aa,bb], + CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] ], - mkIntExpr (wORD_SIZE_IN_BITS - 1) + mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) ] ] -emitPrimOp [res] ParOp [arg] +emitPrimOp _ [res] ParOp [arg] = -- for now, just implement this in a C function -- later, we might want to inline it. @@ -219,37 +224,34 @@ emitPrimOp [res] ParOp [arg] (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))) [(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)] -emitPrimOp [res] SparkOp [arg] +emitPrimOp dflags [res] SparkOp [arg] = do -- returns the value of arg in res. We're going to therefore -- refer to arg twice (once to pass to newSpark(), and once to -- assign to res), so put it in a temporary. tmp <- assignTemp arg - tmp2 <- newTemp bWord + tmp2 <- newTemp (bWord dflags) emitCCall [(tmp2,NoHint)] (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))) [(CmmReg (CmmGlobal BaseReg), AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)] emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp)) -emitPrimOp [res] GetCCSOfOp [arg] - = do dflags <- getDynFlags - emitAssign (CmmLocal res) (val dflags) +emitPrimOp dflags [res] GetCCSOfOp [arg] + = emitAssign (CmmLocal res) val where - val dflags - | dopt Opt_SccProfilingOn dflags = costCentreFrom (cmmUntag arg) - | otherwise = CmmLit zeroCLit + val + | dopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg) + | otherwise = CmmLit (zeroCLit dflags) -emitPrimOp [res] GetCurrentCCSOp [_dummy_arg] +emitPrimOp _ [res] GetCurrentCCSOp [_dummy_arg] = emitAssign (CmmLocal res) curCCS -emitPrimOp [res] ReadMutVarOp [mutv] - = do dflags <- getDynFlags - emitAssign (CmmLocal res) (cmmLoadIndexW mutv (fixedHdrSize dflags) gcWord) +emitPrimOp dflags [res] ReadMutVarOp [mutv] + = emitAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSize dflags) (gcWord dflags)) -emitPrimOp [] WriteMutVarOp [mutv,var] - = do dflags <- getDynFlags - emitStore (cmmOffsetW mutv (fixedHdrSize dflags)) var +emitPrimOp dflags [] WriteMutVarOp [mutv,var] + = do emitStore (cmmOffsetW dflags mutv (fixedHdrSize dflags)) var emitCCall [{-no results-}] (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) @@ -257,53 +259,47 @@ emitPrimOp [] WriteMutVarOp [mutv,var] -- #define sizzeofByteArrayzh(r,a) \ -- r = ((StgArrWords *)(a))->bytes -emitPrimOp [res] SizeofByteArrayOp [arg] - = do dflags <- getDynFlags - emit $ - mkAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize dflags) bWord) +emitPrimOp dflags [res] SizeofByteArrayOp [arg] + = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSize dflags) (bWord dflags)) -- #define sizzeofMutableByteArrayzh(r,a) \ -- r = ((StgArrWords *)(a))->bytes -emitPrimOp [res] SizeofMutableByteArrayOp [arg] - = emitPrimOp [res] SizeofByteArrayOp [arg] +emitPrimOp dflags [res] SizeofMutableByteArrayOp [arg] + = emitPrimOp dflags [res] SizeofByteArrayOp [arg] -- #define touchzh(o) /* nothing */ -emitPrimOp res@[] TouchOp args@[_arg] +emitPrimOp _ res@[] TouchOp args@[_arg] = do emitPrimCall res MO_Touch args -- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) -emitPrimOp [res] ByteArrayContents_Char [arg] - = do dflags <- getDynFlags - emitAssign (CmmLocal res) (cmmOffsetB arg (arrWordsHdrSize dflags)) +emitPrimOp dflags [res] ByteArrayContents_Char [arg] + = emitAssign (CmmLocal res) (cmmOffsetB dflags arg (arrWordsHdrSize dflags)) -- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn) -emitPrimOp [res] StableNameToIntOp [arg] - = do dflags <- getDynFlags - emitAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize dflags) bWord) +emitPrimOp dflags [res] StableNameToIntOp [arg] + = emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSize dflags) (bWord dflags)) -- #define eqStableNamezh(r,sn1,sn2) \ -- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn)) -emitPrimOp [res] EqStableNameOp [arg1,arg2] - = do dflags <- getDynFlags - emitAssign (CmmLocal res) (CmmMachOp mo_wordEq [ - cmmLoadIndexW arg1 (fixedHdrSize dflags) bWord, - cmmLoadIndexW arg2 (fixedHdrSize dflags) bWord +emitPrimOp dflags [res] EqStableNameOp [arg1,arg2] + = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [ + cmmLoadIndexW dflags arg1 (fixedHdrSize dflags) (bWord dflags), + cmmLoadIndexW dflags arg2 (fixedHdrSize dflags) (bWord dflags) ]) -emitPrimOp [res] ReallyUnsafePtrEqualityOp [arg1,arg2] - = emitAssign (CmmLocal res) (CmmMachOp mo_wordEq [arg1,arg2]) +emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2] + = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2]) -- #define addrToHValuezh(r,a) r=(P_)a -emitPrimOp [res] AddrToAnyOp [arg] +emitPrimOp _ [res] AddrToAnyOp [arg] = emitAssign (CmmLocal res) arg -- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info)) -- Note: argument may be tagged! -emitPrimOp [res] DataToTagOp [arg] - = do dflags <- getDynFlags - emitAssign (CmmLocal res) (getConstrTag dflags (cmmUntag arg)) +emitPrimOp dflags [res] DataToTagOp [arg] + = emitAssign (CmmLocal res) (getConstrTag dflags (cmmUntag dflags arg)) {- Freezing arrays-of-ptrs requires changing an info table, for the benefit of the generational collector. It needs to scavenge mutable @@ -315,220 +311,218 @@ emitPrimOp [res] DataToTagOp [arg] -- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN0_info); -- r = a; -- } -emitPrimOp [res] UnsafeFreezeArrayOp [arg] +emitPrimOp _ [res] UnsafeFreezeArrayOp [arg] = emit $ catAGraphs [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)), mkAssign (CmmLocal res) arg ] -emitPrimOp [res] UnsafeFreezeArrayArrayOp [arg] +emitPrimOp _ [res] UnsafeFreezeArrayArrayOp [arg] = emit $ catAGraphs [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)), mkAssign (CmmLocal res) arg ] -- #define unsafeFreezzeByteArrayzh(r,a) r=(a) -emitPrimOp [res] UnsafeFreezeByteArrayOp [arg] +emitPrimOp _ [res] UnsafeFreezeByteArrayOp [arg] = emitAssign (CmmLocal res) arg -- Copying pointer arrays -emitPrimOp [] CopyArrayOp [src,src_off,dst,dst_off,n] = +emitPrimOp _ [] CopyArrayOp [src,src_off,dst,dst_off,n] = doCopyArrayOp src src_off dst dst_off n -emitPrimOp [] CopyMutableArrayOp [src,src_off,dst,dst_off,n] = +emitPrimOp _ [] CopyMutableArrayOp [src,src_off,dst,dst_off,n] = doCopyMutableArrayOp src src_off dst dst_off n -emitPrimOp [res] CloneArrayOp [src,src_off,n] = +emitPrimOp _ [res] CloneArrayOp [src,src_off,n] = emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n -emitPrimOp [res] CloneMutableArrayOp [src,src_off,n] = +emitPrimOp _ [res] CloneMutableArrayOp [src,src_off,n] = emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n -emitPrimOp [res] FreezeArrayOp [src,src_off,n] = +emitPrimOp _ [res] FreezeArrayOp [src,src_off,n] = emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n -emitPrimOp [res] ThawArrayOp [src,src_off,n] = +emitPrimOp _ [res] ThawArrayOp [src,src_off,n] = emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n -emitPrimOp [] CopyArrayArrayOp [src,src_off,dst,dst_off,n] = +emitPrimOp _ [] CopyArrayArrayOp [src,src_off,dst,dst_off,n] = doCopyArrayOp src src_off dst dst_off n -emitPrimOp [] CopyMutableArrayArrayOp [src,src_off,dst,dst_off,n] = +emitPrimOp _ [] CopyMutableArrayArrayOp [src,src_off,dst,dst_off,n] = doCopyMutableArrayOp src src_off dst dst_off n -- Reading/writing pointer arrays -emitPrimOp [res] ReadArrayOp [obj,ix] = doReadPtrArrayOp res obj ix -emitPrimOp [res] IndexArrayOp [obj,ix] = doReadPtrArrayOp res obj ix -emitPrimOp [] WriteArrayOp [obj,ix,v] = doWritePtrArrayOp obj ix v - -emitPrimOp [res] IndexArrayArrayOp_ByteArray [obj,ix] = doReadPtrArrayOp res obj ix -emitPrimOp [res] IndexArrayArrayOp_ArrayArray [obj,ix] = doReadPtrArrayOp res obj ix -emitPrimOp [res] ReadArrayArrayOp_ByteArray [obj,ix] = doReadPtrArrayOp res obj ix -emitPrimOp [res] ReadArrayArrayOp_MutableByteArray [obj,ix] = doReadPtrArrayOp res obj ix -emitPrimOp [res] ReadArrayArrayOp_ArrayArray [obj,ix] = doReadPtrArrayOp res obj ix -emitPrimOp [res] ReadArrayArrayOp_MutableArrayArray [obj,ix] = doReadPtrArrayOp res obj ix -emitPrimOp [] WriteArrayArrayOp_ByteArray [obj,ix,v] = doWritePtrArrayOp obj ix v -emitPrimOp [] WriteArrayArrayOp_MutableByteArray [obj,ix,v] = doWritePtrArrayOp obj ix v -emitPrimOp [] WriteArrayArrayOp_ArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v -emitPrimOp [] WriteArrayArrayOp_MutableArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v - -emitPrimOp [res] SizeofArrayOp [arg] - = do dflags <- getDynFlags - emit $ mkAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs) bWord) -emitPrimOp [res] SizeofMutableArrayOp [arg] - = emitPrimOp [res] SizeofArrayOp [arg] -emitPrimOp [res] SizeofArrayArrayOp [arg] - = emitPrimOp [res] SizeofArrayOp [arg] -emitPrimOp [res] SizeofMutableArrayArrayOp [arg] - = emitPrimOp [res] SizeofArrayOp [arg] +emitPrimOp _ [res] ReadArrayOp [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp _ [res] IndexArrayOp [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp _ [] WriteArrayOp [obj,ix,v] = doWritePtrArrayOp obj ix v + +emitPrimOp _ [res] IndexArrayArrayOp_ByteArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp _ [res] IndexArrayArrayOp_ArrayArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp _ [res] ReadArrayArrayOp_ByteArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp _ [res] ReadArrayArrayOp_MutableByteArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp _ [res] ReadArrayArrayOp_ArrayArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp _ [res] ReadArrayArrayOp_MutableArrayArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp _ [] WriteArrayArrayOp_ByteArray [obj,ix,v] = doWritePtrArrayOp obj ix v +emitPrimOp _ [] WriteArrayArrayOp_MutableByteArray [obj,ix,v] = doWritePtrArrayOp obj ix v +emitPrimOp _ [] WriteArrayArrayOp_ArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v +emitPrimOp _ [] WriteArrayArrayOp_MutableArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v + +emitPrimOp dflags [res] SizeofArrayOp [arg] + = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags) (bWord dflags)) +emitPrimOp dflags [res] SizeofMutableArrayOp [arg] + = emitPrimOp dflags [res] SizeofArrayOp [arg] +emitPrimOp dflags [res] SizeofArrayArrayOp [arg] + = emitPrimOp dflags [res] SizeofArrayOp [arg] +emitPrimOp dflags [res] SizeofMutableArrayArrayOp [arg] + = emitPrimOp dflags [res] SizeofArrayOp [arg] -- IndexXXXoffAddr -emitPrimOp res IndexOffAddrOp_Char args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res IndexOffAddrOp_WideChar args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res IndexOffAddrOp_Int args = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res IndexOffAddrOp_Word args = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res IndexOffAddrOp_Addr args = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res IndexOffAddrOp_Float args = doIndexOffAddrOp Nothing f32 res args -emitPrimOp res IndexOffAddrOp_Double args = doIndexOffAddrOp Nothing f64 res args -emitPrimOp res IndexOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res IndexOffAddrOp_Int8 args = doIndexOffAddrOp (Just mo_s_8ToWord) b8 res args -emitPrimOp res IndexOffAddrOp_Int16 args = doIndexOffAddrOp (Just mo_s_16ToWord) b16 res args -emitPrimOp res IndexOffAddrOp_Int32 args = doIndexOffAddrOp (Just mo_s_32ToWord) b32 res args -emitPrimOp res IndexOffAddrOp_Int64 args = doIndexOffAddrOp Nothing b64 res args -emitPrimOp res IndexOffAddrOp_Word8 args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res IndexOffAddrOp_Word16 args = doIndexOffAddrOp (Just mo_u_16ToWord) b16 res args -emitPrimOp res IndexOffAddrOp_Word32 args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res IndexOffAddrOp_Word64 args = doIndexOffAddrOp Nothing b64 res args +emitPrimOp dflags res IndexOffAddrOp_Char args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexOffAddrOp_WideChar args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp dflags res IndexOffAddrOp_Int args = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexOffAddrOp_Word args = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexOffAddrOp_Addr args = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp _ res IndexOffAddrOp_Float args = doIndexOffAddrOp Nothing f32 res args +emitPrimOp _ res IndexOffAddrOp_Double args = doIndexOffAddrOp Nothing f64 res args +emitPrimOp dflags res IndexOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexOffAddrOp_Int8 args = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexOffAddrOp_Int16 args = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexOffAddrOp_Int32 args = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args +emitPrimOp _ res IndexOffAddrOp_Int64 args = doIndexOffAddrOp Nothing b64 res args +emitPrimOp dflags res IndexOffAddrOp_Word8 args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexOffAddrOp_Word16 args = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexOffAddrOp_Word32 args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp _ res IndexOffAddrOp_Word64 args = doIndexOffAddrOp Nothing b64 res args -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr. -emitPrimOp res ReadOffAddrOp_Char args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res ReadOffAddrOp_WideChar args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res ReadOffAddrOp_Int args = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res ReadOffAddrOp_Word args = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res ReadOffAddrOp_Addr args = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res ReadOffAddrOp_Float args = doIndexOffAddrOp Nothing f32 res args -emitPrimOp res ReadOffAddrOp_Double args = doIndexOffAddrOp Nothing f64 res args -emitPrimOp res ReadOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res ReadOffAddrOp_Int8 args = doIndexOffAddrOp (Just mo_s_8ToWord) b8 res args -emitPrimOp res ReadOffAddrOp_Int16 args = doIndexOffAddrOp (Just mo_s_16ToWord) b16 res args -emitPrimOp res ReadOffAddrOp_Int32 args = doIndexOffAddrOp (Just mo_s_32ToWord) b32 res args -emitPrimOp res ReadOffAddrOp_Int64 args = doIndexOffAddrOp Nothing b64 res args -emitPrimOp res ReadOffAddrOp_Word8 args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res ReadOffAddrOp_Word16 args = doIndexOffAddrOp (Just mo_u_16ToWord) b16 res args -emitPrimOp res ReadOffAddrOp_Word32 args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res ReadOffAddrOp_Word64 args = doIndexOffAddrOp Nothing b64 res args +emitPrimOp dflags res ReadOffAddrOp_Char args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadOffAddrOp_WideChar args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp dflags res ReadOffAddrOp_Int args = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadOffAddrOp_Word args = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadOffAddrOp_Addr args = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp _ res ReadOffAddrOp_Float args = doIndexOffAddrOp Nothing f32 res args +emitPrimOp _ res ReadOffAddrOp_Double args = doIndexOffAddrOp Nothing f64 res args +emitPrimOp dflags res ReadOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadOffAddrOp_Int8 args = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadOffAddrOp_Int16 args = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadOffAddrOp_Int32 args = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args +emitPrimOp _ res ReadOffAddrOp_Int64 args = doIndexOffAddrOp Nothing b64 res args +emitPrimOp dflags res ReadOffAddrOp_Word8 args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadOffAddrOp_Word16 args = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadOffAddrOp_Word32 args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp _ res ReadOffAddrOp_Word64 args = doIndexOffAddrOp Nothing b64 res args -- IndexXXXArray -emitPrimOp res IndexByteArrayOp_Char args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res IndexByteArrayOp_WideChar args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res IndexByteArrayOp_Int args = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res IndexByteArrayOp_Word args = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res IndexByteArrayOp_Addr args = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res IndexByteArrayOp_Float args = doIndexByteArrayOp Nothing f32 res args -emitPrimOp res IndexByteArrayOp_Double args = doIndexByteArrayOp Nothing f64 res args -emitPrimOp res IndexByteArrayOp_StablePtr args = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res IndexByteArrayOp_Int8 args = doIndexByteArrayOp (Just mo_s_8ToWord) b8 res args -emitPrimOp res IndexByteArrayOp_Int16 args = doIndexByteArrayOp (Just mo_s_16ToWord) b16 res args -emitPrimOp res IndexByteArrayOp_Int32 args = doIndexByteArrayOp (Just mo_s_32ToWord) b32 res args -emitPrimOp res IndexByteArrayOp_Int64 args = doIndexByteArrayOp Nothing b64 res args -emitPrimOp res IndexByteArrayOp_Word8 args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res IndexByteArrayOp_Word16 args = doIndexByteArrayOp (Just mo_u_16ToWord) b16 res args -emitPrimOp res IndexByteArrayOp_Word32 args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res IndexByteArrayOp_Word64 args = doIndexByteArrayOp Nothing b64 res args +emitPrimOp dflags res IndexByteArrayOp_Char args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexByteArrayOp_WideChar args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp dflags res IndexByteArrayOp_Int args = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexByteArrayOp_Word args = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexByteArrayOp_Addr args = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp _ res IndexByteArrayOp_Float args = doIndexByteArrayOp Nothing f32 res args +emitPrimOp _ res IndexByteArrayOp_Double args = doIndexByteArrayOp Nothing f64 res args +emitPrimOp dflags res IndexByteArrayOp_StablePtr args = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexByteArrayOp_Int8 args = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexByteArrayOp_Int16 args = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexByteArrayOp_Int32 args = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args +emitPrimOp _ res IndexByteArrayOp_Int64 args = doIndexByteArrayOp Nothing b64 res args +emitPrimOp dflags res IndexByteArrayOp_Word8 args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexByteArrayOp_Word16 args = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexByteArrayOp_Word32 args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp _ res IndexByteArrayOp_Word64 args = doIndexByteArrayOp Nothing b64 res args -- ReadXXXArray, identical to IndexXXXArray. -emitPrimOp res ReadByteArrayOp_Char args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res ReadByteArrayOp_WideChar args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res ReadByteArrayOp_Int args = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res ReadByteArrayOp_Word args = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res ReadByteArrayOp_Addr args = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res ReadByteArrayOp_Float args = doIndexByteArrayOp Nothing f32 res args -emitPrimOp res ReadByteArrayOp_Double args = doIndexByteArrayOp Nothing f64 res args -emitPrimOp res ReadByteArrayOp_StablePtr args = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res ReadByteArrayOp_Int8 args = doIndexByteArrayOp (Just mo_s_8ToWord) b8 res args -emitPrimOp res ReadByteArrayOp_Int16 args = doIndexByteArrayOp (Just mo_s_16ToWord) b16 res args -emitPrimOp res ReadByteArrayOp_Int32 args = doIndexByteArrayOp (Just mo_s_32ToWord) b32 res args -emitPrimOp res ReadByteArrayOp_Int64 args = doIndexByteArrayOp Nothing b64 res args -emitPrimOp res ReadByteArrayOp_Word8 args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res ReadByteArrayOp_Word16 args = doIndexByteArrayOp (Just mo_u_16ToWord) b16 res args -emitPrimOp res ReadByteArrayOp_Word32 args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res ReadByteArrayOp_Word64 args = doIndexByteArrayOp Nothing b64 res args +emitPrimOp dflags res ReadByteArrayOp_Char args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadByteArrayOp_WideChar args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp dflags res ReadByteArrayOp_Int args = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadByteArrayOp_Word args = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadByteArrayOp_Addr args = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp _ res ReadByteArrayOp_Float args = doIndexByteArrayOp Nothing f32 res args +emitPrimOp _ res ReadByteArrayOp_Double args = doIndexByteArrayOp Nothing f64 res args +emitPrimOp dflags res ReadByteArrayOp_StablePtr args = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadByteArrayOp_Int8 args = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadByteArrayOp_Int16 args = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadByteArrayOp_Int32 args = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args +emitPrimOp _ res ReadByteArrayOp_Int64 args = doIndexByteArrayOp Nothing b64 res args +emitPrimOp dflags res ReadByteArrayOp_Word8 args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadByteArrayOp_Word16 args = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadByteArrayOp_Word32 args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp _ res ReadByteArrayOp_Word64 args = doIndexByteArrayOp Nothing b64 res args -- WriteXXXoffAddr -emitPrimOp res WriteOffAddrOp_Char args = doWriteOffAddrOp (Just mo_WordTo8) res args -emitPrimOp res WriteOffAddrOp_WideChar args = doWriteOffAddrOp (Just mo_WordTo32) res args -emitPrimOp res WriteOffAddrOp_Int args = doWriteOffAddrOp Nothing res args -emitPrimOp res WriteOffAddrOp_Word args = doWriteOffAddrOp Nothing res args -emitPrimOp res WriteOffAddrOp_Addr args = doWriteOffAddrOp Nothing res args -emitPrimOp res WriteOffAddrOp_Float args = doWriteOffAddrOp Nothing res args -emitPrimOp res WriteOffAddrOp_Double args = doWriteOffAddrOp Nothing res args -emitPrimOp res WriteOffAddrOp_StablePtr args = doWriteOffAddrOp Nothing res args -emitPrimOp res WriteOffAddrOp_Int8 args = doWriteOffAddrOp (Just mo_WordTo8) res args -emitPrimOp res WriteOffAddrOp_Int16 args = doWriteOffAddrOp (Just mo_WordTo16) res args -emitPrimOp res WriteOffAddrOp_Int32 args = doWriteOffAddrOp (Just mo_WordTo32) res args -emitPrimOp res WriteOffAddrOp_Int64 args = doWriteOffAddrOp Nothing res args -emitPrimOp res WriteOffAddrOp_Word8 args = doWriteOffAddrOp (Just mo_WordTo8) res args -emitPrimOp res WriteOffAddrOp_Word16 args = doWriteOffAddrOp (Just mo_WordTo16) res args -emitPrimOp res WriteOffAddrOp_Word32 args = doWriteOffAddrOp (Just mo_WordTo32) res args -emitPrimOp res WriteOffAddrOp_Word64 args = doWriteOffAddrOp Nothing res args +emitPrimOp dflags res WriteOffAddrOp_Char args = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) res args +emitPrimOp dflags res WriteOffAddrOp_WideChar args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) res args +emitPrimOp _ res WriteOffAddrOp_Int args = doWriteOffAddrOp Nothing res args +emitPrimOp _ res WriteOffAddrOp_Word args = doWriteOffAddrOp Nothing res args +emitPrimOp _ res WriteOffAddrOp_Addr args = doWriteOffAddrOp Nothing res args +emitPrimOp _ res WriteOffAddrOp_Float args = doWriteOffAddrOp Nothing res args +emitPrimOp _ res WriteOffAddrOp_Double args = doWriteOffAddrOp Nothing res args +emitPrimOp _ res WriteOffAddrOp_StablePtr args = doWriteOffAddrOp Nothing res args +emitPrimOp dflags res WriteOffAddrOp_Int8 args = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) res args +emitPrimOp dflags res WriteOffAddrOp_Int16 args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) res args +emitPrimOp dflags res WriteOffAddrOp_Int32 args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) res args +emitPrimOp _ res WriteOffAddrOp_Int64 args = doWriteOffAddrOp Nothing res args +emitPrimOp dflags res WriteOffAddrOp_Word8 args = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) res args +emitPrimOp dflags res WriteOffAddrOp_Word16 args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) res args +emitPrimOp dflags res WriteOffAddrOp_Word32 args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) res args +emitPrimOp _ res WriteOffAddrOp_Word64 args = doWriteOffAddrOp Nothing res args -- WriteXXXArray -emitPrimOp res WriteByteArrayOp_Char args = doWriteByteArrayOp (Just mo_WordTo8) res args -emitPrimOp res WriteByteArrayOp_WideChar args = doWriteByteArrayOp (Just mo_WordTo32) res args -emitPrimOp res WriteByteArrayOp_Int args = doWriteByteArrayOp Nothing res args -emitPrimOp res WriteByteArrayOp_Word args = doWriteByteArrayOp Nothing res args -emitPrimOp res WriteByteArrayOp_Addr args = doWriteByteArrayOp Nothing res args -emitPrimOp res WriteByteArrayOp_Float args = doWriteByteArrayOp Nothing res args -emitPrimOp res WriteByteArrayOp_Double args = doWriteByteArrayOp Nothing res args -emitPrimOp res WriteByteArrayOp_StablePtr args = doWriteByteArrayOp Nothing res args -emitPrimOp res WriteByteArrayOp_Int8 args = doWriteByteArrayOp (Just mo_WordTo8) res args -emitPrimOp res WriteByteArrayOp_Int16 args = doWriteByteArrayOp (Just mo_WordTo16) res args -emitPrimOp res WriteByteArrayOp_Int32 args = doWriteByteArrayOp (Just mo_WordTo32) res args -emitPrimOp res WriteByteArrayOp_Int64 args = doWriteByteArrayOp Nothing res args -emitPrimOp res WriteByteArrayOp_Word8 args = doWriteByteArrayOp (Just mo_WordTo8) res args -emitPrimOp res WriteByteArrayOp_Word16 args = doWriteByteArrayOp (Just mo_WordTo16) res args -emitPrimOp res WriteByteArrayOp_Word32 args = doWriteByteArrayOp (Just mo_WordTo32) res args -emitPrimOp res WriteByteArrayOp_Word64 args = doWriteByteArrayOp Nothing res args +emitPrimOp dflags res WriteByteArrayOp_Char args = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) res args +emitPrimOp dflags res WriteByteArrayOp_WideChar args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) res args +emitPrimOp _ res WriteByteArrayOp_Int args = doWriteByteArrayOp Nothing res args +emitPrimOp _ res WriteByteArrayOp_Word args = doWriteByteArrayOp Nothing res args +emitPrimOp _ res WriteByteArrayOp_Addr args = doWriteByteArrayOp Nothing res args +emitPrimOp _ res WriteByteArrayOp_Float args = doWriteByteArrayOp Nothing res args +emitPrimOp _ res WriteByteArrayOp_Double args = doWriteByteArrayOp Nothing res args +emitPrimOp _ res WriteByteArrayOp_StablePtr args = doWriteByteArrayOp Nothing res args +emitPrimOp dflags res WriteByteArrayOp_Int8 args = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) res args +emitPrimOp dflags res WriteByteArrayOp_Int16 args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) res args +emitPrimOp dflags res WriteByteArrayOp_Int32 args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) res args +emitPrimOp _ res WriteByteArrayOp_Int64 args = doWriteByteArrayOp Nothing res args +emitPrimOp dflags res WriteByteArrayOp_Word8 args = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) res args +emitPrimOp dflags res WriteByteArrayOp_Word16 args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) res args +emitPrimOp dflags res WriteByteArrayOp_Word32 args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) res args +emitPrimOp _ res WriteByteArrayOp_Word64 args = doWriteByteArrayOp Nothing res args -- Copying and setting byte arrays -emitPrimOp [] CopyByteArrayOp [src,src_off,dst,dst_off,n] = +emitPrimOp _ [] CopyByteArrayOp [src,src_off,dst,dst_off,n] = doCopyByteArrayOp src src_off dst dst_off n -emitPrimOp [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] = +emitPrimOp _ [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] = doCopyMutableByteArrayOp src src_off dst dst_off n -emitPrimOp [] SetByteArrayOp [ba,off,len,c] = +emitPrimOp _ [] SetByteArrayOp [ba,off,len,c] = doSetByteArrayOp ba off len c -- Population count -emitPrimOp [res] PopCnt8Op [w] = - emitPopCntCall res (CmmMachOp mo_WordTo8 [w]) W8 -emitPrimOp [res] PopCnt16Op [w] = - emitPopCntCall res (CmmMachOp mo_WordTo16 [w]) W16 -emitPrimOp [res] PopCnt32Op [w] = - emitPopCntCall res (CmmMachOp mo_WordTo32 [w]) W32 -emitPrimOp [res] PopCnt64Op [w] = +emitPrimOp dflags [res] PopCnt8Op [w] = + emitPopCntCall res (CmmMachOp (mo_WordTo8 dflags) [w]) W8 +emitPrimOp dflags [res] PopCnt16Op [w] = + emitPopCntCall res (CmmMachOp (mo_WordTo16 dflags) [w]) W16 +emitPrimOp dflags [res] PopCnt32Op [w] = + emitPopCntCall res (CmmMachOp (mo_WordTo32 dflags) [w]) W32 +emitPrimOp _ [res] PopCnt64Op [w] = emitPopCntCall res w W64 -- arg always has type W64, no need to narrow -emitPrimOp [res] PopCntOp [w] = - emitPopCntCall res w wordWidth +emitPrimOp dflags [res] PopCntOp [w] = + emitPopCntCall res w (wordWidth dflags) -- The rest just translate straightforwardly -emitPrimOp [res] op [arg] +emitPrimOp dflags [res] op [arg] | nopOp op = emitAssign (CmmLocal res) arg | Just (mop,rep) <- narrowOp op = emitAssign (CmmLocal res) $ - CmmMachOp (mop rep wordWidth) [CmmMachOp (mop wordWidth rep) [arg]] + CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]] -emitPrimOp r@[res] op args +emitPrimOp dflags r@[res] op args | Just prim <- callishOp op = do emitPrimCall r prim args - | Just mop <- translateOp op + | Just mop <- translateOp dflags op = let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) in emit stmt -emitPrimOp results op args - = do dflags <- getDynFlags - case callishPrimOpSupported dflags op of +emitPrimOp dflags results op args + = case callishPrimOpSupported dflags op of Left op -> emit $ mkUnsafeCall (PrimTarget op) results args Right gen -> gen results args @@ -537,19 +531,19 @@ type GenericOp = [CmmFormal] -> [CmmActual] -> FCode () callishPrimOpSupported :: DynFlags -> PrimOp -> Either CallishMachOp GenericOp callishPrimOpSupported dflags op = case op of - IntQuotRemOp | ncg && x86ish -> Left (MO_S_QuotRem wordWidth) - | otherwise -> Right genericIntQuotRemOp + IntQuotRemOp | ncg && x86ish -> Left (MO_S_QuotRem (wordWidth dflags)) + | otherwise -> Right (genericIntQuotRemOp dflags) - WordQuotRemOp | ncg && x86ish -> Left (MO_U_QuotRem wordWidth) - | otherwise -> Right genericWordQuotRemOp + WordQuotRemOp | ncg && x86ish -> Left (MO_U_QuotRem (wordWidth dflags)) + | otherwise -> Right (genericWordQuotRemOp dflags) - WordQuotRem2Op | ncg && x86ish -> Left (MO_U_QuotRem2 wordWidth) - | otherwise -> Right genericWordQuotRem2Op + WordQuotRem2Op | ncg && x86ish -> Left (MO_U_QuotRem2 (wordWidth dflags)) + | otherwise -> Right (genericWordQuotRem2Op dflags) - WordAdd2Op | ncg && x86ish -> Left (MO_Add2 wordWidth) + WordAdd2Op | ncg && x86ish -> Left (MO_Add2 (wordWidth dflags)) | otherwise -> Right genericWordAdd2Op - WordMul2Op | ncg && x86ish -> Left (MO_U_Mul2 wordWidth) + WordMul2Op | ncg && x86ish -> Left (MO_U_Mul2 (wordWidth dflags)) | otherwise -> Right genericWordMul2Op _ -> panic "emitPrimOp: can't translate PrimOp" (ppr op) @@ -563,37 +557,37 @@ callishPrimOpSupported dflags op ArchX86_64 -> True _ -> False -genericIntQuotRemOp :: GenericOp -genericIntQuotRemOp [res_q, res_r] [arg_x, arg_y] +genericIntQuotRemOp :: DynFlags -> GenericOp +genericIntQuotRemOp dflags [res_q, res_r] [arg_x, arg_y] = emit $ mkAssign (CmmLocal res_q) - (CmmMachOp (MO_S_Quot wordWidth) [arg_x, arg_y]) <*> + (CmmMachOp (MO_S_Quot (wordWidth dflags)) [arg_x, arg_y]) <*> mkAssign (CmmLocal res_r) - (CmmMachOp (MO_S_Rem wordWidth) [arg_x, arg_y]) -genericIntQuotRemOp _ _ = panic "genericIntQuotRemOp" + (CmmMachOp (MO_S_Rem (wordWidth dflags)) [arg_x, arg_y]) +genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp" -genericWordQuotRemOp :: GenericOp -genericWordQuotRemOp [res_q, res_r] [arg_x, arg_y] +genericWordQuotRemOp :: DynFlags -> GenericOp +genericWordQuotRemOp dflags [res_q, res_r] [arg_x, arg_y] = emit $ mkAssign (CmmLocal res_q) - (CmmMachOp (MO_U_Quot wordWidth) [arg_x, arg_y]) <*> + (CmmMachOp (MO_U_Quot (wordWidth dflags)) [arg_x, arg_y]) <*> mkAssign (CmmLocal res_r) - (CmmMachOp (MO_U_Rem wordWidth) [arg_x, arg_y]) -genericWordQuotRemOp _ _ = panic "genericWordQuotRemOp" - -genericWordQuotRem2Op :: GenericOp -genericWordQuotRem2Op [res_q, res_r] [arg_x_high, arg_x_low, arg_y] - = emit =<< f (widthInBits wordWidth) zero arg_x_high arg_x_low - where ty = cmmExprType arg_x_high - shl x i = CmmMachOp (MO_Shl wordWidth) [x, i] - shr x i = CmmMachOp (MO_U_Shr wordWidth) [x, i] - or x y = CmmMachOp (MO_Or wordWidth) [x, y] - ge x y = CmmMachOp (MO_U_Ge wordWidth) [x, y] - ne x y = CmmMachOp (MO_Ne wordWidth) [x, y] - minus x y = CmmMachOp (MO_Sub wordWidth) [x, y] - times x y = CmmMachOp (MO_Mul wordWidth) [x, y] + (CmmMachOp (MO_U_Rem (wordWidth dflags)) [arg_x, arg_y]) +genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp" + +genericWordQuotRem2Op :: DynFlags -> GenericOp +genericWordQuotRem2Op dflags [res_q, res_r] [arg_x_high, arg_x_low, arg_y] + = emit =<< f (widthInBits (wordWidth dflags)) zero arg_x_high arg_x_low + where ty = cmmExprType dflags arg_x_high + shl x i = CmmMachOp (MO_Shl (wordWidth dflags)) [x, i] + shr x i = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, i] + or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] + ge x y = CmmMachOp (MO_U_Ge (wordWidth dflags)) [x, y] + ne x y = CmmMachOp (MO_Ne (wordWidth dflags)) [x, y] + minus x y = CmmMachOp (MO_Sub (wordWidth dflags)) [x, y] + times x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y] zero = lit 0 one = lit 1 - negone = lit (fromIntegral (widthInBits wordWidth) - 1) - lit i = CmmLit (CmmInt i wordWidth) + negone = lit (fromIntegral (widthInBits (wordWidth dflags)) - 1) + lit i = CmmLit (CmmInt i (wordWidth dflags)) f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*> @@ -626,12 +620,21 @@ genericWordQuotRem2Op [res_q, res_r] [arg_x_high, arg_x_low, arg_y] (CmmReg (CmmLocal rhigh'')) (CmmReg (CmmLocal rlow')) return (this <*> rest) -genericWordQuotRem2Op _ _ = panic "genericWordQuotRem2Op" +genericWordQuotRem2Op _ _ _ = panic "genericWordQuotRem2Op" genericWordAdd2Op :: GenericOp genericWordAdd2Op [res_h, res_l] [arg_x, arg_y] - = do r1 <- newTemp (cmmExprType arg_x) - r2 <- newTemp (cmmExprType arg_x) + = do dflags <- getDynFlags + r1 <- newTemp (cmmExprType dflags arg_x) + r2 <- newTemp (cmmExprType dflags arg_x) + let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww] + toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww] + bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm] + add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y] + or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] + hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags))) + (wordWidth dflags)) + hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags)) emit $ catAGraphs [mkAssign (CmmLocal r1) (add (bottomHalf arg_x) (bottomHalf arg_y)), @@ -643,25 +646,28 @@ genericWordAdd2Op [res_h, res_l] [arg_x, arg_y] mkAssign (CmmLocal res_l) (or (toTopHalf (CmmReg (CmmLocal r2))) (bottomHalf (CmmReg (CmmLocal r1))))] - where topHalf x = CmmMachOp (MO_U_Shr wordWidth) [x, hww] - toTopHalf x = CmmMachOp (MO_Shl wordWidth) [x, hww] - bottomHalf x = CmmMachOp (MO_And wordWidth) [x, hwm] - add x y = CmmMachOp (MO_Add wordWidth) [x, y] - or x y = CmmMachOp (MO_Or wordWidth) [x, y] - hww = CmmLit (CmmInt (fromIntegral (widthInBits halfWordWidth)) - wordWidth) - hwm = CmmLit (CmmInt halfWordMask wordWidth) genericWordAdd2Op _ _ = panic "genericWordAdd2Op" genericWordMul2Op :: GenericOp genericWordMul2Op [res_h, res_l] [arg_x, arg_y] - = do let t = cmmExprType arg_x + = do dflags <- getDynFlags + let t = cmmExprType dflags arg_x xlyl <- liftM CmmLocal $ newTemp t xlyh <- liftM CmmLocal $ newTemp t xhyl <- liftM CmmLocal $ newTemp t r <- liftM CmmLocal $ newTemp t -- This generic implementation is very simple and slow. We might -- well be able to do better, but for now this at least works. + let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww] + toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww] + bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm] + add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y] + sum = foldl1 add + mul x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y] + or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] + hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags))) + (wordWidth dflags)) + hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags)) emit $ catAGraphs [mkAssign xlyl (mul (bottomHalf arg_x) (bottomHalf arg_y)), @@ -681,16 +687,6 @@ genericWordMul2Op [res_h, res_l] [arg_x, arg_y] topHalf (CmmReg xhyl), topHalf (CmmReg xlyh), topHalf (CmmReg r)])] - where topHalf x = CmmMachOp (MO_U_Shr wordWidth) [x, hww] - toTopHalf x = CmmMachOp (MO_Shl wordWidth) [x, hww] - bottomHalf x = CmmMachOp (MO_And wordWidth) [x, hwm] - add x y = CmmMachOp (MO_Add wordWidth) [x, y] - sum = foldl1 add - mul x y = CmmMachOp (MO_Mul wordWidth) [x, y] - or x y = CmmMachOp (MO_Or wordWidth) [x, y] - hww = CmmLit (CmmInt (fromIntegral (widthInBits halfWordWidth)) - wordWidth) - hwm = CmmLit (CmmInt halfWordMask wordWidth) genericWordMul2Op _ _ = panic "genericWordMul2Op" -- These PrimOps are NOPs in Cmm @@ -717,125 +713,125 @@ narrowOp _ = Nothing -- Native word signless ops -translateOp :: PrimOp -> Maybe MachOp -translateOp IntAddOp = Just mo_wordAdd -translateOp IntSubOp = Just mo_wordSub -translateOp WordAddOp = Just mo_wordAdd -translateOp WordSubOp = Just mo_wordSub -translateOp AddrAddOp = Just mo_wordAdd -translateOp AddrSubOp = Just mo_wordSub - -translateOp IntEqOp = Just mo_wordEq -translateOp IntNeOp = Just mo_wordNe -translateOp WordEqOp = Just mo_wordEq -translateOp WordNeOp = Just mo_wordNe -translateOp AddrEqOp = Just mo_wordEq -translateOp AddrNeOp = Just mo_wordNe - -translateOp AndOp = Just mo_wordAnd -translateOp OrOp = Just mo_wordOr -translateOp XorOp = Just mo_wordXor -translateOp NotOp = Just mo_wordNot -translateOp SllOp = Just mo_wordShl -translateOp SrlOp = Just mo_wordUShr - -translateOp AddrRemOp = Just mo_wordURem +translateOp :: DynFlags -> PrimOp -> Maybe MachOp +translateOp dflags IntAddOp = Just (mo_wordAdd dflags) +translateOp dflags IntSubOp = Just (mo_wordSub dflags) +translateOp dflags WordAddOp = Just (mo_wordAdd dflags) +translateOp dflags WordSubOp = Just (mo_wordSub dflags) +translateOp dflags AddrAddOp = Just (mo_wordAdd dflags) +translateOp dflags AddrSubOp = Just (mo_wordSub dflags) + +translateOp dflags IntEqOp = Just (mo_wordEq dflags) +translateOp dflags IntNeOp = Just (mo_wordNe dflags) +translateOp dflags WordEqOp = Just (mo_wordEq dflags) +translateOp dflags WordNeOp = Just (mo_wordNe dflags) +translateOp dflags AddrEqOp = Just (mo_wordEq dflags) +translateOp dflags AddrNeOp = Just (mo_wordNe dflags) + +translateOp dflags AndOp = Just (mo_wordAnd dflags) +translateOp dflags OrOp = Just (mo_wordOr dflags) +translateOp dflags XorOp = Just (mo_wordXor dflags) +translateOp dflags NotOp = Just (mo_wordNot dflags) +translateOp dflags SllOp = Just (mo_wordShl dflags) +translateOp dflags SrlOp = Just (mo_wordUShr dflags) + +translateOp dflags AddrRemOp = Just (mo_wordURem dflags) -- Native word signed ops -translateOp IntMulOp = Just mo_wordMul -translateOp IntMulMayOfloOp = Just (MO_S_MulMayOflo wordWidth) -translateOp IntQuotOp = Just mo_wordSQuot -translateOp IntRemOp = Just mo_wordSRem -translateOp IntNegOp = Just mo_wordSNeg +translateOp dflags IntMulOp = Just (mo_wordMul dflags) +translateOp dflags IntMulMayOfloOp = Just (MO_S_MulMayOflo (wordWidth dflags)) +translateOp dflags IntQuotOp = Just (mo_wordSQuot dflags) +translateOp dflags IntRemOp = Just (mo_wordSRem dflags) +translateOp dflags IntNegOp = Just (mo_wordSNeg dflags) -translateOp IntGeOp = Just mo_wordSGe -translateOp IntLeOp = Just mo_wordSLe -translateOp IntGtOp = Just mo_wordSGt -translateOp IntLtOp = Just mo_wordSLt +translateOp dflags IntGeOp = Just (mo_wordSGe dflags) +translateOp dflags IntLeOp = Just (mo_wordSLe dflags) +translateOp dflags IntGtOp = Just (mo_wordSGt dflags) +translateOp dflags IntLtOp = Just (mo_wordSLt dflags) -translateOp ISllOp = Just mo_wordShl -translateOp ISraOp = Just mo_wordSShr -translateOp ISrlOp = Just mo_wordUShr +translateOp dflags ISllOp = Just (mo_wordShl dflags) +translateOp dflags ISraOp = Just (mo_wordSShr dflags) +translateOp dflags ISrlOp = Just (mo_wordUShr dflags) -- Native word unsigned ops -translateOp WordGeOp = Just mo_wordUGe -translateOp WordLeOp = Just mo_wordULe -translateOp WordGtOp = Just mo_wordUGt -translateOp WordLtOp = Just mo_wordULt +translateOp dflags WordGeOp = Just (mo_wordUGe dflags) +translateOp dflags WordLeOp = Just (mo_wordULe dflags) +translateOp dflags WordGtOp = Just (mo_wordUGt dflags) +translateOp dflags WordLtOp = Just (mo_wordULt dflags) -translateOp WordMulOp = Just mo_wordMul -translateOp WordQuotOp = Just mo_wordUQuot -translateOp WordRemOp = Just mo_wordURem +translateOp dflags WordMulOp = Just (mo_wordMul dflags) +translateOp dflags WordQuotOp = Just (mo_wordUQuot dflags) +translateOp dflags WordRemOp = Just (mo_wordURem dflags) -translateOp AddrGeOp = Just mo_wordUGe -translateOp AddrLeOp = Just mo_wordULe -translateOp AddrGtOp = Just mo_wordUGt -translateOp AddrLtOp = Just mo_wordULt +translateOp dflags AddrGeOp = Just (mo_wordUGe dflags) +translateOp dflags AddrLeOp = Just (mo_wordULe dflags) +translateOp dflags AddrGtOp = Just (mo_wordUGt dflags) +translateOp dflags AddrLtOp = Just (mo_wordULt dflags) -- Char# ops -translateOp CharEqOp = Just (MO_Eq wordWidth) -translateOp CharNeOp = Just (MO_Ne wordWidth) -translateOp CharGeOp = Just (MO_U_Ge wordWidth) -translateOp CharLeOp = Just (MO_U_Le wordWidth) -translateOp CharGtOp = Just (MO_U_Gt wordWidth) -translateOp CharLtOp = Just (MO_U_Lt wordWidth) +translateOp dflags CharEqOp = Just (MO_Eq (wordWidth dflags)) +translateOp dflags CharNeOp = Just (MO_Ne (wordWidth dflags)) +translateOp dflags CharGeOp = Just (MO_U_Ge (wordWidth dflags)) +translateOp dflags CharLeOp = Just (MO_U_Le (wordWidth dflags)) +translateOp dflags CharGtOp = Just (MO_U_Gt (wordWidth dflags)) +translateOp dflags CharLtOp = Just (MO_U_Lt (wordWidth dflags)) -- Double ops -translateOp DoubleEqOp = Just (MO_F_Eq W64) -translateOp DoubleNeOp = Just (MO_F_Ne W64) -translateOp DoubleGeOp = Just (MO_F_Ge W64) -translateOp DoubleLeOp = Just (MO_F_Le W64) -translateOp DoubleGtOp = Just (MO_F_Gt W64) -translateOp DoubleLtOp = Just (MO_F_Lt W64) +translateOp _ DoubleEqOp = Just (MO_F_Eq W64) +translateOp _ DoubleNeOp = Just (MO_F_Ne W64) +translateOp _ DoubleGeOp = Just (MO_F_Ge W64) +translateOp _ DoubleLeOp = Just (MO_F_Le W64) +translateOp _ DoubleGtOp = Just (MO_F_Gt W64) +translateOp _ DoubleLtOp = Just (MO_F_Lt W64) -translateOp DoubleAddOp = Just (MO_F_Add W64) -translateOp DoubleSubOp = Just (MO_F_Sub W64) -translateOp DoubleMulOp = Just (MO_F_Mul W64) -translateOp DoubleDivOp = Just (MO_F_Quot W64) -translateOp DoubleNegOp = Just (MO_F_Neg W64) +translateOp _ DoubleAddOp = Just (MO_F_Add W64) +translateOp _ DoubleSubOp = Just (MO_F_Sub W64) +translateOp _ DoubleMulOp = Just (MO_F_Mul W64) +translateOp _ DoubleDivOp = Just (MO_F_Quot W64) +translateOp _ DoubleNegOp = Just (MO_F_Neg W64) -- Float ops -translateOp FloatEqOp = Just (MO_F_Eq W32) -translateOp FloatNeOp = Just (MO_F_Ne W32) -translateOp FloatGeOp = Just (MO_F_Ge W32) -translateOp FloatLeOp = Just (MO_F_Le W32) -translateOp FloatGtOp = Just (MO_F_Gt W32) -translateOp FloatLtOp = Just (MO_F_Lt W32) +translateOp _ FloatEqOp = Just (MO_F_Eq W32) +translateOp _ FloatNeOp = Just (MO_F_Ne W32) +translateOp _ FloatGeOp = Just (MO_F_Ge W32) +translateOp _ FloatLeOp = Just (MO_F_Le W32) +translateOp _ FloatGtOp = Just (MO_F_Gt W32) +translateOp _ FloatLtOp = Just (MO_F_Lt W32) -translateOp FloatAddOp = Just (MO_F_Add W32) -translateOp FloatSubOp = Just (MO_F_Sub W32) -translateOp FloatMulOp = Just (MO_F_Mul W32) -translateOp FloatDivOp = Just (MO_F_Quot W32) -translateOp FloatNegOp = Just (MO_F_Neg W32) +translateOp _ FloatAddOp = Just (MO_F_Add W32) +translateOp _ FloatSubOp = Just (MO_F_Sub W32) +translateOp _ FloatMulOp = Just (MO_F_Mul W32) +translateOp _ FloatDivOp = Just (MO_F_Quot W32) +translateOp _ FloatNegOp = Just (MO_F_Neg W32) -- Conversions -translateOp Int2DoubleOp = Just (MO_SF_Conv wordWidth W64) -translateOp Double2IntOp = Just (MO_FS_Conv W64 wordWidth) +translateOp dflags Int2DoubleOp = Just (MO_SF_Conv (wordWidth dflags) W64) +translateOp dflags Double2IntOp = Just (MO_FS_Conv W64 (wordWidth dflags)) -translateOp Int2FloatOp = Just (MO_SF_Conv wordWidth W32) -translateOp Float2IntOp = Just (MO_FS_Conv W32 wordWidth) +translateOp dflags Int2FloatOp = Just (MO_SF_Conv (wordWidth dflags) W32) +translateOp dflags Float2IntOp = Just (MO_FS_Conv W32 (wordWidth dflags)) -translateOp Float2DoubleOp = Just (MO_FF_Conv W32 W64) -translateOp Double2FloatOp = Just (MO_FF_Conv W64 W32) +translateOp _ Float2DoubleOp = Just (MO_FF_Conv W32 W64) +translateOp _ Double2FloatOp = Just (MO_FF_Conv W64 W32) -- Word comparisons masquerading as more exotic things. -translateOp SameMutVarOp = Just mo_wordEq -translateOp SameMVarOp = Just mo_wordEq -translateOp SameMutableArrayOp = Just mo_wordEq -translateOp SameMutableByteArrayOp = Just mo_wordEq -translateOp SameMutableArrayArrayOp= Just mo_wordEq -translateOp SameTVarOp = Just mo_wordEq -translateOp EqStablePtrOp = Just mo_wordEq +translateOp dflags SameMutVarOp = Just (mo_wordEq dflags) +translateOp dflags SameMVarOp = Just (mo_wordEq dflags) +translateOp dflags SameMutableArrayOp = Just (mo_wordEq dflags) +translateOp dflags SameMutableByteArrayOp = Just (mo_wordEq dflags) +translateOp dflags SameMutableArrayArrayOp= Just (mo_wordEq dflags) +translateOp dflags SameTVarOp = Just (mo_wordEq dflags) +translateOp dflags EqStablePtrOp = Just (mo_wordEq dflags) -translateOp _ = Nothing +translateOp _ _ = Nothing -- These primops are implemented by CallishMachOps, because they sometimes -- turn into foreign calls depending on the backend. @@ -890,7 +886,7 @@ doIndexByteArrayOp _ _ _ _ doReadPtrArrayOp :: LocalReg -> CmmExpr -> CmmExpr -> FCode () doReadPtrArrayOp res addr idx = do dflags <- getDynFlags - mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing gcWord res addr idx + mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr idx doWriteOffAddrOp :: Maybe MachOp -> [LocalReg] -> [CmmExpr] -> FCode () @@ -914,42 +910,45 @@ doWritePtrArrayOp addr idx val -- the write barrier. We must write a byte into the mark table: -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N] emit $ mkStore ( - cmmOffsetExpr - (cmmOffsetExprW (cmmOffsetB addr (arrPtrsHdrSize dflags)) + cmmOffsetExpr dflags + (cmmOffsetExprW dflags (cmmOffsetB dflags addr (arrPtrsHdrSize dflags)) (loadArrPtrsSize dflags addr)) - (CmmMachOp mo_wordUShr [idx, - mkIntExpr mUT_ARR_PTRS_CARD_BITS]) + (CmmMachOp (mo_wordUShr dflags) [idx, + mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags)]) ) (CmmLit (CmmInt 1 W8)) loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr -loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB addr off) bWord - where off = fixedHdrSize dflags * wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs +loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags) + where off = fixedHdrSize dflags * wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs dflags mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType -> LocalReg -> CmmExpr -> CmmExpr -> FCode () mkBasicIndexedRead off Nothing read_rep res base idx - = emitAssign (CmmLocal res) (cmmLoadIndexOffExpr off read_rep base idx) + = do dflags <- getDynFlags + emitAssign (CmmLocal res) (cmmLoadIndexOffExpr dflags off read_rep base idx) mkBasicIndexedRead off (Just cast) read_rep res base idx - = emitAssign (CmmLocal res) (CmmMachOp cast [ - cmmLoadIndexOffExpr off read_rep base idx]) + = do dflags <- getDynFlags + emitAssign (CmmLocal res) (CmmMachOp cast [ + cmmLoadIndexOffExpr dflags off read_rep base idx]) mkBasicIndexedWrite :: ByteOff -> Maybe MachOp -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () mkBasicIndexedWrite off Nothing base idx val - = emitStore (cmmIndexOffExpr off (typeWidth (cmmExprType val)) base idx) val + = do dflags <- getDynFlags + emitStore (cmmIndexOffExpr dflags off (typeWidth (cmmExprType dflags val)) base idx) val mkBasicIndexedWrite off (Just cast) base idx val = mkBasicIndexedWrite off Nothing base idx (CmmMachOp cast [val]) -- ---------------------------------------------------------------------------- -- Misc utils -cmmIndexOffExpr :: ByteOff -> Width -> CmmExpr -> CmmExpr -> CmmExpr -cmmIndexOffExpr off width base idx - = cmmIndexExpr width (cmmOffsetB base off) idx +cmmIndexOffExpr :: DynFlags -> ByteOff -> Width -> CmmExpr -> CmmExpr -> CmmExpr +cmmIndexOffExpr dflags off width base idx + = cmmIndexExpr dflags width (cmmOffsetB dflags base off) idx -cmmLoadIndexOffExpr :: ByteOff -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr -cmmLoadIndexOffExpr off ty base idx - = CmmLoad (cmmIndexOffExpr off (typeWidth ty) base idx) ty +cmmLoadIndexOffExpr :: DynFlags -> ByteOff -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr +cmmLoadIndexOffExpr dflags off ty base idx + = CmmLoad (cmmIndexOffExpr dflags off (typeWidth ty) base idx) ty setInfo :: CmmExpr -> CmmExpr -> CmmAGraph setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr @@ -968,7 +967,8 @@ doCopyByteArrayOp = emitCopyByteArray copy -- Copy data (we assume the arrays aren't overlapping since -- they're of different types) copy _src _dst dst_p src_p bytes = - emitMemcpyCall dst_p src_p bytes (mkIntExpr 1) + do dflags <- getDynFlags + emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags 1) -- | Takes a source 'MutableByteArray#', an offset in the source -- array, a destination 'MutableByteArray#', an offset into the @@ -983,11 +983,12 @@ doCopyMutableByteArrayOp = emitCopyByteArray copy -- we were provided are the same array! -- TODO: Optimize branch for common case of no aliasing. copy src dst dst_p src_p bytes = do + dflags <- getDynFlags [moveCall, cpyCall] <- forkAlts [ - getCode $ emitMemmoveCall dst_p src_p bytes (mkIntExpr 1), - getCode $ emitMemcpyCall dst_p src_p bytes (mkIntExpr 1) + getCode $ emitMemmoveCall dst_p src_p bytes (mkIntExpr dflags 1), + getCode $ emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags 1) ] - emit =<< mkCmmIfThenElse (cmmEqWord src dst) moveCall cpyCall + emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()) @@ -995,8 +996,8 @@ emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () emitCopyByteArray copy src src_off dst dst_off n = do dflags <- getDynFlags - dst_p <- assignTempE $ cmmOffsetExpr (cmmOffsetB dst (arrWordsHdrSize dflags)) dst_off - src_p <- assignTempE $ cmmOffsetExpr (cmmOffsetB src (arrWordsHdrSize dflags)) src_off + dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off + src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off copy src dst dst_p src_p n -- ---------------------------------------------------------------------------- @@ -1009,8 +1010,8 @@ doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () doSetByteArrayOp ba off len c = do dflags <- getDynFlags - p <- assignTempE $ cmmOffsetExpr (cmmOffsetB ba (arrWordsHdrSize dflags)) off - emitMemsetCall p c len (mkIntExpr 1) + p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off + emitMemsetCall p c len (mkIntExpr dflags 1) -- ---------------------------------------------------------------------------- -- Copying pointer arrays @@ -1040,7 +1041,8 @@ doCopyArrayOp = emitCopyArray copy -- Copy data (we assume the arrays aren't overlapping since -- they're of different types) copy _src _dst dst_p src_p bytes = - emitMemcpyCall dst_p src_p bytes (mkIntExpr wORD_SIZE) + do dflags <- getDynFlags + emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags wORD_SIZE) -- | Takes a source 'MutableArray#', an offset in the source array, a @@ -1055,11 +1057,12 @@ doCopyMutableArrayOp = emitCopyArray copy -- we were provided are the same array! -- TODO: Optimize branch for common case of no aliasing. copy src dst dst_p src_p bytes = do + dflags <- getDynFlags [moveCall, cpyCall] <- forkAlts [ - getCode $ emitMemmoveCall dst_p src_p bytes (mkIntExpr wORD_SIZE), - getCode $ emitMemcpyCall dst_p src_p bytes (mkIntExpr wORD_SIZE) + getCode $ emitMemmoveCall dst_p src_p bytes (mkIntExpr dflags wORD_SIZE), + getCode $ emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags wORD_SIZE) ] - emit =<< mkCmmIfThenElse (cmmEqWord src dst) moveCall cpyCall + emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()) @@ -1077,15 +1080,15 @@ emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 = do -- Set the dirty bit in the header. emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) - dst_elems_p <- assignTempE $ cmmOffsetB dst (arrPtrsHdrSize dflags) - dst_p <- assignTempE $ cmmOffsetExprW dst_elems_p dst_off - src_p <- assignTempE $ cmmOffsetExprW (cmmOffsetB src (arrPtrsHdrSize dflags)) src_off - bytes <- assignTempE $ cmmMulWord n (mkIntExpr wORD_SIZE) + dst_elems_p <- assignTempE $ cmmOffsetB dflags dst (arrPtrsHdrSize dflags) + dst_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p dst_off + src_p <- assignTempE $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off + bytes <- assignTempE $ cmmMulWord dflags n (mkIntExpr dflags wORD_SIZE) copy src dst dst_p src_p bytes -- The base address of the destination card table - dst_cards_p <- assignTempE $ cmmOffsetExprW dst_elems_p (loadArrPtrsSize dflags dst) + dst_cards_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p (loadArrPtrsSize dflags dst) emitSetCards dst_off dst_cards_p n @@ -1096,69 +1099,69 @@ emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 = do emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () emitCloneArray info_p res_r src0 src_off0 n0 = do + dflags <- getDynFlags + let arrPtrsHdrSizeW dflags = mkIntExpr dflags (fixedHdrSize dflags + + (sIZEOF_StgMutArrPtrs_NoHdr dflags `div` wORD_SIZE)) + myCapability = cmmSubWord dflags (CmmReg baseReg) (mkIntExpr dflags (oFFSET_Capability_r dflags)) -- Passed as arguments (be careful) src <- assignTempE src0 src_off <- assignTempE src_off0 n <- assignTempE n0 - card_bytes <- assignTempE $ cardRoundUp n - size <- assignTempE $ n `cmmAddWord` bytesToWordsRoundUp card_bytes - dflags <- getDynFlags - words <- assignTempE $ arrPtrsHdrSizeW dflags `cmmAddWord` size + card_bytes <- assignTempE $ cardRoundUp dflags n + size <- assignTempE $ cmmAddWord dflags n (bytesToWordsRoundUp dflags card_bytes) + words <- assignTempE $ cmmAddWord dflags (arrPtrsHdrSizeW dflags) size - arr_r <- newTemp bWord + arr_r <- newTemp (bWord dflags) emitAllocateCall arr_r myCapability words - tickyAllocPrim (mkIntExpr (arrPtrsHdrSize dflags)) (n `cmmMulWord` wordSize) - zeroExpr + tickyAllocPrim (mkIntExpr dflags (arrPtrsHdrSize dflags)) (cmmMulWord dflags n (wordSize dflags)) + (zeroExpr dflags) let arr = CmmReg (CmmLocal arr_r) emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCS - emit $ mkStore (cmmOffsetB arr (fixedHdrSize dflags * wORD_SIZE + - oFFSET_StgMutArrPtrs_ptrs)) n - emit $ mkStore (cmmOffsetB arr (fixedHdrSize dflags * wORD_SIZE + - oFFSET_StgMutArrPtrs_size)) size + emit $ mkStore (cmmOffsetB dflags arr (fixedHdrSize dflags * wORD_SIZE + + oFFSET_StgMutArrPtrs_ptrs dflags)) n + emit $ mkStore (cmmOffsetB dflags arr (fixedHdrSize dflags * wORD_SIZE + + oFFSET_StgMutArrPtrs_size dflags)) size - dst_p <- assignTempE $ cmmOffsetB arr (arrPtrsHdrSize dflags) - src_p <- assignTempE $ cmmOffsetExprW (cmmOffsetB src (arrPtrsHdrSize dflags)) + dst_p <- assignTempE $ cmmOffsetB dflags arr (arrPtrsHdrSize dflags) + src_p <- assignTempE $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off - emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize) (mkIntExpr wORD_SIZE) + emitMemcpyCall dst_p src_p (cmmMulWord dflags n (wordSize dflags)) (mkIntExpr dflags wORD_SIZE) - emitMemsetCall (cmmOffsetExprW dst_p n) - (mkIntExpr 1) + emitMemsetCall (cmmOffsetExprW dflags dst_p n) + (mkIntExpr dflags 1) card_bytes - (mkIntExpr wORD_SIZE) + (mkIntExpr dflags wORD_SIZE) emit $ mkAssign (CmmLocal res_r) arr - where - arrPtrsHdrSizeW dflags = mkIntExpr (fixedHdrSize dflags + - (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE)) - myCapability = CmmReg baseReg `cmmSubWord` mkIntExpr oFFSET_Capability_r -- | Takes and offset in the destination array, the base address of -- the card table, and the number of elements affected (*not* the -- number of cards). Marks the relevant cards as dirty. emitSetCards :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () emitSetCards dst_start dst_cards_start n = do - start_card <- assignTempE $ card dst_start - emitMemsetCall (dst_cards_start `cmmAddWord` start_card) - (mkIntExpr 1) - (cardRoundUp n) - (mkIntExpr 1) -- no alignment (1 byte) + dflags <- getDynFlags + start_card <- assignTempE $ card dflags dst_start + emitMemsetCall (cmmAddWord dflags dst_cards_start start_card) + (mkIntExpr dflags 1) + (cardRoundUp dflags n) + (mkIntExpr dflags 1) -- no alignment (1 byte) -- Convert an element index to a card index -card :: CmmExpr -> CmmExpr -card i = i `cmmUShrWord` mkIntExpr mUT_ARR_PTRS_CARD_BITS +card :: DynFlags -> CmmExpr -> CmmExpr +card dflags i = cmmUShrWord dflags i (mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags)) -- Convert a number of elements to a number of cards, rounding up -cardRoundUp :: CmmExpr -> CmmExpr -cardRoundUp i = card (i `cmmAddWord` (mkIntExpr ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS) - 1))) +cardRoundUp :: DynFlags -> CmmExpr -> CmmExpr +cardRoundUp dflags i = card dflags (cmmAddWord dflags i (mkIntExpr dflags ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS dflags) - 1))) -bytesToWordsRoundUp :: CmmExpr -> CmmExpr -bytesToWordsRoundUp e = (e `cmmAddWord` mkIntExpr (wORD_SIZE - 1)) - `cmmQuotWord` wordSize +bytesToWordsRoundUp :: DynFlags -> CmmExpr -> CmmExpr +bytesToWordsRoundUp dflags e = cmmQuotWord dflags (cmmAddWord dflags e (mkIntExpr dflags (wORD_SIZE - 1))) + (wordSize dflags) -wordSize :: CmmExpr -wordSize = mkIntExpr wORD_SIZE +wordSize :: DynFlags -> CmmExpr +wordSize dflags = mkIntExpr dflags wORD_SIZE -- | Emit a call to @memcpy@. emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index 7f677d5969..d5fa9d73a1 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -67,10 +67,10 @@ import Data.Char (ord) ----------------------------------------------------------------------------- -- Expression representing the current cost centre stack -ccsType :: CmmType -- Type of a cost-centre stack +ccsType :: DynFlags -> CmmType -- Type of a cost-centre stack ccsType = bWord -ccType :: CmmType -- Type of a cost centre +ccType :: DynFlags -> CmmType -- Type of a cost centre ccType = bWord curCCS :: CmmExpr @@ -85,25 +85,28 @@ mkCCostCentre cc = CmmLabel (mkCCLabel cc) mkCCostCentreStack :: CostCentreStack -> CmmLit mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs) -costCentreFrom :: CmmExpr -- A closure pointer +costCentreFrom :: DynFlags + -> CmmExpr -- A closure pointer -> CmmExpr -- The cost centre from that closure -costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) ccsType +costCentreFrom dflags cl = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (ccsType dflags) staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit] -- The profiling header words in a static closure -- Was SET_STATIC_PROF_HDR staticProfHdr dflags ccs - = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit] + = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit dflags] dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr] -- Profiling header words in a dynamic closure -dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit] +dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags] initUpdFrameProf :: ByteOff -> FCode () -- Initialise the profiling field of an update frame initUpdFrameProf frame_off = ifProfiling $ -- frame->header.prof.ccs = CCCS - emitStore (CmmStackSlot Old (frame_off - oFFSET_StgHeader_ccs)) curCCS + do dflags <- getDynFlags + emitStore (CmmStackSlot Old (frame_off - oFFSET_StgHeader_ccs dflags)) + curCCS -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) -- is unnecessary because it is not used anyhow. @@ -142,7 +145,7 @@ saveCurrentCostCentre = do dflags <- getDynFlags if not (dopt Opt_SccProfilingOn dflags) then return Nothing - else do local_cc <- newTemp ccType + else do local_cc <- newTemp (ccType dflags) emitAssign (CmmLocal local_cc) curCCS return (Just local_cc) @@ -163,7 +166,7 @@ profDynAlloc :: SMRep -> CmmExpr -> FCode () profDynAlloc rep ccs = ifProfiling $ do dflags <- getDynFlags - profAlloc (mkIntExpr (heapClosureSize dflags rep)) ccs + profAlloc (mkIntExpr dflags (heapClosureSize dflags rep)) ccs -- | Record the allocation of a closure (size is given by a CmmExpr) -- The size must be in words, because the allocation counter in a CCS counts @@ -173,10 +176,10 @@ profAlloc words ccs = ifProfiling $ do dflags <- getDynFlags emit (addToMemE alloc_rep - (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc) - (CmmMachOp (MO_UU_Conv wordWidth (typeWidth alloc_rep)) $ - [CmmMachOp mo_wordSub [words, - mkIntExpr (profHdrSize dflags)]])) + (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags)) + (CmmMachOp (MO_UU_Conv (wordWidth dflags) (typeWidth alloc_rep)) $ + [CmmMachOp (mo_wordSub dflags) [words, + mkIntExpr dflags (profHdrSize dflags)]])) -- subtract the "profiling overhead", which is the -- profiling header in a closure. where @@ -187,16 +190,18 @@ profAlloc words ccs enterCostCentreThunk :: CmmExpr -> FCode () enterCostCentreThunk closure = - ifProfiling $ do - emit $ storeCurCCS (costCentreFrom closure) + ifProfiling $ do + dflags <- getDynFlags + emit $ storeCurCCS (costCentreFrom dflags closure) enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode () enterCostCentreFun ccs closure = ifProfiling $ do if isCurrentCCS ccs - then emitRtsCall rtsPackageId (fsLit "enterFunCCS") - [(CmmReg (CmmGlobal BaseReg), AddrHint), - (costCentreFrom closure, AddrHint)] False + then do dflags <- getDynFlags + emitRtsCall rtsPackageId (fsLit "enterFunCCS") + [(CmmReg (CmmGlobal BaseReg), AddrHint), + (costCentreFrom dflags closure, AddrHint)] False else return () -- top-level function, nothing to do ifProfiling :: FCode () -> FCode () @@ -227,48 +232,48 @@ initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs) emitCostCentreDecl :: CostCentre -> FCode () emitCostCentreDecl cc = do + { dflags <- getDynFlags + ; let is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF + | otherwise = zero dflags -- NB. bytesFS: we want the UTF-8 bytes here (#5559) - { label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc) + ; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc) ; modl <- newByteStringCLit (bytesFS $ Module.moduleNameFS $ Module.moduleName $ cc_mod cc) - ; dflags <- getDynFlags ; loc <- newByteStringCLit $ bytesFS $ mkFastString $ showPpr dflags (costCentreSrcSpan cc) -- XXX going via FastString to get UTF-8 encoding is silly ; let - lits = [ zero, -- StgInt ccID, + lits = [ zero dflags, -- StgInt ccID, label, -- char *label, modl, -- char *module, loc, -- char *srcloc, zero64, -- StgWord64 mem_alloc - zero, -- StgWord time_ticks + zero dflags, -- StgWord time_ticks is_caf, -- StgInt is_caf - zero -- struct _CostCentre *link + zero dflags -- struct _CostCentre *link ] ; emitDataLits (mkCCLabel cc) lits } - where - is_caf | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF - | otherwise = zero emitCostCentreStackDecl :: CostCentreStack -> FCode () emitCostCentreStackDecl ccs = case maybeSingletonCCS ccs of - Just cc -> emitDataLits (mkCCSLabel ccs) (mk_lits cc) - Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs) - where - mk_lits cc = zero : - mkCCostCentre cc : - replicate (sizeof_ccs_words - 2) zero - -- Note: to avoid making any assumptions about how the - -- C compiler (that compiles the RTS, in particular) does - -- layouts of structs containing long-longs, simply - -- pad out the struct with zero words until we hit the - -- size of the overall struct (which we get via DerivedConstants.h) - -zero :: CmmLit -zero = mkIntCLit 0 + Just cc -> + do dflags <- getDynFlags + let mk_lits cc = zero dflags : + mkCCostCentre cc : + replicate (sizeof_ccs_words - 2) (zero dflags) + -- Note: to avoid making any assumptions about how the + -- C compiler (that compiles the RTS, in particular) does + -- layouts of structs containing long-longs, simply + -- pad out the struct with zero words until we hit the + -- size of the overall struct (which we get via DerivedConstants.h) + emitDataLits (mkCCSLabel ccs) (mk_lits cc) + Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs) + +zero :: DynFlags -> CmmLit +zero dflags = mkIntCLit dflags 0 zero64 :: CmmLit zero64 = CmmInt 0 W64 @@ -288,9 +293,9 @@ emitSetCCC cc tick push = do dflags <- getDynFlags if not (dopt Opt_SccProfilingOn dflags) then nopC - else do tmp <- newTemp ccsType -- TODO FIXME NOW + else do tmp <- newTemp (ccsType dflags) -- TODO FIXME NOW pushCostCentre tmp curCCS cc - when tick $ emit (bumpSccCount (CmmReg (CmmLocal tmp))) + when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp))) when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp))) pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode () @@ -301,10 +306,10 @@ pushCostCentre result ccs cc (CmmLit (mkCCostCentre cc), AddrHint)] False -bumpSccCount :: CmmExpr -> CmmAGraph -bumpSccCount ccs +bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph +bumpSccCount dflags ccs = addToMem REP_CostCentreStack_scc_count - (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1 + (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1 ----------------------------------------------------------------------------- -- @@ -315,24 +320,25 @@ bumpSccCount ccs -- -- Initial value for the LDV field in a static closure -- -staticLdvInit :: CmmLit +staticLdvInit :: DynFlags -> CmmLit staticLdvInit = zeroCLit -- -- Initial value of the LDV field in a dynamic closure -- -dynLdvInit :: CmmExpr -dynLdvInit = -- (era << LDV_SHIFT) | LDV_STATE_CREATE - CmmMachOp mo_wordOr [ - CmmMachOp mo_wordShl [loadEra, mkIntExpr lDV_SHIFT ], - CmmLit (mkWordCLit lDV_STATE_CREATE) +dynLdvInit :: DynFlags -> CmmExpr +dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE + CmmMachOp (mo_wordOr dflags) [ + CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags lDV_SHIFT ], + CmmLit (mkWordCLit dflags lDV_STATE_CREATE) ] -- -- Initialise the LDV word of a new closure -- ldvRecordCreate :: CmmExpr -> FCode () -ldvRecordCreate closure = emit $ mkStore (ldvWord closure) dynLdvInit +ldvRecordCreate closure = do dflags <- getDynFlags + emit $ mkStore (ldvWord dflags closure) (dynLdvInit dflags) -- -- Called when a closure is entered, marks the closure as having been "used". @@ -341,35 +347,37 @@ ldvRecordCreate closure = emit $ mkStore (ldvWord closure) dynLdvInit -- profiling. -- ldvEnterClosure :: ClosureInfo -> FCode () -ldvEnterClosure closure_info = ldvEnter (cmmOffsetB (CmmReg nodeReg) (-tag)) +ldvEnterClosure closure_info = do dflags <- getDynFlags + ldvEnter (cmmOffsetB dflags (CmmReg nodeReg) (-tag)) where tag = funTag closure_info -- don't forget to substract node's tag ldvEnter :: CmmExpr -> FCode () -- Argument is a closure pointer -ldvEnter cl_ptr - = ifProfiling $ - -- if (era > 0) { - -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) | - -- era | LDV_STATE_USE } - emit =<< mkCmmIfThenElse (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit]) - (mkStore ldv_wd new_ldv_wd) - mkNop - where - -- don't forget to substract node's tag - ldv_wd = ldvWord cl_ptr - new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd bWord) - (CmmLit (mkWordCLit lDV_CREATE_MASK))) - (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE))) - -loadEra :: CmmExpr -loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth) +ldvEnter cl_ptr = do + dflags <- getDynFlags + let -- don't forget to substract node's tag + ldv_wd = ldvWord dflags cl_ptr + new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags)) + (CmmLit (mkWordCLit dflags lDV_CREATE_MASK))) + (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags lDV_STATE_USE))) + ifProfiling $ + -- if (era > 0) { + -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) | + -- era | LDV_STATE_USE } + emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)]) + (mkStore ldv_wd new_ldv_wd) + mkNop + +loadEra :: DynFlags -> CmmExpr +loadEra dflags = CmmMachOp (MO_UU_Conv cIntWidth (wordWidth dflags)) [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "era"))) cInt] -ldvWord :: CmmExpr -> CmmExpr +ldvWord :: DynFlags -> CmmExpr -> CmmExpr -- Takes the address of a closure, and returns -- the address of the LDV word in the closure -ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw +ldvWord dflags closure_ptr + = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags) -- LDV constants, from ghc/includes/Constants.h lDV_SHIFT :: Int diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index bb1c4cf788..137764db3d 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -65,7 +65,6 @@ import Name import Id import BasicTypes import FastString -import Constants import Outputable import DynFlags @@ -106,14 +105,14 @@ emitTickyCounter cl_info args -- krc: note that all the fields are I32 now; some were I16 before, -- but the code generator wasn't handling that properly and it led to chaos, -- panic and disorder. - [ mkIntCLit 0, - mkIntCLit (length args), -- Arity - mkIntCLit 0, -- XXX: we no longer know this! Words passed on stack + [ mkIntCLit dflags 0, + mkIntCLit dflags (length args), -- Arity + mkIntCLit dflags 0, -- XXX: we no longer know this! Words passed on stack fun_descr_lit, arg_descr_lit, - zeroCLit, -- Entry count - zeroCLit, -- Allocs - zeroCLit -- Link + zeroCLit dflags, -- Entry count + zeroCLit dflags, -- Allocs + zeroCLit dflags -- Link ] } -- When printing the name of a thing in a ticky file, we want to @@ -164,10 +163,11 @@ tickyUpdateBhCaf cl_info tickyEnterFun :: ClosureInfo -> FCode () tickyEnterFun cl_info = ifTicky $ - do { bumpTickyCounter ctr + do { dflags <- getDynFlags + ; bumpTickyCounter ctr ; fun_ctr_lbl <- getTickyCtrLabel ; registerTickyCtr fun_ctr_lbl - ; bumpTickyCounter' (cmmLabelOffB fun_ctr_lbl oFFSET_StgEntCounter_entry_count) + ; bumpTickyCounter' (cmmLabelOffB fun_ctr_lbl (oFFSET_StgEntCounter_entry_count dflags)) } where ctr | isStaticClosure cl_info = (fsLit "ENT_STATIC_FUN_DIRECT_ctr") @@ -179,22 +179,23 @@ registerTickyCtr :: CLabel -> FCode () -- f_ct.link = ticky_entry_ctrs; /* hook this one onto the front of the list */ -- ticky_entry_ctrs = & (f_ct); /* mark it as "registered" */ -- f_ct.registeredp = 1 } -registerTickyCtr ctr_lbl - = emit =<< mkCmmIfThen test (catAGraphs register_stmts) - where +registerTickyCtr ctr_lbl = do + dflags <- getDynFlags + let -- krc: code generator doesn't handle Not, so we test for Eq 0 instead - test = CmmMachOp (MO_Eq wordWidth) - [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl - oFFSET_StgEntCounter_registeredp)) bWord, - zeroExpr] + test = CmmMachOp (MO_Eq (wordWidth dflags)) + [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl + (oFFSET_StgEntCounter_registeredp dflags))) (bWord dflags), + zeroExpr dflags] register_stmts - = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_link)) - (CmmLoad ticky_entry_ctrs bWord) - , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl) - , mkStore (CmmLit (cmmLabelOffB ctr_lbl - oFFSET_StgEntCounter_registeredp)) - (mkIntExpr 1) ] + = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_link dflags))) + (CmmLoad ticky_entry_ctrs (bWord dflags)) + , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl) + , mkStore (CmmLit (cmmLabelOffB ctr_lbl + (oFFSET_StgEntCounter_registeredp dflags))) + (mkIntExpr dflags 1) ] ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs")) + emit =<< mkCmmIfThen test (catAGraphs register_stmts) tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode () tickyReturnOldCon arity @@ -314,14 +315,15 @@ tickyAllocHeap :: VirtualHpOffset -> FCode () -- Must be lazy in the amount of allocation! tickyAllocHeap hp = ifTicky $ - do { ticky_ctr <- getTickyCtrLabel + do { dflags <- getDynFlags + ; ticky_ctr <- getTickyCtrLabel ; emit $ catAGraphs $ if hp == 0 then [] -- Inside the emitMiddle to avoid control else [ -- dependency on the argument -- Bump the allcoation count in the StgEntCounter addToMem REP_StgEntCounter_allocs (CmmLit (cmmLabelOffB ticky_ctr - oFFSET_StgEntCounter_allocs)) hp, + (oFFSET_StgEntCounter_allocs dflags))) hp, -- Bump ALLOC_HEAP_ctr addToMemLbl cLong (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_ctr")) 1, -- Bump ALLOC_HEAP_tot diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 8cb0ee89be..52bd114b5d 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -68,7 +68,6 @@ import Unique import DynFlags import FastString import Outputable -import Platform import Data.Char import Data.List @@ -86,31 +85,32 @@ import Data.Maybe cgLit :: Literal -> FCode CmmLit cgLit (MachStr s) = newByteStringCLit (bytesFB s) -- not unpackFS; we want the UTF-8 byte stream. -cgLit other_lit = return (mkSimpleLit other_lit) +cgLit other_lit = do dflags <- getDynFlags + return (mkSimpleLit dflags other_lit) -mkLtOp :: Literal -> MachOp +mkLtOp :: DynFlags -> Literal -> MachOp -- On signed literals we must do a signed comparison -mkLtOp (MachInt _) = MO_S_Lt wordWidth -mkLtOp (MachFloat _) = MO_F_Lt W32 -mkLtOp (MachDouble _) = MO_F_Lt W64 -mkLtOp lit = MO_U_Lt (typeWidth (cmmLitType (mkSimpleLit lit))) +mkLtOp dflags (MachInt _) = MO_S_Lt (wordWidth dflags) +mkLtOp _ (MachFloat _) = MO_F_Lt W32 +mkLtOp _ (MachDouble _) = MO_F_Lt W64 +mkLtOp dflags lit = MO_U_Lt (typeWidth (cmmLitType dflags (mkSimpleLit dflags lit))) -- ToDo: seems terribly indirect! -mkSimpleLit :: Literal -> CmmLit -mkSimpleLit (MachChar c) = CmmInt (fromIntegral (ord c)) wordWidth -mkSimpleLit MachNullAddr = zeroCLit -mkSimpleLit (MachInt i) = CmmInt i wordWidth -mkSimpleLit (MachInt64 i) = CmmInt i W64 -mkSimpleLit (MachWord i) = CmmInt i wordWidth -mkSimpleLit (MachWord64 i) = CmmInt i W64 -mkSimpleLit (MachFloat r) = CmmFloat r W32 -mkSimpleLit (MachDouble r) = CmmFloat r W64 -mkSimpleLit (MachLabel fs ms fod) +mkSimpleLit :: DynFlags -> Literal -> CmmLit +mkSimpleLit dflags (MachChar c) = CmmInt (fromIntegral (ord c)) (wordWidth dflags) +mkSimpleLit dflags MachNullAddr = zeroCLit dflags +mkSimpleLit dflags (MachInt i) = CmmInt i (wordWidth dflags) +mkSimpleLit _ (MachInt64 i) = CmmInt i W64 +mkSimpleLit dflags (MachWord i) = CmmInt i (wordWidth dflags) +mkSimpleLit _ (MachWord64 i) = CmmInt i W64 +mkSimpleLit _ (MachFloat r) = CmmFloat r W32 +mkSimpleLit _ (MachDouble r) = CmmFloat r W64 +mkSimpleLit _ (MachLabel fs ms fod) = CmmLabel (mkForeignLabel fs ms labelSrc fod) where -- TODO: Literal labels might not actually be in the current package... labelSrc = ForeignLabelInThisPackage -mkSimpleLit other = pprPanic "mkSimpleLit" (ppr other) +mkSimpleLit _ other = pprPanic "mkSimpleLit" (ppr other) -------------------------------------------------------------------------- -- @@ -142,13 +142,14 @@ addToMemE rep ptr n -- ------------------------------------------------------------------------- -mkTaggedObjectLoad :: LocalReg -> LocalReg -> WordOff -> DynTag -> CmmAGraph +mkTaggedObjectLoad :: DynFlags -> LocalReg -> LocalReg -> WordOff -> DynTag -> CmmAGraph -- (loadTaggedObjectField reg base off tag) generates assignment -- reg = bitsK[ base + off - tag ] -- where K is fixed by 'reg' -mkTaggedObjectLoad reg base offset tag +mkTaggedObjectLoad dflags reg base offset tag = mkAssign (CmmLocal reg) - (CmmLoad (cmmOffsetB (CmmReg (CmmLocal base)) + (CmmLoad (cmmOffsetB dflags + (CmmReg (CmmLocal base)) (wORD_SIZE*offset - tag)) (localRegType reg)) @@ -159,9 +160,9 @@ mkTaggedObjectLoad reg base offset tag -- ------------------------------------------------------------------------- -tagToClosure :: TyCon -> CmmExpr -> CmmExpr -tagToClosure tycon tag - = CmmLoad (cmmOffsetExprW closure_tbl tag) bWord +tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr +tagToClosure dflags tycon tag + = CmmLoad (cmmOffsetExprW dflags closure_tbl tag) (bWord dflags) where closure_tbl = CmmLit (CmmLabel lbl) lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs @@ -251,11 +252,11 @@ callerSaveVolatileRegs dflags = (caller_save, caller_load) regs_to_save = filter (callerSaves platform) system_regs callerSaveGlobalReg reg - = mkStore (get_GlobalReg_addr platform reg) (CmmReg (CmmGlobal reg)) + = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg)) callerRestoreGlobalReg reg = mkAssign (CmmGlobal reg) - (CmmLoad (get_GlobalReg_addr platform reg) (globalRegType reg)) + (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg)) -- ----------------------------------------------------------------------------- -- Global registers @@ -266,42 +267,42 @@ callerSaveVolatileRegs dflags = (caller_save, caller_load) -- register table address for it. -- (See also get_GlobalReg_reg_or_addr in MachRegs) -get_GlobalReg_addr :: Platform -> GlobalReg -> CmmExpr -get_GlobalReg_addr _ BaseReg = regTableOffset 0 -get_GlobalReg_addr platform mid - = get_Regtable_addr_from_offset platform - (globalRegType mid) (baseRegOffset mid) +get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr +get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0 +get_GlobalReg_addr dflags mid + = get_Regtable_addr_from_offset dflags + (globalRegType dflags mid) (baseRegOffset dflags mid) -- Calculate a literal representing an offset into the register table. -- Used when we don't have an actual BaseReg to offset from. -regTableOffset :: Int -> CmmExpr -regTableOffset n = - CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n)) +regTableOffset :: DynFlags -> Int -> CmmExpr +regTableOffset dflags n = + CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n)) -get_Regtable_addr_from_offset :: Platform -> CmmType -> Int -> CmmExpr -get_Regtable_addr_from_offset platform _rep offset = - if haveRegBase platform +get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr +get_Regtable_addr_from_offset dflags _rep offset = + if haveRegBase (targetPlatform dflags) then CmmRegOff (CmmGlobal BaseReg) offset - else regTableOffset offset + else regTableOffset dflags offset -- ----------------------------------------------------------------------------- -- Information about global registers -baseRegOffset :: GlobalReg -> Int - -baseRegOffset Sp = oFFSET_StgRegTable_rSp -baseRegOffset SpLim = oFFSET_StgRegTable_rSpLim -baseRegOffset (LongReg 1) = oFFSET_StgRegTable_rL1 -baseRegOffset Hp = oFFSET_StgRegTable_rHp -baseRegOffset HpLim = oFFSET_StgRegTable_rHpLim -baseRegOffset CCCS = oFFSET_StgRegTable_rCCCS -baseRegOffset CurrentTSO = oFFSET_StgRegTable_rCurrentTSO -baseRegOffset CurrentNursery = oFFSET_StgRegTable_rCurrentNursery -baseRegOffset HpAlloc = oFFSET_StgRegTable_rHpAlloc -baseRegOffset GCEnter1 = oFFSET_stgGCEnter1 -baseRegOffset GCFun = oFFSET_stgGCFun -baseRegOffset reg = pprPanic "baseRegOffset:" (ppr reg) +baseRegOffset :: DynFlags -> GlobalReg -> Int + +baseRegOffset dflags Sp = oFFSET_StgRegTable_rSp dflags +baseRegOffset dflags SpLim = oFFSET_StgRegTable_rSpLim dflags +baseRegOffset dflags (LongReg 1) = oFFSET_StgRegTable_rL1 dflags +baseRegOffset dflags Hp = oFFSET_StgRegTable_rHp dflags +baseRegOffset dflags HpLim = oFFSET_StgRegTable_rHpLim dflags +baseRegOffset dflags CCCS = oFFSET_StgRegTable_rCCCS dflags +baseRegOffset dflags CurrentTSO = oFFSET_StgRegTable_rCurrentTSO dflags +baseRegOffset dflags CurrentNursery = oFFSET_StgRegTable_rCurrentNursery dflags +baseRegOffset dflags HpAlloc = oFFSET_StgRegTable_rHpAlloc dflags +baseRegOffset dflags GCEnter1 = oFFSET_stgGCEnter1 dflags +baseRegOffset dflags GCFun = oFFSET_stgGCFun dflags +baseRegOffset _ reg = pprPanic "baseRegOffset:" (ppr reg) ------------------------------------------------------------------------- -- @@ -344,8 +345,9 @@ assignTemp :: CmmExpr -> FCode LocalReg -- due to them being trashed on foreign calls--though it means -- the optimization pass doesn't have to do as much work) assignTemp (CmmReg (CmmLocal reg)) = return reg -assignTemp e = do { uniq <- newUnique - ; let reg = LocalReg uniq (cmmExprType e) +assignTemp e = do { dflags <- getDynFlags + ; uniq <- newUnique + ; let reg = LocalReg uniq (cmmExprType dflags e) ; emitAssign (CmmLocal reg) e ; return reg } @@ -360,8 +362,9 @@ newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint]) -- regs it wants will save later assignments. newUnboxedTupleRegs res_ty = ASSERT( isUnboxedTupleType res_ty ) - do { sequel <- getSequel - ; regs <- choose_regs sequel + do { dflags <- getDynFlags + ; sequel <- getSequel + ; regs <- choose_regs dflags sequel ; ASSERT( regs `equalLength` reps ) return (regs, map primRepForeignHint reps) } where @@ -370,8 +373,8 @@ newUnboxedTupleRegs res_ty | ty <- ty_args , let rep = typePrimRep ty , not (isVoidRep rep) ] - choose_regs (AssignTo regs _) = return regs - choose_regs _other = mapM (newTemp . primRepCmmType) reps + choose_regs _ (AssignTo regs _) = return regs + choose_regs dflags _ = mapM (newTemp . primRepCmmType dflags) reps @@ -423,17 +426,18 @@ unscramble vertices = mapM_ do_component components -- Cyclic? Then go via temporaries. Pick one to -- break the loop and try again with the rest. do_component (CyclicSCC ((_,first_stmt) : rest)) = do + dflags <- getDynFlags u <- newUnique - let (to_tmp, from_tmp) = split u first_stmt + let (to_tmp, from_tmp) = split dflags u first_stmt mk_graph to_tmp unscramble rest mk_graph from_tmp - split :: Unique -> Stmt -> (Stmt, Stmt) - split uniq (reg, rhs) + split :: DynFlags -> Unique -> Stmt -> (Stmt, Stmt) + split dflags uniq (reg, rhs) = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp))) where - rep = cmmExprType rhs + rep = cmmExprType dflags rhs tmp = LocalReg uniq rep mk_graph :: Stmt -> FCode () @@ -510,11 +514,11 @@ mk_switch _tag_expr [(_tag,lbl)] Nothing _ _ _ -- SINGLETON BRANCH: one equality check to do mk_switch tag_expr [(tag,lbl)] (Just deflt) _ _ _ - = return (mkCbranch cond deflt lbl) - where - cond = cmmNeWord tag_expr (mkIntExpr tag) - -- We have lo_tag < hi_tag, but there's only one branch, - -- so there must be a default + = do dflags <- getDynFlags + let cond = cmmNeWord dflags tag_expr (mkIntExpr dflags tag) + -- We have lo_tag < hi_tag, but there's only one branch, + -- so there must be a default + return (mkCbranch cond deflt lbl) -- ToDo: we might want to check for the two branch case, where one of -- the branches is the tag 0, because comparing '== 0' is likely to be @@ -531,7 +535,7 @@ mk_switch tag_expr [(tag,lbl)] (Just deflt) _ _ _ -- mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C | use_switch -- Use a switch - = let + = do let find_branch :: ConTagZ -> Maybe BlockId find_branch i = case (assocMaybe branches i) of Just lbl -> Just lbl @@ -542,33 +546,36 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C -- tag of a real branch is real_lo_tag (not lo_tag). arms :: [Maybe BlockId] arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]] - in - return (mkSwitch (cmmOffset tag_expr (- real_lo_tag)) arms) + dflags <- getDynFlags + return (mkSwitch (cmmOffset dflags tag_expr (- real_lo_tag)) arms) -- if we can knock off a bunch of default cases with one if, then do so | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches - = do stmts <- mk_switch tag_expr branches mb_deflt + = do dflags <- getDynFlags + stmts <- mk_switch tag_expr branches mb_deflt lowest_branch hi_tag via_C mkCmmIfThenElse - (cmmULtWord tag_expr (mkIntExpr lowest_branch)) + (cmmULtWord dflags tag_expr (mkIntExpr dflags lowest_branch)) (mkBranch deflt) stmts | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches - = do stmts <- mk_switch tag_expr branches mb_deflt + = do dflags <- getDynFlags + stmts <- mk_switch tag_expr branches mb_deflt lo_tag highest_branch via_C mkCmmIfThenElse - (cmmUGtWord tag_expr (mkIntExpr highest_branch)) + (cmmUGtWord dflags tag_expr (mkIntExpr dflags highest_branch)) (mkBranch deflt) stmts | otherwise -- Use an if-tree - = do lo_stmts <- mk_switch tag_expr lo_branches mb_deflt + = do dflags <- getDynFlags + lo_stmts <- mk_switch tag_expr lo_branches mb_deflt lo_tag (mid_tag-1) via_C hi_stmts <- mk_switch tag_expr hi_branches mb_deflt mid_tag hi_tag via_C mkCmmIfThenElse - (cmmUGeWord tag_expr (mkIntExpr mid_tag)) + (cmmUGeWord dflags tag_expr (mkIntExpr dflags mid_tag)) hi_stmts lo_stmts -- we test (e >= mid_tag) rather than (e < mid_tag), because @@ -649,17 +656,20 @@ mk_lit_switch :: CmmExpr -> BlockId -> [(Literal,BlockId)] -> FCode CmmAGraph mk_lit_switch scrut deflt [(lit,blk)] - = return (mkCbranch (CmmMachOp ne [scrut, CmmLit cmm_lit]) deflt blk) - where - cmm_lit = mkSimpleLit lit - cmm_ty = cmmLitType cmm_lit + = do + dflags <- getDynFlags + let + cmm_lit = mkSimpleLit dflags lit + cmm_ty = cmmLitType dflags cmm_lit rep = typeWidth cmm_ty ne = if isFloatType cmm_ty then MO_F_Ne rep else MO_Ne rep + return (mkCbranch (CmmMachOp ne [scrut, CmmLit cmm_lit]) deflt blk) mk_lit_switch scrut deflt_blk_id branches - = do lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches + = do dflags <- getDynFlags + lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches - mkCmmIfThenElse cond lo_blk hi_blk + mkCmmIfThenElse (cond dflags) lo_blk hi_blk where n_branches = length branches (mid_lit,_) = branches !! (n_branches `div` 2) @@ -668,8 +678,8 @@ mk_lit_switch scrut deflt_blk_id branches (lo_branches, hi_branches) = span is_lo branches is_lo (t,_) = t < mid_lit - cond = CmmMachOp (mkLtOp mid_lit) - [scrut, CmmLit (mkSimpleLit mid_lit)] + cond dflags = CmmMachOp (mkLtOp dflags mid_lit) + [scrut, CmmLit (mkSimpleLit dflags mid_lit)] -------------- @@ -705,7 +715,8 @@ assignTemp' :: CmmExpr -> FCode CmmExpr assignTemp' e | isTrivialCmmExpr e = return e | otherwise = do - lreg <- newTemp (cmmExprType e) + dflags <- getDynFlags + lreg <- newTemp (cmmExprType dflags e) let reg = CmmLocal lreg emitAssign reg e return (CmmReg reg) diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index e1c0e30a58..478c5985c8 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -141,6 +141,7 @@ dsCImport :: Id -> Maybe Header -> DsM ([Binding], SDoc, SDoc) dsCImport id co (CLabel cid) cconv _ _ = do + dflags <- getDynFlags let ty = pFst $ coercionKind co fod = case tyConAppTyCon_maybe (dropForAlls ty) of Just tycon @@ -152,7 +153,7 @@ dsCImport id co (CLabel cid) cconv _ _ = do let rhs = foRhs (Lit (MachLabel cid stdcall_info fod)) rhs' = Cast rhs co - stdcall_info = fun_type_arg_stdcall_info cconv ty + stdcall_info = fun_type_arg_stdcall_info dflags cconv ty in return ([(id, rhs')], empty, empty) @@ -166,15 +167,15 @@ dsCImport id co CWrapper cconv _ _ -- For stdcall labels, if the type was a FunPtr or newtype thereof, -- then we need to calculate the size of the arguments in order to add -- the @n suffix to the label. -fun_type_arg_stdcall_info :: CCallConv -> Type -> Maybe Int -fun_type_arg_stdcall_info StdCallConv ty +fun_type_arg_stdcall_info :: DynFlags -> CCallConv -> Type -> Maybe Int +fun_type_arg_stdcall_info dflags StdCallConv ty | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty, tyConUnique tc == funPtrTyConKey = let (_tvs,sans_foralls) = tcSplitForAllTys arg_ty (fe_arg_tys, _orig_res_ty) = tcSplitFunTys sans_foralls - in Just $ sum (map (widthInBytes . typeWidth . typeCmmType . getPrimTyOf) fe_arg_tys) -fun_type_arg_stdcall_info _other_conv _ + in Just $ sum (map (widthInBytes . typeWidth . typeCmmType dflags . getPrimTyOf) fe_arg_tys) +fun_type_arg_stdcall_info _ _other_conv _ = Nothing \end{code} @@ -519,7 +520,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc (arg_cname n stg_type, stg_type, ty, - typeCmmType (getPrimTyOf ty)) + typeCmmType dflags (getPrimTyOf ty)) | (ty,n) <- zip arg_htys [1::Int ..] ] arg_cname n stg_ty @@ -546,7 +547,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc stable_ptr_arg = (text "the_stableptr", text "StgStablePtr", undefined, - typeCmmType (mkStablePtrPrimTy alphaTy)) + typeCmmType dflags (mkStablePtrPrimTy alphaTy)) -- stuff to do with the return type of the C function res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes @@ -735,7 +736,7 @@ insertRetAddr dflags CCallConv args -- (See rts/Adjustor.c for details). let go :: Int -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)] - go 4 args = ret_addr_arg : args + go 4 args = ret_addr_arg dflags : args go n (arg:args) = arg : go (n+1) args go _ [] = [] in go 0 args @@ -746,20 +747,20 @@ insertRetAddr dflags CCallConv args -- (See rts/Adjustor.c for details). let go :: Int -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)] - go 6 args = ret_addr_arg : args + go 6 args = ret_addr_arg dflags : args go n (arg@(_,_,_,rep):args) | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args | otherwise = arg : go n args go _ [] = [] in go 0 args _ -> - ret_addr_arg : args + ret_addr_arg dflags : args where platform = targetPlatform dflags insertRetAddr _ _ args = args -ret_addr_arg :: (SDoc, SDoc, Type, CmmType) -ret_addr_arg = (text "original_return_addr", text "void*", undefined, - typeCmmType addrPrimTy) +ret_addr_arg :: DynFlags -> (SDoc, SDoc, Type, CmmType) +ret_addr_arg dflags = (text "original_return_addr", text "void*", undefined, + typeCmmType dflags addrPrimTy) -- This function returns the primitive type associated with the boxed -- type argument to a foreign export (eg. Int ==> Int#). diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index e02e9d9869..f07cccffe0 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -49,7 +49,7 @@ Library Exposed: False Build-Depends: base >= 4 && < 5, - directory >= 1 && < 1.2, + directory >= 1 && < 1.3, process >= 1 && < 1.2, bytestring >= 0.9 && < 0.11, time < 1.5, @@ -542,6 +542,7 @@ Library RegAlloc.Linear.StackMap RegAlloc.Linear.Base RegAlloc.Linear.X86.FreeRegs + RegAlloc.Linear.X86_64.FreeRegs RegAlloc.Linear.PPC.FreeRegs RegAlloc.Linear.SPARC.FreeRegs diff --git a/compiler/ghc.mk b/compiler/ghc.mk index ad92b6f2e2..f65813dd94 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -461,9 +461,18 @@ $(compiler_stage1_depfile_haskell) : compiler/stage1/$(PLATFORM_H) $(compiler_stage2_depfile_haskell) : compiler/stage2/$(PLATFORM_H) $(compiler_stage3_depfile_haskell) : compiler/stage3/$(PLATFORM_H) -$(compiler_stage1_depfile_haskell) : $(includes_H_CONFIG) $(includes_H_PLATFORM) $(includes_GHCCONSTANTS) $(includes_DERIVEDCONSTANTS) $(PRIMOP_BITS) -$(compiler_stage2_depfile_haskell) : $(includes_H_CONFIG) $(includes_H_PLATFORM) $(includes_GHCCONSTANTS) $(includes_DERIVEDCONSTANTS) $(PRIMOP_BITS) -$(compiler_stage3_depfile_haskell) : $(includes_H_CONFIG) $(includes_H_PLATFORM) $(includes_GHCCONSTANTS) $(includes_DERIVEDCONSTANTS) $(PRIMOP_BITS) +COMPILER_INCLUDES_DEPS += $(includes_H_CONFIG) +COMPILER_INCLUDES_DEPS += $(includes_H_PLATFORM) +COMPILER_INCLUDES_DEPS += $(includes_GHCCONSTANTS) +COMPILER_INCLUDES_DEPS += $(includes_GHCCONSTANTS_HASKELL_TYPE) +COMPILER_INCLUDES_DEPS += $(includes_GHCCONSTANTS_HASKELL_WRAPPERS) +COMPILER_INCLUDES_DEPS += $(includes_GHCCONSTANTS_HASKELL_EXPORTS) +COMPILER_INCLUDES_DEPS += $(includes_DERIVEDCONSTANTS) +COMPILER_INCLUDES_DEPS += $(PRIMOP_BITS) + +$(compiler_stage1_depfile_haskell) : $(COMPILER_INCLUDES_DEPS) +$(compiler_stage2_depfile_haskell) : $(COMPILER_INCLUDES_DEPS) +$(compiler_stage3_depfile_haskell) : $(COMPILER_INCLUDES_DEPS) # Every Constants.o object file depends on includes/GHCConstants.h: $(eval $(call compiler-hs-dependency,Constants,$(includes_GHCCONSTANTS) includes/HaskellConstants.hs)) diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index 73724c007e..e9dc7d1b21 100644 --- a/compiler/ghci/ByteCodeAsm.lhs +++ b/compiler/ghci/ByteCodeAsm.lhs @@ -133,7 +133,7 @@ assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = d -- Remember that the first insn starts at offset -- sizeOf Word / sizeOf Word16 -- since offset 0 (eventually) will hold the total # of insns. - initial_offset = largeArg16s + initial_offset = largeArg16s dflags -- Jump instructions are variable-sized, there are long and short variants -- depending on the magnitude of the offset. However, we can't tell what @@ -143,9 +143,9 @@ assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = d -- and if the final size is indeed small enough for short jumps, we are -- done. Otherwise, we repeat the calculation, and we force all jumps in -- this BCO to be long. - (n_insns0, lbl_map0) = inspectAsm False initial_offset asm + (n_insns0, lbl_map0) = inspectAsm dflags False initial_offset asm ((n_insns, lbl_map), long_jumps) - | isLarge n_insns0 = (inspectAsm True initial_offset asm, True) + | isLarge n_insns0 = (inspectAsm dflags True initial_offset asm, True) | otherwise = ((n_insns0, lbl_map0), False) env :: Word16 -> Word @@ -154,9 +154,9 @@ assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = d (Map.lookup lbl lbl_map) -- pass 2: run assembler and generate instructions, literals and pointers - let initial_insns = addListToSS emptySS $ largeArg n_insns + let initial_insns = addListToSS emptySS $ largeArg dflags n_insns let initial_state = (initial_insns, emptySS, emptySS) - (final_insns, final_lits, final_ptrs) <- execState initial_state $ runAsm long_jumps env asm + (final_insns, final_lits, final_ptrs) <- execState initial_state $ runAsm dflags long_jumps env asm -- precomputed size should be equal to final size ASSERT (n_insns == sizeSS final_insns) return () @@ -250,8 +250,8 @@ largeOp long_jumps op = case op of Op w -> isLarge w LabelOp _ -> long_jumps -runAsm :: Bool -> LabelEnv -> Assembler a -> State AsmState IO a -runAsm long_jumps e = go +runAsm :: DynFlags -> Bool -> LabelEnv -> Assembler a -> State AsmState IO a +runAsm dflags long_jumps e = go where go (NullAsm x) = return x go (AllocPtr p_io k) = do @@ -273,9 +273,9 @@ runAsm long_jumps e = go | otherwise = w words = concatMap expand ops expand (SmallOp w) = [w] - expand (LargeOp w) = largeArg w + expand (LargeOp w) = largeArg dflags w expand (LabelOp w) = expand (Op (e w)) - expand (Op w) = if largeOps then largeArg w else [fromIntegral w] + expand (Op w) = if largeOps then largeArg dflags w else [fromIntegral w] State $ \(st_i0,st_l0,st_p0) -> do let st_i1 = addListToSS st_i0 (opcode : words) return ((st_i1,st_l0,st_p0), ()) @@ -290,8 +290,8 @@ data InspectState = InspectState , lblEnv :: LabelEnvMap } -inspectAsm :: Bool -> Word -> Assembler a -> (Word, LabelEnvMap) -inspectAsm long_jumps initial_offset +inspectAsm :: DynFlags -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap) +inspectAsm dflags long_jumps initial_offset = go (InspectState initial_offset 0 0 Map.empty) where go s (NullAsm _) = (instrCount s, lblEnv s) @@ -307,9 +307,9 @@ inspectAsm long_jumps initial_offset size = sum (map count ops) + 1 largeOps = any (largeOp long_jumps) ops count (SmallOp _) = 1 - count (LargeOp _) = largeArg16s + count (LargeOp _) = largeArg16s dflags count (LabelOp _) = count (Op 0) - count (Op _) = if largeOps then largeArg16s else 1 + count (Op _) = if largeOps then largeArg16s dflags else 1 -- Bring in all the bci_ bytecode constants. #include "rts/Bytecodes.h" @@ -317,21 +317,21 @@ inspectAsm long_jumps initial_offset largeArgInstr :: Word16 -> Word16 largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci -largeArg :: Word -> [Word16] -largeArg w - | wORD_SIZE_IN_BITS == 64 +largeArg :: DynFlags -> Word -> [Word16] +largeArg dflags w + | wORD_SIZE_IN_BITS dflags == 64 = [fromIntegral (w `shiftR` 48), fromIntegral (w `shiftR` 32), fromIntegral (w `shiftR` 16), fromIntegral w] - | wORD_SIZE_IN_BITS == 32 + | wORD_SIZE_IN_BITS dflags == 32 = [fromIntegral (w `shiftR` 16), fromIntegral w] | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?" -largeArg16s :: Word -largeArg16s | wORD_SIZE_IN_BITS == 64 = 4 - | otherwise = 2 +largeArg16s :: DynFlags -> Word +largeArg16s dflags | wORD_SIZE_IN_BITS dflags == 64 = 4 + | otherwise = 2 assembleI :: DynFlags -> BCInstr diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index b277a1ed30..59dfbc896e 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -49,7 +49,6 @@ import SMRep import ClosureInfo import Bitmap import OrdList -import Constants import Data.List import Foreign @@ -152,7 +151,8 @@ ppBCEnv p -- Create a BCO and do a spot of peephole optimisation on the insns -- at the same time. mkProtoBCO - :: name + :: DynFlags + -> name -> BCInstrList -> Either [AnnAlt Id VarSet] (AnnExpr Id VarSet) -> Int @@ -161,10 +161,10 @@ mkProtoBCO -> Bool -- True <=> is a return point, rather than a function -> [BcPtr] -> ProtoBCO name -mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks +mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks = ProtoBCO { protoBCOName = nm, - protoBCOInstrs = maybe_with_stack_check, + protoBCOInstrs = maybe_with_stack_check dflags, protoBCOBitmap = bitmap, protoBCOBitmapSize = bitmap_size, protoBCOArity = arity, @@ -179,8 +179,8 @@ mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_bloc -- BCO anyway, so we only need to add an explicit one in the -- (hopefully rare) cases when the (overestimated) stack use -- exceeds iNTERP_STACK_CHECK_THRESH. - maybe_with_stack_check - | is_ret && stack_usage < fromIntegral aP_STACK_SPLIM = peep_d + maybe_with_stack_check dflags + | is_ret && stack_usage < fromIntegral (aP_STACK_SPLIM dflags) = peep_d -- don't do stack checks at return points, -- everything is aggregated up to the top BCO -- (which must be a function). @@ -223,6 +223,7 @@ schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name) schemeTopBind (id, rhs) | Just data_con <- isDataConWorkId_maybe id, isNullaryRepDataCon data_con = do + dflags <- getDynFlags -- Special case for the worker of a nullary data con. -- It'll look like this: Nil = /\a -> Nil a -- If we feed it into schemeR, we'll get @@ -231,7 +232,7 @@ schemeTopBind (id, rhs) -- by just re-using the single top-level definition. So -- for the worker itself, we must allocate it directly. -- ioToBc (putStrLn $ "top level BCO") - emitBc (mkProtoBCO (getName id) (toOL [PACK data_con 0, ENTER]) + emitBc (mkProtoBCO dflags (getName id) (toOL [PACK data_con 0, ENTER]) (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) | otherwise @@ -281,7 +282,9 @@ collect (_, e) = go [] e schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name) schemeR_wrk fvs nm original_body (args, body) - = let + = do + dflags <- getDynFlags + let all_args = reverse args ++ fvs arity = length all_args -- all_args are the args in reverse order. We're compiling a function @@ -295,11 +298,10 @@ schemeR_wrk fvs nm original_body (args, body) -- make the arg bitmap bits = argBits (reverse (map idCgRep all_args)) bitmap_size = genericLength bits - bitmap = mkBitmap bits - in do + bitmap = mkBitmap dflags bits body_code <- schemeER_wrk szw_args p_init body - emitBc (mkProtoBCO (getName nm) body_code (Right original_body) + emitBc (mkProtoBCO dflags (getName nm) body_code (Right original_body) arity bitmap_size bitmap False{-not alts-}) -- introduce break instructions for ticked expressions @@ -772,7 +774,9 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple | UbxTupleRep _ <- repType (idType bndr) = unboxedTupleException | otherwise - = let + = do + dflags <- getDynFlags + let -- Top of stack is the return itbl, as usual. -- underneath it is the pointer to the alt_code BCO. -- When an alt is entered, it assumes the returned value is @@ -875,7 +879,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple bitmap_size = trunc16 $ d-s bitmap_size' :: Int bitmap_size' = fromIntegral bitmap_size - bitmap = intsToReverseBitmap bitmap_size'{-size-} + bitmap = intsToReverseBitmap dflags bitmap_size'{-size-} (sort (filter (< bitmap_size') rel_slots)) where binds = Map.toList p @@ -886,13 +890,12 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple | otherwise = [] where rel_offset = trunc16 $ d - fromIntegral offset - 1 - in do alt_stuff <- mapM codeAlt alts alt_final <- mkMultiBranch maybe_ncons alt_stuff let alt_bco_name = getName bndr - alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts) + alt_bco = mkProtoBCO dflags alt_bco_name alt_final (Left alts) 0{-no arity-} bitmap_size bitmap True{-is alts-} -- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++ -- "\n bitmap = " ++ show bitmap) $ do diff --git a/compiler/ghci/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs index 9b22ec8cd6..b88c81226a 100644 --- a/compiler/ghci/ByteCodeItbls.lhs +++ b/compiler/ghci/ByteCodeItbls.lhs @@ -27,7 +27,7 @@ import ClosureInfo import DataCon ( DataCon, dataConRepArgTys, dataConIdentity ) import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) import Type ( flattenRepType, repType ) -import Constants ( mIN_PAYLOAD_SIZE, wORD_SIZE ) +import Constants ( wORD_SIZE ) import CgHeapery ( mkVirtHeapOffsets ) import Util @@ -106,8 +106,8 @@ make_constr_itbls dflags cons ptrs' = ptr_wds nptrs' = tot_wds - ptr_wds nptrs_really - | ptrs' + nptrs' >= mIN_PAYLOAD_SIZE = nptrs' - | otherwise = mIN_PAYLOAD_SIZE - ptrs' + | ptrs' + nptrs' >= mIN_PAYLOAD_SIZE dflags = nptrs' + | otherwise = mIN_PAYLOAD_SIZE dflags - ptrs' code' = mkJumpToAddr entry_addr itbl = StgInfoTable { #ifndef GHCI_TABLES_NEXT_TO_CODE diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index 2ff1ed9829..211620ac42 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -146,7 +146,7 @@ cmmLlvmGen :: DynFlags -> UniqSupply -> LlvmEnv -> RawCmmDecl cmmLlvmGen dflags us env cmm = do -- rewrite assignments to global regs let fixed_cmm = {-# SCC "llvm_fix_regs" #-} - fixStgRegisters (targetPlatform dflags) cmm + fixStgRegisters dflags cmm dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup [fixed_cmm]) diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index d9a43fb249..00c2129ed9 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -137,8 +137,8 @@ tysToParams :: [LlvmType] -> [LlvmParameter] tysToParams = map (\ty -> (ty, [])) -- | Pointer width -llvmPtrBits :: Int -llvmPtrBits = widthInBits $ typeWidth gcWord +llvmPtrBits :: DynFlags -> Int +llvmPtrBits dflags = widthInBits $ typeWidth $ gcWord dflags -- ---------------------------------------------------------------------------- -- * Llvm Version diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 7f80cab617..f80a4f2b4c 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -243,10 +243,12 @@ genCall env (CmmPrim _ (Just stmts)) _ _ _ -- Handle all other foreign calls and prim ops. genCall env target res args ret = do + let dflags = getDflags env + -- parameter types let arg_type (CmmHinted _ AddrHint) = i8Ptr -- cast pointers to i8*. Llvm equivalent of void* - arg_type (CmmHinted expr _ ) = cmmToLlvmType $ cmmExprType expr + arg_type (CmmHinted expr _ ) = cmmToLlvmType $ cmmExprType dflags expr -- ret type let ret_type ([]) = LMVoid @@ -650,9 +652,10 @@ genStore_slow env addr val meta = do other -> pprPanic "genStore: ptr not right type!" (PprCmm.pprExpr addr <+> text ( - "Size of Ptr: " ++ show llvmPtrBits ++ + "Size of Ptr: " ++ show (llvmPtrBits dflags) ++ ", Size of var: " ++ show (llvmWidthInBits other) ++ ", Var: " ++ show vaddr)) + where dflags = getDflags env -- | Unconditional branch @@ -755,11 +758,12 @@ exprToVarOpt env opt e = case e of -> genMachOp env opt op exprs CmmRegOff r i - -> exprToVar env $ expandCmmReg (r, i) + -> exprToVar env $ expandCmmReg dflags (r, i) CmmStackSlot _ _ -> panic "exprToVar: CmmStackSlot not supported!" + where dflags = getDflags env -- | Handle CmmMachOp expressions genMachOp :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData @@ -1127,10 +1131,10 @@ genLoad_slow env e ty meta = do other -> pprPanic "exprToVar: CmmLoad expression is not right type!" (PprCmm.pprExpr e <+> text ( - "Size of Ptr: " ++ show llvmPtrBits ++ + "Size of Ptr: " ++ show (llvmPtrBits dflags) ++ ", Size of var: " ++ show (llvmWidthInBits other) ++ ", Var: " ++ show iptr)) - + where dflags = getDflags env -- | Handle CmmReg expression -- @@ -1171,9 +1175,10 @@ genLit env (CmmFloat r w) nilOL, []) genLit env cmm@(CmmLabel l) - = let label = strCLabel_llvm env l + = let dflags = getDflags env + label = strCLabel_llvm env l ty = funLookup label env - lmty = cmmToLlvmType $ cmmLitType cmm + lmty = cmmToLlvmType $ cmmLitType dflags cmm in case ty of -- Make generic external label definition and then pointer to it Nothing -> do @@ -1340,9 +1345,9 @@ doExpr ty expr = do -- | Expand CmmRegOff -expandCmmReg :: (CmmReg, Int) -> CmmExpr -expandCmmReg (reg, off) - = let width = typeWidth (cmmRegType reg) +expandCmmReg :: DynFlags -> (CmmReg, Int) -> CmmExpr +expandCmmReg dflags (reg, off) + = let width = typeWidth (cmmRegType dflags reg) voff = CmmLit $ CmmInt (fromIntegral off) width in CmmMachOp (MO_Add width) [CmmReg reg, voff] diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs index 8e42149dce..eae8246138 100644 --- a/compiler/llvmGen/LlvmCodeGen/Data.hs +++ b/compiler/llvmGen/LlvmCodeGen/Data.hs @@ -38,11 +38,12 @@ structStr = fsLit "_struct" -- done by 'resolveLlvmData'. genLlvmData :: LlvmEnv -> (Section, CmmStatics) -> LlvmUnresData genLlvmData env (sec, Statics lbl xs) = - let static = map genData xs + let dflags = getDflags env + static = map genData xs label = strCLabel_llvm env lbl types = map getStatTypes static - getStatTypes (Left x) = cmmToLlvmType $ cmmLitType x + getStatTypes (Left x) = cmmToLlvmType $ cmmLitType dflags x getStatTypes (Right x) = getStatType x strucTy = LMStruct types @@ -106,9 +107,10 @@ resData :: LlvmEnv -> UnresStatic -> (LlvmEnv, LlvmStatic, [LMGlobal]) resData env (Right stat) = (env, stat, []) resData env (Left cmm@(CmmLabel l)) = - let label = strCLabel_llvm env l + let dflags = getDflags env + label = strCLabel_llvm env l ty = funLookup label env - lmty = cmmToLlvmType $ cmmLitType cmm + lmty = cmmToLlvmType $ cmmLitType dflags cmm in case ty of -- Make generic external label defenition and then pointer to it Nothing -> diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index e92eb4f34c..fc20ef4988 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -62,7 +62,7 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps cmm_stream do_lint cmm = do { showPass dflags "CmmLint" - ; case cmmLint (targetPlatform dflags) cmm of + ; case cmmLint dflags cmm of Just err -> do { log_action dflags dflags SevDump noSrcSpan defaultDumpStyle err ; ghcExit dflags 1 } diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 4db4245f0a..0566d6ad65 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -1730,16 +1730,15 @@ linkBinary dflags o_files dep_packages = do ] | otherwise = [] - let - thread_opts | WayThreaded `elem` ways dflags = [ -#if !defined(mingw32_TARGET_OS) && !defined(freebsd_TARGET_OS) && !defined(openbsd_TARGET_OS) && !defined(netbsd_TARGET_OS) && !defined(haiku_TARGET_OS) - "-lpthread" -#endif -#if defined(osf3_TARGET_OS) - , "-lexc" -#endif - ] - | otherwise = [] + let thread_opts + | WayThreaded `elem` ways dflags = + let os = platformOS (targetPlatform dflags) + in if os == OSOsf3 then ["-lpthread", "-lexc"] + else if os `elem` [OSMinGW32, OSFreeBSD, OSOpenBSD, + OSNetBSD, OSHaiku] + then [] + else ["-lpthread"] + | otherwise = [] rc_objs <- maybeCreateManifest dflags output_fn @@ -1904,7 +1903,9 @@ linkDynLib dflags o_files dep_packages -- not allow undefined symbols. -- The RTS library path is still added to the library search path -- above in case the RTS is being explicitly linked in (see #3807). - let pkgs_no_rts = case platformOS (targetPlatform dflags) of + let platform = targetPlatform dflags + os = platformOS platform + pkgs_no_rts = case os of OSMinGW32 -> pkgs _ -> @@ -1916,123 +1917,131 @@ linkDynLib dflags o_files dep_packages let extra_ld_opts = getOpts dflags opt_l -#if defined(mingw32_HOST_OS) - ----------------------------------------------------------------------------- - -- Making a DLL - ----------------------------------------------------------------------------- - let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; } + case os of + OSMinGW32 -> do + ------------------------------------------------------------- + -- Making a DLL + ------------------------------------------------------------- + let output_fn = case o_file of + Just s -> s + Nothing -> "HSdll.dll" + + SysTools.runLink dflags ( + map SysTools.Option verbFlags + ++ [ SysTools.Option "-o" + , SysTools.FileOption "" output_fn + , SysTools.Option "-shared" + ] ++ + [ SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a") + | dopt Opt_SharedImplib dflags + ] + ++ map (SysTools.FileOption "") o_files + ++ map SysTools.Option ( + + -- Permit the linker to auto link _symbol to _imp_symbol + -- This lets us link against DLLs without needing an "import library" + ["-Wl,--enable-auto-import"] + + ++ extra_ld_inputs + ++ lib_path_opts + ++ extra_ld_opts + ++ pkg_lib_path_opts + ++ pkg_link_opts + )) + OSDarwin -> do + ------------------------------------------------------------------- + -- Making a darwin dylib + ------------------------------------------------------------------- + -- About the options used for Darwin: + -- -dynamiclib + -- Apple's way of saying -shared + -- -undefined dynamic_lookup: + -- Without these options, we'd have to specify the correct + -- dependencies for each of the dylibs. Note that we could + -- (and should) do without this for all libraries except + -- the RTS; all we need to do is to pass the correct + -- HSfoo_dyn.dylib files to the link command. + -- This feature requires Mac OS X 10.3 or later; there is + -- a similar feature, -flat_namespace -undefined suppress, + -- which works on earlier versions, but it has other + -- disadvantages. + -- -single_module + -- Build the dynamic library as a single "module", i.e. no + -- dynamic binding nonsense when referring to symbols from + -- within the library. The NCG assumes that this option is + -- specified (on i386, at least). + -- -install_name + -- Mac OS/X stores the path where a dynamic library is (to + -- be) installed in the library itself. It's called the + -- "install name" of the library. Then any library or + -- executable that links against it before it's installed + -- will search for it in its ultimate install location. + -- By default we set the install name to the absolute path + -- at build time, but it can be overridden by the + -- -dylib-install-name option passed to ghc. Cabal does + -- this. + ------------------------------------------------------------------- + + let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } + + instName <- case dylibInstallName dflags of + Just n -> return n + Nothing -> do + pwd <- getCurrentDirectory + return $ pwd `combine` output_fn + SysTools.runLink dflags ( + map SysTools.Option verbFlags + ++ [ SysTools.Option "-dynamiclib" + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] + ++ map SysTools.Option ( + o_files + ++ [ "-undefined", "dynamic_lookup", "-single_module" ] + ++ (if platformArch platform == ArchX86_64 + then [ ] + else [ "-Wl,-read_only_relocs,suppress" ]) + ++ [ "-install_name", instName ] + ++ extra_ld_inputs + ++ lib_path_opts + ++ extra_ld_opts + ++ pkg_lib_path_opts + ++ pkg_link_opts + )) + _ -> do + ------------------------------------------------------------------- + -- Making a DSO + ------------------------------------------------------------------- + + let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } + let buildingRts = thisPackage dflags == rtsPackageId + let bsymbolicFlag = if buildingRts + then -- -Bsymbolic breaks the way we implement + -- hooks in the RTS + [] + else -- we need symbolic linking to resolve + -- non-PIC intra-package-relocations + ["-Wl,-Bsymbolic"] + + SysTools.runLink dflags ( + map SysTools.Option verbFlags + ++ [ SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] + ++ map SysTools.Option ( + o_files + ++ [ "-shared" ] + ++ bsymbolicFlag + -- Set the library soname. We use -h rather than -soname as + -- Solaris 10 doesn't support the latter: + ++ [ "-Wl,-h," ++ takeFileName output_fn ] + ++ extra_ld_inputs + ++ lib_path_opts + ++ extra_ld_opts + ++ pkg_lib_path_opts + ++ pkg_link_opts + )) - SysTools.runLink dflags ( - map SysTools.Option verbFlags - ++ [ SysTools.Option "-o" - , SysTools.FileOption "" output_fn - , SysTools.Option "-shared" - ] ++ - [ SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a") - | dopt Opt_SharedImplib dflags - ] - ++ map (SysTools.FileOption "") o_files - ++ map SysTools.Option ( - - -- Permit the linker to auto link _symbol to _imp_symbol - -- This lets us link against DLLs without needing an "import library" - ["-Wl,--enable-auto-import"] - - ++ extra_ld_inputs - ++ lib_path_opts - ++ extra_ld_opts - ++ pkg_lib_path_opts - ++ pkg_link_opts - )) -#elif defined(darwin_TARGET_OS) - ----------------------------------------------------------------------------- - -- Making a darwin dylib - ----------------------------------------------------------------------------- - -- About the options used for Darwin: - -- -dynamiclib - -- Apple's way of saying -shared - -- -undefined dynamic_lookup: - -- Without these options, we'd have to specify the correct dependencies - -- for each of the dylibs. Note that we could (and should) do without this - -- for all libraries except the RTS; all we need to do is to pass the - -- correct HSfoo_dyn.dylib files to the link command. - -- This feature requires Mac OS X 10.3 or later; there is a similar feature, - -- -flat_namespace -undefined suppress, which works on earlier versions, - -- but it has other disadvantages. - -- -single_module - -- Build the dynamic library as a single "module", i.e. no dynamic binding - -- nonsense when referring to symbols from within the library. The NCG - -- assumes that this option is specified (on i386, at least). - -- -install_name - -- Mac OS/X stores the path where a dynamic library is (to be) installed - -- in the library itself. It's called the "install name" of the library. - -- Then any library or executable that links against it before it's - -- installed will search for it in its ultimate install location. By - -- default we set the install name to the absolute path at build time, but - -- it can be overridden by the -dylib-install-name option passed to ghc. - -- Cabal does this. - ----------------------------------------------------------------------------- - - let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } - - instName <- case dylibInstallName dflags of - Just n -> return n - Nothing -> do - pwd <- getCurrentDirectory - return $ pwd `combine` output_fn - SysTools.runLink dflags ( - map SysTools.Option verbFlags - ++ [ SysTools.Option "-dynamiclib" - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ] - ++ map SysTools.Option ( - o_files - ++ [ "-undefined", "dynamic_lookup", "-single_module", -#if !defined(x86_64_TARGET_ARCH) - "-Wl,-read_only_relocs,suppress", -#endif - "-install_name", instName ] - ++ extra_ld_inputs - ++ lib_path_opts - ++ extra_ld_opts - ++ pkg_lib_path_opts - ++ pkg_link_opts - )) -#else - ----------------------------------------------------------------------------- - -- Making a DSO - ----------------------------------------------------------------------------- - - let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } - let buildingRts = thisPackage dflags == rtsPackageId - let bsymbolicFlag = if buildingRts - then -- -Bsymbolic breaks the way we implement - -- hooks in the RTS - [] - else -- we need symbolic linking to resolve - -- non-PIC intra-package-relocations - ["-Wl,-Bsymbolic"] - - SysTools.runLink dflags ( - map SysTools.Option verbFlags - ++ [ SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ] - ++ map SysTools.Option ( - o_files - ++ [ "-shared" ] - ++ bsymbolicFlag - -- Set the library soname. We use -h rather than -soname as - -- Solaris 10 doesn't support the latter: - ++ [ "-Wl,-h," ++ takeFileName output_fn ] - ++ extra_ld_inputs - ++ lib_path_opts - ++ extra_ld_opts - ++ pkg_lib_path_opts - ++ pkg_link_opts - )) -#endif -- ----------------------------------------------------------------------------- -- Running CPP diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 723bf44b8b..d07977ceea 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -20,6 +20,7 @@ module DynFlags ( WarningFlag(..), ExtensionFlag(..), Language(..), + PlatformConstants(..), FatalMessager, LogAction, FlushOut(..), FlushErr(..), ProfAuto(..), glasgowExtsFlags, @@ -115,6 +116,10 @@ module DynFlags ( #endif -- ** Only for use in the tracing functions in Outputable tracingDynFlags, + +#include "../includes/dist-derivedconstants/header/GHCConstantsHaskellExports.hs" + bLOCK_SIZE_W, + wORD_SIZE_IN_BITS, ) where #include "HsVersions.h" @@ -127,7 +132,7 @@ import {-# SOURCE #-} Packages (PackageState) import DriverPhases ( Phase(..), phaseInputExt ) import Config import CmdLineParser -import Constants ( mAX_CONTEXT_REDUCTION_DEPTH ) +import Constants import Panic import Util import Maybes ( orElse ) @@ -705,8 +710,9 @@ data Settings = Settings { sOpt_l :: [String], sOpt_windres :: [String], sOpt_lo :: [String], -- LLVM: llvm optimiser - sOpt_lc :: [String] -- LLVM: llc static compiler + sOpt_lc :: [String], -- LLVM: llc static compiler + sPlatformConstants :: PlatformConstants } targetPlatform :: DynFlags -> Platform @@ -3138,3 +3144,12 @@ compilerInfo dflags ("Global Package DB", systemPackageConfig dflags) ] +#include "../includes/dist-derivedconstants/header/GHCConstantsHaskellType.hs" +#include "../includes/dist-derivedconstants/header/GHCConstantsHaskellWrappers.hs" + +bLOCK_SIZE_W :: DynFlags -> Int +bLOCK_SIZE_W dflags = bLOCK_SIZE dflags `quot` wORD_SIZE + +wORD_SIZE_IN_BITS :: DynFlags -> Int +wORD_SIZE_IN_BITS _ = wORD_SIZE * 8 + diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 7d905d35c6..2154cd3235 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -172,15 +172,23 @@ initSysTools mbMinusB -- format, '/' separated let settingsFile = top_dir </> "settings" + platformConstantsFile = top_dir </> "platformConstants" installed :: FilePath -> FilePath installed file = top_dir </> file settingsStr <- readFile settingsFile + platformConstantsStr <- readFile platformConstantsFile mySettings <- case maybeReadFuzzy settingsStr of Just s -> return s Nothing -> pgmError ("Can't parse " ++ show settingsFile) + platformConstants <- case maybeReadFuzzy platformConstantsStr of + Just s -> + return s + Nothing -> + pgmError ("Can't parse " ++ + show platformConstantsFile) let getSetting key = case lookup key mySettings of Just xs -> return $ case stripPrefix "$topdir" xs of @@ -326,7 +334,8 @@ initSysTools mbMinusB sOpt_l = [], sOpt_windres = [], sOpt_lo = [], - sOpt_lc = [] + sOpt_lc = [], + sPlatformConstants = platformConstants } \end{code} diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 6b1e93f271..8c608f1bf1 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -139,7 +139,7 @@ data NcgImpl statics instr jumpDest = NcgImpl { shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics, shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr, pprNatCmmDecl :: NatCmmDecl statics instr -> SDoc, - maxSpillSlots :: Int, + maxSpillSlots :: DynFlags -> Int, allocatableRegs :: Platform -> [RealReg], ncg_x86fp_kludge :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr], ncgExpandTop :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr], @@ -160,7 +160,7 @@ nativeCodeGen dflags h us cmms ,shortcutStatics = X86.Instr.shortcutStatics ,shortcutJump = X86.Instr.shortcutJump ,pprNatCmmDecl = X86.Ppr.pprNatCmmDecl - ,maxSpillSlots = X86.Instr.maxSpillSlots (target32Bit platform) + ,maxSpillSlots = X86.Instr.maxSpillSlots ,allocatableRegs = X86.Regs.allocatableRegs ,ncg_x86fp_kludge = id ,ncgExpandTop = id @@ -378,7 +378,7 @@ cmmNativeGen dflags ncgImpl us cmm count -- rewrite assignments to global regs let fixed_cmm = {-# SCC "fixStgRegisters" #-} - fixStgRegisters platform cmm + fixStgRegisters dflags cmm -- cmm to cmm optimisations let (opt_cmm, imports) = @@ -428,7 +428,7 @@ cmmNativeGen dflags ncgImpl us cmm count $ Color.regAlloc dflags alloc_regs - (mkUniqSet [0 .. maxSpillSlots ncgImpl]) + (mkUniqSet [0 .. maxSpillSlots ncgImpl dflags]) withLiveness -- dump out what happened during register allocation @@ -955,13 +955,13 @@ cmmExprConFold referenceKind expr = do -- SDM: re-enabled for now, while cmmRewriteAssignments is turned off let expr' = if False -- dopt Opt_TryNewCodeGen dflags then expr - else cmmExprCon (targetPlatform dflags) expr + else cmmExprCon dflags expr cmmExprNative referenceKind expr' -cmmExprCon :: Platform -> CmmExpr -> CmmExpr -cmmExprCon platform (CmmLoad addr rep) = CmmLoad (cmmExprCon platform addr) rep -cmmExprCon platform (CmmMachOp mop args) - = cmmMachOpFold platform mop (map (cmmExprCon platform) args) +cmmExprCon :: DynFlags -> CmmExpr -> CmmExpr +cmmExprCon dflags (CmmLoad addr rep) = CmmLoad (cmmExprCon dflags addr) rep +cmmExprCon dflags (CmmMachOp mop args) + = cmmMachOpFold dflags mop (map (cmmExprCon dflags) args) cmmExprCon _ other = other -- handles both PIC and non-PIC cases... a very strange mixture @@ -993,9 +993,9 @@ cmmExprNative referenceKind expr = do -> do dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl -- need to optimize here, since it's late - return $ cmmMachOpFold platform (MO_Add wordWidth) [ + return $ cmmMachOpFold dflags (MO_Add (wordWidth dflags)) [ dynRef, - (CmmLit $ CmmInt (fromIntegral off) wordWidth) + (CmmLit $ CmmInt (fromIntegral off) (wordWidth dflags)) ] -- On powerpc (non-PIC), it's easier to jump directly to a label than diff --git a/compiler/nativeGen/Instruction.hs b/compiler/nativeGen/Instruction.hs index 292cf82f6a..64ba32c6dc 100644 --- a/compiler/nativeGen/Instruction.hs +++ b/compiler/nativeGen/Instruction.hs @@ -13,6 +13,7 @@ where import Reg import BlockId +import DynFlags import OldCmm import Platform @@ -105,7 +106,7 @@ class Instruction instr where -- | An instruction to spill a register into a spill slot. mkSpillInstr - :: Platform + :: DynFlags -> Reg -- ^ the reg to spill -> Int -- ^ the current stack delta -> Int -- ^ spill slot to use @@ -114,7 +115,7 @@ class Instruction instr where -- | An instruction to reload a register from a spill slot. mkLoadInstr - :: Platform + :: DynFlags -> Reg -- ^ the reg to reload. -> Int -- ^ the current stack delta -> Int -- ^ the spill slot to use diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs index 0b5ffcd0d1..af4bb9e9ed 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -133,7 +133,7 @@ cmmMakeDynamicReference' dflags addImport referenceKind lbl AccessViaSymbolPtr -> do let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl addImport symbolPtr - return $ CmmLoad (cmmMakePicReference dflags symbolPtr) bWord + return $ CmmLoad (cmmMakePicReference dflags symbolPtr) (bWord dflags) AccessDirectly -> case referenceKind of -- for data, we might have to make some calculations: @@ -161,7 +161,7 @@ cmmMakePicReference dflags lbl | (dopt Opt_PIC dflags || not (dopt Opt_Static dflags)) && absoluteLabel lbl - = CmmMachOp (MO_Add wordWidth) + = CmmMachOp (MO_Add (wordWidth dflags)) [ CmmReg (CmmGlobal PicBaseReg) , CmmLit $ picRelative (platformArch $ targetPlatform dflags) @@ -641,11 +641,11 @@ pprImportedSymbol _ platform@(Platform { platformArch = ArchPPC_64 }) _ | osElfTarget (platformOS platform) = empty -pprImportedSymbol _ platform importedLbl +pprImportedSymbol dflags platform importedLbl | osElfTarget (platformOS platform) = case dynamicLinkerLabelInfo importedLbl of Just (SymbolPtr, lbl) - -> let symbolSize = case wordWidth of + -> let symbolSize = case wordWidth dflags of W32 -> sLit "\t.long" W64 -> sLit "\t.quad" _ -> panic "Unknown wordRep in pprImportedSymbol" @@ -703,8 +703,9 @@ initializePicBase_ppc ArchPPC os picReg (CmmProc info lab (ListGraph blocks) : statics) | osElfTarget os = do + dflags <- getDynFlags gotOffLabel <- getNewLabelNat - tmp <- getNewRegNat $ intSize wordWidth + tmp <- getNewRegNat $ intSize (wordWidth dflags) let gotOffset = CmmData Text $ Statics gotOffLabel [ CmmStaticLit (CmmLabelDiffOff gotLabel diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index ce4a54ca9b..367c0fbdec 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -124,7 +124,7 @@ stmtToInstrs stmt = do | target32Bit (targetPlatform dflags) && isWord64 ty -> assignReg_I64Code reg src | otherwise -> assignReg_IntCode size reg src - where ty = cmmRegType reg + where ty = cmmRegType dflags reg size = cmmTypeSize ty CmmStore addr src @@ -132,7 +132,7 @@ stmtToInstrs stmt = do | target32Bit (targetPlatform dflags) && isWord64 ty -> assignMem_I64Code addr src | otherwise -> assignMem_IntCode size addr src - where ty = cmmExprType src + where ty = cmmExprType dflags src size = cmmTypeSize ty CmmCall target result_regs args _ @@ -206,9 +206,9 @@ temporary, then do the other computation, and then use the temporary: -- | Convert a BlockId to some CmmStatic data -jumpTableEntry :: Maybe BlockId -> CmmStatic -jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth) -jumpTableEntry (Just blockid) = CmmStaticLit (CmmLabel blockLabel) +jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic +jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags)) +jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) where blockLabel = mkAsmTempLabel (getUnique blockid) @@ -218,12 +218,12 @@ jumpTableEntry (Just blockid) = CmmStaticLit (CmmLabel blockLabel) -- Expand CmmRegOff. ToDo: should we do it this way around, or convert -- CmmExprs into CmmRegOff? -mangleIndexTree :: CmmExpr -> CmmExpr -mangleIndexTree (CmmRegOff reg off) +mangleIndexTree :: DynFlags -> CmmExpr -> CmmExpr +mangleIndexTree dflags (CmmRegOff reg off) = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] - where width = typeWidth (cmmRegType reg) + where width = typeWidth (cmmRegType dflags reg) -mangleIndexTree _ +mangleIndexTree _ _ = panic "PPC.CodeGen.mangleIndexTree: no match" -- ----------------------------------------------------------------------------- @@ -370,11 +370,11 @@ getRegister' _ (CmmReg (CmmGlobal PicBaseReg)) return (Fixed archWordSize reg nilOL) getRegister' dflags (CmmReg reg) - = return (Fixed (cmmTypeSize (cmmRegType reg)) + = return (Fixed (cmmTypeSize (cmmRegType dflags reg)) (getRegisterReg (targetPlatform dflags) reg) nilOL) getRegister' dflags tree@(CmmRegOff _ _) - = getRegister' dflags (mangleIndexTree tree) + = getRegister' dflags (mangleIndexTree dflags tree) -- for 32-bit architectuers, support some 64 -> 32 bit conversions: -- TO_W_(x), TO_W_(x >> 32) @@ -561,8 +561,8 @@ getRegister' _ (CmmLit (CmmFloat f frep)) = do `consOL` (addr_code `snocOL` LD size dst addr) return (Any size code) -getRegister' _ (CmmLit lit) - = let rep = cmmLitType lit +getRegister' dflags (CmmLit lit) + = let rep = cmmLitType dflags lit imm = litToImm lit code dst = toOL [ LIS dst (HA imm), @@ -607,7 +607,8 @@ temporary, then do the other computation, and then use the temporary: -} getAmode :: CmmExpr -> NatM Amode -getAmode tree@(CmmRegOff _ _) = getAmode (mangleIndexTree tree) +getAmode tree@(CmmRegOff _ _) = do dflags <- getDynFlags + getAmode (mangleIndexTree dflags tree) getAmode (CmmMachOp (MO_Sub W32) [x, CmmLit (CmmInt i _)]) | Just off <- makeImmediate W32 True (-i) @@ -844,14 +845,14 @@ genCCall target dest_regs argsAndHints = do dflags <- getDynFlags let platform = targetPlatform dflags case platformOS platform of - OSLinux -> genCCall' platform GCPLinux target dest_regs argsAndHints - OSDarwin -> genCCall' platform GCPDarwin target dest_regs argsAndHints + OSLinux -> genCCall' dflags GCPLinux target dest_regs argsAndHints + OSDarwin -> genCCall' dflags GCPDarwin target dest_regs argsAndHints _ -> panic "PPC.CodeGen.genCCall: not defined for this os" data GenCCallPlatform = GCPLinux | GCPDarwin genCCall' - :: Platform + :: DynFlags -> GenCCallPlatform -> CmmCallTarget -- function to call -> [HintedCmmFormal] -- where to put the result @@ -902,7 +903,7 @@ genCCall' _ _ (CmmPrim MO_WriteBarrier _) _ _ genCCall' _ _ (CmmPrim _ (Just stmts)) _ _ = stmtsToInstrs stmts -genCCall' platform gcp target dest_regs argsAndHints +genCCall' dflags gcp target dest_regs argsAndHints = ASSERT (not $ any (`elem` [II16]) $ map cmmTypeSize argReps) -- we rely on argument promotion in the codeGen do @@ -934,6 +935,8 @@ genCCall' platform gcp target dest_regs argsAndHints `snocOL` BCTRL usedRegs `appOL` codeAfter) where + platform = targetPlatform dflags + initialStackOffset = case gcp of GCPDarwin -> 24 GCPLinux -> 8 @@ -955,7 +958,7 @@ genCCall' platform gcp target dest_regs argsAndHints = argsAndHints args = map hintlessCmm argsAndHints' - argReps = map cmmExprType args + argReps = map (cmmExprType dflags) args roundTo a x | x `mod` a == 0 = x | otherwise = x + a - (x `mod` a) @@ -1060,23 +1063,23 @@ genCCall' platform gcp target dest_regs argsAndHints GCPDarwin -> case cmmTypeSize rep of II8 -> (1, 0, 4, gprs) + II16 -> (1, 0, 4, gprs) II32 -> (1, 0, 4, gprs) -- The Darwin ABI requires that we skip a -- corresponding number of GPRs when we use -- the FPRs. FF32 -> (1, 1, 4, fprs) FF64 -> (2, 1, 8, fprs) - II16 -> panic "genCCall' passArguments II16" II64 -> panic "genCCall' passArguments II64" FF80 -> panic "genCCall' passArguments FF80" GCPLinux -> case cmmTypeSize rep of II8 -> (1, 0, 4, gprs) + II16 -> (1, 0, 4, gprs) II32 -> (1, 0, 4, gprs) -- ... the SysV ABI doesn't. FF32 -> (0, 1, 4, fprs) FF64 -> (0, 1, 8, fprs) - II16 -> panic "genCCall' passArguments II16" II64 -> panic "genCCall' passArguments II64" FF80 -> panic "genCCall' passArguments FF80" @@ -1089,7 +1092,7 @@ genCCall' platform gcp target dest_regs argsAndHints | isWord64 rep -> toOL [MR (getHiVRegFromLo r_dest) r3, MR r_dest r4] | otherwise -> unitOL (MR r_dest r3) - where rep = cmmRegType (CmmLocal dest) + where rep = cmmRegType dflags (CmmLocal dest) r_dest = getRegisterReg platform (CmmLocal dest) _ -> panic "genCCall' moveResult: Bad dest_regs" @@ -1194,9 +1197,9 @@ generateJumpTableForInstr :: DynFlags -> Instr generateJumpTableForInstr dflags (BCTR ids (Just lbl)) = let jumpTable | dopt Opt_PIC dflags = map jumpTableEntryRel ids - | otherwise = map jumpTableEntry ids + | otherwise = map (jumpTableEntry dflags) ids where jumpTableEntryRel Nothing - = CmmStaticLit (CmmInt 0 wordWidth) + = CmmStaticLit (CmmInt 0 (wordWidth dflags)) jumpTableEntryRel (Just blockid) = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) where blockLabel = mkAsmTempLabel (getUnique blockid) diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs index 1af08a6076..464a88a08b 100644 --- a/compiler/nativeGen/PPC/Instr.hs +++ b/compiler/nativeGen/PPC/Instr.hs @@ -34,8 +34,8 @@ import RegClass import Reg import CodeGen.Platform -import Constants (rESERVED_C_STACK_BYTES) import BlockId +import DynFlags import OldCmm import FastString import CLabel @@ -355,14 +355,15 @@ ppc_patchJumpInstr insn patchF -- | An instruction to spill a register into a spill slot. ppc_mkSpillInstr - :: Platform + :: DynFlags -> Reg -- register to spill -> Int -- current stack delta -> Int -- spill slot to use -> Instr -ppc_mkSpillInstr platform reg delta slot - = let off = spillSlotToOffset slot +ppc_mkSpillInstr dflags reg delta slot + = let platform = targetPlatform dflags + off = spillSlotToOffset dflags slot in let sz = case targetClassOfReg platform reg of RcInteger -> II32 @@ -372,14 +373,15 @@ ppc_mkSpillInstr platform reg delta slot ppc_mkLoadInstr - :: Platform + :: DynFlags -> Reg -- register to load -> Int -- current stack delta -> Int -- spill slot to use -> Instr -ppc_mkLoadInstr platform reg delta slot - = let off = spillSlotToOffset slot +ppc_mkLoadInstr dflags reg delta slot + = let platform = targetPlatform dflags + off = spillSlotToOffset dflags slot in let sz = case targetClassOfReg platform reg of RcInteger -> II32 @@ -391,20 +393,21 @@ ppc_mkLoadInstr platform reg delta slot spillSlotSize :: Int spillSlotSize = 8 -maxSpillSlots :: Int -maxSpillSlots = ((rESERVED_C_STACK_BYTES - 64) `div` spillSlotSize) - 1 +maxSpillSlots :: DynFlags -> Int +maxSpillSlots dflags + = ((rESERVED_C_STACK_BYTES dflags - 64) `div` spillSlotSize) - 1 -- convert a spill slot number to a *byte* offset, with no sign: -- decide on a per arch basis whether you are spilling above or below -- the C stack pointer. -spillSlotToOffset :: Int -> Int -spillSlotToOffset slot - | slot >= 0 && slot < maxSpillSlots +spillSlotToOffset :: DynFlags -> Int -> Int +spillSlotToOffset dflags slot + | slot >= 0 && slot < maxSpillSlots dflags = 64 + spillSlotSize * slot | otherwise = pprPanic "spillSlotToOffset:" ( text "invalid spill location: " <> int slot - $$ text "maxSpillSlots: " <> int maxSpillSlots) + $$ text "maxSpillSlots: " <> int (maxSpillSlots dflags)) -------------------------------------------------------------------------------- diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index 55cc6d2a0d..576e19db1a 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -31,6 +31,7 @@ import RegClass import TargetReg import OldCmm +import BlockId import CLabel @@ -50,7 +51,7 @@ pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc pprNatCmmDecl (CmmData section dats) = pprSectionHeader section $$ pprDatas dats -pprNatCmmDecl proc@(CmmProc _ lbl (ListGraph blocks)) = +pprNatCmmDecl proc@(CmmProc top_info lbl (ListGraph blocks)) = case topInfoTable proc of Nothing -> case blocks of @@ -59,19 +60,15 @@ pprNatCmmDecl proc@(CmmProc _ lbl (ListGraph blocks)) = blocks -> -- special case for code without info table: pprSectionHeader Text $$ pprLabel lbl $$ -- blocks guaranteed not null, so label needed - vcat (map pprBasicBlock blocks) + vcat (map (pprBasicBlock top_info) blocks) - Just (Statics info_lbl info) -> + Just (Statics info_lbl _) -> sdocWithPlatform $ \platform -> - pprSectionHeader Text $$ - ( - (if platformHasSubsectionsViaSymbols platform - then ppr (mkDeadStripPreventer info_lbl) <> char ':' - else empty) $$ - vcat (map pprData info) $$ - pprLabel info_lbl - ) $$ - vcat (map pprBasicBlock blocks) $$ + (if platformHasSubsectionsViaSymbols platform + then pprSectionHeader Text $$ + ppr (mkDeadStripPreventer info_lbl) <> char ':' + else empty) $$ + vcat (map (pprBasicBlock top_info) blocks) $$ -- above: Even the first block gets a label, because with branch-chain -- elimination, it might be the target of a goto. (if platformHasSubsectionsViaSymbols platform @@ -89,10 +86,18 @@ pprNatCmmDecl proc@(CmmProc _ lbl (ListGraph blocks)) = else empty) -pprBasicBlock :: NatBasicBlock Instr -> SDoc -pprBasicBlock (BasicBlock blockid instrs) = - pprLabel (mkAsmTempLabel (getUnique blockid)) $$ - vcat (map pprInstr instrs) +pprBasicBlock :: BlockEnv CmmStatics -> NatBasicBlock Instr -> SDoc +pprBasicBlock info_env (BasicBlock blockid instrs) + = maybe_infotable $$ + pprLabel (mkAsmTempLabel (getUnique blockid)) $$ + vcat (map pprInstr instrs) + where + maybe_infotable = case mapLookup blockid info_env of + Nothing -> empty + Just (Statics info_lbl info) -> + pprSectionHeader Text $$ + vcat (map pprData info) $$ + pprLabel info_lbl @@ -292,7 +297,8 @@ pprSectionHeader seg pprDataItem :: CmmLit -> SDoc pprDataItem lit - = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit) + = sdocWithDynFlags $ \dflags -> + vcat (ppr_item (cmmTypeSize $ cmmLitType dflags lit) lit) where imm = litToImm lit diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs index 32b5e41402..1611a710fb 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Main.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs @@ -174,7 +174,7 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code -- strip off liveness information, -- and rewrite SPILL/RELOAD pseudos into real instructions along the way - let code_final = map (stripLive platform) code_spillclean + let code_final = map (stripLive dflags) code_spillclean -- record what happened in this stage for debugging let stat = diff --git a/compiler/nativeGen/RegAlloc/Linear/Base.hs b/compiler/nativeGen/RegAlloc/Linear/Base.hs index 432acdf314..e58331347c 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Base.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Base.hs @@ -13,7 +13,6 @@ module RegAlloc.Linear.Base ( -- the allocator monad RA_State(..), - RegM(..) ) where @@ -22,6 +21,7 @@ import RegAlloc.Linear.StackMap import RegAlloc.Liveness import Reg +import DynFlags import Outputable import Unique import UniqFM @@ -126,11 +126,7 @@ data RA_State freeRegs -- | Record why things were spilled, for -ddrop-asm-stats. -- Just keep a list here instead of a map of regs -> reasons. -- We don't want to slow down the allocator if we're not going to emit the stats. - , ra_spills :: [SpillReason] } - - --- | The register allocator monad type. -newtype RegM freeRegs a - = RegM { unReg :: RA_State freeRegs -> (# RA_State freeRegs, a #) } + , ra_spills :: [SpillReason] + , ra_DynFlags :: DynFlags } diff --git a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs index 887af1758a..fffdef761b 100644 --- a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs @@ -18,6 +18,7 @@ where import Reg import RegClass +import DynFlags import Panic import Platform @@ -33,9 +34,10 @@ import Platform -- getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f -- allocateReg f r = filter (/= r) f -import qualified RegAlloc.Linear.PPC.FreeRegs as PPC -import qualified RegAlloc.Linear.SPARC.FreeRegs as SPARC -import qualified RegAlloc.Linear.X86.FreeRegs as X86 +import qualified RegAlloc.Linear.PPC.FreeRegs as PPC +import qualified RegAlloc.Linear.SPARC.FreeRegs as SPARC +import qualified RegAlloc.Linear.X86.FreeRegs as X86 +import qualified RegAlloc.Linear.X86_64.FreeRegs as X86_64 import qualified PPC.Instr import qualified SPARC.Instr @@ -53,6 +55,12 @@ instance FR X86.FreeRegs where frInitFreeRegs = X86.initFreeRegs frReleaseReg = \_ -> X86.releaseReg +instance FR X86_64.FreeRegs where + frAllocateReg = \_ -> X86_64.allocateReg + frGetFreeRegs = X86_64.getFreeRegs + frInitFreeRegs = X86_64.initFreeRegs + frReleaseReg = \_ -> X86_64.releaseReg + instance FR PPC.FreeRegs where frAllocateReg = \_ -> PPC.allocateReg frGetFreeRegs = \_ -> PPC.getFreeRegs @@ -65,13 +73,13 @@ instance FR SPARC.FreeRegs where frInitFreeRegs = SPARC.initFreeRegs frReleaseReg = SPARC.releaseReg -maxSpillSlots :: Platform -> Int -maxSpillSlots platform - = case platformArch platform of - ArchX86 -> X86.Instr.maxSpillSlots True -- 32bit - ArchX86_64 -> X86.Instr.maxSpillSlots False -- not 32bit - ArchPPC -> PPC.Instr.maxSpillSlots - ArchSPARC -> SPARC.Instr.maxSpillSlots +maxSpillSlots :: DynFlags -> Int +maxSpillSlots dflags + = case platformArch (targetPlatform dflags) of + ArchX86 -> X86.Instr.maxSpillSlots dflags + ArchX86_64 -> X86.Instr.maxSpillSlots dflags + ArchPPC -> PPC.Instr.maxSpillSlots dflags + ArchSPARC -> SPARC.Instr.maxSpillSlots dflags ArchARM _ _ _ -> panic "maxSpillSlots ArchARM" ArchPPC_64 -> panic "maxSpillSlots ArchPPC_64" ArchUnknown -> panic "maxSpillSlots ArchUnknown" diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs index ea415e2661..6294743c48 100644 --- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs +++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs @@ -1,24 +1,13 @@ -{-# 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 - -- | Handles joining of a jump instruction to its targets. --- The first time we encounter a jump to a particular basic block, we --- record the assignment of temporaries. The next time we encounter a --- jump to the same block, we compare our current assignment to the --- stored one. They might be different if spilling has occrred in one --- branch; so some fixup code will be required to match up the assignments. +-- The first time we encounter a jump to a particular basic block, we +-- record the assignment of temporaries. The next time we encounter a +-- jump to the same block, we compare our current assignment to the +-- stored one. They might be different if spilling has occrred in one +-- branch; so some fixup code will be required to match up the assignments. -- -module RegAlloc.Linear.JoinToTargets ( - joinToTargets -) - -where +module RegAlloc.Linear.JoinToTargets (joinToTargets) where import RegAlloc.Linear.State import RegAlloc.Linear.Base @@ -30,96 +19,94 @@ import Reg import BlockId import OldCmm hiding (RegSet) import Digraph +import DynFlags import Outputable -import Platform import Unique import UniqFM import UniqSet -- | For a jump instruction at the end of a block, generate fixup code so its --- vregs are in the correct regs for its destination. +-- vregs are in the correct regs for its destination. -- joinToTargets - :: (FR freeRegs, Instruction instr) - => Platform - -> BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs - -- that are known to be live on the entry to each block. + :: (FR freeRegs, Instruction instr) + => BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs + -- that are known to be live on the entry to each block. - -> BlockId -- ^ id of the current block - -> instr -- ^ branch instr on the end of the source block. + -> BlockId -- ^ id of the current block + -> instr -- ^ branch instr on the end of the source block. - -> RegM freeRegs ([NatBasicBlock instr] -- fresh blocks of fixup code. - , instr) -- the original branch instruction, but maybe patched to jump - -- to a fixup block first. + -> RegM freeRegs ([NatBasicBlock instr] -- fresh blocks of fixup code. + , instr) -- the original branch + -- instruction, but maybe + -- patched to jump + -- to a fixup block first. -joinToTargets platform block_live id instr +joinToTargets block_live id instr - -- we only need to worry about jump instructions. - | not $ isJumpishInstr instr - = return ([], instr) + -- we only need to worry about jump instructions. + | not $ isJumpishInstr instr + = return ([], instr) - | otherwise - = joinToTargets' platform block_live [] id instr (jumpDestsOfInstr instr) + | otherwise + = joinToTargets' block_live [] id instr (jumpDestsOfInstr instr) ----- joinToTargets' - :: (FR freeRegs, Instruction instr) - => Platform - -> BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs - -- that are known to be live on the entry to each block. + :: (FR freeRegs, Instruction instr) + => BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs + -- that are known to be live on the entry to each block. - -> [NatBasicBlock instr] -- ^ acc blocks of fixup code. + -> [NatBasicBlock instr] -- ^ acc blocks of fixup code. - -> BlockId -- ^ id of the current block - -> instr -- ^ branch instr on the end of the source block. + -> BlockId -- ^ id of the current block + -> instr -- ^ branch instr on the end of the source block. - -> [BlockId] -- ^ branch destinations still to consider. + -> [BlockId] -- ^ branch destinations still to consider. - -> RegM freeRegs ( [NatBasicBlock instr] - , instr) + -> RegM freeRegs ([NatBasicBlock instr], instr) -- no more targets to consider. all done. -joinToTargets' _ _ new_blocks _ instr [] - = return (new_blocks, instr) +joinToTargets' _ new_blocks _ instr [] + = return (new_blocks, instr) -- handle a branch target. -joinToTargets' platform block_live new_blocks block_id instr (dest:dests) - = do - -- get the map of where the vregs are stored on entry to each basic block. - block_assig <- getBlockAssigR - - -- get the assignment on entry to the branch instruction. - assig <- getAssigR - - -- adjust the current assignment to remove any vregs that are not live - -- on entry to the destination block. - let Just live_set = mapLookup dest block_live - let still_live uniq _ = uniq `elemUniqSet_Directly` live_set - let adjusted_assig = filterUFM_Directly still_live assig - - -- and free up those registers which are now free. - let to_free = - [ r | (reg, loc) <- ufmToList assig - , not (elemUniqSet_Directly reg live_set) - , r <- regsOfLoc loc ] - - case mapLookup dest block_assig of - Nothing - -> joinToTargets_first - platform block_live new_blocks block_id instr dest dests - block_assig adjusted_assig to_free - - Just (_, dest_assig) - -> joinToTargets_again - platform block_live new_blocks block_id instr dest dests - adjusted_assig dest_assig +joinToTargets' block_live new_blocks block_id instr (dest:dests) + = do + -- get the map of where the vregs are stored on entry to each basic block. + block_assig <- getBlockAssigR + + -- get the assignment on entry to the branch instruction. + assig <- getAssigR + + -- adjust the current assignment to remove any vregs that are not live + -- on entry to the destination block. + let Just live_set = mapLookup dest block_live + let still_live uniq _ = uniq `elemUniqSet_Directly` live_set + let adjusted_assig = filterUFM_Directly still_live assig + + -- and free up those registers which are now free. + let to_free = + [ r | (reg, loc) <- ufmToList assig + , not (elemUniqSet_Directly reg live_set) + , r <- regsOfLoc loc ] + + case mapLookup dest block_assig of + Nothing + -> joinToTargets_first + block_live new_blocks block_id instr dest dests + block_assig adjusted_assig to_free + + Just (_, dest_assig) + -> joinToTargets_again + block_live new_blocks block_id instr dest dests + adjusted_assig dest_assig -- this is the first time we jumped to this block. joinToTargets_first :: (FR freeRegs, Instruction instr) - => Platform - -> BlockMap RegSet + => BlockMap RegSet -> [NatBasicBlock instr] -> BlockId -> instr @@ -129,24 +116,26 @@ joinToTargets_first :: (FR freeRegs, Instruction instr) -> RegMap Loc -> [RealReg] -> RegM freeRegs ([NatBasicBlock instr], instr) -joinToTargets_first platform block_live new_blocks block_id instr dest dests - block_assig src_assig - to_free +joinToTargets_first block_live new_blocks block_id instr dest dests + block_assig src_assig + to_free - = do -- free up the regs that are not live on entry to this block. - freeregs <- getFreeRegsR - let freeregs' = foldr (frReleaseReg platform) freeregs to_free - - -- remember the current assignment on entry to this block. - setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig) + = do dflags <- getDynFlags + let platform = targetPlatform dflags - joinToTargets' platform block_live new_blocks block_id instr dests + -- free up the regs that are not live on entry to this block. + freeregs <- getFreeRegsR + let freeregs' = foldr (frReleaseReg platform) freeregs to_free + + -- remember the current assignment on entry to this block. + setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig) + + joinToTargets' block_live new_blocks block_id instr dests -- we've jumped to this block before joinToTargets_again :: (Instruction instr, FR freeRegs) - => Platform - -> BlockMap RegSet + => BlockMap RegSet -> [NatBasicBlock instr] -> BlockId -> instr @@ -156,82 +145,82 @@ joinToTargets_again :: (Instruction instr, FR freeRegs) -> UniqFM Loc -> RegM freeRegs ([NatBasicBlock instr], instr) joinToTargets_again - platform block_live new_blocks block_id instr dest dests + block_live new_blocks block_id instr dest dests src_assig dest_assig - -- the assignments already match, no problem. - | ufmToList dest_assig == ufmToList src_assig - = joinToTargets' platform block_live new_blocks block_id instr dests - - -- assignments don't match, need fixup code - | otherwise - = do - - -- make a graph of what things need to be moved where. - let graph = makeRegMovementGraph src_assig dest_assig - - -- look for cycles in the graph. This can happen if regs need to be swapped. - -- Note that we depend on the fact that this function does a - -- bottom up traversal of the tree-like portions of the graph. - -- - -- eg, if we have - -- R1 -> R2 -> R3 - -- - -- ie move value in R1 to R2 and value in R2 to R3. - -- - -- We need to do the R2 -> R3 move before R1 -> R2. - -- - let sccs = stronglyConnCompFromEdgedVerticesR graph - -{- -- debugging - pprTrace - ("joinToTargets: making fixup code") - (vcat [ text " in block: " <> ppr block_id - , text " jmp instruction: " <> ppr instr - , text " src assignment: " <> ppr src_assig - , text " dest assignment: " <> ppr dest_assig - , text " movement graph: " <> ppr graph - , text " sccs of graph: " <> ppr sccs - , text ""]) - (return ()) + -- the assignments already match, no problem. + | ufmToList dest_assig == ufmToList src_assig + = joinToTargets' block_live new_blocks block_id instr dests + + -- assignments don't match, need fixup code + | otherwise + = do + + -- make a graph of what things need to be moved where. + let graph = makeRegMovementGraph src_assig dest_assig + + -- look for cycles in the graph. This can happen if regs need to be swapped. + -- Note that we depend on the fact that this function does a + -- bottom up traversal of the tree-like portions of the graph. + -- + -- eg, if we have + -- R1 -> R2 -> R3 + -- + -- ie move value in R1 to R2 and value in R2 to R3. + -- + -- We need to do the R2 -> R3 move before R1 -> R2. + -- + let sccs = stronglyConnCompFromEdgedVerticesR graph + +{- -- debugging + pprTrace + ("joinToTargets: making fixup code") + (vcat [ text " in block: " <> ppr block_id + , text " jmp instruction: " <> ppr instr + , text " src assignment: " <> ppr src_assig + , text " dest assignment: " <> ppr dest_assig + , text " movement graph: " <> ppr graph + , text " sccs of graph: " <> ppr sccs + , text ""]) + (return ()) -} - delta <- getDeltaR - fixUpInstrs_ <- mapM (handleComponent platform delta instr) sccs - let fixUpInstrs = concat fixUpInstrs_ - - -- make a new basic block containing the fixup code. - -- A the end of the current block we will jump to the fixup one, - -- then that will jump to our original destination. - fixup_block_id <- getUniqueR - let block = BasicBlock (mkBlockId fixup_block_id) - $ fixUpInstrs ++ mkJumpInstr dest - -{- pprTrace - ("joinToTargets: fixup code is:") - (vcat [ ppr block - , text ""]) - (return ()) + delta <- getDeltaR + fixUpInstrs_ <- mapM (handleComponent delta instr) sccs + let fixUpInstrs = concat fixUpInstrs_ + + -- make a new basic block containing the fixup code. + -- A the end of the current block we will jump to the fixup one, + -- then that will jump to our original destination. + fixup_block_id <- getUniqueR + let block = BasicBlock (mkBlockId fixup_block_id) + $ fixUpInstrs ++ mkJumpInstr dest + +{- pprTrace + ("joinToTargets: fixup code is:") + (vcat [ ppr block + , text ""]) + (return ()) -} - -- if we didn't need any fixups, then don't include the block - case fixUpInstrs of - [] -> joinToTargets' platform block_live new_blocks block_id instr dests + -- if we didn't need any fixups, then don't include the block + case fixUpInstrs of + [] -> joinToTargets' block_live new_blocks block_id instr dests - -- patch the original branch instruction so it goes to our - -- fixup block instead. - _ -> let instr' = patchJumpInstr instr - (\bid -> if bid == dest - then mkBlockId fixup_block_id - else bid) -- no change! - - in joinToTargets' platform block_live (block : new_blocks) block_id instr' dests + -- patch the original branch instruction so it goes to our + -- fixup block instead. + _ -> let instr' = patchJumpInstr instr + (\bid -> if bid == dest + then mkBlockId fixup_block_id + else bid) -- no change! + + in joinToTargets' block_live (block : new_blocks) block_id instr' dests -- | Construct a graph of register\/spill movements. -- --- Cyclic components seem to occur only very rarely. +-- Cyclic components seem to occur only very rarely. -- --- We cut some corners by not handling memory-to-memory moves. --- This shouldn't happen because every temporary gets its own stack slot. +-- We cut some corners by not handling memory-to-memory moves. +-- This shouldn't happen because every temporary gets its own stack slot. -- makeRegMovementGraph :: RegMap Loc -> RegMap Loc -> [(Unique, Loc, [Loc])] makeRegMovementGraph adjusted_assig dest_assig @@ -242,95 +231,96 @@ makeRegMovementGraph adjusted_assig dest_assig -- | Expand out the destination, so InBoth destinations turn into --- a combination of InReg and InMem. +-- a combination of InReg and InMem. --- The InBoth handling is a little tricky here. If the destination is --- InBoth, then we must ensure that the value ends up in both locations. --- An InBoth destination must conflict with an InReg or InMem source, so --- we expand an InBoth destination as necessary. +-- The InBoth handling is a little tricky here. If the destination is +-- InBoth, then we must ensure that the value ends up in both locations. +-- An InBoth destination must conflict with an InReg or InMem source, so +-- we expand an InBoth destination as necessary. -- --- An InBoth source is slightly different: we only care about the register --- that the source value is in, so that we can move it to the destinations. +-- An InBoth source is slightly different: we only care about the register +-- that the source value is in, so that we can move it to the destinations. -- -expandNode - :: a - -> Loc -- ^ source of move - -> Loc -- ^ destination of move - -> [(a, Loc, [Loc])] +expandNode + :: a + -> Loc -- ^ source of move + -> Loc -- ^ destination of move + -> [(a, Loc, [Loc])] expandNode vreg loc@(InReg src) (InBoth dst mem) - | src == dst = [(vreg, loc, [InMem mem])] - | otherwise = [(vreg, loc, [InReg dst, InMem mem])] + | src == dst = [(vreg, loc, [InMem mem])] + | otherwise = [(vreg, loc, [InReg dst, InMem mem])] expandNode vreg loc@(InMem src) (InBoth dst mem) - | src == mem = [(vreg, loc, [InReg dst])] - | otherwise = [(vreg, loc, [InReg dst, InMem mem])] + | src == mem = [(vreg, loc, [InReg dst])] + | otherwise = [(vreg, loc, [InReg dst, InMem mem])] expandNode _ (InBoth _ src) (InMem dst) - | src == dst = [] -- guaranteed to be true + | src == dst = [] -- guaranteed to be true expandNode _ (InBoth src _) (InReg dst) - | src == dst = [] + | src == dst = [] expandNode vreg (InBoth src _) dst - = expandNode vreg (InReg src) dst + = expandNode vreg (InReg src) dst expandNode vreg src dst - | src == dst = [] - | otherwise = [(vreg, src, [dst])] + | src == dst = [] + | otherwise = [(vreg, src, [dst])] -- | Generate fixup code for a particular component in the move graph --- This component tells us what values need to be moved to what --- destinations. We have eliminated any possibility of single-node --- cycles in expandNode above. +-- This component tells us what values need to be moved to what +-- destinations. We have eliminated any possibility of single-node +-- cycles in expandNode above. -- -handleComponent - :: Instruction instr - => Platform -> Int -> instr -> SCC (Unique, Loc, [Loc]) -> RegM freeRegs [instr] +handleComponent + :: Instruction instr + => Int -> instr -> SCC (Unique, Loc, [Loc]) + -> RegM freeRegs [instr] -- If the graph is acyclic then we won't get the swapping problem below. --- In this case we can just do the moves directly, and avoid having to --- go via a spill slot. +-- In this case we can just do the moves directly, and avoid having to +-- go via a spill slot. -- -handleComponent platform delta _ (AcyclicSCC (vreg, src, dsts)) - = mapM (makeMove platform delta vreg src) dsts +handleComponent delta _ (AcyclicSCC (vreg, src, dsts)) + = mapM (makeMove delta vreg src) dsts -- Handle some cyclic moves. --- This can happen if we have two regs that need to be swapped. --- eg: --- vreg source loc dest loc --- (vreg1, InReg r1, [InReg r2]) --- (vreg2, InReg r2, [InReg r1]) +-- This can happen if we have two regs that need to be swapped. +-- eg: +-- vreg source loc dest loc +-- (vreg1, InReg r1, [InReg r2]) +-- (vreg2, InReg r2, [InReg r1]) +-- +-- To avoid needing temp register, we just spill all the source regs, then +-- reaload them into their destination regs. -- --- To avoid needing temp register, we just spill all the source regs, then --- reaload them into their destination regs. --- --- Note that we can not have cycles that involve memory locations as --- sources as single destination because memory locations (stack slots) --- are allocated exclusively for a virtual register and therefore can not --- require a fixup. +-- Note that we can not have cycles that involve memory locations as +-- sources as single destination because memory locations (stack slots) +-- are allocated exclusively for a virtual register and therefore can not +-- require a fixup. -- -handleComponent platform delta instr - (CyclicSCC ( (vreg, InReg sreg, (InReg dreg: _)) : rest)) +handleComponent delta instr + (CyclicSCC ((vreg, InReg sreg, (InReg dreg: _)) : rest)) -- dest list may have more than one element, if the reg is also InMem. = do - -- spill the source into its slot - (instrSpill, slot) - <- spillR platform (RegReal sreg) vreg + -- spill the source into its slot + (instrSpill, slot) + <- spillR (RegReal sreg) vreg - -- reload into destination reg - instrLoad <- loadR platform (RegReal dreg) slot - - remainingFixUps <- mapM (handleComponent platform delta instr) - (stronglyConnCompFromEdgedVerticesR rest) + -- reload into destination reg + instrLoad <- loadR (RegReal dreg) slot - -- make sure to do all the reloads after all the spills, - -- so we don't end up clobbering the source values. - return ([instrSpill] ++ concat remainingFixUps ++ [instrLoad]) + remainingFixUps <- mapM (handleComponent delta instr) + (stronglyConnCompFromEdgedVerticesR rest) -handleComponent _ _ _ (CyclicSCC _) + -- make sure to do all the reloads after all the spills, + -- so we don't end up clobbering the source values. + return ([instrSpill] ++ concat remainingFixUps ++ [instrLoad]) + +handleComponent _ _ (CyclicSCC _) = panic "Register Allocator: handleComponent cyclic" @@ -338,29 +328,31 @@ handleComponent _ _ _ (CyclicSCC _) -- makeMove :: Instruction instr - => Platform - -> Int -- ^ current C stack delta. + => Int -- ^ current C stack delta. -> Unique -- ^ unique of the vreg that we're moving. -> Loc -- ^ source location. -> Loc -- ^ destination location. -> RegM freeRegs instr -- ^ move instruction. -makeMove platform _ vreg (InReg src) (InReg dst) - = do recordSpill (SpillJoinRR vreg) - return $ mkRegRegMoveInstr platform (RegReal src) (RegReal dst) - -makeMove platform delta vreg (InMem src) (InReg dst) - = do recordSpill (SpillJoinRM vreg) - return $ mkLoadInstr platform (RegReal dst) delta src - -makeMove platform delta vreg (InReg src) (InMem dst) - = do recordSpill (SpillJoinRM vreg) - return $ mkSpillInstr platform (RegReal src) delta dst - --- we don't handle memory to memory moves. --- they shouldn't happen because we don't share stack slots between vregs. -makeMove _ _ vreg src dst - = panic $ "makeMove " ++ show vreg ++ " (" ++ show src ++ ") (" - ++ show dst ++ ")" - ++ " we don't handle mem->mem moves." +makeMove delta vreg src dst + = do dflags <- getDynFlags + let platform = targetPlatform dflags + + case (src, dst) of + (InReg s, InReg d) -> + do recordSpill (SpillJoinRR vreg) + return $ mkRegRegMoveInstr platform (RegReal s) (RegReal d) + (InMem s, InReg d) -> + do recordSpill (SpillJoinRM vreg) + return $ mkLoadInstr dflags (RegReal d) delta s + (InReg s, InMem d) -> + do recordSpill (SpillJoinRM vreg) + return $ mkSpillInstr dflags (RegReal s) delta d + _ -> + -- we don't handle memory to memory moves. + -- they shouldn't happen because we don't share + -- stack slots between vregs. + panic ("makeMove " ++ show vreg ++ " (" ++ show src ++ ") (" + ++ show dst ++ ")" + ++ " we don't handle mem->mem moves.") diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index c2f89de641..3f92ed975b 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -106,9 +106,10 @@ import RegAlloc.Linear.StackMap import RegAlloc.Linear.FreeRegs import RegAlloc.Linear.Stats import RegAlloc.Linear.JoinToTargets -import qualified RegAlloc.Linear.PPC.FreeRegs as PPC -import qualified RegAlloc.Linear.SPARC.FreeRegs as SPARC -import qualified RegAlloc.Linear.X86.FreeRegs as X86 +import qualified RegAlloc.Linear.PPC.FreeRegs as PPC +import qualified RegAlloc.Linear.SPARC.FreeRegs as SPARC +import qualified RegAlloc.Linear.X86.FreeRegs as X86 +import qualified RegAlloc.Linear.X86_64.FreeRegs as X86_64 import TargetReg import RegAlloc.Liveness import Instruction @@ -188,52 +189,51 @@ linearRegAlloc linearRegAlloc dflags first_id block_live sccs = let platform = targetPlatform dflags in case platformArch platform of - ArchX86 -> linearRegAlloc' platform (frInitFreeRegs platform :: X86.FreeRegs) first_id block_live sccs - ArchX86_64 -> linearRegAlloc' platform (frInitFreeRegs platform :: X86.FreeRegs) first_id block_live sccs - ArchSPARC -> linearRegAlloc' platform (frInitFreeRegs platform :: SPARC.FreeRegs) first_id block_live sccs - ArchPPC -> linearRegAlloc' platform (frInitFreeRegs platform :: PPC.FreeRegs) first_id block_live sccs + ArchX86 -> linearRegAlloc' dflags (frInitFreeRegs platform :: X86.FreeRegs) first_id block_live sccs + ArchX86_64 -> linearRegAlloc' dflags (frInitFreeRegs platform :: X86_64.FreeRegs) first_id block_live sccs + ArchSPARC -> linearRegAlloc' dflags (frInitFreeRegs platform :: SPARC.FreeRegs) first_id block_live sccs + ArchPPC -> linearRegAlloc' dflags (frInitFreeRegs platform :: PPC.FreeRegs) first_id block_live sccs ArchARM _ _ _ -> panic "linearRegAlloc ArchARM" ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64" ArchUnknown -> panic "linearRegAlloc ArchUnknown" linearRegAlloc' :: (FR freeRegs, Outputable instr, Instruction instr) - => Platform + => DynFlags -> freeRegs -> BlockId -- ^ the first block -> BlockMap RegSet -- ^ live regs on entry to each basic block -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" -> UniqSM ([NatBasicBlock instr], RegAllocStats) -linearRegAlloc' platform initFreeRegs first_id block_live sccs +linearRegAlloc' dflags initFreeRegs first_id block_live sccs = do us <- getUs let (_, _, stats, blocks) = - runR emptyBlockMap initFreeRegs emptyRegMap (emptyStackMap platform) us - $ linearRA_SCCs platform first_id block_live [] sccs + runR dflags emptyBlockMap initFreeRegs emptyRegMap (emptyStackMap dflags) us + $ linearRA_SCCs first_id block_live [] sccs return (blocks, stats) linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr) - => Platform - -> BlockId + => BlockId -> BlockMap RegSet -> [NatBasicBlock instr] -> [SCC (LiveBasicBlock instr)] -> RegM freeRegs [NatBasicBlock instr] -linearRA_SCCs _ _ _ blocksAcc [] +linearRA_SCCs _ _ blocksAcc [] = return $ reverse blocksAcc -linearRA_SCCs platform first_id block_live blocksAcc (AcyclicSCC block : sccs) - = do blocks' <- processBlock platform block_live block - linearRA_SCCs platform first_id block_live +linearRA_SCCs first_id block_live blocksAcc (AcyclicSCC block : sccs) + = do blocks' <- processBlock block_live block + linearRA_SCCs first_id block_live ((reverse blocks') ++ blocksAcc) sccs -linearRA_SCCs platform first_id block_live blocksAcc (CyclicSCC blocks : sccs) +linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs) = do - blockss' <- process platform first_id block_live blocks [] (return []) False - linearRA_SCCs platform first_id block_live + blockss' <- process first_id block_live blocks [] (return []) False + linearRA_SCCs first_id block_live (reverse (concat blockss') ++ blocksAcc) sccs @@ -250,8 +250,7 @@ linearRA_SCCs platform first_id block_live blocksAcc (CyclicSCC blocks : sccs) -} process :: (FR freeRegs, Instruction instr, Outputable instr) - => Platform - -> BlockId + => BlockId -> BlockMap RegSet -> [GenBasicBlock (LiveInstr instr)] -> [GenBasicBlock (LiveInstr instr)] @@ -259,10 +258,10 @@ process :: (FR freeRegs, Instruction instr, Outputable instr) -> Bool -> RegM freeRegs [[NatBasicBlock instr]] -process _ _ _ [] [] accum _ +process _ _ [] [] accum _ = return $ reverse accum -process platform first_id block_live [] next_round accum madeProgress +process first_id block_live [] next_round accum madeProgress | not madeProgress {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming. @@ -272,10 +271,10 @@ process platform first_id block_live [] next_round accum madeProgress = return $ reverse accum | otherwise - = process platform first_id block_live + = process first_id block_live next_round [] accum False -process platform first_id block_live (b@(BasicBlock id _) : blocks) +process first_id block_live (b@(BasicBlock id _) : blocks) next_round accum madeProgress = do block_assig <- getBlockAssigR @@ -283,11 +282,11 @@ process platform first_id block_live (b@(BasicBlock id _) : blocks) if isJust (mapLookup id block_assig) || id == first_id then do - b' <- processBlock platform block_live b - process platform first_id block_live blocks + b' <- processBlock block_live b + process first_id block_live blocks next_round (b' : accum) True - else process platform first_id block_live blocks + else process first_id block_live blocks (b : next_round) accum madeProgress @@ -295,24 +294,25 @@ process platform first_id block_live (b@(BasicBlock id _) : blocks) -- processBlock :: (FR freeRegs, Outputable instr, Instruction instr) - => Platform - -> BlockMap RegSet -- ^ live regs on entry to each basic block + => BlockMap RegSet -- ^ live regs on entry to each basic block -> LiveBasicBlock instr -- ^ block to do register allocation on -> RegM freeRegs [NatBasicBlock instr] -- ^ block with registers allocated -processBlock platform block_live (BasicBlock id instrs) - = do initBlock platform id block_live +processBlock block_live (BasicBlock id instrs) + = do initBlock id block_live (instrs', fixups) - <- linearRA platform block_live [] [] id instrs + <- linearRA block_live [] [] id instrs return $ BasicBlock id instrs' : fixups -- | Load the freeregs and current reg assignment into the RegM state -- for the basic block with this BlockId. initBlock :: FR freeRegs - => Platform -> BlockId -> BlockMap RegSet -> RegM freeRegs () -initBlock platform id block_live - = do block_assig <- getBlockAssigR + => BlockId -> BlockMap RegSet -> RegM freeRegs () +initBlock id block_live + = do dflags <- getDynFlags + let platform = targetPlatform dflags + block_assig <- getBlockAssigR case mapLookup id block_assig of -- no prior info about this block: we must consider -- any fixed regs to be allocated, but we can ignore @@ -337,8 +337,7 @@ initBlock platform id block_live -- | Do allocation for a sequence of instructions. linearRA :: (FR freeRegs, Outputable instr, Instruction instr) - => Platform - -> BlockMap RegSet -- ^ map of what vregs are live on entry to each block. + => BlockMap RegSet -- ^ map of what vregs are live on entry to each block. -> [instr] -- ^ accumulator for instructions already processed. -> [NatBasicBlock instr] -- ^ accumulator for blocks of fixup code. -> BlockId -- ^ id of the current block, for debugging. @@ -349,25 +348,23 @@ linearRA , [NatBasicBlock instr]) -- fresh blocks of fixup code. -linearRA _ _ accInstr accFixup _ [] +linearRA _ accInstr accFixup _ [] = return ( reverse accInstr -- instrs need to be returned in the correct order. , accFixup) -- it doesn't matter what order the fixup blocks are returned in. -linearRA platform block_live accInstr accFixups id (instr:instrs) +linearRA block_live accInstr accFixups id (instr:instrs) = do - (accInstr', new_fixups) - <- raInsn platform block_live accInstr id instr + (accInstr', new_fixups) <- raInsn block_live accInstr id instr - linearRA platform block_live accInstr' (new_fixups ++ accFixups) id instrs + linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs -- | Do allocation for a single instruction. raInsn :: (FR freeRegs, Outputable instr, Instruction instr) - => Platform - -> BlockMap RegSet -- ^ map of what vregs are love on entry to each block. + => BlockMap RegSet -- ^ map of what vregs are love on entry to each block. -> [instr] -- ^ accumulator for instructions already processed. -> BlockId -- ^ the id of the current block, for debugging -> LiveInstr instr -- ^ the instr to have its regs allocated, with liveness info. @@ -375,17 +372,17 @@ raInsn ( [instr] -- new instructions , [NatBasicBlock instr]) -- extra fixup blocks -raInsn _ _ new_instrs _ (LiveInstr ii Nothing) +raInsn _ new_instrs _ (LiveInstr ii Nothing) | Just n <- takeDeltaInstr ii = do setDeltaR n return (new_instrs, []) -raInsn _ _ new_instrs _ (LiveInstr ii Nothing) +raInsn _ new_instrs _ (LiveInstr ii Nothing) | isMetaInstr ii = return (new_instrs, []) -raInsn platform block_live new_instrs id (LiveInstr (Instr instr) (Just live)) +raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) = do assig <- getAssigR @@ -420,12 +417,12 @@ raInsn platform block_live new_instrs id (LiveInstr (Instr instr) (Just live)) -} return (new_instrs, []) - _ -> genRaInsn platform block_live new_instrs id instr + _ -> genRaInsn block_live new_instrs id instr (uniqSetToList $ liveDieRead live) (uniqSetToList $ liveDieWrite live) -raInsn _ _ _ _ instr +raInsn _ _ _ instr = pprPanic "raInsn" (text "no match for:" <> ppr instr) @@ -435,8 +432,7 @@ isInReg src assig | Just (InReg _) <- lookupUFM assig src = True genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr) - => Platform - -> BlockMap RegSet + => BlockMap RegSet -> [instr] -> BlockId -> instr @@ -444,8 +440,10 @@ genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr) -> [Reg] -> RegM freeRegs ([instr], [NatBasicBlock instr]) -genRaInsn platform block_live new_instrs block_id instr r_dying w_dying = - case regUsageOfInstr platform instr of { RU read written -> +genRaInsn block_live new_instrs block_id instr r_dying w_dying = do + dflags <- getDynFlags + let platform = targetPlatform dflags + case regUsageOfInstr platform instr of { RU read written -> do let real_written = [ rr | (RegReal rr) <- written ] let virt_written = [ vr | (RegVirtual vr) <- written ] @@ -471,32 +469,32 @@ genRaInsn platform block_live new_instrs block_id instr r_dying w_dying = -- (a), (b) allocate real regs for all regs read by this instruction. (r_spills, r_allocd) <- - allocateRegsAndSpill platform True{-reading-} virt_read [] [] virt_read + allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read -- (c) save any temporaries which will be clobbered by this instruction - clobber_saves <- saveClobberedTemps platform real_written r_dying + clobber_saves <- saveClobberedTemps real_written r_dying -- (d) Update block map for new destinations -- NB. do this before removing dead regs from the assignment, because -- these dead regs might in fact be live in the jump targets (they're -- only dead in the code that follows in the current basic block). (fixup_blocks, adjusted_instr) - <- joinToTargets platform block_live block_id instr + <- joinToTargets block_live block_id instr -- (e) Delete all register assignments for temps which are read -- (only) and die here. Update the free register list. - releaseRegs platform r_dying + releaseRegs r_dying -- (f) Mark regs which are clobbered as unallocatable - clobberRegs platform real_written + clobberRegs real_written -- (g) Allocate registers for temporaries *written* (only) (w_spills, w_allocd) <- - allocateRegsAndSpill platform False{-writing-} virt_written [] [] virt_written + allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written -- (h) Release registers for temps which are written here and not -- used again. - releaseRegs platform w_dying + releaseRegs w_dying let -- (i) Patch the instruction @@ -539,20 +537,23 @@ genRaInsn platform block_live new_instrs block_id instr r_dying w_dying = -- ----------------------------------------------------------------------------- -- releaseRegs -releaseRegs :: FR freeRegs => Platform -> [Reg] -> RegM freeRegs () -releaseRegs platform regs = do +releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs () +releaseRegs regs = do + dflags <- getDynFlags + let platform = targetPlatform dflags assig <- getAssigR free <- getFreeRegsR + let loop _ free _ | free `seq` False = undefined + loop assig free [] = do setAssigR assig; setFreeRegsR free; return () + loop assig free (RegReal rr : rs) = loop assig (frReleaseReg platform rr free) rs + loop assig free (r:rs) = + case lookupUFM assig r of + Just (InBoth real _) -> loop (delFromUFM assig r) + (frReleaseReg platform real free) rs + Just (InReg real) -> loop (delFromUFM assig r) + (frReleaseReg platform real free) rs + _ -> loop (delFromUFM assig r) free rs loop assig free regs - where - loop _ free _ | free `seq` False = undefined - loop assig free [] = do setAssigR assig; setFreeRegsR free; return () - loop assig free (RegReal rr : rs) = loop assig (frReleaseReg platform rr free) rs - loop assig free (r:rs) = - case lookupUFM assig r of - Just (InBoth real _) -> loop (delFromUFM assig r) (frReleaseReg platform real free) rs - Just (InReg real) -> loop (delFromUFM assig r) (frReleaseReg platform real free) rs - _other -> loop (delFromUFM assig r) free rs -- ----------------------------------------------------------------------------- @@ -571,16 +572,15 @@ releaseRegs platform regs = do saveClobberedTemps :: (Outputable instr, Instruction instr, FR freeRegs) - => Platform - -> [RealReg] -- real registers clobbered by this instruction + => [RealReg] -- real registers clobbered by this instruction -> [Reg] -- registers which are no longer live after this insn -> RegM freeRegs [instr] -- return: instructions to spill any temps that will -- be clobbered. -saveClobberedTemps _ [] _ +saveClobberedTemps [] _ = return [] -saveClobberedTemps platform clobbered dying +saveClobberedTemps clobbered dying = do assig <- getAssigR let to_spill @@ -598,7 +598,9 @@ saveClobberedTemps platform clobbered dying = return (instrs, assig) clobber assig instrs ((temp, reg) : rest) - = do + = do dflags <- getDynFlags + let platform = targetPlatform dflags + freeRegs <- getFreeRegsR let regclass = targetClassOfRealReg platform reg freeRegs_thisClass = frGetFreeRegs platform regclass freeRegs @@ -619,7 +621,7 @@ saveClobberedTemps platform clobbered dying -- (2) no free registers: spill the value [] -> do - (spill, slot) <- spillR platform (RegReal reg) temp + (spill, slot) <- spillR (RegReal reg) temp -- record why this reg was spilled for profiling recordSpill (SpillClobber temp) @@ -633,12 +635,14 @@ saveClobberedTemps platform clobbered dying -- | Mark all these real regs as allocated, -- and kick out their vreg assignments. -- -clobberRegs :: FR freeRegs => Platform -> [RealReg] -> RegM freeRegs () -clobberRegs _ [] +clobberRegs :: FR freeRegs => [RealReg] -> RegM freeRegs () +clobberRegs [] = return () -clobberRegs platform clobbered - = do +clobberRegs clobbered + = do dflags <- getDynFlags + let platform = targetPlatform dflags + freeregs <- getFreeRegsR setFreeRegsR $! foldr (frAllocateReg platform) freeregs clobbered @@ -684,24 +688,23 @@ data SpillLoc = ReadMem StackSlot -- reading from register only in memory allocateRegsAndSpill :: (FR freeRegs, Outputable instr, Instruction instr) - => Platform - -> Bool -- True <=> reading (load up spilled regs) + => Bool -- True <=> reading (load up spilled regs) -> [VirtualReg] -- don't push these out -> [instr] -- spill insns -> [RealReg] -- real registers allocated (accum.) -> [VirtualReg] -- temps to allocate -> RegM freeRegs ( [instr] , [RealReg]) -allocateRegsAndSpill _ _ _ spills alloc [] +allocateRegsAndSpill _ _ spills alloc [] = return (spills, reverse alloc) -allocateRegsAndSpill platform reading keep spills alloc (r:rs) +allocateRegsAndSpill reading keep spills alloc (r:rs) = do assig <- getAssigR - let doSpill = allocRegsAndSpill_spill platform reading keep spills alloc r rs assig + let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig case lookupUFM assig r of -- case (1a): already in a register Just (InReg my_reg) -> - allocateRegsAndSpill platform reading keep spills (my_reg:alloc) rs + allocateRegsAndSpill reading keep spills (my_reg:alloc) rs -- case (1b): already in a register (and memory) -- NB1. if we're writing this register, update its assignment to be @@ -710,7 +713,7 @@ allocateRegsAndSpill platform reading keep spills alloc (r:rs) -- are also read by the same instruction. Just (InBoth my_reg _) -> do when (not reading) (setAssigR (addToUFM assig r (InReg my_reg))) - allocateRegsAndSpill platform reading keep spills (my_reg:alloc) rs + allocateRegsAndSpill reading keep spills (my_reg:alloc) rs -- Not already in a register, so we need to find a free one... Just (InMem slot) | reading -> doSpill (ReadMem slot) @@ -729,8 +732,7 @@ allocateRegsAndSpill platform reading keep spills alloc (r:rs) -- reading is redundant with reason, but we keep it around because it's -- convenient and it maintains the recursive structure of the allocator. -- EZY allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr) - => Platform - -> Bool + => Bool -> [VirtualReg] -> [instr] -> [RealReg] @@ -739,8 +741,9 @@ allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr) -> UniqFM Loc -> SpillLoc -> RegM freeRegs ([instr], [RealReg]) -allocRegsAndSpill_spill platform reading keep spills alloc r rs assig spill_loc - = do +allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc + = do dflags <- getDynFlags + let platform = targetPlatform dflags freeRegs <- getFreeRegsR let freeRegs_thisClass = frGetFreeRegs platform (classOfVirtualReg r) freeRegs @@ -748,12 +751,12 @@ allocRegsAndSpill_spill platform reading keep spills alloc r rs assig spill_loc -- case (2): we have a free register (my_reg : _) -> - do spills' <- loadTemp platform r spill_loc my_reg spills + do spills' <- loadTemp r spill_loc my_reg spills setAssigR (addToUFM assig r $! newLocation spill_loc my_reg) setFreeRegsR $ frAllocateReg platform my_reg freeRegs - allocateRegsAndSpill platform reading keep spills' (my_reg : alloc) rs + allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs -- case (3): we need to push something out to free up a register @@ -780,19 +783,19 @@ allocRegsAndSpill_spill platform reading keep spills alloc r rs assig spill_loc -- we have a temporary that is in both register and mem, -- just free up its register for use. | (temp, my_reg, slot) : _ <- candidates_inBoth - = do spills' <- loadTemp platform r spill_loc my_reg spills + = do spills' <- loadTemp r spill_loc my_reg spills let assig1 = addToUFM assig temp (InMem slot) let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg setAssigR assig2 - allocateRegsAndSpill platform reading keep spills' (my_reg:alloc) rs + allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs -- otherwise, we need to spill a temporary that currently -- resides in a register. | (temp_to_push_out, (my_reg :: RealReg)) : _ <- candidates_inReg = do - (spill_insn, slot) <- spillR platform (RegReal my_reg) temp_to_push_out + (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out let spill_store = (if reading then id else reverse) [ -- COMMENT (fsLit "spill alloc") spill_insn ] @@ -806,9 +809,9 @@ allocRegsAndSpill_spill platform reading keep spills alloc r rs assig spill_loc setAssigR assig2 -- if need be, load up a spilled temp into the reg we've just freed up. - spills' <- loadTemp platform r spill_loc my_reg spills + spills' <- loadTemp r spill_loc my_reg spills - allocateRegsAndSpill platform reading keep + allocateRegsAndSpill reading keep (spill_store ++ spills') (my_reg:alloc) rs @@ -835,19 +838,18 @@ newLocation _ my_reg = InReg my_reg -- | Load up a spilled temporary if we need to (read from memory). loadTemp :: (Outputable instr, Instruction instr) - => Platform - -> VirtualReg -- the temp being loaded + => VirtualReg -- the temp being loaded -> SpillLoc -- the current location of this temp -> RealReg -- the hreg to load the temp into -> [instr] -> RegM freeRegs [instr] -loadTemp platform vreg (ReadMem slot) hreg spills +loadTemp vreg (ReadMem slot) hreg spills = do - insn <- loadR platform (RegReal hreg) slot + insn <- loadR (RegReal hreg) slot recordSpill (SpillLoad $ getUnique vreg) return $ {- COMMENT (fsLit "spill load") : -} insn : spills -loadTemp _ _ _ _ spills = +loadTemp _ _ _ spills = return spills diff --git a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs index ea05cf0d0f..b1fc3c169e 100644 --- a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs +++ b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs @@ -28,8 +28,8 @@ where import RegAlloc.Linear.FreeRegs +import DynFlags import Outputable -import Platform import UniqFM import Unique @@ -47,8 +47,8 @@ data StackMap -- | An empty stack map, with all slots available. -emptyStackMap :: Platform -> StackMap -emptyStackMap platform = StackMap [0 .. maxSpillSlots platform] emptyUFM +emptyStackMap :: DynFlags -> StackMap +emptyStackMap dflags = StackMap [0 .. maxSpillSlots dflags] emptyUFM -- | If this vreg unique already has a stack assignment then return the slot number, diff --git a/compiler/nativeGen/RegAlloc/Linear/State.hs b/compiler/nativeGen/RegAlloc/Linear/State.hs index ca2ecd3883..a608a947e7 100644 --- a/compiler/nativeGen/RegAlloc/Linear/State.hs +++ b/compiler/nativeGen/RegAlloc/Linear/State.hs @@ -1,39 +1,31 @@ -- | State monad for the linear register allocator. --- Here we keep all the state that the register allocator keeps track --- of as it walks the instructions in a basic block. - -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# 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 +-- Here we keep all the state that the register allocator keeps track +-- of as it walks the instructions in a basic block. module RegAlloc.Linear.State ( - RA_State(..), - RegM, - runR, - - spillR, - loadR, - - getFreeRegsR, - setFreeRegsR, - - getAssigR, - setAssigR, - - getBlockAssigR, - setBlockAssigR, - - setDeltaR, - getDeltaR, - - getUniqueR, - - recordSpill + RA_State(..), + RegM, + runR, + + spillR, + loadR, + + getFreeRegsR, + setFreeRegsR, + + getAssigR, + setAssigR, + + getBlockAssigR, + setBlockAssigR, + + setDeltaR, + getDeltaR, + + getUniqueR, + + recordSpill ) where @@ -44,67 +36,79 @@ import RegAlloc.Liveness import Instruction import Reg -import Platform +import DynFlags import Unique import UniqSupply +-- | The register allocator monad type. +newtype RegM freeRegs a + = RegM { unReg :: RA_State freeRegs -> (# RA_State freeRegs, a #) } + + -- | The RegM Monad instance Monad (RegM freeRegs) where m >>= k = RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s } return a = RegM $ \s -> (# s, a #) +instance HasDynFlags (RegM a) where + getDynFlags = RegM $ \s -> (# s, ra_DynFlags s #) + -- | Run a computation in the RegM register allocator monad. -runR :: BlockAssignment freeRegs - -> freeRegs - -> RegMap Loc - -> StackMap - -> UniqSupply - -> RegM freeRegs a - -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a) - -runR block_assig freeregs assig stack us thing = - case unReg thing - (RA_State - { ra_blockassig = block_assig - , ra_freeregs = freeregs - , ra_assig = assig - , ra_delta = 0{-???-} - , ra_stack = stack - , ra_us = us - , ra_spills = [] }) +runR :: DynFlags + -> BlockAssignment freeRegs + -> freeRegs + -> RegMap Loc + -> StackMap + -> UniqSupply + -> RegM freeRegs a + -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a) + +runR dflags block_assig freeregs assig stack us thing = + case unReg thing + (RA_State + { ra_blockassig = block_assig + , ra_freeregs = freeregs + , ra_assig = assig + , ra_delta = 0{-???-} + , ra_stack = stack + , ra_us = us + , ra_spills = [] + , ra_DynFlags = dflags }) of - (# state'@RA_State - { ra_blockassig = block_assig - , ra_stack = stack' } - , returned_thing #) - - -> (block_assig, stack', makeRAStats state', returned_thing) + (# state'@RA_State + { ra_blockassig = block_assig + , ra_stack = stack' } + , returned_thing #) + + -> (block_assig, stack', makeRAStats state', returned_thing) -- | Make register allocator stats from its final state. makeRAStats :: RA_State freeRegs -> RegAllocStats makeRAStats state - = RegAllocStats - { ra_spillInstrs = binSpillReasons (ra_spills state) } + = RegAllocStats + { ra_spillInstrs = binSpillReasons (ra_spills state) } spillR :: Instruction instr - => Platform -> Reg -> Unique -> RegM freeRegs (instr, Int) + => Reg -> Unique -> RegM freeRegs (instr, Int) -spillR platform reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} -> - let (stack',slot) = getStackSlotFor stack temp - instr = mkSpillInstr platform reg delta slot +spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} -> + let dflags = ra_DynFlags s + (stack',slot) = getStackSlotFor stack temp + instr = mkSpillInstr dflags reg delta slot in (# s{ra_stack=stack'}, (instr,slot) #) loadR :: Instruction instr - => Platform -> Reg -> Int -> RegM freeRegs instr + => Reg -> Int -> RegM freeRegs instr -loadR platform reg slot = RegM $ \ s@RA_State{ra_delta=delta} -> - (# s, mkLoadInstr platform reg delta slot #) +loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} -> + let dflags = ra_DynFlags s + in (# s, mkLoadInstr dflags reg delta slot #) getFreeRegsR :: RegM freeRegs freeRegs getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} -> @@ -146,4 +150,5 @@ getUniqueR = RegM $ \s -> -- | Record that a spill instruction was inserted, for profiling. recordSpill :: SpillReason -> RegM freeRegs () recordSpill spill - = RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #) + = RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #) + diff --git a/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs index 6309b24b45..0fcd658120 100644 --- a/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs @@ -1,5 +1,5 @@ --- | Free regs map for i386 and x86_64 +-- | Free regs map for i386 module RegAlloc.Linear.X86.FreeRegs where @@ -12,29 +12,25 @@ import Platform import Data.Word import Data.Bits -type FreeRegs -#ifdef i386_TARGET_ARCH - = Word32 -#else - = Word64 -#endif +newtype FreeRegs = FreeRegs Word32 + deriving Show noFreeRegs :: FreeRegs -noFreeRegs = 0 +noFreeRegs = FreeRegs 0 releaseReg :: RealReg -> FreeRegs -> FreeRegs -releaseReg (RealRegSingle n) f - = f .|. (1 `shiftL` n) +releaseReg (RealRegSingle n) (FreeRegs f) + = FreeRegs (f .|. (1 `shiftL` n)) releaseReg _ _ - = panic "RegAlloc.Linear.X86.FreeRegs.realeaseReg: no reg" + = panic "RegAlloc.Linear.X86.FreeRegs.releaseReg: no reg" initFreeRegs :: Platform -> FreeRegs initFreeRegs platform = foldr releaseReg noFreeRegs (allocatableRegs platform) -getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazilly -getFreeRegs platform cls f = go f 0 +getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily +getFreeRegs platform cls (FreeRegs f) = go f 0 where go 0 _ = [] go n m @@ -47,10 +43,9 @@ getFreeRegs platform cls f = go f 0 -- in order to find a floating-point one. allocateReg :: RealReg -> FreeRegs -> FreeRegs -allocateReg (RealRegSingle r) f - = f .&. complement (1 `shiftL` r) +allocateReg (RealRegSingle r) (FreeRegs f) + = FreeRegs (f .&. complement (1 `shiftL` r)) allocateReg _ _ = panic "RegAlloc.Linear.X86.FreeRegs.allocateReg: no reg" - diff --git a/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs new file mode 100644 index 0000000000..c04fce9645 --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs @@ -0,0 +1,52 @@ + +-- | Free regs map for x86_64 +module RegAlloc.Linear.X86_64.FreeRegs +where + +import X86.Regs +import RegClass +import Reg +import Panic +import Platform + +import Data.Word +import Data.Bits + +newtype FreeRegs = FreeRegs Word64 + deriving Show + +noFreeRegs :: FreeRegs +noFreeRegs = FreeRegs 0 + +releaseReg :: RealReg -> FreeRegs -> FreeRegs +releaseReg (RealRegSingle n) (FreeRegs f) + = FreeRegs (f .|. (1 `shiftL` n)) + +releaseReg _ _ + = panic "RegAlloc.Linear.X86_64.FreeRegs.releaseReg: no reg" + +initFreeRegs :: Platform -> FreeRegs +initFreeRegs platform + = foldr releaseReg noFreeRegs (allocatableRegs platform) + +getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily +getFreeRegs platform cls (FreeRegs f) = go f 0 + + where go 0 _ = [] + go n m + | n .&. 1 /= 0 && classOfRealReg platform (RealRegSingle m) == cls + = RealRegSingle m : (go (n `shiftR` 1) $! (m+1)) + + | otherwise + = go (n `shiftR` 1) $! (m+1) + -- ToDo: there's no point looking through all the integer registers + -- in order to find a floating-point one. + +allocateReg :: RealReg -> FreeRegs -> FreeRegs +allocateReg (RealRegSingle r) (FreeRegs f) + = FreeRegs (f .&. complement (1 `shiftL` r)) + +allocateReg _ _ + = panic "RegAlloc.Linear.X86_64.FreeRegs.allocateReg: no reg" + + diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index 2483e12213..ac58944f1c 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -39,6 +39,7 @@ import OldCmm hiding (RegSet) import OldPprCmm() import Digraph +import DynFlags import Outputable import Platform import Unique @@ -461,11 +462,11 @@ slurpReloadCoalesce live -- | Strip away liveness information, yielding NatCmmDecl stripLive :: (Outputable statics, Outputable instr, Instruction instr) - => Platform + => DynFlags -> LiveCmmDecl statics instr -> NatCmmDecl statics instr -stripLive platform live +stripLive dflags live = stripCmm live where stripCmm :: (Outputable statics, Outputable instr, Instruction instr) @@ -481,7 +482,7 @@ stripLive platform live = partition ((== first_id) . blockId) final_blocks in CmmProc info label - (ListGraph $ map (stripLiveBlock platform) $ first' : rest') + (ListGraph $ map (stripLiveBlock dflags) $ first' : rest') -- procs used for stg_split_markers don't contain any blocks, and have no first_id. stripCmm (CmmProc (LiveInfo info Nothing _ _) label []) @@ -496,11 +497,11 @@ stripLive platform live stripLiveBlock :: Instruction instr - => Platform + => DynFlags -> LiveBasicBlock instr -> NatBasicBlock instr -stripLiveBlock platform (BasicBlock i lis) +stripLiveBlock dflags (BasicBlock i lis) = BasicBlock i instrs' where (instrs', _) @@ -511,11 +512,11 @@ stripLiveBlock platform (BasicBlock i lis) spillNat acc (LiveInstr (SPILL reg slot) _ : instrs) = do delta <- get - spillNat (mkSpillInstr platform reg delta slot : acc) instrs + spillNat (mkSpillInstr dflags reg delta slot : acc) instrs spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs) = do delta <- get - spillNat (mkLoadInstr platform reg delta slot : acc) instrs + spillNat (mkLoadInstr dflags reg delta slot : acc) instrs spillNat acc (LiveInstr (Instr instr) _ : instrs) | Just i <- takeDeltaInstr instr diff --git a/compiler/nativeGen/SPARC/Base.hs b/compiler/nativeGen/SPARC/Base.hs index de11b9f77c..aa7b057e69 100644 --- a/compiler/nativeGen/SPARC/Base.hs +++ b/compiler/nativeGen/SPARC/Base.hs @@ -25,7 +25,7 @@ module SPARC.Base ( where -import qualified Constants +import DynFlags import Panic import Data.Int @@ -40,9 +40,9 @@ wordLengthInBits = wordLength * 8 -- Size of the available spill area -spillAreaLength :: Int +spillAreaLength :: DynFlags -> Int spillAreaLength - = Constants.rESERVED_C_STACK_BYTES + = rESERVED_C_STACK_BYTES -- | We need 8 bytes because our largest registers are 64 bit. spillSlotSize :: Int diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index a3409dd28b..9d6aeaafc9 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -111,7 +111,9 @@ stmtsToInstrs stmts stmtToInstrs :: CmmStmt -> NatM InstrBlock -stmtToInstrs stmt = case stmt of +stmtToInstrs stmt = do + dflags <- getDynFlags + case stmt of CmmNop -> return nilOL CmmComment s -> return (unitOL (COMMENT s)) @@ -119,14 +121,14 @@ stmtToInstrs stmt = case stmt of | isFloatType ty -> assignReg_FltCode size reg src | isWord64 ty -> assignReg_I64Code reg src | otherwise -> assignReg_IntCode size reg src - where ty = cmmRegType reg + where ty = cmmRegType dflags reg size = cmmTypeSize ty CmmStore addr src | isFloatType ty -> assignMem_FltCode size addr src | isWord64 ty -> assignMem_I64Code addr src | otherwise -> assignMem_IntCode size addr src - where ty = cmmExprType src + where ty = cmmExprType dflags src size = cmmTypeSize ty CmmCall target result_regs args _ @@ -163,9 +165,9 @@ temporary, then do the other computation, and then use the temporary: -- | Convert a BlockId to some CmmStatic data -jumpTableEntry :: Maybe BlockId -> CmmStatic -jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth) -jumpTableEntry (Just blockid) = CmmStaticLit (CmmLabel blockLabel) +jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic +jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags)) +jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) where blockLabel = mkAsmTempLabel (getUnique blockid) @@ -203,11 +205,12 @@ assignReg_IntCode _ reg src = do -- Floating point assignment to memory assignMem_FltCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock assignMem_FltCode pk addr src = do + dflags <- getDynFlags Amode dst__2 code1 <- getAmode addr (src__2, code2) <- getSomeReg src tmp1 <- getNewRegNat pk let - pk__2 = cmmExprType src + pk__2 = cmmExprType dflags src code__2 = code1 `appOL` code2 `appOL` if sizeToWidth pk == typeWidth pk__2 then unitOL (ST pk src__2 dst__2) @@ -321,8 +324,8 @@ genSwitch dflags expr ids generateJumpTableForInstr :: DynFlags -> Instr -> Maybe (NatCmmDecl CmmStatics Instr) -generateJumpTableForInstr _ (JMP_TBL _ ids label) = - let jumpTable = map jumpTableEntry ids +generateJumpTableForInstr dflags (JMP_TBL _ ids label) = + let jumpTable = map (jumpTableEntry dflags) ids in Just (CmmData ReadOnlyData (Statics label jumpTable)) generateJumpTableForInstr _ _ = Nothing @@ -458,17 +461,21 @@ genCCall target dest_regs argsAndHints -- | Generate code to calculate an argument, and move it into one -- or two integer vregs. arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg]) -arg_to_int_vregs arg +arg_to_int_vregs arg = do dflags <- getDynFlags + arg_to_int_vregs' dflags arg + +arg_to_int_vregs' :: DynFlags -> CmmExpr -> NatM (OrdList Instr, [Reg]) +arg_to_int_vregs' dflags arg -- If the expr produces a 64 bit int, then we can just use iselExpr64 - | isWord64 (cmmExprType arg) + | isWord64 (cmmExprType dflags arg) = do (ChildCode64 code r_lo) <- iselExpr64 arg let r_hi = getHiVRegFromLo r_lo return (code, [r_hi, r_lo]) | otherwise = do (src, code) <- getSomeReg arg - let pk = cmmExprType arg + let pk = cmmExprType dflags arg case cmmTypeSize pk of diff --git a/compiler/nativeGen/SPARC/CodeGen/Amode.hs b/compiler/nativeGen/SPARC/CodeGen/Amode.hs index 92e70eb4dc..139064ccbd 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Amode.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Amode.hs @@ -33,7 +33,8 @@ getAmode -> NatM Amode getAmode tree@(CmmRegOff _ _) - = getAmode (mangleIndexTree tree) + = do dflags <- getDynFlags + getAmode (mangleIndexTree dflags tree) getAmode (CmmMachOp (MO_Sub _) [x, CmmLit (CmmInt i _)]) | fits13Bits (-i) diff --git a/compiler/nativeGen/SPARC/CodeGen/Base.hs b/compiler/nativeGen/SPARC/CodeGen/Base.hs index 469361139b..367d9230ba 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Base.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Base.hs @@ -29,6 +29,7 @@ import Size import Reg import CodeGen.Platform +import DynFlags import OldCmm import OldPprCmm () import Platform @@ -114,13 +115,13 @@ getRegisterReg platform (CmmGlobal mid) -- Expand CmmRegOff. ToDo: should we do it this way around, or convert -- CmmExprs into CmmRegOff? -mangleIndexTree :: CmmExpr -> CmmExpr +mangleIndexTree :: DynFlags -> CmmExpr -> CmmExpr -mangleIndexTree (CmmRegOff reg off) +mangleIndexTree dflags (CmmRegOff reg off) = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] - where width = typeWidth (cmmRegType reg) + where width = typeWidth (cmmRegType dflags reg) -mangleIndexTree _ +mangleIndexTree _ _ = panic "SPARC.CodeGen.Base.mangleIndexTree: no match" diff --git a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs index 74f20196df..d459d98212 100644 --- a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs +++ b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs @@ -93,14 +93,15 @@ condIntCode cond x y = do condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode condFltCode cond x y = do + dflags <- getDynFlags (src1, code1) <- getSomeReg x (src2, code2) <- getSomeReg y tmp <- getNewRegNat FF64 let promote x = FxTOy FF32 FF64 x tmp - pk1 = cmmExprType x - pk2 = cmmExprType y + pk1 = cmmExprType dflags x + pk2 = cmmExprType dflags y code__2 = if pk1 `cmmEqType` pk2 then diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs index c2c47e99aa..f7c7419e15 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs @@ -57,11 +57,12 @@ getRegister :: CmmExpr -> NatM Register getRegister (CmmReg reg) = do dflags <- getDynFlags let platform = targetPlatform dflags - return (Fixed (cmmTypeSize (cmmRegType reg)) - (getRegisterReg platform reg) nilOL) + return (Fixed (cmmTypeSize (cmmRegType dflags reg)) + (getRegisterReg platform reg) nilOL) getRegister tree@(CmmRegOff _ _) - = getRegister (mangleIndexTree tree) + = do dflags <- getDynFlags + getRegister (mangleIndexTree dflags tree) getRegister (CmmMachOp (MO_UU_Conv W64 W32) [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do @@ -490,14 +491,15 @@ trivialFCode -> NatM Register trivialFCode pk instr x y = do + dflags <- getDynFlags (src1, code1) <- getSomeReg x (src2, code2) <- getSomeReg y tmp <- getNewRegNat FF64 let promote x = FxTOy FF32 FF64 x tmp - pk1 = cmmExprType x - pk2 = cmmExprType y + pk1 = cmmExprType dflags x + pk2 = cmmExprType dflags y code__2 dst = if pk1 `cmmEqType` pk2 then diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs index 021b2fb772..9404badea6 100644 --- a/compiler/nativeGen/SPARC/Instr.hs +++ b/compiler/nativeGen/SPARC/Instr.hs @@ -46,6 +46,7 @@ import Size import CLabel import CodeGen.Platform import BlockId +import DynFlags import OldCmm import FastString import FastBool @@ -372,15 +373,16 @@ sparc_patchJumpInstr insn patchF -- | Make a spill instruction. -- On SPARC we spill below frame pointer leaving 2 words/spill sparc_mkSpillInstr - :: Platform + :: DynFlags -> Reg -- ^ register to spill -> Int -- ^ current stack delta -> Int -- ^ spill slot to use -> Instr -sparc_mkSpillInstr platform reg _ slot - = let off = spillSlotToOffset slot - off_w = 1 + (off `div` 4) +sparc_mkSpillInstr dflags reg _ slot + = let platform = targetPlatform dflags + off = spillSlotToOffset dflags slot + off_w = 1 + (off `div` 4) sz = case targetClassOfReg platform reg of RcInteger -> II32 RcFloat -> FF32 @@ -392,14 +394,15 @@ sparc_mkSpillInstr platform reg _ slot -- | Make a spill reload instruction. sparc_mkLoadInstr - :: Platform + :: DynFlags -> Reg -- ^ register to load into -> Int -- ^ current stack delta -> Int -- ^ spill slot to use -> Instr -sparc_mkLoadInstr platform reg _ slot - = let off = spillSlotToOffset slot +sparc_mkLoadInstr dflags reg _ slot + = let platform = targetPlatform dflags + off = spillSlotToOffset dflags slot off_w = 1 + (off `div` 4) sz = case targetClassOfReg platform reg of RcInteger -> II32 diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs index e57e5e2725..55afac0ee2 100644 --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -38,6 +38,7 @@ import PprBase import OldCmm import OldPprCmm() import CLabel +import BlockId import Unique ( Uniquable(..), pprUnique ) import Outputable @@ -52,7 +53,7 @@ pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc pprNatCmmDecl (CmmData section dats) = pprSectionHeader section $$ pprDatas dats -pprNatCmmDecl proc@(CmmProc _ lbl (ListGraph blocks)) = +pprNatCmmDecl proc@(CmmProc top_info lbl (ListGraph blocks)) = case topInfoTable proc of Nothing -> case blocks of @@ -61,19 +62,15 @@ pprNatCmmDecl proc@(CmmProc _ lbl (ListGraph blocks)) = blocks -> -- special case for code without info table: pprSectionHeader Text $$ pprLabel lbl $$ -- blocks guaranteed not null, so label needed - vcat (map pprBasicBlock blocks) + vcat (map (pprBasicBlock top_info) blocks) - Just (Statics info_lbl info) -> + Just (Statics info_lbl _) -> sdocWithPlatform $ \platform -> - pprSectionHeader Text $$ - ( - (if platformHasSubsectionsViaSymbols platform - then ppr (mkDeadStripPreventer info_lbl) <> char ':' - else empty) $$ - vcat (map pprData info) $$ - pprLabel info_lbl - ) $$ - vcat (map pprBasicBlock blocks) $$ + (if platformHasSubsectionsViaSymbols platform + then pprSectionHeader Text $$ + ppr (mkDeadStripPreventer info_lbl) <> char ':' + else empty) $$ + vcat (map (pprBasicBlock top_info) blocks) $$ -- above: Even the first block gets a label, because with branch-chain -- elimination, it might be the target of a goto. (if platformHasSubsectionsViaSymbols platform @@ -91,10 +88,18 @@ pprNatCmmDecl proc@(CmmProc _ lbl (ListGraph blocks)) = else empty) -pprBasicBlock :: NatBasicBlock Instr -> SDoc -pprBasicBlock (BasicBlock blockid instrs) = - pprLabel (mkAsmTempLabel (getUnique blockid)) $$ - vcat (map pprInstr instrs) +pprBasicBlock :: BlockEnv CmmStatics -> NatBasicBlock Instr -> SDoc +pprBasicBlock info_env (BasicBlock blockid instrs) + = maybe_infotable $$ + pprLabel (mkAsmTempLabel (getUnique blockid)) $$ + vcat (map pprInstr instrs) + where + maybe_infotable = case mapLookup blockid info_env of + Nothing -> empty + Just (Statics info_lbl info) -> + pprSectionHeader Text $$ + vcat (map pprData info) $$ + pprLabel info_lbl pprDatas :: CmmStatics -> SDoc @@ -333,7 +338,8 @@ pprSectionHeader seg -- | Pretty print a data item. pprDataItem :: CmmLit -> SDoc pprDataItem lit - = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit) + = sdocWithDynFlags $ \dflags -> + vcat (ppr_item (cmmTypeSize $ cmmLitType dflags lit) lit) where imm = litToImm lit diff --git a/compiler/nativeGen/SPARC/Stack.hs b/compiler/nativeGen/SPARC/Stack.hs index 7f75693889..65dfef0e25 100644 --- a/compiler/nativeGen/SPARC/Stack.hs +++ b/compiler/nativeGen/SPARC/Stack.hs @@ -20,6 +20,7 @@ import SPARC.Regs import SPARC.Base import SPARC.Imm +import DynFlags import Outputable -- | Get an AddrMode relative to the address in sp. @@ -42,15 +43,15 @@ fpRel n -- | Convert a spill slot number to a *byte* offset, with no sign. -- -spillSlotToOffset :: Int -> Int -spillSlotToOffset slot - | slot >= 0 && slot < maxSpillSlots +spillSlotToOffset :: DynFlags -> Int -> Int +spillSlotToOffset dflags slot + | slot >= 0 && slot < maxSpillSlots dflags = 64 + spillSlotSize * slot | otherwise = pprPanic "spillSlotToOffset:" ( text "invalid spill location: " <> int slot - $$ text "maxSpillSlots: " <> int maxSpillSlots) + $$ text "maxSpillSlots: " <> int (maxSpillSlots dflags)) -- | The maximum number of spill slots available on the C stack. @@ -59,7 +60,7 @@ spillSlotToOffset slot -- Why do we reserve 64 bytes, instead of using the whole thing?? -- -- BL 2009/02/15 -- -maxSpillSlots :: Int -maxSpillSlots - = ((spillAreaLength - 64) `div` spillSlotSize) - 1 +maxSpillSlots :: DynFlags -> Int +maxSpillSlots dflags + = ((spillAreaLength dflags - 64) `div` spillSlotSize) - 1 diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index e8f2eccd6b..66ebf75629 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -141,6 +141,7 @@ stmtsToInstrs stmts stmtToInstrs :: CmmStmt -> NatM InstrBlock stmtToInstrs stmt = do + dflags <- getDynFlags is32Bit <- is32BitPlatform case stmt of CmmNop -> return nilOL @@ -150,14 +151,14 @@ stmtToInstrs stmt = do | isFloatType ty -> assignReg_FltCode size reg src | is32Bit && isWord64 ty -> assignReg_I64Code reg src | otherwise -> assignReg_IntCode size reg src - where ty = cmmRegType reg + where ty = cmmRegType dflags reg size = cmmTypeSize ty CmmStore addr src | isFloatType ty -> assignMem_FltCode size addr src | is32Bit && isWord64 ty -> assignMem_I64Code addr src | otherwise -> assignMem_IntCode size addr src - where ty = cmmExprType src + where ty = cmmExprType dflags src size = cmmTypeSize ty CmmCall target result_regs args _ @@ -168,15 +169,15 @@ stmtToInstrs stmt = do CmmSwitch arg ids -> do dflags <- getDynFlags genSwitch dflags arg ids CmmJump arg gregs -> do dflags <- getDynFlags - let platform = targetPlatform dflags - genJump arg (jumpRegs platform gregs) + genJump arg (jumpRegs dflags gregs) CmmReturn -> panic "stmtToInstrs: return statement should have been cps'd away" -jumpRegs :: Platform -> Maybe [GlobalReg] -> [Reg] -jumpRegs platform Nothing = allHaskellArgRegs platform -jumpRegs platform (Just gregs) = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ] +jumpRegs :: DynFlags -> Maybe [GlobalReg] -> [Reg] +jumpRegs dflags Nothing = allHaskellArgRegs dflags +jumpRegs dflags (Just gregs) = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ] + where platform = targetPlatform dflags -------------------------------------------------------------------------------- -- | 'InstrBlock's are the insn sequences generated by the insn selectors. @@ -274,9 +275,9 @@ is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000 -- | Convert a BlockId to some CmmStatic data -jumpTableEntry :: Maybe BlockId -> CmmStatic -jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth) -jumpTableEntry (Just blockid) = CmmStaticLit (CmmLabel blockLabel) +jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic +jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags)) +jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) where blockLabel = mkAsmTempLabel (getUnique blockid) @@ -285,10 +286,10 @@ jumpTableEntry (Just blockid) = CmmStaticLit (CmmLabel blockLabel) -- Expand CmmRegOff. ToDo: should we do it this way around, or convert -- CmmExprs into CmmRegOff? -mangleIndexTree :: CmmReg -> Int -> CmmExpr -mangleIndexTree reg off +mangleIndexTree :: DynFlags -> CmmReg -> Int -> CmmExpr +mangleIndexTree dflags reg off = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] - where width = typeWidth (cmmRegType reg) + where width = typeWidth (cmmRegType dflags reg) -- | The dual to getAnyReg: compute an expression into a register, but -- we don't mind which one it is. @@ -406,12 +407,13 @@ iselExpr64 expr -------------------------------------------------------------------------------- getRegister :: CmmExpr -> NatM Register -getRegister e = do is32Bit <- is32BitPlatform - getRegister' is32Bit e +getRegister e = do dflags <- getDynFlags + is32Bit <- is32BitPlatform + getRegister' dflags is32Bit e -getRegister' :: Bool -> CmmExpr -> NatM Register +getRegister' :: DynFlags -> Bool -> CmmExpr -> NatM Register -getRegister' is32Bit (CmmReg reg) +getRegister' dflags is32Bit (CmmReg reg) = case reg of CmmGlobal PicBaseReg | is32Bit -> @@ -423,44 +425,43 @@ getRegister' is32Bit (CmmReg reg) _ -> do use_sse2 <- sse2Enabled let - sz = cmmTypeSize (cmmRegType reg) + sz = cmmTypeSize (cmmRegType dflags reg) size | not use_sse2 && isFloatSize sz = FF80 | otherwise = sz -- - dflags <- getDynFlags let platform = targetPlatform dflags return (Fixed size (getRegisterReg platform use_sse2 reg) nilOL) -getRegister' is32Bit (CmmRegOff r n) - = getRegister' is32Bit $ mangleIndexTree r n +getRegister' dflags is32Bit (CmmRegOff r n) + = getRegister' dflags is32Bit $ mangleIndexTree dflags r n -- for 32-bit architectuers, support some 64 -> 32 bit conversions: -- TO_W_(x), TO_W_(x >> 32) -getRegister' is32Bit (CmmMachOp (MO_UU_Conv W64 W32) +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) | is32Bit = do ChildCode64 code rlo <- iselExpr64 x return $ Fixed II32 (getHiVRegFromLo rlo) code -getRegister' is32Bit (CmmMachOp (MO_SS_Conv W64 W32) +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) | is32Bit = do ChildCode64 code rlo <- iselExpr64 x return $ Fixed II32 (getHiVRegFromLo rlo) code -getRegister' is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x]) +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x]) | is32Bit = do ChildCode64 code rlo <- iselExpr64 x return $ Fixed II32 rlo code -getRegister' is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x]) +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x]) | is32Bit = do ChildCode64 code rlo <- iselExpr64 x return $ Fixed II32 rlo code -getRegister' _ (CmmLit lit@(CmmFloat f w)) = +getRegister' _ _ (CmmLit lit@(CmmFloat f w)) = if_sse2 float_const_sse2 float_const_x87 where float_const_sse2 @@ -491,60 +492,60 @@ getRegister' _ (CmmLit lit@(CmmFloat f w)) = loadFloatAmode False w addr code -- catch simple cases of zero- or sign-extended load -getRegister' _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _]) = do +getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _]) = do code <- intLoadCode (MOVZxL II8) addr return (Any II32 code) -getRegister' _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _]) = do +getRegister' _ _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _]) = do code <- intLoadCode (MOVSxL II8) addr return (Any II32 code) -getRegister' _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _]) = do +getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _]) = do code <- intLoadCode (MOVZxL II16) addr return (Any II32 code) -getRegister' _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _]) = do +getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _]) = do code <- intLoadCode (MOVSxL II16) addr return (Any II32 code) -- catch simple cases of zero- or sign-extended load -getRegister' is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _]) +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _]) | not is32Bit = do code <- intLoadCode (MOVZxL II8) addr return (Any II64 code) -getRegister' is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _]) +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _]) | not is32Bit = do code <- intLoadCode (MOVSxL II8) addr return (Any II64 code) -getRegister' is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _]) +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _]) | not is32Bit = do code <- intLoadCode (MOVZxL II16) addr return (Any II64 code) -getRegister' is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _]) +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _]) | not is32Bit = do code <- intLoadCode (MOVSxL II16) addr return (Any II64 code) -getRegister' is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _]) +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _]) | not is32Bit = do code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend return (Any II64 code) -getRegister' is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _]) +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _]) | not is32Bit = do code <- intLoadCode (MOVSxL II32) addr return (Any II64 code) -getRegister' is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), +getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), CmmLit displacement]) | not is32Bit = do return $ Any II64 (\dst -> unitOL $ LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst)) -getRegister' is32Bit (CmmMachOp mop [x]) = do -- unary MachOps +getRegister' dflags is32Bit (CmmMachOp mop [x]) = do -- unary MachOps sse2 <- sse2Enabled case mop of MO_F_Neg w @@ -634,11 +635,11 @@ getRegister' is32Bit (CmmMachOp mop [x]) = do -- unary MachOps conversionNop :: Size -> CmmExpr -> NatM Register conversionNop new_size expr - = do e_code <- getRegister' is32Bit expr + = do e_code <- getRegister' dflags is32Bit expr return (swizzleRegisterRep e_code new_size) -getRegister' is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps +getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps sse2 <- sse2Enabled case mop of MO_F_Eq _ -> condFltReg is32Bit EQQ x y @@ -812,14 +813,14 @@ getRegister' is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps return (Fixed size result code) -getRegister' _ (CmmLoad mem pk) +getRegister' _ _ (CmmLoad mem pk) | isFloatType pk = do Amode addr mem_code <- getAmode mem use_sse2 <- sse2Enabled loadFloatAmode use_sse2 (typeWidth pk) addr mem_code -getRegister' is32Bit (CmmLoad mem pk) +getRegister' _ is32Bit (CmmLoad mem pk) | is32Bit && not (isWord64 pk) = do code <- intLoadCode instr mem @@ -837,14 +838,14 @@ getRegister' is32Bit (CmmLoad mem pk) -- simpler we do our 8-bit arithmetic with full 32-bit registers. -- Simpler memory load code on x86_64 -getRegister' is32Bit (CmmLoad mem pk) +getRegister' _ is32Bit (CmmLoad mem pk) | not is32Bit = do code <- intLoadCode (MOV size) mem return (Any size code) where size = intSize $ typeWidth pk -getRegister' is32Bit (CmmLit (CmmInt 0 width)) +getRegister' _ is32Bit (CmmLit (CmmInt 0 width)) = let size = intSize width @@ -861,8 +862,8 @@ getRegister' is32Bit (CmmLit (CmmInt 0 width)) -- optimisation for loading small literals on x86_64: take advantage -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit -- instruction forms are shorter. -getRegister' is32Bit (CmmLit lit) - | not is32Bit, isWord64 (cmmLitType lit), not (isBigLit lit) +getRegister' dflags is32Bit (CmmLit lit) + | not is32Bit, isWord64 (cmmLitType dflags lit), not (isBigLit lit) = let imm = litToImm lit code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst)) @@ -877,15 +878,13 @@ getRegister' is32Bit (CmmLit lit) -- note2: all labels are small, because we're assuming the -- small memory model (see gcc docs, -mcmodel=small). -getRegister' _ (CmmLit lit) - = let - size = cmmTypeSize (cmmLitType lit) - imm = litToImm lit - code dst = unitOL (MOV size (OpImm imm) (OpReg dst)) - in - return (Any size code) +getRegister' dflags _ (CmmLit lit) + = do let size = cmmTypeSize (cmmLitType dflags lit) + imm = litToImm lit + code dst = unitOL (MOV size (OpImm imm) (OpReg dst)) + return (Any size code) -getRegister' _ other = pprPanic "getRegister(x86)" (ppr other) +getRegister' _ _ other = pprPanic "getRegister(x86)" (ppr other) intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr @@ -958,7 +957,8 @@ getAmode e = do is32Bit <- is32BitPlatform getAmode' is32Bit e getAmode' :: Bool -> CmmExpr -> NatM Amode -getAmode' _ (CmmRegOff r n) = getAmode $ mangleIndexTree r n +getAmode' _ (CmmRegOff r n) = do dflags <- getDynFlags + getAmode $ mangleIndexTree dflags r n getAmode' is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), CmmLit displacement]) @@ -1047,7 +1047,8 @@ getNonClobberedOperand (CmmLit lit) = do else do is32Bit <- is32BitPlatform - if is32BitLit is32Bit lit && not (isFloatType (cmmLitType lit)) + dflags <- getDynFlags + if is32BitLit is32Bit lit && not (isFloatType (cmmLitType dflags lit)) then return (OpImm (litToImm lit), nilOL) else getNonClobberedOperand_generic (CmmLit lit) @@ -1100,7 +1101,8 @@ getOperand (CmmLit lit) = do else do is32Bit <- is32BitPlatform - if is32BitLit is32Bit lit && not (isFloatType (cmmLitType lit)) + dflags <- getDynFlags + if is32BitLit is32Bit lit && not (isFloatType (cmmLitType dflags lit)) then return (OpImm (litToImm lit), nilOL) else getOperand_generic (CmmLit lit) @@ -1276,21 +1278,23 @@ condIntCode' _ cond x (CmmLit (CmmInt 0 pk)) = do -- anything vs operand condIntCode' is32Bit cond x y | isOperand is32Bit y = do + dflags <- getDynFlags (x_reg, x_code) <- getNonClobberedReg x (y_op, y_code) <- getOperand y let code = x_code `appOL` y_code `snocOL` - CMP (cmmTypeSize (cmmExprType x)) y_op (OpReg x_reg) + CMP (cmmTypeSize (cmmExprType dflags x)) y_op (OpReg x_reg) return (CondCode False cond code) -- anything vs anything condIntCode' _ cond x y = do + dflags <- getDynFlags (y_reg, y_code) <- getNonClobberedReg y (x_op, x_code) <- getRegOrMem x let code = y_code `appOL` x_code `snocOL` - CMP (cmmTypeSize (cmmExprType x)) (OpReg y_reg) x_op + CMP (cmmTypeSize (cmmExprType dflags x)) (OpReg y_reg) x_op return (CondCode False cond code) @@ -1317,12 +1321,13 @@ condFltCode cond x y -- an operand, but the right must be a reg. We can probably do better -- than this general case... condFltCode_sse2 = do + dflags <- getDynFlags (x_reg, x_code) <- getNonClobberedReg x (y_op, y_code) <- getOperand y let code = x_code `appOL` y_code `snocOL` - CMP (floatSize $ cmmExprWidth x) y_op (OpReg x_reg) + CMP (floatSize $ cmmExprWidth dflags x) y_op (OpReg x_reg) -- NB(1): we need to use the unsigned comparison operators on the -- result of this comparison. return (CondCode True (condToUnsigned cond) code) @@ -1713,7 +1718,7 @@ genCCall32 target dest_regs args = do (CmmPrim _ (Just stmts), _) -> stmtsToInstrs stmts - _ -> genCCall32' target dest_regs args + _ -> genCCall32' dflags target dest_regs args where divOp1 platform signed width results [CmmHinted arg_x _, CmmHinted arg_y _] = divOp platform signed width results Nothing arg_x arg_y @@ -1750,16 +1755,17 @@ genCCall32 target dest_regs args = do divOp _ _ _ _ _ _ _ = panic "genCCall32: Wrong number of results for divOp" -genCCall32' :: CmmCallTarget -- function to call +genCCall32' :: DynFlags + -> CmmCallTarget -- function to call -> [HintedCmmFormal] -- where to put the result -> [HintedCmmActual] -- arguments (of mixed type) -> NatM InstrBlock -genCCall32' target dest_regs args = do +genCCall32' dflags target dest_regs args = do let -- Align stack to 16n for calls, assuming a starting stack -- alignment of 16n - word_size on procedure entry. Which we -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86] - sizes = map (arg_size . cmmExprType . hintlessCmm) (reverse args) + sizes = map (arg_size . cmmExprType dflags . hintlessCmm) (reverse args) raw_arg_size = sum sizes + wORD_SIZE arg_pad_size = (roundTo 16 $ raw_arg_size) - raw_arg_size tot_arg_size = raw_arg_size + arg_pad_size - wORD_SIZE @@ -1780,7 +1786,7 @@ genCCall32' target dest_regs args = do where fn_imm = ImmCLbl lbl CmmCallee expr conv -> do { (dyn_r, dyn_c) <- getSomeReg expr - ; ASSERT( isWord32 (cmmExprType expr) ) + ; ASSERT( isWord32 (cmmExprType dflags expr) ) return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) } CmmPrim _ _ -> panic $ "genCCall: Can't handle CmmPrim call type here, error " @@ -1896,7 +1902,7 @@ genCCall32' target dest_regs args = do DELTA (delta-size)) where - arg_ty = cmmExprType arg + arg_ty = cmmExprType dflags arg size = arg_size arg_ty -- Byte size genCCall64 :: CmmCallTarget -- function to call @@ -1953,8 +1959,7 @@ genCCall64 target dest_regs args = do _ -> do dflags <- getDynFlags - let platform = targetPlatform dflags - genCCall64' platform target dest_regs args + genCCall64' dflags target dest_regs args where divOp1 platform signed width results [CmmHinted arg_x _, CmmHinted arg_y _] = divOp platform signed width results Nothing arg_x arg_y @@ -1989,12 +1994,12 @@ genCCall64 target dest_regs args = do divOp _ _ _ _ _ _ _ = panic "genCCall64: Wrong number of results for divOp" -genCCall64' :: Platform +genCCall64' :: DynFlags -> CmmCallTarget -- function to call -> [HintedCmmFormal] -- where to put the result -> [HintedCmmActual] -- arguments (of mixed type) -> NatM InstrBlock -genCCall64' platform target dest_regs args = do +genCCall64' dflags target dest_regs args = do -- load up the register arguments (stack_args, int_regs_used, fp_regs_used, load_args_code) <- @@ -2070,7 +2075,7 @@ genCCall64' platform target dest_regs args = do -- stdcall has callee do it, but is not supported on -- x86_64 target (see #3336) (if real_size==0 then [] else - [ADD (intSize wordWidth) (OpImm (ImmInt real_size)) (OpReg esp)]) + [ADD (intSize (wordWidth dflags)) (OpImm (ImmInt real_size)) (OpReg esp)]) ++ [DELTA (delta + real_size)] ) @@ -2097,7 +2102,8 @@ genCCall64' platform target dest_regs args = do call `appOL` assign_code dest_regs) - where arg_size = 8 -- always, at the mo + where platform = targetPlatform dflags + arg_size = 8 -- always, at the mo load_args :: [CmmHinted CmmExpr] -> [Reg] -- int regs avail for args @@ -2122,7 +2128,7 @@ genCCall64' platform target dest_regs args = do arg_code <- getAnyReg arg load_args rest rs fregs (code `appOL` arg_code r) where - arg_rep = cmmExprType arg + arg_rep = cmmExprType dflags arg push_this_arg = do (args',ars,frs,code') <- load_args rest aregs fregs code @@ -2156,7 +2162,7 @@ genCCall64' platform target dest_regs args = do load_args_win rest (ireg : usedInt) usedFP regs (code `appOL` arg_code ireg) where - arg_rep = cmmExprType arg + arg_rep = cmmExprType dflags arg push_args [] code = return code push_args ((CmmHinted arg _):rest) code @@ -2165,7 +2171,7 @@ genCCall64' platform target dest_regs args = do delta <- getDeltaNat setDeltaNat (delta-arg_size) let code' = code `appOL` arg_code `appOL` toOL [ - SUB (intSize wordWidth) (OpImm (ImmInt arg_size)) (OpReg rsp) , + SUB (intSize (wordWidth dflags)) (OpImm (ImmInt arg_size)) (OpReg rsp) , DELTA (delta-arg_size), MOV (floatSize width) (OpReg arg_reg) (OpAddr (spRel platform 0))] push_args rest code' @@ -2183,7 +2189,7 @@ genCCall64' platform target dest_regs args = do DELTA (delta-arg_size)] push_args rest code' where - arg_rep = cmmExprType arg + arg_rep = cmmExprType dflags arg width = typeWidth arg_rep leaveStackSpace n = do @@ -2286,7 +2292,7 @@ genSwitch dflags expr ids return $ if target32Bit (targetPlatform dflags) then e_code `appOL` t_code `appOL` toOL [ - ADD (intSize wordWidth) op (OpReg tableReg), + ADD (intSize (wordWidth dflags)) op (OpReg tableReg), JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl ] else case platformOS (targetPlatform dflags) of @@ -2299,7 +2305,7 @@ genSwitch dflags expr ids -- if L0 is not preceded by a non-anonymous -- label in its section. e_code `appOL` t_code `appOL` toOL [ - ADD (intSize wordWidth) op (OpReg tableReg), + ADD (intSize (wordWidth dflags)) op (OpReg tableReg), JMP_TBL (OpReg tableReg) ids Text lbl ] _ -> @@ -2313,7 +2319,7 @@ genSwitch dflags expr ids -- once binutils 2.17 is standard. e_code `appOL` t_code `appOL` toOL [ MOVSxL II32 op (OpReg reg), - ADD (intSize wordWidth) (OpReg reg) (OpReg tableReg), + ADD (intSize (wordWidth dflags)) (OpReg reg) (OpReg tableReg), JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl ] | otherwise @@ -2337,12 +2343,12 @@ createJumpTable dflags ids section lbl = let jumpTable | dopt Opt_PIC dflags = let jumpTableEntryRel Nothing - = CmmStaticLit (CmmInt 0 wordWidth) + = CmmStaticLit (CmmInt 0 (wordWidth dflags)) jumpTableEntryRel (Just blockid) = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) where blockLabel = mkAsmTempLabel (getUnique blockid) in map jumpTableEntryRel ids - | otherwise = map jumpTableEntry ids + | otherwise = map (jumpTableEntry dflags) ids in CmmData section (1, Statics lbl jumpTable) -- ----------------------------------------------------------------------------- diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index a2263b3116..50f5b4c874 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -30,10 +30,10 @@ import FastString import FastBool import Outputable import Platform -import Constants (rESERVED_C_STACK_BYTES) import BasicTypes (Alignment) import CLabel +import DynFlags import UniqSet import Unique @@ -613,14 +613,14 @@ x86_patchJumpInstr insn patchF -- ----------------------------------------------------------------------------- -- | Make a spill instruction. x86_mkSpillInstr - :: Platform + :: DynFlags -> Reg -- register to spill -> Int -- current stack delta -> Int -- spill slot to use -> Instr -x86_mkSpillInstr platform reg delta slot - = let off = spillSlotToOffset is32Bit slot +x86_mkSpillInstr dflags reg delta slot + = let off = spillSlotToOffset dflags slot in let off_w = (off - delta) `div` (if is32Bit then 4 else 8) in case targetClassOfReg platform reg of @@ -629,18 +629,19 @@ x86_mkSpillInstr platform reg delta slot RcDouble -> GST FF80 reg (spRel platform off_w) {- RcFloat/RcDouble -} RcDoubleSSE -> MOV FF64 (OpReg reg) (OpAddr (spRel platform off_w)) _ -> panic "X86.mkSpillInstr: no match" - where is32Bit = target32Bit platform + where platform = targetPlatform dflags + is32Bit = target32Bit platform -- | Make a spill reload instruction. x86_mkLoadInstr - :: Platform + :: DynFlags -> Reg -- register to load -> Int -- current stack delta -> Int -- spill slot to use -> Instr -x86_mkLoadInstr platform reg delta slot - = let off = spillSlotToOffset is32Bit slot +x86_mkLoadInstr dflags reg delta slot + = let off = spillSlotToOffset dflags slot in let off_w = (off-delta) `div` (if is32Bit then 4 else 8) in case targetClassOfReg platform reg of @@ -649,26 +650,28 @@ x86_mkLoadInstr platform reg delta slot RcDouble -> GLD FF80 (spRel platform off_w) reg {- RcFloat/RcDouble -} RcDoubleSSE -> MOV FF64 (OpAddr (spRel platform off_w)) (OpReg reg) _ -> panic "X86.x86_mkLoadInstr" - where is32Bit = target32Bit platform + where platform = targetPlatform dflags + is32Bit = target32Bit platform -spillSlotSize :: Bool -> Int -spillSlotSize is32Bit = if is32Bit then 12 else 8 +spillSlotSize :: DynFlags -> Int +spillSlotSize dflags = if is32Bit then 12 else 8 + where is32Bit = target32Bit (targetPlatform dflags) -maxSpillSlots :: Bool -> Int -maxSpillSlots is32Bit - = ((rESERVED_C_STACK_BYTES - 64) `div` spillSlotSize is32Bit) - 1 +maxSpillSlots :: DynFlags -> Int +maxSpillSlots dflags + = ((rESERVED_C_STACK_BYTES dflags - 64) `div` spillSlotSize dflags) - 1 -- convert a spill slot number to a *byte* offset, with no sign: -- decide on a per arch basis whether you are spilling above or below -- the C stack pointer. -spillSlotToOffset :: Bool -> Int -> Int -spillSlotToOffset is32Bit slot - | slot >= 0 && slot < maxSpillSlots is32Bit - = 64 + spillSlotSize is32Bit * slot +spillSlotToOffset :: DynFlags -> Int -> Int +spillSlotToOffset dflags slot + | slot >= 0 && slot < maxSpillSlots dflags + = 64 + spillSlotSize dflags * slot | otherwise = pprPanic "spillSlotToOffset:" ( text "invalid spill location: " <> int slot - $$ text "maxSpillSlots: " <> int (maxSpillSlots is32Bit)) + $$ text "maxSpillSlots: " <> int (maxSpillSlots dflags)) -------------------------------------------------------------------------------- diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index 6411fb94b1..420da7cc3d 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -34,6 +34,7 @@ import PprBase import BlockId import BasicTypes (Alignment) +import DynFlags import OldCmm import CLabel import Unique ( pprUnique, Uniquable(..) ) @@ -419,12 +420,13 @@ pprSectionHeader seg pprDataItem :: CmmLit -> SDoc -pprDataItem lit = sdocWithPlatform $ \platform -> pprDataItem' platform lit +pprDataItem lit = sdocWithDynFlags $ \dflags -> pprDataItem' dflags lit -pprDataItem' :: Platform -> CmmLit -> SDoc -pprDataItem' platform lit - = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit) +pprDataItem' :: DynFlags -> CmmLit -> SDoc +pprDataItem' dflags lit + = vcat (ppr_item (cmmTypeSize $ cmmLitType dflags lit) lit) where + platform = targetPlatform dflags imm = litToImm lit -- These seem to be common: diff --git a/compiler/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs index 16938a8f15..c88ea98425 100644 --- a/compiler/nativeGen/X86/Regs.hs +++ b/compiler/nativeGen/X86/Regs.hs @@ -54,6 +54,7 @@ import RegClass import OldCmm import CmmCallConv import CLabel ( CLabel ) +import DynFlags import Outputable import Platform import FastTypes @@ -440,8 +441,9 @@ instrClobberedRegs platform -- -- All machine registers that are used for argument-passing to Haskell functions -allHaskellArgRegs :: Platform -> [Reg] -allHaskellArgRegs platform = [ RegReal r | Just r <- map (globalRegMaybe platform) globalArgRegs ] +allHaskellArgRegs :: DynFlags -> [Reg] +allHaskellArgRegs dflags = [ RegReal r | Just r <- map (globalRegMaybe platform) (globalArgRegs dflags) ] + where platform = targetPlatform dflags -- allocatableRegs is allMachRegNos with the fixed-use regs removed. -- i.e., these are the regs for which we are prepared to allow the diff --git a/compiler/simplStg/SRT.lhs b/compiler/simplStg/SRT.lhs index 0d474c5b63..92cfad3283 100644 --- a/compiler/simplStg/SRT.lhs +++ b/compiler/simplStg/SRT.lhs @@ -18,34 +18,35 @@ import VarEnv import Maybes ( orElse, expectJust ) import Bitmap +import DynFlags import Outputable import Data.List \end{code} \begin{code} -computeSRTs :: [StgBinding] -> [(StgBinding,[(Id,[Id])])] +computeSRTs :: DynFlags -> [StgBinding] -> [(StgBinding,[(Id,[Id])])] -- The incoming bindingd are filled with SRTEntries in their SRT slots -- the outgoing ones have NoSRT/SRT values instead -computeSRTs binds = srtTopBinds emptyVarEnv binds +computeSRTs dflags binds = srtTopBinds dflags emptyVarEnv binds -- -------------------------------------------------------------------------- -- Top-level Bindings -srtTopBinds :: IdEnv Id -> [StgBinding] -> [(StgBinding, [(Id,[Id])])] +srtTopBinds :: DynFlags -> IdEnv Id -> [StgBinding] -> [(StgBinding, [(Id,[Id])])] -srtTopBinds _ [] = [] -srtTopBinds env (StgNonRec b rhs : binds) = - (StgNonRec b rhs', [(b,srt')]) : srtTopBinds env' binds +srtTopBinds _ _ [] = [] +srtTopBinds dflags env (StgNonRec b rhs : binds) = + (StgNonRec b rhs', [(b,srt')]) : srtTopBinds dflags env' binds where - (rhs', srt) = srtTopRhs b rhs + (rhs', srt) = srtTopRhs dflags b rhs env' = maybeExtendEnv env b rhs srt' = applyEnvList env srt -srtTopBinds env (StgRec bs : binds) = - (StgRec (zip bndrs rhss), zip bndrs srts') : srtTopBinds env binds +srtTopBinds dflags env (StgRec bs : binds) = + (StgRec (zip bndrs rhss), zip bndrs srts') : srtTopBinds dflags env binds where - (rhss, srts) = unzip [ srtTopRhs b r | (b,r) <- bs ] + (rhss, srts) = unzip [ srtTopRhs dflags b r | (b,r) <- bs ] bndrs = map fst bs srts' = map (applyEnvList env) srts @@ -74,75 +75,75 @@ applyEnv env id = lookupVarEnv env id `orElse` id -- ---- Top-level right hand sides: -srtTopRhs :: Id -> StgRhs -> (StgRhs, [Id]) +srtTopRhs :: DynFlags -> Id -> StgRhs -> (StgRhs, [Id]) -srtTopRhs _ rhs@(StgRhsCon _ _ _) = (rhs, []) -srtTopRhs _ rhs@(StgRhsClosure _ _ _ _ (SRTEntries cafs) _ _) - = (srtRhs table rhs, elems) +srtTopRhs _ _ rhs@(StgRhsCon _ _ _) = (rhs, []) +srtTopRhs dflags _ rhs@(StgRhsClosure _ _ _ _ (SRTEntries cafs) _ _) + = (srtRhs dflags table rhs, elems) where elems = varSetElems cafs table = mkVarEnv (zip elems [0..]) -srtTopRhs _ (StgRhsClosure _ _ _ _ NoSRT _ _) = panic "srtTopRhs NoSRT" -srtTopRhs _ (StgRhsClosure _ _ _ _ (SRT _ _ _) _ _) = panic "srtTopRhs SRT" +srtTopRhs _ _ (StgRhsClosure _ _ _ _ NoSRT _ _) = panic "srtTopRhs NoSRT" +srtTopRhs _ _ (StgRhsClosure _ _ _ _ (SRT _ _ _) _ _) = panic "srtTopRhs SRT" -- ---- Binds: -srtBind :: IdEnv Int -> StgBinding -> StgBinding +srtBind :: DynFlags -> IdEnv Int -> StgBinding -> StgBinding -srtBind table (StgNonRec binder rhs) = StgNonRec binder (srtRhs table rhs) -srtBind table (StgRec pairs) = StgRec [ (b, srtRhs table r) | (b,r) <- pairs ] +srtBind dflags table (StgNonRec binder rhs) = StgNonRec binder (srtRhs dflags table rhs) +srtBind dflags table (StgRec pairs) = StgRec [ (b, srtRhs dflags table r) | (b,r) <- pairs ] -- ---- Right Hand Sides: -srtRhs :: IdEnv Int -> StgRhs -> StgRhs +srtRhs :: DynFlags -> IdEnv Int -> StgRhs -> StgRhs -srtRhs _ e@(StgRhsCon _ _ _) = e -srtRhs table (StgRhsClosure cc bi free_vars u srt args body) - = StgRhsClosure cc bi free_vars u (constructSRT table srt) args - $! (srtExpr table body) +srtRhs _ _ e@(StgRhsCon _ _ _) = e +srtRhs dflags table (StgRhsClosure cc bi free_vars u srt args body) + = StgRhsClosure cc bi free_vars u (constructSRT dflags table srt) args + $! (srtExpr dflags table body) -- --------------------------------------------------------------------------- -- Expressions -srtExpr :: IdEnv Int -> StgExpr -> StgExpr +srtExpr :: DynFlags -> IdEnv Int -> StgExpr -> StgExpr -srtExpr _ e@(StgApp _ _) = e -srtExpr _ e@(StgLit _) = e -srtExpr _ e@(StgConApp _ _) = e -srtExpr _ e@(StgOpApp _ _ _) = e +srtExpr _ _ e@(StgApp _ _) = e +srtExpr _ _ e@(StgLit _) = e +srtExpr _ _ e@(StgConApp _ _) = e +srtExpr _ _ e@(StgOpApp _ _ _) = e -srtExpr table (StgSCC cc tick push expr) = StgSCC cc tick push $! srtExpr table expr +srtExpr dflags table (StgSCC cc tick push expr) = StgSCC cc tick push $! srtExpr dflags table expr -srtExpr table (StgTick m n expr) = StgTick m n $! srtExpr table expr +srtExpr dflags table (StgTick m n expr) = StgTick m n $! srtExpr dflags table expr -srtExpr table (StgCase scrut live1 live2 uniq srt alt_type alts) +srtExpr dflags table (StgCase scrut live1 live2 uniq srt alt_type alts) = StgCase expr' live1 live2 uniq srt' alt_type alts' where - expr' = srtExpr table scrut - srt' = constructSRT table srt - alts' = map (srtAlt table) alts + expr' = srtExpr dflags table scrut + srt' = constructSRT dflags table srt + alts' = map (srtAlt dflags table) alts -srtExpr table (StgLet bind body) - = srtBind table bind =: \ bind' -> - srtExpr table body =: \ body' -> +srtExpr dflags table (StgLet bind body) + = srtBind dflags table bind =: \ bind' -> + srtExpr dflags table body =: \ body' -> StgLet bind' body' -srtExpr table (StgLetNoEscape live1 live2 bind body) - = srtBind table bind =: \ bind' -> - srtExpr table body =: \ body' -> +srtExpr dflags table (StgLetNoEscape live1 live2 bind body) + = srtBind dflags table bind =: \ bind' -> + srtExpr dflags table body =: \ body' -> StgLetNoEscape live1 live2 bind' body' -srtExpr _table expr = pprPanic "srtExpr" (ppr expr) +srtExpr _ _table expr = pprPanic "srtExpr" (ppr expr) -srtAlt :: IdEnv Int -> StgAlt -> StgAlt -srtAlt table (con,args,used,rhs) - = (,,,) con args used $! srtExpr table rhs +srtAlt :: DynFlags -> IdEnv Int -> StgAlt -> StgAlt +srtAlt dflags table (con,args,used,rhs) + = (,,,) con args used $! srtExpr dflags table rhs ----------------------------------------------------------------------------- -- Construct an SRT bitmap. -constructSRT :: IdEnv Int -> SRT -> SRT -constructSRT table (SRTEntries entries) +constructSRT :: DynFlags -> IdEnv Int -> SRT -> SRT +constructSRT dflags table (SRTEntries entries) | isEmptyVarSet entries = NoSRT | otherwise = seqBitmap bitmap $ SRT offset len bitmap where @@ -152,9 +153,9 @@ constructSRT table (SRTEntries entries) offset = head sorted_ints bitmap_entries = map (subtract offset) sorted_ints len = last bitmap_entries + 1 - bitmap = intsToBitmap len bitmap_entries -constructSRT _ NoSRT = panic "constructSRT NoSRT" -constructSRT _ (SRT {}) = panic "constructSRT SRT" + bitmap = intsToBitmap dflags len bitmap_entries +constructSRT _ _ NoSRT = panic "constructSRT NoSRT" +constructSRT _ _ (SRT {}) = panic "constructSRT SRT" -- --------------------------------------------------------------------------- -- Misc stuff diff --git a/compiler/simplStg/SimplStg.lhs b/compiler/simplStg/SimplStg.lhs index 635df3ce41..129d8c6423 100644 --- a/compiler/simplStg/SimplStg.lhs +++ b/compiler/simplStg/SimplStg.lhs @@ -58,7 +58,7 @@ stg2stg dflags module_name binds ; let un_binds = unarise us1 processed_binds ; let srt_binds | dopt Opt_TryNewCodeGen dflags = zip un_binds (repeat []) - | otherwise = computeSRTs un_binds + | otherwise = computeSRTs dflags un_binds ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" (pprStgBindingsWithSRTs srt_binds) diff --git a/compiler/utils/Platform.hs b/compiler/utils/Platform.hs index b53ece9182..a562b4f6f9 100644 --- a/compiler/utils/Platform.hs +++ b/compiler/utils/Platform.hs @@ -65,6 +65,7 @@ data OS | OSNetBSD | OSKFreeBSD | OSHaiku + | OSOsf3 deriving (Read, Show, Eq) -- | ARM Instruction Set Architecture, Extensions and ABI @@ -104,8 +105,11 @@ osElfTarget OSDarwin = False osElfTarget OSMinGW32 = False osElfTarget OSKFreeBSD = True osElfTarget OSHaiku = True +osElfTarget OSOsf3 = False -- I don't know if this is right, but as + -- per comment below it's safe osElfTarget OSUnknown = False -- Defaulting to False is safe; it means don't rely on any -- ELF-specific functionality. It is important to have a default for -- portability, otherwise we have to answer this question for every -- new platform we compile on (even unreg). + diff --git a/ghc/ghc-bin.cabal.in b/ghc/ghc-bin.cabal.in index a7e7bbae66..40dc8581b1 100644 --- a/ghc/ghc-bin.cabal.in +++ b/ghc/ghc-bin.cabal.in @@ -28,7 +28,7 @@ Executable ghc Build-Depends: base >= 3 && < 5, array >= 0.1 && < 0.5, bytestring >= 0.9 && < 0.11, - directory >= 1 && < 1.2, + directory >= 1 && < 1.3, process >= 1 && < 1.2, filepath >= 1 && < 1.4, ghc diff --git a/ghc/ghc.mk b/ghc/ghc.mk index c45e28891a..e1545033be 100644 --- a/ghc/ghc.mk +++ b/ghc/ghc.mk @@ -127,12 +127,19 @@ all_ghc_stage3 : $(GHC_STAGE3) $(INPLACE_LIB)/settings : settings "$(CP)" $< $@ +$(INPLACE_LIB)/platformConstants: $(includes_GHCCONSTANTS_HASKELL_VALUE) + "$(CP)" $< $@ + # The GHC programs need to depend on all the helper programs they might call, # and the settings files they use -$(GHC_STAGE1) : | $(UNLIT) $(INPLACE_LIB)/settings -$(GHC_STAGE2) : | $(UNLIT) $(INPLACE_LIB)/settings -$(GHC_STAGE3) : | $(UNLIT) $(INPLACE_LIB)/settings +GHC_DEPENDENCIES += $(UNLIT) +GHC_DEPENDENCIES += $(INPLACE_LIB)/settings +GHC_DEPENDENCIES += $(INPLACE_LIB)/platformConstants + +$(GHC_STAGE1) : | $(GHC_DEPENDENCIES) +$(GHC_STAGE2) : | $(GHC_DEPENDENCIES) +$(GHC_STAGE3) : | $(GHC_DEPENDENCIES) ifeq "$(GhcUnregisterised)" "NO" $(GHC_STAGE1) : | $(SPLIT) diff --git a/ghc/hschooks.c b/ghc/hschooks.c index b8a720b209..4e6e66d3e2 100644 --- a/ghc/hschooks.c +++ b/ghc/hschooks.c @@ -40,7 +40,7 @@ defaultsHook (void) } void -StackOverflowHook (lnat stack_size) /* in bytes */ +StackOverflowHook (StgWord stack_size) /* in bytes */ { fprintf(stderr, "GHC stack-space overflow: current limit is %zu bytes.\nUse the `-K<size>' option to increase it.\n", (size_t)stack_size); } diff --git a/includes/HaskellConstants.hs b/includes/HaskellConstants.hs index 1cf6de5d19..33108f2eb7 100644 --- a/includes/HaskellConstants.hs +++ b/includes/HaskellConstants.hs @@ -34,76 +34,6 @@ mAX_CONTEXT_REDUCTION_DEPTH :: Int mAX_CONTEXT_REDUCTION_DEPTH = 200 -- Increase to 200; see Trac #5395 --- specialised fun/thunk/constr closure types -mAX_SPEC_THUNK_SIZE :: Int -mAX_SPEC_THUNK_SIZE = MAX_SPEC_THUNK_SIZE - -mAX_SPEC_FUN_SIZE :: Int -mAX_SPEC_FUN_SIZE = MAX_SPEC_FUN_SIZE - -mAX_SPEC_CONSTR_SIZE :: Int -mAX_SPEC_CONSTR_SIZE = MAX_SPEC_CONSTR_SIZE - --- pre-compiled thunk types -mAX_SPEC_SELECTEE_SIZE :: Int -mAX_SPEC_SELECTEE_SIZE = MAX_SPEC_SELECTEE_SIZE - -mAX_SPEC_AP_SIZE :: Int -mAX_SPEC_AP_SIZE = MAX_SPEC_AP_SIZE - --- closure sizes: these do NOT include the header (see below for header sizes) -mIN_PAYLOAD_SIZE ::Int -mIN_PAYLOAD_SIZE = MIN_PAYLOAD_SIZE - -mIN_INTLIKE, mAX_INTLIKE :: Int -mIN_INTLIKE = MIN_INTLIKE -mAX_INTLIKE = MAX_INTLIKE - -mIN_CHARLIKE, mAX_CHARLIKE :: Int -mIN_CHARLIKE = MIN_CHARLIKE -mAX_CHARLIKE = MAX_CHARLIKE - -mUT_ARR_PTRS_CARD_BITS :: Int -mUT_ARR_PTRS_CARD_BITS = MUT_ARR_PTRS_CARD_BITS - --- A section of code-generator-related MAGIC CONSTANTS. - -mAX_Vanilla_REG :: Int -mAX_Vanilla_REG = MAX_VANILLA_REG - -mAX_Float_REG :: Int -mAX_Float_REG = MAX_FLOAT_REG - -mAX_Double_REG :: Int -mAX_Double_REG = MAX_DOUBLE_REG - -mAX_Long_REG :: Int -mAX_Long_REG = MAX_LONG_REG - -mAX_Real_Vanilla_REG :: Int -mAX_Real_Vanilla_REG = MAX_REAL_VANILLA_REG - -mAX_Real_Float_REG :: Int -mAX_Real_Float_REG = MAX_REAL_FLOAT_REG - -mAX_Real_Double_REG :: Int -mAX_Real_Double_REG = MAX_REAL_DOUBLE_REG - -mAX_Real_Long_REG :: Int -#ifdef MAX_REAL_LONG_REG -mAX_Real_Long_REG = MAX_REAL_LONG_REG -#else -mAX_Real_Long_REG = 0 -#endif - --- Closure header sizes. - -sTD_HDR_SIZE :: Int -sTD_HDR_SIZE = STD_HDR_SIZE - -pROF_HDR_SIZE :: Int -pROF_HDR_SIZE = PROF_HDR_SIZE - -- Size of a double in StgWords. dOUBLE_SIZE :: Int @@ -112,35 +42,11 @@ dOUBLE_SIZE = SIZEOF_DOUBLE wORD64_SIZE :: Int wORD64_SIZE = 8 -iNT64_SIZE :: Int -iNT64_SIZE = wORD64_SIZE - --- This tells the native code generator the size of the spill --- area is has available. - -rESERVED_C_STACK_BYTES :: Int -rESERVED_C_STACK_BYTES = RESERVED_C_STACK_BYTES - --- The amount of (Haskell) stack to leave free for saving registers when --- returning to the scheduler. - -rESERVED_STACK_WORDS :: Int -rESERVED_STACK_WORDS = RESERVED_STACK_WORDS - --- Continuations that need more than this amount of stack should do their --- own stack check (see bug #1466). - -aP_STACK_SPLIM :: Int -aP_STACK_SPLIM = AP_STACK_SPLIM - -- Size of a word, in bytes wORD_SIZE :: Int wORD_SIZE = SIZEOF_HSWORD -wORD_SIZE_IN_BITS :: Int -wORD_SIZE_IN_BITS = wORD_SIZE * 8 - -- Define a fixed-range integral type equivalent to the target Int/Word #if SIZEOF_HSWORD == 4 @@ -183,25 +89,8 @@ cLONG_SIZE = SIZEOF_LONG cLONG_LONG_SIZE :: Int cLONG_LONG_SIZE = SIZEOF_LONG_LONG --- Size of a storage manager block (in bytes). - -bLOCK_SIZE :: Int -bLOCK_SIZE = BLOCK_SIZE -bLOCK_SIZE_W :: Int -bLOCK_SIZE_W = bLOCK_SIZE `quot` wORD_SIZE - --- blocks that fit in an MBlock, leaving space for the block descriptors - -bLOCKS_PER_MBLOCK :: Int -bLOCKS_PER_MBLOCK = BLOCKS_PER_MBLOCK - -- Number of bits to shift a bitfield left by in an info table. bITMAP_BITS_SHIFT :: Int bITMAP_BITS_SHIFT = BITMAP_BITS_SHIFT --- Constants derived from headers in ghc/includes, generated by the program --- ../includes/mkDerivedConstants.c. - -#include "../includes/dist-ghcconstants/header/GHCConstants.h" - diff --git a/includes/ghc.mk b/includes/ghc.mk index 2cf835de80..065dd0a60b 100644 --- a/includes/ghc.mk +++ b/includes/ghc.mk @@ -131,6 +131,12 @@ endif # Make DerivedConstants.h for the compiler includes_DERIVEDCONSTANTS = includes/dist-derivedconstants/header/DerivedConstants.h +includes_GHCCONSTANTS_HASKELL_TYPE = includes/dist-derivedconstants/header/GHCConstantsHaskellType.hs +includes_GHCCONSTANTS_HASKELL_VALUE = includes/dist-derivedconstants/header/platformConstants +includes_GHCCONSTANTS_HASKELL_WRAPPERS = includes/dist-derivedconstants/header/GHCConstantsHaskellWrappers.hs +includes_GHCCONSTANTS_HASKELL_EXPORTS = includes/dist-derivedconstants/header/GHCConstantsHaskellExports.hs + +INSTALL_LIBS += includes/dist-derivedconstants/header/platformConstants ifeq "$(PORTING_HOST)-$(AlienScript)" "YES-" @@ -160,44 +166,33 @@ ifeq "$(AlienScript)" "" else $(AlienScript) run ./$< >$@ endif -endif +$(includes_GHCCONSTANTS_HASKELL_TYPE) : $(INPLACE_BIN)/mkDerivedConstants$(exeext) | $$(dir $$@)/. +ifeq "$(AlienScript)" "" + ./$< --gen-haskell-type >$@ +else + $(AlienScript) run ./$< --gen-haskell-type >$@ endif -# ----------------------------------------------------------------------------- -# - -includes_GHCCONSTANTS = includes/dist-ghcconstants/header/GHCConstants.h - -ifeq "$(PORTING_HOST)-$(AlienScript)" "YES-" - -$(includes_GHCCONSTANTS) : - @echo "*** Cross-compiling: please copy DerivedConstants.h from the target system" - @exit 1 - +$(includes_GHCCONSTANTS_HASKELL_VALUE) : $(INPLACE_BIN)/mkDerivedConstants$(exeext) | $$(dir $$@)/. +ifeq "$(AlienScript)" "" + ./$< --gen-haskell-value >$@ else + $(AlienScript) run ./$< --gen-haskell-value >$@ +endif -includes_dist-ghcconstants_C_SRCS = mkDerivedConstants.c -includes_dist-ghcconstants_PROG = mkGHCConstants$(exeext) -includes_dist-ghcconstants_CC_OPTS = -DGEN_HASKELL - -$(eval $(call build-prog,includes,dist-ghcconstants,0)) - -ifneq "$(BINDIST)" "YES" -$(includes_dist-ghcconstants_depfile_c_asm) : $(includes_H_CONFIG) $(includes_H_PLATFORM) $(includes_H_FILES) $$(rts_H_FILES) - -includes/dist-ghcconstants/build/mkDerivedConstants.o : $(includes_H_CONFIG) $(includes_H_PLATFORM) - -ifneq "$(AlienScript)" "" -$(INPLACE_BIN)/mkGHCConstants$(exeext): includes/$(includes_dist-ghcconstants_C_SRCS) | $$(dir $$@)/. - $(WhatGccIsCalled) -o $@ $< $(CFLAGS) $(includes_CC_OPTS) $(includes_dist-ghcconstants_CC_OPTS) +$(includes_GHCCONSTANTS_HASKELL_WRAPPERS) : $(INPLACE_BIN)/mkDerivedConstants$(exeext) | $$(dir $$@)/. +ifeq "$(AlienScript)" "" + ./$< --gen-haskell-wrappers >$@ +else + $(AlienScript) run ./$< --gen-haskell-wrappers >$@ endif -$(includes_GHCCONSTANTS) : $(INPLACE_BIN)/mkGHCConstants$(exeext) | $$(dir $$@)/. +$(includes_GHCCONSTANTS_HASKELL_EXPORTS) : $(INPLACE_BIN)/mkDerivedConstants$(exeext) | $$(dir $$@)/. ifeq "$(AlienScript)" "" - ./$< >$@ + ./$< --gen-haskell-exports >$@ else - $(AlienScript) run ./$< >$@ + $(AlienScript) run ./$< --gen-haskell-exports >$@ endif endif @@ -208,11 +203,11 @@ endif $(eval $(call clean-target,includes,,\ $(includes_H_CONFIG) $(includes_H_PLATFORM) \ - $(includes_GHCCONSTANTS) $(includes_DERIVEDCONSTANTS))) + $(includes_GHCCONSTANTS_HASKELL_TYPE) $(includes_GHCCONSTANTS_HASKELL_VALUE) $(includes_DERIVEDCONSTANTS))) $(eval $(call all-target,includes,,\ $(includes_H_CONFIG) $(includes_H_PLATFORM) \ - $(includes_GHCCONSTANTS) $(includes_DERIVEDCONSTANTS))) + $(includes_GHCCONSTANTS_HASKELL_TYPE) $(includes_GHCCONSTANTS_HASKELL_VALUE) $(includes_DERIVEDCONSTANTS))) install: install_includes @@ -223,5 +218,5 @@ install_includes : $(call INSTALL_DIR,"$(DESTDIR)$(ghcheaderdir)/$d") && \ $(call INSTALL_HEADER,$(INSTALL_OPTS),includes/$d/*.h,"$(DESTDIR)$(ghcheaderdir)/$d/") && \ ) true - $(call INSTALL_HEADER,$(INSTALL_OPTS),$(includes_H_CONFIG) $(includes_H_PLATFORM) $(includes_GHCCONSTANTS) $(includes_DERIVEDCONSTANTS),"$(DESTDIR)$(ghcheaderdir)/") + $(call INSTALL_HEADER,$(INSTALL_OPTS),$(includes_H_CONFIG) $(includes_H_PLATFORM) $(includes_DERIVEDCONSTANTS),"$(DESTDIR)$(ghcheaderdir)/") diff --git a/includes/mkDerivedConstants.c b/includes/mkDerivedConstants.c index 3fcf12849f..609c7aed31 100644 --- a/includes/mkDerivedConstants.c +++ b/includes/mkDerivedConstants.c @@ -26,7 +26,11 @@ #include "Stable.h" #include "Capability.h" +#include <inttypes.h> #include <stdio.h> +#include <string.h> + +enum Mode { Gen_Haskell_Type, Gen_Haskell_Value, Gen_Haskell_Wrappers, Gen_Haskell_Exports, Gen_Header } mode; #define str(a,b) #a "_" #b @@ -36,38 +40,69 @@ #pragma GCC poison sizeof -#if defined(GEN_HASKELL) -#define def_offset(str, offset) \ - printf("oFFSET_" str " :: Int\n"); \ - printf("oFFSET_" str " = %" FMT_SizeT "\n", (size_t)offset); -#else -#define def_offset(str, offset) \ - printf("#define OFFSET_" str " %" FMT_SizeT "\n", (size_t)offset); -#endif +#define def_offset(str, offset) \ + switch (mode) { \ + case Gen_Haskell_Type: \ + printf(" , pc_OFFSET_" str " :: Int\n"); \ + break; \ + case Gen_Haskell_Value: \ + printf(" , pc_OFFSET_" str " = %" PRIdPTR "\n", (intptr_t)offset); \ + break; \ + case Gen_Haskell_Wrappers: \ + printf("oFFSET_" str " :: DynFlags -> Int\n"); \ + printf("oFFSET_" str " dflags = pc_OFFSET_" str " (sPlatformConstants (settings dflags))\n"); \ + break; \ + case Gen_Haskell_Exports: \ + printf(" oFFSET_" str ",\n"); \ + break; \ + case Gen_Header: \ + printf("#define OFFSET_" str " %" PRIdPTR "\n", (intptr_t)offset); \ + break; \ + } + +#define ctype(type) \ + switch (mode) { \ + case Gen_Haskell_Type: \ + case Gen_Haskell_Value: \ + case Gen_Haskell_Wrappers: \ + case Gen_Haskell_Exports: \ + break; \ + case Gen_Header: \ + printf("#define SIZEOF_" #type " %" FMT_SizeT "\n", \ + (size_t)TYPE_SIZE(type)); \ + break; \ + } -#if defined(GEN_HASKELL) -#define ctype(type) /* nothing */ -#else -#define ctype(type) \ - printf("#define SIZEOF_" #type " %" FMT_SizeT "\n", (size_t)TYPE_SIZE(type)); -#endif - -#if defined(GEN_HASKELL) -#define field_type_(str, s_type, field) /* nothing */ -#define field_type_gcptr_(str, s_type, field) /* nothing */ -#else /* Defining REP_x to be b32 etc These are both the C-- types used in a load e.g. b32[addr] and the names of the CmmTypes in the compiler b32 :: CmmType */ -#define field_type_(str, s_type, field) \ - printf("#define REP_" str " b"); \ - printf("%" FMT_SizeT "\n", FIELD_SIZE(s_type, field) * 8); -#define field_type_gcptr_(str, s_type, field) \ - printf("#define REP_" str " gcptr\n"); -#endif +#define field_type_(str, s_type, field) \ + switch (mode) { \ + case Gen_Haskell_Type: \ + case Gen_Haskell_Value: \ + case Gen_Haskell_Wrappers: \ + case Gen_Haskell_Exports: \ + break; \ + case Gen_Header: \ + printf("#define REP_" str " b"); \ + printf("%" FMT_SizeT "\n", FIELD_SIZE(s_type, field) * 8); \ + break; \ + } + +#define field_type_gcptr_(str, s_type, field) \ + switch (mode) { \ + case Gen_Haskell_Type: \ + case Gen_Haskell_Value: \ + case Gen_Haskell_Wrappers: \ + case Gen_Haskell_Exports: \ + break; \ + case Gen_Header: \ + printf("#define REP_" str " gcptr\n"); \ + break; \ + } #define field_type(s_type, field) \ field_type_(str(s_type,field),s_type,field); @@ -79,12 +114,17 @@ field_offset_(str(s_type,field),s_type,field); /* An access macro for use in C-- sources. */ -#if defined(GEN_HASKELL) -#define struct_field_macro(str) /* nothing */ -#else -#define struct_field_macro(str) \ - printf("#define " str "(__ptr__) REP_" str "[__ptr__+OFFSET_" str "]\n"); -#endif +#define struct_field_macro(str) \ + switch (mode) { \ + case Gen_Haskell_Type: \ + case Gen_Haskell_Value: \ + case Gen_Haskell_Wrappers: \ + case Gen_Haskell_Exports: \ + break; \ + case Gen_Header: \ + printf("#define " str "(__ptr__) REP_" str "[__ptr__+OFFSET_" str "]\n"); \ + break; \ + } /* Outputs the byte offset and MachRep for a field */ #define struct_field(s_type, field) \ @@ -97,21 +137,37 @@ field_type_(str, s_type, field); \ struct_field_macro(str) -#if defined(GEN_HASKELL) -#define def_size(str, size) \ - printf("sIZEOF_" str " :: Int\n"); \ - printf("sIZEOF_" str " = %" FMT_SizeT "\n", (size_t)size); -#else -#define def_size(str, size) \ - printf("#define SIZEOF_" str " %" FMT_SizeT "\n", (size_t)size); -#endif - -#if defined(GEN_HASKELL) -#define def_closure_size(str, size) /* nothing */ -#else -#define def_closure_size(str, size) \ - printf("#define SIZEOF_" str " (SIZEOF_StgHeader+%" FMT_SizeT ")\n", (size_t)size); -#endif +#define def_size(str, size) \ + switch (mode) { \ + case Gen_Haskell_Type: \ + printf(" , pc_SIZEOF_" str " :: Int\n"); \ + break; \ + case Gen_Haskell_Value: \ + printf(" , pc_SIZEOF_" str " = %" FMT_SizeT "\n", (size_t)size); \ + break; \ + case Gen_Haskell_Wrappers: \ + printf("sIZEOF_" str " :: DynFlags -> Int\n"); \ + printf("sIZEOF_" str " dflags = pc_SIZEOF_" str " (sPlatformConstants (settings dflags))\n"); \ + break; \ + case Gen_Haskell_Exports: \ + printf(" sIZEOF_" str ",\n"); \ + break; \ + case Gen_Header: \ + printf("#define SIZEOF_" str " %" FMT_SizeT "\n", (size_t)size); \ + break; \ + } + +#define def_closure_size(str, size) \ + switch (mode) { \ + case Gen_Haskell_Type: \ + case Gen_Haskell_Value: \ + case Gen_Haskell_Wrappers: \ + case Gen_Haskell_Exports: \ + break; \ + case Gen_Header: \ + printf("#define SIZEOF_" str " (SIZEOF_StgHeader+%" FMT_SizeT ")\n", (size_t)size); \ + break; \ + } #define struct_size(s_type) \ def_size(#s_type, TYPE_SIZE(s_type)); @@ -129,12 +185,17 @@ closure_size(s_type) /* An access macro for use in C-- sources. */ -#if defined(GEN_HASKELL) -#define closure_field_macro(str) /* nothing */ -#else -#define closure_field_macro(str) \ - printf("#define " str "(__ptr__) REP_" str "[__ptr__+SIZEOF_StgHeader+OFFSET_" str "]\n"); -#endif +#define closure_field_macro(str) \ + switch (mode) { \ + case Gen_Haskell_Type: \ + case Gen_Haskell_Value: \ + case Gen_Haskell_Wrappers: \ + case Gen_Haskell_Exports: \ + break; \ + case Gen_Header: \ + printf("#define " str "(__ptr__) REP_" str "[__ptr__+SIZEOF_StgHeader+OFFSET_" str "]\n"); \ + break; \ + } #define closure_field_offset_(str, s_type,field) \ def_offset(str, OFFSET(s_type,field) - TYPE_SIZE(StgHeader)); @@ -142,12 +203,17 @@ #define closure_field_offset(s_type,field) \ closure_field_offset_(str(s_type,field),s_type,field) -#if defined(GEN_HASKELL) -#define closure_payload_macro(str) /* nothing */ -#else -#define closure_payload_macro(str) \ - printf("#define " str "(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_" str " + WDS(__ix__)]\n"); -#endif +#define closure_payload_macro(str) \ + switch (mode) { \ + case Gen_Haskell_Type: \ + case Gen_Haskell_Value: \ + case Gen_Haskell_Wrappers: \ + case Gen_Haskell_Exports: \ + break; \ + case Gen_Header: \ + printf("#define " str "(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_" str " + WDS(__ix__)]\n"); \ + break; \ + } #define closure_payload(s_type,field) \ closure_field_offset_(str(s_type,field),s_type,field); \ @@ -176,60 +242,161 @@ def_offset(str(s_type,field), OFFSET(s_type,field) - TYPE_SIZE(StgHeader) - TYPE_SIZE(StgTSOProfInfo)); /* Full byte offset for a TSO field, for use from Cmm */ -#if defined(GEN_HASKELL) -#define tso_field_offset_macro(str) /* nothing */ -#else -#define tso_field_offset_macro(str) \ - printf("#define TSO_OFFSET_" str " (SIZEOF_StgHeader+SIZEOF_OPT_StgTSOProfInfo+OFFSET_" str ")\n"); -#endif +#define tso_field_offset_macro(str) \ + switch (mode) { \ + case Gen_Haskell_Type: \ + case Gen_Haskell_Value: \ + case Gen_Haskell_Wrappers: \ + case Gen_Haskell_Exports: \ + break; \ + case Gen_Header: \ + printf("#define TSO_OFFSET_" str " (SIZEOF_StgHeader+SIZEOF_OPT_StgTSOProfInfo+OFFSET_" str ")\n"); \ + break; \ + } #define tso_field_offset(s_type, field) \ tso_payload_offset(s_type, field); \ tso_field_offset_macro(str(s_type,field)); -#if defined(GEN_HASKELL) -#define tso_field_macro(str) /* nothing */ -#else -#define tso_field_macro(str) \ - printf("#define " str "(__ptr__) REP_" str "[__ptr__+TSO_OFFSET_" str "]\n") -#endif +#define tso_field_macro(str) \ + switch (mode) { \ + case Gen_Haskell_Type: \ + case Gen_Haskell_Value: \ + case Gen_Haskell_Wrappers: \ + case Gen_Haskell_Exports: \ + break; \ + case Gen_Header: \ + printf("#define " str "(__ptr__) REP_" str "[__ptr__+TSO_OFFSET_" str "]\n") \ + break; \ + } #define tso_field(s_type, field) \ field_type(s_type, field); \ tso_field_offset(s_type,field); \ tso_field_macro(str(s_type,field)) -#if defined(GEN_HASKELL) -#define opt_struct_size(s_type, option) /* nothing */ -#else -#define opt_struct_size(s_type, option) \ - printf("#ifdef " #option "\n"); \ - printf("#define SIZEOF_OPT_" #s_type " SIZEOF_" #s_type "\n"); \ - printf("#else\n"); \ - printf("#define SIZEOF_OPT_" #s_type " 0\n"); \ - printf("#endif\n\n"); -#endif +#define opt_struct_size(s_type, option) \ + switch (mode) { \ + case Gen_Haskell_Type: \ + case Gen_Haskell_Value: \ + case Gen_Haskell_Wrappers: \ + case Gen_Haskell_Exports: \ + break; \ + case Gen_Header: \ + printf("#ifdef " #option "\n"); \ + printf("#define SIZEOF_OPT_" #s_type " SIZEOF_" #s_type "\n"); \ + printf("#else\n"); \ + printf("#define SIZEOF_OPT_" #s_type " 0\n"); \ + printf("#endif\n\n"); \ + break; \ + } #define FUN_OFFSET(sym) (OFFSET(Capability,f.sym) - OFFSET(Capability,r)) +void constantIntC(char *cName, char *haskellName, intptr_t val) { + /* If the value is larger than 2^28 or smaller than -2^28, then fail. + This test is a bit conservative, but if any constants are roughly + maxBoun or minBound then we probably need them to be Integer + rather than Int so that cross-compiling between 32bit and 64bit + platforms works. */ + if (val > 268435456) { + printf("Value too large for constantInt: %" PRIdPTR "\n", val); + exit(1); + } + if (val < -268435456) { + printf("Value too small for constantInt: %" PRIdPTR "\n", val); + exit(1); + } + + switch (mode) { + case Gen_Haskell_Type: + printf(" , pc_%s :: Int\n", haskellName); + break; + case Gen_Haskell_Value: + printf(" , pc_%s = %" PRIdPTR "\n", haskellName, val); + break; + case Gen_Haskell_Wrappers: + printf("%s :: DynFlags -> Int\n", haskellName); + printf("%s dflags = pc_%s (sPlatformConstants (settings dflags))\n", + haskellName, haskellName); + break; + case Gen_Haskell_Exports: + printf(" %s,\n", haskellName); + break; + case Gen_Header: + if (cName != NULL) { + printf("#define %s %" PRIdPTR "\n", cName, val); + } + break; + } +} + +void constantInt(char *name, intptr_t val) { + constantIntC (NULL, name, val); +} int main(int argc, char *argv[]) { -#ifndef GEN_HASKELL - printf("/* This file is created automatically. Do not edit by hand.*/\n\n"); - - printf("#define STD_HDR_SIZE %" FMT_SizeT "\n", (size_t)sizeofW(StgHeader) - sizeofW(StgProfHeader)); + if (argc == 1) { + mode = Gen_Header; + } + else if (argc == 2) { + if (0 == strcmp("--gen-haskell-type", argv[1])) { + mode = Gen_Haskell_Type; + } + else if (0 == strcmp("--gen-haskell-value", argv[1])) { + mode = Gen_Haskell_Value; + } + else if (0 == strcmp("--gen-haskell-wrappers", argv[1])) { + mode = Gen_Haskell_Wrappers; + } + else if (0 == strcmp("--gen-haskell-exports", argv[1])) { + mode = Gen_Haskell_Exports; + } + else { + printf("Bad args\n"); + exit(1); + } + } + else { + printf("Bad args\n"); + exit(1); + } + + switch (mode) { + case Gen_Haskell_Type: + printf("data PlatformConstants = PlatformConstants {\n"); + /* Now a kludge that allows the real entries to all start with a + comma, which makes life a little easier */ + printf(" pc_platformConstants :: ()\n"); + break; + case Gen_Haskell_Value: + printf("PlatformConstants {\n"); + printf(" pc_platformConstants = ()\n"); + break; + case Gen_Haskell_Wrappers: + case Gen_Haskell_Exports: + break; + case Gen_Header: + printf("/* This file is created automatically. Do not edit by hand.*/\n\n"); + + break; + } + + // Closure header sizes. + constantIntC("STD_HDR_SIZE", "sTD_HDR_SIZE", + sizeofW(StgHeader) - sizeofW(StgProfHeader)); /* grrr.. PROFILING is on so we need to subtract sizeofW(StgProfHeader) */ - printf("#define PROF_HDR_SIZE %" FMT_SizeT "\n", (size_t)sizeofW(StgProfHeader)); + constantIntC("PROF_HDR_SIZE", "pROF_HDR_SIZE", sizeofW(StgProfHeader)); - printf("#define BLOCK_SIZE %u\n", BLOCK_SIZE); - printf("#define MBLOCK_SIZE %u\n", MBLOCK_SIZE); - printf("#define BLOCKS_PER_MBLOCK %" FMT_SizeT "\n", (lnat)BLOCKS_PER_MBLOCK); + // Size of a storage manager block (in bytes). + constantIntC("BLOCK_SIZE", "bLOCK_SIZE", BLOCK_SIZE); + constantIntC("MBLOCK_SIZE", "mBLOCK_SIZE", MBLOCK_SIZE); + // blocks that fit in an MBlock, leaving space for the block descriptors + constantIntC("BLOCKS_PER_MBLOCK", "bLOCKS_PER_MBLOCK", BLOCKS_PER_MBLOCK); // could be derived, but better to save doing the calculation twice - printf("\n\n"); -#endif field_offset(StgRegTable, rR1); field_offset(StgRegTable, rR2); @@ -469,11 +636,65 @@ main(int argc, char *argv[]) struct_field(snEntry,addr); #ifdef mingw32_HOST_OS - struct_size(StgAsyncIOResult); - struct_field(StgAsyncIOResult, reqID); - struct_field(StgAsyncIOResult, len); - struct_field(StgAsyncIOResult, errCode); + /* Note that this conditional part only affects the C headers. + That's important, as it means we get the same PlatformConstants + type on all platforms. */ + if (mode == Gen_Header) { + struct_size(StgAsyncIOResult); + struct_field(StgAsyncIOResult, reqID); + struct_field(StgAsyncIOResult, len); + struct_field(StgAsyncIOResult, errCode); + } #endif + // pre-compiled thunk types + constantInt("mAX_SPEC_SELECTEE_SIZE", MAX_SPEC_SELECTEE_SIZE); + constantInt("mAX_SPEC_AP_SIZE", MAX_SPEC_AP_SIZE); + + // closure sizes: these do NOT include the header (see below for + // header sizes) + constantInt("mIN_PAYLOAD_SIZE", MIN_PAYLOAD_SIZE); + + constantInt("mIN_INTLIKE", MIN_INTLIKE); + constantInt("mAX_INTLIKE", MAX_INTLIKE); + + constantInt("mIN_CHARLIKE", MIN_CHARLIKE); + constantInt("mAX_CHARLIKE", MAX_CHARLIKE); + + constantInt("mUT_ARR_PTRS_CARD_BITS", MUT_ARR_PTRS_CARD_BITS); + + // A section of code-generator-related MAGIC CONSTANTS. + constantInt("mAX_Vanilla_REG", MAX_VANILLA_REG); + constantInt("mAX_Float_REG", MAX_FLOAT_REG); + constantInt("mAX_Double_REG", MAX_DOUBLE_REG); + constantInt("mAX_Long_REG", MAX_LONG_REG); + constantInt("mAX_Real_Vanilla_REG", MAX_REAL_VANILLA_REG); + constantInt("mAX_Real_Float_REG", MAX_REAL_FLOAT_REG); + constantInt("mAX_Real_Double_REG", MAX_REAL_DOUBLE_REG); + constantInt("mAX_Real_Long_REG", MAX_REAL_LONG_REG); + + // This tells the native code generator the size of the spill + // area is has available. + constantInt("rESERVED_C_STACK_BYTES", RESERVED_C_STACK_BYTES); + // The amount of (Haskell) stack to leave free for saving registers when + // returning to the scheduler. + constantInt("rESERVED_STACK_WORDS", RESERVED_STACK_WORDS); + // Continuations that need more than this amount of stack should do their + // own stack check (see bug #1466). + constantInt("aP_STACK_SPLIM", AP_STACK_SPLIM); + + switch (mode) { + case Gen_Haskell_Type: + printf(" } deriving (Read, Show)\n"); + break; + case Gen_Haskell_Value: + printf(" }\n"); + break; + case Gen_Haskell_Wrappers: + case Gen_Haskell_Exports: + case Gen_Header: + break; + } + return 0; } diff --git a/includes/rts/Hooks.h b/includes/rts/Hooks.h index f409205b87..f536afaa09 100644 --- a/includes/rts/Hooks.h +++ b/includes/rts/Hooks.h @@ -18,9 +18,9 @@ extern char *ghc_rts_opts; extern void OnExitHook (void); extern int NoRunnableThreadsHook (void); -extern void StackOverflowHook (lnat stack_size); -extern void OutOfHeapHook (lnat request_size, lnat heap_size); -extern void MallocFailHook (lnat request_size /* in bytes */, char *msg); +extern void StackOverflowHook (W_ stack_size); +extern void OutOfHeapHook (W_ request_size, W_ heap_size); +extern void MallocFailHook (W_ request_size /* in bytes */, char *msg); extern void defaultsHook (void); #endif /* RTS_HOOKS_H */ diff --git a/includes/rts/SpinLock.h b/includes/rts/SpinLock.h index 8b337de73f..63a9395e18 100644 --- a/includes/rts/SpinLock.h +++ b/includes/rts/SpinLock.h @@ -34,7 +34,7 @@ typedef struct SpinLock_ typedef StgWord SpinLock; #endif -typedef lnat SpinLockCount; +typedef StgWord SpinLockCount; #if defined(PROF_SPIN) diff --git a/includes/rts/Threads.h b/includes/rts/Threads.h index 5db5cb7bd8..60d9bc45a1 100644 --- a/includes/rts/Threads.h +++ b/includes/rts/Threads.h @@ -22,17 +22,17 @@ // // Creating threads // -StgTSO *createThread (Capability *cap, nat stack_size); +StgTSO *createThread (Capability *cap, W_ stack_size); void scheduleWaitThread (/* in */ StgTSO *tso, /* out */ HaskellObj* ret, /* inout */ Capability **cap); -StgTSO *createGenThread (Capability *cap, nat stack_size, +StgTSO *createGenThread (Capability *cap, W_ stack_size, StgClosure *closure); -StgTSO *createIOThread (Capability *cap, nat stack_size, +StgTSO *createIOThread (Capability *cap, W_ stack_size, StgClosure *closure); -StgTSO *createStrictIOThread (Capability *cap, nat stack_size, +StgTSO *createStrictIOThread (Capability *cap, W_ stack_size, StgClosure *closure); // Suspending/resuming threads around foreign calls diff --git a/includes/rts/Types.h b/includes/rts/Types.h index ff42cdab1f..aacbfdc0b8 100644 --- a/includes/rts/Types.h +++ b/includes/rts/Types.h @@ -16,8 +16,10 @@ #include <stddef.h> -typedef unsigned int nat; /* at least 32 bits (like int) */ -typedef size_t lnat; /* at least 32 bits */ +typedef unsigned int nat; /* at least 32 bits (like int) */ + +// Deprecated; just use StgWord instead +typedef StgWord lnat; /* ullong (64|128-bit) type: only include if needed (not ANSI) */ #if defined(__GNUC__) diff --git a/includes/rts/storage/Block.h b/includes/rts/storage/Block.h index c73c9af90a..0a9b12b874 100644 --- a/includes/rts/storage/Block.h +++ b/includes/rts/storage/Block.h @@ -244,11 +244,11 @@ extern void initBlockAllocator(void); /* Allocation -------------------------------------------------------------- */ -bdescr *allocGroup(nat n); +bdescr *allocGroup(W_ n); bdescr *allocBlock(void); // versions that take the storage manager lock for you: -bdescr *allocGroup_lock(nat n); +bdescr *allocGroup_lock(W_ n); bdescr *allocBlock_lock(void); /* De-Allocation ----------------------------------------------------------- */ diff --git a/includes/rts/storage/ClosureMacros.h b/includes/rts/storage/ClosureMacros.h index c6b29aa5b8..146564a17f 100644 --- a/includes/rts/storage/ClosureMacros.h +++ b/includes/rts/storage/ClosureMacros.h @@ -429,20 +429,20 @@ EXTERN_INLINE StgWord stack_frame_sizeW( StgClosure *frame ) -------------------------------------------------------------------------- */ // The number of card bytes needed -INLINE_HEADER lnat mutArrPtrsCards (lnat elems) +INLINE_HEADER W_ mutArrPtrsCards (W_ elems) { - return (lnat)((elems + (1 << MUT_ARR_PTRS_CARD_BITS) - 1) + return (W_)((elems + (1 << MUT_ARR_PTRS_CARD_BITS) - 1) >> MUT_ARR_PTRS_CARD_BITS); } // The number of words in the card table -INLINE_HEADER lnat mutArrPtrsCardTableSize (lnat elems) +INLINE_HEADER W_ mutArrPtrsCardTableSize (W_ elems) { return ROUNDUP_BYTES_TO_WDS(mutArrPtrsCards(elems)); } // The address of the card for a particular card number -INLINE_HEADER StgWord8 *mutArrPtrsCard (StgMutArrPtrs *a, lnat n) +INLINE_HEADER StgWord8 *mutArrPtrsCard (StgMutArrPtrs *a, W_ n) { return ((StgWord8 *)&(a->payload[a->ptrs]) + n); } diff --git a/includes/rts/storage/GC.h b/includes/rts/storage/GC.h index 5de8b2be4a..fadaa8c1a4 100644 --- a/includes/rts/storage/GC.h +++ b/includes/rts/storage/GC.h @@ -124,13 +124,13 @@ extern generation * oldest_gen; /* ----------------------------------------------------------------------------- Generic allocation - StgPtr allocate(Capability *cap, nat n) + StgPtr allocate(Capability *cap, W_ n) Allocates memory from the nursery in the current Capability. This can be done without taking a global lock, unlike allocate(). - StgPtr allocatePinned(Capability *cap, nat n) + StgPtr allocatePinned(Capability *cap, W_ n) Allocates a chunk of contiguous store n words long, which is at a fixed address (won't be moved by GC). @@ -149,15 +149,15 @@ extern generation * oldest_gen; -------------------------------------------------------------------------- */ -StgPtr allocate ( Capability *cap, lnat n ); -StgPtr allocatePinned ( Capability *cap, lnat n ); +StgPtr allocate ( Capability *cap, W_ n ); +StgPtr allocatePinned ( Capability *cap, W_ n ); /* memory allocator for executable memory */ -void * allocateExec(unsigned int len, void **exec_addr); +void * allocateExec(W_ len, void **exec_addr); void freeExec (void *p); // Used by GC checks in external .cmm code: -extern nat large_alloc_lim; +extern W_ large_alloc_lim; /* ----------------------------------------------------------------------------- Performing Garbage Collection diff --git a/includes/rts/storage/MBlock.h b/includes/rts/storage/MBlock.h index 69b3742514..7a5eb22cc9 100644 --- a/includes/rts/storage/MBlock.h +++ b/includes/rts/storage/MBlock.h @@ -12,8 +12,8 @@ #ifndef RTS_STORAGE_MBLOCK_H #define RTS_STORAGE_MBLOCK_H -extern lnat peak_mblocks_allocated; -extern lnat mblocks_allocated; +extern W_ peak_mblocks_allocated; +extern W_ mblocks_allocated; extern void initMBlocks(void); extern void * getMBlock(void); @@ -156,7 +156,7 @@ typedef struct { MBlockMapLine lines[MBLOCK_MAP_ENTRIES]; } MBlockMap; -extern lnat mpc_misses; +extern W_ mpc_misses; StgBool HEAP_ALLOCED_miss(StgWord mblock, void *p); diff --git a/includes/stg/Types.h b/includes/stg/Types.h index 839c0641c0..d6bdc9042b 100644 --- a/includes/stg/Types.h +++ b/includes/stg/Types.h @@ -43,9 +43,6 @@ /* * First, platform-dependent definitions of size-specific integers. - * Assume for now that the int type is 32 bits. - * NOTE: Synch the following definitions with MachDeps.h! - * ToDo: move these into a platform-dependent file. */ typedef signed char StgInt8; @@ -89,12 +86,6 @@ typedef unsigned long long int StgWord64; /* * Define the standard word size we'll use on this machine: make it * big enough to hold a pointer. - * - * It's useful if StgInt/StgWord are always the same as long, so that - * we can use a consistent printf format specifier without warnings on - * any platform. Fortunately this works at the moement; if it breaks - * in the future we'll have to start using macros for format - * specifiers (c.f. FMT_StgWord64 in Rts.h). */ #if SIZEOF_VOID_P == 8 @@ -138,10 +129,11 @@ typedef void* StgStablePtr; typedef StgWord8* StgByteArray; /* - Types for the generated C functions - take no arguments - return a pointer to the next function to be called - use: Ptr to Fun that returns a Ptr to Fun which returns Ptr to void + Types for generated C functions when compiling via C. + + The C functions take no arguments, and return a pointer to the next + function to be called use: Ptr to Fun that returns a Ptr to Fun + which returns Ptr to void Note: Neither StgFunPtr not StgFun is quite right (that is, StgFunPtr != StgFun*). So, the functions we define all have type diff --git a/rts/Arena.c b/rts/Arena.c index 653eb69706..361c6c41be 100644 --- a/rts/Arena.c +++ b/rts/Arena.c @@ -80,7 +80,7 @@ arenaAlloc( Arena *arena, size_t size ) return p; } else { // allocate a fresh block... - req_blocks = (lnat)BLOCK_ROUND_UP(size) / BLOCK_SIZE; + req_blocks = (W_)BLOCK_ROUND_UP(size) / BLOCK_SIZE; bd = allocGroup_lock(req_blocks); arena_blocks += req_blocks; diff --git a/rts/Capability.h b/rts/Capability.h index 6c417160ad..1b3c06f5d3 100644 --- a/rts/Capability.h +++ b/rts/Capability.h @@ -123,7 +123,7 @@ struct Capability_ { SparkCounters spark_stats; #endif // Total words allocated by this cap since rts start - lnat total_allocated; + W_ total_allocated; // Per-capability STM-related data StgTVarWatchQueue *free_tvar_watch_queues; diff --git a/rts/Disassembler.c b/rts/Disassembler.c index 033af11f64..bcc085803a 100644 --- a/rts/Disassembler.c +++ b/rts/Disassembler.c @@ -80,7 +80,7 @@ disInstr ( StgBCO *bco, int pc ) pc += 1; break; case bci_STKCHECK: { StgWord stk_words_reqd = BCO_GET_LARGE_ARG + 1; - debugBelch("STKCHECK %" FMT_SizeT "\n", (lnat)stk_words_reqd ); + debugBelch("STKCHECK %" FMT_Word "\n", (W_)stk_words_reqd ); break; } case bci_PUSH_L: diff --git a/rts/FrontPanel.c b/rts/FrontPanel.c index d6269fb5b3..b0b9bced4a 100644 --- a/rts/FrontPanel.c +++ b/rts/FrontPanel.c @@ -296,7 +296,7 @@ numLabel( GtkWidget *lbl, nat n ) } void -updateFrontPanelAfterGC( nat N, lnat live ) +updateFrontPanelAfterGC( nat N, W_ live ) { char buf[1000]; diff --git a/rts/FrontPanel.h b/rts/FrontPanel.h index 1669c2bf94..84e40d5e1b 100644 --- a/rts/FrontPanel.h +++ b/rts/FrontPanel.h @@ -19,7 +19,7 @@ void initFrontPanel( void ); void stopFrontPanel( void ); void updateFrontPanelBeforeGC( nat N ); -void updateFrontPanelAfterGC( nat N, lnat live ); +void updateFrontPanelAfterGC( nat N, W_ live ); void updateFrontPanel( void ); diff --git a/rts/GetTime.h b/rts/GetTime.h index 45804aa3a9..4b967b5b9a 100644 --- a/rts/GetTime.h +++ b/rts/GetTime.h @@ -25,7 +25,7 @@ void getProcessTimes (Time *user, Time *elapsed); void getUnixEpochTime (StgWord64 *sec, StgWord32 *nsec); // Not strictly timing, but related -nat getPageFaults (void); +W_ getPageFaults (void); #include "EndPrivate.h" diff --git a/rts/Linker.c b/rts/Linker.c index bf0045616e..cf60c528d3 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -1900,7 +1900,7 @@ mmap_again: MAP_PRIVATE|TRY_MAP_32BIT|fixed|flags, fd, 0); if (result == MAP_FAILED) { - sysErrorBelch("mmap %" FMT_SizeT " bytes at %p",(lnat)size,map_addr); + sysErrorBelch("mmap %" FMT_Word " bytes at %p",(W_)size,map_addr); errorBelch("Try specifying an address with +RTS -xm<addr> -RTS"); stg_exit(EXIT_FAILURE); } @@ -1943,7 +1943,7 @@ mmap_again: } #endif - IF_DEBUG(linker, debugBelch("mmapForLinker: mapped %" FMT_SizeT " bytes starting at %p\n", (lnat)size, result)); + IF_DEBUG(linker, debugBelch("mmapForLinker: mapped %" FMT_Word " bytes starting at %p\n", (W_)size, result)); IF_DEBUG(linker, debugBelch("mmapForLinker: done\n")); return result; } @@ -4937,7 +4937,7 @@ do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC, default: errorBelch("%s: unhandled ELF relocation(Rel) type %" FMT_SizeT "\n", - oc->fileName, (lnat)ELF_R_TYPE(info)); + oc->fileName, (W_)ELF_R_TYPE(info)); return 0; } @@ -5252,7 +5252,7 @@ do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC, default: errorBelch("%s: unhandled ELF relocation(RelA) type %" FMT_SizeT "\n", - oc->fileName, (lnat)ELF_R_TYPE(info)); + oc->fileName, (W_)ELF_R_TYPE(info)); return 0; } diff --git a/rts/Messages.c b/rts/Messages.c index 6cb66479ee..34dcbdf56d 100644 --- a/rts/Messages.c +++ b/rts/Messages.c @@ -74,7 +74,7 @@ loop: { StgTSO *tso = ((MessageWakeup *)m)->tso; debugTraceCap(DEBUG_sched, cap, "message: try wakeup thread %ld", - (lnat)tso->id); + (W_)tso->id); tryWakeupThread(cap, tso); } else if (i == &stg_MSG_THROWTO_info) @@ -90,7 +90,7 @@ loop: } debugTraceCap(DEBUG_sched, cap, "message: throwTo %ld -> %ld", - (lnat)t->source->id, (lnat)t->target->id); + (W_)t->source->id, (W_)t->target->id); ASSERT(t->source->why_blocked == BlockedOnMsgThrowTo); ASSERT(t->source->block_info.closure == (StgClosure *)m); @@ -167,7 +167,7 @@ nat messageBlackHole(Capability *cap, MessageBlackHole *msg) StgTSO *owner; debugTraceCap(DEBUG_sched, cap, "message: thread %d blocking on blackhole %p", - (lnat)msg->tso->id, msg->bh); + (W_)msg->tso->id, msg->bh); info = bh->header.info; @@ -256,7 +256,7 @@ loop: recordClosureMutated(cap,bh); // bh was mutated debugTraceCap(DEBUG_sched, cap, "thread %d blocked on thread %d", - (lnat)msg->tso->id, (lnat)owner->id); + (W_)msg->tso->id, (W_)owner->id); return 1; // blocked } @@ -289,7 +289,7 @@ loop: } debugTraceCap(DEBUG_sched, cap, "thread %d blocked on thread %d", - (lnat)msg->tso->id, (lnat)owner->id); + (W_)msg->tso->id, (W_)owner->id); // See above, #3838 if (owner->why_blocked == NotBlocked && owner->id != msg->tso->id) { diff --git a/rts/Printer.c b/rts/Printer.c index 156dbea37a..02fbb09962 100644 --- a/rts/Printer.c +++ b/rts/Printer.c @@ -300,21 +300,21 @@ printClosure( StgClosure *obj ) StgWord i; debugBelch("ARR_WORDS(\""); for (i=0; i<arr_words_words((StgArrWords *)obj); i++) - debugBelch("%" FMT_SizeT, (lnat)((StgArrWords *)obj)->payload[i]); + debugBelch("%" FMT_Word, (W_)((StgArrWords *)obj)->payload[i]); debugBelch("\")\n"); break; } case MUT_ARR_PTRS_CLEAN: - debugBelch("MUT_ARR_PTRS_CLEAN(size=%" FMT_SizeT ")\n", (lnat)((StgMutArrPtrs *)obj)->ptrs); + debugBelch("MUT_ARR_PTRS_CLEAN(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs); break; case MUT_ARR_PTRS_DIRTY: - debugBelch("MUT_ARR_PTRS_DIRTY(size=%" FMT_SizeT ")\n", (lnat)((StgMutArrPtrs *)obj)->ptrs); + debugBelch("MUT_ARR_PTRS_DIRTY(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs); break; case MUT_ARR_PTRS_FROZEN: - debugBelch("MUT_ARR_PTRS_FROZEN(size=%" FMT_SizeT ")\n", (lnat)((StgMutArrPtrs *)obj)->ptrs); + debugBelch("MUT_ARR_PTRS_FROZEN(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs); break; case MVAR_CLEAN: @@ -431,7 +431,7 @@ printSmallBitmap( StgPtr spBottom, StgPtr payload, StgWord bitmap, nat size ) printPtr((P_)payload[i]); debugBelch("\n"); } else { - debugBelch("Word# %" FMT_SizeT "\n", (lnat)payload[i]); + debugBelch("Word# %" FMT_Word "\n", (W_)payload[i]); } } } @@ -447,12 +447,12 @@ printLargeBitmap( StgPtr spBottom, StgPtr payload, StgLargeBitmap* large_bitmap, StgWord bitmap = large_bitmap->bitmap[bmp]; j = 0; for(; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1 ) { - debugBelch(" stk[%" FMT_SizeT "] (%p) = ", (lnat)(spBottom-(payload+i)), payload+i); + debugBelch(" stk[%" FMT_Word "] (%p) = ", (W_)(spBottom-(payload+i)), payload+i); if ((bitmap & 1) == 0) { printPtr((P_)payload[i]); debugBelch("\n"); } else { - debugBelch("Word# %" FMT_SizeT "\n", (lnat)payload[i]); + debugBelch("Word# %" FMT_Word "\n", (W_)payload[i]); } } } diff --git a/rts/ProfHeap.c b/rts/ProfHeap.c index c7048a5cf6..c68b661c86 100644 --- a/rts/ProfHeap.c +++ b/rts/ProfHeap.c @@ -821,7 +821,7 @@ dumpCensus( Census *census ) } #endif - fprintf(hp_file, "\t%" FMT_SizeT "\n", (lnat)count * sizeof(W_)); + fprintf(hp_file, "\t%" FMT_SizeT "\n", (W_)count * sizeof(W_)); } printSample(rtsFalse, census->time); diff --git a/rts/Profiling.c b/rts/Profiling.c index 2544e00e21..d43fc6ad54 100644 --- a/rts/Profiling.c +++ b/rts/Profiling.c @@ -42,7 +42,7 @@ unsigned int CCS_ID = 1; /* figures for the profiling report. */ static StgWord64 total_alloc; -static lnat total_prof_ticks; +static W_ total_prof_ticks; /* Globals for opening the profiling log file(s) */ diff --git a/rts/RetainerProfile.c b/rts/RetainerProfile.c index 4bbc3380ae..c07dff76e4 100644 --- a/rts/RetainerProfile.c +++ b/rts/RetainerProfile.c @@ -271,11 +271,11 @@ isEmptyRetainerStack( void ) * Returns size of stack * -------------------------------------------------------------------------- */ #ifdef DEBUG -lnat +W_ retainerStackBlocks( void ) { bdescr* bd; - lnat res = 0; + W_ res = 0; for (bd = firstStack; bd != NULL; bd = bd->link) res += bd->blocks; diff --git a/rts/RetainerProfile.h b/rts/RetainerProfile.h index 0e75327cde..d92563ffbb 100644 --- a/rts/RetainerProfile.h +++ b/rts/RetainerProfile.h @@ -43,7 +43,7 @@ retainerSetOf( StgClosure *c ) // Used by Storage.c:memInventory() #ifdef DEBUG -extern lnat retainerStackBlocks ( void ); +extern W_ retainerStackBlocks ( void ); #endif #include "EndPrivate.h" diff --git a/rts/RtsAPI.c b/rts/RtsAPI.c index c0896f7c6a..ec19b169b6 100644 --- a/rts/RtsAPI.c +++ b/rts/RtsAPI.c @@ -380,7 +380,7 @@ INLINE_HEADER void pushClosure (StgTSO *tso, StgWord c) { } StgTSO * -createGenThread (Capability *cap, nat stack_size, StgClosure *closure) +createGenThread (Capability *cap, W_ stack_size, StgClosure *closure) { StgTSO *t; t = createThread (cap, stack_size); @@ -390,7 +390,7 @@ createGenThread (Capability *cap, nat stack_size, StgClosure *closure) } StgTSO * -createIOThread (Capability *cap, nat stack_size, StgClosure *closure) +createIOThread (Capability *cap, W_ stack_size, StgClosure *closure) { StgTSO *t; t = createThread (cap, stack_size); @@ -406,7 +406,7 @@ createIOThread (Capability *cap, nat stack_size, StgClosure *closure) */ StgTSO * -createStrictIOThread(Capability *cap, nat stack_size, StgClosure *closure) +createStrictIOThread(Capability *cap, W_ stack_size, StgClosure *closure) { StgTSO *t; t = createThread(cap, stack_size); diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c index 7c86efadb7..42c7ef717b 100644 --- a/rts/RtsFlags.c +++ b/rts/RtsFlags.c @@ -1542,7 +1542,7 @@ decodeSize(const char *flag, nat offset, StgWord64 min, StgWord64 max) if (m < 0 || val < min || val > max) { // printf doesn't like 64-bit format specs on Windows // apparently, so fall back to unsigned long. - errorBelch("error in RTS option %s: size outside allowed range (%" FMT_SizeT " - %" FMT_SizeT ")", flag, (lnat)min, (lnat)max); + errorBelch("error in RTS option %s: size outside allowed range (%" FMT_Word " - %" FMT_Word ")", flag, (W_)min, (W_)max); stg_exit(EXIT_FAILURE); } diff --git a/rts/RtsUtils.c b/rts/RtsUtils.c index b880f8c9e5..4d6d362722 100644 --- a/rts/RtsUtils.c +++ b/rts/RtsUtils.c @@ -130,7 +130,7 @@ heapOverflow(void) { /* don't fflush(stdout); WORKAROUND bug in Linux glibc */ OutOfHeapHook(0/*unknown request size*/, - (lnat)RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE); + (W_)RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE); heap_overflow = rtsTrue; } diff --git a/rts/Schedule.c b/rts/Schedule.c index a8de843ea6..41f7f37f71 100644 --- a/rts/Schedule.c +++ b/rts/Schedule.c @@ -1107,9 +1107,9 @@ scheduleHandleHeapOverflow( Capability *cap, StgTSO *t ) if (cap->r.rHpAlloc > BLOCK_SIZE) { // if so, get one and push it on the front of the nursery. bdescr *bd; - lnat blocks; + W_ blocks; - blocks = (lnat)BLOCK_ROUND_UP(cap->r.rHpAlloc) / BLOCK_SIZE; + blocks = (W_)BLOCK_ROUND_UP(cap->r.rHpAlloc) / BLOCK_SIZE; if (blocks > BLOCKS_PER_MBLOCK) { barf("allocation of %ld bytes too large (GHC should have complained at compile-time)", (long)cap->r.rHpAlloc); diff --git a/rts/Stats.c b/rts/Stats.c index b12cb769f7..6c8efd638d 100644 --- a/rts/Stats.c +++ b/rts/Stats.c @@ -57,14 +57,14 @@ static Time HCe_start_time, HCe_tot_time = 0; // heap census prof elap time #endif // current = current as of last GC -static lnat current_residency = 0; // in words; for stats only -static lnat max_residency = 0; -static lnat cumulative_residency = 0; -static lnat residency_samples = 0; // for stats only -static lnat current_slop = 0; -static lnat max_slop = 0; +static W_ current_residency = 0; // in words; for stats only +static W_ max_residency = 0; +static W_ cumulative_residency = 0; +static W_ residency_samples = 0; // for stats only +static W_ current_slop = 0; +static W_ max_slop = 0; -static lnat GC_end_faults = 0; +static W_ GC_end_faults = 0; static Time *GC_coll_cpu = NULL; static Time *GC_coll_elapsed = NULL; @@ -340,8 +340,8 @@ stat_gcWorkerThreadDone (gc_thread *gct STG_UNUSED) void stat_endGC (Capability *cap, gc_thread *gct, - lnat alloc, lnat live, lnat copied, lnat slop, nat gen, - nat par_n_threads, lnat par_max_copied, lnat par_tot_copied) + W_ alloc, W_ live, W_ copied, W_ slop, nat gen, + nat par_n_threads, W_ par_max_copied, W_ par_tot_copied) { if (RtsFlags.GcFlags.giveStats != NO_GC_STATS || RtsFlags.ProfFlags.doHeapProfile) @@ -381,12 +381,12 @@ stat_endGC (Capability *cap, gc_thread *gct, gc_cpu = cpu - gct->gc_start_cpu; if (RtsFlags.GcFlags.giveStats == VERBOSE_GC_STATS) { - nat faults = getPageFaults(); + W_ faults = getPageFaults(); statsPrintf("%9" FMT_SizeT " %9" FMT_SizeT " %9" FMT_SizeT, alloc*sizeof(W_), copied*sizeof(W_), live*sizeof(W_)); - statsPrintf(" %5.2f %5.2f %7.2f %7.2f %4" FMT_SizeT " %4" FMT_SizeT " (Gen: %2d)\n", + statsPrintf(" %5.2f %5.2f %7.2f %7.2f %4" FMT_Word " %4" FMT_Word " (Gen: %2d)\n", TimeToSecondsDbl(gc_cpu), TimeToSecondsDbl(gc_elapsed), TimeToSecondsDbl(cpu), @@ -419,8 +419,8 @@ stat_endGC (Capability *cap, gc_thread *gct, * to calculate the total */ { - lnat tot_alloc = 0; - lnat n; + W_ tot_alloc = 0; + W_ n; for (n = 0; n < n_capabilities; n++) { tot_alloc += capabilities[n].total_allocated; traceEventHeapAllocated(&capabilities[n], @@ -627,7 +627,7 @@ stat_exit(int alloc) if (tot_elapsed == 0.0) tot_elapsed = 1; if (RtsFlags.GcFlags.giveStats >= VERBOSE_GC_STATS) { - statsPrintf("%9" FMT_SizeT " %9.9s %9.9s", (lnat)alloc*sizeof(W_), "", ""); + statsPrintf("%9" FMT_SizeT " %9.9s %9.9s", (W_)alloc*sizeof(W_), "", ""); statsPrintf(" %5.2f %5.2f\n\n", 0.0, 0.0); } @@ -666,7 +666,7 @@ stat_exit(int alloc) if ( residency_samples > 0 ) { showStgWord64(max_residency*sizeof(W_), temp, rtsTrue/*commas*/); - statsPrintf("%16s bytes maximum residency (%" FMT_SizeT " sample(s))\n", + statsPrintf("%16s bytes maximum residency (%" FMT_Word " sample(s))\n", temp, residency_samples); } @@ -675,7 +675,7 @@ stat_exit(int alloc) statsPrintf("%16" FMT_SizeT " MB total memory in use (%" FMT_SizeT " MB lost due to fragmentation)\n\n", peak_mblocks_allocated * MBLOCK_SIZE_W / (1024 * 1024 / sizeof(W_)), - (lnat)(peak_mblocks_allocated * BLOCKS_PER_MBLOCK * BLOCK_SIZE_W - hw_alloc_blocks * BLOCK_SIZE_W) / (1024 * 1024 / sizeof(W_))); + (W_)(peak_mblocks_allocated * BLOCKS_PER_MBLOCK * BLOCK_SIZE_W - hw_alloc_blocks * BLOCK_SIZE_W) / (1024 * 1024 / sizeof(W_))); /* Print garbage collections in each gen */ statsPrintf(" Tot time (elapsed) Avg pause Max pause\n"); @@ -856,9 +856,9 @@ void statDescribeGens(void) { nat g, mut, lge, i; - lnat gen_slop; - lnat tot_live, tot_slop; - lnat gen_live, gen_blocks; + W_ gen_slop; + W_ tot_live, tot_slop; + W_ gen_live, gen_blocks; bdescr *bd; generation *gen; @@ -896,12 +896,12 @@ statDescribeGens(void) gen_blocks += gcThreadLiveBlocks(i,g); } - debugBelch("%5d %7" FMT_SizeT " %9d", g, (lnat)gen->max_blocks, mut); + debugBelch("%5d %7" FMT_Word " %9d", g, (W_)gen->max_blocks, mut); gen_slop = gen_blocks * BLOCK_SIZE_W - gen_live; - debugBelch("%8" FMT_SizeT " %8d %8" FMT_SizeT " %8" FMT_SizeT "\n", gen_blocks, lge, - gen_live*sizeof(W_), gen_slop*sizeof(W_)); + debugBelch("%8" FMT_Word " %8d %8" FMT_Word " %8" FMT_Word "\n", gen_blocks, lge, + gen_live*(W_)sizeof(W_), gen_slop*(W_)sizeof(W_)); tot_live += gen_live; tot_slop += gen_slop; } diff --git a/rts/Stats.h b/rts/Stats.h index d74cf2972d..008ef62ac4 100644 --- a/rts/Stats.h +++ b/rts/Stats.h @@ -29,8 +29,8 @@ void stat_endInit(void); void stat_startGC(Capability *cap, struct gc_thread_ *gct); void stat_endGC (Capability *cap, struct gc_thread_ *gct, - lnat alloc, lnat live, lnat copied, lnat slop, nat gen, - nat n_gc_threads, lnat par_max_copied, lnat par_tot_copied); + W_ alloc, W_ live, W_ copied, W_ slop, nat gen, + nat n_gc_threads, W_ par_max_copied, W_ par_tot_copied); void stat_gcWorkerThreadStart (struct gc_thread_ *gct); void stat_gcWorkerThreadDone (struct gc_thread_ *gct); diff --git a/rts/Threads.c b/rts/Threads.c index 61bf4445e8..b6176163ad 100644 --- a/rts/Threads.c +++ b/rts/Threads.c @@ -57,7 +57,7 @@ static StgThreadID next_thread_id = 1; currently pri (priority) is only used in a GRAN setup -- HWL ------------------------------------------------------------------------ */ StgTSO * -createThread(Capability *cap, nat size) +createThread(Capability *cap, W_ size) { StgTSO *tso; StgStack *stack; @@ -247,7 +247,7 @@ tryWakeupThread (Capability *cap, StgTSO *tso) msg->tso = tso; sendMessage(cap, tso->cap, (Message*)msg); debugTraceCap(DEBUG_sched, cap, "message: try wakeup thread %ld on cap %d", - (lnat)tso->id, tso->cap->no); + (W_)tso->id, tso->cap->no); return; } #endif @@ -272,7 +272,7 @@ tryWakeupThread (Capability *cap, StgTSO *tso) unlockClosure(tso->block_info.closure, i); if (i != &stg_MSG_NULL_info) { debugTraceCap(DEBUG_sched, cap, "thread %ld still blocked on throwto (%p)", - (lnat)tso->id, tso->block_info.throwto->header.info); + (W_)tso->id, tso->block_info.throwto->header.info); return; } @@ -375,7 +375,7 @@ checkBlockingQueues (Capability *cap, StgTSO *tso) debugTraceCap(DEBUG_sched, cap, "collision occurred; checking blocking queues for thread %ld", - (lnat)tso->id); + (W_)tso->id); for (bq = tso->bq; bq != (StgBlockingQueue*)END_TSO_QUEUE; bq = next) { next = bq->link; @@ -494,7 +494,7 @@ threadStackOverflow (Capability *cap, StgTSO *tso) { StgStack *new_stack, *old_stack; StgUnderflowFrame *frame; - lnat chunk_size; + W_ chunk_size; IF_DEBUG(sanity,checkTSO(tso)); @@ -586,7 +586,7 @@ threadStackOverflow (Capability *cap, StgTSO *tso) { StgWord *sp; - nat chunk_words, size; + W_ chunk_words, size; // find the boundary of the chunk of old stack we're going to // copy to the new stack. We skip over stack frames until we @@ -659,7 +659,7 @@ threadStackOverflow (Capability *cap, StgTSO *tso) Stack underflow - called from the stg_stack_underflow_info frame ------------------------------------------------------------------------ */ -nat // returns offset to the return address +W_ // returns offset to the return address threadStackUnderflow (Capability *cap, StgTSO *tso) { StgStack *new_stack, *old_stack; @@ -681,7 +681,7 @@ threadStackUnderflow (Capability *cap, StgTSO *tso) if (retvals != 0) { // we have some return values to copy to the old stack - if ((nat)(new_stack->sp - new_stack->stack) < retvals) + if ((W_)(new_stack->sp - new_stack->stack) < retvals) { barf("threadStackUnderflow: not enough space for return values"); } diff --git a/rts/Threads.h b/rts/Threads.h index 857658a2d0..6d26610334 100644 --- a/rts/Threads.h +++ b/rts/Threads.h @@ -40,7 +40,7 @@ StgBool isThreadBound (StgTSO* tso); // Overfow/underflow void threadStackOverflow (Capability *cap, StgTSO *tso); -nat threadStackUnderflow (Capability *cap, StgTSO *tso); +W_ threadStackUnderflow (Capability *cap, StgTSO *tso); #ifdef DEBUG void printThreadBlockage (StgTSO *tso); diff --git a/rts/Trace.c b/rts/Trace.c index a946f2c5d3..7a08c0f817 100644 --- a/rts/Trace.c +++ b/rts/Trace.c @@ -203,38 +203,38 @@ static void traceSchedEvent_stderr (Capability *cap, EventTypeNum tag, tracePreface(); switch (tag) { case EVENT_CREATE_THREAD: // (cap, thread) - debugBelch("cap %d: created thread %" FMT_SizeT "\n", - cap->no, (lnat)tso->id); + debugBelch("cap %d: created thread %" FMT_Word "\n", + cap->no, (W_)tso->id); break; case EVENT_RUN_THREAD: // (cap, thread) - debugBelch("cap %d: running thread %" FMT_SizeT " (%s)\n", - cap->no, (lnat)tso->id, what_next_strs[tso->what_next]); + debugBelch("cap %d: running thread %" FMT_Word " (%s)\n", + cap->no, (W_)tso->id, what_next_strs[tso->what_next]); break; case EVENT_THREAD_RUNNABLE: // (cap, thread) - debugBelch("cap %d: thread %" FMT_SizeT " appended to run queue\n", - cap->no, (lnat)tso->id); + debugBelch("cap %d: thread %" FMT_Word " appended to run queue\n", + cap->no, (W_)tso->id); break; case EVENT_MIGRATE_THREAD: // (cap, thread, new_cap) - debugBelch("cap %d: thread %" FMT_SizeT " migrating to cap %d\n", - cap->no, (lnat)tso->id, (int)info1); + debugBelch("cap %d: thread %" FMT_Word " migrating to cap %d\n", + cap->no, (W_)tso->id, (int)info1); break; case EVENT_THREAD_WAKEUP: // (cap, thread, info1_cap) - debugBelch("cap %d: waking up thread %" FMT_SizeT " on cap %d\n", - cap->no, (lnat)tso->id, (int)info1); + debugBelch("cap %d: waking up thread %" FMT_Word " on cap %d\n", + cap->no, (W_)tso->id, (int)info1); break; case EVENT_STOP_THREAD: // (cap, thread, status) if (info1 == 6 + BlockedOnBlackHole) { - debugBelch("cap %d: thread %" FMT_SizeT " stopped (blocked on black hole owned by thread %lu)\n", - cap->no, (lnat)tso->id, (long)info2); + debugBelch("cap %d: thread %" FMT_Word " stopped (blocked on black hole owned by thread %lu)\n", + cap->no, (W_)tso->id, (long)info2); } else { - debugBelch("cap %d: thread %" FMT_SizeT " stopped (%s)\n", - cap->no, (lnat)tso->id, thread_stop_reasons[info1]); + debugBelch("cap %d: thread %" FMT_Word " stopped (%s)\n", + cap->no, (W_)tso->id, thread_stop_reasons[info1]); } break; default: - debugBelch("cap %d: thread %" FMT_SizeT ": event %d\n\n", - cap->no, (lnat)tso->id, tag); + debugBelch("cap %d: thread %" FMT_Word ": event %d\n\n", + cap->no, (W_)tso->id, tag); break; } @@ -324,7 +324,7 @@ void traceGcEventAtT_ (Capability *cap, StgWord64 ts, EventTypeNum tag) void traceHeapEvent_ (Capability *cap, EventTypeNum tag, CapsetID heap_capset, - lnat info1) + W_ info1) { #ifdef DEBUG if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) { @@ -338,10 +338,10 @@ void traceHeapEvent_ (Capability *cap, void traceEventHeapInfo_ (CapsetID heap_capset, nat gens, - lnat maxHeapSize, - lnat allocAreaSize, - lnat mblockSize, - lnat blockSize) + W_ maxHeapSize, + W_ allocAreaSize, + W_ mblockSize, + W_ blockSize) { #ifdef DEBUG if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) { @@ -358,12 +358,12 @@ void traceEventHeapInfo_ (CapsetID heap_capset, void traceEventGcStats_ (Capability *cap, CapsetID heap_capset, nat gen, - lnat copied, - lnat slop, - lnat fragmentation, + W_ copied, + W_ slop, + W_ fragmentation, nat par_n_threads, - lnat par_max_copied, - lnat par_tot_copied) + W_ par_max_copied, + W_ par_tot_copied) { #ifdef DEBUG if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) { @@ -423,18 +423,18 @@ void traceCapsetEvent (EventTypeNum tag, tracePreface(); switch (tag) { case EVENT_CAPSET_CREATE: // (capset, capset_type) - debugBelch("created capset %" FMT_SizeT " of type %d\n", (lnat)capset, (int)info); + debugBelch("created capset %" FMT_Word " of type %d\n", (W_)capset, (int)info); break; case EVENT_CAPSET_DELETE: // (capset) - debugBelch("deleted capset %" FMT_SizeT "\n", (lnat)capset); + debugBelch("deleted capset %" FMT_Word "\n", (W_)capset); break; case EVENT_CAPSET_ASSIGN_CAP: // (capset, capno) - debugBelch("assigned cap %" FMT_SizeT " to capset %" FMT_SizeT "\n", - (lnat)info, (lnat)capset); + debugBelch("assigned cap %" FMT_Word " to capset %" FMT_Word "\n", + (W_)info, (W_)capset); break; case EVENT_CAPSET_REMOVE_CAP: // (capset, capno) - debugBelch("removed cap %" FMT_SizeT " from capset %" FMT_SizeT "\n", - (lnat)info, (lnat)capset); + debugBelch("removed cap %" FMT_Word " from capset %" FMT_Word "\n", + (W_)info, (W_)capset); break; } RELEASE_LOCK(&trace_utx); @@ -716,8 +716,8 @@ void traceThreadLabel_(Capability *cap, if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) { ACQUIRE_LOCK(&trace_utx); tracePreface(); - debugBelch("cap %d: thread %" FMT_SizeT " has label %s\n", - cap->no, (lnat)tso->id, label); + debugBelch("cap %d: thread %" FMT_Word " has label %s\n", + cap->no, (W_)tso->id, label); RELEASE_LOCK(&trace_utx); } else #endif diff --git a/rts/Trace.h b/rts/Trace.h index b3710d32c9..4f1ac3bf0a 100644 --- a/rts/Trace.h +++ b/rts/Trace.h @@ -133,24 +133,24 @@ void traceGcEventAtT_ (Capability *cap, StgWord64 ts, EventTypeNum tag); void traceHeapEvent_ (Capability *cap, EventTypeNum tag, CapsetID heap_capset, - lnat info1); + W_ info1); void traceEventHeapInfo_ (CapsetID heap_capset, nat gens, - lnat maxHeapSize, - lnat allocAreaSize, - lnat mblockSize, - lnat blockSize); + W_ maxHeapSize, + W_ allocAreaSize, + W_ mblockSize, + W_ blockSize); void traceEventGcStats_ (Capability *cap, CapsetID heap_capset, nat gen, - lnat copied, - lnat slop, - lnat fragmentation, + W_ copied, + W_ slop, + W_ fragmentation, nat par_n_threads, - lnat par_max_copied, - lnat par_tot_copied); + W_ par_max_copied, + W_ par_tot_copied); /* * Record a spark event @@ -642,12 +642,12 @@ INLINE_HEADER void traceEventGcGlobalSync(Capability *cap STG_UNUSED) INLINE_HEADER void traceEventGcStats(Capability *cap STG_UNUSED, CapsetID heap_capset STG_UNUSED, nat gen STG_UNUSED, - lnat copied STG_UNUSED, - lnat slop STG_UNUSED, - lnat fragmentation STG_UNUSED, + W_ copied STG_UNUSED, + W_ slop STG_UNUSED, + W_ fragmentation STG_UNUSED, nat par_n_threads STG_UNUSED, - lnat par_max_copied STG_UNUSED, - lnat par_tot_copied STG_UNUSED) + W_ par_max_copied STG_UNUSED, + W_ par_tot_copied STG_UNUSED) { if (RTS_UNLIKELY(TRACE_gc)) { traceEventGcStats_(cap, heap_capset, gen, @@ -661,10 +661,10 @@ INLINE_HEADER void traceEventGcStats(Capability *cap STG_UNUSED, INLINE_HEADER void traceEventHeapInfo(CapsetID heap_capset STG_UNUSED, nat gens STG_UNUSED, - lnat maxHeapSize STG_UNUSED, - lnat allocAreaSize STG_UNUSED, - lnat mblockSize STG_UNUSED, - lnat blockSize STG_UNUSED) + W_ maxHeapSize STG_UNUSED, + W_ allocAreaSize STG_UNUSED, + W_ mblockSize STG_UNUSED, + W_ blockSize STG_UNUSED) { if (RTS_UNLIKELY(TRACE_gc)) { traceEventHeapInfo_(heap_capset, gens, @@ -678,7 +678,7 @@ INLINE_HEADER void traceEventHeapInfo(CapsetID heap_capset STG_UNUSED, INLINE_HEADER void traceEventHeapAllocated(Capability *cap STG_UNUSED, CapsetID heap_capset STG_UNUSED, - lnat allocated STG_UNUSED) + W_ allocated STG_UNUSED) { traceHeapEvent(cap, EVENT_HEAP_ALLOCATED, heap_capset, allocated); dtraceEventHeapAllocated((EventCapNo)cap->no, heap_capset, allocated); @@ -686,7 +686,7 @@ INLINE_HEADER void traceEventHeapAllocated(Capability *cap STG_UNUSED, INLINE_HEADER void traceEventHeapSize(Capability *cap STG_UNUSED, CapsetID heap_capset STG_UNUSED, - lnat heap_size STG_UNUSED) + W_ heap_size STG_UNUSED) { traceHeapEvent(cap, EVENT_HEAP_SIZE, heap_capset, heap_size); dtraceEventHeapSize(heap_capset, heap_size); @@ -694,7 +694,7 @@ INLINE_HEADER void traceEventHeapSize(Capability *cap STG_UNUSED, INLINE_HEADER void traceEventHeapLive(Capability *cap STG_UNUSED, CapsetID heap_capset STG_UNUSED, - lnat heap_live STG_UNUSED) + W_ heap_live STG_UNUSED) { traceHeapEvent(cap, EVENT_HEAP_LIVE, heap_capset, heap_live); dtraceEventHeapLive(heap_capset, heap_live); diff --git a/rts/eventlog/EventLog.c b/rts/eventlog/EventLog.c index b6614b940c..81aaecb67d 100644 --- a/rts/eventlog/EventLog.c +++ b/rts/eventlog/EventLog.c @@ -851,7 +851,7 @@ void postWallClockTime (EventCapsetID capset) void postHeapEvent (Capability *cap, EventTypeNum tag, EventCapsetID heap_capset, - lnat info1) + W_ info1) { EventsBuf *eb; @@ -881,10 +881,10 @@ void postHeapEvent (Capability *cap, void postEventHeapInfo (EventCapsetID heap_capset, nat gens, - lnat maxHeapSize, - lnat allocAreaSize, - lnat mblockSize, - lnat blockSize) + W_ maxHeapSize, + W_ allocAreaSize, + W_ mblockSize, + W_ blockSize) { ACQUIRE_LOCK(&eventBufMutex); @@ -910,12 +910,12 @@ void postEventHeapInfo (EventCapsetID heap_capset, void postEventGcStats (Capability *cap, EventCapsetID heap_capset, nat gen, - lnat copied, - lnat slop, - lnat fragmentation, + W_ copied, + W_ slop, + W_ fragmentation, nat par_n_threads, - lnat par_max_copied, - lnat par_tot_copied) + W_ par_max_copied, + W_ par_tot_copied) { EventsBuf *eb; diff --git a/rts/eventlog/EventLog.h b/rts/eventlog/EventLog.h index 93dd9a8144..5861f64757 100644 --- a/rts/eventlog/EventLog.h +++ b/rts/eventlog/EventLog.h @@ -106,24 +106,24 @@ void postThreadLabel(Capability *cap, void postHeapEvent (Capability *cap, EventTypeNum tag, EventCapsetID heap_capset, - lnat info1); + W_ info1); void postEventHeapInfo (EventCapsetID heap_capset, nat gens, - lnat maxHeapSize, - lnat allocAreaSize, - lnat mblockSize, - lnat blockSize); + W_ maxHeapSize, + W_ allocAreaSize, + W_ mblockSize, + W_ blockSize); void postEventGcStats (Capability *cap, EventCapsetID heap_capset, nat gen, - lnat copied, - lnat slop, - lnat fragmentation, + W_ copied, + W_ slop, + W_ fragmentation, nat par_n_threads, - lnat par_max_copied, - lnat par_tot_copied); + W_ par_max_copied, + W_ par_tot_copied); void postTaskCreateEvent (EventTaskId taskId, EventCapNo cap, diff --git a/rts/hooks/MallocFail.c b/rts/hooks/MallocFail.c index e298c2ee77..6c3a1a0faf 100644 --- a/rts/hooks/MallocFail.c +++ b/rts/hooks/MallocFail.c @@ -10,8 +10,8 @@ #include <stdio.h> void -MallocFailHook (lnat request_size /* in bytes */, char *msg) +MallocFailHook (W_ request_size /* in bytes */, char *msg) { - fprintf(stderr, "malloc: failed on request for %" FMT_SizeT " bytes; message: %s\n", request_size, msg); + fprintf(stderr, "malloc: failed on request for %" FMT_Word " bytes; message: %s\n", request_size, msg); } diff --git a/rts/hooks/OutOfHeap.c b/rts/hooks/OutOfHeap.c index 5ed5ed9b96..ec4697b547 100644 --- a/rts/hooks/OutOfHeap.c +++ b/rts/hooks/OutOfHeap.c @@ -9,13 +9,13 @@ #include <stdio.h> void -OutOfHeapHook (lnat request_size, lnat heap_size) /* both sizes in bytes */ +OutOfHeapHook (W_ request_size, W_ heap_size) /* both sizes in bytes */ { /* fprintf(stderr, "Heap exhausted;\nwhile trying to allocate %lu bytes in a %lu-byte heap;\nuse `+RTS -H<size>' to increase the total heap size.\n", */ (void)request_size; /* keep gcc -Wall happy */ if (heap_size > 0) { - errorBelch("Heap exhausted;\nCurrent maximum heap size is %" FMT_SizeT " bytes (%" FMT_SizeT " MB);\nuse `+RTS -M<size>' to increase it.", + errorBelch("Heap exhausted;\nCurrent maximum heap size is %" FMT_Word " bytes (%" FMT_Word " MB);\nuse `+RTS -M<size>' to increase it.", heap_size, heap_size / (1024*1024)); } else { errorBelch("out of memory"); diff --git a/rts/hooks/StackOverflow.c b/rts/hooks/StackOverflow.c index fe8a059b7f..407293902d 100644 --- a/rts/hooks/StackOverflow.c +++ b/rts/hooks/StackOverflow.c @@ -10,8 +10,8 @@ #include <stdio.h> void -StackOverflowHook (lnat stack_size) /* in bytes */ +StackOverflowHook (W_ stack_size) /* in bytes */ { - fprintf(stderr, "Stack space overflow: current size %" FMT_SizeT " bytes.\nUse `+RTS -Ksize -RTS' to increase it.\n", stack_size); + fprintf(stderr, "Stack space overflow: current size %" FMT_Word " bytes.\nUse `+RTS -Ksize -RTS' to increase it.\n", stack_size); } diff --git a/rts/package.conf.in b/rts/package.conf.in index 727b586a09..9068549e21 100644 --- a/rts/package.conf.in +++ b/rts/package.conf.in @@ -53,7 +53,7 @@ extra-libraries: #ifdef INSTALLING include-dirs: INCLUDE_DIR PAPI_INCLUDE_DIR #else /* !INSTALLING */ -include-dirs: TOP"/rts/dist/build" TOP"/includes" TOP"/includes/dist-ghcconstants/header" TOP"/includes/dist-derivedconstants/header" +include-dirs: TOP"/rts/dist/build" TOP"/includes" TOP"/includes/dist-derivedconstants/header" #endif includes: Stg.h diff --git a/rts/parallel/ParTicky.c b/rts/parallel/ParTicky.c index 5f3e3e323c..07e3ba9390 100644 --- a/rts/parallel/ParTicky.c +++ b/rts/parallel/ParTicky.c @@ -30,8 +30,8 @@ extern double ElapsedTimeStart; extern StgWord64 GC_tot_alloc; extern StgWord64 GC_tot_copied; -extern lnat MaxResidency; /* in words; for stats only */ -extern lnat ResidencySamples; /* for stats only */ +extern W_ MaxResidency; /* in words; for stats only */ +extern W_ ResidencySamples; /* for stats only */ /* ngIplu' {Stats.c}vo' */ #define BIG_STRING_LEN 512 diff --git a/rts/posix/GetTime.c b/rts/posix/GetTime.c index fabc40431d..bcee6ce127 100644 --- a/rts/posix/GetTime.c +++ b/rts/posix/GetTime.c @@ -218,7 +218,7 @@ void getUnixEpochTime(StgWord64 *sec, StgWord32 *nsec) #endif } -nat +W_ getPageFaults(void) { #if !defined(HAVE_GETRUSAGE) || irix_HOST_OS || haiku_HOST_OS diff --git a/rts/posix/OSMem.c b/rts/posix/OSMem.c index 509fc5e88d..2237972837 100644 --- a/rts/posix/OSMem.c +++ b/rts/posix/OSMem.c @@ -75,7 +75,7 @@ void osMemInit(void) // the mmap() interface. static void * -my_mmap (void *addr, lnat size) +my_mmap (void *addr, W_ size) { void *ret; @@ -107,7 +107,7 @@ my_mmap (void *addr, lnat size) if(err) { // don't know what the error codes mean exactly, assume it's // not our problem though. - errorBelch("memory allocation failed (requested %lu bytes)", size); + errorBelch("memory allocation failed (requested %" FMT_Word " bytes)", size); stg_exit(EXIT_FAILURE); } else { vm_protect(mach_task_self(),(vm_address_t)ret,size,FALSE,VM_PROT_READ|VM_PROT_WRITE); @@ -122,7 +122,7 @@ my_mmap (void *addr, lnat size) (errno == EINVAL && sizeof(void*)==4 && size >= 0xc0000000)) { // If we request more than 3Gig, then we get EINVAL // instead of ENOMEM (at least on Linux). - errorBelch("out of memory (requested %" FMT_SizeT " bytes)", size); + errorBelch("out of memory (requested %" FMT_Word " bytes)", size); stg_exit(EXIT_FAILURE); } else { barf("getMBlock: mmap: %s", strerror(errno)); @@ -136,7 +136,7 @@ my_mmap (void *addr, lnat size) // mblocks. static void * -gen_map_mblocks (lnat size) +gen_map_mblocks (W_ size) { int slop; StgWord8 *ret; @@ -177,7 +177,7 @@ void * osGetMBlocks(nat n) { caddr_t ret; - lnat size = MBLOCK_SIZE * (lnat)n; + W_ size = MBLOCK_SIZE * (W_)n; if (next_request == 0) { // use gen_map_mblocks the first time. @@ -226,9 +226,9 @@ void osFreeAllMBlocks(void) } } -lnat getPageSize (void) +W_ getPageSize (void) { - static lnat pageSize = 0; + static W_ pageSize = 0; if (pageSize) { return pageSize; } else { @@ -241,7 +241,7 @@ lnat getPageSize (void) } } -void setExecutable (void *p, lnat len, rtsBool exec) +void setExecutable (void *p, W_ len, rtsBool exec) { StgWord pageSize = getPageSize(); diff --git a/rts/sm/BlockAlloc.c b/rts/sm/BlockAlloc.c index 9fd3ef577a..f0f6fb551c 100644 --- a/rts/sm/BlockAlloc.c +++ b/rts/sm/BlockAlloc.c @@ -142,8 +142,8 @@ static bdescr *free_mblock_list; // To find the free list in which to place a block, use log_2(size). // To find a free block of the right size, use log_2_ceil(size). -lnat n_alloc_blocks; // currently allocated blocks -lnat hw_alloc_blocks; // high-water allocated blocks +W_ n_alloc_blocks; // currently allocated blocks +W_ hw_alloc_blocks; // high-water allocated blocks /* ----------------------------------------------------------------------------- Initialisation @@ -168,7 +168,7 @@ STATIC_INLINE void initGroup(bdescr *head) { bdescr *bd; - nat i, n; + W_ i, n; n = head->blocks; head->free = head->start; @@ -184,9 +184,9 @@ initGroup(bdescr *head) // usually small, and MAX_FREE_LIST is also small, so the loop version // might well be the best choice here. STATIC_INLINE nat -log_2_ceil(nat n) +log_2_ceil(W_ n) { - nat i, x; + W_ i, x; x = 1; for (i=0; i < MAX_FREE_LIST; i++) { if (x >= n) return i; @@ -196,9 +196,9 @@ log_2_ceil(nat n) } STATIC_INLINE nat -log_2(nat n) +log_2(W_ n) { - nat i, x; + W_ i, x; x = n; for (i=0; i < MAX_FREE_LIST; i++) { x = x >> 1; @@ -244,7 +244,7 @@ setup_tail (bdescr *bd) // Take a free block group bd, and split off a group of size n from // it. Adjust the free list as necessary, and return the new group. static bdescr * -split_free_block (bdescr *bd, nat n, nat ln) +split_free_block (bdescr *bd, W_ n, nat ln) { bdescr *fg; // free group @@ -311,7 +311,7 @@ alloc_mega_group (nat mblocks) } bdescr * -allocGroup (nat n) +allocGroup (W_ n) { bdescr *bd, *rem; nat ln; @@ -390,42 +390,58 @@ finish: } // -// Allocate a chunk of blocks that is at most a megablock in size. -// This API is used by the nursery allocator that wants contiguous -// memory preferably, but doesn't require it. When memory is -// fragmented we might have lots of large chunks that are less than a -// full megablock, so allowing the nursery allocator to use these -// reduces fragmentation considerably. e.g. on a GHC build with +RTS -// -H, I saw fragmentation go from 17MB down to 3MB on a single compile. +// Allocate a chunk of blocks that is at least min and at most max +// blocks in size. This API is used by the nursery allocator that +// wants contiguous memory preferably, but doesn't require it. When +// memory is fragmented we might have lots of large chunks that are +// less than a full megablock, so allowing the nursery allocator to +// use these reduces fragmentation considerably. e.g. on a GHC build +// with +RTS -H, I saw fragmentation go from 17MB down to 3MB on a +// single compile. // bdescr * -allocLargeChunk (void) +allocLargeChunk (W_ min, W_ max) { bdescr *bd; - nat ln; + nat ln, lnmax; - ln = 5; // start in the 32-63 block bucket - while (ln < MAX_FREE_LIST && free_list[ln] == NULL) { + if (min >= BLOCKS_PER_MBLOCK) { + return allocGroup(max); + } + + ln = log_2_ceil(min); + lnmax = log_2_ceil(max); // tops out at MAX_FREE_LIST + + while (ln < lnmax && free_list[ln] == NULL) { ln++; } - if (ln == MAX_FREE_LIST) { - return allocGroup(BLOCKS_PER_MBLOCK); + if (ln == lnmax) { + return allocGroup(max); } bd = free_list[ln]; + if (bd->blocks <= max) // exactly the right size! + { + dbl_link_remove(bd, &free_list[ln]); + initGroup(bd); + } + else // block too big... + { + bd = split_free_block(bd, max, ln); + ASSERT(bd->blocks == max); + initGroup(bd); + } + n_alloc_blocks += bd->blocks; if (n_alloc_blocks > hw_alloc_blocks) hw_alloc_blocks = n_alloc_blocks; - dbl_link_remove(bd, &free_list[ln]); - initGroup(bd); - IF_DEBUG(sanity, memset(bd->start, 0xaa, bd->blocks * BLOCK_SIZE)); IF_DEBUG(sanity, checkFreeListSanity()); return bd; } bdescr * -allocGroup_lock(nat n) +allocGroup_lock(W_ n) { bdescr *bd; ACQUIRE_SM_LOCK; @@ -637,10 +653,10 @@ initMBlock(void *mblock) Stats / metrics -------------------------------------------------------------------------- */ -nat +W_ countBlocks(bdescr *bd) { - nat n; + W_ n; for (n=0; bd != NULL; bd=bd->link) { n += bd->blocks; } @@ -652,10 +668,10 @@ countBlocks(bdescr *bd) // that would be taken up by block descriptors in the second and // subsequent megablock. This is so we can tally the count with the // number of blocks allocated in the system, for memInventory(). -nat +W_ countAllocdBlocks(bdescr *bd) { - nat n; + W_ n; for (n=0; bd != NULL; bd=bd->link) { n += bd->blocks; // hack for megablock groups: see (*1) above @@ -790,11 +806,11 @@ checkFreeListSanity(void) } } -nat /* BLOCKS */ +W_ /* BLOCKS */ countFreeList(void) { bdescr *bd; - lnat total_blocks = 0; + W_ total_blocks = 0; nat ln; for (ln=0; ln < MAX_FREE_LIST; ln++) { diff --git a/rts/sm/BlockAlloc.h b/rts/sm/BlockAlloc.h index d26bb24cff..aebb71a913 100644 --- a/rts/sm/BlockAlloc.h +++ b/rts/sm/BlockAlloc.h @@ -11,23 +11,23 @@ #include "BeginPrivate.h" -bdescr *allocLargeChunk (void); +bdescr *allocLargeChunk (W_ min, W_ max); /* Debugging -------------------------------------------------------------- */ -extern nat countBlocks (bdescr *bd); -extern nat countAllocdBlocks (bdescr *bd); +extern W_ countBlocks (bdescr *bd); +extern W_ countAllocdBlocks (bdescr *bd); extern void returnMemoryToOS(nat n); #ifdef DEBUG void checkFreeListSanity(void); -nat countFreeList(void); +W_ countFreeList(void); void markBlocks (bdescr *bd); void reportUnmarkedBlocks (void); #endif -extern lnat n_alloc_blocks; // currently allocated blocks -extern lnat hw_alloc_blocks; // high-water allocated blocks +extern W_ n_alloc_blocks; // currently allocated blocks +extern W_ hw_alloc_blocks; // high-water allocated blocks #include "EndPrivate.h" diff --git a/rts/sm/Compact.c b/rts/sm/Compact.c index 6a50f436d7..c97e168433 100644 --- a/rts/sm/Compact.c +++ b/rts/sm/Compact.c @@ -183,7 +183,7 @@ loop: // A word-aligned memmove will be faster for small objects than libc's or gcc's. // Remember, the two regions *might* overlap, but: to <= from. STATIC_INLINE void -move(StgPtr to, StgPtr from, nat size) +move(StgPtr to, StgPtr from, W_ size) { for(; size > 0; --size) { *to++ = *from++; @@ -225,9 +225,9 @@ thread_static( StgClosure* p ) } STATIC_INLINE void -thread_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size ) +thread_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, W_ size ) { - nat i, b; + W_ i, b; StgWord bitmap; b = 0; @@ -252,7 +252,7 @@ thread_arg_block (StgFunInfoTable *fun_info, StgClosure **args) { StgPtr p; StgWord bitmap; - nat size; + W_ size; p = (StgPtr)args; switch (fun_info->f.fun_type) { @@ -287,7 +287,7 @@ thread_stack(StgPtr p, StgPtr stack_end) { const StgRetInfoTable* info; StgWord bitmap; - nat size; + W_ size; // highly similar to scavenge_stack, but we do pointer threading here. @@ -846,7 +846,7 @@ update_fwd_compact( bdescr *blocks ) } } -static nat +static W_ update_bkwd_compact( generation *gen ) { StgPtr p, free; @@ -855,7 +855,7 @@ update_bkwd_compact( generation *gen ) #endif bdescr *bd, *free_bd; StgInfoTable *info; - nat size, free_blocks; + W_ size, free_blocks; StgWord iptr; bd = free_bd = gen->old_blocks; @@ -937,7 +937,7 @@ update_bkwd_compact( generation *gen ) void compact(StgClosure *static_objects) { - nat n, g, blocks; + W_ n, g, blocks; generation *gen; // 1. thread the roots diff --git a/rts/sm/Evac.h b/rts/sm/Evac.h index ad56c644d8..cea2be63ae 100644 --- a/rts/sm/Evac.h +++ b/rts/sm/Evac.h @@ -35,7 +35,7 @@ REGPARM1 void evacuate (StgClosure **p); REGPARM1 void evacuate1 (StgClosure **p); -extern lnat thunk_selector_depth; +extern W_ thunk_selector_depth; #include "EndPrivate.h" diff --git a/rts/sm/GC.c b/rts/sm/GC.c index 1b81b260c9..7bdaef5868 100644 --- a/rts/sm/GC.c +++ b/rts/sm/GC.c @@ -102,7 +102,7 @@ rtsBool major_gc; /* Data used for allocation area sizing. */ -static lnat g0_pcnt_kept = 30; // percentage of g0 live at last minor GC +static W_ g0_pcnt_kept = 30; // percentage of g0 live at last minor GC /* Mut-list stats */ #ifdef DEBUG @@ -149,7 +149,7 @@ static StgWord dec_running (void); static void wakeup_gc_threads (nat me); static void shutdown_gc_threads (nat me); static void collect_gct_blocks (void); -static lnat collect_pinned_object_blocks (void); +static StgWord collect_pinned_object_blocks (void); #if 0 && defined(DEBUG) static void gcCAFs (void); @@ -179,7 +179,7 @@ GarbageCollect (nat collect_gen, { bdescr *bd; generation *gen; - lnat live_blocks, live_words, allocated, par_max_copied, par_tot_copied; + StgWord live_blocks, live_words, allocated, par_max_copied, par_tot_copied; #if defined(THREADED_RTS) gc_thread *saved_gct; #endif @@ -488,7 +488,7 @@ GarbageCollect (nat collect_gen, // Count the mutable list as bytes "copied" for the purposes of // stats. Every mutable list is copied during every GC. if (g > 0) { - nat mut_list_size = 0; + W_ mut_list_size = 0; for (n = 0; n < n_capabilities; n++) { mut_list_size += countOccupied(capabilities[n].mut_lists[g]); } @@ -710,7 +710,7 @@ GarbageCollect (nat collect_gen, ACQUIRE_SM_LOCK; if (major_gc) { - nat need, got; + W_ need, got; need = BLOCKS_TO_MBLOCKS(n_alloc_blocks); got = mblocks_allocated; /* If the amount of data remains constant, next major GC we'll @@ -1275,14 +1275,14 @@ prepare_collected_gen (generation *gen) // for a compacted generation, we need to allocate the bitmap if (gen->mark) { - lnat bitmap_size; // in bytes + StgWord bitmap_size; // in bytes bdescr *bitmap_bdescr; StgWord *bitmap; bitmap_size = gen->n_old_blocks * BLOCK_SIZE / (sizeof(W_)*BITS_PER_BYTE); - + if (bitmap_size > 0) { - bitmap_bdescr = allocGroup((lnat)BLOCK_ROUND_UP(bitmap_size) + bitmap_bdescr = allocGroup((StgWord)BLOCK_ROUND_UP(bitmap_size) / BLOCK_SIZE); gen->bitmap = bitmap_bdescr; bitmap = bitmap_bdescr->start; @@ -1405,12 +1405,12 @@ collect_gct_blocks (void) purposes. -------------------------------------------------------------------------- */ -static lnat +static StgWord collect_pinned_object_blocks (void) { nat n; bdescr *bd, *prev; - lnat allocated = 0; + StgWord allocated = 0; for (n = 0; n < n_capabilities; n++) { prev = NULL; @@ -1510,9 +1510,9 @@ resize_generations (void) nat g; if (major_gc && RtsFlags.GcFlags.generations > 1) { - nat live, size, min_alloc, words; - const nat max = RtsFlags.GcFlags.maxHeapSize; - const nat gens = RtsFlags.GcFlags.generations; + W_ live, size, min_alloc, words; + const W_ max = RtsFlags.GcFlags.maxHeapSize; + const W_ gens = RtsFlags.GcFlags.generations; // live in the oldest generations if (oldest_gen->live_estimate != 0) { @@ -1528,7 +1528,11 @@ resize_generations (void) RtsFlags.GcFlags.minOldGenSize); if (RtsFlags.GcFlags.heapSizeSuggestionAuto) { - RtsFlags.GcFlags.heapSizeSuggestion = size; + if (max > 0) { + RtsFlags.GcFlags.heapSizeSuggestion = stg_min(max, size); + } else { + RtsFlags.GcFlags.heapSizeSuggestion = size; + } } // minimum size for generation zero @@ -1600,11 +1604,11 @@ resize_generations (void) static void resize_nursery (void) { - const lnat min_nursery = RtsFlags.GcFlags.minAllocAreaSize * n_capabilities; + const StgWord min_nursery = RtsFlags.GcFlags.minAllocAreaSize * n_capabilities; if (RtsFlags.GcFlags.generations == 1) { // Two-space collector: - nat blocks; + W_ blocks; /* set up a new nursery. Allocate a nursery size based on a * function of the amount of live data (by default a factor of 2) @@ -1660,7 +1664,7 @@ resize_nursery (void) if (RtsFlags.GcFlags.heapSizeSuggestion) { long blocks; - lnat needed; + StgWord needed; calcNeeded(rtsFalse, &needed); // approx blocks needed at next GC @@ -1699,7 +1703,7 @@ resize_nursery (void) blocks = min_nursery; } - resizeNurseries((nat)blocks); + resizeNurseries((W_)blocks); } else { diff --git a/rts/sm/GCThread.h b/rts/sm/GCThread.h index 1b811e43fc..7d163cb48a 100644 --- a/rts/sm/GCThread.h +++ b/rts/sm/GCThread.h @@ -134,7 +134,7 @@ typedef struct gc_thread_ { StgClosure* static_objects; // live static objects StgClosure* scavenged_static_objects; // static objects scavenged so far - lnat gc_count; // number of GCs this thread has done + W_ gc_count; // number of GCs this thread has done // block that is currently being scanned bdescr * scan_bd; @@ -166,7 +166,7 @@ typedef struct gc_thread_ { // instead of the to-space // corresponding to the object - lnat thunk_selector_depth; // used to avoid unbounded recursion in + W_ thunk_selector_depth; // used to avoid unbounded recursion in // evacuate() for THUNK_SELECTOR #ifdef USE_PAPI @@ -176,17 +176,17 @@ typedef struct gc_thread_ { // ------------------- // stats - lnat allocated; // result of clearNursery() - lnat copied; - lnat scanned; - lnat any_work; - lnat no_work; - lnat scav_find_work; + W_ allocated; // result of clearNursery() + W_ copied; + W_ scanned; + W_ any_work; + W_ no_work; + W_ scav_find_work; Time gc_start_cpu; // process CPU time Time gc_start_elapsed; // process elapsed time Time gc_start_thread_cpu; // thread CPU time - lnat gc_start_faults; + W_ gc_start_faults; // ------------------- // workspaces diff --git a/rts/sm/GCUtils.c b/rts/sm/GCUtils.c index 677998ff14..996b5f6280 100644 --- a/rts/sm/GCUtils.c +++ b/rts/sm/GCUtils.c @@ -263,7 +263,7 @@ alloc_todo_block (gen_workspace *ws, nat size) // bd = hd; if (size > BLOCK_SIZE_W) { - bd = allocGroup_sync((lnat)BLOCK_ROUND_UP(size*sizeof(W_)) + bd = allocGroup_sync((W_)BLOCK_ROUND_UP(size*sizeof(W_)) / BLOCK_SIZE); } else { bd = allocBlock_sync(); diff --git a/rts/sm/MBlock.c b/rts/sm/MBlock.c index 1801086c2a..6bc4049959 100644 --- a/rts/sm/MBlock.c +++ b/rts/sm/MBlock.c @@ -18,9 +18,9 @@ #include <string.h> -lnat peak_mblocks_allocated = 0; -lnat mblocks_allocated = 0; -lnat mpc_misses = 0; +W_ peak_mblocks_allocated = 0; +W_ mblocks_allocated = 0; +W_ mpc_misses = 0; /* ----------------------------------------------------------------------------- The MBlock Map: provides our implementation of HEAP_ALLOCED() diff --git a/rts/sm/OSMem.h b/rts/sm/OSMem.h index b3003edd1e..a0d615b424 100644 --- a/rts/sm/OSMem.h +++ b/rts/sm/OSMem.h @@ -16,8 +16,8 @@ void *osGetMBlocks(nat n); void osFreeMBlocks(char *addr, nat n); void osReleaseFreeMemory(void); void osFreeAllMBlocks(void); -lnat getPageSize (void); -void setExecutable (void *p, lnat len, rtsBool exec); +W_ getPageSize (void); +void setExecutable (void *p, W_ len, rtsBool exec); #include "EndPrivate.h" diff --git a/rts/sm/Sanity.c b/rts/sm/Sanity.c index 99cea93d2e..5c7fb8aa76 100644 --- a/rts/sm/Sanity.c +++ b/rts/sm/Sanity.c @@ -830,7 +830,7 @@ checkRunQueue(Capability *cap) void findSlop(bdescr *bd); void findSlop(bdescr *bd) { - lnat slop; + W_ slop; for (; bd != NULL; bd = bd->link) { slop = (bd->blocks * BLOCK_SIZE_W) - (bd->free - bd->start); @@ -841,7 +841,7 @@ void findSlop(bdescr *bd) } } -static lnat +static W_ genBlocks (generation *gen) { ASSERT(countBlocks(gen->blocks) == gen->n_blocks); @@ -854,10 +854,10 @@ void memInventory (rtsBool show) { nat g, i; - lnat gen_blocks[RtsFlags.GcFlags.generations]; - lnat nursery_blocks, retainer_blocks, + W_ gen_blocks[RtsFlags.GcFlags.generations]; + W_ nursery_blocks, retainer_blocks, arena_blocks, exec_blocks; - lnat live_blocks = 0, free_blocks = 0; + W_ live_blocks = 0, free_blocks = 0; rtsBool leak; // count the blocks we current have @@ -906,7 +906,7 @@ memInventory (rtsBool show) live_blocks += nursery_blocks + + retainer_blocks + arena_blocks + exec_blocks; -#define MB(n) (((n) * BLOCK_SIZE_W) / ((1024*1024)/sizeof(W_))) +#define MB(n) (((double)(n) * BLOCK_SIZE_W) / ((1024*1024)/sizeof(W_))) leak = live_blocks + free_blocks != mblocks_allocated * BLOCKS_PER_MBLOCK; @@ -918,23 +918,23 @@ memInventory (rtsBool show) debugBelch("Memory inventory:\n"); } for (g = 0; g < RtsFlags.GcFlags.generations; g++) { - debugBelch(" gen %d blocks : %5" FMT_SizeT " blocks (%" FMT_SizeT " MB)\n", g, + debugBelch(" gen %d blocks : %5" FMT_Word " blocks (%6.1lf MB)\n", g, gen_blocks[g], MB(gen_blocks[g])); } - debugBelch(" nursery : %5" FMT_SizeT " blocks (%" FMT_SizeT " MB)\n", + debugBelch(" nursery : %5" FMT_Word " blocks (%6.1lf MB)\n", nursery_blocks, MB(nursery_blocks)); - debugBelch(" retainer : %5" FMT_SizeT " blocks (%" FMT_SizeT " MB)\n", + debugBelch(" retainer : %5" FMT_Word " blocks (%6.1lf MB)\n", retainer_blocks, MB(retainer_blocks)); - debugBelch(" arena blocks : %5" FMT_SizeT " blocks (%" FMT_SizeT " MB)\n", + debugBelch(" arena blocks : %5" FMT_Word " blocks (%6.1lf MB)\n", arena_blocks, MB(arena_blocks)); - debugBelch(" exec : %5" FMT_SizeT " blocks (%" FMT_SizeT " MB)\n", + debugBelch(" exec : %5" FMT_Word " blocks (%6.1lf MB)\n", exec_blocks, MB(exec_blocks)); - debugBelch(" free : %5" FMT_SizeT " blocks (%" FMT_SizeT " MB)\n", + debugBelch(" free : %5" FMT_Word " blocks (%6.1lf MB)\n", free_blocks, MB(free_blocks)); - debugBelch(" total : %5" FMT_SizeT " blocks (%" FMT_SizeT " MB)\n", + debugBelch(" total : %5" FMT_Word " blocks (%6.1lf MB)\n", live_blocks + free_blocks, MB(live_blocks+free_blocks)); if (leak) { - debugBelch("\n in system : %5" FMT_SizeT " blocks (%" FMT_SizeT " MB)\n", + debugBelch("\n in system : %5" FMT_Word " blocks (%" FMT_Word " MB)\n", mblocks_allocated * BLOCKS_PER_MBLOCK, mblocks_allocated); } } diff --git a/rts/sm/Scav.c b/rts/sm/Scav.c index e7e02e6c99..cbdf01b720 100644 --- a/rts/sm/Scav.c +++ b/rts/sm/Scav.c @@ -98,7 +98,7 @@ scavengeTSO (StgTSO *tso) static StgPtr scavenge_mut_arr_ptrs (StgMutArrPtrs *a) { - lnat m; + W_ m; rtsBool any_failed; StgPtr p, q; @@ -140,7 +140,7 @@ static StgPtr scavenge_mut_arr_ptrs (StgMutArrPtrs *a) // scavenge only the marked areas of a MUT_ARR_PTRS static StgPtr scavenge_mut_arr_ptrs_marked (StgMutArrPtrs *a) { - lnat m; + W_ m; StgPtr p, q; rtsBool any_failed; @@ -322,8 +322,8 @@ scavenge_srt (StgClosure **srt, nat srt_bitmap) // // If the SRT entry hasn't got bit 0 set, the SRT entry points to a // closure that's fixed at link-time, and no extra magic is required. - if ( (lnat)(*srt) & 0x1 ) { - evacuate( (StgClosure**) ((lnat) (*srt) & ~0x1)); + if ( (W_)(*srt) & 0x1 ) { + evacuate( (StgClosure**) ((W_) (*srt) & ~0x1)); } else { evacuate(p); } diff --git a/rts/sm/Storage.c b/rts/sm/Storage.c index 6b32593aba..541da5df1c 100644 --- a/rts/sm/Storage.c +++ b/rts/sm/Storage.c @@ -41,8 +41,8 @@ StgClosure *caf_list = NULL; StgClosure *revertible_caf_list = NULL; rtsBool keepCAFs; -nat large_alloc_lim; /* GC if n_large_blocks in any nursery - * reaches this. */ +W_ large_alloc_lim; /* GC if n_large_blocks in any nursery + * reaches this. */ bdescr *exec_block; @@ -235,7 +235,7 @@ void storageAddCapabilities (nat from, nat to) void exitStorage (void) { - lnat allocated = updateNurseriesStats(); + W_ allocated = updateNurseriesStats(); stat_exit(allocated); } @@ -425,10 +425,10 @@ newDynCAF (StgRegTable *reg STG_UNUSED, StgClosure *caf, StgClosure *bh) -------------------------------------------------------------------------- */ static bdescr * -allocNursery (bdescr *tail, nat blocks) +allocNursery (bdescr *tail, W_ blocks) { bdescr *bd = NULL; - nat i, n; + W_ i, n; // We allocate the nursery as a single contiguous block and then // divide it into single blocks manually. This way we guarantee @@ -437,8 +437,10 @@ allocNursery (bdescr *tail, nat blocks) // tiny optimisation (~0.5%), but it's free. while (blocks > 0) { - if (blocks >= BLOCKS_PER_MBLOCK) { - bd = allocLargeChunk(); // see comment with allocLargeChunk() + if (blocks >= BLOCKS_PER_MBLOCK / 4) { + n = stg_min(BLOCKS_PER_MBLOCK, blocks); + bd = allocLargeChunk(16, n); // see comment with allocLargeChunk() + // NB. we want a nice power of 2 for the minimum here n = bd->blocks; } else { bd = allocGroup(blocks); @@ -502,15 +504,15 @@ allocNurseries (nat from, nat to) assignNurseriesToCapabilities(from, to); } -lnat +W_ clearNursery (Capability *cap) { bdescr *bd; - lnat allocated = 0; + W_ allocated = 0; for (bd = nurseries[cap->no].blocks; bd; bd = bd->link) { - allocated += (lnat)(bd->free - bd->start); - cap->total_allocated += (lnat)(bd->free - bd->start); + allocated += (W_)(bd->free - bd->start); + cap->total_allocated += (W_)(bd->free - bd->start); bd->free = bd->start; ASSERT(bd->gen_no == 0); ASSERT(bd->gen == g0); @@ -526,11 +528,11 @@ resetNurseries (void) assignNurseriesToCapabilities(0, n_capabilities); } -lnat +W_ countNurseryBlocks (void) { nat i; - lnat blocks = 0; + W_ blocks = 0; for (i = 0; i < n_capabilities; i++) { blocks += nurseries[i].n_blocks; @@ -539,10 +541,10 @@ countNurseryBlocks (void) } static void -resizeNursery (nursery *nursery, nat blocks) +resizeNursery (nursery *nursery, W_ blocks) { bdescr *bd; - nat nursery_blocks; + W_ nursery_blocks; nursery_blocks = nursery->n_blocks; if (nursery_blocks == blocks) return; @@ -582,7 +584,7 @@ resizeNursery (nursery *nursery, nat blocks) // Resize each of the nurseries to the specified size. // void -resizeNurseriesFixed (nat blocks) +resizeNurseriesFixed (W_ blocks) { nat i; for (i = 0; i < n_capabilities; i++) { @@ -594,7 +596,7 @@ resizeNurseriesFixed (nat blocks) // Resize the nurseries to the total specified size. // void -resizeNurseries (nat blocks) +resizeNurseries (W_ blocks) { // If there are multiple nurseries, then we just divide the number // of available blocks between them. @@ -631,7 +633,7 @@ move_STACK (StgStack *src, StgStack *dest) -------------------------------------------------------------------------- */ StgPtr -allocate (Capability *cap, lnat n) +allocate (Capability *cap, W_ n) { bdescr *bd; StgPtr p; @@ -640,7 +642,7 @@ allocate (Capability *cap, lnat n) CCS_ALLOC(cap->r.rCCCS,n); if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) { - lnat req_blocks = (lnat)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE; + W_ req_blocks = (W_)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE; // Attempting to allocate an object larger than maxHeapSize // should definitely be disallowed. (bug #1791) @@ -738,7 +740,7 @@ allocate (Capability *cap, lnat n) ------------------------------------------------------------------------- */ StgPtr -allocatePinned (Capability *cap, lnat n) +allocatePinned (Capability *cap, W_ n) { StgPtr p; bdescr *bd; @@ -918,10 +920,10 @@ dirty_MVAR(StgRegTable *reg, StgClosure *p) * need this function for the final stats when the RTS is shutting down. * -------------------------------------------------------------------------- */ -lnat +W_ updateNurseriesStats (void) { - lnat allocated = 0; + W_ allocated = 0; nat i; for (i = 0; i < n_capabilities; i++) { @@ -933,15 +935,15 @@ updateNurseriesStats (void) return allocated; } -lnat +W_ countLargeAllocated (void) { return g0->n_new_large_words; } -lnat countOccupied (bdescr *bd) +W_ countOccupied (bdescr *bd) { - lnat words; + W_ words; words = 0; for (; bd != NULL; bd = bd->link) { @@ -951,19 +953,19 @@ lnat countOccupied (bdescr *bd) return words; } -lnat genLiveWords (generation *gen) +W_ genLiveWords (generation *gen) { return gen->n_words + countOccupied(gen->large_objects); } -lnat genLiveBlocks (generation *gen) +W_ genLiveBlocks (generation *gen) { return gen->n_blocks + gen->n_large_blocks; } -lnat gcThreadLiveWords (nat i, nat g) +W_ gcThreadLiveWords (nat i, nat g) { - lnat words; + W_ words; words = countOccupied(gc_threads[i]->gens[g].todo_bd); words += countOccupied(gc_threads[i]->gens[g].part_list); @@ -972,9 +974,9 @@ lnat gcThreadLiveWords (nat i, nat g) return words; } -lnat gcThreadLiveBlocks (nat i, nat g) +W_ gcThreadLiveBlocks (nat i, nat g) { - lnat blocks; + W_ blocks; blocks = countBlocks(gc_threads[i]->gens[g].todo_bd); blocks += gc_threads[i]->gens[g].n_part_blocks; @@ -985,10 +987,10 @@ lnat gcThreadLiveBlocks (nat i, nat g) // Return an accurate count of the live data in the heap, excluding // generation 0. -lnat calcLiveWords (void) +W_ calcLiveWords (void) { nat g; - lnat live; + W_ live; live = 0; for (g = 0; g < RtsFlags.GcFlags.generations; g++) { @@ -997,10 +999,10 @@ lnat calcLiveWords (void) return live; } -lnat calcLiveBlocks (void) +W_ calcLiveBlocks (void) { nat g; - lnat live; + W_ live; live = 0; for (g = 0; g < RtsFlags.GcFlags.generations; g++) { @@ -1019,10 +1021,10 @@ lnat calcLiveBlocks (void) * that will be collected next time will therefore need twice as many * blocks since all the data will be copied. */ -extern lnat -calcNeeded (rtsBool force_major, lnat *blocks_needed) +extern W_ +calcNeeded (rtsBool force_major, memcount *blocks_needed) { - lnat needed = 0, blocks; + W_ needed = 0, blocks; nat g, N; generation *gen; @@ -1094,7 +1096,7 @@ calcNeeded (rtsBool force_major, lnat *blocks_needed) // because it knows how to work around the restrictions put in place // by SELinux. -void *allocateExec (nat bytes, void **exec_ret) +void *allocateExec (W_ bytes, void **exec_ret) { void **ret, **exec; ACQUIRE_SM_LOCK; @@ -1118,10 +1120,10 @@ void freeExec (void *addr) #else -void *allocateExec (nat bytes, void **exec_ret) +void *allocateExec (W_ bytes, void **exec_ret) { void *ret; - nat n; + W_ n; ACQUIRE_SM_LOCK; @@ -1135,7 +1137,7 @@ void *allocateExec (nat bytes, void **exec_ret) if (exec_block == NULL || exec_block->free + n + 1 > exec_block->start + BLOCK_SIZE_W) { bdescr *bd; - lnat pagesize = getPageSize(); + W_ pagesize = getPageSize(); bd = allocGroup(stg_max(1, pagesize / BLOCK_SIZE)); debugTrace(DEBUG_gc, "allocate exec block %p", bd->start); bd->gen_no = 0; diff --git a/rts/sm/Storage.h b/rts/sm/Storage.h index b87a32ce09..05690d0a4f 100644 --- a/rts/sm/Storage.h +++ b/rts/sm/Storage.h @@ -37,7 +37,7 @@ doYouWantToGC( Capability *cap ) } /* for splitting blocks groups in two */ -bdescr * splitLargeBlock (bdescr *bd, nat blocks); +bdescr * splitLargeBlock (bdescr *bd, W_ blocks); /* ----------------------------------------------------------------------------- Generational garbage collection support @@ -81,28 +81,28 @@ void dirty_MVAR(StgRegTable *reg, StgClosure *p); extern nursery *nurseries; void resetNurseries ( void ); -lnat clearNursery ( Capability *cap ); -void resizeNurseries ( nat blocks ); -void resizeNurseriesFixed ( nat blocks ); -lnat countNurseryBlocks ( void ); +W_ clearNursery ( Capability *cap ); +void resizeNurseries ( W_ blocks ); +void resizeNurseriesFixed ( W_ blocks ); +W_ countNurseryBlocks ( void ); /* ----------------------------------------------------------------------------- Stats 'n' DEBUG stuff -------------------------------------------------------------------------- */ -lnat updateNurseriesStats (void); -lnat countLargeAllocated (void); -lnat countOccupied (bdescr *bd); -lnat calcNeeded (rtsBool force_major, lnat *blocks_needed); +W_ updateNurseriesStats (void); +W_ countLargeAllocated (void); +W_ countOccupied (bdescr *bd); +W_ calcNeeded (rtsBool force_major, W_ *blocks_needed); -lnat gcThreadLiveWords (nat i, nat g); -lnat gcThreadLiveBlocks (nat i, nat g); +W_ gcThreadLiveWords (nat i, nat g); +W_ gcThreadLiveBlocks (nat i, nat g); -lnat genLiveWords (generation *gen); -lnat genLiveBlocks (generation *gen); +W_ genLiveWords (generation *gen); +W_ genLiveBlocks (generation *gen); -lnat calcLiveBlocks (void); -lnat calcLiveWords (void); +W_ calcLiveBlocks (void); +W_ calcLiveWords (void); /* ---------------------------------------------------------------------------- Storage manager internal APIs and globals diff --git a/rts/sm/Sweep.c b/rts/sm/Sweep.c index 81a41182b1..cc619314e4 100644 --- a/rts/sm/Sweep.c +++ b/rts/sm/Sweep.c @@ -23,7 +23,7 @@ sweep(generation *gen) { bdescr *bd, *prev, *next; nat i; - nat freed, resid, fragd, blocks, live; + W_ freed, resid, fragd, blocks, live; ASSERT(countBlocks(gen->old_blocks) == gen->n_old_blocks); diff --git a/rts/win32/GetTime.c b/rts/win32/GetTime.c index ec506fe4d0..bfab43a9cc 100644 --- a/rts/win32/GetTime.c +++ b/rts/win32/GetTime.c @@ -153,7 +153,7 @@ getUnixEpochTime(StgWord64 *sec, StgWord32 *nsec) *nsec = ((unsigned long)(unixtime.QuadPart % 10000000ull)) * 100ul; } -nat +W_ getPageFaults(void) { /* ToDo (on NT): better, get this via the performance data diff --git a/rts/win32/OSMem.c b/rts/win32/OSMem.c index d9a6459f3d..218b25df13 100644 --- a/rts/win32/OSMem.c +++ b/rts/win32/OSMem.c @@ -16,13 +16,13 @@ typedef struct alloc_rec_ { char* base; /* non-aligned base address, directly from VirtualAlloc */ - lnat size; /* Size in bytes */ + W_ size; /* Size in bytes */ struct alloc_rec_* next; } alloc_rec; typedef struct block_rec_ { char* base; /* base address, non-MBLOCK-aligned */ - lnat size; /* size in bytes */ + W_ size; /* size in bytes */ struct block_rec_* next; } block_rec; @@ -46,7 +46,7 @@ alloc_rec* allocNew(nat n) { alloc_rec* rec; rec = (alloc_rec*)stgMallocBytes(sizeof(alloc_rec),"getMBlocks: allocNew"); - rec->size = ((lnat)n+1)*MBLOCK_SIZE; + rec->size = ((W_)n+1)*MBLOCK_SIZE; rec->base = VirtualAlloc(NULL, rec->size, MEM_RESERVE, PAGE_READWRITE); if(rec->base==0) { @@ -76,7 +76,7 @@ allocNew(nat n) { static void -insertFree(char* alloc_base, lnat alloc_size) { +insertFree(char* alloc_base, W_ alloc_size) { block_rec temp; block_rec* it; block_rec* prev; @@ -116,7 +116,7 @@ findFreeBlocks(nat n) { block_rec temp; block_rec* prev; - lnat required_size; + W_ required_size; it=free_blocks; required_size = n*MBLOCK_SIZE; temp.next=free_blocks; temp.base=0; temp.size=0; @@ -124,7 +124,7 @@ findFreeBlocks(nat n) { /* TODO: Don't just take first block, find smallest sufficient block */ for( ; it!=0 && it->size<required_size; prev=it, it=it->next ) {} if(it!=0) { - if( (((lnat)it->base) & MBLOCK_MASK) == 0) { /* MBlock aligned */ + if( (((W_)it->base) & MBLOCK_MASK) == 0) { /* MBlock aligned */ ret = (void*)it->base; if(it->size==required_size) { prev->next=it->next; @@ -137,7 +137,7 @@ findFreeBlocks(nat n) { char* need_base; block_rec* next; int new_size; - need_base = (char*)(((lnat)it->base) & ((lnat)~MBLOCK_MASK)) + MBLOCK_SIZE; + need_base = (char*)(((W_)it->base) & ((W_)~MBLOCK_MASK)) + MBLOCK_SIZE; next = (block_rec*)stgMallocBytes( sizeof(block_rec) , "getMBlocks: findFreeBlocks: splitting"); @@ -158,12 +158,12 @@ findFreeBlocks(nat n) { so we might need to do many VirtualAlloc MEM_COMMITs. We simply walk the (ordered) allocated blocks. */ static void -commitBlocks(char* base, lnat size) { +commitBlocks(char* base, W_ size) { alloc_rec* it; it=allocs; for( ; it!=0 && (it->base+it->size)<=base; it=it->next ) {} for( ; it!=0 && size>0; it=it->next ) { - lnat size_delta; + W_ size_delta; void* temp; size_delta = it->size - (base-it->base); if(size_delta>size) size_delta=size; @@ -199,7 +199,7 @@ osGetMBlocks(nat n) { barf("getMBlocks: misaligned block returned"); } - commitBlocks(ret, (lnat)MBLOCK_SIZE*n); + commitBlocks(ret, (W_)MBLOCK_SIZE*n); } return ret; @@ -208,7 +208,7 @@ osGetMBlocks(nat n) { void osFreeMBlocks(char *addr, nat n) { alloc_rec *p; - lnat nBytes = (lnat)n * MBLOCK_SIZE; + W_ nBytes = (W_)n * MBLOCK_SIZE; insertFree(addr, nBytes); @@ -229,7 +229,7 @@ void osFreeMBlocks(char *addr, nat n) nBytes = 0; } else { - lnat bytesToFree = p->base + p->size - addr; + W_ bytesToFree = p->base + p->size - addr; if (!VirtualFree(addr, bytesToFree, MEM_DECOMMIT)) { sysErrorBelch("osFreeMBlocks: VirtualFree MEM_DECOMMIT failed"); stg_exit(EXIT_FAILURE); @@ -365,9 +365,9 @@ osFreeAllMBlocks(void) } } -lnat getPageSize (void) +W_ getPageSize (void) { - static lnat pagesize = 0; + static W_ pagesize = 0; if (pagesize) { return pagesize; } else { @@ -378,7 +378,7 @@ lnat getPageSize (void) } } -void setExecutable (void *p, lnat len, rtsBool exec) +void setExecutable (void *p, W_ len, rtsBool exec) { DWORD dwOldProtect = 0; if (VirtualProtect (p, len, @@ -209,7 +209,10 @@ sub scmall { } if (@_ < 1) { help(1); } $subcommand = shift; - if ($subcommand ne 'add' && $subcommand ne 'rm' && $subcommand ne 'set-url') { + if ($subcommand ne 'add' && + $subcommand ne 'rm' && + $subcommand ne 'set-branches' && + $subcommand ne 'set-url') { help(1); } while (@_ > 0 && $_[0] =~ /^-/) { @@ -398,6 +401,8 @@ sub scmall { @scm_args = ("remote", "add", $branch_name, $path); } elsif ($subcommand eq 'rm') { @scm_args = ("remote", "rm", $branch_name); + } elsif ($subcommand eq 'set-branches') { + @scm_args = ("remote", "set-branches", $branch_name); } elsif ($subcommand eq 'set-url') { @scm_args = ("remote", "set-url", $branch_name, $path); } diff --git a/utils/ghc-cabal/ghc-cabal.cabal b/utils/ghc-cabal/ghc-cabal.cabal index cc6fbee99b..864620487d 100644 --- a/utils/ghc-cabal/ghc-cabal.cabal +++ b/utils/ghc-cabal/ghc-cabal.cabal @@ -18,6 +18,6 @@ Executable ghc-cabal Build-Depends: base >= 3 && < 5, bytestring >= 0.10 && < 0.11, Cabal >= 1.10 && < 1.18, - directory >= 1.1 && < 1.2, + directory >= 1.1 && < 1.3, filepath >= 1.2 && < 1.4 diff --git a/utils/ghc-pkg/ghc-pkg.cabal b/utils/ghc-pkg/ghc-pkg.cabal index 4f96dcc4ba..d437882220 100644 --- a/utils/ghc-pkg/ghc-pkg.cabal +++ b/utils/ghc-pkg/ghc-pkg.cabal @@ -19,7 +19,7 @@ Executable ghc-pkg Extensions: CPP, ForeignFunctionInterface, NondecreasingIndentation Build-Depends: base >= 4 && < 5, - directory >= 1 && < 1.2, + directory >= 1 && < 1.3, process >= 1 && < 1.2, filepath, Cabal, diff --git a/utils/ghc-pwd/ghc-pwd.cabal b/utils/ghc-pwd/ghc-pwd.cabal index 8fae857e16..ba2eb63b82 100644 --- a/utils/ghc-pwd/ghc-pwd.cabal +++ b/utils/ghc-pwd/ghc-pwd.cabal @@ -14,5 +14,5 @@ cabal-version: >=1.2 Executable ghc-pwd Main-Is: ghc-pwd.hs Build-Depends: base >= 3 && < 5, - directory >= 1 && < 1.2 + directory >= 1 && < 1.3 diff --git a/utils/hpc/hpc-bin.cabal b/utils/hpc/hpc-bin.cabal index c9afba58f1..133ea5fb35 100644 --- a/utils/hpc/hpc-bin.cabal +++ b/utils/hpc/hpc-bin.cabal @@ -31,7 +31,7 @@ Executable hpc Build-Depends: base < 3 if flag(base3) || flag(base4) - Build-Depends: directory >= 1 && < 1.2, + Build-Depends: directory >= 1 && < 1.3, containers >= 0.1 && < 0.6, array >= 0.1 && < 0.5 Build-Depends: haskell98, hpc diff --git a/utils/runghc/runghc.cabal.in b/utils/runghc/runghc.cabal.in index 3bab879c91..333ed20f9d 100644 --- a/utils/runghc/runghc.cabal.in +++ b/utils/runghc/runghc.cabal.in @@ -20,7 +20,7 @@ Executable runghc if flag(base3) Build-Depends: base >= 3 && < 5, - directory >= 1 && < 1.2, + directory >= 1 && < 1.3, process >= 1 && < 1.2 else Build-Depends: base < 3 |