{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.CmmToAsm.Reg.Linear (
regAlloc,
module GHC.CmmToAsm.Reg.Linear.Base,
module GHC.CmmToAsm.Reg.Linear.Stats
) where
import GHC.Prelude
import GHC.CmmToAsm.Reg.Linear.State
import GHC.CmmToAsm.Reg.Linear.Base
import GHC.CmmToAsm.Reg.Linear.StackMap
import GHC.CmmToAsm.Reg.Linear.FreeRegs
import GHC.CmmToAsm.Reg.Linear.Stats
import GHC.CmmToAsm.Reg.Linear.JoinToTargets
import qualified GHC.CmmToAsm.Reg.Linear.PPC as PPC
import qualified GHC.CmmToAsm.Reg.Linear.X86 as X86
import qualified GHC.CmmToAsm.Reg.Linear.X86_64 as X86_64
import qualified GHC.CmmToAsm.Reg.Linear.AArch64 as AArch64
import qualified GHC.CmmToAsm.Reg.Linear.RV64 as RV64
import GHC.CmmToAsm.Reg.Target
import GHC.CmmToAsm.Reg.Liveness
import GHC.CmmToAsm.Reg.Utils
import GHC.CmmToAsm.Instr
import GHC.CmmToAsm.Config
import GHC.CmmToAsm.Format
import GHC.CmmToAsm.Types
import GHC.Platform.Reg
import GHC.Platform.Reg.Class (RegArch (..), registerArch)
import qualified GHC.Platform.Reg.Class.Separate as Separate
import qualified GHC.Platform.Reg.Class.Unified as Unified
import qualified GHC.Platform.Reg.Class.NoVectors as NoVectors
import GHC.Cmm.BlockId
import GHC.Cmm.Dataflow.Label
import GHC.Cmm
import GHC.Data.Graph.Directed
import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.DSM
import GHC.Types.Unique.Set
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Platform
import Data.Containers.ListUtils
import Data.Maybe
import Data.List (partition)
import Control.Monad
regAlloc
:: Instruction instr
=> NCGConfig
-> LiveCmmDecl statics instr
-> UniqDSM ( NatCmmDecl statics instr
, Maybe Int
, Maybe RegAllocStats
)
regAlloc :: forall instr statics.
Instruction instr =>
NCGConfig
-> LiveCmmDecl statics instr
-> UniqDSM
(NatCmmDecl statics instr, Maybe Int, Maybe RegAllocStats)
regAlloc NCGConfig
_ (CmmData Section
sec statics
d)
= (NatCmmDecl statics instr, Maybe Int, Maybe RegAllocStats)
-> UniqDSM
(NatCmmDecl statics instr, Maybe Int, Maybe RegAllocStats)
forall a. a -> UniqDSM a
forall (m :: * -> *) a. Monad m => a -> m a
return
( Section -> statics -> NatCmmDecl statics instr
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
sec statics
d
, Maybe Int
forall a. Maybe a
Nothing
, Maybe RegAllocStats
forall a. Maybe a
Nothing )
regAlloc NCGConfig
_ (CmmProc (LiveInfo LabelMap RawCmmStatics
info [BlockId]
_ BlockMap (UniqSet RegWithFormat)
_ BlockMap IntSet
_) CLabel
lbl [GlobalRegUse]
live [])
= (NatCmmDecl statics instr, Maybe Int, Maybe RegAllocStats)
-> UniqDSM
(NatCmmDecl statics instr, Maybe Int, Maybe RegAllocStats)
forall a. a -> UniqDSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( LabelMap RawCmmStatics
-> CLabel
-> [GlobalRegUse]
-> ListGraph instr
-> NatCmmDecl statics instr
forall d h g.
h -> CLabel -> [GlobalRegUse] -> g -> GenCmmDecl d h g
CmmProc LabelMap RawCmmStatics
info CLabel
lbl [GlobalRegUse]
live ([GenBasicBlock instr] -> ListGraph instr
forall i. [GenBasicBlock i] -> ListGraph i
ListGraph [])
, Maybe Int
forall a. Maybe a
Nothing
, Maybe RegAllocStats
forall a. Maybe a
Nothing )
regAlloc NCGConfig
config (CmmProc LiveInfo
static CLabel
lbl [GlobalRegUse]
live [SCC (LiveBasicBlock instr)]
sccs)
| LiveInfo LabelMap RawCmmStatics
info entry_ids :: [BlockId]
entry_ids@(BlockId
first_id:[BlockId]
_) BlockMap (UniqSet RegWithFormat)
block_live BlockMap IntSet
_ <- LiveInfo
static
= do
!(!final_blocks, !stats, !stack_use)
<- NCGConfig
-> [BlockId]
-> BlockMap (UniqSet RegWithFormat)
-> [SCC (LiveBasicBlock instr)]
-> UniqDSM ([GenBasicBlock instr], RegAllocStats, Int)
forall instr.
Instruction instr =>
NCGConfig
-> [BlockId]
-> BlockMap (UniqSet RegWithFormat)
-> [SCC (LiveBasicBlock instr)]
-> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
linearRegAlloc NCGConfig
config [BlockId]
entry_ids BlockMap (UniqSet RegWithFormat)
block_live [SCC (LiveBasicBlock instr)]
sccs
let !(!(!first':_), !rest')
= partition ((== first_id) . blockId) final_blocks
let max_spill_slots = NCGConfig -> Int
maxSpillSlots NCGConfig
config
extra_stack
| Int
stack_use Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
max_spill_slots
= Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$! Int
stack_use Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
max_spill_slots
| Bool
otherwise
= Maybe Int
forall a. Maybe a
Nothing
return ( CmmProc info lbl live (ListGraph (first' : rest'))
, extra_stack
, Just stats)
regAlloc NCGConfig
_ (CmmProc LiveInfo
_ CLabel
_ [GlobalRegUse]
_ [SCC (LiveBasicBlock instr)]
_)
= String
-> UniqDSM
(NatCmmDecl statics instr, Maybe Int, Maybe RegAllocStats)
forall a. HasCallStack => String -> a
panic String
"RegAllocLinear.regAlloc: no match"
linearRegAlloc
:: forall instr. (Instruction instr)
=> NCGConfig
-> [BlockId]
-> BlockMap (UniqSet RegWithFormat)
-> [SCC (LiveBasicBlock instr)]
-> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
linearRegAlloc :: forall instr.
Instruction instr =>
NCGConfig
-> [BlockId]
-> BlockMap (UniqSet RegWithFormat)
-> [SCC (LiveBasicBlock instr)]
-> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
linearRegAlloc NCGConfig
config [BlockId]
entry_ids BlockMap (UniqSet RegWithFormat)
block_live [SCC (LiveBasicBlock instr)]
sccs
= case Platform -> Arch
platformArch Platform
platform of
Arch
ArchX86 -> FreeRegs -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
forall regs.
(FR regs, Outputable regs) =>
regs -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
go (FreeRegs -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int))
-> FreeRegs -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
forall a b. (a -> b) -> a -> b
$ (Platform -> FreeRegs
forall freeRegs. FR freeRegs => Platform -> freeRegs
frInitFreeRegs Platform
platform :: X86.FreeRegs)
Arch
ArchX86_64 -> FreeRegs -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
forall regs.
(FR regs, Outputable regs) =>
regs -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
go (FreeRegs -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int))
-> FreeRegs -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
forall a b. (a -> b) -> a -> b
$ (Platform -> FreeRegs
forall freeRegs. FR freeRegs => Platform -> freeRegs
frInitFreeRegs Platform
platform :: X86_64.FreeRegs)
Arch
ArchS390X -> String -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
forall a. HasCallStack => String -> a
panic String
"linearRegAlloc ArchS390X"
Arch
ArchPPC -> FreeRegs -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
forall regs.
(FR regs, Outputable regs) =>
regs -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
go (FreeRegs -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int))
-> FreeRegs -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
forall a b. (a -> b) -> a -> b
$ (Platform -> FreeRegs
forall freeRegs. FR freeRegs => Platform -> freeRegs
frInitFreeRegs Platform
platform :: PPC.FreeRegs)
ArchARM ArmISA
_ [ArmISAExt]
_ ArmABI
_ -> String -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
forall a. HasCallStack => String -> a
panic String
"linearRegAlloc ArchARM"
Arch
ArchAArch64 -> FreeRegs -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
forall regs.
(FR regs, Outputable regs) =>
regs -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
go (FreeRegs -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int))
-> FreeRegs -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
forall a b. (a -> b) -> a -> b
$ (Platform -> FreeRegs
forall freeRegs. FR freeRegs => Platform -> freeRegs
frInitFreeRegs Platform
platform :: AArch64.FreeRegs)
ArchPPC_64 PPC_64ABI
_ -> FreeRegs -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
forall regs.
(FR regs, Outputable regs) =>
regs -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
go (FreeRegs -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int))
-> FreeRegs -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
forall a b. (a -> b) -> a -> b
$ (Platform -> FreeRegs
forall freeRegs. FR freeRegs => Platform -> freeRegs
frInitFreeRegs Platform
platform :: PPC.FreeRegs)
Arch
ArchAlpha -> String -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
forall a. HasCallStack => String -> a
panic String
"linearRegAlloc ArchAlpha"
Arch
ArchMipseb -> String -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
forall a. HasCallStack => String -> a
panic String
"linearRegAlloc ArchMipseb"
Arch
ArchMipsel -> String -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
forall a. HasCallStack => String -> a
panic String
"linearRegAlloc ArchMipsel"
Arch
ArchRISCV64 -> FreeRegs -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
forall regs.
(FR regs, Outputable regs) =>
regs -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
go (Platform -> FreeRegs
forall freeRegs. FR freeRegs => Platform -> freeRegs
frInitFreeRegs Platform
platform :: RV64.FreeRegs)
Arch
ArchLoongArch64-> String -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
forall a. HasCallStack => String -> a
panic String
"linearRegAlloc ArchLoongArch64"
Arch
ArchJavaScript -> String -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
forall a. HasCallStack => String -> a
panic String
"linearRegAlloc ArchJavaScript"
Arch
ArchWasm32 -> String -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
forall a. HasCallStack => String -> a
panic String
"linearRegAlloc ArchWasm32"
Arch
ArchUnknown -> String -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
forall a. HasCallStack => String -> a
panic String
"linearRegAlloc ArchUnknown"
where
go :: (FR regs, Outputable regs)
=> regs -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
go :: forall regs.
(FR regs, Outputable regs) =>
regs -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
go regs
f = NCGConfig
-> regs
-> [BlockId]
-> BlockMap (UniqSet RegWithFormat)
-> [SCC (LiveBasicBlock instr)]
-> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
forall freeRegs instr.
OutputableRegConstraint freeRegs instr =>
NCGConfig
-> freeRegs
-> [BlockId]
-> BlockMap (UniqSet RegWithFormat)
-> [SCC (LiveBasicBlock instr)]
-> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
linearRegAlloc' NCGConfig
config regs
f [BlockId]
entry_ids BlockMap (UniqSet RegWithFormat)
block_live [SCC (LiveBasicBlock instr)]
sccs
platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config
type OutputableRegConstraint freeRegs instr =
(FR freeRegs, Outputable freeRegs, Instruction instr)
linearRegAlloc'
:: OutputableRegConstraint freeRegs instr
=> NCGConfig
-> freeRegs
-> [BlockId]
-> BlockMap (UniqSet RegWithFormat)
-> [SCC (LiveBasicBlock instr)]
-> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
linearRegAlloc' :: forall freeRegs instr.
OutputableRegConstraint freeRegs instr =>
NCGConfig
-> freeRegs
-> [BlockId]
-> BlockMap (UniqSet RegWithFormat)
-> [SCC (LiveBasicBlock instr)]
-> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
linearRegAlloc' NCGConfig
config freeRegs
initFreeRegs [BlockId]
entry_ids BlockMap (UniqSet RegWithFormat)
block_live [SCC (LiveBasicBlock instr)]
sccs
= (DUniqSupply
-> DUniqResult ([NatBasicBlock instr], RegAllocStats, Int))
-> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
forall a. (DUniqSupply -> DUniqResult a) -> UniqDSM a
UDSM ((DUniqSupply
-> DUniqResult ([NatBasicBlock instr], RegAllocStats, Int))
-> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int))
-> (DUniqSupply
-> DUniqResult ([NatBasicBlock instr], RegAllocStats, Int))
-> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)
forall a b. (a -> b) -> a -> b
$ \DUniqSupply
us -> do
let !(BlockAssignment freeRegs
_, !StackMap
stack, !RegAllocStats
stats, ![NatBasicBlock instr]
blocks, DUniqSupply
us') =
NCGConfig
-> BlockAssignment freeRegs
-> freeRegs
-> RegMap Loc
-> StackMap
-> DUniqSupply
-> RegM freeRegs [NatBasicBlock instr]
-> (BlockAssignment freeRegs, StackMap, RegAllocStats,
[NatBasicBlock instr], DUniqSupply)
forall freeRegs a.
NCGConfig
-> BlockAssignment freeRegs
-> freeRegs
-> RegMap Loc
-> StackMap
-> DUniqSupply
-> RegM freeRegs a
-> (BlockAssignment freeRegs, StackMap, RegAllocStats, a,
DUniqSupply)
runR NCGConfig
config BlockAssignment freeRegs
forall freeRegs. BlockAssignment freeRegs
emptyBlockAssignment freeRegs
initFreeRegs RegMap Loc
forall a. RegMap a
emptyRegMap StackMap
emptyStackMap DUniqSupply
us
(RegM freeRegs [NatBasicBlock instr]
-> (BlockAssignment freeRegs, StackMap, RegAllocStats,
[NatBasicBlock instr], DUniqSupply))
-> RegM freeRegs [NatBasicBlock instr]
-> (BlockAssignment freeRegs, StackMap, RegAllocStats,
[NatBasicBlock instr], DUniqSupply)
forall a b. (a -> b) -> a -> b
$ [BlockId]
-> BlockMap (UniqSet RegWithFormat)
-> [NatBasicBlock instr]
-> [SCC (LiveBasicBlock instr)]
-> RegM freeRegs [NatBasicBlock instr]
forall freeRegs instr.
OutputableRegConstraint freeRegs instr =>
[BlockId]
-> BlockMap (UniqSet RegWithFormat)
-> [NatBasicBlock instr]
-> [SCC (LiveBasicBlock instr)]
-> RegM freeRegs [NatBasicBlock instr]
linearRA_SCCs [BlockId]
entry_ids BlockMap (UniqSet RegWithFormat)
block_live [] [SCC (LiveBasicBlock instr)]
sccs
in ([NatBasicBlock instr], RegAllocStats, Int)
-> DUniqSupply
-> DUniqResult ([NatBasicBlock instr], RegAllocStats, Int)
forall a. a -> DUniqSupply -> (# a, DUniqSupply #)
DUniqResult ([NatBasicBlock instr]
blocks, RegAllocStats
stats, StackMap -> Int
getStackUse StackMap
stack) DUniqSupply
us'
linearRA_SCCs :: OutputableRegConstraint freeRegs instr
=> [BlockId]
-> BlockMap (UniqSet RegWithFormat)
-> [NatBasicBlock instr]
-> [SCC (LiveBasicBlock instr)]
-> RegM freeRegs [NatBasicBlock instr]
linearRA_SCCs :: forall freeRegs instr.
OutputableRegConstraint freeRegs instr =>
[BlockId]
-> BlockMap (UniqSet RegWithFormat)
-> [NatBasicBlock instr]
-> [SCC (LiveBasicBlock instr)]
-> RegM freeRegs [NatBasicBlock instr]
linearRA_SCCs [BlockId]
_ BlockMap (UniqSet RegWithFormat)
_ [NatBasicBlock instr]
blocksAcc []
= [NatBasicBlock instr] -> RegM freeRegs [NatBasicBlock instr]
forall a. a -> RegM freeRegs a
forall (m :: * -> *) a. Monad m => a -> m a
return ([NatBasicBlock instr] -> RegM freeRegs [NatBasicBlock instr])
-> [NatBasicBlock instr] -> RegM freeRegs [NatBasicBlock instr]
forall a b. (a -> b) -> a -> b
$ [NatBasicBlock instr] -> [NatBasicBlock instr]
forall a. [a] -> [a]
reverse [NatBasicBlock instr]
blocksAcc
linearRA_SCCs [BlockId]
entry_ids BlockMap (UniqSet RegWithFormat)
block_live [NatBasicBlock instr]
blocksAcc (AcyclicSCC LiveBasicBlock instr
block : [SCC (LiveBasicBlock instr)]
sccs)
= do blocks' <- BlockMap (UniqSet RegWithFormat)
-> LiveBasicBlock instr -> RegM freeRegs [NatBasicBlock instr]
forall freeRegs instr.
OutputableRegConstraint freeRegs instr =>
BlockMap (UniqSet RegWithFormat)
-> LiveBasicBlock instr -> RegM freeRegs [NatBasicBlock instr]
processBlock BlockMap (UniqSet RegWithFormat)
block_live LiveBasicBlock instr
block
linearRA_SCCs entry_ids block_live
((reverse blocks') ++ blocksAcc)
sccs
linearRA_SCCs [BlockId]
entry_ids BlockMap (UniqSet RegWithFormat)
block_live [NatBasicBlock instr]
blocksAcc (CyclicSCC [LiveBasicBlock instr]
blocks : [SCC (LiveBasicBlock instr)]
sccs)
= do
blockss' <- [BlockId]
-> BlockMap (UniqSet RegWithFormat)
-> [LiveBasicBlock instr]
-> RegM freeRegs [[NatBasicBlock instr]]
forall freeRegs instr.
OutputableRegConstraint freeRegs instr =>
[BlockId]
-> BlockMap (UniqSet RegWithFormat)
-> [GenBasicBlock (LiveInstr instr)]
-> RegM freeRegs [[NatBasicBlock instr]]
process [BlockId]
entry_ids BlockMap (UniqSet RegWithFormat)
block_live [LiveBasicBlock instr]
blocks
linearRA_SCCs entry_ids block_live
(reverse (concat blockss') ++ blocksAcc)
sccs
process :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr)
=> [BlockId]
-> BlockMap (UniqSet RegWithFormat)
-> [GenBasicBlock (LiveInstr instr)]
-> RegM freeRegs [[NatBasicBlock instr]]
process :: forall freeRegs instr.
OutputableRegConstraint freeRegs instr =>
[BlockId]
-> BlockMap (UniqSet RegWithFormat)
-> [GenBasicBlock (LiveInstr instr)]
-> RegM freeRegs [[NatBasicBlock instr]]
process [BlockId]
entry_ids BlockMap (UniqSet RegWithFormat)
block_live =
\[GenBasicBlock (LiveInstr instr)]
blocks -> [GenBasicBlock (LiveInstr instr)]
-> [GenBasicBlock (LiveInstr instr)]
-> [[NatBasicBlock instr]]
-> Bool
-> RegM freeRegs [[NatBasicBlock instr]]
go [GenBasicBlock (LiveInstr instr)]
blocks [] ([NatBasicBlock instr] -> [[NatBasicBlock instr]]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []) Bool
False
where
go :: [GenBasicBlock (LiveInstr instr)]
-> [GenBasicBlock (LiveInstr instr)]
-> [[NatBasicBlock instr]]
-> Bool
-> RegM freeRegs [[NatBasicBlock instr]]
go :: [GenBasicBlock (LiveInstr instr)]
-> [GenBasicBlock (LiveInstr instr)]
-> [[NatBasicBlock instr]]
-> Bool
-> RegM freeRegs [[NatBasicBlock instr]]
go [] [] [[NatBasicBlock instr]]
accum Bool
_madeProgress
= [[NatBasicBlock instr]] -> RegM freeRegs [[NatBasicBlock instr]]
forall a. a -> RegM freeRegs a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[NatBasicBlock instr]] -> RegM freeRegs [[NatBasicBlock instr]])
-> [[NatBasicBlock instr]] -> RegM freeRegs [[NatBasicBlock instr]]
forall a b. (a -> b) -> a -> b
$ [[NatBasicBlock instr]] -> [[NatBasicBlock instr]]
forall a. [a] -> [a]
reverse [[NatBasicBlock instr]]
accum
go [] [GenBasicBlock (LiveInstr instr)]
next_round [[NatBasicBlock instr]]
accum Bool
madeProgress
| Bool -> Bool
not Bool
madeProgress
= [[NatBasicBlock instr]] -> RegM freeRegs [[NatBasicBlock instr]]
forall a. a -> RegM freeRegs a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[NatBasicBlock instr]] -> RegM freeRegs [[NatBasicBlock instr]])
-> [[NatBasicBlock instr]] -> RegM freeRegs [[NatBasicBlock instr]]
forall a b. (a -> b) -> a -> b
$ [[NatBasicBlock instr]] -> [[NatBasicBlock instr]]
forall a. [a] -> [a]
reverse [[NatBasicBlock instr]]
accum
| Bool
otherwise
= [GenBasicBlock (LiveInstr instr)]
-> [GenBasicBlock (LiveInstr instr)]
-> [[NatBasicBlock instr]]
-> Bool
-> RegM freeRegs [[NatBasicBlock instr]]
go [GenBasicBlock (LiveInstr instr)]
next_round [] [[NatBasicBlock instr]]
accum Bool
False
go (b :: GenBasicBlock (LiveInstr instr)
b@(BasicBlock BlockId
id [LiveInstr instr]
_) : [GenBasicBlock (LiveInstr instr)]
blocks) [GenBasicBlock (LiveInstr instr)]
next_round [[NatBasicBlock instr]]
accum Bool
madeProgress
= do
block_assig <- RegM freeRegs (BlockAssignment freeRegs)
forall freeRegs. RegM freeRegs (BlockAssignment freeRegs)
getBlockAssigR
if isJust (lookupBlockAssignment id block_assig) || id `elem` entry_ids
then do b' <- processBlock block_live b
go blocks next_round (b' : accum) True
else do go blocks (b : next_round) accum madeProgress
processBlock
:: OutputableRegConstraint freeRegs instr
=> BlockMap (UniqSet RegWithFormat)
-> LiveBasicBlock instr
-> RegM freeRegs [NatBasicBlock instr]
processBlock :: forall freeRegs instr.
OutputableRegConstraint freeRegs instr =>
BlockMap (UniqSet RegWithFormat)
-> LiveBasicBlock instr -> RegM freeRegs [NatBasicBlock instr]
processBlock BlockMap (UniqSet RegWithFormat)
block_live (BasicBlock BlockId
id [LiveInstr instr]
instrs)
= do
BlockId -> BlockMap (UniqSet RegWithFormat) -> RegM freeRegs ()
forall freeRegs.
FR freeRegs =>
BlockId -> BlockMap (UniqSet RegWithFormat) -> RegM freeRegs ()
initBlock BlockId
id BlockMap (UniqSet RegWithFormat)
block_live
(instrs', fixups)
<- BlockMap (UniqSet RegWithFormat)
-> BlockId
-> [LiveInstr instr]
-> RegM freeRegs ([instr], [NatBasicBlock instr])
forall freeRegs instr.
OutputableRegConstraint freeRegs instr =>
BlockMap (UniqSet RegWithFormat)
-> BlockId
-> [LiveInstr instr]
-> RegM freeRegs ([instr], [NatBasicBlock instr])
linearRA BlockMap (UniqSet RegWithFormat)
block_live BlockId
id [LiveInstr instr]
instrs
return $ BasicBlock id instrs' : fixups
initBlock :: FR freeRegs
=> BlockId -> BlockMap (UniqSet RegWithFormat) -> RegM freeRegs ()
initBlock :: forall freeRegs.
FR freeRegs =>
BlockId -> BlockMap (UniqSet RegWithFormat) -> RegM freeRegs ()
initBlock BlockId
id BlockMap (UniqSet RegWithFormat)
block_live
= do platform <- RegM freeRegs Platform
forall a. RegM a Platform
getPlatform
block_assig <- getBlockAssigR
case lookupBlockAssignment id block_assig of
Maybe (freeRegs, RegMap Loc)
Nothing
-> do
case BlockId
-> BlockMap (UniqSet RegWithFormat)
-> Maybe (UniqSet RegWithFormat)
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
id BlockMap (UniqSet RegWithFormat)
block_live of
Maybe (UniqSet RegWithFormat)
Nothing ->
freeRegs -> RegM freeRegs ()
forall freeRegs. freeRegs -> RegM freeRegs ()
setFreeRegsR (Platform -> freeRegs
forall freeRegs. FR freeRegs => Platform -> freeRegs
frInitFreeRegs Platform
platform)
Just UniqSet RegWithFormat
live ->
freeRegs -> RegM freeRegs ()
forall freeRegs. freeRegs -> RegM freeRegs ()
setFreeRegsR (freeRegs -> RegM freeRegs ()) -> freeRegs -> RegM freeRegs ()
forall a b. (a -> b) -> a -> b
$ (freeRegs -> RealReg -> freeRegs)
-> freeRegs -> [RealReg] -> freeRegs
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((RealReg -> freeRegs -> freeRegs)
-> freeRegs -> RealReg -> freeRegs
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((RealReg -> freeRegs -> freeRegs)
-> freeRegs -> RealReg -> freeRegs)
-> (RealReg -> freeRegs -> freeRegs)
-> freeRegs
-> RealReg
-> freeRegs
forall a b. (a -> b) -> a -> b
$ Platform -> RealReg -> freeRegs -> freeRegs
forall freeRegs.
FR freeRegs =>
Platform -> RealReg -> freeRegs -> freeRegs
frAllocateReg Platform
platform) (Platform -> freeRegs
forall freeRegs. FR freeRegs => Platform -> freeRegs
frInitFreeRegs Platform
platform)
(UniqSet RealReg -> [RealReg]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet (UniqSet RealReg -> [RealReg]) -> UniqSet RealReg -> [RealReg]
forall a b. (a -> b) -> a -> b
$ UniqSet RegWithFormat -> UniqSet RealReg
takeRealRegs UniqSet RegWithFormat
live)
RegMap Loc -> RegM freeRegs ()
forall freeRegs. RegMap Loc -> RegM freeRegs ()
setAssigR RegMap Loc
forall a. RegMap a
emptyRegMap
Just (freeRegs
freeregs, RegMap Loc
assig)
-> do freeRegs -> RegM freeRegs ()
forall freeRegs. freeRegs -> RegM freeRegs ()
setFreeRegsR freeRegs
freeregs
RegMap Loc -> RegM freeRegs ()
forall freeRegs. RegMap Loc -> RegM freeRegs ()
setAssigR RegMap Loc
assig
linearRA
:: forall freeRegs instr. (OutputableRegConstraint freeRegs instr)
=> BlockMap (UniqSet RegWithFormat)
-> BlockId
-> [LiveInstr instr]
-> RegM freeRegs
( [instr]
, [NatBasicBlock instr])
linearRA :: forall freeRegs instr.
OutputableRegConstraint freeRegs instr =>
BlockMap (UniqSet RegWithFormat)
-> BlockId
-> [LiveInstr instr]
-> RegM freeRegs ([instr], [NatBasicBlock instr])
linearRA BlockMap (UniqSet RegWithFormat)
block_live BlockId
block_id = [instr]
-> [NatBasicBlock instr]
-> [LiveInstr instr]
-> RegM freeRegs ([instr], [NatBasicBlock instr])
go [] []
where
go :: [instr]
-> [NatBasicBlock instr]
-> [LiveInstr instr]
-> RegM freeRegs
( [instr]
, [NatBasicBlock instr] )
go :: [instr]
-> [NatBasicBlock instr]
-> [LiveInstr instr]
-> RegM freeRegs ([instr], [NatBasicBlock instr])
go ![instr]
accInstr ![NatBasicBlock instr]
accFixups [] = do
([instr], [NatBasicBlock instr])
-> RegM freeRegs ([instr], [NatBasicBlock instr])
forall a. a -> RegM freeRegs a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [instr] -> [instr]
forall a. [a] -> [a]
reverse [instr]
accInstr
, [NatBasicBlock instr]
accFixups )
go [instr]
accInstr [NatBasicBlock instr]
accFixups (LiveInstr instr
instr:[LiveInstr instr]
instrs) = do
(accInstr', new_fixups) <- BlockMap (UniqSet RegWithFormat)
-> [instr]
-> BlockId
-> LiveInstr instr
-> RegM freeRegs ([instr], [NatBasicBlock instr])
forall freeRegs instr.
OutputableRegConstraint freeRegs instr =>
BlockMap (UniqSet RegWithFormat)
-> [instr]
-> BlockId
-> LiveInstr instr
-> RegM freeRegs ([instr], [NatBasicBlock instr])
raInsn BlockMap (UniqSet RegWithFormat)
block_live [instr]
accInstr BlockId
block_id LiveInstr instr
instr
go accInstr' (new_fixups ++ accFixups) instrs
raInsn
:: OutputableRegConstraint freeRegs instr
=> BlockMap (UniqSet RegWithFormat)
-> [instr]
-> BlockId
-> LiveInstr instr
-> RegM freeRegs
( [instr]
, [NatBasicBlock instr])
raInsn :: forall freeRegs instr.
OutputableRegConstraint freeRegs instr =>
BlockMap (UniqSet RegWithFormat)
-> [instr]
-> BlockId
-> LiveInstr instr
-> RegM freeRegs ([instr], [NatBasicBlock instr])
raInsn BlockMap (UniqSet RegWithFormat)
_ [instr]
new_instrs BlockId
_ (LiveInstr InstrSR instr
ii Maybe Liveness
Nothing)
| Just Int
n <- InstrSR instr -> Maybe Int
forall instr. Instruction instr => instr -> Maybe Int
takeDeltaInstr InstrSR instr
ii
= do Int -> RegM freeRegs ()
forall freeRegs. Int -> RegM freeRegs ()
setDeltaR Int
n
([instr], [NatBasicBlock instr])
-> RegM freeRegs ([instr], [NatBasicBlock instr])
forall a. a -> RegM freeRegs a
forall (m :: * -> *) a. Monad m => a -> m a
return ([instr]
new_instrs, [])
raInsn BlockMap (UniqSet RegWithFormat)
_ [instr]
new_instrs BlockId
_ (LiveInstr ii :: InstrSR instr
ii@(Instr instr
i) Maybe Liveness
Nothing)
| InstrSR instr -> Bool
forall instr. Instruction instr => instr -> Bool
isMetaInstr InstrSR instr
ii
= ([instr], [NatBasicBlock instr])
-> RegM freeRegs ([instr], [NatBasicBlock instr])
forall a. a -> RegM freeRegs a
forall (m :: * -> *) a. Monad m => a -> m a
return (instr
i instr -> [instr] -> [instr]
forall a. a -> [a] -> [a]
: [instr]
new_instrs, [])
raInsn BlockMap (UniqSet RegWithFormat)
block_live [instr]
new_instrs BlockId
id (LiveInstr (Instr instr
instr) (Just Liveness
live))
= do
platform <- RegM freeRegs Platform
forall a. RegM a Platform
getPlatform
assig <- getAssigR :: RegM freeRegs (UniqFM Reg Loc)
case takeRegRegMoveInstr platform instr of
Just (Reg
src,Reg
dst) | Just (RegWithFormat Reg
_ Format
fmt) <- UniqSet RegWithFormat -> Unique -> Maybe RegWithFormat
forall a. UniqSet a -> Unique -> Maybe a
lookupUniqSet_Directly (Liveness -> UniqSet RegWithFormat
liveDieRead Liveness
live) (Reg -> Unique
forall a. Uniquable a => a -> Unique
getUnique Reg
src),
Reg -> Bool
isVirtualReg Reg
dst,
Bool -> Bool
not (Reg
dst Reg -> RegMap Loc -> Bool
forall key elt. Uniquable key => key -> UniqFM key elt -> Bool
`elemUFM` RegMap Loc
assig),
Reg -> Bool
isRealReg Reg
src Bool -> Bool -> Bool
|| Reg -> RegMap Loc -> Bool
isInReg Reg
src RegMap Loc
assig -> do
case Reg
src of
RegReal RealReg
rr -> RegMap Loc -> RegM freeRegs ()
forall freeRegs. RegMap Loc -> RegM freeRegs ()
setAssigR (RegMap Loc -> Reg -> Loc -> RegMap Loc
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM RegMap Loc
assig Reg
dst (RealRegUsage -> Loc
InReg (RealRegUsage -> Loc) -> RealRegUsage -> Loc
forall a b. (a -> b) -> a -> b
$ RealReg -> Format -> RealRegUsage
RealRegUsage RealReg
rr Format
fmt))
Reg
_virt -> case RegMap Loc -> Reg -> Maybe Loc
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM RegMap Loc
assig Reg
src of
Maybe Loc
Nothing -> String -> RegM freeRegs ()
forall a. HasCallStack => String -> a
panic String
"raInsn"
Just Loc
loc ->
RegMap Loc -> RegM freeRegs ()
forall freeRegs. RegMap Loc -> RegM freeRegs ()
setAssigR (RegMap Loc -> Reg -> Loc -> RegMap Loc
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM (RegMap Loc -> Reg -> RegMap Loc
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> UniqFM key elt
delFromUFM RegMap Loc
assig Reg
src) Reg
dst Loc
loc)
([instr], [NatBasicBlock instr])
-> RegM freeRegs ([instr], [NatBasicBlock instr])
forall a. a -> RegM freeRegs a
forall (m :: * -> *) a. Monad m => a -> m a
return ([instr]
new_instrs, [])
Maybe (Reg, Reg)
_ -> BlockMap (UniqSet RegWithFormat)
-> [instr]
-> BlockId
-> instr
-> [Reg]
-> [Reg]
-> RegM freeRegs ([instr], [NatBasicBlock instr])
forall freeRegs instr.
OutputableRegConstraint freeRegs instr =>
BlockMap (UniqSet RegWithFormat)
-> [instr]
-> BlockId
-> instr
-> [Reg]
-> [Reg]
-> RegM freeRegs ([instr], [NatBasicBlock instr])
genRaInsn BlockMap (UniqSet RegWithFormat)
block_live [instr]
new_instrs BlockId
id instr
instr
((RegWithFormat -> Reg) -> [RegWithFormat] -> [Reg]
forall a b. (a -> b) -> [a] -> [b]
map RegWithFormat -> Reg
regWithFormat_reg ([RegWithFormat] -> [Reg]) -> [RegWithFormat] -> [Reg]
forall a b. (a -> b) -> a -> b
$ UniqSet RegWithFormat -> [RegWithFormat]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet (UniqSet RegWithFormat -> [RegWithFormat])
-> UniqSet RegWithFormat -> [RegWithFormat]
forall a b. (a -> b) -> a -> b
$ Liveness -> UniqSet RegWithFormat
liveDieRead Liveness
live)
((RegWithFormat -> Reg) -> [RegWithFormat] -> [Reg]
forall a b. (a -> b) -> [a] -> [b]
map RegWithFormat -> Reg
regWithFormat_reg ([RegWithFormat] -> [Reg]) -> [RegWithFormat] -> [Reg]
forall a b. (a -> b) -> a -> b
$ UniqSet RegWithFormat -> [RegWithFormat]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet (UniqSet RegWithFormat -> [RegWithFormat])
-> UniqSet RegWithFormat -> [RegWithFormat]
forall a b. (a -> b) -> a -> b
$ Liveness -> UniqSet RegWithFormat
liveDieWrite Liveness
live)
raInsn BlockMap (UniqSet RegWithFormat)
_ [instr]
_ BlockId
_ LiveInstr instr
instr
= do
platform <- RegM freeRegs Platform
forall a. RegM a Platform
getPlatform
let instr' = (instr -> SDoc) -> LiveInstr instr -> LiveInstr SDoc
forall a b. (a -> b) -> LiveInstr a -> LiveInstr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Platform -> instr -> SDoc
forall instr. Instruction instr => Platform -> instr -> SDoc
pprInstr Platform
platform) LiveInstr instr
instr
pprPanic "raInsn" (text "no match for:" <> ppr instr')
isInReg :: Reg -> RegMap Loc -> Bool
isInReg :: Reg -> RegMap Loc -> Bool
isInReg Reg
src RegMap Loc
assig | Just (InReg RealRegUsage
_) <- RegMap Loc -> Reg -> Maybe Loc
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM RegMap Loc
assig Reg
src = Bool
True
| Bool
otherwise = Bool
False
genRaInsn :: forall freeRegs instr.
(OutputableRegConstraint freeRegs instr)
=> BlockMap (UniqSet RegWithFormat)
-> [instr]
-> BlockId
-> instr
-> [Reg]
-> [Reg]
-> RegM freeRegs ([instr], [NatBasicBlock instr])
genRaInsn :: forall freeRegs instr.
OutputableRegConstraint freeRegs instr =>
BlockMap (UniqSet RegWithFormat)
-> [instr]
-> BlockId
-> instr
-> [Reg]
-> [Reg]
-> RegM freeRegs ([instr], [NatBasicBlock instr])
genRaInsn BlockMap (UniqSet RegWithFormat)
block_live [instr]
new_instrs BlockId
block_id instr
instr [Reg]
r_dying [Reg]
w_dying = do
platform <- RegM freeRegs Platform
forall a. RegM a Platform
getPlatform
case regUsageOfInstr platform instr of { RU [RegWithFormat]
read [RegWithFormat]
written ->
do
let real_written :: [RealReg]
real_written = [ RealReg
rr | RegWithFormat {regWithFormat_reg :: RegWithFormat -> Reg
regWithFormat_reg = RegReal RealReg
rr} <- [RegWithFormat]
written ]
let virt_written :: [VirtualRegWithFormat]
virt_written = [ VirtualReg -> Format -> VirtualRegWithFormat
VirtualRegWithFormat VirtualReg
vr Format
fmt | RegWithFormat (RegVirtual VirtualReg
vr) Format
fmt <- [RegWithFormat]
written ]
let virt_read :: [VirtualRegWithFormat]
virt_read :: [VirtualRegWithFormat]
virt_read = (VirtualRegWithFormat -> VirtualReg)
-> [VirtualRegWithFormat] -> [VirtualRegWithFormat]
forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn VirtualRegWithFormat -> VirtualReg
virtualRegWithFormat_reg [ VirtualReg -> Format -> VirtualRegWithFormat
VirtualRegWithFormat VirtualReg
vr Format
fmt | RegWithFormat (RegVirtual VirtualReg
vr) Format
fmt <- [RegWithFormat]
read ]
(r_spills, r_allocd) <-
Bool
-> [VirtualRegWithFormat]
-> [instr]
-> [RealReg]
-> [VirtualRegWithFormat]
-> RegM freeRegs ([instr], [RealReg])
forall freeRegs instr.
(FR freeRegs, Instruction instr) =>
Bool
-> [VirtualRegWithFormat]
-> [instr]
-> [RealReg]
-> [VirtualRegWithFormat]
-> RegM freeRegs ([instr], [RealReg])
allocateRegsAndSpill Bool
True [VirtualRegWithFormat]
virt_read [] [] [VirtualRegWithFormat]
virt_read
clobber_saves <- saveClobberedTemps real_written r_dying
(fixup_blocks, adjusted_instr)
<- joinToTargets block_live block_id instr
releaseRegs r_dying
clobberRegs real_written
(w_spills, w_allocd) <-
allocateRegsAndSpill False virt_written [] [] virt_written
releaseRegs w_dying
let
patch_map :: UniqFM Reg Reg
patch_map
= UniqFM VirtualReg Reg -> UniqFM Reg Reg
forall elt. UniqFM VirtualReg elt -> UniqFM Reg elt
toRegMap (UniqFM VirtualReg Reg -> UniqFM Reg Reg)
-> UniqFM VirtualReg Reg -> UniqFM Reg Reg
forall a b. (a -> b) -> a -> b
$
[(VirtualReg, Reg)] -> UniqFM VirtualReg Reg
forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM
[ (VirtualRegWithFormat -> VirtualReg
virtualRegWithFormat_reg VirtualRegWithFormat
vr, RealReg -> Reg
RegReal RealReg
rr)
| (VirtualRegWithFormat
vr, RealReg
rr) <- [VirtualRegWithFormat]
-> [RealReg] -> [(VirtualRegWithFormat, RealReg)]
forall a b. [a] -> [b] -> [(a, b)]
zip [VirtualRegWithFormat]
virt_read [RealReg]
r_allocd
[(VirtualRegWithFormat, RealReg)]
-> [(VirtualRegWithFormat, RealReg)]
-> [(VirtualRegWithFormat, RealReg)]
forall a. [a] -> [a] -> [a]
++ [VirtualRegWithFormat]
-> [RealReg] -> [(VirtualRegWithFormat, RealReg)]
forall a b. [a] -> [b] -> [(a, b)]
zip [VirtualRegWithFormat]
virt_written [RealReg]
w_allocd ]
patched_instr :: instr
patched_instr
= Platform -> instr -> (Reg -> Reg) -> instr
forall instr.
(Instruction instr, HasDebugCallStack) =>
Platform -> instr -> (Reg -> Reg) -> instr
patchRegsOfInstr Platform
platform instr
adjusted_instr Reg -> Reg
patchLookup
patchLookup :: Reg -> Reg
patchLookup Reg
x
= case UniqFM Reg Reg -> Reg -> Maybe Reg
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM Reg Reg
patch_map Reg
x of
Maybe Reg
Nothing -> Reg
x
Just Reg
y -> Reg
y
let squashed_instr = case Platform -> instr -> Maybe (Reg, Reg)
forall instr.
Instruction instr =>
Platform -> instr -> Maybe (Reg, Reg)
takeRegRegMoveInstr Platform
platform instr
patched_instr of
Just (Reg
src, Reg
dst)
| Reg
src Reg -> Reg -> Bool
forall a. Eq a => a -> a -> Bool
== Reg
dst -> []
Maybe (Reg, Reg)
_ -> [instr
patched_instr]
let code = [[instr]] -> [instr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
[instr]
squashed_instr
, [instr] -> [instr]
forall a. [a] -> [a]
reverse [instr]
w_spills
, [instr] -> [instr]
forall a. [a] -> [a]
reverse [instr]
r_spills
, [instr] -> [instr]
forall a. [a] -> [a]
reverse [instr]
clobber_saves
, [instr]
new_instrs
]
return (code, fixup_blocks)
}
releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs ()
releaseRegs :: forall freeRegs. FR freeRegs => [Reg] -> RegM freeRegs ()
releaseRegs [Reg]
regs = do
platform <- RegM freeRegs Platform
forall a. RegM a Platform
getPlatform
assig <- getAssigR
free <- getFreeRegsR
let loop RegMap Loc
assig !freeRegs
free [] = do RegMap Loc -> RegM freeRegs ()
forall freeRegs. RegMap Loc -> RegM freeRegs ()
setAssigR RegMap Loc
assig; freeRegs -> RegM freeRegs ()
forall freeRegs. freeRegs -> RegM freeRegs ()
setFreeRegsR freeRegs
free; () -> RegM freeRegs ()
forall a. a -> RegM freeRegs a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
loop RegMap Loc
assig !freeRegs
free (RegReal RealReg
rr : [Reg]
rs) = RegMap Loc -> freeRegs -> [Reg] -> RegM freeRegs ()
loop RegMap Loc
assig (Platform -> RealReg -> freeRegs -> freeRegs
forall freeRegs.
FR freeRegs =>
Platform -> RealReg -> freeRegs -> freeRegs
frReleaseReg Platform
platform RealReg
rr freeRegs
free) [Reg]
rs
loop RegMap Loc
assig !freeRegs
free (Reg
r:[Reg]
rs) =
case RegMap Loc -> Reg -> Maybe Loc
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM RegMap Loc
assig Reg
r of
Just (InBoth RealRegUsage
real Int
_) -> RegMap Loc -> freeRegs -> [Reg] -> RegM freeRegs ()
loop (RegMap Loc -> Reg -> RegMap Loc
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> UniqFM key elt
delFromUFM RegMap Loc
assig Reg
r)
(Platform -> RealReg -> freeRegs -> freeRegs
forall freeRegs.
FR freeRegs =>
Platform -> RealReg -> freeRegs -> freeRegs
frReleaseReg Platform
platform (RealRegUsage -> RealReg
realReg RealRegUsage
real) freeRegs
free) [Reg]
rs
Just (InReg RealRegUsage
real) -> RegMap Loc -> freeRegs -> [Reg] -> RegM freeRegs ()
loop (RegMap Loc -> Reg -> RegMap Loc
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> UniqFM key elt
delFromUFM RegMap Loc
assig Reg
r)
(Platform -> RealReg -> freeRegs -> freeRegs
forall freeRegs.
FR freeRegs =>
Platform -> RealReg -> freeRegs -> freeRegs
frReleaseReg Platform
platform (RealRegUsage -> RealReg
realReg RealRegUsage
real) freeRegs
free) [Reg]
rs
Maybe Loc
_ -> RegMap Loc -> freeRegs -> [Reg] -> RegM freeRegs ()
loop (RegMap Loc -> Reg -> RegMap Loc
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> UniqFM key elt
delFromUFM RegMap Loc
assig Reg
r) freeRegs
free [Reg]
rs
loop assig free regs
saveClobberedTemps
:: forall instr freeRegs.
(Instruction instr, FR freeRegs)
=> [RealReg]
-> [Reg]
-> RegM freeRegs [instr]
saveClobberedTemps :: forall instr freeRegs.
(Instruction instr, FR freeRegs) =>
[RealReg] -> [Reg] -> RegM freeRegs [instr]
saveClobberedTemps [] [Reg]
_
= [instr] -> RegM freeRegs [instr]
forall a. a -> RegM freeRegs a
forall (m :: * -> *) a. Monad m => a -> m a
return []
saveClobberedTemps [RealReg]
clobbered [Reg]
dying
= do
assig <- RegM freeRegs (RegMap Loc)
forall {freeRegs}. RegM freeRegs (RegMap Loc)
getAssigR :: RegM freeRegs (UniqFM Reg Loc)
(assig',instrs) <- nonDetStrictFoldUFM_DirectlyM maybe_spill (assig,[]) assig
setAssigR assig'
return $
instrs
where
maybe_spill :: Unique -> (RegMap Loc,[instr]) -> (Loc) -> RegM freeRegs (RegMap Loc,[instr])
maybe_spill :: Unique
-> (RegMap Loc, [instr])
-> Loc
-> RegM freeRegs (RegMap Loc, [instr])
maybe_spill !Unique
temp !(RegMap Loc
assig,[instr]
instrs) !Loc
loc =
case Loc
loc of
InReg RealRegUsage
reg
| (RealReg -> Bool) -> [RealReg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (RealReg -> RealReg -> Bool
realRegsAlias (RealReg -> RealReg -> Bool) -> RealReg -> RealReg -> Bool
forall a b. (a -> b) -> a -> b
$ RealRegUsage -> RealReg
realReg RealRegUsage
reg) [RealReg]
clobbered
, Unique
temp Unique -> [Unique] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (Reg -> Unique) -> [Reg] -> [Unique]
forall a b. (a -> b) -> [a] -> [b]
map Reg -> Unique
forall a. Uniquable a => a -> Unique
getUnique [Reg]
dying
-> Unique
-> (RegMap Loc, [instr])
-> RealRegUsage
-> RegM freeRegs (RegMap Loc, [instr])
clobber Unique
temp (RegMap Loc
assig,[instr]
instrs) RealRegUsage
reg
Loc
_ -> (RegMap Loc, [instr]) -> RegM freeRegs (RegMap Loc, [instr])
forall a. a -> RegM freeRegs a
forall (m :: * -> *) a. Monad m => a -> m a
return (RegMap Loc
assig,[instr]
instrs)
clobber :: Unique -> (RegMap Loc,[instr]) -> RealRegUsage -> RegM freeRegs (RegMap Loc,[instr])
clobber :: Unique
-> (RegMap Loc, [instr])
-> RealRegUsage
-> RegM freeRegs (RegMap Loc, [instr])
clobber Unique
temp (RegMap Loc
assig,[instr]
instrs) (RealRegUsage RealReg
reg Format
fmt)
= do config <- RegM freeRegs NCGConfig
forall a. RegM a NCGConfig
getConfig
platform <- getPlatform
freeRegs <- getFreeRegsR
let regclass = Platform -> RealReg -> RegClass
targetClassOfRealReg Platform
platform RealReg
reg
freeRegs_thisClass = Platform -> RegClass -> freeRegs -> [RealReg]
forall freeRegs.
FR freeRegs =>
Platform -> RegClass -> freeRegs -> [RealReg]
frGetFreeRegs Platform
platform RegClass
regclass freeRegs
freeRegs
case filter (`notElem` clobbered) freeRegs_thisClass of
(RealReg
my_reg : [RealReg]
_) -> do
freeRegs -> RegM freeRegs ()
forall freeRegs. freeRegs -> RegM freeRegs ()
setFreeRegsR (Platform -> RealReg -> freeRegs -> freeRegs
forall freeRegs.
FR freeRegs =>
Platform -> RealReg -> freeRegs -> freeRegs
frAllocateReg Platform
platform RealReg
my_reg freeRegs
freeRegs)
let new_assign :: RegMap Loc
new_assign = RegMap Loc -> Unique -> Loc -> RegMap Loc
forall {k} (key :: k) elt.
UniqFM key elt -> Unique -> elt -> UniqFM key elt
addToUFM_Directly RegMap Loc
assig Unique
temp (RealRegUsage -> Loc
InReg (RealReg -> Format -> RealRegUsage
RealRegUsage RealReg
my_reg Format
fmt))
let instr :: instr
instr = NCGConfig -> Format -> Reg -> Reg -> instr
forall instr.
(Instruction instr, HasDebugCallStack) =>
NCGConfig -> Format -> Reg -> Reg -> instr
mkRegRegMoveInstr NCGConfig
config Format
fmt
(RealReg -> Reg
RegReal RealReg
reg) (RealReg -> Reg
RegReal RealReg
my_reg)
(RegMap Loc, [instr]) -> RegM freeRegs (RegMap Loc, [instr])
forall a. a -> RegM freeRegs a
forall (m :: * -> *) a. Monad m => a -> m a
return (RegMap Loc
new_assign,(instr
instr instr -> [instr] -> [instr]
forall a. a -> [a] -> [a]
: [instr]
instrs))
[] -> do
(spill, slot) <- RegWithFormat -> Unique -> RegM freeRegs ([instr], Int)
forall instr freeRegs.
Instruction instr =>
RegWithFormat -> Unique -> RegM freeRegs ([instr], Int)
spillR (Reg -> Format -> RegWithFormat
RegWithFormat (RealReg -> Reg
RegReal RealReg
reg) Format
fmt) Unique
temp
recordSpill (SpillClobber temp)
let new_assign = RegMap Loc -> Unique -> Loc -> RegMap Loc
forall {k} (key :: k) elt.
UniqFM key elt -> Unique -> elt -> UniqFM key elt
addToUFM_Directly RegMap Loc
assig Unique
temp (RealRegUsage -> Int -> Loc
InBoth (RealReg -> Format -> RealRegUsage
RealRegUsage RealReg
reg Format
fmt) Int
slot)
return (new_assign, (spill ++ instrs))
clobberRegs :: FR freeRegs => [RealReg] -> RegM freeRegs ()
clobberRegs :: forall freeRegs. FR freeRegs => [RealReg] -> RegM freeRegs ()
clobberRegs []
= () -> RegM freeRegs ()
forall a. a -> RegM freeRegs a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
clobberRegs [RealReg]
clobbered
= do platform <- RegM freeRegs Platform
forall a. RegM a Platform
getPlatform
freeregs <- getFreeRegsR
let allRegClasses =
case Arch -> RegArch
registerArch (Platform -> Arch
platformArch Platform
platform) of
RegArch
Unified -> [RegClass]
Unified.allRegClasses
RegArch
Separate -> [RegClass]
Separate.allRegClasses
RegArch
NoVectors -> [RegClass]
NoVectors.allRegClasses
allFreeRegs = (RegClass -> [RealReg]) -> [RegClass] -> [RealReg]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\ RegClass
rc -> Platform -> RegClass -> freeRegs -> [RealReg]
forall freeRegs.
FR freeRegs =>
Platform -> RegClass -> freeRegs -> [RealReg]
frGetFreeRegs Platform
platform RegClass
rc freeRegs
freeregs) [RegClass]
allRegClasses
let extra_clobbered = [ RealReg
r | RealReg
r <- [RealReg]
clobbered, RealReg
r RealReg -> [RealReg] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [RealReg]
allFreeRegs ]
setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs extra_clobbered
assig <- getAssigR
setAssigR $! clobber assig (nonDetUFMToList assig)
where
clobber :: RegMap Loc -> [(Unique,Loc)] -> RegMap Loc
clobber :: RegMap Loc -> [(Unique, Loc)] -> RegMap Loc
clobber RegMap Loc
assig []
= RegMap Loc
assig
clobber RegMap Loc
assig ((Unique
temp, InBoth RealRegUsage
reg Int
slot) : [(Unique, Loc)]
rest)
| (RealReg -> Bool) -> [RealReg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (RealReg -> RealReg -> Bool
realRegsAlias (RealReg -> RealReg -> Bool) -> RealReg -> RealReg -> Bool
forall a b. (a -> b) -> a -> b
$ RealRegUsage -> RealReg
realReg RealRegUsage
reg) [RealReg]
clobbered
= RegMap Loc -> [(Unique, Loc)] -> RegMap Loc
clobber (RegMap Loc -> Unique -> Loc -> RegMap Loc
forall {k} (key :: k) elt.
UniqFM key elt -> Unique -> elt -> UniqFM key elt
addToUFM_Directly RegMap Loc
assig Unique
temp (Int -> Loc
InMem Int
slot)) [(Unique, Loc)]
rest
clobber RegMap Loc
assig ((Unique, Loc)
_:[(Unique, Loc)]
rest)
= RegMap Loc -> [(Unique, Loc)] -> RegMap Loc
clobber RegMap Loc
assig [(Unique, Loc)]
rest
data SpillLoc = ReadMem StackSlot
| WriteNew
| WriteMem
allocateRegsAndSpill
:: forall freeRegs instr. (FR freeRegs, Instruction instr)
=> Bool
-> [VirtualRegWithFormat]
-> [instr]
-> [RealReg]
-> [VirtualRegWithFormat]
-> RegM freeRegs ( [instr] , [RealReg])
allocateRegsAndSpill :: forall freeRegs instr.
(FR freeRegs, Instruction instr) =>
Bool
-> [VirtualRegWithFormat]
-> [instr]
-> [RealReg]
-> [VirtualRegWithFormat]
-> RegM freeRegs ([instr], [RealReg])
allocateRegsAndSpill Bool
_ [VirtualRegWithFormat]
_ [instr]
spills [RealReg]
alloc []
= ([instr], [RealReg]) -> RegM freeRegs ([instr], [RealReg])
forall a. a -> RegM freeRegs a
forall (m :: * -> *) a. Monad m => a -> m a
return ([instr]
spills, [RealReg] -> [RealReg]
forall a. [a] -> [a]
reverse [RealReg]
alloc)
allocateRegsAndSpill Bool
reading [VirtualRegWithFormat]
keep [instr]
spills [RealReg]
alloc (r :: VirtualRegWithFormat
r@(VirtualRegWithFormat VirtualReg
vr Format
_fmt):[VirtualRegWithFormat]
rs)
= do assig <- RegMap Loc -> UniqFM VirtualReg Loc
forall elt. UniqFM Reg elt -> UniqFM VirtualReg elt
toVRegMap (RegMap Loc -> UniqFM VirtualReg Loc)
-> RegM freeRegs (RegMap Loc)
-> RegM freeRegs (UniqFM VirtualReg Loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RegM freeRegs (RegMap Loc)
forall {freeRegs}. RegM freeRegs (RegMap Loc)
getAssigR
let doSpill = Bool
-> [VirtualRegWithFormat]
-> [instr]
-> [RealReg]
-> VirtualRegWithFormat
-> [VirtualRegWithFormat]
-> UniqFM VirtualReg Loc
-> SpillLoc
-> RegM freeRegs ([instr], [RealReg])
forall freeRegs instr.
(FR freeRegs, Instruction instr) =>
Bool
-> [VirtualRegWithFormat]
-> [instr]
-> [RealReg]
-> VirtualRegWithFormat
-> [VirtualRegWithFormat]
-> UniqFM VirtualReg Loc
-> SpillLoc
-> RegM freeRegs ([instr], [RealReg])
allocRegsAndSpill_spill Bool
reading [VirtualRegWithFormat]
keep [instr]
spills [RealReg]
alloc VirtualRegWithFormat
r [VirtualRegWithFormat]
rs UniqFM VirtualReg Loc
assig
case lookupUFM assig vr of
Just (InReg RealRegUsage
my_reg) ->
Bool
-> [VirtualRegWithFormat]
-> [instr]
-> [RealReg]
-> [VirtualRegWithFormat]
-> RegM freeRegs ([instr], [RealReg])
forall freeRegs instr.
(FR freeRegs, Instruction instr) =>
Bool
-> [VirtualRegWithFormat]
-> [instr]
-> [RealReg]
-> [VirtualRegWithFormat]
-> RegM freeRegs ([instr], [RealReg])
allocateRegsAndSpill Bool
reading [VirtualRegWithFormat]
keep [instr]
spills (RealRegUsage -> RealReg
realReg RealRegUsage
my_regRealReg -> [RealReg] -> [RealReg]
forall a. a -> [a] -> [a]
:[RealReg]
alloc) [VirtualRegWithFormat]
rs
Just (InBoth RealRegUsage
my_reg Int
_)
-> do Bool -> RegM freeRegs () -> RegM freeRegs ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
reading) (RegMap Loc -> RegM freeRegs ()
forall freeRegs. RegMap Loc -> RegM freeRegs ()
setAssigR (RegMap Loc -> RegM freeRegs ()) -> RegMap Loc -> RegM freeRegs ()
forall a b. (a -> b) -> a -> b
$ UniqFM VirtualReg Loc -> RegMap Loc
forall elt. UniqFM VirtualReg elt -> UniqFM Reg elt
toRegMap (UniqFM VirtualReg Loc -> VirtualReg -> Loc -> UniqFM VirtualReg Loc
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM UniqFM VirtualReg Loc
assig VirtualReg
vr (RealRegUsage -> Loc
InReg RealRegUsage
my_reg)))
Bool
-> [VirtualRegWithFormat]
-> [instr]
-> [RealReg]
-> [VirtualRegWithFormat]
-> RegM freeRegs ([instr], [RealReg])
forall freeRegs instr.
(FR freeRegs, Instruction instr) =>
Bool
-> [VirtualRegWithFormat]
-> [instr]
-> [RealReg]
-> [VirtualRegWithFormat]
-> RegM freeRegs ([instr], [RealReg])
allocateRegsAndSpill Bool
reading [VirtualRegWithFormat]
keep [instr]
spills (RealRegUsage -> RealReg
realReg RealRegUsage
my_regRealReg -> [RealReg] -> [RealReg]
forall a. a -> [a] -> [a]
:[RealReg]
alloc) [VirtualRegWithFormat]
rs
Just (InMem Int
slot) | Bool
reading -> SpillLoc -> RegM freeRegs ([instr], [RealReg])
doSpill (Int -> SpillLoc
ReadMem Int
slot)
| Bool
otherwise -> SpillLoc -> RegM freeRegs ([instr], [RealReg])
doSpill SpillLoc
WriteMem
Maybe Loc
Nothing | Bool
reading ->
String -> SDoc -> RegM freeRegs ([instr], [RealReg])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"allocateRegsAndSpill: Cannot read from uninitialized register" (VirtualReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr VirtualReg
vr)
| Bool
otherwise -> SpillLoc -> RegM freeRegs ([instr], [RealReg])
doSpill SpillLoc
WriteNew
findPrefRealReg :: VirtualReg -> RegM freeRegs (Maybe RealReg)
findPrefRealReg :: forall freeRegs. VirtualReg -> RegM freeRegs (Maybe RealReg)
findPrefRealReg VirtualReg
vreg = do
bassig <- RegM freeRegs (BlockAssignment freeRegs)
forall freeRegs. RegM freeRegs (BlockAssignment freeRegs)
getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs)
return $ lookupFirstUsed vreg bassig
allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr)
=> Bool
-> [VirtualRegWithFormat]
-> [instr]
-> [RealReg]
-> VirtualRegWithFormat
-> [VirtualRegWithFormat]
-> UniqFM VirtualReg Loc
-> SpillLoc
-> RegM freeRegs ([instr], [RealReg])
allocRegsAndSpill_spill :: forall freeRegs instr.
(FR freeRegs, Instruction instr) =>
Bool
-> [VirtualRegWithFormat]
-> [instr]
-> [RealReg]
-> VirtualRegWithFormat
-> [VirtualRegWithFormat]
-> UniqFM VirtualReg Loc
-> SpillLoc
-> RegM freeRegs ([instr], [RealReg])
allocRegsAndSpill_spill Bool
reading [VirtualRegWithFormat]
keep [instr]
spills [RealReg]
alloc r :: VirtualRegWithFormat
r@(VirtualRegWithFormat VirtualReg
vr Format
fmt) [VirtualRegWithFormat]
rs UniqFM VirtualReg Loc
assig SpillLoc
spill_loc
= do platform <- RegM freeRegs Platform
forall a. RegM a Platform
getPlatform
freeRegs <- getFreeRegsR
let regclass = Arch -> VirtualReg -> RegClass
classOfVirtualReg (Platform -> Arch
platformArch Platform
platform) VirtualReg
vr
freeRegs_thisClass = Platform -> RegClass -> freeRegs -> [RealReg]
forall freeRegs.
FR freeRegs =>
Platform -> RegClass -> freeRegs -> [RealReg]
frGetFreeRegs Platform
platform RegClass
regclass freeRegs
freeRegs :: [RealReg]
pref_reg <- findPrefRealReg vr
case freeRegs_thisClass of
(RealReg
first_free : [RealReg]
_) ->
do let !final_reg :: RealReg
final_reg
| Just RealReg
reg <- Maybe RealReg
pref_reg
, RealReg
reg RealReg -> [RealReg] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [RealReg]
freeRegs_thisClass
= RealReg
reg
| Bool
otherwise
= RealReg
first_free
spills' <- VirtualRegWithFormat
-> SpillLoc -> RealReg -> [instr] -> RegM freeRegs [instr]
forall instr freeRegs.
Instruction instr =>
VirtualRegWithFormat
-> SpillLoc -> RealReg -> [instr] -> RegM freeRegs [instr]
loadTemp VirtualRegWithFormat
r SpillLoc
spill_loc RealReg
final_reg [instr]
spills
setAssigR $ toRegMap
$ (addToUFM assig vr $! newLocation spill_loc $ RealRegUsage final_reg fmt)
setFreeRegsR $ frAllocateReg platform final_reg freeRegs
allocateRegsAndSpill reading keep spills' (final_reg : alloc) rs
[] ->
do let inRegOrBoth :: Loc -> Bool
inRegOrBoth (InReg RealRegUsage
_) = Bool
True
inRegOrBoth (InBoth RealRegUsage
_ Int
_) = Bool
True
inRegOrBoth Loc
_ = Bool
False
let candidates' :: UniqFM VirtualReg Loc
candidates' :: UniqFM VirtualReg Loc
candidates' =
(UniqFM VirtualReg Loc -> [VirtualReg] -> UniqFM VirtualReg Loc)
-> [VirtualReg] -> UniqFM VirtualReg Loc -> UniqFM VirtualReg Loc
forall a b c. (a -> b -> c) -> b -> a -> c
flip UniqFM VirtualReg Loc -> [VirtualReg] -> UniqFM VirtualReg Loc
forall key elt.
Uniquable key =>
UniqFM key elt -> [key] -> UniqFM key elt
delListFromUFM ((VirtualRegWithFormat -> VirtualReg)
-> [VirtualRegWithFormat] -> [VirtualReg]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap VirtualRegWithFormat -> VirtualReg
virtualRegWithFormat_reg [VirtualRegWithFormat]
keep) (UniqFM VirtualReg Loc -> UniqFM VirtualReg Loc)
-> UniqFM VirtualReg Loc -> UniqFM VirtualReg Loc
forall a b. (a -> b) -> a -> b
$
(Loc -> Bool) -> UniqFM VirtualReg Loc -> UniqFM VirtualReg Loc
forall {k} elt (key :: k).
(elt -> Bool) -> UniqFM key elt -> UniqFM key elt
filterUFM Loc -> Bool
inRegOrBoth (UniqFM VirtualReg Loc -> UniqFM VirtualReg Loc)
-> UniqFM VirtualReg Loc -> UniqFM VirtualReg Loc
forall a b. (a -> b) -> a -> b
$
UniqFM VirtualReg Loc
assig
let candidates :: [(Unique, Loc)]
candidates = UniqFM VirtualReg Loc -> [(Unique, Loc)]
forall {k} (key :: k) elt. UniqFM key elt -> [(Unique, elt)]
nonDetUFMToList UniqFM VirtualReg Loc
candidates'
let compat :: RealReg -> Bool
compat RealReg
reg'
= Platform -> RealReg -> RegClass
targetClassOfRealReg Platform
platform RealReg
reg'
RegClass -> RegClass -> Bool
forall a. Eq a => a -> a -> Bool
== RegClass
regclass
candidates_inBoth :: [(Unique, RealRegUsage, StackSlot)]
candidates_inBoth :: [(Unique, RealRegUsage, Int)]
candidates_inBoth
= [ (Unique
temp, RealRegUsage
reg, Int
mem)
| (Unique
temp, InBoth RealRegUsage
reg Int
mem) <- [(Unique, Loc)]
candidates
, RealReg -> Bool
compat (RealRegUsage -> RealReg
realReg RealRegUsage
reg) ]
let candidates_inReg :: [(Unique, RealRegUsage)]
candidates_inReg
= [ (Unique
temp, RealRegUsage
reg)
| (Unique
temp, InReg RealRegUsage
reg) <- [(Unique, Loc)]
candidates
, RealReg -> Bool
compat (RealRegUsage -> RealReg
realReg RealRegUsage
reg) ]
let result :: RegM freeRegs ([instr], [RealReg])
result
| (Unique
temp, (RealRegUsage RealReg
my_reg Format
_old_fmt), Int
slot) : [(Unique, RealRegUsage, Int)]
_ <- [(Unique, RealRegUsage, Int)]
candidates_inBoth
= do spills' <- VirtualRegWithFormat
-> SpillLoc -> RealReg -> [instr] -> RegM freeRegs [instr]
forall instr freeRegs.
Instruction instr =>
VirtualRegWithFormat
-> SpillLoc -> RealReg -> [instr] -> RegM freeRegs [instr]
loadTemp VirtualRegWithFormat
r SpillLoc
spill_loc RealReg
my_reg [instr]
spills
let assig1 = UniqFM VirtualReg Loc -> Unique -> Loc -> UniqFM VirtualReg Loc
forall {k} (key :: k) elt.
UniqFM key elt -> Unique -> elt -> UniqFM key elt
addToUFM_Directly UniqFM VirtualReg Loc
assig Unique
temp (Int -> Loc
InMem Int
slot)
let assig2 = UniqFM VirtualReg Loc -> VirtualReg -> Loc -> UniqFM VirtualReg Loc
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM UniqFM VirtualReg Loc
assig1 VirtualReg
vr (Loc -> UniqFM VirtualReg Loc) -> Loc -> UniqFM VirtualReg Loc
forall a b. (a -> b) -> a -> b
$! SpillLoc -> RealRegUsage -> Loc
newLocation SpillLoc
spill_loc (RealReg -> Format -> RealRegUsage
RealRegUsage RealReg
my_reg Format
fmt)
setAssigR $ toRegMap assig2
allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
| (Unique
temp_to_push_out, RealRegUsage RealReg
my_reg Format
fmt) : [(Unique, RealRegUsage)]
_
<- [(Unique, RealRegUsage)]
candidates_inReg
= do
(spill_store, slot) <- RegWithFormat -> Unique -> RegM freeRegs ([instr], Int)
forall instr freeRegs.
Instruction instr =>
RegWithFormat -> Unique -> RegM freeRegs ([instr], Int)
spillR (Reg -> Format -> RegWithFormat
RegWithFormat (RealReg -> Reg
RegReal RealReg
my_reg) Format
fmt) Unique
temp_to_push_out
recordSpill (SpillAlloc temp_to_push_out)
let assig1 = UniqFM VirtualReg Loc -> Unique -> Loc -> UniqFM VirtualReg Loc
forall {k} (key :: k) elt.
UniqFM key elt -> Unique -> elt -> UniqFM key elt
addToUFM_Directly UniqFM VirtualReg Loc
assig Unique
temp_to_push_out (Int -> Loc
InMem Int
slot)
let assig2 = UniqFM VirtualReg Loc -> VirtualReg -> Loc -> UniqFM VirtualReg Loc
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM UniqFM VirtualReg Loc
assig1 VirtualReg
vr (Loc -> UniqFM VirtualReg Loc) -> Loc -> UniqFM VirtualReg Loc
forall a b. (a -> b) -> a -> b
$! SpillLoc -> RealRegUsage -> Loc
newLocation SpillLoc
spill_loc (RealReg -> Format -> RealRegUsage
RealRegUsage RealReg
my_reg Format
fmt)
setAssigR $ toRegMap assig2
spills' <- loadTemp r spill_loc my_reg spills
allocateRegsAndSpill reading keep
(spill_store ++ spills')
(my_reg:alloc) rs
| Bool
otherwise
= String -> SDoc -> RegM freeRegs ([instr], [RealReg])
forall a. HasCallStack => String -> SDoc -> a
pprPanic (String
"RegAllocLinear.allocRegsAndSpill: no spill candidates\n")
(SDoc -> RegM freeRegs ([instr], [RealReg]))
-> SDoc -> RegM freeRegs ([instr], [RealReg])
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"allocating vreg: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text (VirtualReg -> String
forall a. Show a => a -> String
show VirtualReg
vr)
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"assignment: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> UniqFM VirtualReg Loc -> SDoc
forall a. Outputable a => a -> SDoc
ppr UniqFM VirtualReg Loc
assig
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"format: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Format -> SDoc
forall a. Outputable a => a -> SDoc
ppr Format
fmt
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"freeRegs: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text (freeRegs -> String
showRegs freeRegs
freeRegs)
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"initFreeRegs: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text (freeRegs -> String
showRegs (Platform -> freeRegs
forall freeRegs. FR freeRegs => Platform -> freeRegs
frInitFreeRegs Platform
platform freeRegs -> freeRegs -> freeRegs
forall a. a -> a -> a
`asTypeOf` freeRegs
freeRegs))
]
where showRegs :: freeRegs -> String
showRegs = [(RealReg, RegClass)] -> String
forall a. Show a => a -> String
show ([(RealReg, RegClass)] -> String)
-> (freeRegs -> [(RealReg, RegClass)]) -> freeRegs -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealReg -> (RealReg, RegClass))
-> [RealReg] -> [(RealReg, RegClass)]
forall a b. (a -> b) -> [a] -> [b]
map (\RealReg
reg -> (RealReg
reg, Platform -> RealReg -> RegClass
targetClassOfRealReg Platform
platform RealReg
reg)) ([RealReg] -> [(RealReg, RegClass)])
-> (freeRegs -> [RealReg]) -> freeRegs -> [(RealReg, RegClass)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> freeRegs -> [RealReg]
forall freeRegs. FR freeRegs => Platform -> freeRegs -> [RealReg]
allFreeRegs Platform
platform
RegM freeRegs ([instr], [RealReg])
result
newLocation :: SpillLoc -> RealRegUsage -> Loc
newLocation :: SpillLoc -> RealRegUsage -> Loc
newLocation (ReadMem Int
slot) RealRegUsage
my_reg = RealRegUsage -> Int -> Loc
InBoth RealRegUsage
my_reg Int
slot
newLocation SpillLoc
_ RealRegUsage
my_reg = RealRegUsage -> Loc
InReg RealRegUsage
my_reg
loadTemp
:: (Instruction instr)
=> VirtualRegWithFormat
-> SpillLoc
-> RealReg
-> [instr]
-> RegM freeRegs [instr]
loadTemp :: forall instr freeRegs.
Instruction instr =>
VirtualRegWithFormat
-> SpillLoc -> RealReg -> [instr] -> RegM freeRegs [instr]
loadTemp (VirtualRegWithFormat VirtualReg
vreg Format
fmt) (ReadMem Int
slot) RealReg
hreg [instr]
spills
= do
insn <- RegWithFormat -> Int -> RegM freeRegs [instr]
forall instr freeRegs.
Instruction instr =>
RegWithFormat -> Int -> RegM freeRegs [instr]
loadR (Reg -> Format -> RegWithFormat
RegWithFormat (RealReg -> Reg
RegReal RealReg
hreg) Format
fmt) Int
slot
recordSpill (SpillLoad $ getUnique vreg)
return $ insn ++ spills
loadTemp VirtualRegWithFormat
_ SpillLoc
_ RealReg
_ [instr]
spills =
[instr] -> RegM freeRegs [instr]
forall a. a -> RegM freeRegs a
forall (m :: * -> *) a. Monad m => a -> m a
return [instr]
spills