Andreas Klebinger pushed to branch wip/andreask/cfg-fix at Glasgow Haskell Compiler / GHC Commits: 457ba7e1 by Andreas Klebinger at 2026-08-21T13:11:45+00:00 Replace maybe with BlockCont type - - - - - a0e60edd by Andreas Klebinger at 2026-08-21T17:40:46+00:00 wip: NatM approach - - - - - 3 changed files: - compiler/GHC/CmmToAsm/BlockLayout.hs - compiler/GHC/CmmToAsm/Monad.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs Changes: ===================================== compiler/GHC/CmmToAsm/BlockLayout.hs ===================================== @@ -66,6 +66,11 @@ import GHC.Types.Unique.DSM (UniqDSM) * Feed this CFG into the block layout code (`sequenceTop`) in this module. Which will then produce a code layout based on the input weights. + It's worth mentioning that instead of maintaining a CFG in the backend we + could re-create one from the assembly. But a naive version of this would lose + some essential information, like weither or not a branch is known to be + likely/unlikely. But we could get a similar effect by encoding the relevant + information directly in the instruction stream as meta instructions or similar. Note [Chain based CFG serialization] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/CmmToAsm/Monad.hs ===================================== @@ -19,7 +19,14 @@ module GHC.CmmToAsm.Monad ( addImportNat, addNodeBetweenNat, addImmediateSuccessorNat, - updateCfgNat, + getCurrentBlock, + setCurrentBlock, + currentBlock, + continueInNewBlock, + addDiamondFlow, + addCondBlock, + addColdSelfLoop, + increaseEdgeWeight, getUniqueNat, setDeltaNat, getConfig, @@ -66,11 +73,12 @@ import GHC.Types.Unique ( Unique ) import GHC.Unit.Module import GHC.Utils.Outputable (SDoc, HDoc, ppr) -import GHC.Utils.Panic (pprPanic) +import GHC.Utils.Panic (panic, pprPanic) import GHC.Utils.Monad.State.Strict (State (..), runState, state) import GHC.Utils.Misc import GHC.CmmToAsm.CFG import GHC.CmmToAsm.CFG.Weight +import GHC.Data.Unboxed (MaybeUB (..)) -- | A Native Code Generator implementation is parametrised over -- * The type of static data (typically related to 'CmmStatics') @@ -184,10 +192,13 @@ data NatM_State natm_config :: NCGConfig, natm_fileid :: DwarfFiles, natm_debug_map :: LabelMap DebugBlock, - natm_cfg :: CFG + natm_cfg :: CFG, -- ^ Having a CFG with additional information is essential for some -- operations. However we can't reconstruct all information once we -- generated instructions. So instead we update the CFG as we go. + natm_cur_block :: !(MaybeUB BlockId) + -- ^ Keep track of the current block during code generation for + -- CFG updates. Only used by backends using the CFG for code layout. } type DwarfFiles = UniqFM FastString (FastString, Int) @@ -217,6 +228,7 @@ mkNatM_State us delta config , natm_fileid = dwf , natm_debug_map = dbg , natm_cfg = cfg + , natm_cur_block = NothingUB } initNat :: NatM_State -> NatM a -> (a, NatM_State) @@ -255,6 +267,167 @@ updateCfgNat f = NatM $ \ st -> let !cfg' = f (natm_cfg st) in ((), st { natm_cfg = cfg'}) +setCurrentBlock :: BlockId -> NatM () +setCurrentBlock bid = NatM $ \ st -> ((), st { natm_cur_block = JustUB bid }) + +getCurrentBlock :: NatM (Maybe BlockId) +getCurrentBlock = NatM $ \ st -> + let !cbid = case natm_cur_block st of + JustUB bid -> Just bid + NothingUB -> Nothing + in + ( cbid, st ) + +{- Note [Updating the CFG during CodeGen] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At the CMM level life is simple: +Blocks consist of a sequence of statements. +Control flow exists only between blocks. + +We are not so lucky for CodeGen. There we may introduce +intra-block control flow. For example we might turn a +simple ´MO_Ctz width arg` into branching code like this: + + arg_block + ╱ ╲ + left right + ╲ ╱ + cont + +We update the CFG to account for this. (See also Note [CFG based code layout]). +To do so we generally: +* Keep track of the current block in the NatM state. +* Compute code for all dependencies (arg in this case) +* Then generate the instructions for the MachOp at hand. + + If that involves branching control flow we call update the CFG + by calling one of continueInNewBlock, addCondBlock or addDiamondFlow, + which will adjust the CFG + and update the current block. +* We then return our generated instructions, and the parent expression + can use the update CFG/currentBlock to generate it's own code. +-} + +-- | The block instructions are currently being generated for. +-- +-- Panics if the current block isn't being tracked, which is a code generator +-- bug: any backend using the CFG based operations below must set the current +-- block for each basic block it starts to generate code for. +currentBlock :: HasDebugCallStack => NatM BlockId +currentBlock = NatM $ \ st -> + case natm_cur_block st of + JustUB bid -> (bid, st) + NothingUB -> panic "currentBlock: current block not tracked" + +-- | Continue/extend the current block under a new label. +-- +-- > Before: cur -> S After: cur -> cont -> S +-- +-- All cur->S edges get rewritten to cont->S. +-- @cont@ becomes the current block. +-- Returns @cur@ (the old current block). +-- +-- Use for example for self loops. See also Note [Updating the CFG during CodeGen] +continueInNewBlock :: HasDebugCallStack => BlockId -> NatM BlockId +continueInNewBlock cont = do + cur <- currentBlock + addImmediateSuccessorNat cur cont + setCurrentBlock cont + return cur + +-- | Register diamond shaped control flow. +-- +-- > Before: After: +-- > +-- > cur cur +-- > │ ╱ ╲ +-- > │ likely unlikely +-- > │ ╲ ╱ +-- > │ cont +-- > ▼ │ +-- > S ▼ +-- > S +-- +-- * All cur->S edges get rewritten to cont->S. +-- * @cont becomes the current block. +-- +-- See also Note [Updating the CFG during CodeGen] +addDiamondFlow :: HasDebugCallStack + => BlockId -- ^ the arm we expect to be taken + -> BlockId -- ^ the arm we expect not to be taken + -> BlockId -- ^ the block both arms converge on + -> NatM () +addDiamondFlow likely unlikely cont = do + weights <- getCfgWeights + cur <- continueInNewBlock cont + -- Both arms end in an unconditional jump to cont. Control never passes + -- from cur to cont directly, so we drop the edge continueInNewBlock added. + updateCfgNat ( addWeightEdge cur likely (fromIntegral $ likelyCondWeight weights) + . addWeightEdge cur unlikely (fromIntegral $ unlikelyCondWeight weights) + . addWeightEdge likely cont (fromIntegral $ uncondWeight weights) + . addWeightEdge unlikely cont (fromIntegral $ uncondWeight weights) + . delEdge cur cont ) + +-- | Register a conditional block that converges again on the same path. +-- +-- > Before: After: +-- > +-- > cur cur ────╮ +-- > │ │ │ +-- > │ │ cond_block +-- > │ │ │ +-- > │ cont ◀─╯ +-- > ▼ │ +-- > S ▼ +-- > S +-- +-- Takes a bool @is_likely@ that indicates if the new block is the likely code +-- path or not. +-- +-- @cont@ takes over the successors of the current block and becomes the +-- current block. +-- +-- See also Note [Updating the CFG during CodeGen] +addCondBlock :: HasDebugCallStack + => BlockId -- ^ the new code block + -> Bool -- ^ Is the newly given block the likely code path? + -> BlockId -- ^ the block control flow converges on + -> NatM () +addCondBlock cond_block is_likely cont = do + weights <- getCfgWeights + cur <- continueInNewBlock cont + let likely = fromIntegral (likelyCondWeight weights) + unlikely = fromIntegral (unlikelyCondWeight weights) + (w_cond, w_skip) | is_likely = (likely, unlikely) + | otherwise = (unlikely, likely) + -- This overwrites the cur -> cont edge added by continueInNewBlock, which + -- is no longer an unconditional jump now that cond_block can be taken. + updateCfgNat ( addWeightEdge cur cond_block w_cond + . addWeightEdge cur cont w_skip + . addWeightEdge cond_block cont (fromIntegral $ uncondWeight weights) ) + +-- | Register a self loop on the given block, e.g. the retry loop of a +-- cmpxchg based sequence. +-- +-- > bid ──╮ +-- > ▲ │ +-- > ╰────╯ +-- +-- The edge gets a weight of zero, which keeps it irrelevant for layout: +-- 'optimizeCFG' deliberately does not apply its back edge bonus to zero weight +-- edges, so @bid@ is not treated as the head of a hot loop. +-- +-- See also Note [Updating the CFG during CodeGen] +-- See also Note [Introducing cfg edges inside basic blocks] for some wrinkles around +-- self loops in particular. +addColdSelfLoop :: BlockId -> NatM () +addColdSelfLoop bid = updateCfgNat (addWeightEdge bid bid 0) + +-- | Allows us to bias layout towards a specific edge. +increaseEdgeWeight :: HasDebugCallStack => BlockId -> EdgeWeight -> NatM () +increaseEdgeWeight target bonus = do + cur <- currentBlock + updateCfgNat (\cfg -> adjustEdgeWeight cfg (+ bonus) cur target) + -- | Record that we added a block between `from` and `old`. addNodeBetweenNat :: BlockId -> BlockId -> BlockId -> NatM () addNodeBetweenNat from between to ===================================== compiler/GHC/CmmToAsm/X86/CodeGen.hs ===================================== @@ -47,8 +47,10 @@ import GHC.CmmToAsm.Monad , getDeltaNat, getBlockIdNat, getPicBaseNat , Reg64(..), RegCode64(..), getNewReg64, localReg64 , getPicBaseMaybeNat, getDebugBlock, getFileId - , addImmediateSuccessorNat, updateCfgNat, getConfig, getPlatform - , getCfgWeights + , getConfig, getPlatform + , setCurrentBlock, getCurrentBlock, currentBlock + , continueInNewBlock, addDiamondFlow, addCondBlock + , addColdSelfLoop, increaseEdgeWeight ) import GHC.CmmToAsm.CFG import GHC.CmmToAsm.Format @@ -216,6 +218,7 @@ basicBlockCodeGen block = do let (_, nodes, tail) = blockSplit block id = entryLabel block stmts = blockToList nodes + setCurrentBlock id -- Generate location directive dbg <- getDebugBlock (entryLabel block) loc_instrs <- case dblSourceTick =<< dbg of @@ -224,8 +227,8 @@ basicBlockCodeGen block = do let line = srcSpanStartLine span; col = srcSpanStartCol span return $ unitOL $ LOCATION fileId line col (unpackFS name) _ -> return nilOL - (mid_instrs,mid_bid) <- stmtsToInstrs id stmts - (!tail_instrs,_) <- stmtToInstrs mid_bid tail + mid_instrs <- stmtsToInstrs stmts + !tail_instrs <- stmtToInstrs tail let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs platform <- getPlatform return $! verifyBasicBlock platform (fromOL instrs) @@ -301,55 +304,41 @@ This resulted in two new basic blocks being inserted: jmp _c3B1 ... -Based on the Cmm we called stmtToInstrs we translated both atomic operations under -the assumption they would be placed into their Cmm basic block `c3Bf`. -However for the retry loop we introduce new labels, so this is not the case -for the second statement. -This resulted in a desync between the explicit control flow graph -we construct as a separate data type and the actual control flow graph in the code. +This is a relatively common occurance for a number of MachOps. And is, in fact, +not limited to statements but can also happen for Cmm expressions in general. +To ensure we always the basic block info around with which we can update the CFG +whenever we split up the control flow graph we keep track of that information +in the NatM state via setCurrentBlock. -Instead we now return the new basic block if a statement causes a change -in the current block and use the block for all following statements. - -For this reason genForeignCall is also split into two parts. One for calls which -*won't* change the basic blocks in which successive instructions will be -placed (since they only evaluate CmmExpr, which can only contain MachOps, which -cannot introduce basic blocks in their lowerings). A different one for calls -which *are* known to change the basic block. +This works because ultimately the control flow of those expressions and statements *does* +converge. So every expression, and every statement that wasn't a conditional branch at +the CMM level must converge in a single block. And whenver we are done generating the code +for one of those we can record the block in which it did so using setCurrentBlock. +While we could go all out and take this one step further and hoist the CFG updates fully +into NatM with combinators like `withDiamond (\left right cont -> ...)` for now we use +explicit CFG updates. -} --- See Note [Keeping track of the current block] for why --- we pass the BlockId. -stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in. - -> [CmmNode O O] -- ^ Cmm Statement - -> NatM (InstrBlock, BlockId) -- ^ Resulting instruction -stmtsToInstrs bid stmts = - go bid stmts nilOL +stmtsToInstrs :: [CmmNode O O] -- ^ Cmm Statements + -> NatM InstrBlock -- ^ Resulting instructions +stmtsToInstrs stmts = + go stmts nilOL where - go bid [] instrs = return (instrs,bid) - go bid (s:stmts) instrs = do - (instrs',bid') <- stmtToInstrs bid s - -- If the statement introduced a new block, we use that one - let !newBid = fromMaybe bid bid' - go newBid stmts (instrs `appOL` instrs') - --- | `bid` refers to the current block and is used to update the CFG --- if new blocks are inserted in the control flow. --- See Note [Keeping track of the current block] for more details. -stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in. - -> CmmNode e x - -> NatM (InstrBlock, Maybe BlockId) - -- ^ Instructions, and bid of new block if successive - -- statements are placed in a different basic block. -stmtToInstrs bid stmt = do + go [] instrs = return instrs + go (s:stmts) instrs = do + instrs' <- stmtToInstrs s + go stmts (instrs `appOL` instrs') + +stmtToInstrs :: CmmNode e x + -> NatM InstrBlock +stmtToInstrs stmt = do is32Bit <- is32BitPlatform platform <- getPlatform case stmt of - CmmUnsafeForeignCall target result_regs args - -> genForeignCall target result_regs args bid + CmmUnsafeForeignCall target result_regs args + -> genForeignCall target result_regs args - _ -> (,Nothing) <$> case stmt of CmmComment s -> return (unitOL (COMMENT s)) CmmTick {} -> return nilOL @@ -381,8 +370,8 @@ stmtToInstrs bid stmt = do --We try to arrange blocks such that the likely branch is the fallthrough --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here. - CmmCondBranch arg true false _ -> genCondBranch bid true false arg - CmmSwitch arg ids -> genSwitch arg ids bid + CmmCondBranch arg true false _ -> genCondBranch true false arg + CmmSwitch arg ids -> genSwitch arg ids CmmCall { cml_target = arg , cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs) _ -> @@ -734,6 +723,8 @@ iselExpr64 (CmmMachOp (MO_Shl _) [e1,e2]) = do Reg64 rhi rlo <- getNewReg64 lbl1 <- newBlockId lbl2 <- newBlockId + -- See Note [Updating the CFG during CodeGen] + addCondBlock lbl1 False lbl2 let code = code1 `appOL` code2 ecx `appOL` @@ -764,6 +755,8 @@ iselExpr64 (CmmMachOp (MO_S_Shr _) [e1,e2]) = do Reg64 rhi rlo <- getNewReg64 lbl1 <- newBlockId lbl2 <- newBlockId + -- See Note [Updating the CFG during CodeGen] + addCondBlock lbl1 False lbl2 let code = code1 `appOL` code2 `appOL` @@ -791,6 +784,8 @@ iselExpr64 (CmmMachOp (MO_U_Shr _) [e1,e2]) = do Reg64 rhi rlo <- getNewReg64 lbl1 <- newBlockId lbl2 <- newBlockId + -- See Note [Updating the CFG during CodeGen] + addCondBlock lbl1 False lbl2 let code = code1 `appOL` code2 `appOL` @@ -4151,21 +4146,20 @@ codes are set according to the supplied comparison operation. -} genCondBranch - :: BlockId -- the source of the jump - -> BlockId -- the true branch target + :: BlockId -- the true branch target -> BlockId -- the false branch target -> CmmExpr -- the condition on which to branch -> NatM InstrBlock -- Instructions -genCondBranch bid id false expr = do +genCondBranch id false expr = do is32Bit <- is32BitPlatform - genCondBranch' is32Bit bid id false expr + genCondBranch' is32Bit id false expr -- | We return the instructions generated. -genCondBranch' :: Bool -> BlockId -> BlockId -> BlockId -> CmmExpr +genCondBranch' :: Bool -> BlockId -> BlockId -> CmmExpr -> NatM InstrBlock -genCondBranch' _ bid id false bool = do +genCondBranch' _ id false bool = do CondCode is_float cond cond_code <- getCondCode bool if not is_float then @@ -4200,7 +4194,11 @@ genCondBranch' _ bid id false bool = do JXX cond id, JXX ALWAYS false ] - updateCfgNat (\cfg -> adjustEdgeWeight cfg (+3) bid false) + + -- We can fall through the false branch. Which makes it + -- beneficial to bias code layout towards placing the + -- false target after the jump. + increaseEdgeWeight false 3 return (cond_code `appOL` code) {- Note [Introducing cfg edges inside basic blocks] @@ -4315,147 +4313,129 @@ genCondBranch' _ bid id false bool = do -- -- (If applicable) Do not fill the delay slots here; you will confuse the -- register allocator. --- --- See Note [Keeping track of the current block] for information why we need --- to take/return a block id. genForeignCall :: ForeignTarget -- ^ function to call -> [CmmFormal] -- ^ where to put the result -> [CmmActual] -- ^ arguments (of mixed type) - -> BlockId -- ^ The block we are in - -> NatM (InstrBlock, Maybe BlockId) + -> NatM InstrBlock -genForeignCall target dst args bid = do +genForeignCall target dst args = do case target of - PrimTarget prim -> genPrim bid prim dst args - ForeignTarget addr conv -> (,Nothing) <$> genCCall bid addr conv dst args + PrimTarget prim -> genPrim prim dst args + ForeignTarget addr conv -> genCCall addr conv dst args genPrim - :: BlockId -- ^ The block we are in - -> CallishMachOp -- ^ MachOp - -> [CmmFormal] -- ^ where to put the result - -> [CmmActual] -- ^ arguments (of mixed type) - -> NatM (InstrBlock, Maybe BlockId) - --- First we deal with cases which might introduce new blocks in the stream. -genPrim bid (MO_AtomicRMW width amop) [dst] [addr, n] - = genAtomicRMW bid width amop dst addr n -genPrim bid (MO_Ctz width) [dst] [src] - = genCtz bid width dst src -genPrim bid (MO_UF_Conv width) [dst] [src] - = genWordToFloat bid width dst src - --- Then we deal with cases which not introducing new blocks in the stream. -genPrim bid prim dst args - = (,Nothing) <$> genSimplePrim bid prim dst args - -genSimplePrim - :: BlockId -- ^ the block we are in - -> CallishMachOp -- ^ MachOp + :: CallishMachOp -- ^ MachOp -> [CmmFormal] -- ^ where to put the result -> [CmmActual] -- ^ arguments (of mixed type) -> NatM InstrBlock -genSimplePrim bid (MO_Memcpy align) [] [dst,src,n] = genMemCpy bid align dst src n -genSimplePrim bid (MO_Memmove align) [] [dst,src,n] = genMemMove bid align dst src n -genSimplePrim bid (MO_Memcmp align) [res] [dst,src,n] = genMemCmp bid align res dst src n -genSimplePrim bid (MO_Memset align) [] [dst,c,n] = genMemSet bid align dst c n -genSimplePrim _ MO_AcquireFence [] [] = return nilOL -- barriers compile to no code on x86/x86-64; -genSimplePrim _ MO_ReleaseFence [] [] = return nilOL -- we keep it this long in order to prevent earlier optimisations. -genSimplePrim _ MO_SeqCstFence [] [] = return $ unitOL MFENCE -genSimplePrim _ MO_Touch [] [_] = return nilOL -genSimplePrim _ (MO_Prefetch_Data n) [] [src] = genPrefetchData n src -genSimplePrim _ (MO_BSwap width) [dst] [src] = genByteSwap width dst src -genSimplePrim bid (MO_BRev width) [dst] [src] = genBitRev bid width dst src -genSimplePrim bid (MO_PopCnt width) [dst] [src] = genPopCnt bid width dst src -genSimplePrim bid (MO_Pdep width) [dst] [src,mask] = genPdep bid width dst src mask -genSimplePrim bid (MO_Pext width) [dst] [src,mask] = genPext bid width dst src mask -genSimplePrim bid (MO_Clz width) [dst] [src] = genClz bid width dst src -genSimplePrim _ (MO_AtomicRead w mo) [dst] [addr] = genAtomicRead w mo dst addr -genSimplePrim _ (MO_AtomicWrite w mo) [] [addr,val] = genAtomicWrite w mo addr val -genSimplePrim bid (MO_Cmpxchg width) [dst] [addr,old,new] = genCmpXchg bid width dst addr old new -genSimplePrim _ (MO_Xchg width) [dst] [addr, value] = genXchg width dst addr value -genSimplePrim _ (MO_AddWordC w) [r,c] [x,y] = genAddSubRetCarry w ADD_CC (const Nothing) CARRY r c x y -genSimplePrim _ (MO_SubWordC w) [r,c] [x,y] = genAddSubRetCarry w SUB_CC (const Nothing) CARRY r c x y -genSimplePrim _ (MO_AddIntC w) [r,c] [x,y] = genAddSubRetCarry w ADD_CC (Just . ADD_CC) OFLO r c x y -genSimplePrim _ (MO_SubIntC w) [r,c] [x,y] = genAddSubRetCarry w SUB_CC (const Nothing) OFLO r c x y -genSimplePrim _ (MO_Add2 w) [h,l] [x,y] = genAddWithCarry w h l x y -genSimplePrim _ (MO_U_Mul2 w) [h,l] [x,y] = genUnsignedLargeMul w h l x y -genSimplePrim _ (MO_S_Mul2 w) [c,h,l] [x,y] = genSignedLargeMul w c h l x y -genSimplePrim _ (MO_S_QuotRem w) [q,r] [x,y] = genQuotRem w True q r Nothing x y -genSimplePrim _ (MO_U_QuotRem w) [q,r] [x,y] = genQuotRem w False q r Nothing x y -genSimplePrim _ (MO_U_QuotRem2 w) [q,r] [hx,lx,y] = genQuotRem w False q r (Just hx) lx y -genSimplePrim _ MO_F32_Fabs [dst] [src] = genFloatAbs W32 dst src -genSimplePrim _ MO_F64_Fabs [dst] [src] = genFloatAbs W64 dst src -genSimplePrim _ MO_F32_Sqrt [dst] [src] = genFloatSqrt FF32 dst src -genSimplePrim _ MO_F64_Sqrt [dst] [src] = genFloatSqrt FF64 dst src -genSimplePrim bid MO_F32_Sin [dst] [src] = genLibCCall bid (fsLit "sinf") [dst] [src] -genSimplePrim bid MO_F32_Cos [dst] [src] = genLibCCall bid (fsLit "cosf") [dst] [src] -genSimplePrim bid MO_F32_Tan [dst] [src] = genLibCCall bid (fsLit "tanf") [dst] [src] -genSimplePrim bid MO_F32_Exp [dst] [src] = genLibCCall bid (fsLit "expf") [dst] [src] -genSimplePrim bid MO_F32_ExpM1 [dst] [src] = genLibCCall bid (fsLit "expm1f") [dst] [src] -genSimplePrim bid MO_F32_Log [dst] [src] = genLibCCall bid (fsLit "logf") [dst] [src] -genSimplePrim bid MO_F32_Log1P [dst] [src] = genLibCCall bid (fsLit "log1pf") [dst] [src] -genSimplePrim bid MO_F32_Asin [dst] [src] = genLibCCall bid (fsLit "asinf") [dst] [src] -genSimplePrim bid MO_F32_Acos [dst] [src] = genLibCCall bid (fsLit "acosf") [dst] [src] -genSimplePrim bid MO_F32_Atan [dst] [src] = genLibCCall bid (fsLit "atanf") [dst] [src] -genSimplePrim bid MO_F32_Sinh [dst] [src] = genLibCCall bid (fsLit "sinhf") [dst] [src] -genSimplePrim bid MO_F32_Cosh [dst] [src] = genLibCCall bid (fsLit "coshf") [dst] [src] -genSimplePrim bid MO_F32_Tanh [dst] [src] = genLibCCall bid (fsLit "tanhf") [dst] [src] -genSimplePrim bid MO_F32_Pwr [dst] [x,y] = genLibCCall bid (fsLit "powf") [dst] [x,y] -genSimplePrim bid MO_F32_Asinh [dst] [src] = genLibCCall bid (fsLit "asinhf") [dst] [src] -genSimplePrim bid MO_F32_Acosh [dst] [src] = genLibCCall bid (fsLit "acoshf") [dst] [src] -genSimplePrim bid MO_F32_Atanh [dst] [src] = genLibCCall bid (fsLit "atanhf") [dst] [src] -genSimplePrim bid MO_F64_Sin [dst] [src] = genLibCCall bid (fsLit "sin") [dst] [src] -genSimplePrim bid MO_F64_Cos [dst] [src] = genLibCCall bid (fsLit "cos") [dst] [src] -genSimplePrim bid MO_F64_Tan [dst] [src] = genLibCCall bid (fsLit "tan") [dst] [src] -genSimplePrim bid MO_F64_Exp [dst] [src] = genLibCCall bid (fsLit "exp") [dst] [src] -genSimplePrim bid MO_F64_ExpM1 [dst] [src] = genLibCCall bid (fsLit "expm1") [dst] [src] -genSimplePrim bid MO_F64_Log [dst] [src] = genLibCCall bid (fsLit "log") [dst] [src] -genSimplePrim bid MO_F64_Log1P [dst] [src] = genLibCCall bid (fsLit "log1p") [dst] [src] -genSimplePrim bid MO_F64_Asin [dst] [src] = genLibCCall bid (fsLit "asin") [dst] [src] -genSimplePrim bid MO_F64_Acos [dst] [src] = genLibCCall bid (fsLit "acos") [dst] [src] -genSimplePrim bid MO_F64_Atan [dst] [src] = genLibCCall bid (fsLit "atan") [dst] [src] -genSimplePrim bid MO_F64_Sinh [dst] [src] = genLibCCall bid (fsLit "sinh") [dst] [src] -genSimplePrim bid MO_F64_Cosh [dst] [src] = genLibCCall bid (fsLit "cosh") [dst] [src] -genSimplePrim bid MO_F64_Tanh [dst] [src] = genLibCCall bid (fsLit "tanh") [dst] [src] -genSimplePrim bid MO_F64_Pwr [dst] [x,y] = genLibCCall bid (fsLit "pow") [dst] [x,y] -genSimplePrim bid MO_F64_Asinh [dst] [src] = genLibCCall bid (fsLit "asinh") [dst] [src] -genSimplePrim bid MO_F64_Acosh [dst] [src] = genLibCCall bid (fsLit "acosh") [dst] [src] -genSimplePrim bid MO_F64_Atanh [dst] [src] = genLibCCall bid (fsLit "atanh") [dst] [src] -genSimplePrim bid MO_SuspendThread [tok] [rs,i] = genRTSCCall bid (fsLit "suspendThread") [tok] [rs,i] -genSimplePrim bid MO_ResumeThread [rs] [tok] = genRTSCCall bid (fsLit "resumeThread") [rs] [tok] -genSimplePrim bid MO_I64_Quot [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotInt64") [dst] [x,y] -genSimplePrim bid MO_I64_Rem [dst] [x,y] = genPrimCCall bid (fsLit "hs_remInt64") [dst] [x,y] -genSimplePrim bid MO_W64_Quot [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotWord64") [dst] [x,y] -genSimplePrim bid MO_W64_Rem [dst] [x,y] = genPrimCCall bid (fsLit "hs_remWord64") [dst] [x,y] -genSimplePrim bid (MO_VS_Quot 16 W8) [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotInt8X16") [dst] [x,y] -genSimplePrim bid (MO_VS_Quot 8 W16) [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotInt16X8") [dst] [x,y] -genSimplePrim bid (MO_VS_Quot 4 W32) [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotInt32X4") [dst] [x,y] -genSimplePrim bid (MO_VS_Quot 2 W64) [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotInt64X2") [dst] [x,y] -genSimplePrim _ op@(MO_VS_Quot {}) _ _ = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op) -genSimplePrim bid (MO_VS_Rem 16 W8) [dst] [x,y] = genPrimCCall bid (fsLit "hs_remInt8X16") [dst] [x,y] -genSimplePrim bid (MO_VS_Rem 8 W16) [dst] [x,y] = genPrimCCall bid (fsLit "hs_remInt16X8") [dst] [x,y] -genSimplePrim bid (MO_VS_Rem 4 W32) [dst] [x,y] = genPrimCCall bid (fsLit "hs_remInt32X4") [dst] [x,y] -genSimplePrim bid (MO_VS_Rem 2 W64) [dst] [x,y] = genPrimCCall bid (fsLit "hs_remInt64X2") [dst] [x,y] -genSimplePrim _ op@(MO_VS_Rem {}) _ _ = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op) -genSimplePrim bid (MO_VU_Quot 16 W8) [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotWord8X16") [dst] [x,y] -genSimplePrim bid (MO_VU_Quot 8 W16) [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotWord16X8") [dst] [x,y] -genSimplePrim bid (MO_VU_Quot 4 W32) [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotWord32X4") [dst] [x,y] -genSimplePrim bid (MO_VU_Quot 2 W64) [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotWord64X2") [dst] [x,y] -genSimplePrim _ op@(MO_VU_Quot {}) _ _ = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op) -genSimplePrim bid (MO_VU_Rem 16 W8) [dst] [x,y] = genPrimCCall bid (fsLit "hs_remWord8X16") [dst] [x,y] -genSimplePrim bid (MO_VU_Rem 8 W16) [dst] [x,y] = genPrimCCall bid (fsLit "hs_remWord16X8") [dst] [x,y] -genSimplePrim bid (MO_VU_Rem 4 W32) [dst] [x,y] = genPrimCCall bid (fsLit "hs_remWord32X4") [dst] [x,y] -genSimplePrim bid (MO_VU_Rem 2 W64) [dst] [x,y] = genPrimCCall bid (fsLit "hs_remWord64X2") [dst] [x,y] -genSimplePrim _ op@(MO_VU_Rem {}) _ _ = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op) -genSimplePrim bid MO_I64X2_Min [dst] [x,y] = genPrimCCall bid (fsLit "hs_minInt64X2") [dst] [x,y] -genSimplePrim bid MO_I64X2_Max [dst] [x,y] = genPrimCCall bid (fsLit "hs_maxInt64X2") [dst] [x,y] -genSimplePrim bid MO_W64X2_Min [dst] [x,y] = genPrimCCall bid (fsLit "hs_minWord64X2") [dst] [x,y] -genSimplePrim bid MO_W64X2_Max [dst] [x,y] = genPrimCCall bid (fsLit "hs_maxWord64X2") [dst] [x,y] -genSimplePrim _ op dst args = do +genPrim (MO_AtomicRMW width amop) [dst] [addr, n] + = genAtomicRMW width amop dst addr n +genPrim (MO_Ctz width) [dst] [src] + = genCtz width dst src +genPrim (MO_UF_Conv width) [dst] [src] + = genWordToFloat width dst src +genPrim (MO_Memcpy align) [] [dst,src,n] = genMemCpy align dst src n +genPrim (MO_Memmove align) [] [dst,src,n] = genMemMove align dst src n +genPrim (MO_Memcmp align) [res] [dst,src,n] = genMemCmp align res dst src n +genPrim (MO_Memset align) [] [dst,c,n] = genMemSet align dst c n +genPrim MO_AcquireFence [] [] = return nilOL -- barriers compile to no code on x86/x86-64; +genPrim MO_ReleaseFence [] [] = return nilOL -- we keep it this long in order to prevent earlier optimisations. +genPrim MO_SeqCstFence [] [] = return $ unitOL MFENCE +genPrim MO_Touch [] [_] = return nilOL +genPrim (MO_Prefetch_Data n) [] [src] = genPrefetchData n src +genPrim (MO_BSwap width) [dst] [src] = genByteSwap width dst src +genPrim (MO_BRev width) [dst] [src] = genBitRev width dst src +genPrim (MO_PopCnt width) [dst] [src] = genPopCnt width dst src +genPrim (MO_Pdep width) [dst] [src,mask] = genPdep width dst src mask +genPrim (MO_Pext width) [dst] [src,mask] = genPext width dst src mask +genPrim (MO_Clz width) [dst] [src] = genClz width dst src +genPrim (MO_AtomicRead w mo) [dst] [addr] = genAtomicRead w mo dst addr +genPrim (MO_AtomicWrite w mo) [] [addr,val] = genAtomicWrite w mo addr val +genPrim (MO_Cmpxchg width) [dst] [addr,old,new] = genCmpXchg width dst addr old new +genPrim (MO_Xchg width) [dst] [addr, value] = genXchg width dst addr value +genPrim (MO_AddWordC w) [r,c] [x,y] = genAddSubRetCarry w ADD_CC (const Nothing) CARRY r c x y +genPrim (MO_SubWordC w) [r,c] [x,y] = genAddSubRetCarry w SUB_CC (const Nothing) CARRY r c x y +genPrim (MO_AddIntC w) [r,c] [x,y] = genAddSubRetCarry w ADD_CC (Just . ADD_CC) OFLO r c x y +genPrim (MO_SubIntC w) [r,c] [x,y] = genAddSubRetCarry w SUB_CC (const Nothing) OFLO r c x y +genPrim (MO_Add2 w) [h,l] [x,y] = genAddWithCarry w h l x y +genPrim (MO_U_Mul2 w) [h,l] [x,y] = genUnsignedLargeMul w h l x y +genPrim (MO_S_Mul2 w) [c,h,l] [x,y] = genSignedLargeMul w c h l x y +genPrim (MO_S_QuotRem w) [q,r] [x,y] = genQuotRem w True q r Nothing x y +genPrim (MO_U_QuotRem w) [q,r] [x,y] = genQuotRem w False q r Nothing x y +genPrim (MO_U_QuotRem2 w) [q,r] [hx,lx,y] = genQuotRem w False q r (Just hx) lx y +genPrim MO_F32_Fabs [dst] [src] = genFloatAbs W32 dst src +genPrim MO_F64_Fabs [dst] [src] = genFloatAbs W64 dst src +genPrim MO_F32_Sqrt [dst] [src] = genFloatSqrt FF32 dst src +genPrim MO_F64_Sqrt [dst] [src] = genFloatSqrt FF64 dst src +genPrim MO_F32_Sin [dst] [src] = genLibCCall (fsLit "sinf") [dst] [src] +genPrim MO_F32_Cos [dst] [src] = genLibCCall (fsLit "cosf") [dst] [src] +genPrim MO_F32_Tan [dst] [src] = genLibCCall (fsLit "tanf") [dst] [src] +genPrim MO_F32_Exp [dst] [src] = genLibCCall (fsLit "expf") [dst] [src] +genPrim MO_F32_ExpM1 [dst] [src] = genLibCCall (fsLit "expm1f") [dst] [src] +genPrim MO_F32_Log [dst] [src] = genLibCCall (fsLit "logf") [dst] [src] +genPrim MO_F32_Log1P [dst] [src] = genLibCCall (fsLit "log1pf") [dst] [src] +genPrim MO_F32_Asin [dst] [src] = genLibCCall (fsLit "asinf") [dst] [src] +genPrim MO_F32_Acos [dst] [src] = genLibCCall (fsLit "acosf") [dst] [src] +genPrim MO_F32_Atan [dst] [src] = genLibCCall (fsLit "atanf") [dst] [src] +genPrim MO_F32_Sinh [dst] [src] = genLibCCall (fsLit "sinhf") [dst] [src] +genPrim MO_F32_Cosh [dst] [src] = genLibCCall (fsLit "coshf") [dst] [src] +genPrim MO_F32_Tanh [dst] [src] = genLibCCall (fsLit "tanhf") [dst] [src] +genPrim MO_F32_Pwr [dst] [x,y] = genLibCCall (fsLit "powf") [dst] [x,y] +genPrim MO_F32_Asinh [dst] [src] = genLibCCall (fsLit "asinhf") [dst] [src] +genPrim MO_F32_Acosh [dst] [src] = genLibCCall (fsLit "acoshf") [dst] [src] +genPrim MO_F32_Atanh [dst] [src] = genLibCCall (fsLit "atanhf") [dst] [src] +genPrim MO_F64_Sin [dst] [src] = genLibCCall (fsLit "sin") [dst] [src] +genPrim MO_F64_Cos [dst] [src] = genLibCCall (fsLit "cos") [dst] [src] +genPrim MO_F64_Tan [dst] [src] = genLibCCall (fsLit "tan") [dst] [src] +genPrim MO_F64_Exp [dst] [src] = genLibCCall (fsLit "exp") [dst] [src] +genPrim MO_F64_ExpM1 [dst] [src] = genLibCCall (fsLit "expm1") [dst] [src] +genPrim MO_F64_Log [dst] [src] = genLibCCall (fsLit "log") [dst] [src] +genPrim MO_F64_Log1P [dst] [src] = genLibCCall (fsLit "log1p") [dst] [src] +genPrim MO_F64_Asin [dst] [src] = genLibCCall (fsLit "asin") [dst] [src] +genPrim MO_F64_Acos [dst] [src] = genLibCCall (fsLit "acos") [dst] [src] +genPrim MO_F64_Atan [dst] [src] = genLibCCall (fsLit "atan") [dst] [src] +genPrim MO_F64_Sinh [dst] [src] = genLibCCall (fsLit "sinh") [dst] [src] +genPrim MO_F64_Cosh [dst] [src] = genLibCCall (fsLit "cosh") [dst] [src] +genPrim MO_F64_Tanh [dst] [src] = genLibCCall (fsLit "tanh") [dst] [src] +genPrim MO_F64_Pwr [dst] [x,y] = genLibCCall (fsLit "pow") [dst] [x,y] +genPrim MO_F64_Asinh [dst] [src] = genLibCCall (fsLit "asinh") [dst] [src] +genPrim MO_F64_Acosh [dst] [src] = genLibCCall (fsLit "acosh") [dst] [src] +genPrim MO_F64_Atanh [dst] [src] = genLibCCall (fsLit "atanh") [dst] [src] +genPrim MO_SuspendThread [tok] [rs,i] = genRTSCCall (fsLit "suspendThread") [tok] [rs,i] +genPrim MO_ResumeThread [rs] [tok] = genRTSCCall (fsLit "resumeThread") [rs] [tok] +genPrim MO_I64_Quot [dst] [x,y] = genPrimCCall (fsLit "hs_quotInt64") [dst] [x,y] +genPrim MO_I64_Rem [dst] [x,y] = genPrimCCall (fsLit "hs_remInt64") [dst] [x,y] +genPrim MO_W64_Quot [dst] [x,y] = genPrimCCall (fsLit "hs_quotWord64") [dst] [x,y] +genPrim MO_W64_Rem [dst] [x,y] = genPrimCCall (fsLit "hs_remWord64") [dst] [x,y] +genPrim (MO_VS_Quot 16 W8) [dst] [x,y] = genPrimCCall (fsLit "hs_quotInt8X16") [dst] [x,y] +genPrim (MO_VS_Quot 8 W16) [dst] [x,y] = genPrimCCall (fsLit "hs_quotInt16X8") [dst] [x,y] +genPrim (MO_VS_Quot 4 W32) [dst] [x,y] = genPrimCCall (fsLit "hs_quotInt32X4") [dst] [x,y] +genPrim (MO_VS_Quot 2 W64) [dst] [x,y] = genPrimCCall (fsLit "hs_quotInt64X2") [dst] [x,y] +genPrim op@(MO_VS_Quot {}) _ _ = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op) +genPrim (MO_VS_Rem 16 W8) [dst] [x,y] = genPrimCCall (fsLit "hs_remInt8X16") [dst] [x,y] +genPrim (MO_VS_Rem 8 W16) [dst] [x,y] = genPrimCCall (fsLit "hs_remInt16X8") [dst] [x,y] +genPrim (MO_VS_Rem 4 W32) [dst] [x,y] = genPrimCCall (fsLit "hs_remInt32X4") [dst] [x,y] +genPrim (MO_VS_Rem 2 W64) [dst] [x,y] = genPrimCCall (fsLit "hs_remInt64X2") [dst] [x,y] +genPrim op@(MO_VS_Rem {}) _ _ = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op) +genPrim (MO_VU_Quot 16 W8) [dst] [x,y] = genPrimCCall (fsLit "hs_quotWord8X16") [dst] [x,y] +genPrim (MO_VU_Quot 8 W16) [dst] [x,y] = genPrimCCall (fsLit "hs_quotWord16X8") [dst] [x,y] +genPrim (MO_VU_Quot 4 W32) [dst] [x,y] = genPrimCCall (fsLit "hs_quotWord32X4") [dst] [x,y] +genPrim (MO_VU_Quot 2 W64) [dst] [x,y] = genPrimCCall (fsLit "hs_quotWord64X2") [dst] [x,y] +genPrim op@(MO_VU_Quot {}) _ _ = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op) +genPrim (MO_VU_Rem 16 W8) [dst] [x,y] = genPrimCCall (fsLit "hs_remWord8X16") [dst] [x,y] +genPrim (MO_VU_Rem 8 W16) [dst] [x,y] = genPrimCCall (fsLit "hs_remWord16X8") [dst] [x,y] +genPrim (MO_VU_Rem 4 W32) [dst] [x,y] = genPrimCCall (fsLit "hs_remWord32X4") [dst] [x,y] +genPrim (MO_VU_Rem 2 W64) [dst] [x,y] = genPrimCCall (fsLit "hs_remWord64X2") [dst] [x,y] +genPrim op@(MO_VU_Rem {}) _ _ = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op) +genPrim MO_I64X2_Min [dst] [x,y] = genPrimCCall (fsLit "hs_minInt64X2") [dst] [x,y] +genPrim MO_I64X2_Max [dst] [x,y] = genPrimCCall (fsLit "hs_maxInt64X2") [dst] [x,y] +genPrim MO_W64X2_Min [dst] [x,y] = genPrimCCall (fsLit "hs_minWord64X2") [dst] [x,y] +genPrim MO_W64X2_Max [dst] [x,y] = genPrimCCall (fsLit "hs_maxWord64X2") [dst] [x,y] +genPrim op dst args = do platform <- ncgPlatform <$> getConfig - pprPanic "genSimplePrim: unhandled primop" (ppr (pprCallishMachOp op, dst, fmap (pdoc platform) args)) + pprPanic "genPrim: unhandled primop" (ppr (pprCallishMachOp op, dst, fmap (pdoc platform) args)) {- Note [Evaluate C-call arguments before placing in destination registers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -4507,8 +4487,8 @@ genForeignCall{32,64}. -} -- | See Note [Evaluate C-call arguments before placing in destination registers] -evalArgs :: BlockId -> [CmmActual] -> NatM (InstrBlock, [CmmActual]) -evalArgs bid actuals +evalArgs :: [CmmActual] -> NatM (InstrBlock, [CmmActual]) +evalArgs actuals | any loadIntoRegMightClobberOtherReg actuals = do regs_blks <- mapM evalArg actuals return (concatOL $ map fst regs_blks, map snd regs_blks) @@ -4519,9 +4499,11 @@ evalArgs bid actuals evalArg actual = do platform <- getPlatform lreg <- newLocalReg $ cmmExprType platform actual - (instrs, bid1) <- stmtToInstrs bid $ CmmAssign (CmmLocal lreg) actual + cur <- getCurrentBlock + instrs <- stmtToInstrs $ CmmAssign (CmmLocal lreg) actual -- The above assignment shouldn't change the current block - massert (isNothing bid1) + cur' <- getCurrentBlock + massert (cur == cur') return (instrs, CmmReg $ CmmLocal lreg) newLocalReg :: CmmType -> NatM LocalReg @@ -4556,27 +4538,25 @@ loadIntoRegMightClobberOtherReg _ = True -- | Generate C call to the given function in ghc-prim genPrimCCall - :: BlockId - -> FastString + :: FastString -> [CmmFormal] -> [CmmActual] -> NatM InstrBlock -genPrimCCall bid lbl_txt dsts args = do +genPrimCCall lbl_txt dsts args = do config <- getConfig -- FIXME: we should use mkForeignLabel instead of mkCmmCodeLabel let lbl = mkCmmCodeLabel ghcInternalUnitId lbl_txt addr <- cmmMakeDynamicReference config CallReference lbl let conv = ForeignConvention CCallConv [] [] CmmMayReturn - genCCall bid addr conv dsts args + genCCall addr conv dsts args -- | Generate C call to the given function in libc genLibCCall - :: BlockId - -> FastString + :: FastString -> [CmmFormal] -> [CmmActual] -> NatM InstrBlock -genLibCCall bid lbl_txt dsts args = do +genLibCCall lbl_txt dsts args = do config <- getConfig -- Assume we can call these functions directly, and that they're not in a dynamic library. -- TODO: Why is this ok? Under linux this code will be in libm.so @@ -4584,37 +4564,35 @@ genLibCCall bid lbl_txt dsts args = do let lbl = mkForeignLabel lbl_txt ForeignLabelInThisPackage IsFunction addr <- cmmMakeDynamicReference config CallReference lbl let conv = ForeignConvention CCallConv [] [] CmmMayReturn - genCCall bid addr conv dsts args + genCCall addr conv dsts args -- | Generate C call to the given function in the RTS genRTSCCall - :: BlockId - -> FastString + :: FastString -> [CmmFormal] -> [CmmActual] -> NatM InstrBlock -genRTSCCall bid lbl_txt dsts args = do +genRTSCCall lbl_txt dsts args = do config <- getConfig -- Assume we can call these functions directly, and that they're not in a dynamic library. let lbl = mkForeignLabel lbl_txt ForeignLabelInThisPackage IsFunction addr <- cmmMakeDynamicReference config CallReference lbl let conv = ForeignConvention CCallConv [] [] CmmMayReturn - genCCall bid addr conv dsts args + genCCall addr conv dsts args -- | Generate a real C call to the given address with the given convention genCCall - :: BlockId - -> CmmExpr + :: CmmExpr -> ForeignConvention -> [CmmFormal] -> [CmmActual] -> NatM InstrBlock -genCCall bid addr conv@(ForeignConvention _ argHints _ _) dest_regs args = do +genCCall addr conv@(ForeignConvention _ argHints _ _) dest_regs args = do platform <- getPlatform is32Bit <- is32BitPlatform let args_hints = zip args (argHints ++ repeat NoHint) prom_args = map (maybePromoteCArgToW32 platform) args_hints - (instrs0, args') <- evalArgs bid prom_args + (instrs0, args') <- evalArgs prom_args instrs1 <- if is32Bit then genCCall32 addr conv dest_regs args' else genCCall64 addr conv dest_regs args' @@ -5575,8 +5553,8 @@ read the table and to compute the target address. However: -- | Generate a JMP_TBL instruction -- -- See Note [Jump tables] -genSwitch :: CmmExpr -> SwitchTargets -> BlockId -> NatM InstrBlock -genSwitch expr targets bid = do +genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock +genSwitch expr targets = do config <- getConfig let platform = ncgPlatform config expr_w = cmmExprWidth platform expr @@ -5595,7 +5573,6 @@ genSwitch expr targets bid = do fmt = archWordFormat is32bit table_lbl <- getNewLabelNat - let bid_lbl = blockLbl bid let table_section = Section ReadOnlyData table_lbl -- see Note [Jump tables] for a description of the following 3 variants. @@ -5607,6 +5584,9 @@ genSwitch expr targets bid = do -- way (via cmmMakeDynamicReference). (reg,e_code) <- getNonClobberedReg indexExpr -- getNonClobberedReg because it needs to survive across t_code and j_code (tableReg,t_code) <- getNonClobberedReg =<< cmmMakeDynamicReference config DataReference table_lbl + -- We make the jump table entries relative to the current block to ensure we don't + -- overflow. + bid_lbl <- blockLbl <$> currentBlock (targetReg,j_code) <- getSomeReg =<< cmmMakeDynamicReference config DataReference bid_lbl pure $ e_code `appOL` t_code `appOL` j_code `appOL` toOL [ ADD fmt (OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0))) @@ -6124,14 +6104,13 @@ invertCondBranches (Just cfg) keep bs = invert [] = [] genAtomicRMW - :: BlockId - -> Width + :: Width -> AtomicMachOp -> LocalReg -> CmmExpr -> CmmExpr - -> NatM (InstrBlock, Maybe BlockId) -genAtomicRMW bid width amop dst addr n = do + -> NatM InstrBlock +genAtomicRMW width amop dst addr n = do Amode amode addr_code <- if amop `elem` [AMO_Add, AMO_Sub] then getAmode addr @@ -6141,28 +6120,28 @@ genAtomicRMW bid width amop dst addr n = do platform <- ncgPlatform <$> getConfig let dst_r = getRegisterReg platform (CmmLocal dst) - (code, lbl) <- op_code dst_r arg amode - return (addr_code `appOL` arg_code arg `appOL` code, Just lbl) + code <- op_code dst_r arg amode + return (addr_code `appOL` arg_code arg `appOL` code) where -- Code for the operation op_code :: Reg -- Destination reg -> Reg -- Register containing argument -> AddrMode -- Address of location to mutate - -> NatM (OrdList Instr,BlockId) -- TODO: Return Maybe BlockId + -> NatM (OrdList Instr) op_code dst_r arg amode = do case amop of -- In the common case where dst_r is a virtual register the -- final move should go away, because it's the last use of arg -- and the first use of dst_r. - AMO_Add -> return $ (toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode)) - , MOV format (OpReg arg) (OpReg dst_r) - ], bid) - AMO_Sub -> return $ (toOL [ NEGI format (OpReg arg) - , LOCK (XADD format (OpReg arg) (OpAddr amode)) - , MOV format (OpReg arg) (OpReg dst_r) - ], bid) - -- In these cases we need a new block id, and have to return it so - -- that later instruction selection can reference it. + AMO_Add -> return $ toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode)) + , MOV format (OpReg arg) (OpReg dst_r) + ] + AMO_Sub -> return $ toOL [ NEGI format (OpReg arg) + , LOCK (XADD format (OpReg arg) (OpAddr amode)) + , MOV format (OpReg arg) (OpReg dst_r) + ] + -- In these cases we need a new block id, and set it as current block + -- so that later instruction selection can reference it. AMO_And -> cmpxchg_code (\ src dst -> unitOL $ AND format src dst) AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND format src dst , NOT format dst @@ -6173,7 +6152,7 @@ genAtomicRMW bid width amop dst addr n = do -- Simulate operation that lacks a dedicated instruction using -- cmpxchg. cmpxchg_code :: (Operand -> Operand -> OrdList Instr) - -> NatM (OrdList Instr, BlockId) + -> NatM (OrdList Instr) cmpxchg_code instrs = do lbl1 <- getBlockIdNat lbl2 <- getBlockIdNat @@ -6182,11 +6161,12 @@ genAtomicRMW bid width amop dst addr n = do --Record inserted blocks -- We turn A -> B into A -> A' -> A'' -> B -- with a self loop on A'. - addImmediateSuccessorNat bid lbl1 - addImmediateSuccessorNat lbl1 lbl2 - updateCfgNat (addWeightEdge lbl1 lbl1 0) + -- See Note [Introducing cfg edges inside basic blocks] + _ <- continueInNewBlock lbl1 + _ <- continueInNewBlock lbl2 + addColdSelfLoop lbl1 - return $ (toOL + return $ toOL [ MOV format (OpAddr amode) (OpReg eax) , JXX ALWAYS lbl1 , NEWBLOCK lbl1 @@ -6201,27 +6181,25 @@ genAtomicRMW bid width amop dst addr n = do -- why this basic block is required. , JXX ALWAYS lbl2 , NEWBLOCK lbl2 - ], - lbl2) + ] format = intFormat width -- | Count trailing zeroes -genCtz :: BlockId -> Width -> LocalReg -> CmmExpr -> NatM (InstrBlock, Maybe BlockId) -genCtz bid width dst src = do +genCtz :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock +genCtz width dst src = do is32Bit <- is32BitPlatform if is32Bit && width == W64 - then genCtz64_32 bid dst src - else (,Nothing) <$> genCtzGeneric width dst src + then genCtz64_32 dst src + else genCtzGeneric width dst src -- | Count trailing zeroes -- -- 64-bit width on 32-bit architecture genCtz64_32 - :: BlockId - -> LocalReg + :: LocalReg -> CmmExpr - -> NatM (InstrBlock, Maybe BlockId) -genCtz64_32 bid dst src = do + -> NatM InstrBlock +genCtz64_32 dst src = do RegCode64 vcode rhi rlo <- iselExpr64 src let dst_r = getLocalRegReg dst lbl1 <- getBlockIdNat @@ -6229,13 +6207,12 @@ genCtz64_32 bid dst src = do tmp_r <- getNewRegNat II64 -- New CFG Edges: - -- bid -> lbl2 - -- bid -> lbl1 -> lbl2 - -- We also changes edges originating at bid to start at lbl2 instead. - weights <- getCfgWeights - updateCfgNat (addWeightEdge bid lbl1 110 . - addWeightEdge lbl1 lbl2 110 . - addImmediateSuccessor weights bid lbl2) + -- cur -> lbl2 + -- cur -> lbl1 -> lbl2 + -- We also change edges originating at the current block to start at lbl2 + -- instead. + -- lbl1 is only skipped when src is zero, so it is the likely branch here. + addCondBlock lbl1 True lbl2 -- The following instruction sequence corresponds to the pseudo-code -- @@ -6260,7 +6237,7 @@ genCtz64_32 bid dst src = do , NEWBLOCK lbl2 ]) - return (instrs, Just lbl2) + return instrs -- | Count trailing zeroes -- @@ -6308,15 +6285,14 @@ genCtzGeneric width dst src = do -- Unroll memcpy calls if the number of bytes to copy isn't too large (cf -- ncgInlineThresholdMemcpy). Otherwise, call C's memcpy. genMemCpy - :: BlockId - -> Int + :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> NatM InstrBlock -genMemCpy bid align dst src arg_n = do +genMemCpy align dst src arg_n = do - let libc_memcpy = genLibCCall bid (fsLit "memcpy") [] [dst,src,arg_n] + let libc_memcpy = genLibCCall (fsLit "memcpy") [] [dst,src,arg_n] case arg_n of CmmLit (CmmInt n _) -> do @@ -6399,15 +6375,14 @@ genMemCpyInlineMaybe align dst src n = do -- Unroll memset calls if the number of bytes to copy isn't too large (cf -- ncgInlineThresholdMemset). Otherwise, call C's memset. genMemSet - :: BlockId - -> Int + :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> NatM InstrBlock -genMemSet bid align dst arg_c arg_n = do +genMemSet align dst arg_c arg_n = do - let libc_memset = genLibCCall bid (fsLit "memset") [] [dst,arg_c,arg_n] + let libc_memset = genLibCCall (fsLit "memset") [] [dst,arg_c,arg_n] case (arg_c,arg_n) of (CmmLit (CmmInt c _), CmmLit (CmmInt n _)) -> do @@ -6503,17 +6478,17 @@ genMemSetInlineMaybe align dst c n = do go4 dst_r (fromInteger n) -genMemMove :: BlockId -> p -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock -genMemMove bid _align dst src n = do +genMemMove :: p -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock +genMemMove _align dst src n = do -- TODO: generate inline assembly when under a given threshold (similarly to -- memcpy and memset) - genLibCCall bid (fsLit "memmove") [] [dst,src,n] + genLibCCall (fsLit "memmove") [] [dst,src,n] -genMemCmp :: BlockId -> p -> CmmFormal -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock -genMemCmp bid _align res dst src n = do +genMemCmp :: p -> CmmFormal -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock +genMemCmp _align res dst src n = do -- TODO: generate inline assembly when under a given threshold (similarly to -- memcpy and memset) - genLibCCall bid (fsLit "memcmp") [res] [dst,src,n] + genLibCCall (fsLit "memcmp") [res] [dst,src,n] genPrefetchData :: Int -> CmmExpr -> NatM (OrdList Instr) genPrefetchData n src = do @@ -6575,14 +6550,14 @@ genByteSwap width dst src = do code_src <- getAnyReg src return $ code_src dst_r `appOL` unitOL (BSWAP format dst_r) -genBitRev :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock -genBitRev bid width dst src = do +genBitRev :: Width -> CmmFormal -> CmmActual -> NatM InstrBlock +genBitRev width dst src = do -- Here the C implementation (hs_bitrevN) is used as there is no x86 -- instruction to reverse a word's bit order. - genPrimCCall bid (bRevLabel width) [dst] [src] + genPrimCCall (bRevLabel width) [dst] [src] -genPopCnt :: BlockId -> Width -> LocalReg -> CmmExpr -> NatM InstrBlock -genPopCnt bid width dst src = do +genPopCnt :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock +genPopCnt width dst src = do config <- getConfig let platform = ncgPlatform config @@ -6611,11 +6586,11 @@ genPopCnt bid width dst src = do -- generate C call to hs_popcntN in ghc-prim -- TODO: we could directly generate the assembly to index popcount_tab -- here instead of doing it by calling a C function - genPrimCCall bid (popCntLabel width) [dst] [src] + genPrimCCall (popCntLabel width) [dst] [src] -genPdep :: BlockId -> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock -genPdep bid width dst src mask = do +genPdep :: Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock +genPdep width dst src mask = do config <- getConfig let platform = ncgPlatform config @@ -6642,11 +6617,11 @@ genPdep bid width dst src mask = do ) else -- generate C call to hs_pdepN in ghc-prim - genPrimCCall bid (pdepLabel width) [dst] [src,mask] + genPrimCCall (pdepLabel width) [dst] [src,mask] -genPext :: BlockId -> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock -genPext bid width dst src mask = do +genPext :: Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock +genPext width dst src mask = do config <- getConfig if ncgBmiVersion config >= Just BMI2 then do @@ -6670,17 +6645,17 @@ genPext bid width dst src mask = do ) else -- generate C call to hs_pextN in ghc-prim - genPrimCCall bid (pextLabel width) [dst] [src,mask] + genPrimCCall (pextLabel width) [dst] [src,mask] -genClz :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock -genClz bid width dst src = do +genClz :: Width -> CmmFormal -> CmmActual -> NatM InstrBlock +genClz width dst src = do is32Bit <- is32BitPlatform config <- getConfig if is32Bit && width == W64 then -- Fallback to `hs_clz64` on i386 - genPrimCCall bid (clzLabel width) [dst] [src] + genPrimCCall (clzLabel width) [dst] [src] else do code_src <- getAnyReg src @@ -6777,8 +6752,8 @@ The constant 65536.0 (= 0x47800000 in float32 bit-pattern) is loaded via a MOV + MOVD, avoiding a memory load. -} -genWordToFloat :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM (InstrBlock, Maybe BlockId) -genWordToFloat bid width dst src = do +genWordToFloat :: Width -> CmmFormal -> CmmActual -> NatM InstrBlock +genWordToFloat width dst src = do is32Bit <- is32BitPlatform platform <- getPlatform @@ -6837,7 +6812,7 @@ genWordToFloat bid width dst src = do , ADD dstFormat (OpReg tmp_v) (OpReg dst_r) -- dst_r = float(high)*65536.0 + float(low) ] _ -> panic ("genWordToFloat: unsupported source operand format: " ++ show srcFormat) - pure (code, Nothing) + pure code else do -- See Note [Word-to-float conversion on x86-64] half_r <- getNewRegNat srcFormat @@ -6847,19 +6822,9 @@ genWordToFloat bid width dst src = do lblSmall <- getBlockIdNat lblAfter <- getBlockIdNat - -- We're building a diamond CFG: - -- bid -> lblSmall -> lblAfter -> origSucc - -- \-> lblLarge ->/ - -- addImmediateSuccessorNat moves bid's original successor to lblAfter, - -- then we fix up the other edges. - addImmediateSuccessorNat bid lblAfter -- Small values (MSB clear, i.e. < 2^63) are assumed more common in - -- practice, hence the higher weight on the lblSmall edge. - updateCfgNat ( addWeightEdge bid lblSmall 100 - . addWeightEdge bid lblLarge 50 - . addWeightEdge lblSmall lblAfter 1 - . addWeightEdge lblLarge lblAfter 1 - . delEdge bid lblAfter ) + -- practice, making lblSmall the likely branch of the diamond. + addDiamondFlow lblSmall lblLarge lblAfter let code = appOL (code_src) $ toOL @@ -6882,7 +6847,7 @@ genWordToFloat bid width dst src = do , JXX ALWAYS lblAfter , NEWBLOCK lblAfter ] - return (code, Just lblAfter) + return code genAtomicRead :: Width -> MemoryOrdering -> LocalReg -> CmmExpr -> NatM InstrBlock genAtomicRead width _mord dst addr = do @@ -6901,14 +6866,13 @@ genAtomicWrite width mord addr val = do return $ if needs_fence then code `snocOL` MFENCE else code genCmpXchg - :: BlockId - -> Width + :: Width -> LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> NatM InstrBlock -genCmpXchg bid width dst addr old new = do +genCmpXchg width dst addr old new = do is32Bit <- is32BitPlatform -- On x86 we don't have enough registers to use cmpxchg with a -- complicated addressing mode, so on that architecture we @@ -6932,7 +6896,7 @@ genCmpXchg bid width dst addr old new = do `appOL` code else -- generate C call to hs_cmpxchgN in ghc-prim - genPrimCCall bid (cmpxchgLabel width) [dst] [addr,old,new] + genPrimCCall (cmpxchgLabel width) [dst] [addr,old,new] -- TODO: implement cmpxchg8b instruction genXchg :: Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a8d57da7c14594a6a29a869e10437c2... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a8d57da7c14594a6a29a869e10437c2... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help