diff options
Diffstat (limited to 'compiler/codeGen')
23 files changed, 288 insertions, 107 deletions
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 6b36ab09cd..51b8ed9ec8 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP, GADTs #-} + ----------------------------------------------------------------------------- -- -- Code generator utilities; mostly monadic @@ -6,7 +8,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE GADTs #-} module CgUtils ( fixStgRegisters ) where #include "HsVersions.h" diff --git a/compiler/codeGen/CodeGen/Platform/ARM.hs b/compiler/codeGen/CodeGen/Platform/ARM.hs index 727a43561f..5d1148496c 100644 --- a/compiler/codeGen/CodeGen/Platform/ARM.hs +++ b/compiler/codeGen/CodeGen/Platform/ARM.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module CodeGen.Platform.ARM where diff --git a/compiler/codeGen/CodeGen/Platform/NoRegs.hs b/compiler/codeGen/CodeGen/Platform/NoRegs.hs index c4c63b7572..0c85ffbda7 100644 --- a/compiler/codeGen/CodeGen/Platform/NoRegs.hs +++ b/compiler/codeGen/CodeGen/Platform/NoRegs.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module CodeGen.Platform.NoRegs where diff --git a/compiler/codeGen/CodeGen/Platform/PPC.hs b/compiler/codeGen/CodeGen/Platform/PPC.hs index bcbdfe244b..76a2b020ac 100644 --- a/compiler/codeGen/CodeGen/Platform/PPC.hs +++ b/compiler/codeGen/CodeGen/Platform/PPC.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module CodeGen.Platform.PPC where diff --git a/compiler/codeGen/CodeGen/Platform/PPC_Darwin.hs b/compiler/codeGen/CodeGen/Platform/PPC_Darwin.hs index 42bf22f26c..a98e558cc1 100644 --- a/compiler/codeGen/CodeGen/Platform/PPC_Darwin.hs +++ b/compiler/codeGen/CodeGen/Platform/PPC_Darwin.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module CodeGen.Platform.PPC_Darwin where diff --git a/compiler/codeGen/CodeGen/Platform/SPARC.hs b/compiler/codeGen/CodeGen/Platform/SPARC.hs index b49af14409..991f515eaf 100644 --- a/compiler/codeGen/CodeGen/Platform/SPARC.hs +++ b/compiler/codeGen/CodeGen/Platform/SPARC.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module CodeGen.Platform.SPARC where diff --git a/compiler/codeGen/CodeGen/Platform/X86.hs b/compiler/codeGen/CodeGen/Platform/X86.hs index 6dd74df130..e74807ff88 100644 --- a/compiler/codeGen/CodeGen/Platform/X86.hs +++ b/compiler/codeGen/CodeGen/Platform/X86.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module CodeGen.Platform.X86 where diff --git a/compiler/codeGen/CodeGen/Platform/X86_64.hs b/compiler/codeGen/CodeGen/Platform/X86_64.hs index 190d642ea6..102132d679 100644 --- a/compiler/codeGen/CodeGen/Platform/X86_64.hs +++ b/compiler/codeGen/CodeGen/Platform/X86_64.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module CodeGen.Platform.X86_64 where diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index a92f80439b..efc89fe04a 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Stg to C-- code generation @@ -37,7 +39,6 @@ import DataCon import Name import TyCon import Module -import ErrUtils import Outputable import Stream import BasicTypes @@ -60,9 +61,7 @@ codeGen :: DynFlags codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info - = do { liftIO $ showPass dflags "New CodeGen" - - -- cg: run the code generator, and yield the resulting CmmGroup + = do { -- cg: run the code generator, and yield the resulting CmmGroup -- Using an IORef to store the state is a bit crude, but otherwise -- we would need to add a state monad layer. ; cgref <- liftIO $ newIORef =<< initC diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 06e17164dd..4631b2dc14 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Stg to C-- code generation: bindings diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index c9302f21a1..b65d56bae2 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP, RecordWildCards #-} + ----------------------------------------------------------------------------- -- -- Stg to C-- code generation: @@ -9,8 +11,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE RecordWildCards #-} - module StgCmmClosure ( DynTag, tagForCon, isSmallFamily, ConTagZ, dataConTagZ, diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index a02a5da616..edd064848f 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Stg to C--: code generation for constructors @@ -188,7 +190,7 @@ buildDynCon' dflags platform binder _ _cc con [arg] , StgLitArg (MachInt val) <- arg , val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer! , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto... - = do { let intlike_lbl = mkCmmClosureLabel rtsPackageId (fsLit "stg_INTLIKE") + = do { let intlike_lbl = mkCmmClosureLabel rtsPackageKey (fsLit "stg_INTLIKE") val_int = fromIntegral val :: Int offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSizeW dflags + 1) -- INTLIKE closures consist of a header and one word payload @@ -203,7 +205,7 @@ buildDynCon' dflags platform binder _ _cc con [arg] , let val_int = ord val :: Int , val_int <= mAX_CHARLIKE dflags , val_int >= mIN_CHARLIKE dflags - = do { let charlike_lbl = mkCmmClosureLabel rtsPackageId (fsLit "stg_CHARLIKE") + = do { let charlike_lbl = mkCmmClosureLabel rtsPackageKey (fsLit "stg_CHARLIKE") offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSizeW dflags + 1) -- CHARLIKE closures consist of a header and one word payload charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs index 2b8677c408..4127b67401 100644 --- a/compiler/codeGen/StgCmmEnv.hs +++ b/compiler/codeGen/StgCmmEnv.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Stg to C-- code generation: the binding environment diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 9b9d6397c4..ad34b5ba19 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Stg to C-- code generation: expressions diff --git a/compiler/codeGen/StgCmmExtCode.hs b/compiler/codeGen/StgCmmExtCode.hs index df1733978f..5f412b3cf8 100644 --- a/compiler/codeGen/StgCmmExtCode.hs +++ b/compiler/codeGen/StgCmmExtCode.hs @@ -57,7 +57,7 @@ data Named = VarN CmmExpr -- ^ Holds CmmLit(CmmLabel ..) which gives the label type, -- eg, RtsLabel, ForeignLabel, CmmLabel etc. - | FunN PackageId -- ^ A function name from this package + | FunN PackageKey -- ^ A function name from this package | LabelN BlockId -- ^ A blockid of some code or data. -- | An environment of named things. @@ -153,7 +153,7 @@ newBlockId = code F.newLabelC -- | Add add a local function to the environment. newFunctionName :: FastString -- ^ name of the function - -> PackageId -- ^ package of the current module + -> PackageKey -- ^ package of the current module -> ExtCode newFunctionName name pkg = addDecl name (FunN pkg) @@ -193,7 +193,7 @@ lookupName name = do case lookupUFM env name of Just (VarN e) -> e Just (FunN pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg name)) - _other -> CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId name)) + _other -> CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageKey name)) -- | Lift an FCode computation into the CmmParse monad diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index bf88f1ccb3..6937c85d01 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Code generation for foreign calls. diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index a3a47a65e7..7ac2c7a0bd 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Stg to C--: heap management functions @@ -514,7 +516,7 @@ generic_gc = mkGcLabel "stg_gc_noregs" -- | Create a CLabel for calling a garbage collector entry point mkGcLabel :: String -> CmmExpr -mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit s))) +mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageKey (fsLit s))) ------------------------------- heapCheck :: Bool -> Bool -> CmmAGraph -> FCode a -> FCode a diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index a56248dcb9..d62101f27e 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Building info tables. @@ -357,10 +359,10 @@ slowArgs dflags args -- careful: reps contains voids (V), but args does not (arg_pat, n) = slowCallPattern (map fst args) (call_args, rest_args) = splitAt n args - stg_ap_pat = mkCmmRetInfoLabel rtsPackageId arg_pat + stg_ap_pat = mkCmmRetInfoLabel rtsPackageKey arg_pat this_pat = (N, Just (mkLblExpr stg_ap_pat)) : call_args save_cccs = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just curCCS)] - save_cccs_lbl = mkCmmRetInfoLabel rtsPackageId (fsLit "stg_restore_cccs") + save_cccs_lbl = mkCmmRetInfoLabel rtsPackageKey (fsLit "stg_restore_cccs") ------------------------------------------------------------------------- ---- Laying out objects on the heap and stack diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 348b7b9299..22c89d7e05 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP, GADTs, UnboxedTuples #-} + ----------------------------------------------------------------------------- -- -- Monad for Stg to C-- code generation @@ -493,7 +494,7 @@ withSelfLoop self_loop code = do instance HasDynFlags FCode where getDynFlags = liftM cgd_dflags getInfoDown -getThisPackage :: FCode PackageId +getThisPackage :: FCode PackageKey getThisPackage = liftM thisPackage getDynFlags withInfoDown :: FCode a -> CgInfoDownwards -> FCode a diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 5c75acba5a..9e12427355 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ---------------------------------------------------------------------------- -- -- Stg to C--: primitive operations @@ -41,6 +43,7 @@ import FastString import Outputable import Util +import Data.Bits ((.&.), bit) import Control.Monad (liftM, when) ------------------------------------------------------------------------ @@ -119,6 +122,26 @@ cgOpApp (StgPrimCallOp primcall) args _res_ty ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall)) ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args } +-- | Interpret the argument as an unsigned value, assuming the value +-- is given in two-complement form in the given width. +-- +-- Example: @asUnsigned W64 (-1)@ is 18446744073709551615. +-- +-- This function is used to work around the fact that many array +-- primops take Int# arguments, but we interpret them as unsigned +-- quantities in the code gen. This means that we have to be careful +-- every time we work on e.g. a CmmInt literal that corresponds to the +-- array size, as it might contain a negative Integer value if the +-- user passed a value larger than 2^(wORD_SIZE_IN_BITS-1) as the Int# +-- literal. +asUnsigned :: Width -> Integer -> Integer +asUnsigned w n = n .&. (bit (widthInBits w) - 1) + +-- TODO: Several primop implementations (e.g. 'doNewByteArrayOp') use +-- ByteOff (or some other fixed width signed type) to represent +-- array sizes or indices. This means that these will overflow for +-- large enough sizes. + -- | Decide whether an out-of-line primop should be replaced by an -- inline implementation. This might happen e.g. if there's enough -- static information, such as statically know arguments, to emit a @@ -133,12 +156,12 @@ shouldInlinePrimOp :: DynFlags -> [CmmExpr] -- ^ The primop arguments -> Maybe ([LocalReg] -> FCode ()) -shouldInlinePrimOp dflags NewByteArrayOp_Char [(CmmLit (CmmInt n _))] - | fromInteger n <= maxInlineAllocSize dflags = +shouldInlinePrimOp dflags NewByteArrayOp_Char [(CmmLit (CmmInt n w))] + | asUnsigned w n <= fromIntegral (maxInlineAllocSize dflags) = Just $ \ [res] -> doNewByteArrayOp res (fromInteger n) -shouldInlinePrimOp dflags NewArrayOp [(CmmLit (CmmInt n _)), init] - | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags = +shouldInlinePrimOp dflags NewArrayOp [(CmmLit (CmmInt n w)), init] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = Just $ \ [res] -> doNewArrayOp res (arrPtrsRep dflags (fromInteger n)) mkMAP_DIRTY_infoLabel [ (mkIntExpr dflags (fromInteger n), @@ -164,24 +187,24 @@ shouldInlinePrimOp _ CopyMutableArrayArrayOp [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] = Just $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n) -shouldInlinePrimOp dflags CloneArrayOp [src, src_off, (CmmLit (CmmInt n _))] - | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags = +shouldInlinePrimOp dflags CloneArrayOp [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_infoLabel res src src_off (fromInteger n) -shouldInlinePrimOp dflags CloneMutableArrayOp [src, src_off, (CmmLit (CmmInt n _))] - | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags = +shouldInlinePrimOp dflags CloneMutableArrayOp [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = Just $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n) -shouldInlinePrimOp dflags FreezeArrayOp [src, src_off, (CmmLit (CmmInt n _))] - | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags = +shouldInlinePrimOp dflags FreezeArrayOp [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_infoLabel res src src_off (fromInteger n) -shouldInlinePrimOp dflags ThawArrayOp [src, src_off, (CmmLit (CmmInt n _))] - | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags = +shouldInlinePrimOp dflags ThawArrayOp [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = Just $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n) -shouldInlinePrimOp dflags NewSmallArrayOp [(CmmLit (CmmInt n _)), init] - | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags = +shouldInlinePrimOp dflags NewSmallArrayOp [(CmmLit (CmmInt n w)), init] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = Just $ \ [res] -> doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel [ (mkIntExpr dflags (fromInteger n), @@ -197,20 +220,20 @@ shouldInlinePrimOp _ CopySmallMutableArrayOp [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] = Just $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n) -shouldInlinePrimOp dflags CloneSmallArrayOp [src, src_off, (CmmLit (CmmInt n _))] - | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags = +shouldInlinePrimOp dflags CloneSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_infoLabel res src src_off (fromInteger n) -shouldInlinePrimOp dflags CloneSmallMutableArrayOp [src, src_off, (CmmLit (CmmInt n _))] - | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags = +shouldInlinePrimOp dflags CloneSmallMutableArrayOp [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = Just $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n) -shouldInlinePrimOp dflags FreezeSmallArrayOp [src, src_off, (CmmLit (CmmInt n _))] - | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags = +shouldInlinePrimOp dflags FreezeSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_infoLabel res src src_off (fromInteger n) -shouldInlinePrimOp dflags ThawSmallArrayOp [src, src_off, (CmmLit (CmmInt n _))] - | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags = +shouldInlinePrimOp dflags ThawSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = Just $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n) shouldInlinePrimOp dflags primop args @@ -248,63 +271,6 @@ emitPrimOp :: DynFlags -- First we handle various awkward cases specially. The remaining -- easy cases are then handled by translateOp, defined below. -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 - fastest way to do it - if you have better code, please send it! --SDM - - Return : r = a + b, c = 0 if no overflow, 1 on overflow. - - We currently don't make use of the r value if c is != 0 (i.e. - overflow), we just convert to big integers and try again. This - could be improved by making r and c the correct values for - plugging into a new J#. - - { r = ((I_)(a)) + ((I_)(b)); \ - c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ - >> (BITS_IN (I_) - 1); \ - } - Wading through the mass of bracketry, it seems to reduce to: - c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1) - --} - = emit $ catAGraphs [ - mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]), - mkAssign (CmmLocal res_c) $ - CmmMachOp (mo_wordUShr dflags) [ - CmmMachOp (mo_wordAnd dflags) [ - CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]], - CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] - ], - mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) - ] - ] - - -emitPrimOp dflags [res_r,res_c] IntSubCOp [aa,bb] -{- Similarly: - #define subIntCzh(r,c,a,b) \ - { r = ((I_)(a)) - ((I_)(b)); \ - c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ - >> (BITS_IN (I_) - 1); \ - } - - c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1) --} - = emit $ catAGraphs [ - mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]), - mkAssign (CmmLocal res_c) $ - CmmMachOp (mo_wordUShr dflags) [ - CmmMachOp (mo_wordAnd dflags) [ - CmmMachOp (mo_wordXor dflags) [aa,bb], - CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] - ], - mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) - ] - ] - - emitPrimOp _ [res] ParOp [arg] = -- for now, just implement this in a C function @@ -597,6 +563,20 @@ emitPrimOp _ [res] PopCnt32Op [w] = emitPopCntCall res w W32 emitPrimOp _ [res] PopCnt64Op [w] = emitPopCntCall res w W64 emitPrimOp dflags [res] PopCntOp [w] = emitPopCntCall res w (wordWidth dflags) +-- count leading zeros +emitPrimOp _ [res] Clz8Op [w] = emitClzCall res w W8 +emitPrimOp _ [res] Clz16Op [w] = emitClzCall res w W16 +emitPrimOp _ [res] Clz32Op [w] = emitClzCall res w W32 +emitPrimOp _ [res] Clz64Op [w] = emitClzCall res w W64 +emitPrimOp dflags [res] ClzOp [w] = emitClzCall res w (wordWidth dflags) + +-- count trailing zeros +emitPrimOp _ [res] Ctz8Op [w] = emitCtzCall res w W8 +emitPrimOp _ [res] Ctz16Op [w] = emitCtzCall res w W16 +emitPrimOp _ [res] Ctz32Op [w] = emitCtzCall res w W32 +emitPrimOp _ [res] Ctz64Op [w] = emitCtzCall res w W64 +emitPrimOp dflags [res] CtzOp [w] = emitCtzCall res w (wordWidth dflags) + -- Unsigned int to floating point conversions emitPrimOp _ [res] Word2FloatOp [w] = emitPrimCall [res] (MO_UF_Conv W32) [w] @@ -767,6 +747,25 @@ emitPrimOp _ res PrefetchByteArrayOp0 args = doPrefetchByteArrayOp 0 res emitPrimOp _ res PrefetchMutableByteArrayOp0 args = doPrefetchByteArrayOp 0 res args emitPrimOp _ res PrefetchAddrOp0 args = doPrefetchAddrOp 0 res args +-- Atomic read-modify-write +emitPrimOp dflags [res] FetchAddByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_Add mba ix (bWord dflags) n +emitPrimOp dflags [res] FetchSubByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_Sub mba ix (bWord dflags) n +emitPrimOp dflags [res] FetchAndByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_And mba ix (bWord dflags) n +emitPrimOp dflags [res] FetchNandByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_Nand mba ix (bWord dflags) n +emitPrimOp dflags [res] FetchOrByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_Or mba ix (bWord dflags) n +emitPrimOp dflags [res] FetchXorByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_Xor mba ix (bWord dflags) n +emitPrimOp dflags [res] AtomicReadByteArrayOp_Int [mba, ix] = + doAtomicReadByteArray res mba ix (bWord dflags) +emitPrimOp dflags [] AtomicWriteByteArrayOp_Int [mba, ix, val] = + doAtomicWriteByteArray mba ix (bWord dflags) val +emitPrimOp dflags [res] CasByteArrayOp_Int [mba, ix, old, new] = + doCasByteArray res mba ix (bWord dflags) old new -- The rest just translate straightforwardly emitPrimOp dflags [res] op [arg] @@ -807,6 +806,10 @@ callishPrimOpSupported dflags op WordAdd2Op | ncg && x86ish -> Left (MO_Add2 (wordWidth dflags)) | otherwise -> Right genericWordAdd2Op + IntAddCOp -> Right genericIntAddCOp + + IntSubCOp -> Right genericIntSubCOp + WordMul2Op | ncg && x86ish -> Left (MO_U_Mul2 (wordWidth dflags)) | otherwise -> Right genericWordMul2Op @@ -912,6 +915,67 @@ genericWordAdd2Op [res_h, res_l] [arg_x, arg_y] (bottomHalf (CmmReg (CmmLocal r1))))] genericWordAdd2Op _ _ = panic "genericWordAdd2Op" +genericIntAddCOp :: GenericOp +genericIntAddCOp [res_r, res_c] [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 + fastest way to do it - if you have better code, please send it! --SDM + + Return : r = a + b, c = 0 if no overflow, 1 on overflow. + + We currently don't make use of the r value if c is != 0 (i.e. + overflow), we just convert to big integers and try again. This + could be improved by making r and c the correct values for + plugging into a new J#. + + { r = ((I_)(a)) + ((I_)(b)); \ + c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ + >> (BITS_IN (I_) - 1); \ + } + Wading through the mass of bracketry, it seems to reduce to: + c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1) + +-} + = do dflags <- getDynFlags + emit $ catAGraphs [ + mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]), + mkAssign (CmmLocal res_c) $ + CmmMachOp (mo_wordUShr dflags) [ + CmmMachOp (mo_wordAnd dflags) [ + CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]], + CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] + ], + mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) + ] + ] +genericIntAddCOp _ _ = panic "genericIntAddCOp" + +genericIntSubCOp :: GenericOp +genericIntSubCOp [res_r, res_c] [aa, bb] +{- Similarly: + #define subIntCzh(r,c,a,b) \ + { r = ((I_)(a)) - ((I_)(b)); \ + c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ + >> (BITS_IN (I_) - 1); \ + } + + c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1) +-} + = do dflags <- getDynFlags + emit $ catAGraphs [ + mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]), + mkAssign (CmmLocal res_c) $ + CmmMachOp (mo_wordUShr dflags) [ + CmmMachOp (mo_wordAnd dflags) [ + CmmMachOp (mo_wordXor dflags) [aa,bb], + CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] + ], + mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) + ] + ] +genericIntSubCOp _ _ = panic "genericIntSubCOp" + genericWordMul2Op :: GenericOp genericWordMul2Op [res_h, res_l] [arg_x, arg_y] = do dflags <- getDynFlags @@ -1931,6 +1995,81 @@ doWriteSmallPtrArrayOp addr idx val = do emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) ------------------------------------------------------------------------------ +-- Atomic read-modify-write + +-- | Emit an atomic modification to a byte array element. The result +-- reg contains that previous value of the element. Implies a full +-- memory barrier. +doAtomicRMW :: LocalReg -- ^ Result reg + -> AtomicMachOp -- ^ Atomic op (e.g. add) + -> CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> CmmExpr -- ^ Op argument (e.g. amount to add) + -> FCode () +doAtomicRMW res amop mba idx idx_ty n = do + dflags <- getDynFlags + let width = typeWidth idx_ty + addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) + width mba idx + emitPrimCall + [ res ] + (MO_AtomicRMW width amop) + [ addr, n ] + +-- | Emit an atomic read to a byte array that acts as a memory barrier. +doAtomicReadByteArray + :: LocalReg -- ^ Result reg + -> CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> FCode () +doAtomicReadByteArray res mba idx idx_ty = do + dflags <- getDynFlags + let width = typeWidth idx_ty + addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) + width mba idx + emitPrimCall + [ res ] + (MO_AtomicRead width) + [ addr ] + +-- | Emit an atomic write to a byte array that acts as a memory barrier. +doAtomicWriteByteArray + :: CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> CmmExpr -- ^ Value to write + -> FCode () +doAtomicWriteByteArray mba idx idx_ty val = do + dflags <- getDynFlags + let width = typeWidth idx_ty + addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) + width mba idx + emitPrimCall + [ {- no results -} ] + (MO_AtomicWrite width) + [ addr, val ] + +doCasByteArray + :: LocalReg -- ^ Result reg + -> CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> CmmExpr -- ^ Old value + -> CmmExpr -- ^ New value + -> FCode () +doCasByteArray res mba idx idx_ty old new = do + dflags <- getDynFlags + let width = (typeWidth idx_ty) + addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) + width mba idx + emitPrimCall + [ res ] + (MO_Cmpxchg width) + [ addr, old, new ] + +------------------------------------------------------------------------------ -- Helpers for emitting function calls -- | Emit a call to @memcpy@. @@ -1971,3 +2110,17 @@ emitPopCntCall res x width = do [ res ] (MO_PopCnt width) [ x ] + +emitClzCall :: LocalReg -> CmmExpr -> Width -> FCode () +emitClzCall res x width = do + emitPrimCall + [ res ] + (MO_Clz width) + [ x ] + +emitCtzCall :: LocalReg -> CmmExpr -> Width -> FCode () +emitCtzCall res x width = do + emitPrimCall + [ res ] + (MO_Ctz width) + [ x ] diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index f858c5a0b6..7249477c9f 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Code generation for profiling @@ -181,7 +183,7 @@ enterCostCentreFun ccs closure = ifProfiling $ do if isCurrentCCS ccs then do dflags <- getDynFlags - emitRtsCall rtsPackageId (fsLit "enterFunCCS") + emitRtsCall rtsPackageKey (fsLit "enterFunCCS") [(CmmReg (CmmGlobal BaseReg), AddrHint), (costCentreFrom dflags closure, AddrHint)] False else return () -- top-level function, nothing to do @@ -283,7 +285,7 @@ emitSetCCC cc tick push pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode () pushCostCentre result ccs cc = emitRtsCallWithResult result AddrHint - rtsPackageId + rtsPackageKey (fsLit "pushCostCentre") [(ccs,AddrHint), (CmmLit (mkCCostCentre cc), AddrHint)] False @@ -354,7 +356,7 @@ ldvEnter cl_ptr = do loadEra :: DynFlags -> CmmExpr loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags)) - [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "era"))) + [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageKey (fsLit "era"))) (cInt dflags)] ldvWord :: DynFlags -> CmmExpr -> CmmExpr diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index b1218201a6..3652a79979 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE BangPatterns, CPP #-} + ----------------------------------------------------------------------------- -- -- Code generation for ticky-ticky profiling @@ -325,7 +327,7 @@ registerTickyCtr ctr_lbl = do , mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_registeredp dflags))) (mkIntExpr dflags 1) ] - ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs")) + ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageKey (fsLit "ticky_entry_ctrs")) emit =<< mkCmmIfThen test (catAGraphs register_stmts) tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode () @@ -470,12 +472,12 @@ tickyAllocHeap genuine hp bytes, -- Bump the global allocation total ALLOC_HEAP_tot addToMemLbl (cLong dflags) - (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_tot")) + (mkCmmDataLabel rtsPackageKey (fsLit "ALLOC_HEAP_tot")) bytes, -- Bump the global allocation counter ALLOC_HEAP_ctr if not genuine then mkNop else addToMemLbl (cLong dflags) - (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_ctr")) + (mkCmmDataLabel rtsPackageKey (fsLit "ALLOC_HEAP_ctr")) 1 ]} @@ -539,13 +541,13 @@ ifTickyDynThunk :: FCode () -> FCode () ifTickyDynThunk code = tickyDynThunkIsOn >>= \b -> when b code bumpTickyCounter :: FastString -> FCode () -bumpTickyCounter lbl = bumpTickyLbl (mkCmmDataLabel rtsPackageId lbl) +bumpTickyCounter lbl = bumpTickyLbl (mkCmmDataLabel rtsPackageKey lbl) bumpTickyCounterBy :: FastString -> Int -> FCode () -bumpTickyCounterBy lbl = bumpTickyLblBy (mkCmmDataLabel rtsPackageId lbl) +bumpTickyCounterBy lbl = bumpTickyLblBy (mkCmmDataLabel rtsPackageKey lbl) bumpTickyCounterByE :: FastString -> CmmExpr -> FCode () -bumpTickyCounterByE lbl = bumpTickyLblByE (mkCmmDataLabel rtsPackageId lbl) +bumpTickyCounterByE lbl = bumpTickyLblByE (mkCmmDataLabel rtsPackageKey lbl) bumpTickyEntryCount :: CLabel -> FCode () bumpTickyEntryCount lbl = do diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 1c6c3f2eae..985c6db900 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- Code generator utilities; mostly monadic @@ -173,10 +175,10 @@ tagToClosure dflags tycon tag -- ------------------------------------------------------------------------- -emitRtsCall :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () +emitRtsCall :: PackageKey -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe -emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageId -> FastString +emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageKey -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () emitRtsCallWithResult res hint pkg fun args safe = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe |