Commit 665229e5 authored by sewardj's avatar sewardj

[project @ 2000-06-15 08:38:25 by sewardj]

Major thing: new register allocator.  Brief description follows.
Should correctly handle code with loops in, even though we don't
generate any such at the moment.  A lot of comments.  The previous
machinery for spilling is retained, as is the idea of a fast-and-easy
initial allocation attempt intended to deal with the majority of code
blocks (about 60% on x86) very cheaply.  Many comments explaining
in detail how it works :-)

The Stix inliner is now on by default.  Integer code seems to run
within about 1% of that -fvia-C.  x86 fp code is significantly worse,
up to about 30% slower, depending on the amount of fp activity.

Minor thing: lazyfication of the top-level NCG plumbing, so that the
NCG doesn't require any greater residency than compiling to C, just a
bit more time.  Created lazyThenUs and lazyMapUs for this purpose.

The new allocator is somewhat, although not catastophically, slower
than the old one.  Fixing of the long-standing NCG space leak more
than makes up for it; overall hsc run-time is down about 5%, due to
significantly reduced GC time.

--------------------------------------------------------------------

Instructions are numbered sequentially, starting at zero.

A flow edge (FE) is a pair of insn numbers (MkFE Int Int) denoting
a possible flow of control from the first insn to the second.

The input to the register allocator is a list of instructions, which
mention Regs.  A Reg can be a RealReg -- a real machine reg -- or a
VirtualReg, which carries a unique.  After allocation, all the
VirtualReg references will have been converted into RealRegs, and
possibly some spill code will have been inserted.

The heart of the register allocator works in four phases.

1.  (find_flow_edges) Calculate all the FEs for the code list.
    Return them not as a [FE], but implicitly, as a pair of
    Array Int [Int], being the successor and predecessor maps
    for instructions.

2.  (calc_liveness) Returns a FiniteMap FE RegSet.  For each
    FE, indicates the set of registers live on that FE.  Note
    that the set includes both RealRegs and VirtualRegs.  The
    former appear because the code could mention fixed register
    usages, and we need to take them into account from the start.

3.  (calc_live_range_sets) Invert the above mapping, giving a
    FiniteMap Reg FeSet, indicating, for each virtual and real
    reg mentioned in the code, which FEs it is live on.

4.  (calc_vreg_to_rreg_mapping) For virtual reg, try and find
    an allocatable real register for it.  Each real register has
    a "current commitment", indicating the set of FEs it is
    currently live on.  A virtual reg v can be assigned to
    real reg r iff v's live-fe-set does not intersect with r's
    current commitment fe-set.  If the assignment is made,
    v's live-fe-set is union'd into r's current commitment fe-set.
    There is also the minor restriction that v and r must be of
    the same register class (integer or floating).

    Once this mapping is established, we simply apply it to the
    input insns, and that's it.

    If no suitable real register can be found, the vreg is mapped
    to itself, and we deem allocation to have failed.  The partially
    allocated code is returned.  The higher echelons of the allocator
    (doGeneralAlloc and runRegAlloc) then cooperate to insert spill
    code and re-run allocation, until a successful allocation is found.
parent 1364aa0b
...@@ -15,6 +15,7 @@ module UniqSupply ( ...@@ -15,6 +15,7 @@ module UniqSupply (
getUniqueUs, getUniquesUs, getUniqueUs, getUniquesUs,
mapUs, mapAndUnzipUs, mapAndUnzip3Us, mapUs, mapAndUnzipUs, mapAndUnzip3Us,
thenMaybeUs, mapAccumLUs, thenMaybeUs, mapAccumLUs,
lazyThenUs, lazyMapUs,
mkSplitUniqSupply, mkSplitUniqSupply,
splitUniqSupply splitUniqSupply
...@@ -121,6 +122,7 @@ initUs_ :: UniqSupply -> UniqSM a -> a ...@@ -121,6 +122,7 @@ initUs_ :: UniqSupply -> UniqSM a -> a
initUs_ init_us m = case m init_us of { (r,us) -> r } initUs_ init_us m = case m init_us of { (r,us) -> r }
{-# INLINE thenUs #-} {-# INLINE thenUs #-}
{-# INLINE lazyThenUs #-}
{-# INLINE returnUs #-} {-# INLINE returnUs #-}
{-# INLINE splitUniqSupply #-} {-# INLINE splitUniqSupply #-}
\end{code} \end{code}
...@@ -135,10 +137,15 @@ thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b ...@@ -135,10 +137,15 @@ thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
thenUs expr cont us thenUs expr cont us
= case (expr us) of { (result, us') -> cont result us' } = case (expr us) of { (result, us') -> cont result us' }
lazyThenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
lazyThenUs expr cont us
= let (result, us') = expr us in cont result us'
thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b
thenUs_ expr cont us thenUs_ expr cont us
= case (expr us) of { (_, us') -> cont us' } = case (expr us) of { (_, us') -> cont us' }
returnUs :: a -> UniqSM a returnUs :: a -> UniqSM a
returnUs result us = (result, us) returnUs result us = (result, us)
...@@ -159,13 +166,19 @@ getUniquesUs n us = case splitUniqSupply us of ...@@ -159,13 +166,19 @@ getUniquesUs n us = case splitUniqSupply us of
\begin{code} \begin{code}
mapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b] mapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b]
mapUs f [] = returnUs [] mapUs f [] = returnUs []
mapUs f (x:xs) mapUs f (x:xs)
= f x `thenUs` \ r -> = f x `thenUs` \ r ->
mapUs f xs `thenUs` \ rs -> mapUs f xs `thenUs` \ rs ->
returnUs (r:rs) returnUs (r:rs)
lazyMapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b]
lazyMapUs f [] = returnUs []
lazyMapUs f (x:xs)
= f x `lazyThenUs` \ r ->
lazyMapUs f xs `lazyThenUs` \ rs ->
returnUs (r:rs)
mapAndUnzipUs :: (a -> UniqSM (b,c)) -> [a] -> UniqSM ([b],[c]) mapAndUnzipUs :: (a -> UniqSM (b,c)) -> [a] -> UniqSM ([b],[c])
mapAndUnzip3Us :: (a -> UniqSM (b,c,d)) -> [a] -> UniqSM ([b],[c],[d]) mapAndUnzip3Us :: (a -> UniqSM (b,c,d)) -> [a] -> UniqSM ([b],[c],[d])
......
...@@ -462,13 +462,15 @@ initTyVarUnique = mkUnique 't' 0 ...@@ -462,13 +462,15 @@ initTyVarUnique = mkUnique 't' 0
initTidyUniques :: (Unique, Unique) -- Global and local initTidyUniques :: (Unique, Unique) -- Global and local
initTidyUniques = (mkUnique 'g' 0, mkUnique 'x' 0) initTidyUniques = (mkUnique 'g' 0, mkUnique 'x' 0)
mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3, mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
mkBuiltinUnique :: Int -> Unique mkBuiltinUnique :: Int -> Unique
mkBuiltinUnique i = mkUnique 'B' i mkBuiltinUnique i = mkUnique 'B' i
mkPseudoUnique1 i = mkUnique 'C' i -- used for getUnique on Regs mkPseudoUnique1 i = mkUnique 'C' i -- used for getUnique on Regs
mkPseudoUnique2 i = mkUnique 'D' i -- ditto mkPseudoUnique2 i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs
mkPseudoUnique3 i = mkUnique 'E' i -- ditto mkPseudoUnique3 i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs
getBuiltinUniques :: Int -> [Unique] getBuiltinUniques :: Int -> [Unique]
getBuiltinUniques n = map (mkUnique 'B') [1 .. n] getBuiltinUniques n = map (mkUnique 'B') [1 .. n]
......
...@@ -32,7 +32,7 @@ import CmdLineOpts ...@@ -32,7 +32,7 @@ import CmdLineOpts
import Maybes ( maybeToBool ) import Maybes ( maybeToBool )
import ErrUtils ( doIfSet, dumpIfSet ) import ErrUtils ( doIfSet, dumpIfSet )
import Outputable import Outputable
import IO ( IOMode(..), hClose, openFile ) import IO ( IOMode(..), hClose, openFile, Handle )
\end{code} \end{code}
...@@ -69,6 +69,7 @@ codeOutput mod_name tycons classes core_binds stg_binds ...@@ -69,6 +69,7 @@ codeOutput mod_name tycons classes core_binds stg_binds
} } } }
doOutput :: (Handle -> IO ()) -> IO ()
doOutput io_action doOutput io_action
= (do handle <- openFile opt_OutputFile WriteMode = (do handle <- openFile opt_OutputFile WriteMode
io_action handle io_action handle
...@@ -101,9 +102,9 @@ outputC flat_absC ...@@ -101,9 +102,9 @@ outputC flat_absC
outputAsm flat_absC ncg_uniqs outputAsm flat_absC ncg_uniqs
#ifndef OMIT_NATIVE_CODEGEN #ifndef OMIT_NATIVE_CODEGEN
= do dumpIfSet opt_D_dump_stix "Final stix code" stix_final = do dumpIfSet opt_D_dump_stix "Final stix code" stix_final
dumpIfSet opt_D_dump_asm "Asm code" ncg_output_d dumpIfSet opt_D_dump_asm "Asm code" ncg_output_d
doOutput (\ f -> printForAsm f ncg_output_d) doOutput ( \f -> printForAsm f ncg_output_d)
where where
(stix_final, ncg_output_d) = nativeCodeGen flat_absC ncg_uniqs (stix_final, ncg_output_d) = nativeCodeGen flat_absC ncg_uniqs
......
...@@ -14,7 +14,7 @@ import Stix ...@@ -14,7 +14,7 @@ import Stix
import MachMisc import MachMisc
import AbsCUtils ( getAmodeRep, mixedTypeLocn, import AbsCUtils ( getAmodeRep, mixedTypeLocn,
nonemptyAbsC, mkAbsCStmts, mkAbsCStmtList nonemptyAbsC, mkAbsCStmts
) )
import PprAbsC ( dumpRealC ) import PprAbsC ( dumpRealC )
import SMRep ( fixedItblSize, import SMRep ( fixedItblSize,
...@@ -54,11 +54,10 @@ We leave the chunks separated so that register allocation can be ...@@ -54,11 +54,10 @@ We leave the chunks separated so that register allocation can be
performed locally within the chunk. performed locally within the chunk.
\begin{code} \begin{code}
genCodeAbstractC :: AbstractC -> UniqSM [[StixTree]] genCodeAbstractC :: AbstractC -> UniqSM [StixTree]
genCodeAbstractC absC genCodeAbstractC absC
= mapUs gentopcode (mkAbsCStmtList absC) `thenUs` \ trees -> = gentopcode absC
returnUs ([StComment SLIT("Native Code")] : trees)
where where
a2stix = amodeToStix a2stix = amodeToStix
a2stix' = amodeToStix' a2stix' = amodeToStix'
......
...@@ -18,9 +18,10 @@ import PprMach ...@@ -18,9 +18,10 @@ import PprMach
import AbsCStixGen ( genCodeAbstractC ) import AbsCStixGen ( genCodeAbstractC )
import AbsCSyn ( AbstractC, MagicId ) import AbsCSyn ( AbstractC, MagicId )
import AbsCUtils ( mkAbsCStmtList )
import AsmRegAlloc ( runRegAllocate ) import AsmRegAlloc ( runRegAllocate )
import PrimOp ( commutableOp, PrimOp(..) ) import PrimOp ( commutableOp, PrimOp(..) )
import RegAllocInfo ( mkMRegsState, MRegsState, findReservedRegs ) import RegAllocInfo ( findReservedRegs )
import Stix ( StixTree(..), StixReg(..), import Stix ( StixTree(..), StixReg(..),
pprStixTrees, pprStixTree, CodeSegment(..), pprStixTrees, pprStixTree, CodeSegment(..),
stixCountTempUses, stixSubst, stixCountTempUses, stixSubst,
...@@ -29,7 +30,8 @@ import Stix ( StixTree(..), StixReg(..), ...@@ -29,7 +30,8 @@ import Stix ( StixTree(..), StixReg(..),
uniqOfNatM_State, deltaOfNatM_State ) uniqOfNatM_State, deltaOfNatM_State )
import PrimRep ( isFloatingRep, PrimRep(..) ) import PrimRep ( isFloatingRep, PrimRep(..) )
import UniqSupply ( returnUs, thenUs, mapUs, initUs, import UniqSupply ( returnUs, thenUs, mapUs, initUs,
initUs_, UniqSM, UniqSupply ) initUs_, UniqSM, UniqSupply,
lazyThenUs, lazyMapUs )
import MachMisc ( IF_ARCH_i386(i386_insert_ffrees,) ) import MachMisc ( IF_ARCH_i386(i386_insert_ffrees,) )
import OrdList ( fromOL, concatOL ) import OrdList ( fromOL, concatOL )
...@@ -87,38 +89,47 @@ So, here we go: ...@@ -87,38 +89,47 @@ So, here we go:
\begin{code} \begin{code}
nativeCodeGen :: AbstractC -> UniqSupply -> (SDoc, SDoc) nativeCodeGen :: AbstractC -> UniqSupply -> (SDoc, SDoc)
nativeCodeGen absC us nativeCodeGen absC us
= let (stixRaw, us1) = initUs us (genCodeAbstractC absC) = let absCstmts = mkAbsCStmtList absC
stixOpt = map genericOpt stixRaw (sdoc_pairs, us1) = initUs us (lazyMapUs absCtoNat absCstmts)
insns = initUs_ us1 (codeGen stixOpt) stix_sdocs = map fst sdoc_pairs
debug_stix = vcat (map pprStixTrees stixOpt) insn_sdocs = map snd sdoc_pairs
in {- trace "nativeGen: begin" -} (debug_stix, insns)
\end{code} insn_sdoc = my_vcat insn_sdocs
stix_sdoc = vcat stix_sdocs
@codeGen@ is the top-level code-generation function:
\begin{code} # if DEBUG
codeGen :: [[StixTree]] -> UniqSM SDoc my_trace m x = trace m x
my_vcat sds = vcat (intersperse (char ' '
codeGen stixFinal $$ ptext SLIT("# ___stg_split_marker")
= mapUs genMachCode stixFinal `thenUs` \ dynamic_codes -> $$ char ' ')
let sds)
fp_kludge :: [Instr] -> [Instr] # else
fp_kludge = IF_ARCH_i386(i386_insert_ffrees,id) my_vcat sds = vcat sds
my_trace m x = x
static_instrss :: [[Instr]] # endif
static_instrss = map fp_kludge (scheduleMachCode dynamic_codes) in
docs = map (vcat . map pprInstr) static_instrss my_trace "nativeGen: begin"
(stix_sdoc, insn_sdoc)
-- for debugging only
docs_prealloc = map (vcat . map pprInstr . fromOL)
dynamic_codes absCtoNat :: AbstractC -> UniqSM (SDoc, SDoc)
text_prealloc = vcat (intersperse (char ' ' $$ char ' ') docs_prealloc) absCtoNat absC
in = genCodeAbstractC absC `thenUs` \ stixRaw ->
--trace (showSDoc text_prealloc) ( genericOpt stixRaw `bind` \ stixOpt ->
returnUs (vcat (intersperse (char ' ' genMachCode stixOpt `thenUs` \ pre_regalloc ->
$$ ptext SLIT("# ___stg_split_marker") regAlloc pre_regalloc `bind` \ almost_final ->
$$ char ' ') x86fp_kludge almost_final `bind` \ final_mach_code ->
docs)) vcat (map pprInstr final_mach_code) `bind` \ final_sdoc ->
--) pprStixTrees stixOpt `bind` \ stix_sdoc ->
returnUs (stix_sdoc, final_sdoc)
where
bind f x = x f
x86fp_kludge :: [Instr] -> [Instr]
x86fp_kludge = IF_ARCH_i386(i386_insert_ffrees,id)
regAlloc :: InstrBlock -> [Instr]
regAlloc = runRegAllocate allocatableRegs findReservedRegs
\end{code} \end{code}
Top level code generator for a chunk of stix code. For this part of Top level code generator for a chunk of stix code. For this part of
...@@ -154,20 +165,6 @@ genMachCode stmts initial_us ...@@ -154,20 +165,6 @@ genMachCode stmts initial_us
(int final_delta) (int final_delta)
\end{code} \end{code}
The next bit does the code scheduling. The scheduler must also deal
with register allocation of temporaries. Much parallelism can be
exposed via the OrdList, but more might occur, so further analysis
might be needed.
\begin{code}
scheduleMachCode :: [InstrBlock] -> [[Instr]]
scheduleMachCode
= map (runRegAllocate freeRegsState findReservedRegs)
where
freeRegsState = mkMRegsState (extractMappedRegNos freeRegs)
\end{code}
%************************************************************************ %************************************************************************
%* * %* *
\subsection[NCOpt]{The Generic Optimiser} \subsection[NCOpt]{The Generic Optimiser}
...@@ -197,24 +194,26 @@ stixPeep :: [StixTree] -> [StixTree] ...@@ -197,24 +194,26 @@ stixPeep :: [StixTree] -> [StixTree]
-- second assignment would be substituted for, giving nonsense -- second assignment would be substituted for, giving nonsense
-- code. As far as I can see, StixTemps are only ever assigned -- code. As far as I can see, StixTemps are only ever assigned
-- to once. It would be nice to be sure! -- to once. It would be nice to be sure!
{-
stixPeep ( t1@(StAssign pka (StReg (StixTemp u pk)) rhs) stixPeep ( t1@(StAssign pka (StReg (StixTemp u pk)) rhs)
: t2 : t2
: ts ) : ts )
| stixCountTempUses u t2 == 1 | stixCountTempUses u t2 == 1
&& sum (map (stixCountTempUses u) ts) == 0 && sum (map (stixCountTempUses u) ts) == 0
= trace ("nativeGen: stixInline: " ++ showSDoc (pprStixTree rhs)) =
# ifdef DEBUG
trace ("nativeGen: inlining " ++ showSDoc (pprStixTree rhs))
# endif
(stixPeep (stixSubst u rhs t2 : ts)) (stixPeep (stixSubst u rhs t2 : ts))
stixPeep (t1:t2:ts) = t1 : stixPeep (t2:ts) stixPeep (t1:t2:ts) = t1 : stixPeep (t2:ts)
stixPeep [t1] = [t1] stixPeep [t1] = [t1]
stixPeep [] = [] stixPeep [] = []
-}
-- disable stix inlining until we figure out how to fix the -- disable stix inlining until we figure out how to fix the
-- latent bugs in the register allocator which are exposed by -- latent bugs in the register allocator which are exposed by
-- the inliner. -- the inliner.
stixPeep = id --stixPeep = id
\end{code} \end{code}
For most nodes, just optimize the children. For most nodes, just optimize the children.
......
This diff is collapsed.
...@@ -241,7 +241,7 @@ getRegister (StReg (StixMagicId stgreg)) ...@@ -241,7 +241,7 @@ getRegister (StReg (StixMagicId stgreg))
-- cannae be Nothing -- cannae be Nothing
getRegister (StReg (StixTemp u pk)) getRegister (StReg (StixTemp u pk))
= returnNat (Fixed pk (UnmappedReg u pk) nilOL) = returnNat (Fixed pk (mkVReg u pk) nilOL)
getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree) getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
......
...@@ -14,25 +14,21 @@ modules --- the pleasure has been foregone.) ...@@ -14,25 +14,21 @@ modules --- the pleasure has been foregone.)
module MachRegs ( module MachRegs (
Reg(..), RegClass(..), regClass,
Reg(..), isRealReg, isVirtualReg,
allocatableRegs,
Imm(..), Imm(..),
MachRegsAddr(..), MachRegsAddr(..),
RegLoc(..), RegLoc(..),
RegNo,
addrOffset, addrOffset,
argRegs,
baseRegOffset, baseRegOffset,
callClobberedRegs,
callerSaves, callerSaves,
extractMappedRegNos, freeReg,
mappedRegNo,
freeMappedRegs,
freeReg, freeRegs,
getNewRegNCG, getNewRegNCG,
mkVReg,
magicIdRegMaybe, magicIdRegMaybe,
mkReg,
realReg,
saveLoc, saveLoc,
spRel, spRel,
stgReg, stgReg,
...@@ -63,13 +59,10 @@ import AbsCSyn ( MagicId(..) ) ...@@ -63,13 +59,10 @@ import AbsCSyn ( MagicId(..) )
import AbsCUtils ( magicIdPrimRep ) import AbsCUtils ( magicIdPrimRep )
import CLabel ( CLabel, mkMainRegTableLabel ) import CLabel ( CLabel, mkMainRegTableLabel )
import PrimOp ( PrimOp(..) ) import PrimOp ( PrimOp(..) )
import PrimRep ( PrimRep(..) ) import PrimRep ( PrimRep(..), isFloatingRep )
import Stix ( StixTree(..), StixReg(..), import Stix ( StixTree(..), StixReg(..),
getUniqueNat, returnNat, thenNat, NatM ) getUniqueNat, returnNat, thenNat, NatM )
import Unique ( mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3, import Unique ( mkPseudoUnique2, Uniquable(..), Unique )
Uniquable(..), Unique
)
--import UniqSupply ( getUniqueUs, returnUs, thenUs, UniqSM )
import Outputable import Outputable
\end{code} \end{code}
...@@ -249,101 +242,78 @@ fpRel n ...@@ -249,101 +242,78 @@ fpRel n
%* * %* *
%************************************************************************ %************************************************************************
Static Registers correspond to actual machine registers. These should RealRegs are machine regs which are available for allocation, in the
be avoided until the last possible moment. usual way. We know what class they are, because that's part of the
processor's architecture.
VirtualRegs are virtual registers. The register allocator will
eventually have to map them into RealRegs, or into spill slots.
VirtualRegs are allocated on the fly, usually to represent a single
value in the abstract assembly code (i.e. dynamic registers are
usually single assignment). With the new register allocator, the
single assignment restriction isn't necessary to get correct code,
although a better register allocation will result if single assignment
is used -- because the allocator maps a VirtualReg into a single
RealReg, even if the VirtualReg has multiple live ranges.
Dynamic registers are allocated on the fly, usually to represent a single Virtual regs can be of either class, so that info is attached.
value in the abstract assembly code (i.e. dynamic registers are usually
single assignment). Ultimately, they are mapped to available machine
registers before spitting out the code.
\begin{code} \begin{code}
data Reg
= FixedReg FAST_INT -- A pre-allocated machine register
| MappedReg FAST_INT -- A dynamically allocated machine register data RegClass
= RcInteger
| RcFloating
deriving Eq
data Reg
= RealReg Int
| VirtualRegI Unique
| VirtualRegF Unique
| MemoryReg Int PrimRep -- A machine "register" actually held in mkVReg :: Unique -> PrimRep -> Reg
-- a memory allocated table of mkVReg u pk
-- registers which didn't fit in real = if isFloatingRep pk then VirtualRegF u else VirtualRegI u
-- registers.
| UnmappedReg Unique PrimRep -- One of an infinite supply of registers, isVirtualReg (RealReg _) = False
-- always mapped to one of the earlier isVirtualReg (VirtualRegI _) = True
-- two (?) before we're done. isVirtualReg (VirtualRegF _) = True
mkReg :: Unique -> PrimRep -> Reg isRealReg = not . isVirtualReg
mkReg = UnmappedReg
getNewRegNCG :: PrimRep -> NatM Reg getNewRegNCG :: PrimRep -> NatM Reg
getNewRegNCG pk getNewRegNCG pk
= getUniqueNat `thenNat` \ u -> = if isFloatingRep pk
returnNat (UnmappedReg u pk) then getUniqueNat `thenNat` \ u -> returnNat (VirtualRegF u)
else getUniqueNat `thenNat` \ u -> returnNat (VirtualRegI u)
instance Show Reg where
showsPrec _ (FixedReg i) = showString "%" . shows IBOX(i)
showsPrec _ (MappedReg i) = showString "%" . shows IBOX(i)
showsPrec _ (MemoryReg i _) = showString "%M" . shows i
showsPrec _ (UnmappedReg i _) = showString "%U" . shows i
#ifdef DEBUG
instance Outputable Reg where
ppr r = text (show r)
#endif
cmpReg (FixedReg i) (FixedReg i') = cmp_ihash i i'
cmpReg (MappedReg i) (MappedReg i') = cmp_ihash i i'
cmpReg (MemoryReg i _) (MemoryReg i' _) = i `compare` i'
cmpReg (UnmappedReg u _) (UnmappedReg u' _) = compare u u'
cmpReg r1 r2
= let tag1 = tagReg r1
tag2 = tagReg r2
in
if tag1 _LT_ tag2 then LT else GT
where
tagReg (FixedReg _) = (ILIT(1) :: FAST_INT)
tagReg (MappedReg _) = ILIT(2)
tagReg (MemoryReg _ _) = ILIT(3)
tagReg (UnmappedReg _ _) = ILIT(4)
cmp_ihash :: FAST_INT -> FAST_INT -> Ordering
cmp_ihash a1 a2 = if a1 _EQ_ a2 then EQ else if a1 _LT_ a2 then LT else GT
instance Eq Reg where instance Eq Reg where
a == b = case (a `compare` b) of { EQ -> True; _ -> False } (==) (RealReg i1) (RealReg i2) = i1 == i2
a /= b = case (a `compare` b) of { EQ -> False; _ -> True } (==) (VirtualRegI u1) (VirtualRegI u2) = u1 == u2
(==) (VirtualRegF u1) (VirtualRegF u2) = u1 == u2
(==) reg1 reg2 = False
instance Ord Reg where instance Ord Reg where
a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } compare (RealReg i1) (RealReg i2) = compare i1 i2
a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } compare (RealReg _) (VirtualRegI _) = LT
a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } compare (RealReg _) (VirtualRegF _) = LT
a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } compare (VirtualRegI _) (RealReg _) = GT
compare a b = cmpReg a b compare (VirtualRegI u1) (VirtualRegI u2) = compare u1 u2
compare (VirtualRegI _) (VirtualRegF _) = LT
instance Uniquable Reg where compare (VirtualRegF _) (RealReg _) = GT
getUnique (UnmappedReg u _) = u compare (VirtualRegF _) (VirtualRegI _) = GT
getUnique (FixedReg i) = mkPseudoUnique1 IBOX(i) compare (VirtualRegF u1) (VirtualRegF u2) = compare u1 u2
getUnique (MappedReg i) = mkPseudoUnique2 IBOX(i)
getUnique (MemoryReg i _) = mkPseudoUnique3 i
\end{code}
\begin{code}
type RegNo = Int
realReg :: RegNo -> Reg instance Show Reg where
realReg n@IBOX(i) showsPrec _ (RealReg i) = showString (showReg i)
= if _IS_TRUE_(freeReg i) then MappedReg i else FixedReg i showsPrec _ (VirtualRegI u) = showString "%vI_" . shows u
showsPrec _ (VirtualRegF u) = showString "%vF_" . shows u
extractMappedRegNos :: [Reg] -> [RegNo]
extractMappedRegNos regs instance Outputable Reg where
= foldr ex [] regs ppr r = text (show r)
where
ex (MappedReg i) acc = IBOX(i) : acc -- we'll take it
ex _ acc = acc -- leave it out
mappedRegNo :: Reg -> RegNo instance Uniquable Reg where
mappedRegNo (MappedReg i) = IBOX(i) getUnique (RealReg i) = mkPseudoUnique2 i
mappedRegNo _ = pprPanic "mappedRegNo" empty getUnique (VirtualRegI u) = u
getUnique (VirtualRegF u) = u
\end{code} \end{code}
** Machine-specific Reg stuff: ** ** Machine-specific Reg stuff: **
...@@ -385,25 +355,35 @@ Intel x86 architecture: ...@@ -385,25 +355,35 @@ Intel x86 architecture:
\begin{code} \begin{code}
#if i386_TARGET_ARCH #if i386_TARGET_ARCH
gReg,fReg :: Int -> Int fake0, fake1, fake2, fake3, fake4, fake5,
gReg x = x eax, ebx, ecx, edx, esp, ebp, esi, edi :: Reg
fReg x = (8 + x) eax = RealReg 0
ebx = RealReg 1
fake0, fake1, fake2, fake3, fake4, fake5, eax, ebx, ecx, edx, esp :: Reg ecx = RealReg 2
eax = realReg (gReg 0) edx = RealReg 3
ebx = realReg (gReg 1) esi = RealReg 4
ecx = realReg (gReg 2) edi = RealReg 5
edx = realReg (gReg 3) ebp = RealReg 6
esi = realReg (gReg 4) esp = RealReg 7<