From 55fd158dfaebe96ef02d623b512b7559283a6f0a Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Tue, 22 Dec 2020 15:04:34 -0500 Subject: [PATCH 1/2] CmmToAsm.Reg.Linear: Use concat rather than repeated (++) --- compiler/GHC/CmmToAsm/Reg/Linear.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/compiler/GHC/CmmToAsm/Reg/Linear.hs b/compiler/GHC/CmmToAsm/Reg/Linear.hs index 19da3721e00..31bcbd1d687 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear.hs @@ -595,8 +595,7 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = do | src == dst -> [] _ -> [patched_instr] - let code = squashed_instr ++ w_spills ++ reverse r_spills - ++ clobber_saves ++ new_instrs + let code = concat [ squashed_instr, w_spills, reverse r_spills, clobber_saves, new_instrs ] -- pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do -- pprTrace "pached-fixup" ((ppr fixup_blocks)) $ do -- GitLab From 23f4bc89406de24ec77ced45aa267f9a8f8aaa60 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Tue, 22 Dec 2020 14:26:43 -0500 Subject: [PATCH 2/2] CmmToAsm.Reg.Linear: oneShot-ify RegM ------------------------- Metric Decrease: T783 T4801 T12707 T13379 T3294 T4801 T5321FD ------------------------- --- compiler/GHC/CmmToAsm/Reg/Linear/State.hs | 38 +++++++++++++---------- 1 file changed, 22 insertions(+), 16 deletions(-) diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/State.hs b/compiler/GHC/CmmToAsm/Reg/Linear/State.hs index b36270f3bcc..4fdc5c96cf2 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear/State.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/State.hs @@ -50,6 +50,7 @@ import GHC.Cmm.BlockId import GHC.Platform import GHC.Types.Unique import GHC.Types.Unique.Supply +import GHC.Exts (oneShot) import Control.Monad (ap) @@ -64,16 +65,21 @@ newtype RegM freeRegs a = RegM { unReg :: RA_State freeRegs -> RA_Result freeRegs a } deriving (Functor) +-- | Smart constructor for 'RegM', as described in Note [The one-shot state +-- monad trick] in GHC.Utils.Monad. +mkRegM :: (RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a +mkRegM f = RegM (oneShot f) + instance Applicative (RegM freeRegs) where - pure a = RegM $ \s -> RA_Result s a + pure a = mkRegM $ \s -> RA_Result s a (<*>) = ap instance Monad (RegM freeRegs) where - m >>= k = RegM $ \s -> case unReg m s of { RA_Result s a -> unReg (k a) s } + m >>= k = mkRegM $ \s -> case unReg m s of { RA_Result s a -> unReg (k a) s } -- | Get native code generator configuration getConfig :: RegM a NCGConfig -getConfig = RegM $ \s -> RA_Result s (ra_config s) +getConfig = mkRegM $ \s -> RA_Result s (ra_config s) -- | Get target platform from native code generator configuration getPlatform :: RegM a Platform @@ -117,7 +123,7 @@ makeRAStats state spillR :: Instruction instr => Reg -> Unique -> RegM freeRegs (instr, Int) -spillR reg temp = RegM $ \s -> +spillR reg temp = mkRegM $ \s -> let (stack1,slot) = getStackSlotFor (ra_stack s) temp instr = mkSpillInstr (ra_config s) reg (ra_delta s) slot in @@ -127,42 +133,42 @@ spillR reg temp = RegM $ \s -> loadR :: Instruction instr => Reg -> Int -> RegM freeRegs instr -loadR reg slot = RegM $ \s -> +loadR reg slot = mkRegM $ \s -> RA_Result s (mkLoadInstr (ra_config s) reg (ra_delta s) slot) getFreeRegsR :: RegM freeRegs freeRegs -getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} -> +getFreeRegsR = mkRegM $ \ s@RA_State{ra_freeregs = freeregs} -> RA_Result s freeregs setFreeRegsR :: freeRegs -> RegM freeRegs () -setFreeRegsR regs = RegM $ \ s -> +setFreeRegsR regs = mkRegM $ \ s -> RA_Result s{ra_freeregs = regs} () getAssigR :: RegM freeRegs (RegMap Loc) -getAssigR = RegM $ \ s@RA_State{ra_assig = assig} -> +getAssigR = mkRegM $ \ s@RA_State{ra_assig = assig} -> RA_Result s assig setAssigR :: RegMap Loc -> RegM freeRegs () -setAssigR assig = RegM $ \ s -> +setAssigR assig = mkRegM $ \ s -> RA_Result s{ra_assig=assig} () getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs) -getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} -> +getBlockAssigR = mkRegM $ \ s@RA_State{ra_blockassig = assig} -> RA_Result s assig setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs () -setBlockAssigR assig = RegM $ \ s -> +setBlockAssigR assig = mkRegM $ \ s -> RA_Result s{ra_blockassig = assig} () setDeltaR :: Int -> RegM freeRegs () -setDeltaR n = RegM $ \ s -> +setDeltaR n = mkRegM $ \ s -> RA_Result s{ra_delta = n} () getDeltaR :: RegM freeRegs Int -getDeltaR = RegM $ \s -> RA_Result s (ra_delta s) +getDeltaR = mkRegM $ \s -> RA_Result s (ra_delta s) getUniqueR :: RegM freeRegs Unique -getUniqueR = RegM $ \s -> +getUniqueR = mkRegM $ \s -> case takeUniqFromSupply (ra_us s) of (uniq, us) -> RA_Result s{ra_us = us} uniq @@ -170,9 +176,9 @@ getUniqueR = RegM $ \s -> -- | Record that a spill instruction was inserted, for profiling. recordSpill :: SpillReason -> RegM freeRegs () recordSpill spill - = RegM $ \s -> RA_Result (s { ra_spills = spill : ra_spills s }) () + = mkRegM $ \s -> RA_Result (s { ra_spills = spill : ra_spills s }) () -- | Record a created fixup block recordFixupBlock :: BlockId -> BlockId -> BlockId -> RegM freeRegs () recordFixupBlock from between to - = RegM $ \s -> RA_Result (s { ra_fixups = (from,between,to) : ra_fixups s }) () + = mkRegM $ \s -> RA_Result (s { ra_fixups = (from,between,to) : ra_fixups s }) () -- GitLab