diff options
Diffstat (limited to 'compiler')
146 files changed, 5180 insertions, 4748 deletions
diff --git a/compiler/cmm/Bitmap.hs b/compiler/cmm/Bitmap.hs index 642ae40fdb..93217d5192 100644 --- a/compiler/cmm/Bitmap.hs +++ b/compiler/cmm/Bitmap.hs @@ -24,7 +24,7 @@ module Bitmap ( #include "../includes/MachDeps.h" import SMRep -import Constants +import DynFlags import Util import Data.Bits @@ -37,10 +37,10 @@ generated code which need to be emitted as sequences of StgWords. type Bitmap = [StgWord] -- | Make a bitmap from a sequence of bits -mkBitmap :: [Bool] -> Bitmap -mkBitmap [] = [] -mkBitmap stuff = chunkToBitmap chunk : mkBitmap rest - where (chunk, rest) = splitAt wORD_SIZE_IN_BITS stuff +mkBitmap :: DynFlags -> [Bool] -> Bitmap +mkBitmap _ [] = [] +mkBitmap dflags stuff = chunkToBitmap chunk : mkBitmap dflags rest + where (chunk, rest) = splitAt (wORD_SIZE_IN_BITS dflags) stuff chunkToBitmap :: [Bool] -> StgWord chunkToBitmap chunk = @@ -50,31 +50,31 @@ chunkToBitmap chunk = -- eg. @[0,1,3], size 4 ==> 0xb@. -- -- The list of @Int@s /must/ be already sorted. -intsToBitmap :: Int -> [Int] -> Bitmap -intsToBitmap size slots{- must be sorted -} +intsToBitmap :: DynFlags -> Int -> [Int] -> Bitmap +intsToBitmap dflags size slots{- must be sorted -} | size <= 0 = [] | otherwise = (foldr (.|.) 0 (map (1 `shiftL`) these)) : - intsToBitmap (size - wORD_SIZE_IN_BITS) - (map (\x -> x - wORD_SIZE_IN_BITS) rest) - where (these,rest) = span (<wORD_SIZE_IN_BITS) slots + intsToBitmap dflags (size - wORD_SIZE_IN_BITS dflags) + (map (\x -> x - wORD_SIZE_IN_BITS dflags) rest) + where (these,rest) = span (< wORD_SIZE_IN_BITS dflags) slots -- | Make a bitmap where the slots specified are the /zeros/ in the bitmap. -- eg. @[0,1,3], size 4 ==> 0x4@ (we leave any bits outside the size as zero, -- just to make the bitmap easier to read). -- -- The list of @Int@s /must/ be already sorted and duplicate-free. -intsToReverseBitmap :: Int -> [Int] -> Bitmap -intsToReverseBitmap size slots{- must be sorted -} +intsToReverseBitmap :: DynFlags -> Int -> [Int] -> Bitmap +intsToReverseBitmap dflags size slots{- must be sorted -} | size <= 0 = [] | otherwise = - (foldr xor init (map (1 `shiftL`) these)) : - intsToReverseBitmap (size - wORD_SIZE_IN_BITS) - (map (\x -> x - wORD_SIZE_IN_BITS) rest) - where (these,rest) = span (<wORD_SIZE_IN_BITS) slots - init - | size >= wORD_SIZE_IN_BITS = complement 0 - | otherwise = (1 `shiftL` size) - 1 + (foldr xor init (map (1 `shiftL`) these)) : + intsToReverseBitmap dflags (size - wORD_SIZE_IN_BITS dflags) + (map (\x -> x - wORD_SIZE_IN_BITS dflags) rest) + where (these,rest) = span (< wORD_SIZE_IN_BITS dflags) slots + init + | size >= wORD_SIZE_IN_BITS dflags = complement 0 + | otherwise = (1 `shiftL` size) - 1 {- | Magic number, must agree with @BITMAP_BITS_SHIFT@ in InfoTables.h. @@ -83,9 +83,10 @@ possible, or fall back to an external pointer when the bitmap is too large. This value represents the largest size of bitmap that can be packed into a single word. -} -mAX_SMALL_BITMAP_SIZE :: Int -mAX_SMALL_BITMAP_SIZE | wORD_SIZE == 4 = 27 - | otherwise = 58 +mAX_SMALL_BITMAP_SIZE :: DynFlags -> Int +mAX_SMALL_BITMAP_SIZE dflags + | wORD_SIZE dflags == 4 = 27 + | otherwise = 58 seqBitmap :: Bitmap -> a -> a seqBitmap = seqList diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 6ffbbc774d..907f8521e1 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -13,6 +13,7 @@ module CLabel ( mkClosureLabel, mkSRTLabel, + mkModSRTLabel, mkInfoTableLabel, mkEntryLabel, mkSlowEntryLabel, @@ -104,7 +105,6 @@ module CLabel ( ) where import IdInfo -import StaticFlags import BasicTypes import Packages import DataCon @@ -120,6 +120,8 @@ import DynFlags import Platform import UniqSet +import Data.Maybe (isJust) + -- ----------------------------------------------------------------------------- -- The CLabel type @@ -215,6 +217,9 @@ data CLabel -- | Per-module table of tick locations | HpcTicksLabel Module + -- | Static reference table + | SRTLabel (Maybe Module) !Unique + -- | Label of an StgLargeSRT | LargeSRTLabel {-# UNPACK #-} !Unique @@ -272,7 +277,9 @@ pprDebugCLabel lbl data IdLabelInfo = Closure -- ^ Label for closure - | SRT -- ^ Static reference table + | SRT -- ^ Static reference table (TODO: could be removed + -- with the old code generator, but might be needed + -- when we implement the New SRT Plan) | InfoTable -- ^ Info tables for closures; always read-only | Entry -- ^ Entry point | Slow -- ^ Slow entry point @@ -348,6 +355,9 @@ data DynamicLinkerLabelInfo mkSlowEntryLabel :: Name -> CafInfo -> CLabel mkSlowEntryLabel name c = IdLabel name c Slow +mkModSRTLabel :: Maybe Module -> Unique -> CLabel +mkModSRTLabel mb_mod u = SRTLabel mb_mod u + mkSRTLabel :: Name -> CafInfo -> CLabel mkRednCountsLabel :: Name -> CafInfo -> CLabel mkSRTLabel name c = IdLabel name c SRT @@ -582,7 +592,7 @@ needsCDecl :: CLabel -> Bool -- False <=> it's pre-declared; don't bother -- don't bother declaring SRT & Bitmap labels, we always make sure -- they are defined before use. -needsCDecl (IdLabel _ _ SRT) = False +needsCDecl (SRTLabel _ _) = False needsCDecl (LargeSRTLabel _) = False needsCDecl (LargeBitmapLabel _) = False needsCDecl (IdLabel _ _ _) = True @@ -730,6 +740,7 @@ externallyVisibleCLabel (CCS_Label _) = True externallyVisibleCLabel (DynamicLinkerLabel _ _) = False externallyVisibleCLabel (HpcTicksLabel _) = True externallyVisibleCLabel (LargeBitmapLabel _) = False +externallyVisibleCLabel (SRTLabel mb_mod _) = isJust mb_mod externallyVisibleCLabel (LargeSRTLabel _) = False externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel" externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer" @@ -777,6 +788,7 @@ labelType (RtsLabel (RtsApFast _)) = CodeLabel labelType (CaseLabel _ CaseReturnInfo) = DataLabel labelType (CaseLabel _ _) = CodeLabel labelType (PlainModuleInitLabel _) = CodeLabel +labelType (SRTLabel _ _) = CodeLabel labelType (LargeSRTLabel _) = DataLabel labelType (LargeBitmapLabel _) = DataLabel labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel @@ -808,15 +820,15 @@ labelDynamic :: DynFlags -> PackageId -> CLabel -> Bool labelDynamic dflags this_pkg lbl = case lbl of -- is the RTS in a DLL or not? - RtsLabel _ -> not opt_Static && (this_pkg /= rtsPackageId) + RtsLabel _ -> not (dopt Opt_Static dflags) && (this_pkg /= rtsPackageId) - IdLabel n _ _ -> isDllName this_pkg n + IdLabel n _ _ -> isDllName dflags this_pkg n -- When compiling in the "dyn" way, each package is to be linked into -- its own shared library. CmmLabel pkg _ _ | os == OSMinGW32 -> - not opt_Static && (this_pkg /= pkg) + not (dopt Opt_Static dflags) && (this_pkg /= pkg) | otherwise -> True @@ -834,14 +846,14 @@ labelDynamic dflags this_pkg lbl = -- When compiling in the "dyn" way, each package is to be -- linked into its own DLL. ForeignLabelInPackage pkgId -> - (not opt_Static) && (this_pkg /= pkgId) + (not (dopt Opt_Static dflags)) && (this_pkg /= pkgId) else -- On Mac OS X and on ELF platforms, false positives are OK, -- so we claim that all foreign imports come from dynamic -- libraries True - PlainModuleInitLabel m -> not opt_Static && this_pkg /= (modulePackageId m) + PlainModuleInitLabel m -> not (dopt Opt_Static dflags) && this_pkg /= (modulePackageId m) -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves. _ -> False @@ -979,6 +991,11 @@ pprCLbl (CaseLabel u (CaseAlt tag)) pprCLbl (CaseLabel u CaseDefault) = hcat [pprUnique u, ptext (sLit "_dflt")] +pprCLbl (SRTLabel mb_mod u) + = pp_mod <> pprUnique u <> pp_cSEP <> ptext (sLit "srt") + where pp_mod | Just mod <- mb_mod = ppr mod <> pp_cSEP + | otherwise = empty + pprCLbl (LargeSRTLabel u) = pprUnique u <> pp_cSEP <> ptext (sLit "srtd") pprCLbl (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLit "btm") -- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7') diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index 309536b963..30e0addbdc 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -32,10 +32,10 @@ import Bitmap import CLabel import Cmm import CmmUtils -import IdInfo import Data.List +import DynFlags import Maybes -import Name +import Module import Outputable import SMRep import UniqSupply @@ -137,9 +137,9 @@ instance Outputable TopSRT where <+> ppr elts <+> ppr eltmap -emptySRT :: MonadUnique m => m TopSRT -emptySRT = - do top_lbl <- getUniqueM >>= \ u -> return $ mkSRTLabel (mkFCallName u "srt") NoCafRefs +emptySRT :: MonadUnique m => Maybe Module -> m TopSRT +emptySRT mb_mod = + do top_lbl <- getUniqueM >>= \ u -> return $ mkModSRTLabel mb_mod u return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = Map.empty } cafMember :: TopSRT -> CLabel -> Bool @@ -167,17 +167,17 @@ srtToData srt = [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)] -- in the SRT. Then, if the number of CAFs is small enough to fit in a bitmap, -- we make sure they're all close enough to the bottom of the table that the -- bitmap will be able to cover all of them. -buildSRT :: TopSRT -> CAFSet -> UniqSM (TopSRT, Maybe CmmDecl, C_SRT) -buildSRT topSRT cafs = +buildSRT :: DynFlags -> TopSRT -> CAFSet -> UniqSM (TopSRT, Maybe CmmDecl, C_SRT) +buildSRT dflags topSRT cafs = do let -- For each label referring to a function f without a static closure, -- replace it with the CAFs that are reachable from f. sub_srt topSRT localCafs = let cafs = Set.elems localCafs mkSRT topSRT = - do localSRTs <- procpointSRT (lbl topSRT) (elt_map topSRT) cafs + do localSRTs <- procpointSRT dflags (lbl topSRT) (elt_map topSRT) cafs return (topSRT, localSRTs) - in if length cafs > maxBmpSize then + in if length cafs > maxBmpSize dflags then mkSRT (foldl add_if_missing topSRT cafs) else -- make sure all the cafs are near the bottom of the srt mkSRT (add_if_too_far topSRT cafs) @@ -197,7 +197,7 @@ buildSRT topSRT cafs = add srt [] = srt add srt@(TopSRT {next_elt = next}) (caf : rst) = case cafOffset srt caf of - Just ix -> if next - ix > maxBmpSize then + Just ix -> if next - ix > maxBmpSize dflags then add (addCAF caf srt) rst else srt Nothing -> add (addCAF caf srt) rst @@ -207,12 +207,12 @@ buildSRT topSRT cafs = -- Construct an SRT bitmap. -- Adapted from simpleStg/SRT.lhs, which expects Id's. -procpointSRT :: CLabel -> Map CLabel Int -> [CLabel] -> +procpointSRT :: DynFlags -> CLabel -> Map CLabel Int -> [CLabel] -> UniqSM (Maybe CmmDecl, C_SRT) -procpointSRT _ _ [] = +procpointSRT _ _ _ [] = return (Nothing, NoC_SRT) -procpointSRT top_srt top_table entries = - do (top, srt) <- bitmap `seq` to_SRT top_srt offset len bitmap +procpointSRT dflags top_srt top_table entries = + do (top, srt) <- bitmap `seq` to_SRT dflags top_srt offset len bitmap return (top, srt) where ints = map (expectJust "constructSRT" . flip Map.lookup top_table) entries @@ -220,22 +220,22 @@ procpointSRT top_srt top_table entries = offset = head sorted_ints bitmap_entries = map (subtract offset) sorted_ints len = P.last bitmap_entries + 1 - bitmap = intsToBitmap len bitmap_entries + bitmap = intsToBitmap dflags len bitmap_entries -maxBmpSize :: Int -maxBmpSize = widthInBits wordWidth `div` 2 +maxBmpSize :: DynFlags -> Int +maxBmpSize dflags = widthInBits (wordWidth dflags) `div` 2 -- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT. -to_SRT :: CLabel -> Int -> Int -> Bitmap -> UniqSM (Maybe CmmDecl, C_SRT) -to_SRT top_srt off len bmp - | len > maxBmpSize || bmp == [fromIntegral srt_escape] +to_SRT :: DynFlags -> CLabel -> Int -> Int -> Bitmap -> UniqSM (Maybe CmmDecl, C_SRT) +to_SRT dflags top_srt off len bmp + | len > maxBmpSize dflags || bmp == [fromIntegral srt_escape] = do id <- getUniqueM let srt_desc_lbl = mkLargeSRTLabel id tbl = CmmData RelocatableReadOnlyData $ Statics srt_desc_lbl $ map CmmStaticLit - ( cmmLabelOffW top_srt off - : mkWordCLit (fromIntegral len) - : map mkWordCLit bmp) + ( cmmLabelOffW dflags top_srt off + : mkWordCLit dflags (fromIntegral len) + : map (mkWordCLit dflags) bmp) return (Just tbl, C_SRT srt_desc_lbl 0 srt_escape) | otherwise = return (Nothing, C_SRT top_srt off (fromIntegral (head bmp))) @@ -319,11 +319,12 @@ flattenCAFSets cpsdecls = zipWith (bundle flatmap) zipped localCAFs localCAFs = unzipWith localCAFInfo zipped flatmap = mkTopCAFInfo localCAFs -- transitive closure of localCAFs -doSRTs :: TopSRT +doSRTs :: DynFlags + -> TopSRT -> [(CAFEnv, [CmmDecl])] -> IO (TopSRT, [CmmDecl]) -doSRTs topSRT tops +doSRTs dflags topSRT tops = do let caf_decls = flattenCAFSets tops us <- mkSplitUniqSupply 'u' @@ -331,19 +332,19 @@ doSRTs topSRT tops return (topSRT', reverse gs' {- Note [reverse gs] -}) where setSRT (topSRT, rst) (caf_map, decl@(CmmProc{})) = do - (topSRT, srt_tables, srt_env) <- buildSRTs topSRT caf_map + (topSRT, srt_tables, srt_env) <- buildSRTs dflags topSRT caf_map let decl' = updInfoSRTs srt_env decl return (topSRT, decl': srt_tables ++ rst) setSRT (topSRT, rst) (_, decl) = return (topSRT, decl : rst) -buildSRTs :: TopSRT -> BlockEnv CAFSet +buildSRTs :: DynFlags -> TopSRT -> BlockEnv CAFSet -> UniqSM (TopSRT, [CmmDecl], BlockEnv C_SRT) -buildSRTs top_srt caf_map +buildSRTs dflags top_srt caf_map = foldM doOne (top_srt, [], mapEmpty) (mapToList caf_map) where doOne (top_srt, decls, srt_env) (l, cafs) - = do (top_srt, mb_decl, srt) <- buildSRT top_srt cafs + = do (top_srt, mb_decl, srt) <- buildSRT dflags top_srt cafs return ( top_srt, maybeToList mb_decl ++ decls , mapInsert l srt srt_env ) diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs index dd1b6af643..235fe7f911 100644 --- a/compiler/cmm/CmmCallConv.hs +++ b/compiler/cmm/CmmCallConv.hs @@ -18,7 +18,6 @@ import SMRep import Cmm (Convention(..)) import PprCmm () -import Constants import qualified Data.List as L import DynFlags import Outputable @@ -46,12 +45,12 @@ assignArgumentsPos dflags conv arg_ty reps = assignments regs = case (reps, conv) of (_, NativeNodeCall) -> getRegsWithNode dflags (_, NativeDirectCall) -> getRegsWithoutNode dflags - ([_], NativeReturn) -> allRegs + ([_], NativeReturn) -> allRegs dflags (_, NativeReturn) -> getRegsWithNode dflags -- GC calling convention *must* put values in registers - (_, GC) -> allRegs - (_, PrimOpCall) -> allRegs - ([_], PrimOpReturn) -> allRegs + (_, GC) -> allRegs dflags + (_, PrimOpCall) -> allRegs dflags + ([_], PrimOpReturn) -> allRegs dflags (_, PrimOpReturn) -> getRegsWithNode dflags (_, Slow) -> noRegs -- The calling conventions first assign arguments to registers, @@ -78,9 +77,9 @@ assignArgumentsPos dflags conv arg_ty reps = assignments _ -> (assts, (r:rs)) int = case (w, regs) of (W128, _) -> panic "W128 unsupported register type" - (_, (v:vs, fs, ds, ls)) | widthInBits w <= widthInBits wordWidth + (_, (v:vs, fs, ds, ls)) | widthInBits w <= widthInBits (wordWidth dflags) -> k (RegisterParam (v gcp), (vs, fs, ds, ls)) - (_, (vs, fs, ds, l:ls)) | widthInBits w > widthInBits wordWidth + (_, (vs, fs, ds, l:ls)) | widthInBits w > widthInBits (wordWidth dflags) -> k (RegisterParam l, (vs, fs, ds, ls)) _ -> (assts, (r:rs)) k (asst, regs') = assign_regs ((r, asst) : assts) rs regs' @@ -92,7 +91,7 @@ assignArgumentsPos dflags conv arg_ty reps = assignments assign_stk _ assts [] = assts assign_stk offset assts (r:rs) = assign_stk off' ((r, StackParam off') : assts) rs where w = typeWidth (arg_ty r) - size = (((widthInBytes w - 1) `div` wORD_SIZE) + 1) * wORD_SIZE + size = (((widthInBytes w - 1) `div` wORD_SIZE dflags) + 1) * wORD_SIZE dflags off' = offset + size ----------------------------------------------------------------------------- @@ -111,46 +110,51 @@ type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs. -- that are guaranteed to map to machine registers. getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs -getRegsWithoutNode _dflags = - ( filter (\r -> r VGcPtr /= node) realVanillaRegs - , realFloatRegs - , realDoubleRegs - , realLongRegs ) +getRegsWithoutNode dflags = + ( filter (\r -> r VGcPtr /= node) (realVanillaRegs dflags) + , realFloatRegs dflags + , realDoubleRegs dflags + , realLongRegs dflags) -- getRegsWithNode uses R1/node even if it isn't a register -getRegsWithNode _dflags = - ( if null realVanillaRegs then [VanillaReg 1] else realVanillaRegs - , realFloatRegs - , realDoubleRegs - , realLongRegs ) - -allFloatRegs, allDoubleRegs, allLongRegs :: [GlobalReg] -allVanillaRegs :: [VGcPtr -> GlobalReg] - -allVanillaRegs = map VanillaReg $ regList mAX_Vanilla_REG -allFloatRegs = map FloatReg $ regList mAX_Float_REG -allDoubleRegs = map DoubleReg $ regList mAX_Double_REG -allLongRegs = map LongReg $ regList mAX_Long_REG - -realFloatRegs, realDoubleRegs, realLongRegs :: [GlobalReg] -realVanillaRegs :: [VGcPtr -> GlobalReg] - -realVanillaRegs = map VanillaReg $ regList mAX_Real_Vanilla_REG -realFloatRegs = map FloatReg $ regList mAX_Real_Float_REG -realDoubleRegs = map DoubleReg $ regList mAX_Real_Double_REG -realLongRegs = map LongReg $ regList mAX_Real_Long_REG +getRegsWithNode dflags = + ( if null (realVanillaRegs dflags) + then [VanillaReg 1] + else realVanillaRegs dflags + , realFloatRegs dflags + , realDoubleRegs dflags + , realLongRegs dflags) + +allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg] +allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg] + +allVanillaRegs dflags = map VanillaReg $ regList (mAX_Vanilla_REG dflags) +allFloatRegs dflags = map FloatReg $ regList (mAX_Float_REG dflags) +allDoubleRegs dflags = map DoubleReg $ regList (mAX_Double_REG dflags) +allLongRegs dflags = map LongReg $ regList (mAX_Long_REG dflags) + +realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg] +realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg] + +realVanillaRegs dflags = map VanillaReg $ regList (mAX_Real_Vanilla_REG dflags) +realFloatRegs dflags = map FloatReg $ regList (mAX_Real_Float_REG dflags) +realDoubleRegs dflags = map DoubleReg $ regList (mAX_Real_Double_REG dflags) +realLongRegs dflags = map LongReg $ regList (mAX_Real_Long_REG dflags) regList :: Int -> [Int] regList n = [1 .. n] -allRegs :: AvailRegs -allRegs = (allVanillaRegs, allFloatRegs, allDoubleRegs, allLongRegs) +allRegs :: DynFlags -> AvailRegs +allRegs dflags = (allVanillaRegs dflags, + allFloatRegs dflags, + allDoubleRegs dflags, + allLongRegs dflags) noRegs :: AvailRegs noRegs = ([], [], [], []) -globalArgRegs :: [GlobalReg] -globalArgRegs = map ($VGcPtr) allVanillaRegs ++ - allFloatRegs ++ - allDoubleRegs ++ - allLongRegs +globalArgRegs :: DynFlags -> [GlobalReg] +globalArgRegs dflags = map ($ VGcPtr) (allVanillaRegs dflags) ++ + allFloatRegs dflags ++ + allDoubleRegs dflags ++ + allLongRegs dflags diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs index a6b9b11e5f..128eb1ca62 100644 --- a/compiler/cmm/CmmExpr.hs +++ b/compiler/cmm/CmmExpr.hs @@ -1,18 +1,11 @@ -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module CmmExpr ( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr , CmmReg(..), cmmRegType , CmmLit(..), cmmLitType , LocalReg(..), localRegType , GlobalReg(..), globalRegType, spReg, hpReg, spLimReg, nodeReg, node, baseReg - , VGcPtr(..), vgcFlag -- Temporary! + , VGcPtr(..), vgcFlag -- Temporary! , DefinerOfLocalRegs, UserOfLocalRegs, foldRegsDefd, foldRegsUsed, filterRegsUsed , RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet @@ -30,13 +23,14 @@ import CmmType import CmmMachOp import BlockId import CLabel +import DynFlags import Unique import Data.Set (Set) import qualified Data.Set as Set ----------------------------------------------------------------------------- --- CmmExpr +-- CmmExpr -- An expression. Expressions have no side effects. ----------------------------------------------------------------------------- @@ -48,21 +42,21 @@ data CmmExpr | CmmStackSlot Area {-# UNPACK #-} !Int -- addressing expression of a stack slot | CmmRegOff !CmmReg Int - -- CmmRegOff reg i - -- ** is shorthand only, meaning ** - -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)] - -- where rep = typeWidth (cmmRegType reg) - -instance Eq CmmExpr where -- Equality ignores the types - CmmLit l1 == CmmLit l2 = l1==l2 - CmmLoad e1 _ == CmmLoad e2 _ = e1==e2 - CmmReg r1 == CmmReg r2 = r1==r2 - CmmRegOff r1 i1 == CmmRegOff r2 i2 = r1==r2 && i1==i2 - CmmMachOp op1 es1 == CmmMachOp op2 es2 = op1==op2 && es1==es2 + -- CmmRegOff reg i + -- ** is shorthand only, meaning ** + -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)] + -- where rep = typeWidth (cmmRegType reg) + +instance Eq CmmExpr where -- Equality ignores the types + CmmLit l1 == CmmLit l2 = l1==l2 + CmmLoad e1 _ == CmmLoad e2 _ = e1==e2 + CmmReg r1 == CmmReg r2 = r1==r2 + CmmRegOff r1 i1 == CmmRegOff r2 i2 = r1==r2 && i1==i2 + CmmMachOp op1 es1 == CmmMachOp op2 es2 = op1==op2 && es1==es2 CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2 - _e1 == _e2 = False + _e1 == _e2 = False -data CmmReg +data CmmReg = CmmLocal {-# UNPACK #-} !LocalReg | CmmGlobal GlobalReg deriving( Eq, Ord ) @@ -75,14 +69,14 @@ data Area -- See Note [Continuation BlockId] in CmmNode. deriving (Eq, Ord) -{- Note [Old Area] +{- Note [Old Area] ~~~~~~~~~~~~~~~~~~ There is a single call area 'Old', allocated at the extreme old end of the stack frame (ie just younger than the return address) which holds: - * incoming (overflow) parameters, + * incoming (overflow) parameters, * outgoing (overflow) parameter to tail calls, - * outgoing (overflow) result values + * outgoing (overflow) result values * the update frame (if any) Its size is the max of all these requirements. On entry, the stack @@ -93,22 +87,22 @@ End of note -} data CmmLit = CmmInt !Integer Width - -- Interpretation: the 2's complement representation of the value - -- is truncated to the specified size. This is easier than trying - -- to keep the value within range, because we don't know whether - -- it will be used as a signed or unsigned value (the CmmType doesn't - -- distinguish between signed & unsigned). + -- Interpretation: the 2's complement representation of the value + -- is truncated to the specified size. This is easier than trying + -- to keep the value within range, because we don't know whether + -- it will be used as a signed or unsigned value (the CmmType doesn't + -- distinguish between signed & unsigned). | CmmFloat Rational Width - | CmmLabel CLabel -- Address of label - | CmmLabelOff CLabel Int -- Address of label + byte offset - + | CmmLabel CLabel -- Address of label + | CmmLabelOff CLabel Int -- Address of label + byte offset + -- Due to limitations in the C backend, the following -- MUST ONLY be used inside the info table indicated by label2 -- (label2 must be the info label), and label1 must be an -- SRT, a slow entrypoint or a large bitmap (see the Mangler) -- Don't use it at all unless tablesNextToCode. -- It is also used inside the NCG during when generating - -- position-independent code. + -- position-independent code. | CmmLabelDiffOff CLabel CLabel Int -- label1 - label2 + offset | CmmBlock {-# UNPACK #-} !BlockId -- Code label @@ -118,31 +112,32 @@ data CmmLit | CmmHighStackMark -- stands for the max stack space used during a procedure deriving Eq -cmmExprType :: CmmExpr -> CmmType -cmmExprType (CmmLit lit) = cmmLitType lit -cmmExprType (CmmLoad _ rep) = rep -cmmExprType (CmmReg reg) = cmmRegType reg -cmmExprType (CmmMachOp op args) = machOpResultType op (map cmmExprType args) -cmmExprType (CmmRegOff reg _) = cmmRegType reg -cmmExprType (CmmStackSlot _ _) = bWord -- an address +cmmExprType :: DynFlags -> CmmExpr -> CmmType +cmmExprType dflags (CmmLit lit) = cmmLitType dflags lit +cmmExprType _ (CmmLoad _ rep) = rep +cmmExprType dflags (CmmReg reg) = cmmRegType dflags reg +cmmExprType dflags (CmmMachOp op args) = machOpResultType dflags op (map (cmmExprType dflags) args) +cmmExprType dflags (CmmRegOff reg _) = cmmRegType dflags reg +cmmExprType dflags (CmmStackSlot _ _) = bWord dflags -- an address -- Careful though: what is stored at the stack slot may be bigger than -- an address -cmmLitType :: CmmLit -> CmmType -cmmLitType (CmmInt _ width) = cmmBits width -cmmLitType (CmmFloat _ width) = cmmFloat width -cmmLitType (CmmLabel lbl) = cmmLabelType lbl -cmmLitType (CmmLabelOff lbl _) = cmmLabelType lbl -cmmLitType (CmmLabelDiffOff {}) = bWord -cmmLitType (CmmBlock _) = bWord -cmmLitType (CmmHighStackMark) = bWord +cmmLitType :: DynFlags -> CmmLit -> CmmType +cmmLitType _ (CmmInt _ width) = cmmBits width +cmmLitType _ (CmmFloat _ width) = cmmFloat width +cmmLitType dflags (CmmLabel lbl) = cmmLabelType dflags lbl +cmmLitType dflags (CmmLabelOff lbl _) = cmmLabelType dflags lbl +cmmLitType dflags (CmmLabelDiffOff {}) = bWord dflags +cmmLitType dflags (CmmBlock _) = bWord dflags +cmmLitType dflags (CmmHighStackMark) = bWord dflags -cmmLabelType :: CLabel -> CmmType -cmmLabelType lbl | isGcPtrLabel lbl = gcWord - | otherwise = bWord +cmmLabelType :: DynFlags -> CLabel -> CmmType +cmmLabelType dflags lbl + | isGcPtrLabel lbl = gcWord dflags + | otherwise = bWord dflags -cmmExprWidth :: CmmExpr -> Width -cmmExprWidth e = typeWidth (cmmExprType e) +cmmExprWidth :: DynFlags -> CmmExpr -> Width +cmmExprWidth dflags e = typeWidth (cmmExprType dflags e) -------- --- Negation for conditional branches @@ -153,7 +148,7 @@ maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op maybeInvertCmmExpr _ = Nothing ----------------------------------------------------------------------------- --- Local registers +-- Local registers ----------------------------------------------------------------------------- data LocalReg @@ -171,15 +166,15 @@ instance Ord LocalReg where instance Uniquable LocalReg where getUnique (LocalReg uniq _) = uniq -cmmRegType :: CmmReg -> CmmType -cmmRegType (CmmLocal reg) = localRegType reg -cmmRegType (CmmGlobal reg) = globalRegType reg +cmmRegType :: DynFlags -> CmmReg -> CmmType +cmmRegType _ (CmmLocal reg) = localRegType reg +cmmRegType dflags (CmmGlobal reg) = globalRegType dflags reg localRegType :: LocalReg -> CmmType localRegType (LocalReg _ rep) = rep ----------------------------------------------------------------------------- --- Register-use information for expressions and other types +-- Register-use information for expressions and other types ----------------------------------------------------------------------------- -- | Sets of local registers @@ -270,58 +265,58 @@ instance DefinerOfLocalRegs a => DefinerOfLocalRegs (Maybe a) where -- Another reg utility regUsedIn :: CmmReg -> CmmExpr -> Bool -_ `regUsedIn` CmmLit _ = False -reg `regUsedIn` CmmLoad e _ = reg `regUsedIn` e -reg `regUsedIn` CmmReg reg' = reg == reg' +_ `regUsedIn` CmmLit _ = False +reg `regUsedIn` CmmLoad e _ = reg `regUsedIn` e +reg `regUsedIn` CmmReg reg' = reg == reg' reg `regUsedIn` CmmRegOff reg' _ = reg == reg' reg `regUsedIn` CmmMachOp _ es = any (reg `regUsedIn`) es _ `regUsedIn` CmmStackSlot _ _ = False ----------------------------------------------------------------------------- --- Global STG registers +-- Global STG registers ----------------------------------------------------------------------------- data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show ) - -- TEMPORARY!!! + -- TEMPORARY!!! ----------------------------------------------------------------------------- --- Global STG registers +-- Global STG registers ----------------------------------------------------------------------------- vgcFlag :: CmmType -> VGcPtr vgcFlag ty | isGcPtrType ty = VGcPtr - | otherwise = VNonGcPtr + | otherwise = VNonGcPtr data GlobalReg -- Argument and return registers - = VanillaReg -- pointers, unboxed ints and chars - {-# UNPACK #-} !Int -- its number - VGcPtr + = VanillaReg -- pointers, unboxed ints and chars + {-# UNPACK #-} !Int -- its number + VGcPtr - | FloatReg -- single-precision floating-point registers - {-# UNPACK #-} !Int -- its number + | FloatReg -- single-precision floating-point registers + {-# UNPACK #-} !Int -- its number - | DoubleReg -- double-precision floating-point registers - {-# UNPACK #-} !Int -- its number + | DoubleReg -- double-precision floating-point registers + {-# UNPACK #-} !Int -- its number - | LongReg -- long int registers (64-bit, really) - {-# UNPACK #-} !Int -- its number + | LongReg -- long int registers (64-bit, really) + {-# UNPACK #-} !Int -- its number -- STG registers - | Sp -- Stack ptr; points to last occupied stack location. - | SpLim -- Stack limit - | Hp -- Heap ptr; points to last occupied heap location. - | HpLim -- Heap limit register + | Sp -- Stack ptr; points to last occupied stack location. + | SpLim -- Stack limit + | Hp -- Heap ptr; points to last occupied heap location. + | HpLim -- Heap limit register | CCCS -- Current cost-centre stack | CurrentTSO -- pointer to current thread's TSO - | CurrentNursery -- pointer to allocation area - | HpAlloc -- allocation count for heap check failure + | CurrentNursery -- pointer to allocation area + | HpAlloc -- allocation count for heap check failure - -- We keep the address of some commonly-called - -- functions in the register table, to keep code - -- size down: + -- We keep the address of some commonly-called + -- functions in the register table, to keep code + -- size down: | EagerBlackholeInfo -- stg_EAGER_BLACKHOLE_info - | GCEnter1 -- stg_gc_enter_1 - | GCFun -- stg_gc_fun + | GCEnter1 -- stg_gc_enter_1 + | GCFun -- stg_gc_fun -- Base offset for the register table, used for accessing registers -- which do not have real registers assigned to them. This register @@ -337,7 +332,7 @@ data GlobalReg deriving( Show ) instance Eq GlobalReg where - VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes + VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes FloatReg i == FloatReg j = i==j DoubleReg i == DoubleReg j = i==j LongReg i == LongReg j = i==j @@ -419,12 +414,13 @@ nodeReg = CmmGlobal node node :: GlobalReg node = VanillaReg 1 VGcPtr -globalRegType :: GlobalReg -> CmmType -globalRegType (VanillaReg _ VGcPtr) = gcWord -globalRegType (VanillaReg _ VNonGcPtr) = bWord -globalRegType (FloatReg _) = cmmFloat W32 -globalRegType (DoubleReg _) = cmmFloat W64 -globalRegType (LongReg _) = cmmBits W64 -globalRegType Hp = gcWord -- The initialiser for all - -- dynamically allocated closures -globalRegType _ = bWord +globalRegType :: DynFlags -> GlobalReg -> CmmType +globalRegType dflags (VanillaReg _ VGcPtr) = gcWord dflags +globalRegType dflags (VanillaReg _ VNonGcPtr) = bWord dflags +globalRegType _ (FloatReg _) = cmmFloat W32 +globalRegType _ (DoubleReg _) = cmmFloat W64 +globalRegType _ (LongReg _) = cmmBits W64 +globalRegType dflags Hp = gcWord dflags + -- The initialiser for all + -- dynamically allocated closures +globalRegType dflags _ = bWord dflags diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index 29affaef0b..0735937754 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -24,7 +24,6 @@ import qualified Stream import Hoopl import Maybes -import Constants import DynFlags import Panic import UniqSupply @@ -114,8 +113,8 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks) -- Use a zero place-holder in place of the -- entry-label in the info table return (top_decls ++ - [mkRODataLits info_lbl (zeroCLit : rel_std_info ++ - rel_extra_bits)]) + [mkRODataLits info_lbl (zeroCLit dflags : rel_std_info ++ + rel_extra_bits)]) _nonempty -> -- Separately emit info table (with the function entry -- point as first entry) and the entry code @@ -172,9 +171,9 @@ mkInfoTableContents dflags -- (which in turn came from a handwritten .cmm file) | StackRep frame <- smrep - = do { (prof_lits, prof_data) <- mkProfLits prof - ; let (srt_label, srt_bitmap) = mkSRTLit srt - ; (liveness_lit, liveness_data) <- mkLivenessBits frame + = do { (prof_lits, prof_data) <- mkProfLits dflags prof + ; let (srt_label, srt_bitmap) = mkSRTLit dflags srt + ; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame ; let std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit rts_tag | Just tag <- mb_rts_tag = tag @@ -184,9 +183,9 @@ mkInfoTableContents dflags ; return (prof_data ++ liveness_data, (std_info, srt_label)) } | HeapRep _ ptrs nonptrs closure_type <- smrep - = do { let layout = packHalfWordsCLit ptrs nonptrs - ; (prof_lits, prof_data) <- mkProfLits prof - ; let (srt_label, srt_bitmap) = mkSRTLit srt + = do { let layout = packHalfWordsCLit dflags ptrs nonptrs + ; (prof_lits, prof_data) <- mkProfLits dflags prof + ; let (srt_label, srt_bitmap) = mkSRTLit dflags srt ; (mb_srt_field, mb_layout, extra_bits, ct_data) <- mk_pieces closure_type srt_label ; let std_info = mkStdInfoTable dflags prof_lits @@ -208,24 +207,24 @@ mkInfoTableContents dflags = return (Nothing, Nothing, srt_label, []) mk_pieces (ThunkSelector offset) _no_srt - = return (Just 0, Just (mkWordCLit offset), [], []) + = return (Just 0, Just (mkWordCLit dflags offset), [], []) -- Layout known (one free var); we use the layout field for offset mk_pieces (Fun arity (ArgSpec fun_type)) srt_label - = do { let extra_bits = packHalfWordsCLit fun_type arity : srt_label + = do { let extra_bits = packHalfWordsCLit dflags fun_type arity : srt_label ; return (Nothing, Nothing, extra_bits, []) } mk_pieces (Fun arity (ArgGen arg_bits)) srt_label - = do { (liveness_lit, liveness_data) <- mkLivenessBits arg_bits + = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits ; let fun_type | null liveness_data = aRG_GEN | otherwise = aRG_GEN_BIG - extra_bits = [ packHalfWordsCLit fun_type arity + extra_bits = [ packHalfWordsCLit dflags fun_type arity , srt_lit, liveness_lit, slow_entry ] ; return (Nothing, Nothing, extra_bits, liveness_data) } where slow_entry = CmmLabel (toSlowEntryLbl info_lbl) srt_lit = case srt_label of - [] -> mkIntCLit 0 + [] -> mkIntCLit dflags 0 (lit:_rest) -> ASSERT( null _rest ) lit mk_pieces BlackHole _ = panic "mk_pieces: BlackHole" @@ -233,11 +232,12 @@ mkInfoTableContents dflags mkInfoTableContents _ _ _ = panic "mkInfoTableContents" -- NonInfoTable dealt with earlier -mkSRTLit :: C_SRT +mkSRTLit :: DynFlags + -> C_SRT -> ([CmmLit], -- srt_label, if any StgHalfWord) -- srt_bitmap -mkSRTLit NoC_SRT = ([], 0) -mkSRTLit (C_SRT lbl off bitmap) = ([cmmLabelOffW lbl off], bitmap) +mkSRTLit _ NoC_SRT = ([], 0) +mkSRTLit dflags (C_SRT lbl off bitmap) = ([cmmLabelOffW dflags lbl off], bitmap) ------------------------------------------------------------------------- @@ -297,34 +297,34 @@ makeRelativeRefTo _ _ lit = lit -- The head of the stack layout is the top of the stack and -- the least-significant bit. -mkLivenessBits :: Liveness -> UniqSM (CmmLit, [RawCmmDecl]) +mkLivenessBits :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl]) -- ^ Returns: -- 1. The bitmap (literal value or label) -- 2. Large bitmap CmmData if needed -mkLivenessBits liveness - | n_bits > mAX_SMALL_BITMAP_SIZE -- does not fit in one word +mkLivenessBits dflags liveness + | n_bits > mAX_SMALL_BITMAP_SIZE dflags -- does not fit in one word = do { uniq <- getUniqueUs ; let bitmap_lbl = mkBitmapLabel uniq ; return (CmmLabel bitmap_lbl, [mkRODataLits bitmap_lbl lits]) } | otherwise -- Fits in one word - = return (mkWordCLit bitmap_word, []) + = return (mkWordCLit dflags bitmap_word, []) where n_bits = length liveness bitmap :: Bitmap - bitmap = mkBitmap liveness + bitmap = mkBitmap dflags liveness small_bitmap = case bitmap of [] -> 0 [b] -> b _ -> panic "mkLiveness" bitmap_word = fromIntegral n_bits - .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT) + .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags) - lits = mkWordCLit (fromIntegral n_bits) : map mkWordCLit bitmap + lits = mkWordCLit dflags (fromIntegral n_bits) : map (mkWordCLit dflags) bitmap -- The first word is the size. The structure must match -- StgLargeBitmap in includes/rts/storage/InfoTable.h @@ -361,7 +361,7 @@ mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit | dopt Opt_SccProfilingOn dflags = [type_descr, closure_descr] | otherwise = [] - type_lit = packHalfWordsCLit cl_type srt_len + type_lit = packHalfWordsCLit dflags cl_type srt_len ------------------------------------------------------------------------- -- @@ -369,9 +369,9 @@ mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit -- ------------------------------------------------------------------------- -mkProfLits :: ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl]) -mkProfLits NoProfilingInfo = return ((zeroCLit, zeroCLit), []) -mkProfLits (ProfilingInfo td cd) +mkProfLits :: DynFlags -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl]) +mkProfLits dflags NoProfilingInfo = return ((zeroCLit dflags, zeroCLit dflags), []) +mkProfLits _ (ProfilingInfo td cd) = do { (td_lit, td_decl) <- newStringLit td ; (cd_lit, cd_decl) <- newStringLit cd ; return ((td_lit,cd_lit), [td_decl,cd_decl]) } diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs index 98008d5d0d..5505b92f5a 100644 --- a/compiler/cmm/CmmLayoutStack.hs +++ b/compiler/cmm/CmmLayoutStack.hs @@ -17,7 +17,6 @@ import CmmLive import CmmProcPoint import SMRep import Hoopl -import Constants import UniqSupply import Maybes import UniqFM @@ -120,7 +119,7 @@ cmmLayoutStack dflags procpoints entry_args (final_stackmaps, _final_high_sp, new_blocks) <- mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) -> - layout procpoints liveness entry entry_args + layout dflags procpoints liveness entry entry_args rec_stackmaps rec_high_sp blocks new_blocks' <- mapM (lowerSafeForeignCall dflags) new_blocks @@ -130,7 +129,8 @@ cmmLayoutStack dflags procpoints entry_args -layout :: BlockSet -- proc points +layout :: DynFlags + -> BlockSet -- proc points -> BlockEnv CmmLive -- liveness -> BlockId -- entry -> ByteOff -- stack args on entry @@ -146,7 +146,7 @@ layout :: BlockSet -- proc points , [CmmBlock] -- [out] new blocks ) -layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks +layout dflags procpoints liveness entry entry_args final_stackmaps final_hwm blocks = go blocks init_stackmap entry_args [] where (updfr, cont_info) = collectContInfo blocks @@ -187,7 +187,7 @@ layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks -- each of the successor blocks. See handleLastNode for -- details. (middle2, sp_off, last1, fixup_blocks, out) - <- handleLastNode procpoints liveness cont_info + <- handleLastNode dflags procpoints liveness cont_info acc_stackmaps stack1 middle0 last0 -- pprTrace "layout(out)" (ppr out) $ return () @@ -210,7 +210,7 @@ layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks -- beginning of a proc, and we don't modify Sp before the -- check. - final_blocks = manifestSp final_stackmaps stack0 sp0 sp_high entry0 + final_blocks = manifestSp dflags final_stackmaps stack0 sp0 sp_high entry0 middle_pre sp_off last1 fixup_blocks acc_stackmaps' = mapUnion acc_stackmaps out @@ -317,7 +317,7 @@ getStackLoc (Young l) n stackmaps = -- extra code that goes *after* the Sp adjustment. handleLastNode - :: ProcPointSet -> BlockEnv CmmLive -> BlockEnv ByteOff + :: DynFlags -> ProcPointSet -> BlockEnv CmmLive -> BlockEnv ByteOff -> BlockEnv StackMap -> StackMap -> Block CmmNode O O -> CmmNode O C @@ -329,7 +329,7 @@ handleLastNode , BlockEnv StackMap -- stackmaps for the continuations ) -handleLastNode procpoints liveness cont_info stackmaps +handleLastNode dflags procpoints liveness cont_info stackmaps stack0@StackMap { sm_sp = sp0 } middle last = case last of -- At each return / tail call, @@ -344,7 +344,7 @@ handleLastNode procpoints liveness cont_info stackmaps return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off CmmForeignCall{ succ = cont_lbl, .. } -> do - return $ lastCall cont_lbl wORD_SIZE wORD_SIZE (sm_ret_off stack0) + return $ lastCall cont_lbl (wORD_SIZE dflags) (wORD_SIZE dflags) (sm_ret_off stack0) -- one word each for args and results: the return address CmmBranch{..} -> handleBranches @@ -380,7 +380,7 @@ handleLastNode procpoints liveness cont_info stackmaps = (save_assignments, new_cont_stack) where (new_cont_stack, save_assignments) - = setupStackFrame lbl liveness cml_ret_off cml_ret_args stack0 + = setupStackFrame dflags lbl liveness cml_ret_off cml_ret_args stack0 -- For other last nodes (branches), if any of the targets is a @@ -403,7 +403,7 @@ handleLastNode procpoints liveness cont_info stackmaps out = mapFromList [ (l', cont_stack) | l' <- successors last ] return ( assigs - , spOffsetForCall sp0 cont_stack wORD_SIZE + , spOffsetForCall sp0 cont_stack (wORD_SIZE dflags) , last , [] , out) @@ -428,7 +428,7 @@ handleLastNode procpoints liveness cont_info stackmaps | Just stack2 <- mapLookup l stackmaps = do let assigs = fixupStack stack0 stack2 - (tmp_lbl, block) <- makeFixupBlock sp0 l stack2 assigs + (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 assigs return (l, tmp_lbl, stack2, block) -- (b) if the successor is a proc point, save everything @@ -439,10 +439,10 @@ handleLastNode procpoints liveness cont_info stackmaps (stack2, assigs) = --pprTrace "first visit to proc point" -- (ppr l <+> ppr stack1) $ - setupStackFrame l liveness (sm_ret_off stack0) + setupStackFrame dflags l liveness (sm_ret_off stack0) cont_args stack0 -- - (tmp_lbl, block) <- makeFixupBlock sp0 l stack2 assigs + (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 assigs return (l, tmp_lbl, stack2, block) -- (c) otherwise, the current StackMap is the StackMap for @@ -456,14 +456,15 @@ handleLastNode procpoints liveness cont_info stackmaps is_live (r,_) = r `elemRegSet` live -makeFixupBlock :: ByteOff -> Label -> StackMap -> [CmmNode O O] -> UniqSM (Label, [CmmBlock]) -makeFixupBlock sp0 l stack assigs +makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap -> [CmmNode O O] + -> UniqSM (Label, [CmmBlock]) +makeFixupBlock dflags sp0 l stack assigs | null assigs && sp0 == sm_sp stack = return (l, []) | otherwise = do tmp_lbl <- liftM mkBlockId $ getUniqueM let sp_off = sp0 - sm_sp stack block = blockJoin (CmmEntry tmp_lbl) - (maybeAddSpAdj sp_off (blockFromList assigs)) + (maybeAddSpAdj dflags sp_off (blockFromList assigs)) (CmmBranch l) return (tmp_lbl, [block]) @@ -494,14 +495,15 @@ fixupStack old_stack new_stack = concatMap move new_locs setupStackFrame - :: BlockId -- label of continuation + :: DynFlags + -> BlockId -- label of continuation -> BlockEnv CmmLive -- liveness -> ByteOff -- updfr -> ByteOff -- bytes of return values on stack -> StackMap -- current StackMap -> (StackMap, [CmmNode O O]) -setupStackFrame lbl liveness updfr_off ret_args stack0 +setupStackFrame dflags lbl liveness updfr_off ret_args stack0 = (cont_stack, assignments) where -- get the set of LocalRegs live in the continuation @@ -517,7 +519,7 @@ setupStackFrame lbl liveness updfr_off ret_args stack0 -- everything up to updfr_off is off-limits -- stack1 contains updfr_off, plus everything we need to save - (stack1, assignments) = allocate updfr_off live stack0 + (stack1, assignments) = allocate dflags updfr_off live stack0 -- And the Sp at the continuation is: -- sm_sp stack1 + ret_args @@ -598,9 +600,10 @@ futureContinuation middle = foldBlockNodesB f middle Nothing -- on the stack and return the new StackMap and the assignments to do -- the saving. -- -allocate :: ByteOff -> RegSet -> StackMap -> (StackMap, [CmmNode O O]) -allocate ret_off live stackmap@StackMap{ sm_sp = sp0 - , sm_regs = regs0 } +allocate :: DynFlags -> ByteOff -> RegSet -> StackMap + -> (StackMap, [CmmNode O O]) +allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0 + , sm_regs = regs0 } = -- pprTrace "allocate" (ppr live $$ ppr stackmap) $ @@ -611,37 +614,37 @@ allocate ret_off live stackmap@StackMap{ sm_sp = sp0 -- make a map of the stack let stack = reverse $ Array.elems $ - accumArray (\_ x -> x) Empty (1, toWords (max sp0 ret_off)) $ + accumArray (\_ x -> x) Empty (1, toWords dflags (max sp0 ret_off)) $ ret_words ++ live_words where ret_words = [ (x, Occupied) - | x <- [ 1 .. toWords ret_off] ] + | x <- [ 1 .. toWords dflags ret_off] ] live_words = - [ (toWords x, Occupied) + [ (toWords dflags x, Occupied) | (r,off) <- eltsUFM regs1, - let w = localRegBytes r, - x <- [ off, off-wORD_SIZE .. off - w + 1] ] + let w = localRegBytes dflags r, + x <- [ off, off - wORD_SIZE dflags .. off - w + 1] ] in -- Pass over the stack: find slots to save all the new live variables, -- choosing the oldest slots first (hence a foldr). let save slot ([], stack, n, assigs, regs) -- no more regs to save - = ([], slot:stack, n `plusW` 1, assigs, regs) + = ([], slot:stack, plusW dflags n 1, assigs, regs) save slot (to_save, stack, n, assigs, regs) = case slot of - Occupied -> (to_save, Occupied:stack, n `plusW` 1, assigs, regs) + Occupied -> (to_save, Occupied:stack, plusW dflags n 1, assigs, regs) Empty | Just (stack', r, to_save') <- select_save to_save (slot:stack) -> let assig = CmmStore (CmmStackSlot Old n') (CmmReg (CmmLocal r)) - n' = n `plusW` 1 + n' = plusW dflags n 1 in (to_save', stack', n', assig : assigs, (r,(r,n')):regs) | otherwise - -> (to_save, slot:stack, n `plusW` 1, assigs, regs) + -> (to_save, slot:stack, plusW dflags n 1, assigs, regs) -- we should do better here: right now we'll fit the smallest first, -- but it would make more sense to fit the biggest first. @@ -654,7 +657,7 @@ allocate ret_off live stackmap@StackMap{ sm_sp = sp0 = Just (replicate words Occupied ++ rest, r, rs++no_fit) | otherwise = go rs (r:no_fit) - where words = localRegWords r + where words = localRegWords dflags r -- fill in empty slots as much as possible (still_to_save, save_stack, n, save_assigs, save_regs) @@ -667,14 +670,14 @@ allocate ret_off live stackmap@StackMap{ sm_sp = sp0 push r (n, assigs, regs) = (n', assig : assigs, (r,(r,n')) : regs) where - n' = n + localRegBytes r + n' = n + localRegBytes dflags r assig = CmmStore (CmmStackSlot Old n') (CmmReg (CmmLocal r)) trim_sp | not (null push_regs) = push_sp | otherwise - = n `plusW` (- length (takeWhile isEmpty save_stack)) + = plusW dflags n (- length (takeWhile isEmpty save_stack)) final_regs = regs1 `addListToUFM` push_regs `addListToUFM` save_regs @@ -683,7 +686,7 @@ allocate ret_off live stackmap@StackMap{ sm_sp = sp0 -- XXX should be an assert if ( n /= max sp0 ret_off ) then pprPanic "allocate" (ppr n <+> ppr sp0 <+> ppr ret_off) else - if (trim_sp .&. (wORD_SIZE - 1)) /= 0 then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else + if (trim_sp .&. (wORD_SIZE dflags - 1)) /= 0 then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else ( stackmap { sm_regs = final_regs , sm_sp = trim_sp } , push_assigs ++ save_assigs ) @@ -705,7 +708,8 @@ allocate ret_off live stackmap@StackMap{ sm_sp = sp0 -- middle_post, because the Sp adjustment intervenes. -- manifestSp - :: BlockEnv StackMap -- StackMaps for other blocks + :: DynFlags + -> BlockEnv StackMap -- StackMaps for other blocks -> StackMap -- StackMap for this block -> ByteOff -- Sp on entry to the block -> ByteOff -- SpHigh @@ -716,17 +720,17 @@ manifestSp -> [CmmBlock] -- new blocks -> [CmmBlock] -- final blocks with Sp manifest -manifestSp stackmaps stack0 sp0 sp_high +manifestSp dflags stackmaps stack0 sp0 sp_high first middle_pre sp_off last fixup_blocks = final_block : fixup_blocks' where area_off = getAreaOff stackmaps adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x - adj_pre_sp = mapExpDeep (areaToSp sp0 sp_high area_off) - adj_post_sp = mapExpDeep (areaToSp (sp0 - sp_off) sp_high area_off) + adj_pre_sp = mapExpDeep (areaToSp dflags sp0 sp_high area_off) + adj_post_sp = mapExpDeep (areaToSp dflags (sp0 - sp_off) sp_high area_off) - final_middle = maybeAddSpAdj sp_off $ + final_middle = maybeAddSpAdj dflags sp_off $ blockFromList $ map adj_pre_sp $ elimStackStores stack0 stackmaps area_off $ @@ -747,10 +751,10 @@ getAreaOff stackmaps (Young l) = Nothing -> pprPanic "getAreaOff" (ppr l) -maybeAddSpAdj :: ByteOff -> Block CmmNode O O -> Block CmmNode O O -maybeAddSpAdj 0 block = block -maybeAddSpAdj sp_off block - = block `blockSnoc` CmmAssign spReg (cmmOffset (CmmReg spReg) sp_off) +maybeAddSpAdj :: DynFlags -> ByteOff -> Block CmmNode O O -> Block CmmNode O O +maybeAddSpAdj _ 0 block = block +maybeAddSpAdj dflags sp_off block + = block `blockSnoc` CmmAssign spReg (cmmOffset dflags (CmmReg spReg) sp_off) {- @@ -770,16 +774,16 @@ arguments. to be Sp + Sp(L) - Sp(L') -} -areaToSp :: ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr -areaToSp sp_old _sp_hwm area_off (CmmStackSlot area n) = - cmmOffset (CmmReg spReg) (sp_old - area_off area - n) -areaToSp _ sp_hwm _ (CmmLit CmmHighStackMark) = CmmLit (mkIntCLit sp_hwm) -areaToSp _ _ _ (CmmMachOp (MO_U_Lt _) -- Note [null stack check] - [CmmMachOp (MO_Sub _) - [ CmmReg (CmmGlobal Sp) - , CmmLit (CmmInt 0 _)], - CmmReg (CmmGlobal SpLim)]) = CmmLit (CmmInt 0 wordWidth) -areaToSp _ _ _ other = other +areaToSp :: DynFlags -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr +areaToSp dflags sp_old _sp_hwm area_off (CmmStackSlot area n) = + cmmOffset dflags (CmmReg spReg) (sp_old - area_off area - n) +areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark) = mkIntExpr dflags sp_hwm +areaToSp dflags _ _ _ (CmmMachOp (MO_U_Lt _) -- Note [null stack check] + [CmmMachOp (MO_Sub _) + [ CmmReg (CmmGlobal Sp) + , CmmLit (CmmInt 0 _)], + CmmReg (CmmGlobal SpLim)]) = zeroExpr dflags +areaToSp _ _ _ _ other = other -- ----------------------------------------------------------------------------- -- Note [null stack check] @@ -840,8 +844,8 @@ elimStackStores stackmap stackmaps area_off nodes -- Update info tables to include stack liveness -setInfoTableStackMap :: BlockEnv StackMap -> CmmDecl -> CmmDecl -setInfoTableStackMap stackmaps (CmmProc top_info@TopInfo{..} l g) +setInfoTableStackMap :: DynFlags -> BlockEnv StackMap -> CmmDecl -> CmmDecl +setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l g) = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l g where fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } = @@ -852,18 +856,18 @@ setInfoTableStackMap stackmaps (CmmProc top_info@TopInfo{..} l g) get_liveness lbl = case mapLookup lbl stackmaps of Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> ppr info_tbls) - Just sm -> stackMapToLiveness sm + Just sm -> stackMapToLiveness dflags sm -setInfoTableStackMap _ d = d +setInfoTableStackMap _ _ d = d -stackMapToLiveness :: StackMap -> Liveness -stackMapToLiveness StackMap{..} = +stackMapToLiveness :: DynFlags -> StackMap -> Liveness +stackMapToLiveness dflags StackMap{..} = reverse $ Array.elems $ - accumArray (\_ x -> x) True (toWords sm_ret_off + 1, - toWords (sm_sp - sm_args)) live_words + accumArray (\_ x -> x) True (toWords dflags sm_ret_off + 1, + toWords dflags (sm_sp - sm_args)) live_words where - live_words = [ (toWords off, False) + live_words = [ (toWords dflags off, False) | (r,off) <- eltsUFM sm_regs, isGcPtrType (localRegType r) ] @@ -910,14 +914,14 @@ lowerSafeForeignCall dflags block = do -- Both 'id' and 'new_base' are KindNonPtr because they're -- RTS-only objects and are not subject to garbage collection - id <- newTemp bWord - new_base <- newTemp (cmmRegType (CmmGlobal BaseReg)) + id <- newTemp (bWord dflags) + new_base <- newTemp (cmmRegType dflags (CmmGlobal BaseReg)) let (caller_save, caller_load) = callerSaveVolatileRegs dflags - load_tso <- newTemp gcWord - load_stack <- newTemp gcWord + load_tso <- newTemp (gcWord dflags) + load_stack <- newTemp (gcWord dflags) let suspend = saveThreadState dflags <*> caller_save <*> - mkMiddle (callSuspendThread id intrbl) + mkMiddle (callSuspendThread dflags id intrbl) midCall = mkUnsafeCall tgt res args resume = mkMiddle (callResumeThread new_base id) <*> -- Assign the result to BaseReg: we @@ -935,10 +939,10 @@ lowerSafeForeignCall dflags block -- received an exception during the call, then the stack might be -- different. Hence we continue by jumping to the top stack frame, -- not by jumping to succ. - jump = CmmCall { cml_target = CmmLoad (CmmReg spReg) bWord + jump = CmmCall { cml_target = CmmLoad (CmmReg spReg) (bWord dflags) , cml_cont = Just succ , cml_args_regs = regs - , cml_args = widthInBytes wordWidth + , cml_args = widthInBytes (wordWidth dflags) , cml_ret_args = ret_args , cml_ret_off = updfr } @@ -963,12 +967,12 @@ foreignLbl name = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId name)) newTemp :: CmmType -> UniqSM LocalReg newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep) -callSuspendThread :: LocalReg -> Bool -> CmmNode O O -callSuspendThread id intrbl = +callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O +callSuspendThread dflags id intrbl = CmmUnsafeForeignCall (ForeignTarget (foreignLbl (fsLit "suspendThread")) (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint])) - [id] [CmmReg (CmmGlobal BaseReg), CmmLit (mkIntCLit (fromEnum intrbl))] + [id] [CmmReg (CmmGlobal BaseReg), mkIntExpr dflags (fromEnum intrbl)] callResumeThread :: LocalReg -> LocalReg -> CmmNode O O callResumeThread new_base id = @@ -979,8 +983,8 @@ callResumeThread new_base id = -- ----------------------------------------------------------------------------- -plusW :: ByteOff -> WordOff -> ByteOff -plusW b w = b + w * wORD_SIZE +plusW :: DynFlags -> ByteOff -> WordOff -> ByteOff +plusW dflags b w = b + w * wORD_SIZE dflags dropEmpty :: WordOff -> [StackSlot] -> Maybe [StackSlot] dropEmpty 0 ss = Just ss @@ -991,14 +995,15 @@ isEmpty :: StackSlot -> Bool isEmpty Empty = True isEmpty _ = False -localRegBytes :: LocalReg -> ByteOff -localRegBytes r = roundUpToWords (widthInBytes (typeWidth (localRegType r))) +localRegBytes :: DynFlags -> LocalReg -> ByteOff +localRegBytes dflags r + = roundUpToWords dflags (widthInBytes (typeWidth (localRegType r))) -localRegWords :: LocalReg -> WordOff -localRegWords = toWords . localRegBytes +localRegWords :: DynFlags -> LocalReg -> WordOff +localRegWords dflags = toWords dflags . localRegBytes dflags -toWords :: ByteOff -> WordOff -toWords x = x `quot` wORD_SIZE +toWords :: DynFlags -> ByteOff -> WordOff +toWords dflags x = x `quot` wORD_SIZE dflags insertReloads :: StackMap -> [CmmNode O O] diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 47c30b1a0f..87a3ebfb5e 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -18,7 +18,7 @@ import PprCmm () import BlockId import FastString import Outputable -import Constants +import DynFlags import Data.Maybe @@ -31,15 +31,15 @@ import Data.Maybe -- Exported entry points: cmmLint :: (Outputable d, Outputable h) - => GenCmmGroup d h CmmGraph -> Maybe SDoc -cmmLint tops = runCmmLint (mapM_ lintCmmDecl) tops + => DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc +cmmLint dflags tops = runCmmLint dflags (mapM_ lintCmmDecl) tops -cmmLintGraph :: CmmGraph -> Maybe SDoc -cmmLintGraph g = runCmmLint lintCmmGraph g +cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc +cmmLintGraph dflags g = runCmmLint dflags lintCmmGraph g -runCmmLint :: Outputable a => (a -> CmmLint b) -> a -> Maybe SDoc -runCmmLint l p = - case unCL (l p) of +runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc +runCmmLint dflags l p = + case unCL (l p) dflags of Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"), nest 2 err, ptext $ sLit ("Program was:"), @@ -85,24 +85,29 @@ lintCmmExpr (CmmLoad expr rep) = do -- cmmCheckWordAddress expr return rep lintCmmExpr expr@(CmmMachOp op args) = do + dflags <- getDynFlags tys <- mapM lintCmmExpr args - if map (typeWidth . cmmExprType) args == machOpArgReps op + if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op then cmmCheckMachOp op args tys - else cmmLintMachOpErr expr (map cmmExprType args) (machOpArgReps op) + else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op) lintCmmExpr (CmmRegOff reg offset) - = lintCmmExpr (CmmMachOp (MO_Add rep) + = do dflags <- getDynFlags + let rep = typeWidth (cmmRegType dflags reg) + lintCmmExpr (CmmMachOp (MO_Add rep) [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)]) - where rep = typeWidth (cmmRegType reg) lintCmmExpr expr = - return (cmmExprType expr) + do dflags <- getDynFlags + return (cmmExprType dflags expr) -- Check for some common byte/word mismatches (eg. Sp + 1) cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys = cmmCheckMachOp op [reg, lit] tys cmmCheckMachOp op _ tys - = return (machOpResultType op tys) + = do dflags <- getDynFlags + return (machOpResultType dflags op tys) +{- isOffsetOp :: MachOp -> Bool isOffsetOp (MO_Add _) = True isOffsetOp (MO_Sub _) = True @@ -112,10 +117,10 @@ isOffsetOp _ = False -- check for funny-looking sub-word offsets. _cmmCheckWordAddress :: CmmExpr -> CmmLint () _cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) - | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0 + | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0 = cmmLintDubiousWordOffset e _cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) - | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0 + | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0 = cmmLintDubiousWordOffset e _cmmCheckWordAddress _ = return () @@ -125,14 +130,16 @@ _cmmCheckWordAddress _ notNodeReg :: CmmExpr -> Bool notNodeReg (CmmReg reg) | reg == nodeReg = False notNodeReg _ = True +-} lintCmmMiddle :: CmmNode O O -> CmmLint () lintCmmMiddle node = case node of CmmComment _ -> return () CmmAssign reg expr -> do + dflags <- getDynFlags erep <- lintCmmExpr expr - let reg_ty = cmmRegType reg + let reg_ty = cmmRegType dflags reg if (erep `cmmEqType_ignoring_ptrhood` reg_ty) then return () else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty @@ -152,14 +159,16 @@ lintCmmLast labels node = case node of CmmBranch id -> checkTarget id CmmCondBranch e t f -> do + dflags <- getDynFlags mapM_ checkTarget [t,f] _ <- lintCmmExpr e - checkCond e + checkCond dflags e CmmSwitch e branches -> do + dflags <- getDynFlags mapM_ checkTarget $ catMaybes branches erep <- lintCmmExpr e - if (erep `cmmEqType_ignoring_ptrhood` bWord) + if (erep `cmmEqType_ignoring_ptrhood` bWord dflags) then return () else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e <> text " :: " <> ppr erep) @@ -183,10 +192,10 @@ lintTarget (ForeignTarget e _) = lintCmmExpr e >> return () lintTarget (PrimTarget {}) = return () -checkCond :: CmmExpr -> CmmLint () -checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return () -checkCond (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values -checkCond expr +checkCond :: DynFlags -> CmmExpr -> CmmLint () +checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return () +checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values +checkCond _ expr = cmmLintErr (hang (text "expression is not a conditional:") 2 (ppr expr)) @@ -195,20 +204,24 @@ checkCond expr -- just a basic error monad: -newtype CmmLint a = CmmLint { unCL :: Either SDoc a } +newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a } instance Monad CmmLint where - CmmLint m >>= k = CmmLint $ case m of + CmmLint m >>= k = CmmLint $ \dflags -> + case m dflags of Left e -> Left e - Right a -> unCL (k a) - return a = CmmLint (Right a) + Right a -> unCL (k a) dflags + return a = CmmLint (\_ -> Right a) + +instance HasDynFlags CmmLint where + getDynFlags = CmmLint (\dflags -> Right dflags) cmmLintErr :: SDoc -> CmmLint a -cmmLintErr msg = CmmLint (Left msg) +cmmLintErr msg = CmmLint (\_ -> Left msg) addLintInfo :: SDoc -> CmmLint a -> CmmLint a -addLintInfo info thing = CmmLint $ - case unCL thing of +addLintInfo info thing = CmmLint $ \dflags -> + case unCL thing dflags of Left err -> Left (hang info 2 err) Right a -> Right a @@ -227,7 +240,10 @@ cmmLintAssignErr stmt e_ty r_ty text "Rhs ty:" <+> ppr e_ty])) +{- cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a cmmLintDubiousWordOffset expr = cmmLintErr (text "offset is not a multiple of words: " $$ nest 2 (ppr expr)) +-} + diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs index f42626f638..520c7e7a7d 100644 --- a/compiler/cmm/CmmMachOp.hs +++ b/compiler/cmm/CmmMachOp.hs @@ -13,7 +13,7 @@ module CmmMachOp , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32 , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord - , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32 + , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64 -- CallishMachOp , CallishMachOp(..) @@ -25,6 +25,7 @@ where import CmmType import Outputable +import DynFlags ----------------------------------------------------------------------------- -- MachOp @@ -122,58 +123,62 @@ mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe , mo_wordULe, mo_wordUGt, mo_wordULt , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr - , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32 , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord - , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32 + , mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64 + :: DynFlags -> MachOp + +mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32 + , mo_32To8, mo_32To16 :: MachOp -mo_wordAdd = MO_Add wordWidth -mo_wordSub = MO_Sub wordWidth -mo_wordEq = MO_Eq wordWidth -mo_wordNe = MO_Ne wordWidth -mo_wordMul = MO_Mul wordWidth -mo_wordSQuot = MO_S_Quot wordWidth -mo_wordSRem = MO_S_Rem wordWidth -mo_wordSNeg = MO_S_Neg wordWidth -mo_wordUQuot = MO_U_Quot wordWidth -mo_wordURem = MO_U_Rem wordWidth - -mo_wordSGe = MO_S_Ge wordWidth -mo_wordSLe = MO_S_Le wordWidth -mo_wordSGt = MO_S_Gt wordWidth -mo_wordSLt = MO_S_Lt wordWidth - -mo_wordUGe = MO_U_Ge wordWidth -mo_wordULe = MO_U_Le wordWidth -mo_wordUGt = MO_U_Gt wordWidth -mo_wordULt = MO_U_Lt wordWidth - -mo_wordAnd = MO_And wordWidth -mo_wordOr = MO_Or wordWidth -mo_wordXor = MO_Xor wordWidth -mo_wordNot = MO_Not wordWidth -mo_wordShl = MO_Shl wordWidth -mo_wordSShr = MO_S_Shr wordWidth -mo_wordUShr = MO_U_Shr wordWidth - -mo_u_8To32 = MO_UU_Conv W8 W32 -mo_s_8To32 = MO_SS_Conv W8 W32 -mo_u_16To32 = MO_UU_Conv W16 W32 -mo_s_16To32 = MO_SS_Conv W16 W32 - -mo_u_8ToWord = MO_UU_Conv W8 wordWidth -mo_s_8ToWord = MO_SS_Conv W8 wordWidth -mo_u_16ToWord = MO_UU_Conv W16 wordWidth -mo_s_16ToWord = MO_SS_Conv W16 wordWidth -mo_s_32ToWord = MO_SS_Conv W32 wordWidth -mo_u_32ToWord = MO_UU_Conv W32 wordWidth - -mo_WordTo8 = MO_UU_Conv wordWidth W8 -mo_WordTo16 = MO_UU_Conv wordWidth W16 -mo_WordTo32 = MO_UU_Conv wordWidth W32 - -mo_32To8 = MO_UU_Conv W32 W8 -mo_32To16 = MO_UU_Conv W32 W16 +mo_wordAdd dflags = MO_Add (wordWidth dflags) +mo_wordSub dflags = MO_Sub (wordWidth dflags) +mo_wordEq dflags = MO_Eq (wordWidth dflags) +mo_wordNe dflags = MO_Ne (wordWidth dflags) +mo_wordMul dflags = MO_Mul (wordWidth dflags) +mo_wordSQuot dflags = MO_S_Quot (wordWidth dflags) +mo_wordSRem dflags = MO_S_Rem (wordWidth dflags) +mo_wordSNeg dflags = MO_S_Neg (wordWidth dflags) +mo_wordUQuot dflags = MO_U_Quot (wordWidth dflags) +mo_wordURem dflags = MO_U_Rem (wordWidth dflags) + +mo_wordSGe dflags = MO_S_Ge (wordWidth dflags) +mo_wordSLe dflags = MO_S_Le (wordWidth dflags) +mo_wordSGt dflags = MO_S_Gt (wordWidth dflags) +mo_wordSLt dflags = MO_S_Lt (wordWidth dflags) + +mo_wordUGe dflags = MO_U_Ge (wordWidth dflags) +mo_wordULe dflags = MO_U_Le (wordWidth dflags) +mo_wordUGt dflags = MO_U_Gt (wordWidth dflags) +mo_wordULt dflags = MO_U_Lt (wordWidth dflags) + +mo_wordAnd dflags = MO_And (wordWidth dflags) +mo_wordOr dflags = MO_Or (wordWidth dflags) +mo_wordXor dflags = MO_Xor (wordWidth dflags) +mo_wordNot dflags = MO_Not (wordWidth dflags) +mo_wordShl dflags = MO_Shl (wordWidth dflags) +mo_wordSShr dflags = MO_S_Shr (wordWidth dflags) +mo_wordUShr dflags = MO_U_Shr (wordWidth dflags) + +mo_u_8To32 = MO_UU_Conv W8 W32 +mo_s_8To32 = MO_SS_Conv W8 W32 +mo_u_16To32 = MO_UU_Conv W16 W32 +mo_s_16To32 = MO_SS_Conv W16 W32 + +mo_u_8ToWord dflags = MO_UU_Conv W8 (wordWidth dflags) +mo_s_8ToWord dflags = MO_SS_Conv W8 (wordWidth dflags) +mo_u_16ToWord dflags = MO_UU_Conv W16 (wordWidth dflags) +mo_s_16ToWord dflags = MO_SS_Conv W16 (wordWidth dflags) +mo_s_32ToWord dflags = MO_SS_Conv W32 (wordWidth dflags) +mo_u_32ToWord dflags = MO_UU_Conv W32 (wordWidth dflags) + +mo_WordTo8 dflags = MO_UU_Conv (wordWidth dflags) W8 +mo_WordTo16 dflags = MO_UU_Conv (wordWidth dflags) W16 +mo_WordTo32 dflags = MO_UU_Conv (wordWidth dflags) W32 +mo_WordTo64 dflags = MO_UU_Conv (wordWidth dflags) W64 + +mo_32To8 = MO_UU_Conv W32 W8 +mo_32To16 = MO_UU_Conv W32 W16 -- ---------------------------------------------------------------------------- @@ -282,8 +287,8 @@ maybeInvertComparison op {- | Returns the MachRep of the result of a MachOp. -} -machOpResultType :: MachOp -> [CmmType] -> CmmType -machOpResultType mop tys = +machOpResultType :: DynFlags -> MachOp -> [CmmType] -> CmmType +machOpResultType dflags mop tys = case mop of MO_Add {} -> ty1 -- Preserve GC-ptr-hood MO_Sub {} -> ty1 -- of first arg @@ -296,29 +301,29 @@ machOpResultType mop tys = MO_U_Quot r -> cmmBits r MO_U_Rem r -> cmmBits r - MO_Eq {} -> comparisonResultRep - MO_Ne {} -> comparisonResultRep - MO_S_Ge {} -> comparisonResultRep - MO_S_Le {} -> comparisonResultRep - MO_S_Gt {} -> comparisonResultRep - MO_S_Lt {} -> comparisonResultRep + MO_Eq {} -> comparisonResultRep dflags + MO_Ne {} -> comparisonResultRep dflags + MO_S_Ge {} -> comparisonResultRep dflags + MO_S_Le {} -> comparisonResultRep dflags + MO_S_Gt {} -> comparisonResultRep dflags + MO_S_Lt {} -> comparisonResultRep dflags - MO_U_Ge {} -> comparisonResultRep - MO_U_Le {} -> comparisonResultRep - MO_U_Gt {} -> comparisonResultRep - MO_U_Lt {} -> comparisonResultRep + MO_U_Ge {} -> comparisonResultRep dflags + MO_U_Le {} -> comparisonResultRep dflags + MO_U_Gt {} -> comparisonResultRep dflags + MO_U_Lt {} -> comparisonResultRep dflags MO_F_Add r -> cmmFloat r MO_F_Sub r -> cmmFloat r MO_F_Mul r -> cmmFloat r MO_F_Quot r -> cmmFloat r MO_F_Neg r -> cmmFloat r - MO_F_Eq {} -> comparisonResultRep - MO_F_Ne {} -> comparisonResultRep - MO_F_Ge {} -> comparisonResultRep - MO_F_Le {} -> comparisonResultRep - MO_F_Gt {} -> comparisonResultRep - MO_F_Lt {} -> comparisonResultRep + MO_F_Eq {} -> comparisonResultRep dflags + MO_F_Ne {} -> comparisonResultRep dflags + MO_F_Ge {} -> comparisonResultRep dflags + MO_F_Le {} -> comparisonResultRep dflags + MO_F_Gt {} -> comparisonResultRep dflags + MO_F_Lt {} -> comparisonResultRep dflags MO_And {} -> ty1 -- Used for pointer masking MO_Or {} -> ty1 @@ -336,7 +341,7 @@ machOpResultType mop tys = where (ty1:_) = tys -comparisonResultRep :: CmmType +comparisonResultRep :: DynFlags -> CmmType comparisonResultRep = bWord -- is it? @@ -348,8 +353,8 @@ comparisonResultRep = bWord -- is it? -- its arguments are the same as the MachOp expects. This is used when -- linting a CmmExpr. -machOpArgReps :: MachOp -> [Width] -machOpArgReps op = +machOpArgReps :: DynFlags -> MachOp -> [Width] +machOpArgReps dflags op = case op of MO_Add r -> [r,r] MO_Sub r -> [r,r] @@ -390,9 +395,9 @@ machOpArgReps op = MO_Or r -> [r,r] MO_Xor r -> [r,r] MO_Not r -> [r] - MO_Shl r -> [r,wordWidth] - MO_U_Shr r -> [r,wordWidth] - MO_S_Shr r -> [r,wordWidth] + MO_Shl r -> [r, wordWidth dflags] + MO_U_Shr r -> [r, wordWidth dflags] + MO_S_Shr r -> [r, wordWidth dflags] MO_SS_Conv from _ -> [from] MO_UU_Conv from _ -> [from] diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs index fa41ed5f42..ae7ac091de 100644 --- a/compiler/cmm/CmmNode.hs +++ b/compiler/cmm/CmmNode.hs @@ -395,14 +395,7 @@ foldExp f (CmmCall {cml_target=tgt}) z = f tgt z foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z -foldExpDeep f = foldExp go - where -- go :: CmmExpr -> z -> z - go e@(CmmMachOp _ es) z = gos es $! f e z - go e@(CmmLoad addr _) z = go addr $! f e z - go e z = f e z - - gos [] z = z - gos (e:es) z = gos es $! f e z +foldExpDeep f = foldExp (wrapRecExpf f) -- ----------------------------------------------------------------------------- diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index 5f208244f8..0df24a6a66 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -183,8 +183,7 @@ cmmMiniInlineStmts dflags uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) -- not CmmLocal: that might invalidate the usage analysis results isTiny _ = False - platform = targetPlatform dflags - foldExp (CmmMachOp op args) = cmmMachOpFold platform op args + foldExp (CmmMachOp op args) = cmmMachOpFold dflags op args foldExp e = e ncgDebugTrace str x = if ncgDebugIsOn then trace str x else x @@ -302,17 +301,17 @@ inlineExpr _ _ other_expr = other_expr -- been optimized and folded. cmmMachOpFold - :: Platform + :: DynFlags -> MachOp -- The operation from an CmmMachOp -> [CmmExpr] -- The optimized arguments -> CmmExpr -cmmMachOpFold platform op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM platform op args) +cmmMachOpFold dflags op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM dflags op args) -- Returns Nothing if no changes, useful for Hoopl, also reduces -- allocation! cmmMachOpFoldM - :: Platform + :: DynFlags -> MachOp -> [CmmExpr] -> Maybe CmmExpr @@ -338,7 +337,7 @@ cmmMachOpFoldM _ (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = Just x cmmMachOpFoldM _ (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = Just x -- Eliminate nested conversions where possible -cmmMachOpFoldM platform conv_outer [CmmMachOp conv_inner [x]] +cmmMachOpFoldM dflags conv_outer [CmmMachOp conv_inner [x]] | Just (rep1,rep2,signed1) <- isIntConversion conv_inner, Just (_, rep3,signed2) <- isIntConversion conv_outer = case () of @@ -348,13 +347,13 @@ cmmMachOpFoldM platform conv_outer [CmmMachOp conv_inner [x]] -- but remember to use the signedness from the widening, just in case -- the final conversion is a widen. | rep1 < rep2 && rep2 > rep3 -> - Just $ cmmMachOpFold platform (intconv signed1 rep1 rep3) [x] + Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x] -- Nested widenings: collapse if the signedness is the same | rep1 < rep2 && rep2 < rep3 && signed1 == signed2 -> - Just $ cmmMachOpFold platform (intconv signed1 rep1 rep3) [x] + Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x] -- Nested narrowings: collapse | rep1 > rep2 && rep2 > rep3 -> - Just $ cmmMachOpFold platform (MO_UU_Conv rep1 rep3) [x] + Just $ cmmMachOpFold dflags (MO_UU_Conv rep1 rep3) [x] | otherwise -> Nothing where @@ -371,22 +370,22 @@ cmmMachOpFoldM platform conv_outer [CmmMachOp conv_inner [x]] -- but what if the architecture only supports word-sized loads, should -- we do the transformation anyway? -cmmMachOpFoldM _ mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)] +cmmMachOpFoldM dflags mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)] = case mop of -- for comparisons: don't forget to narrow the arguments before -- comparing, since they might be out of range. - MO_Eq _ -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) wordWidth) - MO_Ne _ -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) wordWidth) + MO_Eq _ -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth dflags)) + MO_Ne _ -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth dflags)) - MO_U_Gt _ -> Just $ CmmLit (CmmInt (if x_u > y_u then 1 else 0) wordWidth) - MO_U_Ge _ -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) wordWidth) - MO_U_Lt _ -> Just $ CmmLit (CmmInt (if x_u < y_u then 1 else 0) wordWidth) - MO_U_Le _ -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) wordWidth) + MO_U_Gt _ -> Just $ CmmLit (CmmInt (if x_u > y_u then 1 else 0) (wordWidth dflags)) + MO_U_Ge _ -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth dflags)) + MO_U_Lt _ -> Just $ CmmLit (CmmInt (if x_u < y_u then 1 else 0) (wordWidth dflags)) + MO_U_Le _ -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth dflags)) - MO_S_Gt _ -> Just $ CmmLit (CmmInt (if x_s > y_s then 1 else 0) wordWidth) - MO_S_Ge _ -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) wordWidth) - MO_S_Lt _ -> Just $ CmmLit (CmmInt (if x_s < y_s then 1 else 0) wordWidth) - MO_S_Le _ -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) wordWidth) + MO_S_Gt _ -> Just $ CmmLit (CmmInt (if x_s > y_s then 1 else 0) (wordWidth dflags)) + MO_S_Ge _ -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth dflags)) + MO_S_Lt _ -> Just $ CmmLit (CmmInt (if x_s < y_s then 1 else 0) (wordWidth dflags)) + MO_S_Le _ -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth dflags)) MO_Add r -> Just $ CmmLit (CmmInt (x + y) r) MO_Sub r -> Just $ CmmLit (CmmInt (x - y) r) @@ -418,9 +417,9 @@ cmmMachOpFoldM _ mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)] -- also assume that constants have been shifted to the right when -- possible. -cmmMachOpFoldM platform op [x@(CmmLit _), y] +cmmMachOpFoldM dflags op [x@(CmmLit _), y] | not (isLit y) && isCommutableMachOp op - = Just (cmmMachOpFold platform op [y, x]) + = Just (cmmMachOpFold dflags op [y, x]) -- Turn (a+b)+c into a+(b+c) where possible. Because literals are -- moved to the right, it is more likely that we will find @@ -438,19 +437,19 @@ cmmMachOpFoldM platform op [x@(CmmLit _), y] -- Also don't do it if arg1 is PicBaseReg, so that we don't separate the -- PicBaseReg from the corresponding label (or label difference). -- -cmmMachOpFoldM platform mop1 [CmmMachOp mop2 [arg1,arg2], arg3] +cmmMachOpFoldM dflags mop1 [CmmMachOp mop2 [arg1,arg2], arg3] | mop2 `associates_with` mop1 && not (isLit arg1) && not (isPicReg arg1) - = Just (cmmMachOpFold platform mop2 [arg1, cmmMachOpFold platform mop1 [arg2,arg3]]) + = Just (cmmMachOpFold dflags mop2 [arg1, cmmMachOpFold dflags mop1 [arg2,arg3]]) where MO_Add{} `associates_with` MO_Sub{} = True mop1 `associates_with` mop2 = mop1 == mop2 && isAssociativeMachOp mop1 -- special case: (a - b) + c ==> a + (c - b) -cmmMachOpFoldM platform mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3] +cmmMachOpFoldM dflags mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3] | not (isLit arg1) && not (isPicReg arg1) - = Just (cmmMachOpFold platform mop1 [arg1, cmmMachOpFold platform mop2 [arg3,arg2]]) + = Just (cmmMachOpFold dflags mop1 [arg1, cmmMachOpFold dflags mop2 [arg3,arg2]]) -- Make a RegOff if we can cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)] @@ -479,9 +478,9 @@ cmmMachOpFoldM _ (MO_Sub _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)] -- narrowing throws away bits from the operand, there's no way to do -- the same comparison at the larger size. -cmmMachOpFoldM platform cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)] +cmmMachOpFoldM dflags cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)] | -- powerPC NCG has a TODO for I8/I16 comparisons, so don't try - platformArch platform `elem` [ArchX86, ArchX86_64], + platformArch (targetPlatform dflags) `elem` [ArchX86, ArchX86_64], -- if the operand is widened: Just (rep, signed, narrow_fn) <- maybe_conversion conv, -- and this is a comparison operation: @@ -489,7 +488,7 @@ cmmMachOpFoldM platform cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)] -- and the literal fits in the smaller size: i == narrow_fn rep i -- then we can do the comparison at the smaller size - = Just (cmmMachOpFold platform narrow_cmp [x, CmmLit (CmmInt i rep)]) + = Just (cmmMachOpFold dflags narrow_cmp [x, CmmLit (CmmInt i rep)]) where maybe_conversion (MO_UU_Conv from to) | to > from @@ -522,7 +521,7 @@ cmmMachOpFoldM platform cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)] -- We can often do something with constants of 0 and 1 ... -cmmMachOpFoldM _ mop [x, y@(CmmLit (CmmInt 0 _))] +cmmMachOpFoldM dflags mop [x, y@(CmmLit (CmmInt 0 _))] = case mop of MO_Add _ -> Just x MO_Sub _ -> Just x @@ -537,15 +536,15 @@ cmmMachOpFoldM _ mop [x, y@(CmmLit (CmmInt 0 _))] MO_Eq _ | Just x' <- maybeInvertCmmExpr x -> Just x' MO_U_Gt _ | isComparisonExpr x -> Just x MO_S_Gt _ | isComparisonExpr x -> Just x - MO_U_Lt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 wordWidth) - MO_S_Lt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 wordWidth) - MO_U_Ge _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 wordWidth) - MO_S_Ge _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 wordWidth) + MO_U_Lt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 (wordWidth dflags)) + MO_S_Lt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 (wordWidth dflags)) + MO_U_Ge _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 (wordWidth dflags)) + MO_S_Ge _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 (wordWidth dflags)) MO_U_Le _ | Just x' <- maybeInvertCmmExpr x -> Just x' MO_S_Le _ | Just x' <- maybeInvertCmmExpr x -> Just x' _ -> Nothing -cmmMachOpFoldM _ mop [x, (CmmLit (CmmInt 1 rep))] +cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt 1 rep))] = case mop of MO_Mul _ -> Just x MO_S_Quot _ -> Just x @@ -556,24 +555,24 @@ cmmMachOpFoldM _ mop [x, (CmmLit (CmmInt 1 rep))] MO_Eq _ | isComparisonExpr x -> Just x MO_U_Lt _ | Just x' <- maybeInvertCmmExpr x -> Just x' MO_S_Lt _ | Just x' <- maybeInvertCmmExpr x -> Just x' - MO_U_Gt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 wordWidth) - MO_S_Gt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 wordWidth) - MO_U_Le _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 wordWidth) - MO_S_Le _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 wordWidth) + MO_U_Gt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 (wordWidth dflags)) + MO_S_Gt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 (wordWidth dflags)) + MO_U_Le _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 (wordWidth dflags)) + MO_S_Le _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 (wordWidth dflags)) MO_U_Ge _ | isComparisonExpr x -> Just x MO_S_Ge _ | isComparisonExpr x -> Just x _ -> Nothing -- Now look for multiplication/division by powers of 2 (integers). -cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt n _))] +cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt n _))] = case mop of MO_Mul rep | Just p <- exactLog2 n -> - Just (cmmMachOpFold platform (MO_Shl rep) [x, CmmLit (CmmInt p rep)]) + Just (cmmMachOpFold dflags (MO_Shl rep) [x, CmmLit (CmmInt p rep)]) MO_U_Quot rep | Just p <- exactLog2 n -> - Just (cmmMachOpFold platform (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)]) + Just (cmmMachOpFold dflags (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)]) MO_S_Quot rep | Just p <- exactLog2 n, CmmReg _ <- x -> -- We duplicate x below, hence require @@ -601,7 +600,7 @@ cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt n _))] CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)] x3 = CmmMachOp (MO_Add rep) [x, x2] in - Just (cmmMachOpFold platform (MO_S_Shr rep) [x3, CmmLit (CmmInt p rep)]) + Just (cmmMachOpFold dflags (MO_S_Shr rep) [x3, CmmLit (CmmInt p rep)]) _ -> Nothing -- ToDo (#7116): optimise floating-point multiplication, e.g. x*2.0 -> x+x diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 8a10724524..3061062a4c 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -340,9 +340,10 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals_without_hints0 ')' -- closure type, live regs {% withThisPackage $ \pkg -> - do live <- sequence (map (liftM Just) $7) + do dflags <- getDynFlags + live <- sequence (map (liftM Just) $7) let prof = NoProfilingInfo - bitmap = mkLiveness live + bitmap = mkLiveness dflags live rep = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap return (mkCmmRetLabel pkg $3, CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 @@ -522,7 +523,7 @@ expr0 :: { ExtFCode CmmExpr } -- leaving out the type of a literal gives you the native word size in C-- maybe_ty :: { CmmType } - : {- empty -} { bWord } + : {- empty -} {% do dflags <- getDynFlags; return $ bWord dflags } | '::' type { $2 } maybe_actuals :: { [ExtFCode HintedCmmActual] } @@ -611,7 +612,7 @@ typenot8 :: { CmmType } | 'bits64' { b64 } | 'float32' { f32 } | 'float64' { f64 } - | 'gcptr' { gcWord } + | 'gcptr' {% do dflags <- getDynFlags; return $ gcWord dflags } { section :: String -> Section section "text" = Text @@ -630,8 +631,9 @@ mkString s = CmmString (map (fromIntegral.ord) s) -- the op. mkMachOp :: (Width -> MachOp) -> [ExtFCode CmmExpr] -> ExtFCode CmmExpr mkMachOp fn args = do + dflags <- getDynFlags arg_exprs <- sequence args - return (CmmMachOp (fn (typeWidth (cmmExprType (head arg_exprs)))) arg_exprs) + return (CmmMachOp (fn (typeWidth (cmmExprType dflags (head arg_exprs)))) arg_exprs) getLit :: CmmExpr -> CmmLit getLit (CmmLit l) = l @@ -658,12 +660,12 @@ exprOp name args_code = do exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr) exprMacros dflags = listToUFM [ ( fsLit "ENTRY_CODE", \ [x] -> entryCode dflags x ), - ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr x ), + ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr dflags x ), ( fsLit "STD_INFO", \ [x] -> infoTable dflags x ), ( fsLit "FUN_INFO", \ [x] -> funInfoTable dflags x ), - ( fsLit "GET_ENTRY", \ [x] -> entryCode dflags (closureInfoPtr x) ), - ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr x) ), - ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr x) ), + ( fsLit "GET_ENTRY", \ [x] -> entryCode dflags (closureInfoPtr dflags x) ), + ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ), + ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ), ( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType dflags x ), ( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs dflags x ), ( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs dflags x ) @@ -868,7 +870,7 @@ foreignCall conv_string results_code expr_code args_code vols safety ret -- Temporary hack so at least some functions are CmmSafe CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args ret)) _ -> - let expr' = adjCallTarget platform convention expr args in + let expr' = adjCallTarget dflags convention expr args in case safety of CmmUnsafe -> code (emitForeignCall' PlayRisky results @@ -880,13 +882,14 @@ foreignCall conv_string results_code expr_code args_code vols safety ret code (emitForeignCall' PlayInterruptible results (CmmCallee expr' convention) args vols NoC_SRT ret) -adjCallTarget :: Platform -> CCallConv -> CmmExpr -> [CmmHinted CmmExpr] +adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [CmmHinted CmmExpr] -> CmmExpr -- On Windows, we have to add the '@N' suffix to the label when making -- a call with the stdcall calling convention. -adjCallTarget (Platform { platformOS = OSMinGW32 }) StdCallConv (CmmLit (CmmLabel lbl)) args +adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args + | platformOS (targetPlatform dflags) == OSMinGW32 = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args)))) - where size (CmmHinted e _) = max wORD_SIZE (widthInBytes (typeWidth (cmmExprType e))) + where size (CmmHinted e _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e))) -- c.f. CgForeignCall.emitForeignCall adjCallTarget _ _ expr _ = expr @@ -917,14 +920,15 @@ primCall results_code name args_code vols safety doStore :: CmmType -> ExtFCode CmmExpr -> ExtFCode CmmExpr -> ExtCode doStore rep addr_code val_code - = do addr <- addr_code + = do dflags <- getDynFlags + addr <- addr_code val <- val_code -- if the specified store type does not match the type of the expr -- on the rhs, then we insert a coercion that will cause the type -- mismatch to be flagged by cmm-lint. If we don't do this, then -- the store will happen at the wrong type, and the error will not -- be noticed. - let val_width = typeWidth (cmmExprType val) + let val_width = typeWidth (cmmExprType dflags val) rep_width = typeWidth rep let coerce_val | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val] @@ -940,8 +944,8 @@ emitRetUT args = do emitSimultaneously stmts -- NB. the args might overlap with the stack slots -- or regs that we assign to, so better use -- simultaneous assignments here (#3546) - when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp))) - stmtC $ CmmJump (entryCode dflags (CmmLoad (cmmRegOffW spReg sp) bWord)) (Just live) + when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW dflags spReg (-sp))) + stmtC $ CmmJump (entryCode dflags (CmmLoad (cmmRegOffW dflags spReg sp) (bWord dflags))) (Just live) -- ----------------------------------------------------------------------------- -- If-then-else and boolean expressions @@ -1050,9 +1054,9 @@ doSwitch mb_range scrut arms deflt initEnv :: DynFlags -> Env initEnv dflags = listToUFM [ ( fsLit "SIZEOF_StgHeader", - VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags * wORD_SIZE)) wordWidth) )), + VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags * wORD_SIZE dflags)) (wordWidth dflags)) )), ( fsLit "SIZEOF_StgInfoTable", - VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) wordWidth) )) + VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) )) ] parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup) diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index b3b4af712d..76927266ad 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -43,7 +43,7 @@ cmmPipeline hsc_env topSRT prog = tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog - (topSRT, cmms) <- {-# SCC "toTops" #-} doSRTs topSRT tops + (topSRT, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags topSRT tops dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms) return (topSRT, cmms) @@ -105,6 +105,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ------------- CAF analysis ---------------------------------------------- let cafEnv = {-# SCC "cafAnal" #-} cafAnal g + dumpIfSet_dyn dflags Opt_D_dump_cmmz "CAFEnv" (ppr cafEnv) if splitting_proc_points then do @@ -118,7 +119,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ------------- Populate info tables with stack info ----------------- gs <- {-# SCC "setInfoTableStackMap" #-} - return $ map (setInfoTableStackMap stackmaps) gs + return $ map (setInfoTableStackMap dflags stackmaps) gs dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs ----------- Control-flow optimisations ----------------------------- @@ -136,7 +137,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ------------- Populate info tables with stack info ----------------- g <- {-# SCC "setInfoTableStackMap" #-} - return $ setInfoTableStackMap stackmaps g + return $ setInfoTableStackMap dflags stackmaps g dump' Opt_D_dump_cmmz_info "after setInfoTableStackMap" g ----------- Control-flow optimisations ----------------------------- @@ -182,7 +183,7 @@ dumpGraph dflags flag name g = do when (dopt Opt_DoCmmLinting dflags) $ do_lint g dumpWith dflags flag name g where - do_lint g = case cmmLintGraph g of + do_lint g = case cmmLintGraph dflags g of Just err -> do { fatalErrorMsg dflags err ; ghcExit dflags 1 } diff --git a/compiler/cmm/CmmRewriteAssignments.hs b/compiler/cmm/CmmRewriteAssignments.hs index a5b7602078..585d78e95b 100644 --- a/compiler/cmm/CmmRewriteAssignments.hs +++ b/compiler/cmm/CmmRewriteAssignments.hs @@ -20,8 +20,8 @@ import CmmUtils import CmmOpt import StgCmmUtils +import DynFlags import UniqSupply -import Platform import UniqFM import Unique import BlockId @@ -35,8 +35,8 @@ import Prelude hiding (succ, zip) ---------------------------------------------------------------- --- Main function -rewriteAssignments :: Platform -> CmmGraph -> UniqSM CmmGraph -rewriteAssignments platform g = do +rewriteAssignments :: DynFlags -> CmmGraph -> UniqSM CmmGraph +rewriteAssignments dflags g = do -- Because we need to act on forwards and backwards information, we -- first perform usage analysis and bake this information into the -- graph (backwards transform), and then do a forwards transform @@ -44,8 +44,8 @@ rewriteAssignments platform g = do g' <- annotateUsage g g'' <- liftM fst $ dataflowPassFwd g' [(g_entry g, fact_bot assignmentLattice)] $ analRewFwd assignmentLattice - (assignmentTransfer platform) - (assignmentRewrite `thenFwdRw` machOpFoldRewrite platform) + (assignmentTransfer dflags) + (assignmentRewrite `thenFwdRw` machOpFoldRewrite dflags) return (modifyGraph eraseRegUsage g'') ---------------------------------------------------------------- @@ -309,7 +309,7 @@ invalidateUsersOf reg = mapUFM (invalidateUsers' reg) -- optimize; we need an algorithmic change to prevent us from having to -- traverse the /entire/ map continually. -middleAssignment :: Platform -> WithRegUsage CmmNode O O -> AssignmentMap +middleAssignment :: DynFlags -> WithRegUsage CmmNode O O -> AssignmentMap -> AssignmentMap -- Algorithm for annotated assignments: @@ -349,10 +349,10 @@ middleAssignment _ (Plain (CmmAssign (CmmLocal _) _)) assign = assign -- 1. Delete any sinking assignments that were used by this instruction -- 2. Look for all assignments that load from memory locations that -- were clobbered by this store and invalidate them. -middleAssignment _ (Plain n@(CmmStore lhs rhs)) assign +middleAssignment dflags (Plain n@(CmmStore lhs rhs)) assign = let m = deleteSinks n assign in foldUFM_Directly f m m -- [foldUFM performance] - where f u (xassign -> Just x) m | (lhs, rhs) `clobbers` (u, x) = addToUFM_Directly m u NeverOptimize + where f u (xassign -> Just x) m | clobbers dflags (lhs, rhs) (u, x) = addToUFM_Directly m u NeverOptimize f _ _ m = m {- Also leaky = mapUFM_Directly p . deleteSinks n $ assign @@ -371,7 +371,7 @@ middleAssignment _ (Plain n@(CmmStore lhs rhs)) assign -- This is kind of expensive. (One way to optimize this might be to -- store extra information about expressions that allow this and other -- checks to be done cheaply.) -middleAssignment platform (Plain n@(CmmUnsafeForeignCall{})) assign +middleAssignment dflags (Plain n@(CmmUnsafeForeignCall{})) assign = deleteCallerSaves (foldRegsDefd (\m r -> addToUFM m r NeverOptimize) (deleteSinks n assign) n) where deleteCallerSaves m = foldUFM_Directly f m m f u (xassign -> Just x) m | wrapRecExpf g x False = addToUFM_Directly m u NeverOptimize @@ -379,6 +379,7 @@ middleAssignment platform (Plain n@(CmmUnsafeForeignCall{})) assign g (CmmReg (CmmGlobal r)) _ | callerSaves platform r = True g (CmmRegOff (CmmGlobal r) _) _ | callerSaves platform r = True g _ b = b + platform = targetPlatform dflags middleAssignment _ (Plain (CmmComment {})) assign = assign @@ -398,17 +399,18 @@ middleAssignment _ (Plain (CmmComment {})) assign -- the next spill.) -- * Non stack-slot stores always conflict with each other. (This is -- not always the case; we could probably do something special for Hp) -clobbers :: (CmmExpr, CmmExpr) -- (lhs, rhs) of clobbering CmmStore +clobbers :: DynFlags + -> (CmmExpr, CmmExpr) -- (lhs, rhs) of clobbering CmmStore -> (Unique, CmmExpr) -- (register, expression) that may be clobbered -> Bool -clobbers (CmmRegOff (CmmGlobal Hp) _, _) (_, _) = False -clobbers (CmmReg (CmmGlobal Hp), _) (_, _) = False +clobbers _ (CmmRegOff (CmmGlobal Hp) _, _) (_, _) = False +clobbers _ (CmmReg (CmmGlobal Hp), _) (_, _) = False -- ToDo: Also catch MachOp case -clobbers (ss@CmmStackSlot{}, CmmReg (CmmLocal r)) (u, CmmLoad (ss'@CmmStackSlot{}) _) +clobbers _ (ss@CmmStackSlot{}, CmmReg (CmmLocal r)) (u, CmmLoad (ss'@CmmStackSlot{}) _) | getUnique r == u, ss == ss' = False -- No-op on the stack slot (XXX: Do we need this special case?) -clobbers (CmmStackSlot a o, rhs) (_, expr) = f expr +clobbers dflags (CmmStackSlot a o, rhs) (_, expr) = f expr where f (CmmLoad (CmmStackSlot a' o') t) - = (a, o, widthInBytes (cmmExprWidth rhs)) `overlaps` (a', o', widthInBytes (typeWidth t)) + = (a, o, widthInBytes (cmmExprWidth dflags rhs)) `overlaps` (a', o', widthInBytes (typeWidth t)) f (CmmLoad e _) = containsStackSlot e f (CmmMachOp _ es) = or (map f es) f _ = False @@ -418,7 +420,7 @@ clobbers (CmmStackSlot a o, rhs) (_, expr) = f expr containsStackSlot (CmmMachOp _ es) = or (map containsStackSlot es) containsStackSlot (CmmStackSlot{}) = True containsStackSlot _ = False -clobbers _ (_, e) = f e +clobbers _ _ (_, e) = f e where f (CmmLoad (CmmStackSlot _ _) _) = False f (CmmLoad{}) = True -- conservative f (CmmMachOp _ es) = or (map f es) @@ -463,11 +465,11 @@ invalidateVolatile k m = mapUFM p m exp _ = False p _ = NeverOptimize -- probably shouldn't happen with AlwaysSink -assignmentTransfer :: Platform +assignmentTransfer :: DynFlags -> FwdTransfer (WithRegUsage CmmNode) AssignmentMap -assignmentTransfer platform +assignmentTransfer dflags = mkFTransfer3 (flip const) - (middleAssignment platform) + (middleAssignment dflags) ((mkFactBase assignmentLattice .) . lastAssignment) -- Note [Soundness of inlining] @@ -611,8 +613,8 @@ assignmentRewrite = mkFRewrite3 first middle last -- in literals, which we can inline more aggressively, and inlining -- gives us opportunities for more folding. However, we don't need any -- facts to do MachOp folding. -machOpFoldRewrite :: Platform -> FwdRewrite UniqSM (WithRegUsage CmmNode) a -machOpFoldRewrite platform = mkFRewrite3 first middle last +machOpFoldRewrite :: DynFlags -> FwdRewrite UniqSM (WithRegUsage CmmNode) a +machOpFoldRewrite dflags = mkFRewrite3 first middle last where first _ _ = return Nothing middle :: WithRegUsage CmmNode O O -> a -> GenCmmReplGraph (WithRegUsage CmmNode) O O middle (Plain m) _ = return (fmap (mkMiddle . Plain) (foldNode m)) @@ -622,7 +624,7 @@ machOpFoldRewrite platform = mkFRewrite3 first middle last last (Plain l) _ = return (fmap (mkLast . Plain) (foldNode l)) foldNode :: CmmNode e x -> Maybe (CmmNode e x) foldNode n = mapExpDeepM foldExp n - foldExp (CmmMachOp op args) = cmmMachOpFoldM platform op args + foldExp (CmmMachOp op args) = cmmMachOpFoldM dflags op args foldExp _ = Nothing -- ToDo: Outputable instance for UsageMap and AssignmentMap diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs index 71ed4f09f8..8c5c99d469 100644 --- a/compiler/cmm/CmmSink.hs +++ b/compiler/cmm/CmmSink.hs @@ -237,8 +237,8 @@ walk dflags nodes assigs = go nodes emptyBlock assigs go [] block as = (block, as) go ((live,node):ns) block as | shouldDiscard node live = go ns block as - | Just a <- shouldSink node1 = go ns block (a : as1) - | otherwise = go ns block' as' + | Just a <- shouldSink dflags node1 = go ns block (a : as1) + | otherwise = go ns block' as' where (node1, as1) = tryToInline dflags live node as @@ -251,10 +251,10 @@ walk dflags nodes assigs = go nodes emptyBlock assigs -- be profitable to sink assignments to global regs too, but the -- liveness analysis doesn't track those (yet) so we can't. -- -shouldSink :: CmmNode e x -> Maybe Assignment -shouldSink (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprMem e) +shouldSink :: DynFlags -> CmmNode e x -> Maybe Assignment +shouldSink dflags (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprMem dflags e) where no_local_regs = True -- foldRegsUsed (\_ _ -> False) True e -shouldSink _other = Nothing +shouldSink _ _other = Nothing -- -- discard dead assignments. This doesn't do as good a job as @@ -342,7 +342,7 @@ tryToInline dflags live node assigs = go usages node [] assigs node' = mapExpDeep inline node where inline (CmmReg (CmmLocal l')) | l == l' = rhs inline (CmmRegOff (CmmLocal l') off) | l == l' - = cmmOffset rhs off + = cmmOffset dflags rhs off inline other = other go usages node skipped (assig@(l,rhs,_) : rest) @@ -407,7 +407,7 @@ conflicts dflags (r, rhs, addr) node | foldRegsUsed (\b r' -> r == r' || b) False node = True -- (2) a store to an address conflicts with a read of the same memory - | CmmStore addr' e <- node, memConflicts addr (loadAddr addr' (cmmExprWidth e)) = True + | CmmStore addr' e <- node, memConflicts addr (loadAddr dflags addr' (cmmExprWidth dflags e)) = True -- (3) an assignment to Hp/Sp conflicts with a heap/stack read respectively | HeapMem <- addr, CmmAssign (CmmGlobal Hp) _ <- node = True @@ -480,21 +480,21 @@ memConflicts (SpMem o1 w1) (SpMem o2 w2) | otherwise = o2 + w2 > o1 memConflicts _ _ = True -exprMem :: CmmExpr -> AbsMem -exprMem (CmmLoad addr w) = bothMems (loadAddr addr (typeWidth w)) (exprMem addr) -exprMem (CmmMachOp _ es) = foldr bothMems NoMem (map exprMem es) -exprMem _ = NoMem +exprMem :: DynFlags -> CmmExpr -> AbsMem +exprMem dflags (CmmLoad addr w) = bothMems (loadAddr dflags addr (typeWidth w)) (exprMem dflags addr) +exprMem dflags (CmmMachOp _ es) = foldr bothMems NoMem (map (exprMem dflags) es) +exprMem _ _ = NoMem -loadAddr :: CmmExpr -> Width -> AbsMem -loadAddr e w = +loadAddr :: DynFlags -> CmmExpr -> Width -> AbsMem +loadAddr dflags e w = case e of - CmmReg r -> regAddr r 0 w - CmmRegOff r i -> regAddr r i w + CmmReg r -> regAddr dflags r 0 w + CmmRegOff r i -> regAddr dflags r i w _other | CmmGlobal Sp `regUsedIn` e -> StackMem | otherwise -> AnyMem -regAddr :: CmmReg -> Int -> Width -> AbsMem -regAddr (CmmGlobal Sp) i w = SpMem i (widthInBytes w) -regAddr (CmmGlobal Hp) _ _ = HeapMem -regAddr r _ _ | isGcPtrType (cmmRegType r) = HeapMem -- yay! GCPtr pays for itself -regAddr _ _ _ = AnyMem +regAddr :: DynFlags -> CmmReg -> Int -> Width -> AbsMem +regAddr _ (CmmGlobal Sp) i w = SpMem i (widthInBytes w) +regAddr _ (CmmGlobal Hp) _ _ = HeapMem +regAddr dflags r _ _ | isGcPtrType (cmmRegType dflags r) = HeapMem -- yay! GCPtr pays for itself +regAddr _ _ _ _ = AnyMem diff --git a/compiler/cmm/CmmType.hs b/compiler/cmm/CmmType.hs index 59455d3b54..c0ce9e3d88 100644 --- a/compiler/cmm/CmmType.hs +++ b/compiler/cmm/CmmType.hs @@ -17,7 +17,7 @@ where #include "HsVersions.h" -import Constants +import DynFlags import FastString import Outputable @@ -95,10 +95,14 @@ f32 = cmmFloat W32 f64 = cmmFloat W64 -- CmmTypes of native word widths -bWord, bHalfWord, gcWord :: CmmType -bWord = cmmBits wordWidth -bHalfWord = cmmBits halfWordWidth -gcWord = CmmType GcPtrCat wordWidth +bWord :: DynFlags -> CmmType +bWord dflags = cmmBits (wordWidth dflags) + +bHalfWord :: DynFlags -> CmmType +bHalfWord dflags = cmmBits (halfWordWidth dflags) + +gcWord :: DynFlags -> CmmType +gcWord dflags = CmmType GcPtrCat (wordWidth dflags) cInt, cLong :: CmmType cInt = cmmBits cIntWidth @@ -155,19 +159,23 @@ mrStr W80 = sLit("W80") -------- Common Widths ------------ -wordWidth, halfWordWidth :: Width -wordWidth | wORD_SIZE == 4 = W32 - | wORD_SIZE == 8 = W64 - | otherwise = panic "MachOp.wordRep: Unknown word size" - -halfWordWidth | wORD_SIZE == 4 = W16 - | wORD_SIZE == 8 = W32 - | otherwise = panic "MachOp.halfWordRep: Unknown word size" - -halfWordMask :: Integer -halfWordMask | wORD_SIZE == 4 = 0xFFFF - | wORD_SIZE == 8 = 0xFFFFFFFF - | otherwise = panic "MachOp.halfWordMask: Unknown word size" +wordWidth :: DynFlags -> Width +wordWidth dflags + | wORD_SIZE dflags == 4 = W32 + | wORD_SIZE dflags == 8 = W64 + | otherwise = panic "MachOp.wordRep: Unknown word size" + +halfWordWidth :: DynFlags -> Width +halfWordWidth dflags + | wORD_SIZE dflags == 4 = W16 + | wORD_SIZE dflags == 8 = W32 + | otherwise = panic "MachOp.halfWordRep: Unknown word size" + +halfWordMask :: DynFlags -> Integer +halfWordMask dflags + | wORD_SIZE dflags == 4 = 0xFFFF + | wORD_SIZE dflags == 8 = 0xFFFFFFFF + | otherwise = panic "MachOp.halfWordMask: Unknown word size" -- cIntRep is the Width for a C-language 'int' cIntWidth, cLongWidth :: Width diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs index 615e2fd625..bff4804fc2 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -1,10 +1,4 @@ {-# LANGUAGE GADTs #-} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details {-# OPTIONS_GHC -fno-warn-deprecations #-} -- Warnings from deprecated blockToNodeList @@ -18,36 +12,37 @@ -- ----------------------------------------------------------------------------- -module CmmUtils( +module CmmUtils( -- CmmType - primRepCmmType, primRepForeignHint, - typeCmmType, typeForeignHint, + primRepCmmType, primRepForeignHint, + typeCmmType, typeForeignHint, - -- CmmLit - zeroCLit, mkIntCLit, - mkWordCLit, packHalfWordsCLit, - mkByteStringCLit, + -- CmmLit + zeroCLit, mkIntCLit, + mkWordCLit, packHalfWordsCLit, + mkByteStringCLit, mkDataLits, mkRODataLits, - -- CmmExpr - mkLblExpr, - cmmRegOff, cmmOffset, cmmLabelOff, cmmOffsetLit, cmmOffsetExpr, - cmmRegOffB, cmmOffsetB, cmmLabelOffB, cmmOffsetLitB, cmmOffsetExprB, - cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW, - cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW, - cmmNegate, - cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord, - cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord, - cmmUShrWord, cmmAddWord, cmmMulWord, - - isTrivialCmmExpr, hasNoGlobalRegs, - - -- Statics - blankWord, - - -- Tagging - cmmTagMask, cmmPointerMask, cmmUntag, cmmGetTag, cmmIsTagged, - cmmConstrTag, cmmConstrTag1, + -- CmmExpr + mkIntExpr, zeroExpr, + mkLblExpr, + cmmRegOff, cmmOffset, cmmLabelOff, cmmOffsetLit, cmmOffsetExpr, + cmmRegOffB, cmmOffsetB, cmmLabelOffB, cmmOffsetLitB, cmmOffsetExprB, + cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW, + cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW, + cmmNegate, + cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord, + cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord, + cmmUShrWord, cmmAddWord, cmmMulWord, cmmQuotWord, + + isTrivialCmmExpr, hasNoGlobalRegs, + + -- Statics + blankWord, + + -- Tagging + cmmTagMask, cmmPointerMask, cmmUntag, cmmGetTag, cmmIsTagged, + cmmConstrTag, cmmConstrTag1, -- Liveness and bitmaps mkLiveness, @@ -59,7 +54,7 @@ module CmmUtils( ofBlockMap, toBlockMap, insertBlock, ofBlockList, toBlockList, bodyToBlockList, foldGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1, - + analFwd, analBwd, analRewFwd, analRewBwd, dataflowPassFwd, dataflowPassBwd, dataflowAnalFwd, dataflowAnalBwd, dataflowAnalFwdBlocks @@ -67,8 +62,8 @@ module CmmUtils( #include "HsVersions.h" -import TyCon ( PrimRep(..) ) -import Type ( UnaryType, typePrimRep ) +import TyCon ( PrimRep(..) ) +import Type ( UnaryType, typePrimRep ) import SMRep import Cmm @@ -77,7 +72,7 @@ import CLabel import Outputable import Unique import UniqSupply -import Constants( wORD_SIZE, tAG_MASK ) +import DynFlags import Util import Data.Word @@ -87,52 +82,58 @@ import Hoopl --------------------------------------------------- -- --- CmmTypes +-- CmmTypes -- --------------------------------------------------- -primRepCmmType :: PrimRep -> CmmType -primRepCmmType VoidRep = panic "primRepCmmType:VoidRep" -primRepCmmType PtrRep = gcWord -primRepCmmType IntRep = bWord -primRepCmmType WordRep = bWord -primRepCmmType Int64Rep = b64 -primRepCmmType Word64Rep = b64 -primRepCmmType AddrRep = bWord -primRepCmmType FloatRep = f32 -primRepCmmType DoubleRep = f64 +primRepCmmType :: DynFlags -> PrimRep -> CmmType +primRepCmmType _ VoidRep = panic "primRepCmmType:VoidRep" +primRepCmmType dflags PtrRep = gcWord dflags +primRepCmmType dflags IntRep = bWord dflags +primRepCmmType dflags WordRep = bWord dflags +primRepCmmType _ Int64Rep = b64 +primRepCmmType _ Word64Rep = b64 +primRepCmmType dflags AddrRep = bWord dflags +primRepCmmType _ FloatRep = f32 +primRepCmmType _ DoubleRep = f64 -typeCmmType :: UnaryType -> CmmType -typeCmmType ty = primRepCmmType (typePrimRep ty) +typeCmmType :: DynFlags -> UnaryType -> CmmType +typeCmmType dflags ty = primRepCmmType dflags (typePrimRep ty) primRepForeignHint :: PrimRep -> ForeignHint -primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep" -primRepForeignHint PtrRep = AddrHint -primRepForeignHint IntRep = SignedHint -primRepForeignHint WordRep = NoHint -primRepForeignHint Int64Rep = SignedHint -primRepForeignHint Word64Rep = NoHint +primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep" +primRepForeignHint PtrRep = AddrHint +primRepForeignHint IntRep = SignedHint +primRepForeignHint WordRep = NoHint +primRepForeignHint Int64Rep = SignedHint +primRepForeignHint Word64Rep = NoHint primRepForeignHint AddrRep = AddrHint -- NB! AddrHint, but NonPtrArg -primRepForeignHint FloatRep = NoHint -primRepForeignHint DoubleRep = NoHint +primRepForeignHint FloatRep = NoHint +primRepForeignHint DoubleRep = NoHint typeForeignHint :: UnaryType -> ForeignHint typeForeignHint = primRepForeignHint . typePrimRep --------------------------------------------------- -- --- CmmLit +-- CmmLit -- --------------------------------------------------- -mkIntCLit :: Int -> CmmLit -mkIntCLit i = CmmInt (toInteger i) wordWidth +mkIntCLit :: DynFlags -> Int -> CmmLit +mkIntCLit dflags i = CmmInt (toInteger i) (wordWidth dflags) -zeroCLit :: CmmLit -zeroCLit = CmmInt 0 wordWidth +mkIntExpr :: DynFlags -> Int -> CmmExpr +mkIntExpr dflags i = CmmLit $! mkIntCLit dflags i + +zeroCLit :: DynFlags -> CmmLit +zeroCLit dflags = CmmInt 0 (wordWidth dflags) + +zeroExpr :: DynFlags -> CmmExpr +zeroExpr dflags = CmmLit (zeroCLit dflags) mkByteStringCLit :: Unique -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt) --- We have to make a top-level decl for the string, +-- We have to make a top-level decl for the string, -- and return a literal pointing to it mkByteStringCLit uniq bytes = (CmmLabel lbl, CmmData ReadOnlyData $ Statics lbl [CmmString bytes]) @@ -147,44 +148,44 @@ mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt -- Build a read-only data block mkRODataLits lbl lits = mkDataLits section lbl lits - where + where section | any needsRelocation lits = RelocatableReadOnlyData | otherwise = ReadOnlyData needsRelocation (CmmLabel _) = True needsRelocation (CmmLabelOff _ _) = True needsRelocation _ = False -mkWordCLit :: StgWord -> CmmLit -mkWordCLit wd = CmmInt (fromIntegral wd) wordWidth +mkWordCLit :: DynFlags -> StgWord -> CmmLit +mkWordCLit dflags wd = CmmInt (fromIntegral wd) (wordWidth dflags) -packHalfWordsCLit :: (Integral a, Integral b) => a -> b -> CmmLit +packHalfWordsCLit :: (Integral a, Integral b) => DynFlags -> a -> b -> CmmLit -- Make a single word literal in which the lower_half_word is --- at the lower address, and the upper_half_word is at the +-- at the lower address, and the upper_half_word is at the -- higher address -- ToDo: consider using half-word lits instead --- but be careful: that's vulnerable when reversed -packHalfWordsCLit lower_half_word upper_half_word +-- but be careful: that's vulnerable when reversed +packHalfWordsCLit dflags lower_half_word upper_half_word #ifdef WORDS_BIGENDIAN - = mkWordCLit ((fromIntegral lower_half_word `shiftL` hALF_WORD_SIZE_IN_BITS) - .|. fromIntegral upper_half_word) -#else - = mkWordCLit ((fromIntegral lower_half_word) - .|. (fromIntegral upper_half_word `shiftL` hALF_WORD_SIZE_IN_BITS)) + = mkWordCLit dflags ((fromIntegral lower_half_word `shiftL` hALF_WORD_SIZE_IN_BITS) + .|. fromIntegral upper_half_word) +#else + = mkWordCLit dflags ((fromIntegral lower_half_word) + .|. (fromIntegral upper_half_word `shiftL` hALF_WORD_SIZE_IN_BITS)) #endif --------------------------------------------------- -- --- CmmExpr +-- CmmExpr -- --------------------------------------------------- mkLblExpr :: CLabel -> CmmExpr mkLblExpr lbl = CmmLit (CmmLabel lbl) -cmmOffsetExpr :: CmmExpr -> CmmExpr -> CmmExpr +cmmOffsetExpr :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr -- assumes base and offset have the same CmmType -cmmOffsetExpr e (CmmLit (CmmInt n _)) = cmmOffset e (fromInteger n) -cmmOffsetExpr e byte_off = CmmMachOp (MO_Add (cmmExprWidth e)) [e, byte_off] +cmmOffsetExpr dflags e (CmmLit (CmmInt n _)) = cmmOffset dflags e (fromInteger n) +cmmOffsetExpr dflags e byte_off = CmmMachOp (MO_Add (cmmExprWidth dflags e)) [e, byte_off] -- NB. Do *not* inspect the value of the offset in these smart constructors!!! -- because the offset is sometimes involved in a loop in the code generator @@ -193,28 +194,28 @@ cmmOffsetExpr e byte_off = CmmMachOp (MO_Add (cmmExprWidth e)) [e, byte_off] -- stage; they're eliminated later instead (either during printing or -- a later optimisation step on Cmm). -- -cmmOffset :: CmmExpr -> Int -> CmmExpr -cmmOffset e 0 = e -cmmOffset (CmmReg reg) byte_off = cmmRegOff reg byte_off -cmmOffset (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off) -cmmOffset (CmmLit lit) byte_off = CmmLit (cmmOffsetLit lit byte_off) -cmmOffset (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2 - = CmmMachOp (MO_Add rep) - [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)] -cmmOffset expr byte_off +cmmOffset :: DynFlags -> CmmExpr -> Int -> CmmExpr +cmmOffset _ e 0 = e +cmmOffset _ (CmmReg reg) byte_off = cmmRegOff reg byte_off +cmmOffset _ (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off) +cmmOffset _ (CmmLit lit) byte_off = CmmLit (cmmOffsetLit lit byte_off) +cmmOffset _ (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2 + = CmmMachOp (MO_Add rep) + [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)] +cmmOffset dflags expr byte_off = CmmMachOp (MO_Add width) [expr, CmmLit (CmmInt (toInteger byte_off) width)] where - width = cmmExprWidth expr + width = cmmExprWidth dflags expr -- Smart constructor for CmmRegOff. Same caveats as cmmOffset above. cmmRegOff :: CmmReg -> Int -> CmmExpr cmmRegOff reg byte_off = CmmRegOff reg byte_off cmmOffsetLit :: CmmLit -> Int -> CmmLit -cmmOffsetLit (CmmLabel l) byte_off = cmmLabelOff l byte_off -cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off) +cmmOffsetLit (CmmLabel l) byte_off = cmmLabelOff l byte_off +cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off) cmmOffsetLit (CmmInt m rep) byte_off = CmmInt (m + fromIntegral byte_off) rep -cmmOffsetLit _ byte_off = pprPanic "cmmOffsetLit" (ppr byte_off) +cmmOffsetLit _ byte_off = pprPanic "cmmOffsetLit" (ppr byte_off) cmmLabelOff :: CLabel -> Int -> CmmLit -- Smart constructor for CmmLabelOff @@ -223,35 +224,37 @@ cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off -- | Useful for creating an index into an array, with a staticaly known offset. -- The type is the element type; used for making the multiplier -cmmIndex :: Width -- Width w - -> CmmExpr -- Address of vector of items of width w - -> Int -- Which element of the vector (0 based) - -> CmmExpr -- Address of i'th element -cmmIndex width base idx = cmmOffset base (idx * widthInBytes width) +cmmIndex :: DynFlags + -> Width -- Width w + -> CmmExpr -- Address of vector of items of width w + -> Int -- Which element of the vector (0 based) + -> CmmExpr -- Address of i'th element +cmmIndex dflags width base idx = cmmOffset dflags base (idx * widthInBytes width) -- | Useful for creating an index into an array, with an unknown offset. -cmmIndexExpr :: Width -- Width w - -> CmmExpr -- Address of vector of items of width w - -> CmmExpr -- Which element of the vector (0 based) - -> CmmExpr -- Address of i'th element -cmmIndexExpr width base (CmmLit (CmmInt n _)) = cmmIndex width base (fromInteger n) -cmmIndexExpr width base idx = - cmmOffsetExpr base byte_off +cmmIndexExpr :: DynFlags + -> Width -- Width w + -> CmmExpr -- Address of vector of items of width w + -> CmmExpr -- Which element of the vector (0 based) + -> CmmExpr -- Address of i'th element +cmmIndexExpr dflags width base (CmmLit (CmmInt n _)) = cmmIndex dflags width base (fromInteger n) +cmmIndexExpr dflags width base idx = + cmmOffsetExpr dflags base byte_off where - idx_w = cmmExprWidth idx - byte_off = CmmMachOp (MO_Shl idx_w) [idx, CmmLit (mkIntCLit (widthInLog width))] + idx_w = cmmExprWidth dflags idx + byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr dflags (widthInLog width)] -cmmLoadIndex :: CmmType -> CmmExpr -> Int -> CmmExpr -cmmLoadIndex ty expr ix = CmmLoad (cmmIndex (typeWidth ty) expr ix) ty +cmmLoadIndex :: DynFlags -> CmmType -> CmmExpr -> Int -> CmmExpr +cmmLoadIndex dflags ty expr ix = CmmLoad (cmmIndex dflags (typeWidth ty) expr ix) ty -- The "B" variants take byte offsets cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr cmmRegOffB = cmmRegOff -cmmOffsetB :: CmmExpr -> ByteOff -> CmmExpr +cmmOffsetB :: DynFlags -> CmmExpr -> ByteOff -> CmmExpr cmmOffsetB = cmmOffset -cmmOffsetExprB :: CmmExpr -> CmmExpr -> CmmExpr +cmmOffsetExprB :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr cmmOffsetExprB = cmmOffsetExpr cmmLabelOffB :: CLabel -> ByteOff -> CmmLit @@ -262,103 +265,103 @@ cmmOffsetLitB = cmmOffsetLit ----------------------- -- The "W" variants take word offsets -cmmOffsetExprW :: CmmExpr -> CmmExpr -> CmmExpr +cmmOffsetExprW :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr -- The second arg is a *word* offset; need to change it to bytes -cmmOffsetExprW e (CmmLit (CmmInt n _)) = cmmOffsetW e (fromInteger n) -cmmOffsetExprW e wd_off = cmmIndexExpr wordWidth e wd_off +cmmOffsetExprW dflags e (CmmLit (CmmInt n _)) = cmmOffsetW dflags e (fromInteger n) +cmmOffsetExprW dflags e wd_off = cmmIndexExpr dflags (wordWidth dflags) e wd_off -cmmOffsetW :: CmmExpr -> WordOff -> CmmExpr -cmmOffsetW e n = cmmOffsetB e (wORD_SIZE * n) +cmmOffsetW :: DynFlags -> CmmExpr -> WordOff -> CmmExpr +cmmOffsetW dflags e n = cmmOffsetB dflags e (wORD_SIZE dflags * n) -cmmRegOffW :: CmmReg -> WordOff -> CmmExpr -cmmRegOffW reg wd_off = cmmRegOffB reg (wd_off * wORD_SIZE) +cmmRegOffW :: DynFlags -> CmmReg -> WordOff -> CmmExpr +cmmRegOffW dflags reg wd_off = cmmRegOffB reg (wd_off * wORD_SIZE dflags) -cmmOffsetLitW :: CmmLit -> WordOff -> CmmLit -cmmOffsetLitW lit wd_off = cmmOffsetLitB lit (wORD_SIZE * wd_off) +cmmOffsetLitW :: DynFlags -> CmmLit -> WordOff -> CmmLit +cmmOffsetLitW dflags lit wd_off = cmmOffsetLitB lit (wORD_SIZE dflags * wd_off) -cmmLabelOffW :: CLabel -> WordOff -> CmmLit -cmmLabelOffW lbl wd_off = cmmLabelOffB lbl (wORD_SIZE * wd_off) +cmmLabelOffW :: DynFlags -> CLabel -> WordOff -> CmmLit +cmmLabelOffW dflags lbl wd_off = cmmLabelOffB lbl (wORD_SIZE dflags * wd_off) -cmmLoadIndexW :: CmmExpr -> Int -> CmmType -> CmmExpr -cmmLoadIndexW base off ty = CmmLoad (cmmOffsetW base off) ty +cmmLoadIndexW :: DynFlags -> CmmExpr -> Int -> CmmType -> CmmExpr +cmmLoadIndexW dflags base off ty = CmmLoad (cmmOffsetW dflags base off) ty ----------------------- cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord, cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord, - cmmUShrWord, cmmAddWord, cmmMulWord - :: CmmExpr -> CmmExpr -> CmmExpr -cmmOrWord e1 e2 = CmmMachOp mo_wordOr [e1, e2] -cmmAndWord e1 e2 = CmmMachOp mo_wordAnd [e1, e2] -cmmNeWord e1 e2 = CmmMachOp mo_wordNe [e1, e2] -cmmEqWord e1 e2 = CmmMachOp mo_wordEq [e1, e2] -cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2] -cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2] -cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2] ---cmmShlWord e1 e2 = CmmMachOp mo_wordShl [e1, e2] -cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2] -cmmAddWord e1 e2 = CmmMachOp mo_wordAdd [e1, e2] -cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2] -cmmMulWord e1 e2 = CmmMachOp mo_wordMul [e1, e2] - -cmmNegate :: CmmExpr -> CmmExpr -cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep) -cmmNegate e = CmmMachOp (MO_S_Neg (cmmExprWidth e)) [e] - -blankWord :: CmmStatic -blankWord = CmmUninitialised wORD_SIZE + cmmUShrWord, cmmAddWord, cmmMulWord, cmmQuotWord + :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr +cmmOrWord dflags e1 e2 = CmmMachOp (mo_wordOr dflags) [e1, e2] +cmmAndWord dflags e1 e2 = CmmMachOp (mo_wordAnd dflags) [e1, e2] +cmmNeWord dflags e1 e2 = CmmMachOp (mo_wordNe dflags) [e1, e2] +cmmEqWord dflags e1 e2 = CmmMachOp (mo_wordEq dflags) [e1, e2] +cmmULtWord dflags e1 e2 = CmmMachOp (mo_wordULt dflags) [e1, e2] +cmmUGeWord dflags e1 e2 = CmmMachOp (mo_wordUGe dflags) [e1, e2] +cmmUGtWord dflags e1 e2 = CmmMachOp (mo_wordUGt dflags) [e1, e2] +--cmmShlWord dflags e1 e2 = CmmMachOp (mo_wordShl dflags) [e1, e2] +cmmUShrWord dflags e1 e2 = CmmMachOp (mo_wordUShr dflags) [e1, e2] +cmmAddWord dflags e1 e2 = CmmMachOp (mo_wordAdd dflags) [e1, e2] +cmmSubWord dflags e1 e2 = CmmMachOp (mo_wordSub dflags) [e1, e2] +cmmMulWord dflags e1 e2 = CmmMachOp (mo_wordMul dflags) [e1, e2] +cmmQuotWord dflags e1 e2 = CmmMachOp (mo_wordUQuot dflags) [e1, e2] + +cmmNegate :: DynFlags -> CmmExpr -> CmmExpr +cmmNegate _ (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep) +cmmNegate dflags e = CmmMachOp (MO_S_Neg (cmmExprWidth dflags e)) [e] + +blankWord :: DynFlags -> CmmStatic +blankWord dflags = CmmUninitialised (wORD_SIZE dflags) --------------------------------------------------- -- --- CmmExpr predicates +-- CmmExpr predicates -- --------------------------------------------------- isTrivialCmmExpr :: CmmExpr -> Bool -isTrivialCmmExpr (CmmLoad _ _) = False -isTrivialCmmExpr (CmmMachOp _ _) = False -isTrivialCmmExpr (CmmLit _) = True -isTrivialCmmExpr (CmmReg _) = True -isTrivialCmmExpr (CmmRegOff _ _) = True +isTrivialCmmExpr (CmmLoad _ _) = False +isTrivialCmmExpr (CmmMachOp _ _) = False +isTrivialCmmExpr (CmmLit _) = True +isTrivialCmmExpr (CmmReg _) = True +isTrivialCmmExpr (CmmRegOff _ _) = True isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot" hasNoGlobalRegs :: CmmExpr -> Bool -hasNoGlobalRegs (CmmLoad e _) = hasNoGlobalRegs e -hasNoGlobalRegs (CmmMachOp _ es) = all hasNoGlobalRegs es -hasNoGlobalRegs (CmmLit _) = True +hasNoGlobalRegs (CmmLoad e _) = hasNoGlobalRegs e +hasNoGlobalRegs (CmmMachOp _ es) = all hasNoGlobalRegs es +hasNoGlobalRegs (CmmLit _) = True hasNoGlobalRegs (CmmReg (CmmLocal _)) = True hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True hasNoGlobalRegs _ = False --------------------------------------------------- -- --- Tagging +-- Tagging -- --------------------------------------------------- -- Tag bits mask --cmmTagBits = CmmLit (mkIntCLit tAG_BITS) -cmmTagMask, cmmPointerMask :: CmmExpr -cmmTagMask = CmmLit (mkIntCLit tAG_MASK) -cmmPointerMask = CmmLit (mkIntCLit (complement tAG_MASK)) +cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr +cmmTagMask dflags = mkIntExpr dflags (tAG_MASK dflags) +cmmPointerMask dflags = mkIntExpr dflags (complement (tAG_MASK dflags)) -- Used to untag a possibly tagged pointer -- A static label need not be untagged -cmmUntag, cmmGetTag :: CmmExpr -> CmmExpr -cmmUntag e@(CmmLit (CmmLabel _)) = e +cmmUntag, cmmGetTag :: DynFlags -> CmmExpr -> CmmExpr +cmmUntag _ e@(CmmLit (CmmLabel _)) = e -- Default case -cmmUntag e = (e `cmmAndWord` cmmPointerMask) +cmmUntag dflags e = cmmAndWord dflags e (cmmPointerMask dflags) -cmmGetTag e = (e `cmmAndWord` cmmTagMask) +cmmGetTag dflags e = cmmAndWord dflags e (cmmTagMask dflags) -- Test if a closure pointer is untagged -cmmIsTagged :: CmmExpr -> CmmExpr -cmmIsTagged e = (e `cmmAndWord` cmmTagMask) - `cmmNeWord` CmmLit zeroCLit +cmmIsTagged :: DynFlags -> CmmExpr -> CmmExpr +cmmIsTagged dflags e = cmmNeWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (zeroExpr dflags) -cmmConstrTag, cmmConstrTag1 :: CmmExpr -> CmmExpr -cmmConstrTag e = (e `cmmAndWord` cmmTagMask) `cmmSubWord` (CmmLit (mkIntCLit 1)) +cmmConstrTag, cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr +cmmConstrTag dflags e = cmmSubWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (mkIntExpr dflags 1) -- Get constructor tag, but one based. -cmmConstrTag1 e = e `cmmAndWord` cmmTagMask +cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags) -------------------------------------------- @@ -367,15 +370,15 @@ cmmConstrTag1 e = e `cmmAndWord` cmmTagMask -- --------------------------------------------- -mkLiveness :: [Maybe LocalReg] -> Liveness -mkLiveness [] = [] -mkLiveness (reg:regs) - = take sizeW bits ++ mkLiveness regs +mkLiveness :: DynFlags -> [Maybe LocalReg] -> Liveness +mkLiveness _ [] = [] +mkLiveness dflags (reg:regs) + = take sizeW bits ++ mkLiveness dflags regs where sizeW = case reg of Nothing -> 1 - Just r -> (widthInBytes (typeWidth (localRegType r)) + wORD_SIZE - 1) - `quot` wORD_SIZE + Just r -> (widthInBytes (typeWidth (localRegType r)) + wORD_SIZE dflags - 1) + `quot` wORD_SIZE dflags -- number of words, rounded up bits = repeat $ is_non_ptr reg -- True <=> Non Ptr diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs index 8952ba1803..3233dbed8c 100644 --- a/compiler/cmm/MkGraph.hs +++ b/compiler/cmm/MkGraph.hs @@ -231,7 +231,7 @@ mkReturn dflags e actuals updfr_off = mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph mkReturnSimple dflags actuals updfr_off = mkReturn dflags e actuals updfr_off - where e = CmmLoad (CmmStackSlot Old updfr_off) gcWord + where e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags) mkBranch :: BlockId -> CmmAGraph mkBranch bid = mkLast (CmmBranch bid) @@ -306,7 +306,7 @@ copyIn dflags oflow conv area formals = where ci (reg, RegisterParam r) (n, ms) = (n, CmmAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) : ms) ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms) - init_offset = widthInBytes wordWidth -- infotable + init_offset = widthInBytes (wordWidth dflags) -- infotable args = assignArgumentsPos dflags conv localRegType formals args' = foldl adjust [] args where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst @@ -356,10 +356,10 @@ copyOutOflow dflags conv transfer area actuals updfr_off case transfer of Call -> ([(CmmLit (CmmBlock id), StackParam init_offset)], - widthInBytes wordWidth) + widthInBytes (wordWidth dflags)) JumpRet -> ([], - widthInBytes wordWidth) + widthInBytes (wordWidth dflags)) _other -> ([], 0) Old -> ([], updfr_off) @@ -367,7 +367,7 @@ copyOutOflow dflags conv transfer area actuals updfr_off arg_offset = init_offset + extra_stack_off args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it - args = assignArgumentsPos dflags conv cmmExprType actuals + args = assignArgumentsPos dflags conv (cmmExprType dflags) actuals args' = foldl adjust setRA args where adjust rst (v, StackParam off) = (v, StackParam (off + arg_offset)) : rst diff --git a/compiler/cmm/OldCmmLint.hs b/compiler/cmm/OldCmmLint.hs index 72e40ce4f8..5dd3209892 100644 --- a/compiler/cmm/OldCmmLint.hs +++ b/compiler/cmm/OldCmmLint.hs @@ -22,9 +22,8 @@ import OldCmm import CLabel import Outputable import OldPprCmm() -import Constants import FastString -import Platform +import DynFlags import Data.Maybe @@ -32,15 +31,15 @@ import Data.Maybe -- Exported entry points: cmmLint :: (Outputable d, Outputable h) - => Platform -> GenCmmGroup d h (ListGraph CmmStmt) -> Maybe SDoc -cmmLint platform tops = runCmmLint platform (mapM_ (lintCmmDecl platform)) tops + => DynFlags -> GenCmmGroup d h (ListGraph CmmStmt) -> Maybe SDoc +cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops cmmLintTop :: (Outputable d, Outputable h) - => Platform -> GenCmmDecl d h (ListGraph CmmStmt) -> Maybe SDoc -cmmLintTop platform top = runCmmLint platform (lintCmmDecl platform) top + => DynFlags -> GenCmmDecl d h (ListGraph CmmStmt) -> Maybe SDoc +cmmLintTop dflags top = runCmmLint dflags (lintCmmDecl dflags) top runCmmLint :: Outputable a - => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc + => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc runCmmLint _ l p = case unCL (l p) of Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"), @@ -49,19 +48,20 @@ runCmmLint _ l p = nest 2 (ppr p)]) Right _ -> Nothing -lintCmmDecl :: Platform -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint () -lintCmmDecl platform (CmmProc _ lbl (ListGraph blocks)) +lintCmmDecl :: DynFlags -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint () +lintCmmDecl dflags (CmmProc _ lbl (ListGraph blocks)) = addLintInfo (text "in proc " <> pprCLabel platform lbl) $ let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks - in mapM_ (lintCmmBlock platform labels) blocks + in mapM_ (lintCmmBlock dflags labels) blocks + where platform = targetPlatform dflags lintCmmDecl _ (CmmData {}) = return () -lintCmmBlock :: Platform -> BlockSet -> GenBasicBlock CmmStmt -> CmmLint () -lintCmmBlock platform labels (BasicBlock id stmts) +lintCmmBlock :: DynFlags -> BlockSet -> GenBasicBlock CmmStmt -> CmmLint () +lintCmmBlock dflags labels (BasicBlock id stmts) = addLintInfo (text "in basic block " <> ppr id) $ - mapM_ (lintCmmStmt platform labels) stmts + mapM_ (lintCmmStmt dflags labels) stmts -- ----------------------------------------------------------------------------- -- lintCmmExpr @@ -69,33 +69,34 @@ lintCmmBlock platform labels (BasicBlock id stmts) -- Checks whether a CmmExpr is "type-correct", and check for obvious-looking -- byte/word mismatches. -lintCmmExpr :: Platform -> CmmExpr -> CmmLint CmmType -lintCmmExpr platform (CmmLoad expr rep) = do - _ <- lintCmmExpr platform expr +lintCmmExpr :: DynFlags -> CmmExpr -> CmmLint CmmType +lintCmmExpr dflags (CmmLoad expr rep) = do + _ <- lintCmmExpr dflags expr -- Disabled, if we have the inlining phase before the lint phase, -- we can have funny offsets due to pointer tagging. -- EZY -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $ -- cmmCheckWordAddress expr return rep -lintCmmExpr platform expr@(CmmMachOp op args) = do - tys <- mapM (lintCmmExpr platform) args - if map (typeWidth . cmmExprType) args == machOpArgReps op - then cmmCheckMachOp op args tys - else cmmLintMachOpErr expr (map cmmExprType args) (machOpArgReps op) -lintCmmExpr platform (CmmRegOff reg offset) - = lintCmmExpr platform (CmmMachOp (MO_Add rep) +lintCmmExpr dflags expr@(CmmMachOp op args) = do + tys <- mapM (lintCmmExpr dflags) args + if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op + then cmmCheckMachOp dflags op args tys + else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op) +lintCmmExpr dflags (CmmRegOff reg offset) + = lintCmmExpr dflags (CmmMachOp (MO_Add rep) [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)]) - where rep = typeWidth (cmmRegType reg) -lintCmmExpr _ expr = - return (cmmExprType expr) + where rep = typeWidth (cmmRegType dflags reg) +lintCmmExpr dflags expr = + return (cmmExprType dflags expr) -- Check for some common byte/word mismatches (eg. Sp + 1) -cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType -cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys - = cmmCheckMachOp op [reg, lit] tys -cmmCheckMachOp op _ tys - = return (machOpResultType op tys) +cmmCheckMachOp :: DynFlags -> MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType +cmmCheckMachOp dflags op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys + = cmmCheckMachOp dflags op [reg, lit] tys +cmmCheckMachOp dflags op _ tys + = return (machOpResultType dflags op tys) +{- isOffsetOp :: MachOp -> Bool isOffsetOp (MO_Add _) = True isOffsetOp (MO_Sub _) = True @@ -105,10 +106,10 @@ isOffsetOp _ = False -- check for funny-looking sub-word offsets. _cmmCheckWordAddress :: CmmExpr -> CmmLint () _cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) - | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0 + | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0 = cmmLintDubiousWordOffset e _cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) - | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0 + | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0 = cmmLintDubiousWordOffset e _cmmCheckWordAddress _ = return () @@ -118,50 +119,51 @@ _cmmCheckWordAddress _ notNodeReg :: CmmExpr -> Bool notNodeReg (CmmReg reg) | reg == nodeReg = False notNodeReg _ = True +-} -lintCmmStmt :: Platform -> BlockSet -> CmmStmt -> CmmLint () -lintCmmStmt platform labels = lint +lintCmmStmt :: DynFlags -> BlockSet -> CmmStmt -> CmmLint () +lintCmmStmt dflags labels = lint where lint (CmmNop) = return () lint (CmmComment {}) = return () lint stmt@(CmmAssign reg expr) = do - erep <- lintCmmExpr platform expr - let reg_ty = cmmRegType reg + erep <- lintCmmExpr dflags expr + let reg_ty = cmmRegType dflags reg if (erep `cmmEqType_ignoring_ptrhood` reg_ty) then return () else cmmLintAssignErr stmt erep reg_ty lint (CmmStore l r) = do - _ <- lintCmmExpr platform l - _ <- lintCmmExpr platform r + _ <- lintCmmExpr dflags l + _ <- lintCmmExpr dflags r return () lint (CmmCall target _res args _) = - do lintTarget platform labels target - mapM_ (lintCmmExpr platform . hintlessCmm) args - lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr platform e >> checkCond e + do lintTarget dflags labels target + mapM_ (lintCmmExpr dflags . hintlessCmm) args + lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr dflags e >> checkCond dflags e lint (CmmSwitch e branches) = do mapM_ checkTarget $ catMaybes branches - erep <- lintCmmExpr platform e - if (erep `cmmEqType_ignoring_ptrhood` bWord) + erep <- lintCmmExpr dflags e + if (erep `cmmEqType_ignoring_ptrhood` bWord dflags) then return () else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e <> text " :: " <> ppr erep) - lint (CmmJump e _) = lintCmmExpr platform e >> return () + lint (CmmJump e _) = lintCmmExpr dflags e >> return () lint (CmmReturn) = return () lint (CmmBranch id) = checkTarget id checkTarget id = if setMember id labels then return () else cmmLintErr (text "Branch to nonexistent id" <+> ppr id) -lintTarget :: Platform -> BlockSet -> CmmCallTarget -> CmmLint () -lintTarget platform _ (CmmCallee e _) = do _ <- lintCmmExpr platform e - return () -lintTarget _ _ (CmmPrim _ Nothing) = return () -lintTarget platform labels (CmmPrim _ (Just stmts)) - = mapM_ (lintCmmStmt platform labels) stmts +lintTarget :: DynFlags -> BlockSet -> CmmCallTarget -> CmmLint () +lintTarget dflags _ (CmmCallee e _) = do _ <- lintCmmExpr dflags e + return () +lintTarget _ _ (CmmPrim _ Nothing) = return () +lintTarget dflags labels (CmmPrim _ (Just stmts)) + = mapM_ (lintCmmStmt dflags labels) stmts -checkCond :: CmmExpr -> CmmLint () -checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return () -checkCond (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values -checkCond expr +checkCond :: DynFlags -> CmmExpr -> CmmLint () +checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return () +checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values +checkCond _ expr = cmmLintErr (hang (text "expression is not a conditional:") 2 (ppr expr)) @@ -203,7 +205,10 @@ cmmLintAssignErr stmt e_ty r_ty +{- cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a cmmLintDubiousWordOffset expr = cmmLintErr (text "offset is not a multiple of words: " $$ nest 2 (ppr expr)) +-} + diff --git a/compiler/cmm/OldCmmUtils.hs b/compiler/cmm/OldCmmUtils.hs index 0ec7a25f15..fe6ccee642 100644 --- a/compiler/cmm/OldCmmUtils.hs +++ b/compiler/cmm/OldCmmUtils.hs @@ -20,6 +20,7 @@ module OldCmmUtils( import OldCmm import CmmUtils import OrdList +import DynFlags import Unique --------------------------------------------------- @@ -77,23 +78,23 @@ cheapEqReg _ _ = False -- --------------------------------------------------- -loadArgsIntoTemps :: [Unique] +loadArgsIntoTemps :: DynFlags -> [Unique] -> [HintedCmmActual] -> ([Unique], [CmmStmt], [HintedCmmActual]) -loadArgsIntoTemps uniques [] = (uniques, [], []) -loadArgsIntoTemps uniques ((CmmHinted e hint):args) = +loadArgsIntoTemps _ uniques [] = (uniques, [], []) +loadArgsIntoTemps dflags uniques ((CmmHinted e hint):args) = (uniques'', new_stmts ++ remaining_stmts, (CmmHinted new_e hint) : remaining_e) where - (uniques', new_stmts, new_e) = maybeAssignTemp uniques e + (uniques', new_stmts, new_e) = maybeAssignTemp dflags uniques e (uniques'', remaining_stmts, remaining_e) = - loadArgsIntoTemps uniques' args + loadArgsIntoTemps dflags uniques' args -maybeAssignTemp :: [Unique] -> CmmExpr -> ([Unique], [CmmStmt], CmmExpr) -maybeAssignTemp uniques e +maybeAssignTemp :: DynFlags -> [Unique] -> CmmExpr -> ([Unique], [CmmStmt], CmmExpr) +maybeAssignTemp dflags uniques e | hasNoGlobalRegs e = (uniques, [], e) | otherwise = (tail uniques, [CmmAssign local e], CmmReg local) - where local = CmmLocal (LocalReg (head uniques) (cmmExprType e)) + where local = CmmLocal (LocalReg (head uniques) (cmmExprType dflags e)) diff --git a/compiler/cmm/OldPprCmm.hs b/compiler/cmm/OldPprCmm.hs index 9605cb9bdf..a3857d4e47 100644 --- a/compiler/cmm/OldPprCmm.hs +++ b/compiler/cmm/OldPprCmm.hs @@ -93,9 +93,10 @@ pprStmt stmt = case stmt of CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi -- rep[lv] = expr; - CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi - where - rep = ppr ( cmmExprType expr ) + CmmStore lv expr -> + sdocWithDynFlags $ \dflags -> + let rep = ppr ( cmmExprType dflags expr ) + in rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi -- call "ccall" foo(x, y)[r1, r2]; -- ToDo ppr volatile diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index dd71ac655e..bb2f189e14 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -31,7 +31,6 @@ import OldCmm import OldPprCmm () -- Utils -import Constants import CPrim import DynFlags import FastString @@ -149,9 +148,10 @@ pprBBlock (BasicBlock lbl stmts) = pprWordArray :: CLabel -> [CmmStatic] -> SDoc pprWordArray lbl ds - = hcat [ pprLocalness lbl, ptext (sLit "StgWord") + = sdocWithDynFlags $ \dflags -> + hcat [ pprLocalness lbl, ptext (sLit "StgWord") , space, ppr lbl, ptext (sLit "[] = {") ] - $$ nest 8 (commafy (pprStatics ds)) + $$ nest 8 (commafy (pprStatics dflags ds)) $$ ptext (sLit "};") -- @@ -167,7 +167,9 @@ pprLocalness lbl | not $ externallyVisibleCLabel lbl = ptext (sLit "static ") pprStmt :: CmmStmt -> SDoc -pprStmt stmt = case stmt of +pprStmt stmt = + sdocWithDynFlags $ \dflags -> + case stmt of CmmReturn -> panic "pprStmt: return statement should have been cps'd away" CmmNop -> empty CmmComment _ -> empty -- (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/") @@ -176,10 +178,10 @@ pprStmt stmt = case stmt of -- some debugging option is on. They can get quite -- large. - CmmAssign dest src -> pprAssign dest src + CmmAssign dest src -> pprAssign dflags dest src CmmStore dest src - | typeWidth rep == W64 && wordWidth /= W64 + | typeWidth rep == W64 && wordWidth dflags /= W64 -> (if isFloatType rep then ptext (sLit "ASSIGN_DBL") else ptext (sLit ("ASSIGN_Word64"))) <> parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi @@ -187,7 +189,7 @@ pprStmt stmt = case stmt of | otherwise -> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ] where - rep = cmmExprType src + rep = cmmExprType dflags src CmmCall (CmmCallee fn cconv) results args ret -> maybe_proto $$ @@ -246,7 +248,8 @@ pprStmt stmt = case stmt of CmmBranch ident -> pprBranch ident CmmCondBranch expr ident -> pprCondBranch expr ident CmmJump lbl _ -> mkJMP_(pprExpr lbl) <> semi - CmmSwitch arg ids -> pprSwitch arg ids + CmmSwitch arg ids -> sdocWithDynFlags $ \dflags -> + pprSwitch dflags arg ids pprForeignCall :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> (SDoc, SDoc) @@ -262,15 +265,15 @@ pprForeignCall fn cconv results args = (proto, fn_call) pprCFunType :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc pprCFunType ppr_fn cconv ress args - = res_type ress <+> - parens (ccallConvAttribute cconv <> ppr_fn) <> - parens (commafy (map arg_type args)) - where - res_type [] = ptext (sLit "void") + = sdocWithDynFlags $ \dflags -> + let res_type [] = ptext (sLit "void") res_type [CmmHinted one hint] = machRepHintCType (localRegType one) hint res_type _ = panic "pprCFunType: only void or 1 return value supported" - arg_type (CmmHinted expr hint) = machRepHintCType (cmmExprType expr) hint + arg_type (CmmHinted expr hint) = machRepHintCType (cmmExprType dflags expr) hint + in res_type ress <+> + parens (ccallConvAttribute cconv <> ppr_fn) <> + parens (commafy (map arg_type args)) -- --------------------------------------------------------------------- -- unconditional branches @@ -295,8 +298,8 @@ pprCondBranch expr ident -- 'undefined'. However, they may be defined one day, so we better -- document this behaviour. -- -pprSwitch :: CmmExpr -> [ Maybe BlockId ] -> SDoc -pprSwitch e maybe_ids +pprSwitch :: DynFlags -> CmmExpr -> [ Maybe BlockId ] -> SDoc +pprSwitch dflags e maybe_ids = let pairs = [ (ix, ident) | (ix,Just ident) <- zip [0..] maybe_ids ] pairs2 = [ (map fst as, snd (head as)) | as <- groupBy sndEq pairs ] in @@ -311,11 +314,11 @@ pprSwitch e maybe_ids caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix where do_fallthrough ix = - hsep [ ptext (sLit "case") , pprHexVal ix wordWidth <> colon , + hsep [ ptext (sLit "case") , pprHexVal ix (wordWidth dflags) <> colon , ptext (sLit "/* fall through */") ] final_branch ix = - hsep [ ptext (sLit "case") , pprHexVal ix wordWidth <> colon , + hsep [ ptext (sLit "case") , pprHexVal ix (wordWidth dflags) <> colon , ptext (sLit "goto") , (pprBlockId ident) <> semi ] caseify (_ , _ ) = panic "pprSwtich: swtich with no cases!" @@ -339,7 +342,7 @@ pprExpr e = case e of CmmLit lit -> pprLit lit - CmmLoad e ty -> pprLoad e ty + CmmLoad e ty -> sdocWithDynFlags $ \dflags -> pprLoad dflags e ty CmmReg reg -> pprCastReg reg CmmRegOff reg 0 -> pprCastReg reg @@ -354,26 +357,26 @@ pprExpr e = case e of CmmStackSlot _ _ -> panic "pprExpr: CmmStackSlot not supported!" -pprLoad :: CmmExpr -> CmmType -> SDoc -pprLoad e ty - | width == W64, wordWidth /= W64 +pprLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc +pprLoad dflags e ty + | width == W64, wordWidth dflags /= W64 = (if isFloatType ty then ptext (sLit "PK_DBL") else ptext (sLit "PK_Word64")) <> parens (mkP_ <> pprExpr1 e) | otherwise = case e of - CmmReg r | isPtrReg r && width == wordWidth && not (isFloatType ty) + CmmReg r | isPtrReg r && width == wordWidth dflags && not (isFloatType ty) -> char '*' <> pprAsPtrReg r - CmmRegOff r 0 | isPtrReg r && width == wordWidth && not (isFloatType ty) + CmmRegOff r 0 | isPtrReg r && width == wordWidth dflags && not (isFloatType ty) -> char '*' <> pprAsPtrReg r - CmmRegOff r off | isPtrReg r && width == wordWidth - , off `rem` wORD_SIZE == 0 && not (isFloatType ty) + CmmRegOff r off | isPtrReg r && width == wordWidth dflags + , off `rem` wORD_SIZE dflags == 0 && not (isFloatType ty) -- ToDo: check that the offset is a word multiple? -- (For tagging to work, I had to avoid unaligned loads. --ARY) - -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift)) + -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift dflags)) _other -> cLoad e ty where @@ -423,8 +426,10 @@ pprMachOpApp' mop args where -- Cast needed for signed integer ops - pprArg e | signedOp mop = cCast (machRep_S_CType (typeWidth (cmmExprType e))) e - | needsFCasts mop = cCast (machRep_F_CType (typeWidth (cmmExprType e))) e + pprArg e | signedOp mop = sdocWithDynFlags $ \dflags -> + cCast (machRep_S_CType (typeWidth (cmmExprType dflags e))) e + | needsFCasts mop = sdocWithDynFlags $ \dflags -> + cCast (machRep_F_CType (typeWidth (cmmExprType dflags e))) e | otherwise = pprExpr1 e needsFCasts (MO_F_Eq _) = False needsFCasts (MO_F_Ne _) = False @@ -470,37 +475,38 @@ pprLit1 other = pprLit other -- --------------------------------------------------------------------------- -- Static data -pprStatics :: [CmmStatic] -> [SDoc] -pprStatics [] = [] -pprStatics (CmmStaticLit (CmmFloat f W32) : rest) +pprStatics :: DynFlags -> [CmmStatic] -> [SDoc] +pprStatics _ [] = [] +pprStatics dflags (CmmStaticLit (CmmFloat f W32) : rest) -- floats are padded to a word, see #1852 - | wORD_SIZE == 8, CmmStaticLit (CmmInt 0 W32) : rest' <- rest - = pprLit1 (floatToWord f) : pprStatics rest' - | wORD_SIZE == 4 - = pprLit1 (floatToWord f) : pprStatics rest + | wORD_SIZE dflags == 8, CmmStaticLit (CmmInt 0 W32) : rest' <- rest + = pprLit1 (floatToWord dflags f) : pprStatics dflags rest' + | wORD_SIZE dflags == 4 + = pprLit1 (floatToWord dflags f) : pprStatics dflags rest | otherwise = pprPanic "pprStatics: float" (vcat (map ppr' rest)) - where ppr' (CmmStaticLit l) = ppr (cmmLitType l) + where ppr' (CmmStaticLit l) = sdocWithDynFlags $ \dflags -> + ppr (cmmLitType dflags l) ppr' _other = ptext (sLit "bad static!") -pprStatics (CmmStaticLit (CmmFloat f W64) : rest) - = map pprLit1 (doubleToWords f) ++ pprStatics rest -pprStatics (CmmStaticLit (CmmInt i W64) : rest) - | wordWidth == W32 +pprStatics dflags (CmmStaticLit (CmmFloat f W64) : rest) + = map pprLit1 (doubleToWords dflags f) ++ pprStatics dflags rest +pprStatics dflags (CmmStaticLit (CmmInt i W64) : rest) + | wordWidth dflags == W32 #ifdef WORDS_BIGENDIAN - = pprStatics (CmmStaticLit (CmmInt q W32) : - CmmStaticLit (CmmInt r W32) : rest) + = pprStatics dflags (CmmStaticLit (CmmInt q W32) : + CmmStaticLit (CmmInt r W32) : rest) #else - = pprStatics (CmmStaticLit (CmmInt r W32) : - CmmStaticLit (CmmInt q W32) : rest) + = pprStatics dflags (CmmStaticLit (CmmInt r W32) : + CmmStaticLit (CmmInt q W32) : rest) #endif where r = i .&. 0xffffffff q = i `shiftR` 32 -pprStatics (CmmStaticLit (CmmInt _ w) : _) - | w /= wordWidth +pprStatics dflags (CmmStaticLit (CmmInt _ w) : _) + | w /= wordWidth dflags = panic "pprStatics: cannot emit a non-word-sized static literal" -pprStatics (CmmStaticLit lit : rest) - = pprLit1 lit : pprStatics rest -pprStatics (other : _) +pprStatics dflags (CmmStaticLit lit : rest) + = pprLit1 lit : pprStatics dflags rest +pprStatics _ (other : _) = pprPanic "pprWord" (pprStatic other) pprStatic :: CmmStatic -> SDoc @@ -705,19 +711,19 @@ mkP_ = ptext (sLit "(P_)") -- StgWord* -- -- Generating assignments is what we're all about, here -- -pprAssign :: CmmReg -> CmmExpr -> SDoc +pprAssign :: DynFlags -> CmmReg -> CmmExpr -> SDoc -- dest is a reg, rhs is a reg -pprAssign r1 (CmmReg r2) +pprAssign _ r1 (CmmReg r2) | isPtrReg r1 && isPtrReg r2 = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ] -- dest is a reg, rhs is a CmmRegOff -pprAssign r1 (CmmRegOff r2 off) - | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE == 0) +pprAssign dflags r1 (CmmRegOff r2 off) + | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE dflags == 0) = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ] where - off1 = off `shiftR` wordShift + off1 = off `shiftR` wordShift dflags (op,off') | off >= 0 = (char '+', off1) | otherwise = (char '-', -off1) @@ -725,7 +731,7 @@ pprAssign r1 (CmmRegOff r2 off) -- dest is a reg, rhs is anything. -- We can't cast the lvalue, so we have to cast the rhs if necessary. Casting -- the lvalue elicits a warning from new GCC versions (3.4+). -pprAssign r1 r2 +pprAssign _ r1 r2 | isFixedPtrReg r1 = mkAssign (mkP_ <> pprExpr1 r2) | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 r2) | otherwise = mkAssign (pprExpr r2) @@ -846,7 +852,8 @@ pprCall ppr_fn cconv results args = cCast (ptext (sLit "void *")) expr -- see comment by machRepHintCType below pprArg (CmmHinted expr SignedHint) - = cCast (machRep_S_CType $ typeWidth $ cmmExprType expr) expr + = sdocWithDynFlags $ \dflags -> + cCast (machRep_S_CType $ typeWidth $ cmmExprType dflags expr) expr pprArg (CmmHinted expr _other) = pprExpr expr @@ -901,9 +908,9 @@ pprExternDecl _in_srt lbl -- If the label we want to refer to is a stdcall function (on Windows) then -- we must generate an appropriate prototype for it, so that the C compiler will -- add the @n suffix to the label (#2276) - stdcall_decl sz = + stdcall_decl sz = sdocWithDynFlags $ \dflags -> ptext (sLit "extern __attribute__((stdcall)) void ") <> ppr lbl - <> parens (commafy (replicate (sz `quot` wORD_SIZE) (machRep_U_CType wordWidth))) + <> parens (commafy (replicate (sz `quot` wORD_SIZE dflags) (machRep_U_CType (wordWidth dflags)))) <> semi type TEState = (UniqSet LocalReg, Map CLabel ()) @@ -984,10 +991,10 @@ cLoad expr rep bewareLoadStoreAlignment (ArchARM {}) = True bewareLoadStoreAlignment _ = False -isCmmWordType :: CmmType -> Bool +isCmmWordType :: DynFlags -> CmmType -> Bool -- True of GcPtrReg/NonGcReg of native word size -isCmmWordType ty = not (isFloatType ty) - && typeWidth ty == wordWidth +isCmmWordType dflags ty = not (isFloatType ty) + && typeWidth ty == wordWidth dflags -- This is for finding the types of foreign call arguments. For a pointer -- argument, we always cast the argument to (void *), to avoid warnings from @@ -998,8 +1005,10 @@ machRepHintCType rep SignedHint = machRep_S_CType (typeWidth rep) machRepHintCType rep _other = machRepCType rep machRepPtrCType :: CmmType -> SDoc -machRepPtrCType r | isCmmWordType r = ptext (sLit "P_") - | otherwise = machRepCType r <> char '*' +machRepPtrCType r + = sdocWithDynFlags $ \dflags -> + if isCmmWordType dflags r then ptext (sLit "P_") + else machRepCType r <> char '*' machRepCType :: CmmType -> SDoc machRepCType ty | isFloatType ty = machRep_F_CType w @@ -1013,20 +1022,26 @@ machRep_F_CType W64 = ptext (sLit "StgDouble") machRep_F_CType _ = panic "machRep_F_CType" machRep_U_CType :: Width -> SDoc -machRep_U_CType w | w == wordWidth = ptext (sLit "W_") -machRep_U_CType W8 = ptext (sLit "StgWord8") -machRep_U_CType W16 = ptext (sLit "StgWord16") -machRep_U_CType W32 = ptext (sLit "StgWord32") -machRep_U_CType W64 = ptext (sLit "StgWord64") -machRep_U_CType _ = panic "machRep_U_CType" +machRep_U_CType w + = sdocWithDynFlags $ \dflags -> + case w of + _ | w == wordWidth dflags -> ptext (sLit "W_") + W8 -> ptext (sLit "StgWord8") + W16 -> ptext (sLit "StgWord16") + W32 -> ptext (sLit "StgWord32") + W64 -> ptext (sLit "StgWord64") + _ -> panic "machRep_U_CType" machRep_S_CType :: Width -> SDoc -machRep_S_CType w | w == wordWidth = ptext (sLit "I_") -machRep_S_CType W8 = ptext (sLit "StgInt8") -machRep_S_CType W16 = ptext (sLit "StgInt16") -machRep_S_CType W32 = ptext (sLit "StgInt32") -machRep_S_CType W64 = ptext (sLit "StgInt64") -machRep_S_CType _ = panic "machRep_S_CType" +machRep_S_CType w + = sdocWithDynFlags $ \dflags -> + case w of + _ | w == wordWidth dflags -> ptext (sLit "I_") + W8 -> ptext (sLit "StgInt8") + W16 -> ptext (sLit "StgInt16") + W32 -> ptext (sLit "StgInt32") + W64 -> ptext (sLit "StgInt64") + _ -> panic "machRep_S_CType" -- --------------------------------------------------------------------- @@ -1043,10 +1058,10 @@ pprStringInCStyle s = doubleQuotes (text (concatMap charToC s)) -- This is a hack to turn the floating point numbers into ints that we -- can safely initialise to static locations. -big_doubles :: Bool -big_doubles - | widthInBytes W64 == 2 * wORD_SIZE = True - | widthInBytes W64 == wORD_SIZE = False +big_doubles :: DynFlags -> Bool +big_doubles dflags + | widthInBytes W64 == 2 * wORD_SIZE dflags = True + | widthInBytes W64 == wORD_SIZE dflags = False | otherwise = panic "big_doubles" castFloatToIntArray :: STUArray s Int Float -> ST s (STUArray s Int Int) @@ -1056,27 +1071,27 @@ castDoubleToIntArray :: STUArray s Int Double -> ST s (STUArray s Int Int) castDoubleToIntArray = castSTUArray -- floats are always 1 word -floatToWord :: Rational -> CmmLit -floatToWord r +floatToWord :: DynFlags -> Rational -> CmmLit +floatToWord dflags r = runST (do arr <- newArray_ ((0::Int),0) writeArray arr 0 (fromRational r) arr' <- castFloatToIntArray arr i <- readArray arr' 0 - return (CmmInt (toInteger i) wordWidth) + return (CmmInt (toInteger i) (wordWidth dflags)) ) -doubleToWords :: Rational -> [CmmLit] -doubleToWords r - | big_doubles -- doubles are 2 words +doubleToWords :: DynFlags -> Rational -> [CmmLit] +doubleToWords dflags r + | big_doubles dflags -- doubles are 2 words = runST (do arr <- newArray_ ((0::Int),1) writeArray arr 0 (fromRational r) arr' <- castDoubleToIntArray arr i1 <- readArray arr' 0 i2 <- readArray arr' 1 - return [ CmmInt (toInteger i1) wordWidth - , CmmInt (toInteger i2) wordWidth + return [ CmmInt (toInteger i1) (wordWidth dflags) + , CmmInt (toInteger i2) (wordWidth dflags) ] ) | otherwise -- doubles are 1 word @@ -1085,14 +1100,14 @@ doubleToWords r writeArray arr 0 (fromRational r) arr' <- castDoubleToIntArray arr i <- readArray arr' 0 - return [ CmmInt (toInteger i) wordWidth ] + return [ CmmInt (toInteger i) (wordWidth dflags) ] ) -- --------------------------------------------------------------------------- -- Utils -wordShift :: Int -wordShift = widthInLog wordWidth +wordShift :: DynFlags -> Int +wordShift dflags = widthInLog (wordWidth dflags) commafy :: [SDoc] -> SDoc commafy xs = hsep $ punctuate comma xs @@ -1110,11 +1125,11 @@ pprHexVal w rep -- times values are unsigned. This also helps eliminate occasional -- warnings about integer overflow from gcc. - repsuffix W64 - | cINT_SIZE == 8 = char 'U' - | cLONG_SIZE == 8 = ptext (sLit "UL") - | cLONG_LONG_SIZE == 8 = ptext (sLit "ULL") - | otherwise = panic "pprHexVal: Can't find a 64-bit type" + repsuffix W64 = sdocWithDynFlags $ \dflags -> + if cINT_SIZE dflags == 8 then char 'U' + else if cLONG_SIZE dflags == 8 then ptext (sLit "UL") + else if cLONG_LONG_SIZE dflags == 8 then ptext (sLit "ULL") + else panic "pprHexVal: Can't find a 64-bit type" repsuffix _ = char 'U' go 0 = empty diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 58866979f8..423bcd5504 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -185,7 +185,8 @@ pprNode node = pp_node <+> pp_debug -- rep[lv] = expr; CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi where - rep = ppr ( cmmExprType expr ) + rep = sdocWithDynFlags $ \dflags -> + ppr ( cmmExprType dflags expr ) -- call "ccall" foo(x, y)[r1, r2]; -- ToDo ppr volatile diff --git a/compiler/cmm/PprCmmExpr.hs b/compiler/cmm/PprCmmExpr.hs index 2f25b028d1..7d2f4824ef 100644 --- a/compiler/cmm/PprCmmExpr.hs +++ b/compiler/cmm/PprCmmExpr.hs @@ -73,11 +73,12 @@ instance Outputable GlobalReg where pprExpr :: CmmExpr -> SDoc pprExpr e - = case e of + = sdocWithDynFlags $ \dflags -> + case e of CmmRegOff reg i -> pprExpr (CmmMachOp (MO_Add rep) [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)]) - where rep = typeWidth (cmmRegType reg) + where rep = typeWidth (cmmRegType dflags reg) CmmLit lit -> pprLit lit _other -> pprExpr1 e @@ -186,10 +187,11 @@ infixMachOp mop -- has the natural machine word size, we do not append the type -- pprLit :: CmmLit -> SDoc -pprLit lit = case lit of +pprLit lit = sdocWithDynFlags $ \dflags -> + case lit of CmmInt i rep -> hcat [ (if i < 0 then parens else id)(integer i) - , ppUnless (rep == wordWidth) $ + , ppUnless (rep == wordWidth dflags) $ space <> dcolon <+> ppr rep ] CmmFloat f rep -> hsep [ double (fromRat f), dcolon, ppr rep ] diff --git a/compiler/cmm/SMRep.lhs b/compiler/cmm/SMRep.lhs index 1d5574ae8f..2c9cb32ec0 100644 --- a/compiler/cmm/SMRep.lhs +++ b/compiler/cmm/SMRep.lhs @@ -45,7 +45,6 @@ module SMRep ( #include "../includes/MachDeps.h" import DynFlags -import Constants import Outputable import FastString @@ -65,8 +64,8 @@ import Data.Bits type WordOff = Int -- Word offset, or word count type ByteOff = Int -- Byte offset, or byte count -roundUpToWords :: ByteOff -> ByteOff -roundUpToWords n = (n + (wORD_SIZE - 1)) .&. (complement (wORD_SIZE - 1)) +roundUpToWords :: DynFlags -> ByteOff -> ByteOff +roundUpToWords dflags n = (n + (wORD_SIZE dflags - 1)) .&. (complement (wORD_SIZE dflags - 1)) \end{code} StgWord is a type representing an StgWord on the target platform. @@ -219,33 +218,33 @@ isStaticNoCafCon _ = False -- | Size of a closure header (StgHeader in includes/rts/storage/Closures.h) fixedHdrSize :: DynFlags -> WordOff -fixedHdrSize dflags = sTD_HDR_SIZE + profHdrSize dflags +fixedHdrSize dflags = sTD_HDR_SIZE dflags + profHdrSize dflags -- | Size of the profiling part of a closure header -- (StgProfHeader in includes/rts/storage/Closures.h) profHdrSize :: DynFlags -> WordOff profHdrSize dflags - | dopt Opt_SccProfilingOn dflags = pROF_HDR_SIZE + | dopt Opt_SccProfilingOn dflags = pROF_HDR_SIZE dflags | otherwise = 0 -- | The garbage collector requires that every closure is at least as -- big as this. minClosureSize :: DynFlags -> WordOff -minClosureSize dflags = fixedHdrSize dflags + mIN_PAYLOAD_SIZE +minClosureSize dflags = fixedHdrSize dflags + mIN_PAYLOAD_SIZE dflags arrWordsHdrSize :: DynFlags -> ByteOff arrWordsHdrSize dflags - = fixedHdrSize dflags * wORD_SIZE + sIZEOF_StgArrWords_NoHdr + = fixedHdrSize dflags * wORD_SIZE dflags + sIZEOF_StgArrWords_NoHdr dflags arrPtrsHdrSize :: DynFlags -> ByteOff arrPtrsHdrSize dflags - = fixedHdrSize dflags * wORD_SIZE + sIZEOF_StgMutArrPtrs_NoHdr + = fixedHdrSize dflags * wORD_SIZE dflags + sIZEOF_StgMutArrPtrs_NoHdr dflags -- Thunks have an extra header word on SMP, so the update doesn't -- splat the payload. thunkHdrSize :: DynFlags -> WordOff thunkHdrSize dflags = fixedHdrSize dflags + smp_hdr - where smp_hdr = sIZEOF_StgSMPThunkHeader `quot` wORD_SIZE + where smp_hdr = sIZEOF_StgSMPThunkHeader dflags `quot` wORD_SIZE dflags nonHdrSize :: SMRep -> WordOff diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs index 0efc99d370..834276bd7b 100644 --- a/compiler/codeGen/CgBindery.lhs +++ b/compiler/codeGen/CgBindery.lhs @@ -38,8 +38,8 @@ import CgStackery import CgUtils import CLabel import ClosureInfo -import Constants +import DynFlags import OldCmm import PprCmm ( {- instance Outputable -} ) import SMRep @@ -87,8 +87,8 @@ data CgIdInfo , cg_tag :: {-# UNPACK #-} !Int -- tag to be added in idInfoToAmode } -mkCgIdInfo :: Id -> VolatileLoc -> StableLoc -> LambdaFormInfo -> CgIdInfo -mkCgIdInfo id vol stb lf +mkCgIdInfo :: DynFlags -> Id -> VolatileLoc -> StableLoc -> LambdaFormInfo -> CgIdInfo +mkCgIdInfo dflags id vol stb lf = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb, cg_lf = lf, cg_rep = idCgRep id, cg_tag = tag } where @@ -100,10 +100,10 @@ mkCgIdInfo id vol stb lf If yes, we assume that the constructor is evaluated and can be tagged. -} - = tagForCon con + = tagForCon dflags con | otherwise - = funTagLFInfo lf + = funTagLFInfo dflags lf voidIdInfo :: Id -> CgIdInfo voidIdInfo id = CgIdInfo { cg_id = id, cg_vol = NoVolatileLoc @@ -120,11 +120,11 @@ data VolatileLoc -- These locations die across a call -- NB. Byte offset, because we subtract R1's -- tag from the offset. -mkTaggedCgIdInfo :: Id -> VolatileLoc -> StableLoc -> LambdaFormInfo -> DataCon +mkTaggedCgIdInfo :: DynFlags -> Id -> VolatileLoc -> StableLoc -> LambdaFormInfo -> DataCon -> CgIdInfo -mkTaggedCgIdInfo id vol stb lf con +mkTaggedCgIdInfo dflags id vol stb lf con = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb, - cg_lf = lf, cg_rep = idCgRep id, cg_tag = tagForCon con } + cg_lf = lf, cg_rep = idCgRep id, cg_tag = tagForCon dflags con } \end{code} @StableLoc@ encodes where an Id can be found, used by @@ -172,43 +172,52 @@ instance Outputable StableLoc where %************************************************************************ \begin{code} -stableIdInfo :: Id -> CmmExpr -> LambdaFormInfo -> CgIdInfo -stableIdInfo id amode lf_info = mkCgIdInfo id NoVolatileLoc (StableLoc amode) lf_info +stableIdInfo :: DynFlags -> Id -> CmmExpr -> LambdaFormInfo -> CgIdInfo +stableIdInfo dflags id amode lf_info = mkCgIdInfo dflags id NoVolatileLoc (StableLoc amode) lf_info -heapIdInfo :: Id -> VirtualHpOffset -> LambdaFormInfo -> CgIdInfo -heapIdInfo id offset lf_info = mkCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info +heapIdInfo :: DynFlags -> Id -> VirtualHpOffset -> LambdaFormInfo -> CgIdInfo +heapIdInfo dflags id offset lf_info = mkCgIdInfo dflags id (VirHpLoc offset) NoStableLoc lf_info -letNoEscapeIdInfo :: Id -> VirtualSpOffset -> LambdaFormInfo -> CgIdInfo -letNoEscapeIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLNE sp) lf_info +letNoEscapeIdInfo :: DynFlags -> Id -> VirtualSpOffset -> LambdaFormInfo -> CgIdInfo +letNoEscapeIdInfo dflags id sp lf_info + = mkCgIdInfo dflags id NoVolatileLoc (VirStkLNE sp) lf_info -stackIdInfo :: Id -> VirtualSpOffset -> LambdaFormInfo -> CgIdInfo -stackIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLoc sp) lf_info +stackIdInfo :: DynFlags -> Id -> VirtualSpOffset -> LambdaFormInfo -> CgIdInfo +stackIdInfo dflags id sp lf_info + = mkCgIdInfo dflags id NoVolatileLoc (VirStkLoc sp) lf_info -nodeIdInfo :: Id -> Int -> LambdaFormInfo -> CgIdInfo -nodeIdInfo id offset lf_info = mkCgIdInfo id (VirNodeLoc (wORD_SIZE*offset)) NoStableLoc lf_info +nodeIdInfo :: DynFlags -> Id -> Int -> LambdaFormInfo -> CgIdInfo +nodeIdInfo dflags id offset lf_info = mkCgIdInfo dflags id (VirNodeLoc (wORD_SIZE dflags * offset)) NoStableLoc lf_info -regIdInfo :: Id -> CmmReg -> LambdaFormInfo -> CgIdInfo -regIdInfo id reg lf_info = mkCgIdInfo id (RegLoc reg) NoStableLoc lf_info +regIdInfo :: DynFlags -> Id -> CmmReg -> LambdaFormInfo -> CgIdInfo +regIdInfo dflags id reg lf_info = mkCgIdInfo dflags id (RegLoc reg) NoStableLoc lf_info -taggedStableIdInfo :: Id -> CmmExpr -> LambdaFormInfo -> DataCon -> CgIdInfo -taggedStableIdInfo id amode lf_info con - = mkTaggedCgIdInfo id NoVolatileLoc (StableLoc amode) lf_info con +taggedStableIdInfo :: DynFlags -> Id -> CmmExpr -> LambdaFormInfo -> DataCon -> CgIdInfo +taggedStableIdInfo dflags id amode lf_info con + = mkTaggedCgIdInfo dflags id NoVolatileLoc (StableLoc amode) lf_info con -taggedHeapIdInfo :: Id -> VirtualHpOffset -> LambdaFormInfo -> DataCon +taggedHeapIdInfo :: DynFlags -> Id -> VirtualHpOffset -> LambdaFormInfo -> DataCon -> CgIdInfo -taggedHeapIdInfo id offset lf_info con - = mkTaggedCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info con +taggedHeapIdInfo dflags id offset lf_info con + = mkTaggedCgIdInfo dflags id (VirHpLoc offset) NoStableLoc lf_info con -untagNodeIdInfo :: Id -> Int -> LambdaFormInfo -> Int -> CgIdInfo -untagNodeIdInfo id offset lf_info tag - = mkCgIdInfo id (VirNodeLoc (wORD_SIZE*offset - tag)) NoStableLoc lf_info +untagNodeIdInfo :: DynFlags -> Id -> Int -> LambdaFormInfo -> Int -> CgIdInfo +untagNodeIdInfo dflags id offset lf_info tag + = mkCgIdInfo dflags id (VirNodeLoc (wORD_SIZE dflags * offset - tag)) NoStableLoc lf_info 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 +237,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 @@ -283,7 +285,8 @@ modifyBindC name mangle_fn = do getCgIdInfo :: Id -> FCode CgIdInfo getCgIdInfo id - = do { -- Try local bindings first + = do { dflags <- getDynFlags + ; -- Try local bindings first ; local_binds <- getBinds ; case lookupVarEnv local_binds id of { Just info -> return info ; @@ -301,7 +304,7 @@ getCgIdInfo id in if isExternalName name then do let ext_lbl = CmmLit (CmmLabel (mkClosureLabel name $ idCafInfo id)) - return (stableIdInfo id ext_lbl (mkLFImported id)) + return (stableIdInfo dflags id ext_lbl (mkLFImported id)) else if isVoidArg (idCgRep id) then -- Void things are never in the environment @@ -428,9 +431,9 @@ getArgAmodes (atom:atoms) \begin{code} bindArgsToStack :: [(Id, VirtualSpOffset)] -> Code bindArgsToStack args - = mapCs bind args - where - bind(id, offset) = addBindC id (stackIdInfo id offset (mkLFArgument id)) + = do dflags <- getDynFlags + let bind (id, offset) = addBindC id (stackIdInfo dflags id offset (mkLFArgument id)) + mapCs bind args bindArgsToRegs :: [(Id, GlobalReg)] -> Code bindArgsToRegs args @@ -440,30 +443,32 @@ bindArgsToRegs args bindNewToNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Code bindNewToNode id offset lf_info - = addBindC id (nodeIdInfo id offset lf_info) + = do dflags <- getDynFlags + addBindC id (nodeIdInfo dflags id offset lf_info) bindNewToUntagNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Int -> Code bindNewToUntagNode id offset lf_info tag - = addBindC id (untagNodeIdInfo id offset lf_info tag) + = do dflags <- getDynFlags + addBindC id (untagNodeIdInfo dflags id offset lf_info tag) -- Create a new temporary whose unique is that in the id, -- bind the id to it, and return the addressing mode for the -- 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 dflags 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 - = addBindC name info - where - info = mkCgIdInfo name (RegLoc reg) NoStableLoc lf_info + = do dflags <- getDynFlags + let info = mkCgIdInfo dflags name (RegLoc reg) NoStableLoc lf_info + addBindC name info rebindToStack :: Id -> VirtualSpOffset -> Code rebindToStack name offset @@ -497,9 +502,10 @@ Probably *naughty* to look inside monad... nukeDeadBindings :: StgLiveVars -- All the *live* variables -> Code nukeDeadBindings live_vars = do + dflags <- getDynFlags binds <- getBinds let (dead_stk_slots, bs') = - dead_slots live_vars + dead_slots dflags live_vars [] [] [ (cg_id b, b) | b <- varEnvElts binds ] setBinds $ mkVarEnv bs' @@ -509,7 +515,8 @@ nukeDeadBindings live_vars = do Several boring auxiliary functions to do the dirty work. \begin{code} -dead_slots :: StgLiveVars +dead_slots :: DynFlags + -> StgLiveVars -> [(Id,CgIdInfo)] -> [VirtualSpOffset] -> [(Id,CgIdInfo)] @@ -517,12 +524,12 @@ dead_slots :: StgLiveVars -- dead_slots carries accumulating parameters for -- filtered bindings, dead slots -dead_slots _ fbs ds [] +dead_slots _ _ fbs ds [] = (ds, reverse fbs) -- Finished; rm the dups, if any -dead_slots live_vars fbs ds ((v,i):bs) +dead_slots dflags live_vars fbs ds ((v,i):bs) | v `elementOfUniqSet` live_vars - = dead_slots live_vars ((v,i):fbs) ds bs + = dead_slots dflags live_vars ((v,i):fbs) ds bs -- Live, so don't record it in dead slots -- Instead keep it in the filtered bindings @@ -530,12 +537,12 @@ dead_slots live_vars fbs ds ((v,i):bs) = case cg_stb i of VirStkLoc offset | size > 0 - -> dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs + -> dead_slots dflags live_vars fbs ([offset-size+1 .. offset] ++ ds) bs - _ -> dead_slots live_vars fbs ds bs + _ -> dead_slots dflags live_vars fbs ds bs where size :: WordOff - size = cgRepSizeW (cg_rep i) + size = cgRepSizeW dflags (cg_rep i) getLiveStackSlots :: FCode [VirtualSpOffset] -- Return the offsets of slots in stack containig live pointers diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs index 9443e0e936..45edd64666 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 @@ -67,18 +66,18 @@ import Data.Bits ------------------------- mkArgDescr :: Name -> [Id] -> FCode ArgDescr mkArgDescr _nm args - = case stdPattern arg_reps of - Just spec_id -> return (ArgSpec spec_id) - Nothing -> return (ArgGen arg_bits) - where - arg_bits = argBits arg_reps - arg_reps = filter nonVoidArg (map idCgRep args) - -- Getting rid of voids eases matching of standard patterns - -argBits :: [CgRep] -> [Bool] -- True for non-ptr, False for ptr -argBits [] = [] -argBits (PtrArg : args) = False : argBits args -argBits (arg : args) = take (cgRepSizeW arg) (repeat True) ++ argBits args + = do dflags <- getDynFlags + let arg_bits = argBits dflags arg_reps + arg_reps = filter nonVoidArg (map idCgRep args) + -- Getting rid of voids eases matching of standard patterns + case stdPattern arg_reps of + Just spec_id -> return (ArgSpec spec_id) + Nothing -> return (ArgGen arg_bits) + +argBits :: DynFlags -> [CgRep] -> [Bool] -- True for non-ptr, False for ptr +argBits _ [] = [] +argBits dflags (PtrArg : args) = False : argBits dflags args +argBits dflags (arg : args) = take (cgRepSizeW dflags arg) (repeat True) ++ argBits dflags args stdPattern :: [CgRep] -> Maybe StgHalfWord stdPattern [] = Just ARG_NONE -- just void args, probably @@ -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 f1da2d4235..11a5091c07 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -84,7 +84,7 @@ cgTopRhsClosure id ccs binder_info upd_flag args body = do ; let descr = closureDescription dflags mod_name name closure_info = mkClosureInfo dflags True id lf_info 0 0 srt_info descr closure_label = mkLocalClosureLabel name $ idCafInfo id - cg_id_info = stableIdInfo id (mkLblExpr closure_label) lf_info + cg_id_info = stableIdInfo dflags id (mkLblExpr closure_label) lf_info closure_rep = mkStaticClosureFields dflags closure_info ccs True [] -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY) @@ -136,7 +136,7 @@ cgStdRhsClosure bndr _cc _bndr_info _fvs _args _body lf_info payload ; heap_offset <- allocDynClosure closure_info curCCS curCCS amodes_w_offsets -- RETURN - ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) } + ; returnFC (bndr, heapIdInfo dflags bndr heap_offset lf_info) } \end{code} Here's the general case. @@ -188,7 +188,7 @@ cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do let -- A function closure pointer may be tagged, so we -- must take it into account when accessing the free variables. - mbtag = tagForArity (length args) + mbtag = tagForArity dflags (length args) bind_fv (info, offset) | Just tag <- mbtag = bindNewToUntagNode (cgIdInfoId info) offset (cgIdInfoLF info) tag @@ -211,7 +211,7 @@ cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do ; heap_offset <- allocDynClosure closure_info curCCS curCCS amodes_w_offsets -- RETURN - ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) } + ; returnFC (bndr, heapIdInfo dflags bndr heap_offset lf_info) } mkClosureLFInfo :: Id -- The binder @@ -279,7 +279,7 @@ closureCodeBody _binder_info cl_info cc args body -- eg. if we're compiling a let-no-escape). ; vSp <- getVirtSp ; let (reg_args, other_args) = assignCallRegs dflags (addIdReps args) - (sp_top, stk_args) = mkVirtStkOffsets vSp other_args + (sp_top, stk_args) = mkVirtStkOffsets dflags vSp other_args -- Allocate the global ticky counter ; let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) (clHasCafRefs cl_info) @@ -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 - , CmmLit (mkIntCLit (funTag cl_info)) ]) + (CmmMachOp (mo_wordSub dflags) [ CmmReg nodeReg + , mkIntExpr dflags (funTag dflags cl_info) ]) (node : map snd reg_args) -- live regs ; cgExpr body } @@ -364,22 +365,22 @@ mkSlowEntryCode dflags cl_info reg_args reps_w_regs :: [(CgRep,GlobalReg)] reps_w_regs = [(idCgRep id, reg) | (id,reg) <- reverse reg_args] (final_stk_offset, stk_offsets) - = mapAccumL (\off (rep,_) -> (off + cgRepSizeW rep, off)) + = mapAccumL (\off (rep,_) -> (off + cgRepSizeW dflags rep, off)) 0 reps_w_regs 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)) + (CmmLoad (cmmRegOffW dflags spReg offset) + (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 dflags spReg offset) (CmmReg (CmmGlobal reg)) - stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset) - stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset)) + stk_adj_pop = CmmAssign spReg (cmmRegOffW dflags spReg final_stk_offset) + stk_adj_push = CmmAssign spReg (cmmRegOffW dflags spReg (- final_stk_offset)) live_regs = Just $ map snd reps_w_regs jump_to_entry = CmmJump (mkLblExpr (entryLabelFromCI dflags cl_info)) live_regs \end{code} @@ -429,8 +430,8 @@ 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), - CmmLit (mkIntCLit tag)]) l) - stmtC (CmmStore (CmmLit (mkWordCLit 0)) (CmmLit (mkWordCLit 0))) + 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), CmmLit zeroCLit]) $ + ; 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..aeb87235e3 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 @@ -99,7 +98,7 @@ cgTopRhsCon id con args ; emitDataLits closure_label closure_rep -- RETURN - ; returnFC (id, taggedStableIdInfo id (mkLblExpr closure_label) lf_info con) } + ; returnFC (id, taggedStableIdInfo dflags id (mkLblExpr closure_label) lf_info con) } \end{code} %************************************************************************ @@ -149,8 +148,8 @@ which have exclusively size-zero (VoidRep) args, we generate no code at all. \begin{code} -buildDynCon' _ _ binder _ con [] - = returnFC (taggedStableIdInfo binder +buildDynCon' dflags _ binder _ con [] + = returnFC (taggedStableIdInfo dflags binder (mkLblExpr (mkClosureLabel (dataConName con) (idCafInfo binder))) (mkConLFInfo con) @@ -189,24 +188,24 @@ 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) } + intlike_amode = CmmLit (cmmLabelOffW dflags intlike_lbl offsetW) + ; returnFC (taggedStableIdInfo dflags binder intlike_amode (mkConLFInfo con) con) } buildDynCon' dflags platform binder _ con [arg_amode] | maybeCharLikeCon con , 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) } + charlike_amode = CmmLit (cmmLabelOffW dflags charlike_lbl offsetW) + ; returnFC (taggedStableIdInfo dflags binder charlike_amode (mkConLFInfo con) con) } \end{code} @@ -219,7 +218,7 @@ buildDynCon' dflags _ binder ccs con args (closure_info, amodes_w_offsets) = layOutDynConstr dflags con args ; hp_off <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets - ; returnFC (taggedHeapIdInfo binder hp_off lf_info con) } + ; returnFC (taggedHeapIdInfo dflags binder hp_off lf_info con) } where lf_info = mkConLFInfo con @@ -250,7 +249,7 @@ bindConArgs con args let -- The binding below forces the masking out of the tag bits -- when accessing the constructor field. - bind_arg (arg, offset) = bindNewToUntagNode arg offset (mkLFArgument arg) (tagForCon con) + bind_arg (arg, offset) = bindNewToUntagNode arg offset (mkLFArgument arg) (tagForCon dflags con) (_, args_w_offsets) = layOutDynConstr dflags con (addIdReps args) -- ASSERT(not (isUnboxedTupleCon con)) return () @@ -285,8 +284,8 @@ bindUnboxedTupleComponents args -- Allocate the rest on the stack -- The real SP points to the return address, above which any -- leftover unboxed-tuple components will be allocated - (ptr_sp, ptr_offsets) = mkVirtStkOffsets rsp ptr_args - (nptr_sp, nptr_offsets) = mkVirtStkOffsets ptr_sp nptr_args + (ptr_sp, ptr_offsets) = mkVirtStkOffsets dflags rsp ptr_args + (nptr_sp, nptr_offsets) = mkVirtStkOffsets dflags ptr_sp nptr_args ptrs = ptr_sp - rsp nptrs = nptr_sp - ptr_sp @@ -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 @@ -419,7 +418,8 @@ closures predeclared. \begin{code} cgTyCon :: TyCon -> FCode CmmGroup -- each constructor gets a separate CmmGroup cgTyCon tycon - = do { constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon) + = do { dflags <- getDynFlags + ; constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon) -- Generate a table of static closures for an enumeration type -- Put the table after the data constructor decls, because the @@ -432,7 +432,7 @@ cgTyCon tycon ; extra <- if isEnumerationTyCon tycon then do tbl <- getCmm (emitRODataLits "cgTyCon" (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs) - [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs) (tagForCon con) + [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs) (tagForCon dflags con) | con <- tyConDataCons tycon]) return [tbl] else @@ -478,7 +478,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 a37245ea01..824a82635d 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -30,7 +30,6 @@ import OldCmm import OldCmmUtils import SMRep import ForeignCall -import Constants import DynFlags import Outputable import Module @@ -70,13 +69,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 +98,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 + arg_size rep = max (widthInBytes (typeWidth rep)) (wORD_SIZE dflags) + 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 +136,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 +151,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 +193,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,78 +211,81 @@ 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], - CmmLit (mkIntCLit 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 +closureField dflags off = off + fixedHdrSize dflags * wORD_SIZE dflags stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr stgSp = CmmReg sp @@ -307,10 +310,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 2ce37cf565..c7f6f294ce 100644 --- a/compiler/codeGen/CgHeapery.lhs +++ b/compiler/codeGen/CgHeapery.lhs @@ -42,7 +42,6 @@ import TyCon import CostCentre import Util import Module -import Constants import Outputable import DynFlags import FastString @@ -103,8 +102,9 @@ setRealHp new_realHp getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr getHpRelOffset virtual_offset - = do { hp_usg <- getHpUsage - ; return (cmmRegOffW hpReg (hpRel (realHp hp_usg) virtual_offset)) } + = do { dflags <- getDynFlags + ; hp_usg <- getHpUsage + ; return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset)) } \end{code} @@ -165,7 +165,7 @@ mkVirtHeapOffsets dflags is_thunk things | otherwise = fixedHdrSize dflags computeOffset wds_so_far (rep, thing) - = (wds_so_far + cgRepSizeW rep, (thing, hdr_size + wds_so_far)) + = (wds_so_far + cgRepSizeW dflags rep, (thing, hdr_size + wds_so_far)) \end{code} @@ -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,10 +241,10 @@ 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) - pad_length = wORD_SIZE - widthInBytes width :: Int +padLitToWord :: DynFlags -> CmmLit -> [CmmLit] +padLitToWord dflags lit = lit : padding pad_length + where width = typeWidth (cmmLitType dflags lit) + pad_length = wORD_SIZE dflags - widthInBytes width :: Int padding n | n <= 0 = [] | n `rem` 2 /= 0 = CmmInt 0 W8 : padding (n-1) @@ -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' (CmmLit (mkIntCLit (stk*wORD_SIZE))) - (CmmLit (mkIntCLit (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 dflags)) + (mkIntExpr dflags (hp * wORD_SIZE dflags)) + (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' (CmmLit (mkIntCLit 0)) 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' (CmmLit (mkIntCLit 0)) 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 (CmmLit (mkIntCLit 0)) 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 (CmmLit (mkIntCLit 0)) 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..e2a3aa2efd 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -43,7 +43,6 @@ import CLabel import Name import Unique -import Constants import DynFlags import Util import Outputable @@ -94,16 +93,17 @@ emitReturnTarget -> CgStmts -- The direct-return code (if any) -> FCode CLabel emitReturnTarget name stmts - = do { srt_info <- getSRTInfo - ; blks <- cgStmtsToBlocks stmts - ; frame <- mkStackLayout - ; let smrep = mkStackRep (mkLiveness frame) - info = CmmInfoTable { cit_lbl = info_lbl - , cit_prof = NoProfilingInfo - , cit_rep = smrep - , cit_srt = srt_info } - ; emitInfoTableAndCode entry_lbl info args blks - ; return info_lbl } + = do dflags <- getDynFlags + srt_info <- getSRTInfo + blks <- cgStmtsToBlocks stmts + frame <- mkStackLayout + let smrep = mkStackRep (mkLiveness dflags frame) + info = CmmInfoTable { cit_lbl = info_lbl + , cit_prof = NoProfilingInfo + , cit_rep = smrep + , cit_srt = srt_info } + emitInfoTableAndCode entry_lbl info args blks + return info_lbl where args = {- trace "emitReturnTarget: missing args" -} [] uniq = getUnique name @@ -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) + rep_size = cgRepSizeW dflags (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? - if isSmallFamily fam_sz + dflags <- getDynFlags + if isSmallFamily dflags 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) @@ -256,7 +258,7 @@ stdInfoTableSizeW dflags | otherwise = 0 stdInfoTableSizeB :: DynFlags -> ByteOff -stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE +stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags stdSrtBitmapOffset :: DynFlags -> ByteOff -- Byte offset of the SRT bitmap half-word which is @@ -265,11 +267,11 @@ stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE stdClosureTypeOffset :: DynFlags -> ByteOff -- Byte offset of the closure type half-word -stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE +stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff -stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2*wORD_SIZE -stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2*wORD_SIZE + hALF_WORD_SIZE +stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags +stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE ------------------------------------------------------------------------- -- @@ -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/CgLetNoEscape.lhs b/compiler/codeGen/CgLetNoEscape.lhs index 2fb603baed..610869ad89 100644 --- a/compiler/codeGen/CgLetNoEscape.lhs +++ b/compiler/codeGen/CgLetNoEscape.lhs @@ -162,7 +162,8 @@ cgLetNoEscapeClosure in -- saveVolatileVarsAndRegs done earlier in cgExpr. - do { (vSp, _) <- forkEvalHelp rhs_eob_info + do { dflags <- getDynFlags + ; (vSp, _) <- forkEvalHelp rhs_eob_info (do { allocStackTop retAddrSizeW ; nukeDeadBindings full_live_in_rhss }) @@ -176,7 +177,7 @@ cgLetNoEscapeClosure ; _ <- emitReturnTarget (idName bndr) abs_c ; return () }) - ; returnFC (bndr, letNoEscapeIdInfo bndr vSp lf_info) } + ; returnFC (bndr, letNoEscapeIdInfo dflags bndr vSp lf_info) } \end{code} \begin{code} diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index a2e50e0c0d..98c7e21332 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -28,12 +28,12 @@ import OldCmmUtils import PrimOp import SMRep import Module -import Constants import Outputable import DynFlags import FastString import Control.Monad +import Data.Bits -- --------------------------------------------------------------------------- -- Code generation for PrimOps @@ -45,12 +45,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 @@ -59,7 +61,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 @@ -81,19 +83,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)] ], - CmmLit (mkIntCLit (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)); \ @@ -104,19 +106,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)] ], - CmmLit (mkIntCLit (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. @@ -132,15 +134,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) @@ -153,24 +155,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-}] @@ -184,54 +183,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 @@ -243,203 +237,211 @@ 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 -emitPrimOp [res] PopCnt8Op [w] live = emitPopCntCall res w W8 live -emitPrimOp [res] PopCnt16Op [w] live = emitPopCntCall res w W16 live -emitPrimOp [res] PopCnt32Op [w] live = emitPopCntCall res w W32 live -emitPrimOp [res] PopCnt64Op [w] live = emitPopCntCall res w W64 live -emitPrimOp [res] PopCntOp [w] live = emitPopCntCall res w wordWidth live +-- Population count. +-- The type of the primop takes a Word#, so we have to be careful to narrow +-- 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 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 @@ -450,49 +452,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] @@ -523,8 +525,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, @@ -533,9 +535,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 @@ -549,23 +551,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 @@ -591,17 +593,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, @@ -609,7 +611,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 @@ -640,125 +642,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. @@ -815,7 +817,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 @@ -835,47 +837,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)) - (CmmMachOp mo_wordUShr [idx, - CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)]) + (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 dflags + 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 @@ -894,7 +899,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 @@ -909,9 +915,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) @@ -920,8 +927,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 -- ---------------------------------------------------------------------------- @@ -934,8 +941,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 @@ -958,7 +965,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 dflags))) live -- | Takes a source 'MutableArray#', an offset in the source array, a -- destination 'MutableArray#', an offset into the destination array, @@ -972,9 +980,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 dflags))) live) + (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags (wORD_SIZE dflags))) live) emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code) @@ -994,15 +1003,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 dflags))) 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 @@ -1014,65 +1023,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 dflags) + 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_words <- assignTemp $ (n `cmmUShrWord` - (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))) - `cmmAddWord` CmmLit (mkIntCLit 1) - size <- assignTemp $ n `cmmAddWord` card_words - 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 dflags + + oFFSET_StgMutArrPtrs_ptrs dflags)) n + stmtC $ CmmStore (cmmOffsetB dflags arr (fixedHdrSize dflags * wORD_SIZE dflags + + 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 dflags))) live - emitMemsetCall (cmmOffsetExprW dst_p n) - (CmmLit (mkIntCLit 1)) - (card_words `cmmMulWord` wordSize) - (CmmLit (mkIntCLit wORD_SIZE)) + emitMemsetCall (cmmOffsetExprW dflags dst_p n) + (CmmLit (mkIntCLit dflags 1)) + card_bytes + (CmmLit (mkIntCLit dflags (wORD_SIZE dflags))) live stmtC $ CmmAssign (CmmLocal res_r) arr - where - arrPtrsHdrSizeW dflags = CmmLit $ mkIntCLit $ fixedHdrSize dflags + - (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE) - wordSize = CmmLit (mkIntCLit 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)) - ((card (dst_start `cmmAddWord` n) `cmmSubWord` start_card) - `cmmAddWord` CmmLit (mkIntCLit 1)) - (CmmLit (mkIntCLit wORD_SIZE)) + 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 - where - -- Convert an element index to a card index - card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)) + +-- Convert an element index to a card index +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 :: DynFlags -> CmmExpr -> CmmExpr +cardRoundUp dflags i = card dflags (cmmAddWord dflags i (CmmLit (mkIntCLit dflags ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS dflags) - 1)))) + +bytesToWordsRoundUp :: DynFlags -> CmmExpr -> CmmExpr +bytesToWordsRoundUp dflags e + = cmmQuotWord dflags + (cmmAddWord dflags e (CmmLit (mkIntCLit dflags (wORD_SIZE dflags - 1)))) + (wordSize dflags) + +wordSize :: DynFlags -> CmmExpr +wordSize dflags = CmmLit (mkIntCLit dflags (wORD_SIZE dflags)) -- | Emit a call to @memcpy@. emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs index 2eccae7926..6d87ee7127 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,6 @@ import CostCentre import DynFlags import FastString import Module -import Constants -- Lots of field offsets import Outputable import Data.Char @@ -77,27 +69,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 +103,7 @@ profDynAlloc :: ClosureInfo -> CmmExpr -> Code profDynAlloc cl_info ccs = ifProfiling $ do dflags <- getDynFlags - profAlloc (CmmLit (mkIntCLit (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 +116,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, - CmmLit (mkIntCLit (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 +160,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,51 +174,53 @@ 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 dflags - 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 :: DynFlags -> Int +sizeof_ccs_words dflags -- round up to the next word. | ms == 0 = ws | otherwise = ws + 1 where - (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE + (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE dflags -- --------------------------------------------------------------------------- -- Set the current cost centre stack @@ -230,51 +229,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, CmmLit (mkIntCLit 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 +283,38 @@ ldvRecordCreate closure = stmtC $ CmmStore (ldvWord closure) dynLdvInit -- profiling. -- ldvEnterClosure :: ClosureInfo -> Code -ldvEnterClosure closure_info = ldvEnter (cmmOffsetB (CmmReg nodeReg) (-tag)) - where tag = funTag closure_info +ldvEnterClosure closure_info + = do dflags <- getDynFlags + let tag = funTag dflags closure_info + ldvEnter (cmmOffsetB dflags (CmmReg nodeReg) (-tag)) -- 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..2f7bdfc083 100644 --- a/compiler/codeGen/CgStackery.lhs +++ b/compiler/codeGen/CgStackery.lhs @@ -37,7 +37,6 @@ import SMRep import OldCmm import OldCmmUtils import CLabel -import Constants import DynFlags import Util import OrdList @@ -101,8 +100,9 @@ setRealSp new_real_sp getSpRelOffset :: VirtualSpOffset -> FCode CmmExpr getSpRelOffset virtual_offset - = do { real_sp <- getRealSp - ; return (cmmRegOffW spReg (spRel real_sp virtual_offset)) } + = do dflags <- getDynFlags + real_sp <- getRealSp + return (cmmRegOffW dflags spReg (spRel real_sp virtual_offset)) \end{code} @@ -118,12 +118,13 @@ increase towards the top of stack). \begin{code} mkVirtStkOffsets - :: VirtualSpOffset -- Offset of the last allocated thing + :: DynFlags + -> VirtualSpOffset -- Offset of the last allocated thing -> [(CgRep,a)] -- things to make offsets for -> (VirtualSpOffset, -- OUTPUTS: Topmost allocated word [(a, VirtualSpOffset)]) -- things with offsets (voids filtered out) -mkVirtStkOffsets init_Sp_offset things +mkVirtStkOffsets dflags init_Sp_offset things = loop init_Sp_offset [] (reverse things) where loop offset offs [] = (offset,offs) @@ -132,7 +133,7 @@ mkVirtStkOffsets init_Sp_offset things loop offset offs ((rep,t):things) = loop thing_slot ((t,thing_slot):offs) things where - thing_slot = offset + cgRepSizeW rep + thing_slot = offset + cgRepSizeW dflags rep -- offset of thing is offset+size, because we're -- growing the stack *downwards* as the offsets increase. @@ -149,12 +150,13 @@ mkStkAmodes CmmStmts) -- Assignments to appropriate stk slots mkStkAmodes tail_Sp things - = do { rSp <- getRealSp - ; let (last_Sp_offset, offsets) = mkVirtStkOffsets tail_Sp things - abs_cs = [ CmmStore (cmmRegOffW spReg (spRel rSp offset)) amode - | (amode, offset) <- offsets - ] - ; returnFC (last_Sp_offset, toOL abs_cs) } + = do dflags <- getDynFlags + rSp <- getRealSp + let (last_Sp_offset, offsets) = mkVirtStkOffsets dflags tail_Sp things + abs_cs = [ CmmStore (cmmRegOffW dflags spReg (spRel rSp offset)) amode + | (amode, offset) <- offsets + ] + returnFC (last_Sp_offset, toOL abs_cs) \end{code} %************************************************************************ @@ -167,7 +169,11 @@ Allocate a virtual offset for something. \begin{code} allocPrimStack :: CgRep -> FCode VirtualSpOffset -allocPrimStack rep +allocPrimStack rep = do dflags <- getDynFlags + allocPrimStack' dflags rep + +allocPrimStack' :: DynFlags -> CgRep -> FCode VirtualSpOffset +allocPrimStack' dflags rep = do { stk_usg <- getStkUsage ; let free_stk = freeStk stk_usg ; case find_block free_stk of @@ -183,7 +189,7 @@ allocPrimStack rep } where size :: WordOff - size = cgRepSizeW rep + size = cgRepSizeW dflags rep -- Find_block looks for a contiguous chunk of free slots -- returning the offset of its topmost word @@ -289,7 +295,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 dflags) ; vsp <- getVirtSp ; setStackFrame vsp ; frame_addr <- getSpRelOffset vsp @@ -317,12 +323,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 dflags + 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 cfef1087cc..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 @@ -310,8 +311,8 @@ tickyAllocHeap hp ifTicky :: Code -> Code ifTicky code = do dflags <- getDynFlags - if doingTickyProfiling dflags then code - else nopC + if dopt Opt_Ticky dflags then code + else nopC addToMemLbl :: Width -> CLabel -> Int -> CmmStmt addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 298143bd08..c52c8a8c99 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -53,7 +53,6 @@ import TyCon import DataCon import Id import IdInfo -import Constants import SMRep import OldCmm import OldCmmUtils @@ -69,7 +68,6 @@ import Util import DynFlags import FastString import Outputable -import Platform import Data.Char import Data.Word @@ -94,33 +92,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))) --------------------------------------------------- @@ -142,20 +141,20 @@ mkLtOp lit = MO_U_Lt (typeWidth (cmmLitType (mkSimpleLit lit))) Big families only use the tag value 1 to represent evaluatedness. -} -isSmallFamily :: Int -> Bool -isSmallFamily fam_size = fam_size <= mAX_PTR_TAG +isSmallFamily :: DynFlags -> Int -> Bool +isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags -tagForCon :: DataCon -> ConTagZ -tagForCon con = tag +tagForCon :: DynFlags -> DataCon -> ConTagZ +tagForCon dflags con = tag where con_tag = dataConTagZ con fam_size = tyConFamilySize (dataConTyCon con) - tag | isSmallFamily fam_size = con_tag + 1 - | otherwise = 1 + tag | isSmallFamily dflags fam_size = con_tag + 1 + | 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 dflags con) -------------------------------------------------------------------------- -- @@ -183,9 +182,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 +298,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 +322,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 +401,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 +414,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 +478,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 +501,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 +514,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 +522,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 +532,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 +542,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 +610,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 +635,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 +658,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 +695,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 +721,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 +786,7 @@ possiblySameLoc _ _ _ _ = True -- Conservative getSRTInfo :: FCode C_SRT getSRTInfo = do + dflags <- getDynFlags srt_lbl <- getSRTLabel srt <- getSRT case srt of @@ -788,9 +799,9 @@ getSRTInfo = do -> do id <- newUnique let srt_desc_lbl = mkLargeSRTLabel id emitRODataLits "getSRTInfo" srt_desc_lbl - ( cmmLabelOffW srt_lbl off - : mkWordCLit (fromIntegral len) - : map mkWordCLit bmp) + ( cmmLabelOffW dflags srt_lbl off + : mkWordCLit dflags (fromIntegral len) + : map (mkWordCLit dflags) bmp) return (C_SRT srt_desc_lbl 0 srt_escape) | otherwise @@ -810,80 +821,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 +907,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 +919,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 d3db24ce4c..7a72a00602 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 @@ -342,17 +342,17 @@ separateByPtrFollowness things \end{code} \begin{code} -cgRepSizeB :: CgRep -> ByteOff -cgRepSizeB DoubleArg = dOUBLE_SIZE -cgRepSizeB LongArg = wORD64_SIZE -cgRepSizeB VoidArg = 0 -cgRepSizeB _ = wORD_SIZE - -cgRepSizeW :: CgRep -> ByteOff -cgRepSizeW DoubleArg = dOUBLE_SIZE `quot` wORD_SIZE -cgRepSizeW LongArg = wORD64_SIZE `quot` wORD_SIZE -cgRepSizeW VoidArg = 0 -cgRepSizeW _ = 1 +cgRepSizeB :: DynFlags -> CgRep -> ByteOff +cgRepSizeB dflags DoubleArg = dOUBLE_SIZE dflags +cgRepSizeB _ LongArg = wORD64_SIZE +cgRepSizeB _ VoidArg = 0 +cgRepSizeB dflags _ = wORD_SIZE dflags + +cgRepSizeW :: DynFlags -> CgRep -> ByteOff +cgRepSizeW dflags DoubleArg = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags +cgRepSizeW dflags LongArg = wORD64_SIZE `quot` wORD_SIZE dflags +cgRepSizeW _ VoidArg = 0 +cgRepSizeW _ _ = 1 retAddrSizeW :: WordOff retAddrSizeW = 1 -- One word @@ -689,7 +689,7 @@ getCallMethod _dflags _name _caf (LFThunk _ _ _updatable _std_form_info is_fun) -- So the right thing to do is just to enter the thing -- Old version: --- | updatable || doingTickyProfiling dflags -- to catch double entry +-- | updatable || dopt Opt_Ticky dflags -- to catch double entry -- = EnterIt -- | otherwise -- Jump direct to code for single-entry thunks -- = JumpToIt (thunkEntryLabel name caf std_form_info updatable) @@ -927,25 +927,27 @@ lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr) lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc) lfFunInfo _ = Nothing -funTag :: ClosureInfo -> Int -funTag (ClosureInfo { closureLFInfo = lf_info }) = funTagLFInfo lf_info -funTag _ = 0 +funTag :: DynFlags -> ClosureInfo -> Int +funTag dflags (ClosureInfo { closureLFInfo = lf_info }) + = funTagLFInfo dflags lf_info +funTag _ _ = 0 -- maybe this should do constructor tags too? -funTagLFInfo :: LambdaFormInfo -> Int -funTagLFInfo lf +funTagLFInfo :: DynFlags -> LambdaFormInfo -> Int +funTagLFInfo dflags lf -- A function is tagged with its arity | Just (arity,_) <- lfFunInfo lf, - Just tag <- tagForArity arity + Just tag <- tagForArity dflags arity = tag -- other closures (and unknown ones) are not tagged | otherwise = 0 -tagForArity :: RepArity -> Maybe Int -tagForArity i | i <= mAX_PTR_TAG = Just i - | otherwise = Nothing +tagForArity :: DynFlags -> RepArity -> Maybe Int +tagForArity dflags i + | i <= mAX_PTR_TAG dflags = Just i + | otherwise = Nothing clHasCafRefs :: ClosureInfo -> CafInfo clHasCafRefs (ClosureInfo {closureSRT = srt}) = diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs index 29193137a7..311f947248 100644 --- a/compiler/codeGen/CodeGen.lhs +++ b/compiler/codeGen/CodeGen.lhs @@ -35,7 +35,6 @@ import OldPprCmm () import StgSyn import PrelNames import DynFlags -import StaticFlags import HscTypes import CostCentre @@ -101,7 +100,7 @@ mkModuleInit mkModuleInit dflags cost_centre_info this_mod hpc_info = do { -- Allocate the static boolean that records if this - ; whenC (opt_Hpc) $ + ; whenC (dopt Opt_Hpc dflags) $ hpcTable this_mod hpc_info ; whenC (dopt Opt_SccProfilingOn dflags) $ do diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index b8ed1aa939..f1022e5280 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -143,7 +143,6 @@ cgTopRhs bndr (StgRhsCon _cc con args) cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag _srt args body) = ASSERT(null fvs) -- There should be no free variables - setSRTLabel (mkSRTLabel (idName bndr) (idCafInfo bndr)) $ forkStatics (cgTopRhsClosure bndr cc bi upd_flag args body) @@ -206,9 +205,10 @@ mkModuleInit cost_centre_info this_mod hpc_info cgEnumerationTyCon :: TyCon -> FCode () cgEnumerationTyCon tycon - = emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs) + = do dflags <- getDynFlags + emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs) [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs) - (tagForCon con) + (tagForCon dflags con) | con <- tyConDataCons tycon] @@ -236,8 +236,8 @@ cgDataCon data_con do { _ <- ticky_code ; ldvEnter (CmmReg nodeReg) ; tickyReturnOldCon (length arg_things) - ; void $ emitReturn [cmmOffsetB (CmmReg nodeReg) - (tagForCon data_con)] + ; void $ emitReturn [cmmOffsetB dflags (CmmReg nodeReg) + (tagForCon dflags data_con)] } -- The case continuation code expects a tagged pointer diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 0f0bfb8467..02d3d0246f 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -43,7 +43,6 @@ import Module import ListSetOps import Util import BasicTypes -import Constants import Outputable import FastString import Maybes @@ -65,9 +64,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 +242,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 +271,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 +340,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 +381,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 +457,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 - , CmmLit (mkIntCLit (funTag cl_info)) ]) + , mkIntExpr dflags (funTag dflags cl_info) ]) ; whenC node_points (ldvEnterClosure cl_info) ; granYield arg_regs node_points @@ -481,8 +481,9 @@ 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) - where tag = lfDynTag lf_info + do dflags <- getDynFlags + let tag = lfDynTag dflags lf_info + emit $ mkTaggedObjectLoad dflags reg node off tag) ----------------------------------------- -- The "slow entry" code for a function. This entry point takes its @@ -506,7 +507,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 +581,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)) @@ -632,9 +633,9 @@ pushUpdateFrame lbl updatee body updfr <- getUpdFrameOff dflags <- getDynFlags let - hdr = fixedHdrSize dflags * wORD_SIZE - frame = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr - off_updatee = hdr + oFFSET_StgUpdateFrame_updatee + hdr = fixedHdrSize dflags * wORD_SIZE dflags + 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 +687,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 +704,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 +715,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/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index 2afcb6a8c7..85346da205 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -86,7 +86,6 @@ import TcType import TyCon import BasicTypes import Outputable -import Constants import DynFlags import Util @@ -299,32 +298,33 @@ Big families only use the tag value 1 to represent evaluatedness. We don't have very many tag bits: for example, we have 2 bits on x86-32 and 3 bits on x86-64. -} -isSmallFamily :: Int -> Bool -isSmallFamily fam_size = fam_size <= mAX_PTR_TAG +isSmallFamily :: DynFlags -> Int -> Bool +isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags -- We keep the *zero-indexed* tag in the srt_len field of the info -- table of a data constructor. dataConTagZ :: DataCon -> ConTagZ dataConTagZ con = dataConTag con - fIRST_TAG -tagForCon :: DataCon -> DynTag -tagForCon con - | isSmallFamily fam_size = con_tag + 1 - | otherwise = 1 +tagForCon :: DynFlags -> DataCon -> DynTag +tagForCon dflags con + | isSmallFamily dflags fam_size = con_tag + 1 + | otherwise = 1 where con_tag = dataConTagZ con fam_size = tyConFamilySize (dataConTyCon con) -tagForArity :: RepArity -> DynTag -tagForArity arity | isSmallFamily arity = arity - | otherwise = 0 +tagForArity :: DynFlags -> RepArity -> DynTag +tagForArity dflags arity + | isSmallFamily dflags arity = arity + | otherwise = 0 -lfDynTag :: LambdaFormInfo -> DynTag +lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag -- Return the tag in the low order bits of a variable bound -- to this LambdaForm -lfDynTag (LFCon con) = tagForCon con -lfDynTag (LFReEntrant _ arity _ _) = tagForArity arity -lfDynTag _other = 0 +lfDynTag dflags (LFCon con) = tagForCon dflags con +lfDynTag dflags (LFReEntrant _ arity _ _) = tagForArity dflags arity +lfDynTag _ _other = 0 ----------------------------------------------------------------------------- @@ -498,7 +498,7 @@ getCallMethod dflags name caf (LFThunk _ _ updatable std_form_info is_fun) n_arg -- is the fast-entry code] -- Since is_fun is False, we are *definitely* looking at a data value - | updatable || doingTickyProfiling dflags -- to catch double entry + | updatable || dopt Opt_Ticky dflags -- to catch double entry {- OLD: || opt_SMP I decided to remove this, because in SMP mode it doesn't matter if we enter the same thunk multiple times, so the optimisation @@ -755,8 +755,9 @@ lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr) lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc) lfFunInfo _ = Nothing -funTag :: ClosureInfo -> DynTag -funTag (ClosureInfo { closureLFInfo = lf_info }) = lfDynTag lf_info +funTag :: DynFlags -> ClosureInfo -> DynTag +funTag dflags (ClosureInfo { closureLFInfo = lf_info }) + = lfDynTag dflags lf_info isToplevClosure :: ClosureInfo -> Bool isToplevClosure (ClosureInfo { closureLFInfo = lf_info }) diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index 083e615b78..c822a64e2c 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 + intlike_amode = cmmLabelOffW dflags intlike_lbl offsetW + ; 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 + charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW + ; 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 @@ -247,16 +246,15 @@ bindConArgs (DataAlt con) base args = ASSERT(not (isUnboxedTupleCon con)) do dflags <- getDynFlags let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args) + tag = tagForCon dflags con + + -- The binding below forces the masking out of the tag bits + -- when accessing the constructor field. + bind_arg :: (NonVoid Id, VirtualHpOffset) -> FCode LocalReg + bind_arg (arg, offset) + = do emit $ mkTaggedObjectLoad dflags (idToReg dflags arg) base offset tag + bindArgToReg arg mapM bind_arg args_w_offsets - where - tag = tagForCon con - - -- The binding below forces the masking out of the tag bits - -- when accessing the constructor field. - bind_arg :: (NonVoid Id, VirtualHpOffset) -> FCode LocalReg - bind_arg (arg, offset) - = do { emit $ mkTaggedObjectLoad (idToReg arg) base offset tag - ; bindArgToReg arg } bindConArgs _other_con _base args = ASSERT( null args ) return [] diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs index 9f1f161d37..5106b971b1 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 @@ -75,25 +76,25 @@ nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidRep (idPrimRep id))] -- Manipulating CgIdInfo ------------------------------------- -mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo -mkCgIdInfo id lf expr +mkCgIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo +mkCgIdInfo dflags id lf expr = CgIdInfo { cg_id = id, cg_lf = lf , cg_loc = CmmLoc expr, - cg_tag = lfDynTag lf } + cg_tag = lfDynTag dflags 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 + tag = lfDynTag dflags 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_tag = lfDynTag lf } + , cg_loc = LneLoc blk_id (map (idToReg dflags) regs) + , cg_tag = lfDynTag dflags lf } where lf = mkLFLetNoEscape blk_id = mkBlockId (idUnique id) @@ -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 dflags 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 dflags 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 @@ -180,15 +183,13 @@ cgLookupPanic :: Id -> FCode a cgLookupPanic id = do static_binds <- getStaticBinds local_binds <- getBinds - srt <- getSRTLabel - pprPanic "StgCmmEnv: variable not found" + pprPanic "StgCmmEnv: variable not found" (vcat [ppr id, ptext (sLit "static binds for:"), vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ], ptext (sLit "local binds for:"), - vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ], - ptext (sLit "SRT label") <+> ppr srt - ]) + vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ] + ]) -------------------- @@ -214,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 dflags id lf_info (CmmReg (CmmLocal reg))) + return reg rebindToReg :: NonVoid Id -> FCode LocalReg -- Like bindToReg, but the Id is already in scope, so @@ -231,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 -- @@ -239,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 ab6f888835..307d3715b3 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 + ; if isSmallFamily dflags 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 @@ -611,7 +624,10 @@ cgIdApp fun_id args = do { fun_info <- getCgIdInfo fun_id ; case maybeLetNoEscape fun_info of Just (blk_id, lne_regs) -> cgLneJump blk_id lne_regs args - Nothing -> cgTailCall fun_id fun_info args } + Nothing -> cgTailCall (cg_id fun_info) fun_info args } + -- NB. use (cg_id fun_info) instead of fun_id, because the former + -- may be externalised for -split-objs. + -- See StgCmm.maybeExternaliseId. cgLneJump :: BlockId -> [LocalReg] -> [StgArg] -> FCode ReturnKind cgLneJump blk_id lne_regs args -- Join point; discard sequel @@ -670,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 } @@ -712,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 5a717bbc65..9e4db9cdaa 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -34,7 +34,6 @@ import TysPrim import CLabel import SMRep import ForeignCall -import Constants import DynFlags import Maybes import Outputable @@ -55,7 +54,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 dflags) + ; cmm_args <- getFCallArgs stg_args ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty ; let ((call_args, arg_hints), cmm_target) = case target of @@ -98,18 +109,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 +221,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 +261,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 +278,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,78 +290,79 @@ 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], - CmmLit (mkIntCLit 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 -closureField dflags off = off + fixedHdrSize dflags * wORD_SIZE +closureField dflags off = off + fixedHdrSize dflags * wORD_SIZE dflags stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr stgSp = CmmReg sp @@ -405,10 +406,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 12f3b1347e..fb3739177c 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -44,7 +44,6 @@ import IdInfo( CafInfo(..), mayHaveCafRefs ) import Module import DynFlags import FastString( mkFastString, fsLit ) -import Constants import Util import Control.Monad (when) @@ -140,9 +139,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 +180,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 +189,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 +205,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,10 +218,10 @@ 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) - pad_length = wORD_SIZE - widthInBytes width :: Int +padLitToWord :: DynFlags -> CmmLit -> [CmmLit] +padLitToWord dflags lit = lit : padding pad_length + where width = typeWidth (cmmLitType dflags lit) + pad_length = wORD_SIZE dflags - widthInBytes width :: Int padding n | n <= 0 = [] | n `rem` 2 /= 0 = CmmInt 0 W8 : padding (n-1) @@ -401,9 +400,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 +436,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 +450,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 +478,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 +489,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 +540,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 dflags) -- 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 +576,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 = CmmLit (mkIntCLit (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 4465e30b04..cb60e9dd71 100644 --- a/compiler/codeGen/StgCmmHpc.hs +++ b/compiler/codeGen/StgCmmHpc.hs @@ -17,16 +17,16 @@ import Module import CmmUtils import StgCmmUtils import HscTypes -import StaticFlags +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 @@ -35,9 +35,10 @@ initHpc :: Module -> HpcInfo -> FCode () initHpc _ (NoHpcInfo {}) = return () initHpc this_mod (HpcInfo tickCount _hashNo) - = whenC opt_Hpc $ - do { emitDataLits (mkHpcTicksLabel this_mod) - [ (CmmInt 0 W64) - | _ <- take tickCount [0::Int ..] - ] - } + = do dflags <- getDynFlags + whenC (dopt Opt_Hpc dflags) $ + do emitDataLits (mkHpcTicksLabel this_mod) + [ (CmmInt 0 W64) + | _ <- take tickCount [0 :: Int ..] + ] + diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index e20e4a29bd..142100e109 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -219,7 +219,7 @@ direct_call caller call_conv lbl arity args emitCallWithExtraStack (call_conv, NativeReturn) target (nonVArgs fast_args) - (mkStkOffsets (stack_args dflags)) + (mkStkOffsets dflags (stack_args dflags)) where target = CmmLit (CmmLabel lbl) (fast_args, rest_args) = splitAt real_arity args @@ -329,10 +329,11 @@ slowCallPattern [] = (fsLit "stg_ap_0", 0) -- See Note [over-saturated calls]. mkStkOffsets - :: [(ArgRep, Maybe CmmExpr)] -- things to make offsets for + :: DynFlags + -> [(ArgRep, Maybe CmmExpr)] -- things to make offsets for -> ( ByteOff -- OUTPUTS: Topmost allocated word , [(CmmExpr, ByteOff)] ) -- things with offsets (voids filtered out) -mkStkOffsets things +mkStkOffsets dflags things = loop 0 [] (reverse things) where loop offset offs [] = (offset,offs) @@ -341,7 +342,7 @@ mkStkOffsets things loop offset offs ((rep,Just thing):things) = loop thing_off ((thing, thing_off):offs) things where - thing_off = offset + argRepSizeW rep * wORD_SIZE + thing_off = offset + argRepSizeW dflags rep * wORD_SIZE dflags -- offset of thing is offset+size, because we're -- growing the stack *downwards* as the offsets increase. @@ -382,13 +383,13 @@ isNonV :: ArgRep -> Bool isNonV V = False isNonV _ = True -argRepSizeW :: ArgRep -> WordOff -- Size in words -argRepSizeW N = 1 -argRepSizeW P = 1 -argRepSizeW F = 1 -argRepSizeW L = wORD64_SIZE `quot` wORD_SIZE -argRepSizeW D = dOUBLE_SIZE `quot` wORD_SIZE -argRepSizeW V = 0 +argRepSizeW :: DynFlags -> ArgRep -> WordOff -- Size in words +argRepSizeW _ N = 1 +argRepSizeW _ P = 1 +argRepSizeW _ F = 1 +argRepSizeW dflags L = wORD64_SIZE `quot` wORD_SIZE dflags +argRepSizeW dflags D = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags +argRepSizeW _ V = 0 idArgRep :: Id -> ArgRep idArgRep = toArgRep . idPrimRep @@ -405,8 +406,9 @@ hpRel hp off = off - hp getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr getHpRelOffset virtual_offset - = do { hp_usg <- getHpUsage - ; return (cmmRegOffW hpReg (hpRel (realHp hp_usg) virtual_offset)) } + = do dflags <- getDynFlags + hp_usg <- getHpUsage + return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset)) mkVirtHeapOffsets :: DynFlags @@ -438,7 +440,7 @@ mkVirtHeapOffsets dflags is_thunk things | otherwise = fixedHdrSize dflags computeOffset wds_so_far (rep, thing) - = (wds_so_far + argRepSizeW (toArgRep rep), + = (wds_so_far + argRepSizeW dflags (toArgRep rep), (NonVoid thing, hdr_size + wds_so_far)) mkVirtConstrOffsets :: DynFlags -> [(PrimRep,a)] -> (WordOff, WordOff, [(NonVoid a, VirtualHpOffset)]) @@ -462,19 +464,20 @@ mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False #include "../includes/rts/storage/FunTypes.h" mkArgDescr :: Name -> [Id] -> FCode ArgDescr -mkArgDescr _nm args - = case stdPattern arg_reps of - Just spec_id -> return (ArgSpec spec_id) - Nothing -> return (ArgGen arg_bits) - where - arg_bits = argBits arg_reps - arg_reps = filter isNonV (map idArgRep args) - -- Getting rid of voids eases matching of standard patterns - -argBits :: [ArgRep] -> [Bool] -- True for non-ptr, False for ptr -argBits [] = [] -argBits (P : args) = False : argBits args -argBits (arg : args) = take (argRepSizeW arg) (repeat True) ++ argBits args +mkArgDescr _nm args + = do dflags <- getDynFlags + let arg_bits = argBits dflags arg_reps + arg_reps = filter isNonV (map idArgRep args) + -- Getting rid of voids eases matching of standard patterns + case stdPattern arg_reps of + Just spec_id -> return (ArgSpec spec_id) + Nothing -> return (ArgGen arg_bits) + +argBits :: DynFlags -> [ArgRep] -> [Bool] -- True for non-ptr, False for ptr +argBits _ [] = [] +argBits dflags (P : args) = False : argBits dflags args +argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True) + ++ argBits dflags args ---------------------- stdPattern :: [ArgRep] -> Maybe StgHalfWord @@ -527,13 +530,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 @@ -571,7 +573,7 @@ stdInfoTableSizeW dflags | otherwise = 0 stdInfoTableSizeB :: DynFlags -> ByteOff -stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE :: ByteOff +stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags stdSrtBitmapOffset :: DynFlags -> ByteOff -- Byte offset of the SRT bitmap half-word which is @@ -580,11 +582,11 @@ stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE stdClosureTypeOffset :: DynFlags -> ByteOff -- Byte offset of the closure type half-word -stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE +stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff -stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2*wORD_SIZE -stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2*wORD_SIZE + hALF_WORD_SIZE +stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags +stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE ------------------------------------------------------------------------- -- @@ -592,16 +594,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 +611,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 +640,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 +662,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 2290914310..fb290d8e96 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -39,8 +39,7 @@ module StgCmmMonad ( Sequel(..), ReturnKind(..), withSequel, getSequel, - setSRTLabel, getSRTLabel, - setTickyCtrLabel, getTickyCtrLabel, + setTickyCtrLabel, getTickyCtrLabel, withUpdFrameOff, getUpdFrameOff, initUpdFrameOff, @@ -155,8 +154,7 @@ data CgInfoDownwards -- information only passed *downwards* by the monad cgd_dflags :: DynFlags, cgd_mod :: Module, -- Module being compiled cgd_statics :: CgBindings, -- [Id -> info] : static environment - cgd_srt_lbl :: CLabel, -- Label of the current top-level SRT - cgd_updfr_off :: UpdFrameOffset, -- Size of current update frame + cgd_updfr_off :: UpdFrameOffset, -- Size of current update frame cgd_ticky :: CLabel, -- Current destination for ticky counts cgd_sequel :: Sequel -- What to do at end of basic block } @@ -285,16 +283,15 @@ initCgInfoDown dflags mod = MkCgInfoDown { cgd_dflags = dflags, cgd_mod = mod, cgd_statics = emptyVarEnv, - cgd_srt_lbl = error "initC: srt_lbl", - 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 -------------------------------------------------------- @@ -472,22 +469,6 @@ getSequel = do { info <- getInfoDown ; return (cgd_sequel info) } -- ---------------------------------------------------------------------------- --- Get/set the current SRT label - --- There is just one SRT for each top level binding; all the nested --- bindings use sub-sections of this SRT. The label is passed down to --- the nested bindings via the monad. - -getSRTLabel :: FCode CLabel -- Used only by cgPanic -getSRTLabel = do info <- getInfoDown - return (cgd_srt_lbl info) - -setSRTLabel :: CLabel -> FCode a -> FCode a -setSRTLabel srt_lbl code - = do info <- getInfoDown - withInfoDown code (info { cgd_srt_lbl = srt_lbl}) - --- ---------------------------------------------------------------------------- -- Get/set the size of the update frame -- We keep track of the size of the update frame so that we @@ -537,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 @@ -553,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) @@ -699,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 d9585c6d61..cbb2aa70bd 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -42,13 +42,13 @@ import CLabel import CmmUtils import PrimOp import SMRep -import Constants import Module import FastString import Outputable import Util import Control.Monad (liftM) +import Data.Bits ------------------------------------------------------------------------ -- Primitive operations and foreign calls @@ -80,10 +80,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 @@ -103,7 +104,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)] @@ -115,10 +117,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 @@ -136,15 +139,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 () @@ -152,7 +157,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 @@ -174,19 +179,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)] ], - CmmLit (mkIntCLit (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)); \ @@ -197,19 +202,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)] ], - CmmLit (mkIntCLit (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. @@ -218,37 +223,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)) @@ -256,53 +258,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 @@ -314,215 +310,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 w W8 -emitPrimOp [res] PopCnt16Op [w] = emitPopCntCall res w W16 -emitPrimOp [res] PopCnt32Op [w] = emitPopCntCall res w W32 -emitPrimOp [res] PopCnt64Op [w] = emitPopCntCall res w W64 -emitPrimOp [res] PopCntOp [w] = emitPopCntCall res w wordWidth +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 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 @@ -531,19 +530,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) @@ -557,37 +556,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 <*> @@ -620,12 +619,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)), @@ -637,25 +645,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)), @@ -675,16 +686,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 @@ -711,125 +712,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. @@ -884,7 +885,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 () @@ -908,42 +909,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, - CmmLit (mkIntCLit 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 dflags + 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 @@ -962,7 +966,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 (CmmLit (mkIntCLit 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 @@ -977,11 +982,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 (CmmLit (mkIntCLit 1)), - getCode $ emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit 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 ()) @@ -989,8 +995,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 -- ---------------------------------------------------------------------------- @@ -1003,8 +1009,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 (CmmLit (mkIntCLit 1)) + p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off + emitMemsetCall p c len (mkIntExpr dflags 1) -- ---------------------------------------------------------------------------- -- Copying pointer arrays @@ -1034,7 +1040,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 (CmmLit (mkIntCLit wORD_SIZE)) + do dflags <- getDynFlags + emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags (wORD_SIZE dflags)) -- | Takes a source 'MutableArray#', an offset in the source array, a @@ -1049,11 +1056,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 (CmmLit (mkIntCLit wORD_SIZE)), - getCode $ emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) + getCode $ emitMemmoveCall dst_p src_p bytes (mkIntExpr dflags (wORD_SIZE dflags)), + getCode $ emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags (wORD_SIZE dflags)) ] - emit =<< mkCmmIfThenElse (cmmEqWord src dst) moveCall cpyCall + emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()) @@ -1071,15 +1079,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 (CmmLit (mkIntCLit 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 dflags)) 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 @@ -1090,62 +1098,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 dflags)) + 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_words <- assignTempE $ (n `cmmUShrWord` - (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))) - `cmmAddWord` CmmLit (mkIntCLit 1) - size <- assignTempE $ n `cmmAddWord` card_words - 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 (CmmLit (mkIntCLit (arrPtrsHdrSize dflags))) (n `cmmMulWord` wordSize) - (CmmLit $ mkIntCLit 0) + 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 dflags + + oFFSET_StgMutArrPtrs_ptrs dflags)) n + emit $ mkStore (cmmOffsetB dflags arr (fixedHdrSize dflags * wORD_SIZE dflags + + 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) (CmmLit (mkIntCLit wORD_SIZE)) + emitMemcpyCall dst_p src_p (cmmMulWord dflags n (wordSize dflags)) (mkIntExpr dflags (wORD_SIZE dflags)) - emitMemsetCall (cmmOffsetExprW dst_p n) - (CmmLit (mkIntCLit 1)) - (card_words `cmmMulWord` wordSize) - (CmmLit (mkIntCLit wORD_SIZE)) + emitMemsetCall (cmmOffsetExprW dflags dst_p n) + (mkIntExpr dflags 1) + card_bytes + (mkIntExpr dflags (wORD_SIZE dflags)) emit $ mkAssign (CmmLocal res_r) arr - where - arrPtrsHdrSizeW dflags = CmmLit $ mkIntCLit $ fixedHdrSize dflags + - (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE) - wordSize = CmmLit (mkIntCLit 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 -> FCode () emitSetCards dst_start dst_cards_start n = do - start_card <- assignTempE $ card dst_start - emitMemsetCall (dst_cards_start `cmmAddWord` start_card) - (CmmLit (mkIntCLit 1)) - ((card (dst_start `cmmAddWord` n) `cmmSubWord` start_card) - `cmmAddWord` CmmLit (mkIntCLit 1)) - (CmmLit (mkIntCLit wORD_SIZE)) - where - -- Convert an element index to a card index - card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)) + 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 :: 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 :: DynFlags -> CmmExpr -> CmmExpr +cardRoundUp dflags i = card dflags (cmmAddWord dflags i (mkIntExpr dflags ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS dflags) - 1))) + +bytesToWordsRoundUp :: DynFlags -> CmmExpr -> CmmExpr +bytesToWordsRoundUp dflags e = cmmQuotWord dflags (cmmAddWord dflags e (mkIntExpr dflags (wORD_SIZE dflags - 1))) + (wordSize dflags) + +wordSize :: DynFlags -> CmmExpr +wordSize dflags = mkIntExpr dflags (wORD_SIZE dflags) -- | Emit a call to @memcpy@. emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index 56c02d040f..e6e9899040 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -54,7 +54,6 @@ import CostCentre import DynFlags import FastString import Module -import Constants -- Lots of field offsets import Outputable import Control.Monad @@ -67,10 +66,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 +84,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 +144,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 +165,7 @@ profDynAlloc :: SMRep -> CmmExpr -> FCode () profDynAlloc rep ccs = ifProfiling $ do dflags <- getDynFlags - profAlloc (CmmLit (mkIntCLit (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 +175,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, - CmmLit (mkIntCLit (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 +189,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,58 +231,58 @@ 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 dflags - 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 -sizeof_ccs_words :: Int -sizeof_ccs_words +sizeof_ccs_words :: DynFlags -> Int +sizeof_ccs_words dflags -- round up to the next word. | ms == 0 = ws | otherwise = ws + 1 where - (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE + (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE dflags -- --------------------------------------------------------------------------- -- Set the current cost centre stack @@ -288,9 +292,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 +305,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 +319,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, CmmLit (mkIntCLit 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 +346,37 @@ ldvRecordCreate closure = emit $ mkStore (ldvWord closure) dynLdvInit -- profiling. -- ldvEnterClosure :: ClosureInfo -> FCode () -ldvEnterClosure closure_info = ldvEnter (cmmOffsetB (CmmReg nodeReg) (-tag)) - where tag = funTag closure_info +ldvEnterClosure closure_info = do dflags <- getDynFlags + let tag = funTag dflags closure_info + ldvEnter (cmmOffsetB dflags (CmmReg nodeReg) (-tag)) -- 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 ec8f674555..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, - CmmLit (mkIntCLit 0)] + 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)) - (CmmLit (mkIntCLit 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 @@ -332,8 +334,8 @@ tickyAllocHeap hp ifTicky :: FCode () -> FCode () ifTicky code = do dflags <- getDynFlags - if doingTickyProfiling dflags then code - else nopC + if dopt Opt_Ticky dflags then code + else nopC -- All the ticky-ticky counters are declared "unsigned long" in C bumpTickyCounter :: FastString -> FCode () diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 100d821cb0..4471b78151 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -57,7 +57,6 @@ import ForeignCall import IdInfo import Type import TyCon -import Constants import SMRep import Module import Literal @@ -68,7 +67,6 @@ import Unique import DynFlags import FastString import Outputable -import Platform import Data.Char import Data.List @@ -86,31 +84,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,14 +141,15 @@ 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)) - (wORD_SIZE*offset - tag)) + (CmmLoad (cmmOffsetB dflags + (CmmReg (CmmLocal base)) + (wORD_SIZE dflags * offset - tag)) (localRegType reg)) ------------------------------------------------------------------------- @@ -159,9 +159,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 +251,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 +266,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 +344,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 +361,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 +372,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 +425,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 +513,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 (CmmLit (mkIntCLit 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 +534,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 +545,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 (CmmLit (mkIntCLit 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 (CmmLit (mkIntCLit 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 (CmmLit (mkIntCLit 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 +655,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 +677,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 +714,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/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs index d05da2a420..21037088e1 100644 --- a/compiler/coreSyn/MkExternalCore.lhs +++ b/compiler/coreSyn/MkExternalCore.lhs @@ -229,7 +229,8 @@ make_lit dflags l = MachWord64 i -> C.Lint i t MachFloat r -> C.Lrational r t MachDouble r -> C.Lrational r t - _ -> error "MkExternalCore died: make_lit" + LitInteger i _ -> C.Lint i t + _ -> pprPanic "MkExternalCore died: make_lit" (ppr l) where t = make_ty dflags (literalType l) diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 34500bb109..493ff0c13e 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -23,7 +23,6 @@ import VarSet import Data.List import FastString import HscTypes -import StaticFlags import TyCon import Unique import BasicTypes @@ -91,7 +90,7 @@ addTicksToBinds dflags mod mod_loc exports tyCons binds = , this_mod = mod , tickishType = case hscTarget dflags of HscInterpreted -> Breakpoints - _ | opt_Hpc -> HpcTicks + _ | dopt Opt_Hpc dflags -> HpcTicks | dopt Opt_SccProfilingOn dflags -> ProfNotes | otherwise -> error "addTicksToBinds: No way to annotate!" @@ -105,7 +104,7 @@ addTicksToBinds dflags mod mod_loc exports tyCons binds = let count = tickBoxCount st hashNo <- writeMixEntries dflags mod count entries orig_file2 - modBreaks <- mkModBreaks count entries + modBreaks <- mkModBreaks dflags count entries doIfSet_dyn dflags Opt_D_dump_ticked $ log_action dflags dflags SevDump noSrcSpan defaultDumpStyle @@ -127,9 +126,9 @@ guessSourceFile binds orig_file = _ -> orig_file -mkModBreaks :: Int -> [MixEntry_] -> IO ModBreaks -mkModBreaks count entries = do - breakArray <- newBreakArray $ length entries +mkModBreaks :: DynFlags -> Int -> [MixEntry_] -> IO ModBreaks +mkModBreaks dflags count entries = do + breakArray <- newBreakArray dflags $ length entries let locsTicks = listArray (0,count-1) [ span | (span,_,_,_) <- entries ] varsTicks = listArray (0,count-1) [ vars | (_,_,vars,_) <- entries ] @@ -146,7 +145,7 @@ mkModBreaks count entries = do writeMixEntries :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int writeMixEntries dflags mod count entries filename - | not opt_Hpc = return 0 + | not (dopt Opt_Hpc dflags) = return 0 | otherwise = do let hpc_dir = hpcDir dflags @@ -184,7 +183,7 @@ data TickDensity mkDensity :: DynFlags -> TickDensity mkDensity dflags - | opt_Hpc = TickForCoverage + | dopt Opt_Hpc dflags = TickForCoverage | HscInterpreted <- hscTarget dflags = TickForBreakPoints | ProfAutoAll <- profAuto dflags = TickAllFunctions | ProfAutoTop <- profAuto dflags = TickTopFunctions diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 5d0e83f1f6..ee606808d9 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -16,7 +16,6 @@ The Desugarer: turning HsSyn into Core. module Desugar ( deSugar, deSugarExpr ) where import DynFlags -import StaticFlags import HscTypes import HsSyn import TcRnTypes @@ -109,7 +108,7 @@ deSugar hsc_env Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks)) _ -> do - let want_ticks = opt_Hpc + let want_ticks = dopt Opt_Hpc dflags || target == HscInterpreted || (dopt Opt_SccProfilingOn dflags && case profAuto dflags of @@ -130,7 +129,7 @@ deSugar hsc_env ; ds_rules <- mapMaybeM dsRule rules ; ds_vects <- mapM dsVect vects ; let hpc_init - | opt_Hpc = hpcInitCode mod ds_hpc_info + | dopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info | otherwise = empty ; return ( ds_ev_binds , foreign_prs `appOL` core_prs `appOL` spec_prs diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs index a2459f5a4c..e02ef7b385 100644 --- a/compiler/deSugar/DsCCall.lhs +++ b/compiler/deSugar/DsCCall.lhs @@ -47,7 +47,6 @@ import BasicTypes import Literal import PrelNames import VarSet -import Constants import DynFlags import Outputable import Util @@ -357,9 +356,10 @@ resultWrapper result_ty -- This includes types like Ptr and ForeignPtr | Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty, dataConSourceArity data_con == 1 - = do let + = do dflags <- getDynFlags + let (unwrapped_res_ty : _) = data_con_arg_tys - narrow_wrapper = maybeNarrow tycon + narrow_wrapper = maybeNarrow dflags tycon (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty return (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con)) @@ -375,16 +375,16 @@ resultWrapper result_ty -- standard appears to say that this is the responsibility of the -- caller, not the callee. -maybeNarrow :: TyCon -> (CoreExpr -> CoreExpr) -maybeNarrow tycon +maybeNarrow :: DynFlags -> TyCon -> (CoreExpr -> CoreExpr) +maybeNarrow dflags tycon | tycon `hasKey` int8TyConKey = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e | tycon `hasKey` int16TyConKey = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e | tycon `hasKey` int32TyConKey - && wORD_SIZE > 4 = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e + && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e | tycon `hasKey` word8TyConKey = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e | tycon `hasKey` word32TyConKey - && wORD_SIZE > 4 = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e + && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e | otherwise = id \end{code} diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index e1c0e30a58..cc6b6afada 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -44,7 +44,6 @@ import FastString import DynFlags import Platform import Config -import Constants import OrdList import Pair import Util @@ -141,6 +140,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 +152,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 +166,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 +519,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 @@ -532,10 +532,10 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc type_string -- libffi needs to know the result type too: - | libffi = primTyDescChar res_hty : arg_type_string + | libffi = primTyDescChar dflags res_hty : arg_type_string | otherwise = arg_type_string - arg_type_string = [primTyDescChar ty | (_,_,ty,_) <- arg_info] + arg_type_string = [primTyDescChar dflags ty | (_,_,ty,_) <- arg_info] -- just the real args -- add some auxiliary args; the stable ptr in the wrapper case, and @@ -546,7 +546,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 +735,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 +746,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#). @@ -781,8 +781,8 @@ getPrimTyOf ty -- represent a primitive type as a Char, for building a string that -- described the foreign function type. The types are size-dependent, -- e.g. 'W' is a signed 32-bit integer. -primTyDescChar :: Type -> Char -primTyDescChar ty +primTyDescChar :: DynFlags -> Type -> Char +primTyDescChar dflags ty | ty `eqType` unitTy = 'v' | otherwise = case typePrimRep (getPrimTyOf ty) of @@ -796,7 +796,7 @@ primTyDescChar ty _ -> pprPanic "primTyDescChar" (ppr ty) where (signed_word, unsigned_word) - | wORD_SIZE == 4 = ('W','w') - | wORD_SIZE == 8 = ('L','l') - | otherwise = panic "primTyDescChar" + | wORD_SIZE dflags == 4 = ('W','w') + | wORD_SIZE dflags == 8 = ('L','l') + | otherwise = panic "primTyDescChar" \end{code} 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 be2b631617..f65813dd94 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -452,18 +452,6 @@ compiler_stage1_HC_OPTS += $(GhcStage1HcOpts) compiler_stage2_HC_OPTS += $(GhcStage2HcOpts) compiler_stage3_HC_OPTS += $(GhcStage3HcOpts) -ifeq "$(GhcStage1DefaultNewCodegen)" "YES" -compiler_stage1_HC_OPTS += -DGHC_DEFAULT_NEW_CODEGEN -endif - -ifeq "$(GhcStage2DefaultNewCodegen)" "YES" -compiler_stage2_HC_OPTS += -DGHC_DEFAULT_NEW_CODEGEN -endif - -ifeq "$(GhcStage3DefaultNewCodegen)" "YES" -compiler_stage3_HC_OPTS += -DGHC_DEFAULT_NEW_CODEGEN -endif - ifneq "$(BINDIST)" "YES" compiler_stage2_TAGS_HC_OPTS = -package ghc @@ -473,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..15c41d044e 100644 --- a/compiler/ghci/ByteCodeAsm.lhs +++ b/compiler/ghci/ByteCodeAsm.lhs @@ -27,7 +27,6 @@ import NameSet import Literal import TyCon import PrimOp -import Constants import FastString import SMRep import ClosureInfo -- CgRep stuff @@ -133,7 +132,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 +142,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 +153,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 +249,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 +272,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 +289,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 +306,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 +316,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 @@ -432,9 +431,9 @@ assembleI dflags i = case i of litlabel fs = lit [BCONPtrLbl fs] addr = words . mkLitPtr float = words . mkLitF - double = words . mkLitD + double = words . mkLitD dflags int = words . mkLitI - int64 = words . mkLitI64 + int64 = words . mkLitI64 dflags words ws = lit (map BCONPtrWord ws) word w = words [w] @@ -460,11 +459,11 @@ return_ubx PtrArg = bci_RETURN_P -- Make lists of host-sized words for literals, so that when the -- words are placed in memory at increasing addresses, the -- bit pattern is correct for the host's word size and endianness. -mkLitI :: Int -> [Word] -mkLitF :: Float -> [Word] -mkLitD :: Double -> [Word] -mkLitPtr :: Ptr () -> [Word] -mkLitI64 :: Int64 -> [Word] +mkLitI :: Int -> [Word] +mkLitF :: Float -> [Word] +mkLitD :: DynFlags -> Double -> [Word] +mkLitPtr :: Ptr () -> [Word] +mkLitI64 :: DynFlags -> Int64 -> [Word] mkLitF f = runST (do @@ -475,8 +474,8 @@ mkLitF f return [w0 :: Word] ) -mkLitD d - | wORD_SIZE == 4 +mkLitD dflags d + | wORD_SIZE dflags == 4 = runST (do arr <- newArray_ ((0::Int),1) writeArray arr 0 d @@ -485,7 +484,7 @@ mkLitD d w1 <- readArray d_arr 1 return [w0 :: Word, w1] ) - | wORD_SIZE == 8 + | wORD_SIZE dflags == 8 = runST (do arr <- newArray_ ((0::Int),0) writeArray arr 0 d @@ -496,8 +495,8 @@ mkLitD d | otherwise = panic "mkLitD: Bad wORD_SIZE" -mkLitI64 ii - | wORD_SIZE == 4 +mkLitI64 dflags ii + | wORD_SIZE dflags == 4 = runST (do arr <- newArray_ ((0::Int),1) writeArray arr 0 ii @@ -506,7 +505,7 @@ mkLitI64 ii w1 <- readArray d_arr 1 return [w0 :: Word,w1] ) - | wORD_SIZE == 8 + | wORD_SIZE dflags == 8 = runST (do arr <- newArray_ ((0::Int),0) writeArray arr 0 ii diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index b277a1ed30..af7a06876d 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -22,7 +22,9 @@ import ByteCodeAsm import ByteCodeLink import LibFFI +import DynFlags import Outputable +import Platform import Name import MkId import Id @@ -40,7 +42,6 @@ import TyCon import Util import VarSet import TysPrim -import DynFlags import ErrUtils import Unique import FastString @@ -49,7 +50,6 @@ import SMRep import ClosureInfo import Bitmap import OrdList -import Constants import Data.List import Foreign @@ -152,7 +152,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,7 +162,7 @@ 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, @@ -180,7 +181,7 @@ mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_bloc -- (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 + | 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). @@ -206,11 +207,11 @@ mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_bloc peep [] = [] -argBits :: [CgRep] -> [Bool] -argBits [] = [] -argBits (rep : args) - | isFollowableArg rep = False : argBits args - | otherwise = take (cgRepSizeW rep) (repeat True) ++ argBits args +argBits :: DynFlags -> [CgRep] -> [Bool] +argBits _ [] = [] +argBits dflags (rep : args) + | isFollowableArg rep = False : argBits dflags args + | otherwise = take (cgRepSizeW dflags rep) (repeat True) ++ argBits dflags args -- ----------------------------------------------------------------------------- -- schemeTopBind @@ -223,6 +224,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 +233,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,25 +283,26 @@ 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 -- \fv1..fvn x1..xn -> e -- i.e. the fvs come first - szsw_args = map (fromIntegral . idSizeW) all_args + szsw_args = map (fromIntegral . idSizeW dflags) all_args szw_args = sum szsw_args p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsw_args)) -- make the arg bitmap - bits = argBits (reverse (map idCgRep all_args)) + bits = argBits dflags (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 @@ -396,15 +399,16 @@ schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body)) -- General case for let. Generates correct, if inefficient, code in -- all situations. -schemeE d s p (AnnLet binds (_,body)) - = let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs]) +schemeE d s p (AnnLet binds (_,body)) = do + dflags <- getDynFlags + let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs]) AnnRec xs_n_rhss -> unzip xs_n_rhss n_binds = genericLength xs fvss = map (fvsToEnv p' . fst) rhss -- Sizes of free vars - sizes = map (\rhs_fvs -> sum (map (fromIntegral . idSizeW) rhs_fvs)) fvss + sizes = map (\rhs_fvs -> sum (map (fromIntegral . idSizeW dflags) rhs_fvs)) fvss -- the arity of each rhs arities = map (genericLength . fst . collect) rhss @@ -447,7 +451,6 @@ schemeE d s p (AnnLet binds (_,body)) | (fvs, x, rhs, size, arity, n) <- zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1] ] - in do body_code <- schemeE d' s p' body thunk_codes <- sequence compile_binds return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code) @@ -772,7 +775,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 @@ -787,7 +792,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple | otherwise = 1 -- depth of stack after the return value has been pushed - d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW bndr) + d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW dflags bndr) -- depth of stack after the extra info table for an unboxed return -- has been pushed, if any. This is the stack depth at the @@ -821,8 +826,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple | otherwise = let (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs - ptr_sizes = map (fromIntegral . idSizeW) ptrs - nptrs_sizes = map (fromIntegral . idSizeW) nptrs + ptr_sizes = map (fromIntegral . idSizeW dflags) ptrs + nptrs_sizes = map (fromIntegral . idSizeW dflags) nptrs bind_sizes = ptr_sizes ++ nptrs_sizes size = sum ptr_sizes + sum nptrs_sizes -- the UNPACK instruction unpacks in reverse order... @@ -875,7 +880,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 +891,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 @@ -923,10 +927,13 @@ generateCCall :: Word -> Sequel -- stack and sequel depths -> BcM BCInstrList generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l - = let + = do + dflags <- getDynFlags + + let -- useful constants addr_sizeW :: Word16 - addr_sizeW = fromIntegral (cgRepSizeW NonPtrArg) + addr_sizeW = fromIntegral (cgRepSizeW dflags NonPtrArg) -- Get the args on the stack, with tags and suitably -- dereferenced for the CCall. For each arg, return the @@ -942,14 +949,12 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l -- contains. Just t | t == arrayPrimTyCon || t == mutableArrayPrimTyCon - -> do dflags <- getDynFlags - rest <- pargs (d + fromIntegral addr_sizeW) az + -> do rest <- pargs (d + fromIntegral addr_sizeW) az code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize dflags)) d p a return ((code,AddrRep):rest) | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon - -> do dflags <- getDynFlags - rest <- pargs (d + fromIntegral addr_sizeW) az + -> do rest <- pargs (d + fromIntegral addr_sizeW) az code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a return ((code,AddrRep):rest) @@ -970,11 +975,10 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l -- header and then pretend this is an Addr#. return (push_fo `snocOL` SWIZZLE 0 hdrSize) - in do code_n_reps <- pargs d0 args_r_to_l let (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps - a_reps_sizeW = fromIntegral (sum (map primRepSizeW a_reps_pushed_r_to_l)) + a_reps_sizeW = fromIntegral (sum (map (primRepSizeW dflags) a_reps_pushed_r_to_l)) push_args = concatOL pushs_arg d_after_args = d0 + a_reps_sizeW @@ -1029,8 +1033,8 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l void marshall_code ( StgWord* ptr_to_top_of_stack ) -} -- resolve static address - get_target_info - = case target of + get_target_info = do + case target of DynamicTarget -> return (False, panic "ByteCodeGen.generateCCall(dyn)") @@ -1041,11 +1045,10 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l return (True, res) where stdcall_adj_target -#ifdef mingw32_TARGET_OS - | StdCallConv <- cconv - = let size = fromIntegral a_reps_sizeW * wORD_SIZE in + | OSMinGW32 <- platformOS (targetPlatform dflags) + , StdCallConv <- cconv + = let size = fromIntegral a_reps_sizeW * wORD_SIZE dflags in mkFastString (unpackFS target ++ '@':show size) -#endif | otherwise = target @@ -1069,7 +1072,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l -- Push the return placeholder. For a call returning nothing, -- this is a VoidArg (tag). - r_sizeW = fromIntegral (primRepSizeW r_rep) + r_sizeW = fromIntegral (primRepSizeW dflags r_rep) d_after_r = d_after_Addr + fromIntegral r_sizeW r_lit = mkDummyLiteral r_rep push_r = (if returns_void @@ -1087,7 +1090,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l -- the only difference in libffi mode is that we prepare a cif -- describing the call type by calling libffi, and we attach the -- address of this to the CCALL instruction. - token <- ioToBc $ prepForeignCall cconv a_reps r_rep + token <- ioToBc $ prepForeignCall dflags cconv a_reps r_rep let addr_of_marshaller = castPtrToFunPtr token recordItblMallocBc (ItblPtr (castFunPtrToPtr addr_of_marshaller)) @@ -1214,8 +1217,11 @@ pushAtom d p (AnnVar v) = return (unitOL (PUSH_PRIMOP primop), 1) | Just d_v <- lookupBCEnv_maybe v p -- v is a local variable - = let l = trunc16 $ d - d_v + fromIntegral sz - 2 - in return (toOL (genericReplicate sz (PUSH_L l)), sz) + = do dflags <- getDynFlags + let sz :: Word16 + sz = fromIntegral (idSizeW dflags v) + l = trunc16 $ d - d_v + fromIntegral sz - 2 + return (toOL (genericReplicate sz (PUSH_L l)), sz) -- d - d_v the number of words between the TOS -- and the 1st slot of the object -- @@ -1227,17 +1233,22 @@ pushAtom d p (AnnVar v) -- Having found the last slot, we proceed to copy the right number of -- slots on to the top of the stack. - | otherwise -- v must be a global variable - = ASSERT(sz == 1) - return (unitOL (PUSH_G (getName v)), sz) + | otherwise -- v must be a global variable + = do dflags <- getDynFlags + let sz :: Word16 + sz = fromIntegral (idSizeW dflags v) + MASSERT(sz == 1) + return (unitOL (PUSH_G (getName v)), sz) - where - sz :: Word16 - sz = fromIntegral (idSizeW v) +pushAtom _ _ (AnnLit lit) = do + dflags <- getDynFlags + let code rep + = let size_host_words = fromIntegral (cgRepSizeW dflags rep) + in return (unitOL (PUSH_UBX (Left lit) size_host_words), + size_host_words) -pushAtom _ _ (AnnLit lit) - = case lit of + case lit of MachLabel _ _ _ -> code NonPtrArg MachWord _ -> code NonPtrArg MachInt _ -> code NonPtrArg @@ -1253,11 +1264,6 @@ pushAtom _ _ (AnnLit lit) -- representation. LitInteger {} -> panic "pushAtom: LitInteger" where - code rep - = let size_host_words = fromIntegral (cgRepSizeW rep) - in return (unitOL (PUSH_UBX (Left lit) size_host_words), - size_host_words) - pushStr s = let getMallocvilleAddr = case s of @@ -1430,8 +1436,8 @@ instance Outputable Discr where lookupBCEnv_maybe :: Id -> BCEnv -> Maybe Word lookupBCEnv_maybe = Map.lookup -idSizeW :: Id -> Int -idSizeW = cgRepSizeW . bcIdCgRep +idSizeW :: DynFlags -> Id -> Int +idSizeW dflags = cgRepSizeW dflags . bcIdCgRep bcIdCgRep :: Id -> CgRep bcIdCgRep = primRepToCgRep . bcIdPrimRep diff --git a/compiler/ghci/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs index 9b22ec8cd6..2564d4b797 100644 --- a/compiler/ghci/ByteCodeItbls.lhs +++ b/compiler/ghci/ByteCodeItbls.lhs @@ -27,7 +27,6 @@ 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 CgHeapery ( mkVirtHeapOffsets ) import Util @@ -49,14 +48,14 @@ import GHC.Ptr ( Ptr(..) ) \begin{code} newtype ItblPtr = ItblPtr (Ptr ()) deriving Show -itblCode :: ItblPtr -> Ptr () -itblCode (ItblPtr ptr) - | ghciTablesNextToCode = castPtr ptr `plusPtr` conInfoTableSizeB +itblCode :: DynFlags -> ItblPtr -> Ptr () +itblCode dflags (ItblPtr ptr) + | ghciTablesNextToCode = castPtr ptr `plusPtr` conInfoTableSizeB dflags | otherwise = castPtr ptr -- XXX bogus -conInfoTableSizeB :: Int -conInfoTableSizeB = 3 * wORD_SIZE +conInfoTableSizeB :: DynFlags -> Int +conInfoTableSizeB dflags = 3 * wORD_SIZE dflags type ItblEnv = NameEnv (Name, ItblPtr) -- We need the Name in the range so we know which @@ -106,8 +105,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 @@ -128,7 +127,7 @@ make_constr_itbls dflags cons } -- Make a piece of code to jump to "entry_label". -- This is the only arch-dependent bit. - addrCon <- newExec pokeConItbl conInfoTbl + addrCon <- newExecConItbl dflags conInfoTbl --putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl)) --putStrLn ("# ptrs of itbl is " ++ show ptrs) --putStrLn ("# nptrs of itbl is " ++ show nptrs_really) @@ -285,39 +284,17 @@ data StgConInfoTable = StgConInfoTable { infoTable :: StgInfoTable } -instance Storable StgConInfoTable where - sizeOf conInfoTable +sizeOfConItbl :: StgConInfoTable -> Int +sizeOfConItbl conInfoTable = sum [ sizeOf (conDesc conInfoTable) , sizeOf (infoTable conInfoTable) ] - alignment _ = SIZEOF_VOID_P - peek ptr - = evalState (castPtr ptr) $ do -#ifdef GHCI_TABLES_NEXT_TO_CODE - desc <- load -#endif - itbl <- load -#ifndef GHCI_TABLES_NEXT_TO_CODE - desc <- load -#endif - return - StgConInfoTable - { -#ifdef GHCI_TABLES_NEXT_TO_CODE - conDesc = castPtr $ ptr `plusPtr` conInfoTableSizeB `plusPtr` desc -#else - conDesc = desc -#endif - , infoTable = itbl - } - poke = error "poke(StgConInfoTable): use pokeConItbl instead" - -pokeConItbl :: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable +pokeConItbl :: DynFlags -> Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable -> IO () -pokeConItbl wr_ptr ex_ptr itbl +pokeConItbl dflags wr_ptr ex_ptr itbl = evalState (castPtr wr_ptr) $ do #ifdef GHCI_TABLES_NEXT_TO_CODE - store (conDesc itbl `minusPtr` (ex_ptr `plusPtr` conInfoTableSizeB)) + store (conDesc itbl `minusPtr` (ex_ptr `plusPtr` conInfoTableSizeB dflags)) #endif store (infoTable itbl) #ifndef GHCI_TABLES_NEXT_TO_CODE @@ -443,12 +420,12 @@ load = do addr <- advance lift (peek addr) -newExec :: Storable a => (Ptr a -> Ptr a -> a -> IO ()) -> a -> IO (FunPtr ()) -newExec poke_fn obj +newExecConItbl :: DynFlags -> StgConInfoTable -> IO (FunPtr ()) +newExecConItbl dflags obj = alloca $ \pcode -> do - wr_ptr <- _allocateExec (fromIntegral (sizeOf obj)) pcode + wr_ptr <- _allocateExec (fromIntegral (sizeOfConItbl obj)) pcode ex_ptr <- peek pcode - poke_fn wr_ptr ex_ptr obj + pokeConItbl dflags wr_ptr ex_ptr obj return (castPtrToFunPtr ex_ptr) foreign import ccall unsafe "allocateExec" diff --git a/compiler/ghci/ByteCodeLink.lhs b/compiler/ghci/ByteCodeLink.lhs index 8ceb91cfce..8938bfe4f1 100644 --- a/compiler/ghci/ByteCodeLink.lhs +++ b/compiler/ghci/ByteCodeLink.lhs @@ -20,6 +20,7 @@ import ByteCodeItbls import ByteCodeAsm import ObjLink +import DynFlags import Name import NameEnv import PrimOp @@ -76,9 +77,9 @@ data BCO# = BCO# ByteArray# -- instrs :: Array Word16# ByteArray# -- itbls :: Array Addr# -} -linkBCO :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO HValue -linkBCO ie ce ul_bco - = do BCO bco# <- linkBCO' ie ce ul_bco +linkBCO :: DynFlags -> ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO HValue +linkBCO dflags ie ce ul_bco + = do BCO bco# <- linkBCO' dflags ie ce ul_bco -- SDM: Why do we need mkApUpd0 here? I *think* it's because -- otherwise top-level interpreted CAFs don't get updated -- after evaluation. A top-level BCO will evaluate itself and @@ -97,18 +98,18 @@ linkBCO ie ce ul_bco else case mkApUpd0# bco# of { (# final_bco #) -> return (HValue final_bco) } -linkBCO' :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO -linkBCO' ie ce (UnlinkedBCO _ arity insns_barr bitmap literalsSS ptrsSS) +linkBCO' :: DynFlags -> ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO +linkBCO' dflags ie ce (UnlinkedBCO _ arity insns_barr bitmap literalsSS ptrsSS) -- Raises an IO exception on failure = do let literals = ssElts literalsSS ptrs = ssElts ptrsSS - linked_literals <- mapM (lookupLiteral ie) literals + linked_literals <- mapM (lookupLiteral dflags ie) literals let n_literals = sizeSS literalsSS n_ptrs = sizeSS ptrsSS - ptrs_arr <- mkPtrsArray ie ce n_ptrs ptrs + ptrs_arr <- mkPtrsArray dflags ie ce n_ptrs ptrs let !ptrs_parr = case ptrs_arr of Array _lo _hi _n parr -> parr @@ -126,8 +127,8 @@ linkBCO' ie ce (UnlinkedBCO _ arity insns_barr bitmap literalsSS ptrsSS) -- we recursively link any sub-BCOs while making the ptrs array -mkPtrsArray :: ItblEnv -> ClosureEnv -> Word -> [BCOPtr] -> IO (Array Word HValue) -mkPtrsArray ie ce n_ptrs ptrs = do +mkPtrsArray :: DynFlags -> ItblEnv -> ClosureEnv -> Word -> [BCOPtr] -> IO (Array Word HValue) +mkPtrsArray dflags ie ce n_ptrs ptrs = do let ptrRange = if n_ptrs > 0 then (0, n_ptrs-1) else (1, 0) marr <- newArray_ ptrRange let @@ -138,7 +139,7 @@ mkPtrsArray ie ce n_ptrs ptrs = do ptr <- lookupPrimOp op unsafeWrite marr i ptr fill (BCOPtrBCO ul_bco) i = do - BCO bco# <- linkBCO' ie ce ul_bco + BCO bco# <- linkBCO' dflags ie ce ul_bco writeArrayBCO marr i bco# fill (BCOPtrBreakInfo brkInfo) i = unsafeWrite marr i (HValue (unsafeCoerce# brkInfo)) @@ -180,12 +181,12 @@ newBCO instrs lits ptrs arity bitmap (# s1, bco #) -> (# s1, BCO bco #) -lookupLiteral :: ItblEnv -> BCONPtr -> IO Word -lookupLiteral _ (BCONPtrWord lit) = return lit -lookupLiteral _ (BCONPtrLbl sym) = do Ptr a# <- lookupStaticPtr sym - return (W# (int2Word# (addr2Int# a#))) -lookupLiteral ie (BCONPtrItbl nm) = do Ptr a# <- lookupIE ie nm - return (W# (int2Word# (addr2Int# a#))) +lookupLiteral :: DynFlags -> ItblEnv -> BCONPtr -> IO Word +lookupLiteral _ _ (BCONPtrWord lit) = return lit +lookupLiteral _ _ (BCONPtrLbl sym) = do Ptr a# <- lookupStaticPtr sym + return (W# (int2Word# (addr2Int# a#))) +lookupLiteral dflags ie (BCONPtrItbl nm) = do Ptr a# <- lookupIE dflags ie nm + return (W# (int2Word# (addr2Int# a#))) lookupStaticPtr :: FastString -> IO (Ptr ()) lookupStaticPtr addr_of_label_string @@ -218,10 +219,10 @@ lookupName ce nm (# a #) -> return (HValue a) Nothing -> linkFail "ByteCodeLink.lookupCE" sym_to_find -lookupIE :: ItblEnv -> Name -> IO (Ptr a) -lookupIE ie con_nm +lookupIE :: DynFlags -> ItblEnv -> Name -> IO (Ptr a) +lookupIE dflags ie con_nm = case lookupNameEnv ie con_nm of - Just (_, a) -> return (castPtr (itblCode a)) + Just (_, a) -> return (castPtr (itblCode dflags a)) Nothing -> do -- try looking up in the object files. let sym_to_find1 = nameToCLabel con_nm "con_info" diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs index 19a3cbb721..cd46ec311e 100644 --- a/compiler/ghci/DebuggerUtils.hs +++ b/compiler/ghci/DebuggerUtils.hs @@ -14,7 +14,6 @@ import Module import OccName import Name import Outputable -import Constants import MonadUtils () import Util @@ -95,7 +94,7 @@ dataConInfoPtrToName x = do getConDescAddress :: DynFlags -> Ptr StgInfoTable -> IO (Ptr Word8) getConDescAddress dflags ptr | ghciTablesNextToCode = do - offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE) + offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE dflags) return $ (ptr `plusPtr` stdInfoTableSizeB dflags) `plusPtr` (fromIntegral (offsetToString :: StgWord)) | otherwise = peek $ intPtrToPtr $ ptrToIntPtr ptr + fromIntegral (stdInfoTableSizeB dflags) diff --git a/compiler/ghci/LibFFI.hsc b/compiler/ghci/LibFFI.hsc index 9bdabda0c2..128197109b 100644 --- a/compiler/ghci/LibFFI.hsc +++ b/compiler/ghci/LibFFI.hsc @@ -24,7 +24,7 @@ import TyCon import ForeignCall import Panic -- import Outputable -import Constants +import DynFlags import Foreign import Foreign.C @@ -35,20 +35,21 @@ import Text.Printf type ForeignCallToken = C_ffi_cif prepForeignCall - :: CCallConv + :: DynFlags + -> CCallConv -> [PrimRep] -- arg types -> PrimRep -- result type -> IO (Ptr ForeignCallToken) -- token for making calls -- (must be freed by caller) -prepForeignCall cconv arg_types result_type +prepForeignCall dflags cconv arg_types result_type = do let n_args = length arg_types arg_arr <- mallocArray n_args - let init_arg (ty,n) = pokeElemOff arg_arr n (primRepToFFIType ty) + let init_arg (ty,n) = pokeElemOff arg_arr n (primRepToFFIType dflags ty) mapM_ init_arg (zip arg_types [0..]) cif <- mallocBytes (#const sizeof(ffi_cif)) let abi = convToABI cconv - let res_ty = primRepToFFIType result_type + let res_ty = primRepToFFIType dflags result_type r <- ffi_prep_cif cif abi (fromIntegral n_args) res_ty arg_arr if (r /= fFI_OK) then ghcError (InstallationError @@ -64,8 +65,8 @@ convToABI StdCallConv = fFI_STDCALL convToABI _ = fFI_DEFAULT_ABI -- c.f. DsForeign.primTyDescChar -primRepToFFIType :: PrimRep -> Ptr C_ffi_type -primRepToFFIType r +primRepToFFIType :: DynFlags -> PrimRep -> Ptr C_ffi_type +primRepToFFIType dflags r = case r of VoidRep -> ffi_type_void IntRep -> signed_word @@ -78,9 +79,9 @@ primRepToFFIType r _ -> panic "primRepToFFIType" where (signed_word, unsigned_word) - | wORD_SIZE == 4 = (ffi_type_sint32, ffi_type_uint32) - | wORD_SIZE == 8 = (ffi_type_sint64, ffi_type_uint64) - | otherwise = panic "primTyDescChar" + | wORD_SIZE dflags == 4 = (ffi_type_sint32, ffi_type_uint32) + | wORD_SIZE dflags == 8 = (ffi_type_sint64, ffi_type_uint64) + | otherwise = panic "primTyDescChar" data C_ffi_type diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 7a5ca901bc..565cf0b8a8 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -44,7 +44,6 @@ import BasicTypes import Outputable import Panic import Util -import StaticFlags import ErrUtils import SrcLoc import qualified Maybes @@ -264,7 +263,7 @@ showLinkerState dflags -- @-l@ options in @v_Opt_l@, -- -- d) Loading any @.o\/.dll@ files specified on the command line, now held --- in @v_Ld_inputs@, +-- in @ldInputs@, -- -- e) Loading any MacOS frameworks. -- @@ -298,7 +297,7 @@ reallyInitDynLinker dflags = ; libspecs <- mapM (locateLib dflags False lib_paths) minus_ls -- (d) Link .o files from the command-line - ; cmdline_ld_inputs <- readIORef v_Ld_inputs + ; let cmdline_ld_inputs = ldInputs dflags ; classified_ld_inputs <- mapM (classifyLdInput dflags) cmdline_ld_inputs @@ -458,7 +457,7 @@ linkExpr hsc_env span root_ul_bco ce = closure_env pls -- Link the necessary packages and linkables - ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco] + ; (_, (root_hval:_)) <- linkSomeBCOs dflags False ie ce [root_ul_bco] ; return (pls, root_hval) }}} where @@ -666,7 +665,7 @@ linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv) = do ce = closure_env pls -- Link the necessary packages and linkables - (final_gce, _) <- linkSomeBCOs False ie ce unlinkedBCOs + (final_gce, _) <- linkSomeBCOs dflags False ie ce unlinkedBCOs let pls2 = pls { closure_env = final_gce, itbl_env = ie } return (pls2, ()) --hvals) @@ -725,7 +724,7 @@ linkModules dflags pls linkables if failed ok_flag then return (pls1, Failed) else do - pls2 <- dynLinkBCOs pls1 bcos + pls2 <- dynLinkBCOs dflags pls1 bcos return (pls2, Succeeded) @@ -805,8 +804,9 @@ rmDupLinkables already ls %************************************************************************ \begin{code} -dynLinkBCOs :: PersistentLinkerState -> [Linkable] -> IO PersistentLinkerState -dynLinkBCOs pls bcos = do +dynLinkBCOs :: DynFlags -> PersistentLinkerState -> [Linkable] + -> IO PersistentLinkerState +dynLinkBCOs dflags pls bcos = do let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos pls1 = pls { bcos_loaded = bcos_loaded' } @@ -822,7 +822,7 @@ dynLinkBCOs pls bcos = do gce = closure_env pls final_ie = foldr plusNameEnv (itbl_env pls) ies - (final_gce, _linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos + (final_gce, _linked_bcos) <- linkSomeBCOs dflags True final_ie gce ul_bcos -- XXX What happens to these linked_bcos? let pls2 = pls1 { closure_env = final_gce, @@ -831,7 +831,8 @@ dynLinkBCOs pls bcos = do return pls2 -- Link a bunch of BCOs and return them + updated closure env. -linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env +linkSomeBCOs :: DynFlags + -> Bool -- False <=> add _all_ BCOs to returned closure env -- True <=> add only toplevel BCOs to closure env -> ItblEnv -> ClosureEnv @@ -841,11 +842,11 @@ linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env -- the incoming unlinked BCOs. Each gives the -- value of the corresponding unlinked BCO -linkSomeBCOs toplevs_only ie ce_in ul_bcos +linkSomeBCOs dflags toplevs_only ie ce_in ul_bcos = do let nms = map unlinkedBCOName ul_bcos hvals <- fixIO ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs) - in mapM (linkBCO ie ce_out) ul_bcos ) + in mapM (linkBCO dflags ie ce_out) ul_bcos ) let ce_all_additions = zip nms hvals ce_top_additions = filter (isExternalName.fst) ce_all_additions ce_additions = if toplevs_only then ce_top_additions diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index f06d120bc4..bf49a98a3b 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -60,7 +60,6 @@ import PrelNames import TysWiredIn import DynFlags import Outputable as Ppr -import Constants ( wORD_SIZE ) import GHC.Arr ( Array(..) ) import GHC.Exts import GHC.IO ( IO(..) ) @@ -172,8 +171,8 @@ pAP_CODE = PAP #undef AP #undef PAP -getClosureData :: a -> IO Closure -getClosureData a = +getClosureData :: DynFlags -> a -> IO Closure +getClosureData dflags a = case unpackClosure# a of (# iptr, ptrs, nptrs #) -> do let iptr' @@ -185,7 +184,7 @@ getClosureData a = -- but the Storable instance for info tables takes -- into account the extra entry pointer when -- !ghciTablesNextToCode, so we must adjust here: - Ptr iptr `plusPtr` negate wORD_SIZE + Ptr iptr `plusPtr` negate (wORD_SIZE dflags) itbl <- peek iptr' let tipe = readCType (BCI.tipe itbl) elems = fromIntegral (BCI.ptrs itbl) @@ -224,11 +223,11 @@ isThunk ThunkSelector = True isThunk AP = True isThunk _ = False -isFullyEvaluated :: a -> IO Bool -isFullyEvaluated a = do - closure <- getClosureData a +isFullyEvaluated :: DynFlags -> a -> IO Bool +isFullyEvaluated dflags a = do + closure <- getClosureData dflags a case tipe closure of - Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure) + Constr -> do are_subs_evaluated <- amapM (isFullyEvaluated dflags) (ptrs closure) return$ and are_subs_evaluated _ -> return False where amapM f = sequence . amap' f @@ -691,6 +690,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do text "Type obtained: " <> ppr (termType term)) return term where + dflags = hsc_dflags hsc_env go :: Int -> Type -> Type -> HValue -> TcM Term -- [SPJ May 11] I don't understand the difference between my_ty and old_ty @@ -699,13 +699,13 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do go 0 my_ty _old_ty a = do traceTR (text "Gave up reconstructing a term after" <> int max_depth <> text " steps") - clos <- trIO $ getClosureData a + clos <- trIO $ getClosureData dflags a return (Suspension (tipe clos) my_ty a Nothing) go max_depth my_ty old_ty a = do let monomorphic = not(isTyVarTy my_ty) -- This ^^^ is a convention. The ancestor tests for -- monomorphism and passes a type instead of a tv - clos <- trIO $ getClosureData a + clos <- trIO $ getClosureData dflags a case tipe clos of -- Thunks we may want to force t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >> @@ -818,7 +818,8 @@ extractSubTerms recurse clos = liftM thirdOf3 . go 0 (nonPtrs clos) t <- appArr (recurse ty) (ptrs clos) ptr_i return (ptr_i + 1, ws, t) _ -> do - let (ws0, ws1) = splitAt (primRepSizeW rep) ws + dflags <- getDynFlags + let (ws0, ws1) = splitAt (primRepSizeW dflags rep) ws return (ptr_i, ws1, Prim ty ws0) unboxedTupleTerm ty terms = Term ty (Right (tupleCon UnboxedTuple (length terms))) @@ -855,6 +856,8 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty) return new_ty where + dflags = hsc_dflags hsc_env + -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m () search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <> int max_depth <> text " steps") @@ -869,7 +872,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do go :: Type -> HValue -> TR [(Type, HValue)] go my_ty a = do traceTR (text "go" <+> ppr my_ty) - clos <- trIO $ getClosureData a + clos <- trIO $ getClosureData dflags a case tipe clos of Blackhole -> appArr (go my_ty) (ptrs clos) 0 -- carefully, don't eval the TSO Indirection _ -> go my_ty $! (ptrs clos ! 0) diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 965b1a96c3..a319f6ed62 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -117,7 +117,7 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do -- should be). Also, the serialisation of value of type "Bin -- a" used to depend on the word size of the machine, now they -- are always 32 bits. - if wORD_SIZE == 4 + if wORD_SIZE dflags == 4 then do _ <- Binary.get bh :: IO Word32; return () else do _ <- Binary.get bh :: IO Word64; return () @@ -168,7 +168,7 @@ writeBinIface dflags hi_path mod_iface = do -- dummy 32/64-bit field before the version/way for -- compatibility with older interface file formats. -- See Note [dummy iface field] above. - if wORD_SIZE == 4 + if wORD_SIZE dflags == 4 then Binary.put_ bh (0 :: Word32) else Binary.put_ bh (0 :: Word64) diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index bc5fc954eb..a41a9dac47 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -24,6 +24,7 @@ module IfaceSyn ( -- Misc ifaceDeclImplicitBndrs, visibleIfConDecls, + ifaceDeclFingerprints, -- Free Names freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst, @@ -51,6 +52,10 @@ import Outputable import FastString import Module import TysWiredIn ( eqTyConName ) +import Fingerprint +import Binary + +import System.IO.Unsafe infixl 3 &&& \end{code} @@ -448,6 +453,23 @@ ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ, ifaceDeclImplicitBndrs _ = [] +-- ----------------------------------------------------------------------------- +-- The fingerprints of an IfaceDecl + + -- We better give each name bound by the declaration a + -- different fingerprint! So we calculate the fingerprint of + -- each binder by combining the fingerprint of the whole + -- declaration with the name of the binder. (#5614, #7215) +ifaceDeclFingerprints :: Fingerprint -> IfaceDecl -> [(OccName,Fingerprint)] +ifaceDeclFingerprints hash decl + = (ifName decl, hash) : + [ (occ, computeFingerprint' (hash,occ)) + | occ <- ifaceDeclImplicitBndrs decl ] + where + computeFingerprint' = + unsafeDupablePerformIO + . computeFingerprint (panic "ifaceDeclFingerprints") + ----------------------------- Printing IfaceDecl ------------------------------ instance Outputable IfaceDecl where diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 93ca3853e2..d92cb4a185 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -530,25 +530,12 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- to assign fingerprints to all the OccNames that it binds, to -- use when referencing those OccNames in later declarations. -- - -- We better give each name bound by the declaration a - -- different fingerprint! So we calculate the fingerprint of - -- each binder by combining the fingerprint of the whole - -- declaration with the name of the binder. (#5614) extend_hash_env :: OccEnv (OccName,Fingerprint) -> (Fingerprint,IfaceDecl) -> IO (OccEnv (OccName,Fingerprint)) extend_hash_env env0 (hash,d) = do - let - sub_bndrs = ifaceDeclImplicitBndrs d - fp_sub_bndr occ = computeFingerprint putNameLiterally (hash,occ) - -- - sub_fps <- mapM fp_sub_bndr sub_bndrs - return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env1 - (zip sub_bndrs sub_fps)) - where - decl_name = ifName d - item = (decl_name, hash) - env1 = extendOccEnv env0 decl_name item + return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0 + (ifaceDeclFingerprints hash d)) -- (local_env, decls_w_hashes) <- diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs index 35de40bdc4..9e77990160 100644 --- a/compiler/llvmGen/Llvm/Types.hs +++ b/compiler/llvmGen/Llvm/Types.hs @@ -11,7 +11,7 @@ import Data.Int import Data.List (intercalate) import Numeric -import Constants +import DynFlags import FastString import Unique @@ -325,21 +325,21 @@ isGlobal (LMGlobalVar _ _ _ _ _ _) = True isGlobal _ = False -- | Width in bits of an 'LlvmType', returns 0 if not applicable -llvmWidthInBits :: LlvmType -> Int -llvmWidthInBits (LMInt n) = n -llvmWidthInBits (LMFloat) = 32 -llvmWidthInBits (LMDouble) = 64 -llvmWidthInBits (LMFloat80) = 80 -llvmWidthInBits (LMFloat128) = 128 +llvmWidthInBits :: DynFlags -> LlvmType -> Int +llvmWidthInBits _ (LMInt n) = n +llvmWidthInBits _ (LMFloat) = 32 +llvmWidthInBits _ (LMDouble) = 64 +llvmWidthInBits _ (LMFloat80) = 80 +llvmWidthInBits _ (LMFloat128) = 128 -- Could return either a pointer width here or the width of what -- it points to. We will go with the former for now. -llvmWidthInBits (LMPointer _) = llvmWidthInBits llvmWord -llvmWidthInBits (LMArray _ _) = llvmWidthInBits llvmWord -llvmWidthInBits LMLabel = 0 -llvmWidthInBits LMVoid = 0 -llvmWidthInBits (LMStruct tys) = sum $ map llvmWidthInBits tys -llvmWidthInBits (LMFunction _) = 0 -llvmWidthInBits (LMAlias (_,t)) = llvmWidthInBits t +llvmWidthInBits dflags (LMPointer _) = llvmWidthInBits dflags (llvmWord dflags) +llvmWidthInBits dflags (LMArray _ _) = llvmWidthInBits dflags (llvmWord dflags) +llvmWidthInBits _ LMLabel = 0 +llvmWidthInBits _ LMVoid = 0 +llvmWidthInBits dflags (LMStruct tys) = sum $ map (llvmWidthInBits dflags) tys +llvmWidthInBits _ (LMFunction _) = 0 +llvmWidthInBits dflags (LMAlias (_,t)) = llvmWidthInBits dflags t -- ----------------------------------------------------------------------------- @@ -356,9 +356,9 @@ i1 = LMInt 1 i8Ptr = pLift i8 -- | The target architectures word size -llvmWord, llvmWordPtr :: LlvmType -llvmWord = LMInt (wORD_SIZE * 8) -llvmWordPtr = pLift llvmWord +llvmWord, llvmWordPtr :: DynFlags -> LlvmType +llvmWord dflags = LMInt (wORD_SIZE dflags * 8) +llvmWordPtr dflags = pLift (llvmWord dflags) -- ----------------------------------------------------------------------------- -- * LLVM Function Types 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..5b944b799d 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -31,7 +31,6 @@ import LlvmCodeGen.Regs import CLabel import CgUtils ( activeStgRegs ) -import Constants import DynFlags import FastString import OldCmm @@ -99,33 +98,33 @@ llvmFunSig env lbl link llvmFunSig' :: DynFlags -> LMString -> LlvmLinkageType -> LlvmFunctionDecl llvmFunSig' dflags lbl link - = let platform = targetPlatform dflags - toParams x | isPointer x = (x, [NoAlias, NoCapture]) + = let toParams x | isPointer x = (x, [NoAlias, NoCapture]) | otherwise = (x, []) in LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs - (map (toParams . getVarType) (llvmFunArgs platform)) - llvmFunAlign + (map (toParams . getVarType) (llvmFunArgs dflags)) + (llvmFunAlign dflags) -- | Create a Haskell function in LLVM. mkLlvmFunc :: LlvmEnv -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks -> LlvmFunction mkLlvmFunc env lbl link sec blks - = let platform = targetPlatform $ getDflags env + = let dflags = getDflags env funDec = llvmFunSig env lbl link - funArgs = map (fsLit . getPlainName) (llvmFunArgs platform) + funArgs = map (fsLit . getPlainName) (llvmFunArgs dflags) in LlvmFunction funDec funArgs llvmStdFunAttrs sec blks -- | Alignment to use for functions -llvmFunAlign :: LMAlign -llvmFunAlign = Just wORD_SIZE +llvmFunAlign :: DynFlags -> LMAlign +llvmFunAlign dflags = Just (wORD_SIZE dflags) -- | Alignment to use for into tables -llvmInfAlign :: LMAlign -llvmInfAlign = Just wORD_SIZE +llvmInfAlign :: DynFlags -> LMAlign +llvmInfAlign dflags = Just (wORD_SIZE dflags) -- | A Function's arguments -llvmFunArgs :: Platform -> [LlvmVar] -llvmFunArgs platform = map lmGlobalRegArg (activeStgRegs platform) +llvmFunArgs :: DynFlags -> [LlvmVar] +llvmFunArgs dflags = map (lmGlobalRegArg dflags) (activeStgRegs platform) + where platform = targetPlatform dflags -- | Llvm standard fun attributes llvmStdFunAttrs :: [LlvmFuncAttr] @@ -137,8 +136,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 @@ -169,19 +168,19 @@ type LlvmEnvMap = UniqFM LlvmType -- | Get initial Llvm environment. initLlvmEnv :: DynFlags -> LlvmEnv initLlvmEnv dflags = LlvmEnv (initFuncs, emptyUFM, defaultLlvmVersion, dflags) - where initFuncs = listToUFM $ [ (n, LMFunction ty) | (n, ty) <- ghcInternalFunctions ] + where initFuncs = listToUFM $ [ (n, LMFunction ty) | (n, ty) <- ghcInternalFunctions dflags ] -- | Here we pre-initialise some functions that are used internally by GHC -- so as to make sure they have the most general type in the case that -- user code also uses these functions but with a different type than GHC -- internally. (Main offender is treating return type as 'void' instead of -- 'void *'. Fixes trac #5486. -ghcInternalFunctions :: [(LMString, LlvmFunctionDecl)] -ghcInternalFunctions = - [ mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord] - , mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord] - , mk "memset" i8Ptr [i8Ptr, llvmWord, llvmWord] - , mk "newSpark" llvmWord [i8Ptr, i8Ptr] +ghcInternalFunctions :: DynFlags -> [(LMString, LlvmFunctionDecl)] +ghcInternalFunctions dflags = + [ mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags] + , mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags] + , mk "memset" i8Ptr [i8Ptr, llvmWord dflags, llvmWord dflags] + , mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr] ] where mk n ret args = @@ -244,12 +243,12 @@ strCLabel_llvm env l = {-# SCC "llvm_strCLabel" #-} -- | Create an external definition for a 'CLabel' defined in another module. genCmmLabelRef :: LlvmEnv -> CLabel -> LMGlobal -genCmmLabelRef env = genStringLabelRef . strCLabel_llvm env +genCmmLabelRef env = genStringLabelRef (getDflags env) . strCLabel_llvm env -- | As above ('genCmmLabelRef') but taking a 'LMString', not 'CLabel'. -genStringLabelRef :: LMString -> LMGlobal -genStringLabelRef cl - = let ty = LMPointer $ LMArray 0 llvmWord +genStringLabelRef :: DynFlags -> LMString -> LMGlobal +genStringLabelRef dflags cl + = let ty = LMPointer $ LMArray 0 (llvmWord dflags) in (LMGlobalVar cl ty External Nothing Nothing False, Nothing) -- ---------------------------------------------------------------------------- diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 7f80cab617..448bd4d94c 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -55,11 +55,11 @@ basicBlocksCodeGen :: LlvmEnv -> ( [LlvmBasicBlock] , [LlvmCmmDecl] ) -> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmDecl] ) basicBlocksCodeGen env ([]) (blocks, tops) - = do let platform = targetPlatform $ getDflags env + = do let dflags = getDflags env let (blocks', allocs) = mapAndUnzip dominateAllocs blocks let allocs' = concat allocs let ((BasicBlock id fstmts):rblks) = blocks' - let fblocks = (BasicBlock id $ funPrologue platform ++ allocs' ++ fstmts):rblks + let fblocks = (BasicBlock id $ funPrologue dflags ++ allocs' ++ fstmts):rblks return (env, fblocks, tops) basicBlocksCodeGen env (block:blocks) (lblocks', ltops') @@ -148,9 +148,10 @@ barrier env = do -- | Memory barrier instruction for LLVM < 3.0 oldBarrier :: LlvmEnv -> UniqSM StmtData oldBarrier env = do + let dflags = getDflags env let fname = fsLit "llvm.memory.barrier" let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc LMVoid - FixedArgs (tysToParams [i1, i1, i1, i1, i1]) llvmFunAlign + FixedArgs (tysToParams [i1, i1, i1, i1, i1]) (llvmFunAlign dflags) let fty = LMFunction funSig let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing False @@ -185,7 +186,8 @@ genCall env (CmmPrim MO_WriteBarrier _) _ _ _ -- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM -- is strict about types. genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do - let width = widthToLlvmInt w + let dflags = getDflags env + width = widthToLlvmInt w dstTy = cmmToLlvmType $ localRegType dst funTy = \n -> LMFunction $ LlvmFunctionDecl n ExternallyVisible CC_Ccc width FixedArgs (tysToParams [width]) Nothing @@ -193,9 +195,9 @@ genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do (env2, argsV, stmts2, top2) <- arg_vars env1 args ([], nilOL, []) (env3, fptr, stmts3, top3) <- getFunPtr env2 funTy t - (argsV', stmts4) <- castVars $ zip argsV [width] + (argsV', stmts4) <- castVars dflags $ zip argsV [width] (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] - ([retV'], stmts5) <- castVars [(retV,dstTy)] + ([retV'], stmts5) <- castVars dflags [(retV,dstTy)] let s2 = Store retV' dstV let stmts = stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` @@ -208,17 +210,18 @@ genCall env t@(CmmPrim op _) [] args' CmmMayReturn | op == MO_Memcpy || op == MO_Memset || op == MO_Memmove = do - let (args, alignVal) = splitAlignVal args' + let dflags = getDflags env + (args, alignVal) = splitAlignVal args' (isVolTy, isVolVal) = if getLlvmVer env >= 28 then ([i1], [mkIntLit i1 0]) else ([], []) - argTy | op == MO_Memset = [i8Ptr, i8, llvmWord, i32] ++ isVolTy - | otherwise = [i8Ptr, i8Ptr, llvmWord, i32] ++ isVolTy + argTy | op == MO_Memset = [i8Ptr, i8, llvmWord dflags, i32] ++ isVolTy + | otherwise = [i8Ptr, i8Ptr, llvmWord dflags, i32] ++ isVolTy funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, []) (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy t - (argVars', stmts3) <- castVars $ zip argVars argTy + (argVars', stmts3) <- castVars dflags $ zip argVars argTy let arguments = argVars' ++ (alignVal:isVolVal) call = Expr $ Call StdCall fptr arguments [] @@ -243,10 +246,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 @@ -288,7 +293,7 @@ genCall env target res args ret = do let retTy = ret_type res let argTy = tysToParams $ map arg_type args let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible - lmconv retTy FixedArgs argTy llvmFunAlign + lmconv retTy FixedArgs argTy (llvmFunAlign dflags) (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, []) @@ -413,16 +418,17 @@ arg_vars env (CmmHinted e _:rest) (vars, stmts, tops) -- | Cast a collection of LLVM variables to specific types. -castVars :: [(LlvmVar, LlvmType)] +castVars :: DynFlags -> [(LlvmVar, LlvmType)] -> UniqSM ([LlvmVar], LlvmStatements) -castVars vars = do - done <- mapM (uncurry castVar) vars +castVars dflags vars = do + done <- mapM (uncurry (castVar dflags)) vars let (vars', stmts) = unzip done return (vars', toOL stmts) -- | Cast an LLVM variable to a specific type, panicing if it can't be done. -castVar :: LlvmVar -> LlvmType -> UniqSM (LlvmVar, LlvmStatement) -castVar v t | getVarType v == t +castVar :: DynFlags -> LlvmVar -> LlvmType -> UniqSM (LlvmVar, LlvmStatement) +castVar dflags v t + | getVarType v == t = return (v, Nop) | otherwise @@ -430,7 +436,7 @@ castVar v t | getVarType v == t (LMInt n, LMInt m) -> if n < m then LM_Sext else LM_Trunc (vt, _) | isFloat vt && isFloat t - -> if llvmWidthInBits vt < llvmWidthInBits t + -> if llvmWidthInBits dflags vt < llvmWidthInBits dflags t then LM_Fpext else LM_Fptrunc (vt, _) | isInt vt && isFloat t -> LM_Sitofp (vt, _) | isFloat vt && isInt t -> LM_Fptosi @@ -496,10 +502,11 @@ cmmPrimOpFunctions env mop MO_Touch -> unsupported where + dflags = getDflags env intrinTy1 = (if getLlvmVer env >= 28 - then "p0i8.p0i8." else "") ++ show llvmWord + then "p0i8.p0i8." else "") ++ show (llvmWord dflags) intrinTy2 = (if getLlvmVer env >= 28 - then "p0i8." else "") ++ show llvmWord + then "p0i8." else "") ++ show (llvmWord dflags) unsupported = panic ("cmmPrimOpFunctions: " ++ show mop ++ " not supported here") @@ -541,12 +548,13 @@ genJump env expr live = do -- these with registers when possible. genAssign :: LlvmEnv -> CmmReg -> CmmExpr -> UniqSM StmtData genAssign env reg val = do - let (env1, vreg, stmts1, top1) = getCmmReg env reg + let dflags = getDflags env + (env1, vreg, stmts1, top1) = getCmmReg env reg (env2, vval, stmts2, top2) <- exprToVar env1 val let stmts = stmts1 `appOL` stmts2 let ty = (pLower . getVarType) vreg - case isPointer ty && getVarType vval == llvmWord of + case isPointer ty && getVarType vval == llvmWord dflags of -- Some registers are pointer types, so need to cast value to pointer True -> do (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty @@ -592,10 +600,11 @@ genStore env addr val = genStore_slow env addr val [other] genStore_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmExpr -> UniqSM StmtData genStore_fast env addr r n val - = let gr = lmGlobalRegVar r + = let dflags = getDflags env + gr = lmGlobalRegVar (getDflags env) r meta = [getTBAA r] grt = (pLower . getVarType) gr - (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8) + (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) in case isPointer grt && rem == 0 of True -> do (env', vval, stmts, top) <- exprToVar env val @@ -632,7 +641,7 @@ genStore_slow env addr val meta = do let stmts = stmts1 `appOL` stmts2 case getVarType vaddr of -- sometimes we need to cast an int to a pointer before storing - LMPointer ty@(LMPointer _) | getVarType vval == llvmWord -> do + LMPointer ty@(LMPointer _) | getVarType vval == llvmWord dflags -> do (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty let s2 = MetaStmt meta $ Store v vaddr return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) @@ -641,7 +650,7 @@ genStore_slow env addr val meta = do let s1 = MetaStmt meta $ Store vval vaddr return (env2, stmts `snocOL` s1, top1 ++ top2) - i@(LMInt _) | i == llvmWord -> do + i@(LMInt _) | i == llvmWord dflags -> do let vty = pLift $ getVarType vval (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty let s2 = MetaStmt meta $ Store vval vptr @@ -650,9 +659,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 var: " ++ show (llvmWidthInBits other) ++ + "Size of Ptr: " ++ show (llvmPtrBits dflags) ++ + ", Size of var: " ++ show (llvmWidthInBits dflags other) ++ ", Var: " ++ show vaddr)) + where dflags = getDflags env -- | Unconditional branch @@ -720,14 +730,14 @@ data EOption = EOption { i1Option :: EOption i1Option = EOption (Just i1) -wordOption :: EOption -wordOption = EOption (Just llvmWord) +wordOption :: DynFlags -> EOption +wordOption dflags = EOption (Just (llvmWord dflags)) -- | Convert a CmmExpr to a list of LlvmStatements with the result of the -- expression being stored in the returned LlvmVar. exprToVar :: LlvmEnv -> CmmExpr -> UniqSM ExprData -exprToVar env = exprToVarOpt env wordOption +exprToVar env = exprToVarOpt env (wordOption (getDflags env)) exprToVarOpt :: LlvmEnv -> EOption -> CmmExpr -> UniqSM ExprData exprToVarOpt env opt e = case e of @@ -746,7 +756,7 @@ exprToVarOpt env opt e = case e of case (isPointer . getVarType) v1 of True -> do -- Cmm wants the value, so pointer types must be cast to ints - (v2, s2) <- doExpr llvmWord $ Cast LM_Ptrtoint v1 llvmWord + (v2, s2) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint v1 (llvmWord dflags) return (env', v2, stmts `snocOL` s1 `snocOL` s2, top) False -> return (env', v1, stmts `snocOL` s1, top) @@ -755,11 +765,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 @@ -833,6 +844,8 @@ genMachOp env _ op [x] = case op of MO_S_Shr _ -> panicOp where + dflags = getDflags env + negate ty v2 negOp = do (env', vx, stmts, top) <- exprToVar env x (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx @@ -848,7 +861,7 @@ genMachOp env _ op [x] = case op of let sameConv' op = do (v1, s1) <- doExpr ty $ Cast op vx ty return (env', v1, stmts `snocOL` s1, top) - let toWidth = llvmWidthInBits ty + let toWidth = llvmWidthInBits dflags ty -- LLVM doesn't like trying to convert to same width, so -- need to check for that as we do get Cmm code doing it. case widthInBits from of @@ -876,14 +889,15 @@ genMachOp env opt op e = genMachOp_slow env opt op e genMachOp_fast :: LlvmEnv -> EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr] -> UniqSM ExprData genMachOp_fast env opt op r n e - = let gr = lmGlobalRegVar r + = let dflags = getDflags env + gr = lmGlobalRegVar dflags r grt = (pLower . getVarType) gr - (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8) + (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) in case isPointer grt && rem == 0 of True -> do (gv, s1) <- doExpr grt $ Load gr (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] - (var, s3) <- doExpr llvmWord $ Cast LM_Ptrtoint ptr llvmWord + (var, s3) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint ptr (llvmWord dflags) return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, []) False -> genMachOp_slow env opt op e @@ -953,6 +967,8 @@ genMachOp_slow env opt op [x, y] = case op of MO_FF_Conv _ _ -> panicOp where + dflags = getDflags env + binLlvmOp ty binOp = do (env1, vx, stmts1, top1) <- exprToVar env x (env2, vy, stmts2, top2) <- exprToVar env1 y @@ -1013,10 +1029,10 @@ genMachOp_slow env opt op [x, y] = case op of (env2, vy, stmts2, top2) <- exprToVar env1 y let word = getVarType vx - let word2 = LMInt $ 2 * (llvmWidthInBits $ getVarType vx) - let shift = llvmWidthInBits word - let shift1 = toIWord (shift - 1) - let shift2 = toIWord shift + let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx) + let shift = llvmWidthInBits dflags word + let shift1 = toIWord dflags (shift - 1) + let shift2 = toIWord dflags shift if isInt word then do @@ -1077,11 +1093,12 @@ genLoad env e ty = genLoad_slow env e ty [other] genLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType -> UniqSM ExprData genLoad_fast env e r n ty = - let gr = lmGlobalRegVar r + let dflags = getDflags env + gr = lmGlobalRegVar dflags r meta = [getTBAA r] grt = (pLower . getVarType) gr ty' = cmmToLlvmType ty - (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8) + (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) in case isPointer grt && rem == 0 of True -> do (gv, s1) <- doExpr grt $ Load gr @@ -1118,7 +1135,7 @@ genLoad_slow env e ty meta = do (MetaExpr meta $ Load iptr) return (env', dvar, stmts `snocOL` load, tops) - i@(LMInt _) | i == llvmWord -> do + i@(LMInt _) | i == llvmWord dflags -> do let pty = LMPointer $ cmmToLlvmType ty (ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty (dvar, load) <- doExpr (cmmToLlvmType ty) @@ -1127,10 +1144,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 var: " ++ show (llvmWidthInBits other) ++ + "Size of Ptr: " ++ show (llvmPtrBits dflags) ++ + ", Size of var: " ++ show (llvmWidthInBits dflags other) ++ ", Var: " ++ show iptr)) - + where dflags = getDflags env -- | Handle CmmReg expression -- @@ -1146,7 +1163,7 @@ getCmmReg env r@(CmmLocal (LocalReg un _)) Just ety -> (env, (LMLocalVar un $ pLift ety), nilOL, []) Nothing -> (nenv, newv, stmts, []) -getCmmReg env (CmmGlobal g) = (env, lmGlobalRegVar g, nilOL, []) +getCmmReg env (CmmGlobal g) = (env, lmGlobalRegVar (getDflags env) g, nilOL, []) -- | Allocate a CmmReg on the stack @@ -1171,16 +1188,17 @@ 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 - let glob@(var, _) = genStringLabelRef label + let glob@(var, _) = genStringLabelRef dflags label let ldata = [CmmData Data [([glob], [])]] let env' = funInsert label (pLower $ getVarType var) env - (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord + (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags) return (env', v1, unitOL s1, ldata) -- Referenced data exists in this module, retrieve type and make @@ -1188,23 +1206,25 @@ genLit env cmm@(CmmLabel l) Just ty' -> do let var = LMGlobalVar label (LMPointer ty') ExternallyVisible Nothing Nothing False - (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord + (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags) return (env, v1, unitOL s1, []) genLit env (CmmLabelOff label off) = do + let dflags = getDflags env (env', vlbl, stmts, stat) <- genLit env (CmmLabel label) - let voff = toIWord off + let voff = toIWord dflags off (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff return (env', v1, stmts `snocOL` s1, stat) genLit env (CmmLabelDiffOff l1 l2 off) = do + let dflags = getDflags env (env1, vl1, stmts1, stat1) <- genLit env (CmmLabel l1) (env2, vl2, stmts2, stat2) <- genLit env1 (CmmLabel l2) - let voff = toIWord off + let voff = toIWord dflags off let ty1 = getVarType vl1 let ty2 = getVarType vl2 if (isInt ty1) && (isInt ty2) - && (llvmWidthInBits ty1 == llvmWidthInBits ty2) + && (llvmWidthInBits dflags ty1 == llvmWidthInBits dflags ty2) then do (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2 @@ -1227,11 +1247,12 @@ genLit _ CmmHighStackMark -- -- | Function prologue. Load STG arguments into variables for function. -funPrologue :: Platform -> [LlvmStatement] -funPrologue platform = concat $ map getReg $ activeStgRegs platform - where getReg rr = - let reg = lmGlobalRegVar rr - arg = lmGlobalRegArg rr +funPrologue :: DynFlags -> [LlvmStatement] +funPrologue dflags = concat $ map getReg $ activeStgRegs platform + where platform = targetPlatform dflags + getReg rr = + let reg = lmGlobalRegVar dflags rr + arg = lmGlobalRegArg dflags rr alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1 in [alloc, Store arg reg] @@ -1249,11 +1270,11 @@ funEpilogue env (Just live) | dopt Opt_RegLiveness dflags = do dflags = getDflags env platform = targetPlatform dflags loadExpr r | r `elem` alwaysLive || r `elem` live = do - let reg = lmGlobalRegVar r + let reg = lmGlobalRegVar dflags r (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg return (v, unitOL s) loadExpr r = do - let ty = (pLower . getVarType $ lmGlobalRegVar r) + let ty = (pLower . getVarType $ lmGlobalRegVar dflags r) return (LMLitVar $ LMUndefLit ty, unitOL Nop) -- don't do liveness optimisation @@ -1265,7 +1286,7 @@ funEpilogue env _ = do dflags = getDflags env platform = targetPlatform dflags loadExpr r = do - let reg = lmGlobalRegVar r + let reg = lmGlobalRegVar dflags r (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg return (v, unitOL s) @@ -1285,7 +1306,7 @@ trashStmts :: DynFlags -> LlvmStatements trashStmts dflags = concatOL $ map trashReg $ activeStgRegs platform where platform = targetPlatform dflags trashReg r = - let reg = lmGlobalRegVar r + let reg = lmGlobalRegVar dflags r ty = (pLower . getVarType) reg trash = unitOL $ Store (LMLitVar $ LMUndefLit ty) reg in case callerSaves (targetPlatform dflags) r of @@ -1340,9 +1361,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] @@ -1356,9 +1377,11 @@ mkIntLit :: Integral a => LlvmType -> a -> LlvmVar mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty -- | Convert int type to a LLvmVar of word or i32 size -toI32, toIWord :: Integral a => a -> LlvmVar +toI32 :: Integral a => a -> LlvmVar toI32 = mkIntLit i32 -toIWord = mkIntLit llvmWord + +toIWord :: Integral a => DynFlags -> a -> LlvmVar +toIWord dflags = mkIntLit (llvmWord dflags) -- | Error functions diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs index 8e42149dce..9c57ab3cd4 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,13 +107,14 @@ 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 -> - let glob@(var, _) = genStringLabelRef label + let glob@(var, _) = genStringLabelRef dflags label env' = funInsert label (pLower $ getVarType var) env ptr = LMStaticPointer var in (env', LMPtoI ptr lmty, [glob]) @@ -125,15 +127,17 @@ resData env (Left cmm@(CmmLabel l)) = in (env, LMPtoI ptr lmty, []) resData env (Left (CmmLabelOff label off)) = - let (env', var, glob) = resData env (Left (CmmLabel label)) - offset = LMStaticLit $ LMIntLit (toInteger off) llvmWord + let dflags = getDflags env + (env', var, glob) = resData env (Left (CmmLabel label)) + offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags) in (env', LMAdd var offset, glob) resData env (Left (CmmLabelDiffOff l1 l2 off)) = - let (env1, var1, glob1) = resData env (Left (CmmLabel l1)) + let dflags = getDflags env + (env1, var1, glob1) = resData env (Left (CmmLabel l1)) (env2, var2, glob2) = resData env1 (Left (CmmLabel l2)) var = LMSub var1 var2 - offset = LMStaticLit $ LMIntLit (toInteger off) llvmWord + offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags) in (env2, LMAdd var offset, glob1 ++ glob2) resData _ _ = panic "resData: Non CLabel expr as left type!" diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index cf78b3730a..c791e85a52 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -28,10 +28,10 @@ import Unique -- | Header code for LLVM modules pprLlvmHeader :: SDoc -pprLlvmHeader = +pprLlvmHeader = sdocWithDynFlags $ \dflags -> moduleLayout $+$ text "" - $+$ ppLlvmFunctionDecls (map snd ghcInternalFunctions) + $+$ ppLlvmFunctionDecls (map snd (ghcInternalFunctions dflags)) $+$ ppLlvmMetas stgTBAA $+$ text "" @@ -106,14 +106,15 @@ pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl (ListGraph blks)) -- | Pretty print CmmStatic pprInfoTable :: LlvmEnv -> Int -> CLabel -> CmmStatics -> (SDoc, [LlvmVar]) pprInfoTable env count info_lbl stat - = let unres = genLlvmData env (Text, stat) + = let dflags = getDflags env + unres = genLlvmData env (Text, stat) (_, (ldata, ltypes)) = resolveLlvmData env unres setSection ((LMGlobalVar _ ty l _ _ c), d) = let sec = mkLayoutSection count ilabel = strCLabel_llvm env info_lbl `appendFS` fsLit iTableSuf - gv = LMGlobalVar ilabel ty l sec llvmInfAlign c + gv = LMGlobalVar ilabel ty l sec (llvmInfAlign dflags) c v = if l == Internal then [gv] else [] in ((gv, d), v) setSection v = (v,[]) diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs index b7ff9f008e..49c900d5e0 100644 --- a/compiler/llvmGen/LlvmCodeGen/Regs.hs +++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs @@ -12,23 +12,24 @@ module LlvmCodeGen.Regs ( import Llvm import CmmExpr +import DynFlags import FastString import Outputable ( panic ) -- | Get the LlvmVar function variable storing the real register -lmGlobalRegVar :: GlobalReg -> LlvmVar -lmGlobalRegVar = (pVarLift . lmGlobalReg "_Var") +lmGlobalRegVar :: DynFlags -> GlobalReg -> LlvmVar +lmGlobalRegVar dflags = pVarLift . lmGlobalReg dflags "_Var" -- | Get the LlvmVar function argument storing the real register -lmGlobalRegArg :: GlobalReg -> LlvmVar -lmGlobalRegArg = lmGlobalReg "_Arg" +lmGlobalRegArg :: DynFlags -> GlobalReg -> LlvmVar +lmGlobalRegArg dflags = lmGlobalReg dflags "_Arg" {- Need to make sure the names here can't conflict with the unique generated names. Uniques generated names containing only base62 chars. So using say the '_' char guarantees this. -} -lmGlobalReg :: String -> GlobalReg -> LlvmVar -lmGlobalReg suf reg +lmGlobalReg :: DynFlags -> String -> GlobalReg -> LlvmVar +lmGlobalReg dflags suf reg = case reg of BaseReg -> ptrGlobal $ "Base" ++ suf Sp -> ptrGlobal $ "Sp" ++ suf @@ -53,8 +54,8 @@ lmGlobalReg suf reg -- LongReg, HpLim, CCSS, CurrentTSO, CurrentNusery, HpAlloc -- EagerBlackholeInfo, GCEnter1, GCFun, BaseReg, PicBaseReg where - wordGlobal name = LMNLocalVar (fsLit name) llvmWord - ptrGlobal name = LMNLocalVar (fsLit name) llvmWordPtr + wordGlobal name = LMNLocalVar (fsLit name) (llvmWord dflags) + ptrGlobal name = LMNLocalVar (fsLit name) (llvmWordPtr dflags) floatGlobal name = LMNLocalVar (fsLit name) LMFloat doubleGlobal name = LMNLocalVar (fsLit name) LMDouble diff --git a/compiler/main/BreakArray.hs b/compiler/main/BreakArray.hs index 91e4c96c9a..4d3145fb3a 100644 --- a/compiler/main/BreakArray.hs +++ b/compiler/main/BreakArray.hs @@ -25,62 +25,62 @@ module BreakArray #endif ) where +import DynFlags + #ifdef GHCI import Control.Monad import GHC.Exts import GHC.IO ( IO(..) ) -import Constants - data BreakArray = BA (MutableByteArray# RealWorld) breakOff, breakOn :: Word breakOn = 1 breakOff = 0 -showBreakArray :: BreakArray -> IO () -showBreakArray array = do - forM_ [0..(size array - 1)] $ \i -> do +showBreakArray :: DynFlags -> BreakArray -> IO () +showBreakArray dflags array = do + forM_ [0 .. (size dflags array - 1)] $ \i -> do val <- readBreakArray array i putStr $ ' ' : show val putStr "\n" -setBreakOn :: BreakArray -> Int -> IO Bool -setBreakOn array index - | safeIndex array index = do +setBreakOn :: DynFlags -> BreakArray -> Int -> IO Bool +setBreakOn dflags array index + | safeIndex dflags array index = do writeBreakArray array index breakOn return True | otherwise = return False -setBreakOff :: BreakArray -> Int -> IO Bool -setBreakOff array index - | safeIndex array index = do +setBreakOff :: DynFlags -> BreakArray -> Int -> IO Bool +setBreakOff dflags array index + | safeIndex dflags array index = do writeBreakArray array index breakOff return True | otherwise = return False -getBreak :: BreakArray -> Int -> IO (Maybe Word) -getBreak array index - | safeIndex array index = do +getBreak :: DynFlags -> BreakArray -> Int -> IO (Maybe Word) +getBreak dflags array index + | safeIndex dflags array index = do val <- readBreakArray array index return $ Just val | otherwise = return Nothing -safeIndex :: BreakArray -> Int -> Bool -safeIndex array index = index < size array && index >= 0 +safeIndex :: DynFlags -> BreakArray -> Int -> Bool +safeIndex dflags array index = index < size dflags array && index >= 0 -size :: BreakArray -> Int -size (BA array) = (I# (sizeofMutableByteArray# array)) `div` wORD_SIZE +size :: DynFlags -> BreakArray -> Int +size dflags (BA array) = (I# (sizeofMutableByteArray# array)) `div` wORD_SIZE dflags allocBA :: Int -> IO BreakArray allocBA (I# sz) = IO $ \s1 -> case newByteArray# sz s1 of { (# s2, array #) -> (# s2, BA array #) } -- create a new break array and initialise elements to zero -newBreakArray :: Int -> IO BreakArray -newBreakArray entries@(I# sz) = do - BA array <- allocBA (entries * wORD_SIZE) +newBreakArray :: DynFlags -> Int -> IO BreakArray +newBreakArray dflags entries@(I# sz) = do + BA array <- allocBA (entries * wORD_SIZE dflags) case breakOff of W# off -> do -- Todo: there must be a better way to write zero as a Word! let loop n | n ==# sz = return () @@ -112,8 +112,8 @@ readBreakArray (BA array) (I# i) = readBA# array i -- presumably have a different representation. data BreakArray = Unspecified -newBreakArray :: Int -> IO BreakArray -newBreakArray _ = return Unspecified +newBreakArray :: DynFlags -> Int -> IO BreakArray +newBreakArray _ _ = return Unspecified #endif /* GHCI */ 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 fe158460cb..0566d6ad65 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -39,7 +39,6 @@ import Module import UniqFM ( eltsUFM ) import ErrUtils import DynFlags -import StaticFlags ( v_Ld_inputs, opt_Static, WayName(..) ) import Config import Panic import Util @@ -357,7 +356,7 @@ linkingNeeded dflags linkables pkg_deps = do Left _ -> return True Right t -> do -- first check object files and extra_ld_inputs - extra_ld_inputs <- readIORef v_Ld_inputs + let extra_ld_inputs = ldInputs dflags e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs let (errs,extra_times) = splitEithers e_extra_times let obj_times = map linkableTime linkables ++ extra_times @@ -1352,9 +1351,9 @@ runPhase LlvmLlc input_fn dflags let lc_opts = getOpts dflags opt_lc opt_lvl = max 0 (min 2 $ optLevel dflags) - rmodel | dopt Opt_PIC dflags = "pic" - | not opt_Static = "dynamic-no-pic" - | otherwise = "static" + rmodel | dopt Opt_PIC dflags = "pic" + | not (dopt Opt_Static dflags) = "dynamic-no-pic" + | otherwise = "static" tbaa | ver < 29 = "" -- no tbaa in 2.8 and earlier | dopt Opt_LlvmTBAA dflags = "--enable-tbaa=true" | otherwise = "--enable-tbaa=false" @@ -1448,9 +1447,9 @@ maybeMergeStub runPhase_MoveBinary :: DynFlags -> FilePath -> IO Bool runPhase_MoveBinary dflags input_fn - | WayPar `elem` (wayNames dflags) && not opt_Static = + | WayPar `elem` ways dflags && not (dopt Opt_Static dflags) = panic ("Don't know how to combine PVM wrapper and dynamic wrapper") - | WayPar `elem` (wayNames dflags) = do + | WayPar `elem` ways dflags = do let sysMan = pgm_sysman dflags pvm_root <- getEnv "PVM_ROOT" pvm_arch <- getEnv "PVM_ARCH" @@ -1557,7 +1556,7 @@ getLinkInfo dflags dep_packages = do pkg_frameworks <- case platformOS (targetPlatform dflags) of OSDarwin -> getPackageFrameworks dflags dep_packages _ -> return [] - extra_ld_inputs <- readIORef v_Ld_inputs + let extra_ld_inputs = ldInputs dflags let link_info = (package_link_opts, pkg_frameworks, @@ -1668,7 +1667,7 @@ linkBinary dflags o_files dep_packages = do get_pkg_lib_path_opts l | osElfTarget (platformOS platform) && dynLibLoader dflags == SystemDependent && - not opt_Static + not (dopt Opt_Static dflags) = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l] | otherwise = ["-L" ++ l] @@ -1715,34 +1714,31 @@ linkBinary dflags o_files dep_packages = do return [] -- probably _stub.o files - extra_ld_inputs <- readIORef v_Ld_inputs + let extra_ld_inputs = ldInputs dflags -- opts from -optl-<blah> (including -l<blah> options) let extra_ld_opts = getOpts dflags opt_l - let ways = wayNames dflags - -- Here are some libs that need to be linked at the *end* of -- the command line, because they contain symbols that are referred to -- by the RTS. We can't therefore use the ordinary way opts for these. let - debug_opts | WayDebug `elem` ways = [ + debug_opts | WayDebug `elem` ways dflags = [ #if defined(HAVE_LIBBFD) "-lbfd", "-liberty" #endif ] | otherwise = [] - let - thread_opts | WayThreaded `elem` ways = [ -#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 @@ -1893,7 +1889,7 @@ linkDynLib dflags o_files dep_packages get_pkg_lib_path_opts l | osElfTarget (platformOS (targetPlatform dflags)) && dynLibLoader dflags == SystemDependent && - not opt_Static + not (dopt Opt_Static dflags) = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l] | otherwise = ["-L" ++ l] @@ -1907,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 _ -> @@ -1915,127 +1913,135 @@ linkDynLib dflags o_files dep_packages let pkg_link_opts = collectLinkOpts dflags pkgs_no_rts -- probably _stub.o files - extra_ld_inputs <- readIORef v_Ld_inputs + let extra_ld_inputs = ldInputs dflags 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 8abe664aa0..d4c3d535d6 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, @@ -45,11 +46,13 @@ module DynFlags ( Option(..), showOpt, DynLibLoader(..), fFlags, fWarningFlags, fLangFlags, xFlags, - wayNames, dynFlagDependencies, + dynFlagDependencies, tablesNextToCode, mkTablesNextToCode, printOutputForUser, printInfoForUser, + Way(..), mkBuildTag, wayRTSOnly, + -- ** Safe Haskell SafeHaskellMode(..), safeHaskellOn, safeImportsOn, safeLanguageOn, safeInferOn, @@ -82,7 +85,6 @@ module DynFlags ( updOptLevel, setTmpDir, setPackageName, - doingTickyProfiling, -- ** Parsing DynFlags parseDynamicFlagsCmdLine, @@ -114,6 +116,12 @@ 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, + tAG_MASK, + mAX_PTR_TAG, ) where #include "HsVersions.h" @@ -122,12 +130,11 @@ import Platform import Module import PackageConfig import PrelNames ( mAIN ) -import StaticFlags 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 ) @@ -144,8 +151,9 @@ import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessage ) import System.IO.Unsafe ( unsafePerformIO ) #endif import Data.IORef -import Control.Monad ( when ) +import Control.Monad +import Data.Bits import Data.Char import Data.List import Data.Map (Map) @@ -325,6 +333,9 @@ data DynFlag | Opt_GranMacros | Opt_PIC | Opt_SccProfilingOn + | Opt_Ticky + | Opt_Static + | Opt_Hpc -- output style opts | Opt_PprCaseAsLet @@ -521,6 +532,7 @@ data DynFlags = DynFlags { liberateCaseThreshold :: Maybe Int, -- ^ Threshold for LiberateCase floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating -- See CoreMonad.FloatOutSwitches + historySize :: Int, cmdlineHcIncludes :: [String], -- ^ @\-\#includes@ importPaths :: [FilePath], @@ -561,6 +573,8 @@ data DynFlags = DynFlags { -- Set by @-ddump-file-prefix@ dumpPrefixForce :: Maybe FilePath, + ldInputs :: [String], + includePaths :: [String], libraryPaths :: [String], frameworkPaths :: [String], -- used on darwin only @@ -699,8 +713,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 @@ -765,9 +780,6 @@ opt_lo dflags = sOpt_lo (settings dflags) opt_lc :: DynFlags -> [String] opt_lc dflags = sOpt_lc (settings dflags) -wayNames :: DynFlags -> [WayName] -wayNames = map wayName . ways - -- | The target code type of the compilation (if any). -- -- Whenever you change the target, also make sure to set 'ghcLink' to @@ -855,13 +867,6 @@ isNoLink :: GhcLink -> Bool isNoLink NoLink = True isNoLink _ = False --- Is it worth evaluating this Bool and caching it in the DynFlags value --- during initDynFlags? -doingTickyProfiling :: DynFlags -> Bool -doingTickyProfiling _ = opt_Ticky - -- XXX -ticky is a static flag, because it implies -debug which is also - -- static. If the way flags were made dynamic, we could fix this. - data PackageFlag = ExposePackage String | ExposePackageId String @@ -902,19 +907,187 @@ data DynLibLoader data RtsOptsEnabled = RtsOptsNone | RtsOptsSafeOnly | RtsOptsAll deriving (Show) +----------------------------------------------------------------------------- +-- Ways + +-- The central concept of a "way" is that all objects in a given +-- program must be compiled in the same "way". Certain options change +-- parameters of the virtual machine, eg. profiling adds an extra word +-- to the object header, so profiling objects cannot be linked with +-- non-profiling objects. + +-- After parsing the command-line options, we determine which "way" we +-- are building - this might be a combination way, eg. profiling+threaded. + +-- We then find the "build-tag" associated with this way, and this +-- becomes the suffix used to find .hi files and libraries used in +-- this compilation. + +data Way + = WayThreaded + | WayDebug + | WayProf + | WayEventLog + | WayPar + | WayGran + | WayNDP + | WayDyn + deriving (Eq,Ord) + +allowed_combination :: [Way] -> Bool +allowed_combination way = and [ x `allowedWith` y + | x <- way, y <- way, x < y ] + where + -- Note ordering in these tests: the left argument is + -- <= the right argument, according to the Ord instance + -- on Way above. + + -- dyn is allowed with everything + _ `allowedWith` WayDyn = True + WayDyn `allowedWith` _ = True + + -- debug is allowed with everything + _ `allowedWith` WayDebug = True + WayDebug `allowedWith` _ = True + + WayProf `allowedWith` WayNDP = True + WayThreaded `allowedWith` WayProf = True + WayThreaded `allowedWith` WayEventLog = True + _ `allowedWith` _ = False + +mkBuildTag :: [Way] -> String +mkBuildTag ways = concat (intersperse "_" (map wayTag ways)) + +wayTag :: Way -> String +wayTag WayThreaded = "thr" +wayTag WayDebug = "debug" +wayTag WayDyn = "dyn" +wayTag WayProf = "p" +wayTag WayEventLog = "l" +wayTag WayPar = "mp" +-- wayTag WayPar = "mt" +-- wayTag WayPar = "md" +wayTag WayGran = "mg" +wayTag WayNDP = "ndp" + +wayRTSOnly :: Way -> Bool +wayRTSOnly WayThreaded = True +wayRTSOnly WayDebug = True +wayRTSOnly WayDyn = False +wayRTSOnly WayProf = False +wayRTSOnly WayEventLog = True +wayRTSOnly WayPar = False +-- wayRTSOnly WayPar = False +-- wayRTSOnly WayPar = False +wayRTSOnly WayGran = False +wayRTSOnly WayNDP = False + +wayDesc :: Way -> String +wayDesc WayThreaded = "Threaded" +wayDesc WayDebug = "Debug" +wayDesc WayDyn = "Dynamic" +wayDesc WayProf = "Profiling" +wayDesc WayEventLog = "RTS Event Logging" +wayDesc WayPar = "Parallel" +-- wayDesc WayPar = "Parallel ticky profiling" +-- wayDesc WayPar = "Distributed" +wayDesc WayGran = "GranSim" +wayDesc WayNDP = "Nested data parallelism" + +wayOpts :: Platform -> Way -> DynP () +wayOpts platform WayThreaded = do + -- FreeBSD's default threading library is the KSE-based M:N libpthread, + -- which GHC has some problems with. It's currently not clear whether + -- the problems are our fault or theirs, but it seems that using the + -- alternative 1:1 threading library libthr works around it: + let os = platformOS platform + case os of + OSFreeBSD -> upd $ addOptl "-lthr" + OSSolaris2 -> upd $ addOptl "-lrt" + _ + | os `elem` [OSOpenBSD, OSNetBSD] -> + do upd $ addOptc "-pthread" + upd $ addOptl "-pthread" + _ -> + return () +wayOpts _ WayDebug = return () +wayOpts platform WayDyn = do + upd $ addOptP "-DDYNAMIC" + upd $ addOptc "-DDYNAMIC" + let os = platformOS platform + case os of + OSMinGW32 -> + -- On Windows, code that is to be linked into a dynamic + -- library must be compiled with -fPIC. Labels not in + -- the current package are assumed to be in a DLL + -- different from the current one. + setFPIC + OSDarwin -> + setFPIC + _ | os `elem` [OSOpenBSD, OSNetBSD] -> + -- Without this, linking the shared libHSffi fails + -- because it uses pthread mutexes. + upd $ addOptl "-optl-pthread" + _ -> + return () +wayOpts _ WayProf = do + setDynFlag Opt_SccProfilingOn + upd $ addOptP "-DPROFILING" + upd $ addOptc "-DPROFILING" +wayOpts _ WayEventLog = do + upd $ addOptP "-DTRACING" + upd $ addOptc "-DTRACING" +wayOpts _ WayPar = do + setDynFlag Opt_Parallel + upd $ addOptP "-D__PARALLEL_HASKELL__" + upd $ addOptc "-DPAR" + exposePackage "concurrent" + upd $ addOptc "-w" + upd $ addOptl "-L${PVM_ROOT}/lib/${PVM_ARCH}" + upd $ addOptl "-lpvm3" + upd $ addOptl "-lgpvm3" +{- +wayOpts WayPar = + [ "-fparallel" + , "-D__PARALLEL_HASKELL__" + , "-optc-DPAR" + , "-optc-DPAR_TICKY" + , "-package concurrent" + , "-optc-w" + , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}" + , "-optl-lpvm3" + , "-optl-lgpvm3" ] +wayOpts WayPar = + [ "-fparallel" + , "-D__PARALLEL_HASKELL__" + , "-D__DISTRIBUTED_HASKELL__" + , "-optc-DPAR" + , "-optc-DDIST" + , "-package concurrent" + , "-optc-w" + , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}" + , "-optl-lpvm3" + , "-optl-lgpvm3" ] +-} +wayOpts _ WayGran = do + setDynFlag Opt_GranMacros + upd $ addOptP "-D__GRANSIM__" + upd $ addOptc "-DGRAN" + exposePackage "concurrent" +wayOpts _ WayNDP = do + setExtensionFlag Opt_ParallelArrays + setDynFlag Opt_Vectorise + +----------------------------------------------------------------------------- + -- | Used by 'GHC.newSession' to partially initialize a new 'DynFlags' value initDynFlags :: DynFlags -> IO DynFlags initDynFlags dflags = do - -- someday these will be dynamic flags - ways <- readIORef v_Ways refFilesToClean <- newIORef [] refDirsToClean <- newIORef Map.empty refGeneratedDumps <- newIORef Set.empty refLlvmVersion <- newIORef 28 return dflags{ - ways = ways, - buildTag = mkBuildTag (filter (not . wayRTSOnly) ways), - rtsBuildTag = mkBuildTag ways, filesToClean = refFilesToClean, dirsToClean = refDirsToClean, generatedDumps = refGeneratedDumps, @@ -942,6 +1115,7 @@ defaultDynFlags mySettings = specConstrCount = Just 3, liberateCaseThreshold = Just 2000, floatLamArgs = Just 0, -- Default: float only if no fvs + historySize = 20, strictnessBefore = [], cmdlineHcIncludes = [], @@ -970,6 +1144,7 @@ defaultDynFlags mySettings = dynLibLoader = SystemDependent, dumpPrefix = Nothing, dumpPrefixForce = Nothing, + ldInputs = [], includePaths = [], libraryPaths = [], frameworkPaths = [], @@ -983,9 +1158,9 @@ defaultDynFlags mySettings = packageFlags = [], pkgDatabase = Nothing, pkgState = panic "no package state yet: call GHC.setSessionDynFlags", - ways = panic "defaultDynFlags: No ways", - buildTag = panic "defaultDynFlags: No buildTag", - rtsBuildTag = panic "defaultDynFlags: No rtsBuildTag", + ways = [], + buildTag = mkBuildTag [], + rtsBuildTag = mkBuildTag [], splitInfo = Nothing, settings = mySettings, -- ghc -M values @@ -1289,7 +1464,7 @@ getVerbFlags dflags setObjectDir, setHiDir, setStubDir, setDumpDir, setOutputDir, setDylibInstallName, setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode, - setPgmP, addOptl, addOptP, + setPgmP, addOptl, addOptc, addOptP, addCmdlineFramework, addHaddockOpts, addGhciScript, setInteractivePrint :: String -> DynFlags -> DynFlags @@ -1335,6 +1510,7 @@ setDumpPrefixForce f d = d { dumpPrefixForce = f} -- Config.hs should really use Option. setPgmP f = let (pgm:args) = words f in alterSettings (\s -> s { sPgm_P = (pgm, map Option args)}) addOptl f = alterSettings (\s -> s { sOpt_l = f : sOpt_l s}) +addOptc f = alterSettings (\s -> s { sOpt_c = f : sOpt_c s}) addOptP f = alterSettings (\s -> s { sOpt_P = f : sOpt_P s}) @@ -1420,7 +1596,7 @@ getStgToDo dflags todo1 = if stg_stats then [D_stg_stats] else [] - todo2 | WayProf `elem` wayNames dflags + todo2 | WayProf `elem` ways dflags = StgDoMassageForProfiling : todo1 | otherwise = todo1 @@ -1486,7 +1662,19 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do -- check for disabled flags in safe haskell let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1 - return (dflags2, leftover, sh_warns ++ warns) + theWays = sort $ nub $ ways dflags2 + theBuildTag = mkBuildTag (filter (not . wayRTSOnly) theWays) + dflags3 = dflags2 { + ways = theWays, + buildTag = theBuildTag, + rtsBuildTag = mkBuildTag theWays + } + + unless (allowed_combination theWays) $ + ghcError (CmdLineError ("combination not supported: " ++ + intercalate "/" (map wayDesc theWays))) + + return (dflags3, leftover, sh_warns ++ warns) -- | Check (and potentially disable) any extensions that aren't allowed @@ -1582,6 +1770,32 @@ dynamic_flags = [ addWarn "-#include and INCLUDE pragmas are deprecated: They no longer have any effect")) , Flag "v" (OptIntSuffix setVerbosity) + ------- ways -------------------------------------------------------- + , Flag "prof" (NoArg (addWay WayProf)) + , Flag "eventlog" (NoArg (addWay WayEventLog)) + , Flag "parallel" (NoArg (addWay WayPar)) + , Flag "gransim" (NoArg (addWay WayGran)) + , Flag "smp" (NoArg (addWay WayThreaded >> deprecate "Use -threaded instead")) + , Flag "debug" (NoArg (addWay WayDebug)) + , Flag "ndp" (NoArg (addWay WayNDP)) + , Flag "threaded" (NoArg (addWay WayThreaded)) + + , Flag "ticky" (NoArg (setDynFlag Opt_Ticky >> addWay WayDebug)) + + -- -ticky enables ticky-ticky code generation, and also implies -debug which + -- is required to get the RTS ticky support. + + ----- Linker -------------------------------------------------------- + -- -static is the default. If -dynamic has been given then, due to the + -- way wayOpts is currently used, we've already set -DDYNAMIC etc. + -- It's too fiddly to undo that, so we just give an error if + -- Opt_Static has been unset. + , Flag "static" (noArgM (\dfs -> do unless (dopt Opt_Static dfs) (addErr "Can't use -static after -dynamic") + return dfs)) + , Flag "dynamic" (NoArg (unSetDynFlag Opt_Static >> addWay WayDyn)) + -- ignored for compat w/ gcc: + , Flag "rdynamic" (NoArg (return ())) + ------- Specific phases -------------------------------------------- -- need to appear before -pgmL to be parsed as LLVM flags. , Flag "pgmlo" (hasArg (\f -> alterSettings (\s -> s { sPgm_lo = (f,[])}))) @@ -1603,7 +1817,7 @@ dynamic_flags = [ , Flag "optL" (hasArg (\f -> alterSettings (\s -> s { sOpt_L = f : sOpt_L s}))) , Flag "optP" (hasArg addOptP) , Flag "optF" (hasArg (\f -> alterSettings (\s -> s { sOpt_F = f : sOpt_F s}))) - , Flag "optc" (hasArg (\f -> alterSettings (\s -> s { sOpt_c = f : sOpt_c s}))) + , Flag "optc" (hasArg addOptc) , Flag "optm" (HasArg (\_ -> addWarn "The -optm flag does nothing; it will be removed in a future GHC release")) , Flag "opta" (hasArg (\f -> alterSettings (\s -> s { sOpt_a = f : sOpt_a s}))) , Flag "optl" (hasArg addOptl) @@ -1839,6 +2053,7 @@ dynamic_flags = [ , Flag "fstrictness-before" (intSuffix (\n d -> d{ strictnessBefore = n : strictnessBefore d })) , Flag "ffloat-lam-args" (intSuffix (\n d -> d{ floatLamArgs = Just n })) , Flag "ffloat-all-lams" (noArg (\d -> d{ floatLamArgs = Nothing })) + , Flag "fhistory-size" (intSuffix (\n d -> d{ historySize = n })) ------ Profiling ---------------------------------------------------- @@ -2067,13 +2282,11 @@ fFlags = [ ( "ghci-history", Opt_GhciHistory, nop ), ( "helpful-errors", Opt_HelpfulErrors, nop ), ( "defer-type-errors", Opt_DeferTypeErrors, nop ), - ( "parallel", Opt_Parallel, nop ), - ( "scc-profiling", Opt_SccProfilingOn, nop ), - ( "gransim", Opt_GranMacros, nop ), ( "building-cabal-package", Opt_BuildingCabalPackage, nop ), ( "implicit-import-qualified", Opt_ImplicitImportQualified, nop ), ( "prof-count-entries", Opt_ProfCountEntries, nop ), - ( "prof-cafs", Opt_AutoSccsOnIndividualCafs, nop ) + ( "prof-cafs", Opt_AutoSccsOnIndividualCafs, nop ), + ( "hpc", Opt_Hpc, nop ) ] -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ @@ -2242,12 +2455,11 @@ xFlags = [ defaultFlags :: Platform -> [DynFlag] defaultFlags platform = [ Opt_AutoLinkPackages, + Opt_Static, Opt_SharedImplib, -#if GHC_DEFAULT_NEW_CODEGEN Opt_TryNewCodeGen, -#endif Opt_GenManifest, Opt_EmbedManifest, @@ -2265,7 +2477,6 @@ defaultFlags platform OSDarwin -> case platformArch platform of ArchX86_64 -> [Opt_PIC] - _ | not opt_Static -> [Opt_PIC] _ -> [] _ -> []) @@ -2328,7 +2539,8 @@ optLevelFlags , ([2], Opt_LiberateCase) , ([2], Opt_SpecConstr) - , ([2], Opt_RegsGraph) +-- XXX disabled, see #7192 +-- , ([2], Opt_RegsGraph) , ([0,1,2], Opt_LlvmTBAA) , ([0,1,2], Opt_RegLiveness) , ([1,2], Opt_CmmSink) @@ -2528,6 +2740,12 @@ setDumpFlag :: DynFlag -> OptKind (CmdLineP DynFlags) setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag) -------------------------- +addWay :: Way -> DynP () +addWay w = do upd (\dfs -> dfs { ways = w : ways dfs }) + dfs <- liftEwM getCmdLineState + wayOpts (targetPlatform dfs) w + +-------------------------- setDynFlag, unSetDynFlag :: DynFlag -> DynP () setDynFlag f = upd (\dfs -> dopt_set dfs f) unSetDynFlag f = upd (\dfs -> dopt_unset dfs f) @@ -2671,7 +2889,7 @@ setObjTarget l = updM set return dflags HscLlvm | not ((arch == ArchX86_64) && (os == OSLinux || os == OSDarwin)) && - (not opt_Static || dopt Opt_PIC dflags) + (not (dopt Opt_Static dflags) || dopt Opt_PIC dflags) -> do addWarn ("Ignoring " ++ flag ++ " as it is incompatible with -fPIC and -dynamic on this platform") return dflags @@ -2708,7 +2926,7 @@ unSetFPIC = updM set | platformArch platform == ArchX86_64 -> do addWarn "Ignoring -fno-PIC on this platform" return dflags - _ | not opt_Static -> + _ | not (dopt Opt_Static dflags) -> do addWarn "Ignoring -fno-PIC as -fstatic is off" return dflags _ -> return $ dopt_unset dflags Opt_PIC @@ -2883,7 +3101,8 @@ picCCOpts dflags -- correctly. They need to reference data in the Haskell -- objects, but can't without -fPIC. See -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/PositionIndependentCode - | dopt Opt_PIC dflags || not opt_Static -> ["-fPIC", "-U __PIC__", "-D__PIC__"] + | dopt Opt_PIC dflags || not (dopt Opt_Static dflags) -> + ["-fPIC", "-U __PIC__", "-D__PIC__"] | otherwise -> [] picPOpts :: DynFlags -> [String] @@ -2928,3 +3147,18 @@ 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 dflags + +wORD_SIZE_IN_BITS :: DynFlags -> Int +wORD_SIZE_IN_BITS dflags = wORD_SIZE dflags * 8 + +tAG_MASK :: DynFlags -> Int +tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1 + +mAX_PTR_TAG :: DynFlags -> Int +mAX_PTR_TAG = tAG_MASK + diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 22684126c2..6f9745dbfc 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -1399,7 +1399,9 @@ tryNewCodeGen hsc_env this_mod data_tycons -- We are building a single SRT for the entire module, so -- we must thread it through all the procedures as we cps-convert them. us <- mkSplitUniqSupply 'S' - let initTopSRT = initUs_ us emptySRT + let srt_mod | dopt Opt_SplitObjs dflags = Just this_mod + | otherwise = Nothing + initTopSRT = initUs_ us (emptySRT srt_mod) let run_pipeline topSRT cmmgroup = do (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT cmmgroup diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 793740e96e..7c1f169440 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -744,6 +744,22 @@ emptyModIface mod mi_trust = noIfaceTrustInfo, mi_trust_pkg = False } + +-- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface' +mkIfaceHashCache :: [(Fingerprint,IfaceDecl)] + -> (OccName -> Maybe (OccName, Fingerprint)) +mkIfaceHashCache pairs + = \occ -> lookupOccEnv env occ + where + env = foldr add_decl emptyOccEnv pairs + add_decl (v,d) env0 = foldr add env0 (ifaceDeclFingerprints v d) + where + add (occ,hash) env0 = extendOccEnv env0 occ (occ,hash) + +emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint) +emptyIfaceHashCache _occ = Nothing + + -- | The 'ModDetails' is essentially a cache for information in the 'ModIface' -- for home modules only. Information relating to packages will be loaded into -- global environments in 'ExternalPackageState'. @@ -1460,24 +1476,6 @@ class Monad m => MonadThings m where lookupTyCon = liftM tyThingTyCon . lookupThing \end{code} -\begin{code} --- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface' -mkIfaceHashCache :: [(Fingerprint,IfaceDecl)] - -> (OccName -> Maybe (OccName, Fingerprint)) -mkIfaceHashCache pairs - = \occ -> lookupOccEnv env occ - where - env = foldr add_decl emptyOccEnv pairs - add_decl (v,d) env0 = foldr add_imp env1 (ifaceDeclImplicitBndrs d) - where - decl_name = ifName d - env1 = extendOccEnv env0 decl_name (decl_name, v) - add_imp bndr env = extendOccEnv env bndr (decl_name, v) - -emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint) -emptyIfaceHashCache _occ = Nothing -\end{code} - %************************************************************************ %* * \subsection{Auxiliary types} diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index a797329930..806f8356e6 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -347,7 +347,8 @@ isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool isBreakEnabled hsc_env inf = case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of Just hmi -> do - w <- getBreak (modBreaks_flags (getModBreaks hmi)) + w <- getBreak (hsc_dflags hsc_env) + (modBreaks_flags (getModBreaks hmi)) (breakInfo_number inf) case w of Just n -> return (n /= 0); _other -> return False _ -> diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 5bea131088..87e573e628 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -37,7 +37,6 @@ where import PackageConfig import DynFlags -import StaticFlags import Config ( cProjectVersion ) import Name ( Name, nameModule_maybe ) import UniqFM @@ -883,20 +882,20 @@ packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) where ways0 = ways dflags - ways1 = filter ((/= WayDyn) . wayName) ways0 + ways1 = filter (/= WayDyn) ways0 -- the name of a shared library is libHSfoo-ghc<version>.so -- we leave out the _dyn, because it is superfluous -- debug RTS includes support for -eventlog - ways2 | WayDebug `elem` map wayName ways1 - = filter ((/= WayEventLog) . wayName) ways1 + ways2 | WayDebug `elem` ways1 + = filter (/= WayEventLog) ways1 | otherwise = ways1 tag = mkBuildTag (filter (not . wayRTSOnly) ways2) rts_tag = mkBuildTag ways2 - mkDynName | opt_Static = id + mkDynName | dopt Opt_Static dflags = id | otherwise = (++ ("-ghc" ++ cProjectVersion)) addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag) @@ -1031,12 +1030,12 @@ missingDependencyMsg (Just parent) -- ----------------------------------------------------------------------------- -- | Will the 'Name' come from a dynamically linked library? -isDllName :: PackageId -> Name -> Bool +isDllName :: DynFlags -> PackageId -> Name -> Bool -- Despite the "dll", I think this function just means that -- the synbol comes from another dynamically-linked package, -- and applies on all platforms, not just Windows -isDllName this_pkg name - | opt_Static = False +isDllName dflags this_pkg name + | dopt Opt_Static dflags = False | Just mod <- nameModule_maybe name = modulePackageId mod /= this_pkg | otherwise = False -- no, it is not even an external name diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs index 2b7f95a910..36b32fa45f 100644 --- a/compiler/main/StaticFlagParser.hs +++ b/compiler/main/StaticFlagParser.hs @@ -18,8 +18,7 @@ module StaticFlagParser ( #include "HsVersions.h" import qualified StaticFlags as SF -import StaticFlags ( v_opt_C_ready, getWayFlags, WayName(..) - , opt_SimplExcessPrecision ) +import StaticFlags ( v_opt_C_ready, opt_SimplExcessPrecision ) import CmdLineParser import SrcLoc import Util @@ -60,18 +59,9 @@ parseStaticFlagsFull flagsAvailable args = do ready <- readIORef v_opt_C_ready when ready $ ghcError (ProgramError "Too late for parseStaticFlags: call it before newSession") - (leftover, errs, warns1) <- processArgs flagsAvailable args + (leftover, errs, warns) <- processArgs flagsAvailable args when (not (null errs)) $ ghcError $ errorsToGhcException errs - -- deal with the way flags: the way (eg. prof) gives rise to - -- further flags, some of which might be static. - way_flags <- getWayFlags - let way_flags' = map (mkGeneralLocated "in way flags") way_flags - - -- as these are GHC generated flags, we parse them with all static flags - -- in scope, regardless of what availableFlags are passed in. - (more_leftover, errs, warns2) <- processArgs flagsStatic way_flags' - -- see sanity code in staticOpts writeIORef v_opt_C_ready True @@ -83,9 +73,7 @@ parseStaticFlagsFull flagsAvailable args = do ["-fexcess-precision"] | otherwise = [] - when (not (null errs)) $ ghcError $ errorsToGhcException errs - return (excess_prec ++ more_leftover ++ leftover, - warns1 ++ warns2) + return (excess_prec ++ leftover, warns) flagsStatic :: [Flag IO] -- All the static flags should appear in this list. It describes how each @@ -102,22 +90,8 @@ flagsStatic :: [Flag IO] -- flags further down the list with the same prefix. flagsStatic = [ - ------- ways -------------------------------------------------------- - Flag "prof" (NoArg (addWay WayProf)) - , Flag "eventlog" (NoArg (addWay WayEventLog)) - , Flag "parallel" (NoArg (addWay WayPar)) - , Flag "gransim" (NoArg (addWay WayGran)) - , Flag "smp" (NoArg (addWay WayThreaded >> deprecate "Use -threaded instead")) - , Flag "debug" (NoArg (addWay WayDebug)) - , Flag "ndp" (NoArg (addWay WayNDP)) - , Flag "threaded" (NoArg (addWay WayThreaded)) - - , Flag "ticky" (PassFlag (\f -> do addOpt f; addWay WayDebug)) - -- -ticky enables ticky-ticky code generation, and also implies -debug which - -- is required to get the RTS ticky support. - ------ Debugging ---------------------------------------------------- - , Flag "dppr-debug" (PassFlag addOpt) + Flag "dppr-debug" (PassFlag addOpt) , Flag "dsuppress-all" (PassFlag addOpt) , Flag "dsuppress-uniques" (PassFlag addOpt) , Flag "dsuppress-coercions" (PassFlag addOpt) @@ -126,17 +100,9 @@ flagsStatic = [ , Flag "dsuppress-idinfo" (PassFlag addOpt) , Flag "dsuppress-var-kinds" (PassFlag addOpt) , Flag "dsuppress-type-signatures" (PassFlag addOpt) - , Flag "dopt-fuel" (AnySuffix addOpt) , Flag "dno-debug-output" (PassFlag addOpt) - , Flag "dstub-dead-values" (PassFlag addOpt) -- rest of the debugging flags are dynamic - ----- Linker -------------------------------------------------------- - , Flag "static" (PassFlag addOpt) - , Flag "dynamic" (NoArg (removeOpt "-static" >> addWay WayDyn)) - -- ignored for compat w/ gcc: - , Flag "rdynamic" (NoArg (return ())) - ----- RTS opts ------------------------------------------------------ , Flag "H" (HasArg (\s -> liftEwM (setHeapSize (fromIntegral (decodeSize s))))) @@ -166,7 +132,6 @@ isStaticFlag f = "fno-pre-inlining", "fno-opt-coercion", "fexcess-precision", - "static", "fhardwire-lib-paths", "fcpr-off", "ferror-spans", @@ -175,7 +140,6 @@ isStaticFlag f = || any (`isPrefixOf` f) [ "fliberate-case-threshold", "fmax-worker-args", - "fhistory-size", "funfolding-creation-threshold", "funfolding-dict-threshold", "funfolding-use-threshold", @@ -203,9 +167,6 @@ type StaticP = EwM IO addOpt :: String -> StaticP () addOpt = liftEwM . SF.addOpt -addWay :: WayName -> StaticP () -addWay = liftEwM . SF.addWay - removeOpt :: String -> StaticP () removeOpt = liftEwM . SF.removeOpt diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index 2334940492..3165c6944b 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -23,9 +23,6 @@ module StaticFlags ( staticFlags, initStaticOpts, - -- Ways - WayName(..), Way(..), v_Ways, isRTSWay, mkBuildTag, - -- Output style options opt_PprStyle_Debug, opt_NoDebugOutput, @@ -40,9 +37,6 @@ module StaticFlags ( opt_SuppressTypeSignatures, opt_SuppressVarKinds, - -- Hpc opts - opt_Hpc, - -- language opts opt_DictsStrict, @@ -63,21 +57,11 @@ module StaticFlags ( opt_UF_KeenessFactor, opt_UF_DearOp, - -- Optimization fuel controls - opt_Fuel, - - -- Related to linking - opt_Static, - -- misc opts opt_ErrorSpans, - opt_HistorySize, - v_Ld_inputs, - opt_StubDeadValues, - opt_Ticky, -- For the parser - addOpt, removeOpt, addWay, getWayFlags, v_opt_C_ready, + addOpt, removeOpt, v_opt_C_ready, -- Saving/restoring globals saveStaticFlagGlobals, restoreStaticFlagGlobals @@ -90,9 +74,7 @@ import Util import Maybes ( firstJusts ) import Panic -import Control.Monad ( liftM3 ) -import Data.Function -import Data.Maybe ( listToMaybe ) +import Control.Monad import Data.IORef import System.IO.Unsafe ( unsafePerformIO ) import Data.List @@ -106,9 +88,6 @@ initStaticOpts = writeIORef v_opt_C_ready True addOpt :: String -> IO () addOpt = consIORef v_opt_C -addWay :: WayName -> IO () -addWay = consIORef v_Ways . lkupWay - removeOpt :: String -> IO () removeOpt f = do fs <- readIORef v_opt_C @@ -121,7 +100,7 @@ lookup_str :: String -> Maybe String -- holds the static opts while they're being collected, before -- being unsafely read by unpacked_static_opts below. -GLOBAL_VAR(v_opt_C, defaultStaticOpts, [String]) +GLOBAL_VAR(v_opt_C, [], [String]) GLOBAL_VAR(v_opt_C_ready, False, Bool) staticFlags :: [String] @@ -131,10 +110,6 @@ staticFlags = unsafePerformIO $ do then panic "Static flags have not been initialised!\n Please call GHC.newSession or GHC.parseStaticFlags early enough." else readIORef v_opt_C --- -static is the default -defaultStaticOpts :: [String] -defaultStaticOpts = ["-static"] - packed_static_opts :: [FastString] packed_static_opts = map mkFastString staticFlags @@ -238,16 +213,9 @@ opt_SuppressUniques opt_PprStyle_Debug :: Bool opt_PprStyle_Debug = lookUp (fsLit "-dppr-debug") -opt_Fuel :: Int -opt_Fuel = lookup_def_int "-dopt-fuel" maxBound - opt_NoDebugOutput :: Bool opt_NoDebugOutput = lookUp (fsLit "-dno-debug-output") --- Hpc opts -opt_Hpc :: Bool -opt_Hpc = lookUp (fsLit "-fhpc") - -- language opts opt_DictsStrict :: Bool opt_DictsStrict = lookUp (fsLit "-fdicts-strict") @@ -264,12 +232,6 @@ opt_CprOff = lookUp (fsLit "-fcpr-off") opt_MaxWorkerArgs :: Int opt_MaxWorkerArgs = lookup_def_int "-fmax-worker-args" (10::Int) -opt_HistorySize :: Int -opt_HistorySize = lookup_def_int "-fhistory-size" 20 - -opt_StubDeadValues :: Bool -opt_StubDeadValues = lookUp (fsLit "-dstub-dead-values") - -- Simplifier switches opt_SimplNoPreInlining :: Bool opt_SimplNoPreInlining = lookUp (fsLit "-fno-pre-inlining") @@ -305,213 +267,18 @@ opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (1.5::Fl opt_UF_DearOp = ( 40 :: Int) --- Related to linking -opt_Static :: Bool -opt_Static = lookUp (fsLit "-static") - -- Include full span info in error messages, instead of just the start position. opt_ErrorSpans :: Bool opt_ErrorSpans = lookUp (fsLit "-ferror-spans") -opt_Ticky :: Bool -opt_Ticky = lookUp (fsLit "-ticky") - --- object files and libraries to be linked in are collected here. --- ToDo: perhaps this could be done without a global, it wasn't obvious --- how to do it though --SDM. -GLOBAL_VAR(v_Ld_inputs, [], [String]) - ------------------------------------------------------------------------------ --- Ways - --- The central concept of a "way" is that all objects in a given --- program must be compiled in the same "way". Certain options change --- parameters of the virtual machine, eg. profiling adds an extra word --- to the object header, so profiling objects cannot be linked with --- non-profiling objects. - --- After parsing the command-line options, we determine which "way" we --- are building - this might be a combination way, eg. profiling+threaded. - --- We then find the "build-tag" associated with this way, and this --- becomes the suffix used to find .hi files and libraries used in --- this compilation. - -data WayName - = WayThreaded - | WayDebug - | WayProf - | WayEventLog - | WayPar - | WayGran - | WayNDP - | WayDyn - deriving (Eq,Ord) - -GLOBAL_VAR(v_Ways, [] ,[Way]) - -allowed_combination :: [WayName] -> Bool -allowed_combination way = and [ x `allowedWith` y - | x <- way, y <- way, x < y ] - where - -- Note ordering in these tests: the left argument is - -- <= the right argument, according to the Ord instance - -- on Way above. - - -- dyn is allowed with everything - _ `allowedWith` WayDyn = True - WayDyn `allowedWith` _ = True - - -- debug is allowed with everything - _ `allowedWith` WayDebug = True - WayDebug `allowedWith` _ = True - - WayProf `allowedWith` WayNDP = True - WayThreaded `allowedWith` WayProf = True - WayThreaded `allowedWith` WayEventLog = True - _ `allowedWith` _ = False - - -getWayFlags :: IO [String] -- new options -getWayFlags = do - unsorted <- readIORef v_Ways - let ways = sortBy (compare `on` wayName) $ - nubBy ((==) `on` wayName) $ unsorted - writeIORef v_Ways ways - - if not (allowed_combination (map wayName ways)) - then ghcError (CmdLineError $ - "combination not supported: " ++ - foldr1 (\a b -> a ++ '/':b) - (map wayDesc ways)) - else - return (concatMap wayOpts ways) - -mkBuildTag :: [Way] -> String -mkBuildTag ways = concat (intersperse "_" (map wayTag ways)) - -lkupWay :: WayName -> Way -lkupWay w = - case listToMaybe (filter ((==) w . wayName) way_details) of - Nothing -> error "findBuildTag" - Just details -> details - -isRTSWay :: WayName -> Bool -isRTSWay = wayRTSOnly . lkupWay - -data Way = Way { - wayName :: WayName, - wayTag :: String, - wayRTSOnly :: Bool, - wayDesc :: String, - wayOpts :: [String] - } - -way_details :: [ Way ] -way_details = - [ Way WayThreaded "thr" True "Threaded" [ -#if defined(freebsd_TARGET_OS) --- "-optc-pthread" --- , "-optl-pthread" - -- FreeBSD's default threading library is the KSE-based M:N libpthread, - -- which GHC has some problems with. It's currently not clear whether - -- the problems are our fault or theirs, but it seems that using the - -- alternative 1:1 threading library libthr works around it: - "-optl-lthr" -#elif defined(openbsd_TARGET_OS) || defined(netbsd_TARGET_OS) - "-optc-pthread" - , "-optl-pthread" -#elif defined(solaris2_TARGET_OS) - "-optl-lrt" -#endif - ], - - Way WayDebug "debug" True "Debug" [], - - Way WayDyn "dyn" False "Dynamic" - [ "-DDYNAMIC" - , "-optc-DDYNAMIC" -#if defined(mingw32_TARGET_OS) - -- On Windows, code that is to be linked into a dynamic library must be compiled - -- with -fPIC. Labels not in the current package are assumed to be in a DLL - -- different from the current one. - , "-fPIC" -#elif defined(openbsd_TARGET_OS) || defined(netbsd_TARGET_OS) - -- Without this, linking the shared libHSffi fails because - -- it uses pthread mutexes. - , "-optl-pthread" -#endif - ], - - Way WayProf "p" False "Profiling" - [ "-fscc-profiling" - , "-DPROFILING" - , "-optc-DPROFILING" ], - - Way WayEventLog "l" True "RTS Event Logging" - [ "-DTRACING" - , "-optc-DTRACING" ], - - Way WayPar "mp" False "Parallel" - [ "-fparallel" - , "-D__PARALLEL_HASKELL__" - , "-optc-DPAR" - , "-package concurrent" - , "-optc-w" - , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}" - , "-optl-lpvm3" - , "-optl-lgpvm3" ], - - -- at the moment we only change the RTS and could share compiler and libs! - Way WayPar "mt" False "Parallel ticky profiling" - [ "-fparallel" - , "-D__PARALLEL_HASKELL__" - , "-optc-DPAR" - , "-optc-DPAR_TICKY" - , "-package concurrent" - , "-optc-w" - , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}" - , "-optl-lpvm3" - , "-optl-lgpvm3" ], - - Way WayPar "md" False "Distributed" - [ "-fparallel" - , "-D__PARALLEL_HASKELL__" - , "-D__DISTRIBUTED_HASKELL__" - , "-optc-DPAR" - , "-optc-DDIST" - , "-package concurrent" - , "-optc-w" - , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}" - , "-optl-lpvm3" - , "-optl-lgpvm3" ], - - Way WayGran "mg" False "GranSim" - [ "-fgransim" - , "-D__GRANSIM__" - , "-optc-DGRAN" - , "-package concurrent" ], - - Way WayNDP "ndp" False "Nested data parallelism" - [ "-XParr" - , "-fvectorise"] - ] - ----------------------------------------------------------------------------- -- Tunneling our global variables into a new instance of the GHC library --- Ignore the v_Ld_inputs global because: --- a) It is mutated even once GHC has been initialised, which means that I'd --- have to add another layer of indirection to truly share the value --- b) We can get away without sharing it because it only affects the link, --- and is mutated by the GHC exe. Users who load up a new copy of the GHC --- library while another is running almost certainly won't actually access it. -saveStaticFlagGlobals :: IO (Bool, [String], [Way]) -saveStaticFlagGlobals = liftM3 (,,) (readIORef v_opt_C_ready) (readIORef v_opt_C) (readIORef v_Ways) - -restoreStaticFlagGlobals :: (Bool, [String], [Way]) -> IO () -restoreStaticFlagGlobals (c_ready, c, ways) = do +saveStaticFlagGlobals :: IO (Bool, [String]) +saveStaticFlagGlobals = liftM2 (,) (readIORef v_opt_C_ready) (readIORef v_opt_C) + +restoreStaticFlagGlobals :: (Bool, [String]) -> IO () +restoreStaticFlagGlobals (c_ready, c) = do writeIORef v_opt_C_ready c_ready writeIORef v_opt_C c - writeIORef v_Ways ways 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/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index bea9f14ee6..ffd5de809d 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -47,7 +47,6 @@ import Module import Packages( isDllName ) import HscTypes import Maybes -import Platform import UniqSupply import ErrUtils (Severity(..)) import Outputable @@ -1049,20 +1048,20 @@ tidyTopBinds hsc_env unfold_env init_occ_env binds $ initTcForLookup hsc_env (tcLookupGlobal mkIntegerName) return $ tidy mkIntegerId init_env binds where - platform = targetPlatform (hsc_dflags hsc_env) + dflags = hsc_dflags hsc_env init_env = (init_occ_env, emptyVarEnv) - this_pkg = thisPackage (hsc_dflags hsc_env) + this_pkg = thisPackage dflags tidy _ env [] = (env, []) - tidy mkIntegerId env (b:bs) = let (env1, b') = tidyTopBind platform this_pkg mkIntegerId unfold_env env b + tidy mkIntegerId env (b:bs) = let (env1, b') = tidyTopBind dflags this_pkg mkIntegerId unfold_env env b (env2, bs') = tidy mkIntegerId env1 bs in (env2, b':bs') ------------------------ -tidyTopBind :: Platform +tidyTopBind :: DynFlags -> PackageId -> Id -> UnfoldEnv @@ -1070,16 +1069,16 @@ tidyTopBind :: Platform -> CoreBind -> (TidyEnv, CoreBind) -tidyTopBind platform this_pkg mkIntegerId unfold_env (occ_env,subst1) (NonRec bndr rhs) +tidyTopBind dflags this_pkg mkIntegerId unfold_env (occ_env,subst1) (NonRec bndr rhs) = (tidy_env2, NonRec bndr' rhs') where Just (name',show_unfold) = lookupVarEnv unfold_env bndr - caf_info = hasCafRefs platform this_pkg (mkIntegerId, subst1) (idArity bndr) rhs + caf_info = hasCafRefs dflags this_pkg (mkIntegerId, subst1) (idArity bndr) rhs (bndr', rhs') = tidyTopPair show_unfold tidy_env2 caf_info name' (bndr, rhs) subst2 = extendVarEnv subst1 bndr bndr' tidy_env2 = (occ_env, subst2) -tidyTopBind platform this_pkg mkIntegerId unfold_env (occ_env,subst1) (Rec prs) +tidyTopBind dflags this_pkg mkIntegerId unfold_env (occ_env,subst1) (Rec prs) = (tidy_env2, Rec prs') where prs' = [ tidyTopPair show_unfold tidy_env2 caf_info name' (id,rhs) @@ -1096,7 +1095,7 @@ tidyTopBind platform this_pkg mkIntegerId unfold_env (occ_env,subst1) (Rec prs) -- the CafInfo for a recursive group says whether *any* rhs in -- the group may refer indirectly to a CAF (because then, they all do). caf_info - | or [ mayHaveCafRefs (hasCafRefs platform this_pkg (mkIntegerId, subst1) (idArity bndr) rhs) + | or [ mayHaveCafRefs (hasCafRefs dflags this_pkg (mkIntegerId, subst1) (idArity bndr) rhs) | (bndr,rhs) <- prs ] = MayHaveCafRefs | otherwise = NoCafRefs @@ -1233,15 +1232,15 @@ it as a CAF. In these cases however, we would need to use an additional CAF list to keep track of non-collectable CAFs. \begin{code} -hasCafRefs :: Platform -> PackageId -> (Id, VarEnv Var) -> Arity -> CoreExpr +hasCafRefs :: DynFlags -> PackageId -> (Id, VarEnv Var) -> Arity -> CoreExpr -> CafInfo -hasCafRefs platform this_pkg p arity expr +hasCafRefs dflags this_pkg p arity expr | is_caf || mentions_cafs = MayHaveCafRefs | otherwise = NoCafRefs where mentions_cafs = isFastTrue (cafRefsE p expr) - is_dynamic_name = isDllName this_pkg - is_caf = not (arity > 0 || rhsIsStatic platform is_dynamic_name expr) + is_dynamic_name = isDllName dflags this_pkg + is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name expr) -- NB. we pass in the arity of the expression, which is expected -- to be calculated by exprArity. This is because exprArity 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 67945669f5..af4bb9e9ed 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -65,6 +65,7 @@ import Reg import NCGMonad +import Hoopl import OldCmm import CLabel ( CLabel, ForeignLabelSource(..), pprCLabel, mkDynamicLinkerLabel, DynamicLinkerLabelInfo(..), @@ -74,7 +75,6 @@ import CLabel ( CLabel, ForeignLabelSource(..), pprCLabel, import CLabel ( mkForeignLabel ) -import StaticFlags ( opt_Static ) import BasicTypes import Outputable @@ -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: @@ -160,8 +160,8 @@ cmmMakePicReference dflags lbl = CmmLit $ CmmLabel lbl - | (dopt Opt_PIC dflags || not opt_Static) && absoluteLabel lbl - = CmmMachOp (MO_Add wordWidth) + | (dopt Opt_PIC dflags || not (dopt Opt_Static dflags)) && absoluteLabel lbl + = CmmMachOp (MO_Add (wordWidth dflags)) [ CmmReg (CmmGlobal PicBaseReg) , CmmLit $ picRelative (platformArch $ targetPlatform dflags) @@ -213,14 +213,14 @@ howToAccessLabel -- To access the function at SYMBOL from our local module, we just need to -- dereference the local __imp_SYMBOL. -- --- If opt_Static is set then we assume that all our code will be linked +-- If Opt_Static is set then we assume that all our code will be linked -- into the same .exe file. In this case we always access symbols directly, -- and never use __imp_SYMBOL. -- howToAccessLabel dflags _ OSMinGW32 _ lbl -- Assume all symbols will be in the same PE, so just access them directly. - | opt_Static + | dopt Opt_Static dflags = AccessDirectly -- If the target symbol is in another PE we need to access it via the @@ -306,7 +306,7 @@ howToAccessLabel dflags _ os _ _ -- if we don't dynamically link to Haskell code, -- it actually manages to do so without messing thins up. | osElfTarget os - , not (dopt Opt_PIC dflags) && opt_Static + , not (dopt Opt_PIC dflags) && dopt Opt_Static dflags = AccessDirectly howToAccessLabel dflags arch os DataReference lbl @@ -428,12 +428,12 @@ needImportedSymbols dflags arch os -- PowerPC Linux: -fPIC or -dynamic | osElfTarget os , arch == ArchPPC - = dopt Opt_PIC dflags || not opt_Static + = dopt Opt_PIC dflags || not (dopt Opt_Static dflags) -- i386 (and others?): -dynamic but not -fPIC | osElfTarget os , arch /= ArchPPC_64 - = not opt_Static && not (dopt Opt_PIC dflags) + = not (dopt Opt_Static dflags) && not (dopt Opt_PIC dflags) | otherwise = False @@ -622,7 +622,7 @@ pprImportedSymbol _ (Platform { platformOS = OSDarwin }) _ -- section. -- The "official" GOT mechanism (label@got) isn't intended to be used -- in position dependent code, so we have to create our own "fake GOT" --- when not Opt_PIC && not opt_Static. +-- when not Opt_PIC && not (dopt Opt_Static dflags). -- -- 2) PowerPC Linux is just plain broken. -- While it's theoretically possible to use GOT offsets larger @@ -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 @@ -752,18 +753,37 @@ initializePicBase_x86 -> NatM [NatCmmDecl (Alignment, CmmStatics) X86.Instr] initializePicBase_x86 ArchX86 os picReg - (CmmProc info lab (ListGraph blocks) : statics) + (CmmProc info lab (ListGraph blocks) : statics) | osElfTarget os - = return (CmmProc info lab (ListGraph (b':tail blocks)) : statics) - where BasicBlock bID insns = head blocks - b' = BasicBlock bID (X86.FETCHGOT picReg : insns) + = return (CmmProc info lab (ListGraph blocks') : statics) + where blocks' = case blocks of + [] -> [] + (b:bs) -> fetchGOT b : map maybeFetchGOT bs + + -- we want to add a FETCHGOT instruction to the beginning of + -- every block that is an entry point, which corresponds to + -- the blocks that have entries in the info-table mapping. + maybeFetchGOT b@(BasicBlock bID _) + | bID `mapMember` info = fetchGOT b + | otherwise = b + + fetchGOT (BasicBlock bID insns) = + BasicBlock bID (X86.FETCHGOT picReg : insns) initializePicBase_x86 ArchX86 OSDarwin picReg (CmmProc info lab (ListGraph blocks) : statics) - = return (CmmProc info lab (ListGraph (b':tail blocks)) : statics) + = return (CmmProc info lab (ListGraph blocks') : statics) - where BasicBlock bID insns = head blocks - b' = BasicBlock bID (X86.FETCHPC picReg : insns) + where blocks' = case blocks of + [] -> [] + (b:bs) -> fetchPC b : map maybeFetchPC bs + + maybeFetchPC b@(BasicBlock bID _) + | bID `mapMember` info = fetchPC b + | otherwise = b + + fetchPC (BasicBlock bID insns) = + BasicBlock bID (X86.FETCHPC picReg : insns) initializePicBase_x86 _ _ _ _ = panic "initializePicBase_x86: not needed" diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index ce4a54ca9b..1f036aa43e 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) @@ -1376,10 +1379,10 @@ coerceInt2FP fromRep toRep x = do [CmmStaticLit (CmmInt 0x43300000 W32), CmmStaticLit (CmmInt 0x80000000 W32)], XORIS itmp src (ImmInt 0x8000), - ST II32 itmp (spRel 3), + ST II32 itmp (spRel dflags 3), LIS itmp (ImmInt 0x4330), - ST II32 itmp (spRel 2), - LD FF64 ftmp (spRel 2) + ST II32 itmp (spRel dflags 2), + LD FF64 ftmp (spRel dflags 2) ] `appOL` addr_code `appOL` toOL [ LD FF64 dst addr, FSUB FF64 dst ftmp dst @@ -1401,6 +1404,7 @@ coerceInt2FP fromRep toRep x = do coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register coerceFP2Int _ toRep x = do + dflags <- getDynFlags -- the reps don't really matter: F*->FF64 and II32->I* are no-ops (src, code) <- getSomeReg x tmp <- getNewRegNat FF64 @@ -1409,7 +1413,7 @@ coerceFP2Int _ toRep x = do -- convert to int in FP reg FCTIWZ tmp src, -- store value (64bit) from FP to stack - ST FF64 tmp (spRel 2), + ST FF64 tmp (spRel dflags 2), -- read low word of value (high word is undefined) - LD II32 dst (spRel 3)] + LD II32 dst (spRel dflags 3)] return (Any (intSize toRep) code') 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/PPC/Regs.hs b/compiler/nativeGen/PPC/Regs.hs index 7dccb6040e..d4123aca84 100644 --- a/compiler/nativeGen/PPC/Regs.hs +++ b/compiler/nativeGen/PPC/Regs.hs @@ -55,8 +55,8 @@ import CLabel ( CLabel ) import Unique import CodeGen.Platform +import DynFlags import Outputable -import Constants import FastBool import FastTypes import Platform @@ -194,10 +194,11 @@ addrOffset addr off -- temporaries and for excess call arguments. @fpRel@, where -- applicable, is the same but for the frame pointer. -spRel :: Int -- desired stack offset in words, positive or negative +spRel :: DynFlags + -> Int -- desired stack offset in words, positive or negative -> AddrMode -spRel n = AddrRegImm sp (ImmInt (n * wORD_SIZE)) +spRel dflags n = AddrRegImm sp (ImmInt (n * wORD_SIZE dflags)) -- argRegs is the set of regs which are read for an n-argument call to C. 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..b83ede89aa 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -52,7 +52,6 @@ import Outputable import Unique import FastString import FastBool ( isFastTrue ) -import Constants ( wORD_SIZE ) import DynFlags import Util @@ -141,6 +140,7 @@ stmtsToInstrs stmts stmtToInstrs :: CmmStmt -> NatM InstrBlock stmtToInstrs stmt = do + dflags <- getDynFlags is32Bit <- is32BitPlatform case stmt of CmmNop -> return nilOL @@ -150,14 +150,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 +168,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 +274,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 +285,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 +406,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 +424,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 +491,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 +634,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 +812,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 +837,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 +861,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 +877,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 +956,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 +1046,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 +1100,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 +1277,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 +1320,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 +1717,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,19 +1754,20 @@ 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) - raw_arg_size = sum sizes + wORD_SIZE + sizes = map (arg_size . cmmExprType dflags . hintlessCmm) (reverse args) + raw_arg_size = sum sizes + wORD_SIZE dflags arg_pad_size = (roundTo 16 $ raw_arg_size) - raw_arg_size - tot_arg_size = raw_arg_size + arg_pad_size - wORD_SIZE + tot_arg_size = raw_arg_size + arg_pad_size - wORD_SIZE dflags delta0 <- getDeltaNat setDeltaNat (delta0 - arg_pad_size) @@ -1780,7 +1785,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 +1901,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 +1958,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 +1993,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) <- @@ -2021,14 +2025,14 @@ genCCall64' platform target dest_regs args = do -- alignment of 16n - word_size on procedure entry. Which we -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86] (real_size, adjust_rsp) <- - if (tot_arg_size + wORD_SIZE) `rem` 16 == 0 + if (tot_arg_size + wORD_SIZE dflags) `rem` 16 == 0 then return (tot_arg_size, nilOL) else do -- we need to adjust... delta <- getDeltaNat - setDeltaNat (delta - wORD_SIZE) - return (tot_arg_size + wORD_SIZE, toOL [ - SUB II64 (OpImm (ImmInt wORD_SIZE)) (OpReg rsp), - DELTA (delta - wORD_SIZE) ]) + setDeltaNat (delta - wORD_SIZE dflags) + return (tot_arg_size + wORD_SIZE dflags, toOL [ + SUB II64 (OpImm (ImmInt (wORD_SIZE dflags))) (OpReg rsp), + DELTA (delta - wORD_SIZE dflags) ]) -- push the stack args, right to left push_code <- push_args (reverse stack_args) nilOL @@ -2070,7 +2074,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 +2101,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 +2127,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 +2161,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,9 +2170,9 @@ 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))] + MOV (floatSize width) (OpReg arg_reg) (OpAddr (spRel dflags 0))] push_args rest code' | otherwise = do @@ -2183,14 +2188,14 @@ 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 delta <- getDeltaNat setDeltaNat (delta - n * arg_size) return $ toOL [ - SUB II64 (OpImm (ImmInt (n * wORD_SIZE))) (OpReg rsp), + SUB II64 (OpImm (ImmInt (n * wORD_SIZE dflags))) (OpReg rsp), DELTA (delta - n * arg_size)] -- | We're willing to inline and unroll memcpy/memset calls that touch @@ -2282,11 +2287,11 @@ genSwitch dflags expr ids dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl (tableReg,t_code) <- getSomeReg $ dynRef let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) - (EAIndex reg wORD_SIZE) (ImmInt 0)) + (EAIndex reg (wORD_SIZE dflags)) (ImmInt 0)) 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 +2304,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,14 +2318,14 @@ 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 = do (reg,e_code) <- getSomeReg expr lbl <- getNewLabelNat - let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg wORD_SIZE) (ImmCLbl lbl)) + let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (wORD_SIZE dflags)) (ImmCLbl lbl)) code = e_code `appOL` toOL [ JMP_TBL op ids ReadOnlyData lbl ] @@ -2337,12 +2342,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..7f0e48e769 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,62 +613,65 @@ 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 RcInteger -> MOV (archWordSize is32Bit) - (OpReg reg) (OpAddr (spRel platform off_w)) - RcDouble -> GST FF80 reg (spRel platform off_w) {- RcFloat/RcDouble -} - RcDoubleSSE -> MOV FF64 (OpReg reg) (OpAddr (spRel platform off_w)) + (OpReg reg) (OpAddr (spRel dflags off_w)) + RcDouble -> GST FF80 reg (spRel dflags off_w) {- RcFloat/RcDouble -} + RcDoubleSSE -> MOV FF64 (OpReg reg) (OpAddr (spRel dflags 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 RcInteger -> MOV (archWordSize is32Bit) - (OpAddr (spRel platform off_w)) (OpReg reg) - RcDouble -> GLD FF80 (spRel platform off_w) reg {- RcFloat/RcDouble -} - RcDoubleSSE -> MOV FF64 (OpAddr (spRel platform off_w)) (OpReg reg) + (OpAddr (spRel dflags off_w)) (OpReg reg) + RcDouble -> GLD FF80 (spRel dflags off_w) reg {- RcFloat/RcDouble -} + RcDoubleSSE -> MOV FF64 (OpAddr (spRel dflags 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..4eec96f5e1 100644 --- a/compiler/nativeGen/X86/Regs.hs +++ b/compiler/nativeGen/X86/Regs.hs @@ -54,11 +54,11 @@ import RegClass import OldCmm import CmmCallConv import CLabel ( CLabel ) +import DynFlags import Outputable import Platform import FastTypes import FastBool -import Constants -- | regSqueeze_class reg @@ -195,14 +195,14 @@ addrModeRegs _ = [] -- applicable, is the same but for the frame pointer. -spRel :: Platform +spRel :: DynFlags -> Int -- ^ desired stack offset in words, positive or negative -> AddrMode -spRel platform n - | target32Bit platform - = AddrBaseIndex (EABaseReg esp) EAIndexNone (ImmInt (n * wORD_SIZE)) +spRel dflags n + | target32Bit (targetPlatform dflags) + = AddrBaseIndex (EABaseReg esp) EAIndexNone (ImmInt (n * wORD_SIZE dflags)) | otherwise - = AddrBaseIndex (EABaseReg rsp) EAIndexNone (ImmInt (n * wORD_SIZE)) + = AddrBaseIndex (EABaseReg rsp) EAIndexNone (ImmInt (n * wORD_SIZE dflags)) -- The register numbers must fit into 32 bits on x86, so that we can -- use a Word32 to represent the set of free registers in the register @@ -440,8 +440,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/parser/Lexer.x b/compiler/parser/Lexer.x index b872a7d953..91f00ecf2f 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -57,7 +57,7 @@ module Lexer ( extension, bangPatEnabled, datatypeContextsEnabled, traditionalRecordSyntaxEnabled, typeLiteralsEnabled, - explicitNamespacesEnabled, sccProfilingOn, + explicitNamespacesEnabled, sccProfilingOn, hpcEnabled, addWarning, lexTokenStream ) where @@ -1851,6 +1851,8 @@ rawTokenStreamBit :: Int rawTokenStreamBit = 20 -- producing a token stream with all comments included sccProfilingOnBit :: Int sccProfilingOnBit = 21 +hpcBit :: Int +hpcBit = 22 alternativeLayoutRuleBit :: Int alternativeLayoutRuleBit = 23 relaxedLayoutBit :: Int @@ -1907,6 +1909,8 @@ rawTokenStreamEnabled :: Int -> Bool rawTokenStreamEnabled flags = testBit flags rawTokenStreamBit alternativeLayoutRule :: Int -> Bool alternativeLayoutRule flags = testBit flags alternativeLayoutRuleBit +hpcEnabled :: Int -> Bool +hpcEnabled flags = testBit flags hpcBit relaxedLayout :: Int -> Bool relaxedLayout flags = testBit flags relaxedLayoutBit nondecreasingIndentation :: Int -> Bool @@ -1977,6 +1981,7 @@ mkPState flags buf loc = .|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags .|. transformComprehensionsBit `setBitIf` xopt Opt_MonadComprehensions flags .|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags + .|. hpcBit `setBitIf` dopt Opt_Hpc flags .|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags .|. sccProfilingOnBit `setBitIf` dopt Opt_SccProfilingOn flags diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 410f95bebf..718adcabfd 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -24,6 +24,16 @@ to inline certain key external functions, so we instruct GHC not to throw away inlinings as it would normally do in -O0 mode. -} +-- CPP tricks because we want the directives in the output of the +-- first CPP pass. +#define __IF_GHC_77__ #if __GLASGOW_HASKELL__ >= 707 +#define __ENDIF__ #endif +__IF_GHC_77__ +-- Required on x86 to avoid the register allocator running out of +-- stack slots when compiling this module with -fPIC -dynamic. +{-# OPTIONS_GHC -fcmm-sink #-} +__ENDIF__ + module Parser ( parseModule, parseStmt, parseIdentifier, parseType, parseHeader ) where @@ -43,7 +53,6 @@ import OccName ( varName, dataName, tcClsName, tvName ) import DataCon ( DataCon, dataConName ) import SrcLoc import Module -import StaticFlags ( opt_Hpc ) import Kind ( Kind, liftedTypeKind, unliftedTypeKind, mkArrowKind ) import Class ( FunDep ) import BasicTypes @@ -1406,9 +1415,10 @@ exp10 :: { LHsExpr RdrName } ; return $ LL $ if on then HsSCC (unLoc $1) $2 else HsPar $2 } } - | hpc_annot exp { LL $ if opt_Hpc - then HsTickPragma (unLoc $1) $2 - else HsPar $2 } + | hpc_annot exp {% do { on <- extension hpcEnabled + ; return $ LL $ if on + then HsTickPragma (unLoc $1) $2 + else HsPar $2 } } | 'proc' aexp '->' exp {% checkPattern $2 >>= \ p -> diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index b1429c5dbf..9af48b4b81 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -480,7 +480,8 @@ zeroSimplCount :: DynFlags -> SimplCount isZeroSimplCount :: SimplCount -> Bool hasDetailedCounts :: SimplCount -> Bool pprSimplCount :: SimplCount -> SDoc -doSimplTick, doFreeSimplTick :: Tick -> SimplCount -> SimplCount +doSimplTick :: DynFlags -> Tick -> SimplCount -> SimplCount +doFreeSimplTick :: Tick -> SimplCount -> SimplCount plusSimplCount :: SimplCount -> SimplCount -> SimplCount \end{code} @@ -525,13 +526,14 @@ doFreeSimplTick tick sc@SimplCount { details = dts } = sc { details = dts `addTick` tick } doFreeSimplTick _ sc = sc -doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 } - | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 } - | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 } +doSimplTick dflags tick + sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }) + | nl >= historySize dflags = sc1 { n_log = 1, log1 = [tick], log2 = l1 } + | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 } where sc1 = sc { ticks = tks+1, details = dts `addTick` tick } -doSimplTick _ (VerySimplCount n) = VerySimplCount (n+1) +doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1) -- Don't use Map.unionWith because that's lazy, and we want to @@ -720,7 +722,7 @@ data CoreReader = CoreReader { cr_hsc_env :: HscEnv, cr_rule_base :: RuleBase, cr_module :: Module, - cr_globals :: ((Bool, [String], [Way]), + cr_globals :: ((Bool, [String]), #ifdef GHCI (MVar PersistentLinkerState, Bool)) #else diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs index 04b8c4e6d5..9d9856923a 100644 --- a/compiler/simplCore/SimplMonad.lhs +++ b/compiler/simplCore/SimplMonad.lhs @@ -182,15 +182,15 @@ getSimplCount :: SimplM SimplCount getSimplCount = SM (\_st_env us sc -> return (sc, us, sc)) tick :: Tick -> SimplM () -tick t = SM (\_st_env us sc -> let sc' = doSimplTick t sc - in sc' `seq` return ((), us, sc')) +tick t = SM (\st_env us sc -> let sc' = doSimplTick (st_flags st_env) t sc + in sc' `seq` return ((), us, sc')) checkedTick :: Tick -> SimplM () -- Try to take a tick, but fail if too many checkedTick t = SM (\st_env us sc -> if st_max_ticks st_env <= simplCountN sc then pprPanic "Simplifier ticks exhausted" (msg sc) - else let sc' = doSimplTick t sc + else let sc' = doSimplTick (st_flags st_env) t sc in sc' `seq` return ((), us, sc')) where msg sc = vcat [ ptext (sLit "When trying") <+> ppr t 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/simplStg/UnariseStg.lhs b/compiler/simplStg/UnariseStg.lhs index ac439ebfd3..b1717ad120 100644 --- a/compiler/simplStg/UnariseStg.lhs +++ b/compiler/simplStg/UnariseStg.lhs @@ -67,56 +67,102 @@ unarise us binds = zipWith (\us -> unariseBinding us init_env) (listSplitUniqSup unariseBinding :: UniqSupply -> UnariseEnv -> StgBinding -> StgBinding unariseBinding us rho bind = case bind of StgNonRec x rhs -> StgNonRec x (unariseRhs us rho rhs) - StgRec xrhss -> StgRec $ zipWith (\us (x, rhs) -> (x, unariseRhs us rho rhs)) (listSplitUniqSupply us) xrhss + StgRec xrhss -> StgRec $ zipWith (\us (x, rhs) -> (x, unariseRhs us rho rhs)) + (listSplitUniqSupply us) xrhss unariseRhs :: UniqSupply -> UnariseEnv -> StgRhs -> StgRhs unariseRhs us rho rhs = case rhs of StgRhsClosure ccs b_info fvs update_flag srt args expr - -> StgRhsClosure ccs b_info (unariseIds rho fvs) update_flag (unariseSRT rho srt) args' (unariseExpr us' rho' expr) + -> StgRhsClosure ccs b_info (unariseIds rho fvs) update_flag + (unariseSRT rho srt) args' (unariseExpr us' rho' expr) where (us', rho', args') = unariseIdBinders us rho args StgRhsCon ccs con args -> StgRhsCon ccs con (unariseArgs rho args) +------------------------ unariseExpr :: UniqSupply -> UnariseEnv -> StgExpr -> StgExpr -unariseExpr us rho e = case e of - -- Particularly important where (##) is concerned (Note [The nullary (# #) constructor]) - StgApp f [] | UbxTupleRep tys <- repType (idType f) - -> StgConApp (tupleCon UnboxedTuple (length tys)) (map StgVarArg (unariseId rho f)) - StgApp f args -> StgApp f (unariseArgs rho args) - StgLit l -> StgLit l - StgConApp dc args | isUnboxedTupleCon dc -> StgConApp (tupleCon UnboxedTuple (length args')) args' - | otherwise -> StgConApp dc args' - where args' = unariseArgs rho args - StgOpApp op args ty -> StgOpApp op (unariseArgs rho args) ty - StgLam xs e -> StgLam xs' (unariseExpr us' rho' e) - where (us', rho', xs') = unariseIdBinders us rho xs - StgCase e case_lives alts_lives bndr srt alt_ty alts - -> StgCase (unariseExpr us1 rho e) (unariseLives rho case_lives) (unariseLives rho alts_lives) bndr (unariseSRT rho srt) alt_ty' alts' - where (us1, us2) = splitUniqSupply us - (alt_ty', alts') = case repType (idType bndr) of - UbxTupleRep tys -> case alts of - (DEFAULT, [], [], e):_ -> (UbxTupAlt n, [(DataAlt (tupleCon UnboxedTuple n), ys, uses, unariseExpr us2' rho' e)]) - where (us2', rho', ys) = unariseIdBinder us2 rho bndr - uses = replicate (length ys) (not (isDeadBinder bndr)) - n = length tys - [(DataAlt _, ys, uses, e)] -> (UbxTupAlt n, [(DataAlt (tupleCon UnboxedTuple n), ys', uses', unariseExpr us2' rho'' e)]) - where (us2', rho', ys', uses') = unariseUsedIdBinders us2 rho ys uses - rho'' = extendVarEnv rho' bndr ys' - n = length ys' - _ -> panic "unariseExpr: strange unboxed tuple alts" - UnaryRep _ -> (alt_ty, zipWith (\us alt -> unariseAlt us rho alt) (listSplitUniqSupply us2) alts) - StgLet bind e -> StgLet (unariseBinding us1 rho bind) (unariseExpr us2 rho e) - where (us1, us2) = splitUniqSupply us - StgLetNoEscape live_in_let live_in_bind bind e - -> StgLetNoEscape (unariseLives rho live_in_let) (unariseLives rho live_in_bind) (unariseBinding us1 rho bind) (unariseExpr us2 rho e) - where (us1, us2) = splitUniqSupply us - StgSCC cc bump_entry push_cc e -> StgSCC cc bump_entry push_cc (unariseExpr us rho e) - StgTick mod tick_n e -> StgTick mod tick_n (unariseExpr us rho e) - +unariseExpr _ rho (StgApp f args) + | null args + , UbxTupleRep tys <- repType (idType f) + = -- Particularly important where (##) is concerned + -- See Note [Nullary unboxed tuple] + StgConApp (tupleCon UnboxedTuple (length tys)) + (map StgVarArg (unariseId rho f)) + + | otherwise + = StgApp f (unariseArgs rho args) + +unariseExpr _ _ (StgLit l) + = StgLit l + +unariseExpr _ rho (StgConApp dc args) + | isUnboxedTupleCon dc = StgConApp (tupleCon UnboxedTuple (length args')) args' + | otherwise = StgConApp dc args' + where + args' = unariseArgs rho args + +unariseExpr _ rho (StgOpApp op args ty) + = StgOpApp op (unariseArgs rho args) ty + +unariseExpr us rho (StgLam xs e) + = StgLam xs' (unariseExpr us' rho' e) + where + (us', rho', xs') = unariseIdBinders us rho xs + +unariseExpr us rho (StgCase e case_lives alts_lives bndr srt alt_ty alts) + = StgCase (unariseExpr us1 rho e) (unariseLives rho case_lives) + (unariseLives rho alts_lives) bndr (unariseSRT rho srt) + alt_ty' alts' + where + (us1, us2) = splitUniqSupply us + (alt_ty', alts') = unariseAlts us2 rho alt_ty bndr (repType (idType bndr)) alts + +unariseExpr us rho (StgLet bind e) + = StgLet (unariseBinding us1 rho bind) (unariseExpr us2 rho e) + where + (us1, us2) = splitUniqSupply us + +unariseExpr us rho (StgLetNoEscape live_in_let live_in_bind bind e) + = StgLetNoEscape (unariseLives rho live_in_let) (unariseLives rho live_in_bind) + (unariseBinding us1 rho bind) (unariseExpr us2 rho e) + where + (us1, us2) = splitUniqSupply us + +unariseExpr us rho (StgSCC cc bump_entry push_cc e) + = StgSCC cc bump_entry push_cc (unariseExpr us rho e) +unariseExpr us rho (StgTick mod tick_n e) + = StgTick mod tick_n (unariseExpr us rho e) + +------------------------ +unariseAlts :: UniqSupply -> UnariseEnv -> AltType -> Id -> RepType -> [StgAlt] -> (AltType, [StgAlt]) +unariseAlts us rho alt_ty _ (UnaryRep _) alts + = (alt_ty, zipWith (\us alt -> unariseAlt us rho alt) (listSplitUniqSupply us) alts) + +unariseAlts us rho _ bndr (UbxTupleRep tys) ((DEFAULT, [], [], e) : _) + = (UbxTupAlt n, [(DataAlt (tupleCon UnboxedTuple n), ys, uses, unariseExpr us2' rho' e)]) + where + (us2', rho', ys) = unariseIdBinder us rho bndr + uses = replicate (length ys) (not (isDeadBinder bndr)) + n = length tys + +unariseAlts us rho _ bndr (UbxTupleRep _) [(DataAlt _, ys, uses, e)] + = (UbxTupAlt n, [(DataAlt (tupleCon UnboxedTuple n), ys', uses', unariseExpr us2' rho'' e)]) + where + (us2', rho', ys', uses') = unariseUsedIdBinders us rho ys uses + rho'' = extendVarEnv rho' bndr ys' + n = length ys' + +unariseAlts _ _ _ _ (UbxTupleRep _) alts + = pprPanic "unariseExpr: strange unboxed tuple alts" (ppr alts) + +-------------------------- unariseAlt :: UniqSupply -> UnariseEnv -> StgAlt -> StgAlt -unariseAlt us rho (con, xs, uses, e) = (con, xs', uses', unariseExpr us' rho' e) - where (us', rho', xs', uses') = unariseUsedIdBinders us rho xs uses +unariseAlt us rho (con, xs, uses, e) + = (con, xs', uses', unariseExpr us' rho' e) + where + (us', rho', xs', uses') = unariseUsedIdBinders us rho xs uses +------------------------ unariseSRT :: UnariseEnv -> SRT -> SRT unariseSRT _ NoSRT = NoSRT unariseSRT rho (SRTEntries ids) = SRTEntries (concatMapVarSet (unariseId rho) ids) @@ -136,16 +182,24 @@ unariseIds :: UnariseEnv -> [Id] -> [Id] unariseIds rho = concatMap (unariseId rho) unariseId :: UnariseEnv -> Id -> [Id] -unariseId rho x = case lookupVarEnv rho x of - Just ys -> ASSERT2(case repType (idType x) of UbxTupleRep _ -> True; _ -> x == ubxTupleId0, text "unariseId: not unboxed tuple" <+> ppr x) - ys - Nothing -> ASSERT2(case repType (idType x) of UbxTupleRep _ -> False; _ -> True, text "unariseId: was unboxed tuple" <+> ppr x) - [x] - -unariseUsedIdBinders :: UniqSupply -> UnariseEnv -> [Id] -> [Bool] -> (UniqSupply, UnariseEnv, [Id], [Bool]) -unariseUsedIdBinders us rho xs uses = case mapAccumL2 (\us rho (x, use) -> third3 (map (flip (,) use)) $ unariseIdBinder us rho x) - us rho (zipEqual "unariseUsedIdBinders" xs uses) of - (us', rho', xs_usess) -> uncurry ((,,,) us' rho') (unzip (concat xs_usess)) +unariseId rho x + | Just ys <- lookupVarEnv rho x + = ASSERT2( case repType (idType x) of UbxTupleRep _ -> True; _ -> x == ubxTupleId0 + , text "unariseId: not unboxed tuple" <+> ppr x ) + ys + + | otherwise + = ASSERT2( case repType (idType x) of UbxTupleRep _ -> False; _ -> True + , text "unariseId: was unboxed tuple" <+> ppr x ) + [x] + +unariseUsedIdBinders :: UniqSupply -> UnariseEnv -> [Id] -> [Bool] + -> (UniqSupply, UnariseEnv, [Id], [Bool]) +unariseUsedIdBinders us rho xs uses + = case mapAccumL2 do_one us rho (zipEqual "unariseUsedIdBinders" xs uses) of + (us', rho', xs_usess) -> uncurry ((,,,) us' rho') (unzip (concat xs_usess)) + where + do_one us rho (x, use) = third3 (map (flip (,) use)) (unariseIdBinder us rho x) unariseIdBinders :: UniqSupply -> UnariseEnv -> [Id] -> (UniqSupply, UnariseEnv, [Id]) unariseIdBinders us rho xs = third3 concat $ mapAccumL2 unariseIdBinder us rho xs diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index 6dc091961a..eed579eed7 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -36,6 +36,7 @@ import Maybes ( maybeToBool ) import Name ( getOccName, isExternalName, nameOccName ) import OccName ( occNameString, occNameFS ) import BasicTypes ( Arity ) +import TysWiredIn ( unboxedUnitDataCon ) import Literal import Outputable import MonadUtils @@ -420,6 +421,14 @@ coreToStgExpr (Case scrut bndr _ alts) = do ) where vars_alt (con, binders, rhs) + | DataAlt c <- con, c == unboxedUnitDataCon + = -- This case is a bit smelly. + -- See Note [Nullary unboxed tuple] in Type.lhs + -- where a nullary tuple is mapped to (State# World#) + ASSERT( null binders ) + do { (rhs2, rhs_fvs, rhs_escs) <- coreToStgExpr rhs + ; return ((DEFAULT, [], [], rhs2), rhs_fvs, rhs_escs) } + | otherwise = let -- Remove type variables binders' = filterStgBinders binders in @@ -463,7 +472,7 @@ mkStgAltType bndr alts = case repType (idType bndr) of PolyAlt Nothing -> PolyAlt UbxTupleRep rep_tys -> UbxTupAlt (length rep_tys) - + -- NB Nullary unboxed tuples have UnaryRep, and generate a PrimAlt where _is_poly_alt_tycon tc = isFunTyCon tc diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.lhs index 84a4c69af9..e5c525e4c3 100644 --- a/compiler/stgSyn/StgSyn.lhs +++ b/compiler/stgSyn/StgSyn.lhs @@ -106,14 +106,14 @@ data GenStgArg occ isDllConApp :: DynFlags -> DataCon -> [StgArg] -> Bool isDllConApp dflags con args | platformOS (targetPlatform dflags) == OSMinGW32 - = isDllName this_pkg (dataConName con) || any is_dll_arg args + = isDllName dflags this_pkg (dataConName con) || any is_dll_arg args | otherwise = False where -- NB: typePrimRep is legit because any free variables won't have -- unlifted type (there are no unlifted things at top level) is_dll_arg :: StgArg -> Bool is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep (idType v)) - && isDllName this_pkg (idName v) + && isDllName dflags this_pkg (idName v) is_dll_arg _ = False this_pkg = thisPackage dflags diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 8d79e89d97..64ef9d9730 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -1554,7 +1554,8 @@ genDerivStuff :: SrcSpan -> FixityEnv -> Class -> Name -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff) genDerivStuff loc fix_env clas name tycon comaux_maybe | className clas `elem` typeableClassNames - = return (gen_Typeable_binds loc tycon, emptyBag) + = do dflags <- getDynFlags + return (gen_Typeable_binds dflags loc tycon, emptyBag) | ck `elem` [genClassKey, gen1ClassKey] -- Special case because monadic = let gk = if ck == genClassKey then Gen0 else Gen1 -- TODO NSF: correctly identify when we're building Both instead of One diff --git a/compiler/typecheck/TcEvidence.lhs b/compiler/typecheck/TcEvidence.lhs index 12149058c9..321809f91d 100644 --- a/compiler/typecheck/TcEvidence.lhs +++ b/compiler/typecheck/TcEvidence.lhs @@ -492,27 +492,26 @@ data EvLit Note [Coercion evidence terms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An evidence term for a coercion, of type (t1 ~ t2), always takes one of -these forms: - co_tm ::= EvId v +A "coercion evidence term" takes one of these forms + co_tm ::= EvId v where v :: t1 ~ t2 | EvCoercion co | EvCast co_tm co -An alternative would be - -* To establish the invariant that coercions are represented only - by EvCoercion - -* To maintain the invariant by smart constructors. Eg - mkEvCast (EvCoercion c1) c2 = EvCoercion (TcCastCo c1 c2) - mkEvCast t c = EvCast t c - -I don't think it matters much... but maybe we'll find a good reason to -do one or the other. But currently we allow any of the three forms. - We do quite often need to get a TcCoercion from an EvTerm; see 'evTermCoercion'. +INVARIANT: The evidence for any constraint with type (t1~t2) is +a coercion evidence term. Consider for example + [G] g :: F Int a +If we have + ax7 a :: F Int a ~ (a ~ Bool) +then we do NOT generate the constraint + [G} (g |> ax7 a) :: a ~ Bool +because that does not satisfy the invariant. Instead we make a binding + g1 :: a~Bool = g |> ax7 a +and the constraint + [G] g1 :: a~Bool +See Trac [7238] Note [EvKindCast] ~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 0566192353..e5baaeca9f 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -72,7 +72,6 @@ import Outputable import FastString import Bag import Fingerprint -import Constants import TcEnv (InstInfo) import Data.List ( partition, intersperse ) @@ -1192,8 +1191,8 @@ we generate We are passed the Typeable2 class as well as T \begin{code} -gen_Typeable_binds :: SrcSpan -> TyCon -> LHsBinds RdrName -gen_Typeable_binds loc tycon +gen_Typeable_binds :: DynFlags -> SrcSpan -> TyCon -> LHsBinds RdrName +gen_Typeable_binds dflags loc tycon = unitBag $ mk_easy_FunBind loc (mk_typeOf_RDR tycon) -- Name of appropriate type0f function @@ -1219,8 +1218,8 @@ gen_Typeable_binds loc tycon Fingerprint high low = fingerprintString hashThis int64 - | wORD_SIZE == 4 = HsWord64Prim . fromIntegral - | otherwise = HsWordPrim . fromIntegral + | wORD_SIZE dflags == 4 = HsWord64Prim . fromIntegral + | otherwise = HsWordPrim . fromIntegral mk_typeOf_RDR :: TyCon -> RdrName diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index d0e89bbab9..9650b059e9 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -321,7 +321,11 @@ tc_hs_type :: HsType Name -> ExpKind -> TcM TcType tc_hs_type (HsParTy ty) exp_kind = tc_lhs_type ty exp_kind tc_hs_type (HsDocTy ty _) exp_kind = tc_lhs_type ty exp_kind tc_hs_type (HsQuasiQuoteTy {}) _ = panic "tc_hs_type: qq" -- Eliminated by renamer -tc_hs_type (HsBangTy {}) _ = panic "tc_hs_type: bang" -- Unwrapped by con decls +tc_hs_type ty@(HsBangTy {}) _ + -- While top-level bangs at this point are eliminated (eg !(Maybe Int)), + -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of + -- bangs are invalid, so fail. (#7210) + = failWithTc (ptext (sLit "Unexpected strictness annotation:") <+> ppr ty) tc_hs_type (HsRecTy _) _ = panic "tc_hs_type: record" -- Unwrapped by con decls -- Record types (which only show up temporarily in constructor -- signatures) should have been removed by now @@ -566,7 +570,12 @@ tcTyVar name -- Could be a tyvar, a tycon, or a datacon ; thing <- tcLookup name ; traceTc "lk2" (ppr name <+> ppr thing) ; case thing of - ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv) + ATyVar _ tv + | isKindVar tv + -> failWithTc (ptext (sLit "Kind variable") <+> quotes (ppr tv) + <+> ptext (sLit "used as a type")) + | otherwise + -> return (mkTyVarTy tv, tyVarKind tv) AThing kind -> do { tc <- get_loopy_tc name ; inst_tycon (mkNakedTyConApp tc) kind } @@ -1348,7 +1357,7 @@ tc_lhs_kind (L span ki) = setSrcSpan span (tc_hs_kind ki) -- The main worker tc_hs_kind :: HsKind Name -> TcM Kind -tc_hs_kind k@(HsTyVar _) = tc_kind_app k [] +tc_hs_kind (HsTyVar tc) = tc_kind_var_app tc [] tc_hs_kind k@(HsAppTy _ _) = tc_kind_app k [] tc_hs_kind (HsParTy ki) = tc_lhs_kind ki diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 7a88420205..2e0c04f642 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -620,14 +620,17 @@ skolemiseSigTv tv zonkImplication :: Implication -> TcM Implication zonkImplication implic@(Implic { ic_untch = untch , ic_binds = binds_var + , ic_skols = skols , ic_given = given , ic_wanted = wanted , ic_loc = loc }) - = do { -- No need to zonk the skolems + = do { skols' <- mapM zonkTcTyVarBndr skols -- Need to zonk their kinds! + -- as Trac #7230 showed ; given' <- mapM zonkEvVar given ; loc' <- zonkGivenLoc loc ; wanted' <- zonkWCRec binds_var untch wanted - ; return (implic { ic_given = given' + ; return (implic { ic_skols = skols' + , ic_given = given' , ic_fsks = [] -- Zonking removes all FlatSkol tyvars , ic_wanted = wanted' , ic_loc = loc' }) } @@ -868,10 +871,18 @@ zonkTcType ty | otherwise = TyVarTy <$> updateTyVarKindM go tyvar -- Ordinary (non Tc) tyvars occur inside quantified types - go (ForAllTy tyvar ty) = ASSERT2( isImmutableTyVar tyvar, ppr tyvar ) do - ty' <- go ty - tyvar' <- updateTyVarKindM go tyvar - return (ForAllTy tyvar' ty') + go (ForAllTy tv ty) = do { tv' <- zonkTcTyVarBndr tv + ; ty' <- go ty + ; return (ForAllTy tv' ty') } + +zonkTcTyVarBndr :: TcTyVar -> TcM TcTyVar +-- A tyvar binder is never a unification variable (MetaTv), +-- rather it is always a skolems. BUT it may have a kind +-- that has not yet been zonked, and may include kind +-- unification variables. +zonkTcTyVarBndr tyvar + = ASSERT2( isImmutableTyVar tyvar, ppr tyvar ) do + updateTyVarKindM zonkTcType tyvar zonkTcTyVar :: TcTyVar -> TcM TcType -- Simply look through all Flexis diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 0e7233cb63..8ee2178928 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -1448,6 +1448,20 @@ Example , ev_decomp = \c. [nth 1 c, nth 2 c] }) (\fresh-goals. stuff) +Note [Bind new Givens immediately] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For Givens we make new EvVars and bind them immediately. We don't worry +about caching, but we don't expect complicated calculations among Givens. +It is important to bind each given: + class (a~b) => C a b where .... + f :: C a b => .... +Then in f's Givens we have g:(C a b) and the superclass sc(g,0):a~b. +But that superclass selector can't (yet) appear in a coercion +(see evTermCoercion), so the easy thing is to bind it to an Id. + +See Note [Coercion evidence terms] in TcEvidence. + + \begin{code} xCtFlavor :: CtEvidence -- Original flavor -> [TcPredType] -- New predicate types @@ -1457,14 +1471,7 @@ xCtFlavor :: CtEvidence -- Original flavor xCtFlavor (CtGiven { ctev_gloc = gl, ctev_evtm = tm }) ptys xev = ASSERT( equalLength ptys (ev_decomp xev tm) ) zipWithM (newGivenEvVar gl) ptys (ev_decomp xev tm) - -- For Givens we make new EvVars and bind them immediately. We don't worry - -- about caching, but we don't expect complicated calculations among Givens. - -- It is important to bind each given: - -- class (a~b) => C a b where .... - -- f :: C a b => .... - -- Then in f's Givens we have g:(C a b) and the superclass sc(g,0):a~b. - -- But that superclass selector can't (yet) appear in a coercion - -- (see evTermCoercion), so the easy thing is to bind it to an Id + -- See Note [Bind new Givens immediately] xCtFlavor ctev@(CtWanted { ctev_wloc = wl, ctev_evar = evar }) ptys xev = do { new_evars <- mapM (newWantedEvVar wl) ptys @@ -1511,7 +1518,8 @@ rewriteCtFlavor (CtDerived { ctev_wloc = wl }) pty_new _co = newDerived wl pty_new rewriteCtFlavor (CtGiven { ctev_gloc = gl, ctev_evtm = old_tm }) pty_new co - = return (Just (CtGiven { ctev_gloc = gl, ctev_pred = pty_new, ctev_evtm = new_tm })) + = do { new_ev <- newGivenEvVar gl pty_new new_tm -- See Note [Bind new Givens immediately] + ; return (Just new_ev) } where new_tm = mkEvCast old_tm (mkTcSymCo co) -- mkEvCase optimises ReflCo diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 743bd7c30c..40ed8983c1 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -1180,25 +1180,28 @@ conRepresentibleWithH98Syntax -- and reboxing more complicated chooseBoxingStrategy :: TcType -> HsBang -> TcM HsBang chooseBoxingStrategy arg_ty bang - = case bang of - HsNoBang -> return HsNoBang - HsStrict -> do { unbox_strict <- doptM Opt_UnboxStrictFields - ; if unbox_strict then return (can_unbox HsStrict arg_ty) - else return HsStrict } - HsNoUnpack -> return HsStrict - HsUnpack -> do { omit_prags <- doptM Opt_OmitInterfacePragmas - ; let bang = can_unbox HsUnpackFailed arg_ty - ; if omit_prags && bang == HsUnpack - then return HsStrict - else return bang } + = do { dflags <- getDynFlags + ; let choice = case bang of + HsNoBang -> HsNoBang + HsStrict | dopt Opt_UnboxStrictFields dflags + -> can_unbox HsStrict arg_ty + | otherwise -> HsStrict + HsNoUnpack -> HsStrict + HsUnpack -> can_unbox HsUnpackFailed arg_ty + HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty) + -- Source code never has HsUnpackFailed + + ; case choice of + HsUnpack | dopt Opt_OmitInterfacePragmas dflags + -> return HsStrict + _other -> return choice -- Do not respect UNPACK pragmas if OmitInterfacePragmas is on -- See Trac #5252: unpacking means we must not conceal the -- representation of the argument type -- However: even when OmitInterfacePragmas is on, we still want -- to know if we have HsUnpackFailed, because we omit a -- warning in that case (#3966) - HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty) - -- Source code never has shtes + } where can_unbox :: HsBang -> TcType -> HsBang -- Returns HsUnpack if we can unpack arg_ty diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 6da7632ec7..4124f2c7e0 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -1168,17 +1168,20 @@ uUnboundKVar kv1 k2@(TyVarTy kv2) uUnboundKVar kv1 non_var_k2 = do { k2' <- zonkTcKind non_var_k2 - ; kindOccurCheck kv1 k2' ; let k2'' = defaultKind k2' -- MetaKindVars must be bound only to simple kinds + ; kindUnifCheck kv1 k2'' ; writeMetaTyVar kv1 k2'' } ---------------- -kindOccurCheck :: TyVar -> Type -> TcM () -kindOccurCheck kv1 k2 -- k2 is zonked - = if elemVarSet kv1 (tyVarsOfType k2) - then failWithTc (kindOccurCheckErr kv1 k2) - else return () +kindUnifCheck :: TyVar -> Type -> TcM () +kindUnifCheck kv1 k2 -- k2 is zonked + | elemVarSet kv1 (tyVarsOfType k2) + = failWithTc (kindOccurCheckErr kv1 k2) + | isSigTyVar kv1 + = failWithTc (kindSigVarErr kv1 k2) + | otherwise + = return () mkKindErrorCtxt :: Type -> Type -> Kind -> Kind -> TidyEnv -> TcM (TidyEnv, SDoc) mkKindErrorCtxt ty1 ty2 k1 k2 env0 @@ -1210,4 +1213,9 @@ kindOccurCheckErr :: Var -> Type -> SDoc kindOccurCheckErr tyvar ty = hang (ptext (sLit "Occurs check: cannot construct the infinite kind:")) 2 (sep [ppr tyvar, char '=', ppr ty]) + +kindSigVarErr :: Var -> Type -> SDoc +kindSigVarErr tv ty + = hang (ptext (sLit "Cannot unify the kind variable") <+> quotes (ppr tv)) + 2 (ptext (sLit "with the kind") <+> quotes (ppr ty)) \end{code} diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 147e16dbe1..06fef36102 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -93,6 +93,7 @@ import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon ) import Var import Class import BasicTypes +import DynFlags import ForeignCall import Name import PrelNames @@ -777,16 +778,16 @@ instance Outputable PrimRep where ppr r = text (show r) -- | Find the size of a 'PrimRep', in words -primRepSizeW :: PrimRep -> Int -primRepSizeW IntRep = 1 -primRepSizeW WordRep = 1 -primRepSizeW Int64Rep = wORD64_SIZE `quot` wORD_SIZE -primRepSizeW Word64Rep= wORD64_SIZE `quot` wORD_SIZE -primRepSizeW FloatRep = 1 -- NB. might not take a full word -primRepSizeW DoubleRep= dOUBLE_SIZE `quot` wORD_SIZE -primRepSizeW AddrRep = 1 -primRepSizeW PtrRep = 1 -primRepSizeW VoidRep = 0 +primRepSizeW :: DynFlags -> PrimRep -> Int +primRepSizeW _ IntRep = 1 +primRepSizeW _ WordRep = 1 +primRepSizeW dflags Int64Rep = wORD64_SIZE `quot` wORD_SIZE dflags +primRepSizeW dflags Word64Rep= wORD64_SIZE `quot` wORD_SIZE dflags +primRepSizeW _ FloatRep = 1 -- NB. might not take a full word +primRepSizeW dflags DoubleRep= dOUBLE_SIZE dflags `quot` wORD_SIZE dflags +primRepSizeW _ AddrRep = 1 +primRepSizeW _ PtrRep = 1 +primRepSizeW _ VoidRep = 0 \end{code} %************************************************************************ diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index c613b4b4f3..5e1199d33b 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -612,14 +612,14 @@ newtype at outermost level; and bale out if we see it again. Note [Nullary unboxed tuple] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We represent the nullary unboxed tuple as the unary (but void) type State# RealWorld. -The reason for this is that the ReprArity is never less than the Arity (as it would -otherwise be for a function type like (# #) -> Int). - -As a result, ReprArity is always strictly positive if Arity is. This is important -because it allows us to distinguish at runtime between a thunk and a function - takes a nullary unboxed tuple as an argument! +We represent the nullary unboxed tuple as the unary (but void) type +State# RealWorld. The reason for this is that the ReprArity is never +less than the Arity (as it would otherwise be for a function type like +(# #) -> Int). + +As a result, ReprArity is always strictly positive if Arity is. This +is important because it allows us to distinguish at runtime between a +thunk and a function takes a nullary unboxed tuple as an argument! \begin{code} type UnaryType = Type 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). + |