NCG: Split up the native code generator into arch specific modules

  - nativeGen/Instruction defines a type class for a generic
    instruction set. Each of the instruction sets we have, 
    X86, PPC and SPARC are instances of it.
  
  - The register alloctors use this type class when they need
    info about a certain register or instruction, such as
    regUsage, mkSpillInstr, mkJumpInstr, patchRegs..
  
  - nativeGen/Platform defines some data types enumerating
    the architectures and operating systems supported by the 
    native code generator.
  
  - DynFlags now keeps track of the current build platform, and 
    the PositionIndependentCode module uses this to decide what
    to do instead of relying of #ifdefs.
  
  - It's not totally retargetable yet. Some info info about the
    build target is still hardwired, but I've tried to contain
    most of it to a single module, TargetRegs.
  
  - Moved the SPILL and RELOAD instructions into LiveInstr.
  
  - Reg and RegClass now have their own modules, and are shared
    across all architectures.
parent 77ed23d5
......@@ -454,31 +454,38 @@ Library
Exposed-Modules:
AsmCodeGen
MachCodeGen
Regs
RegsBase
Instrs
RegAllocInfo
PprMach
TargetReg
NCGMonad
Instruction
Size
Reg
RegClass
PprBase
PIC
Platform
Alpha.Regs
Alpha.RegInfo
Alpha.Instr
Alpha.Ppr
Alpha.CodeGen
X86.Regs
X86.RegInfo
X86.Instr
X86.Cond
X86.Ppr
X86.CodeGen
PPC.Regs
PPC.RegInfo
PPC.Instr
PPC.Cond
PPC.Ppr
PPC.CodeGen
SPARC.Regs
SPARC.RegInfo
SPARC.Instr
SPARC.Cond
SPARC.Ppr
NCGMonad
PositionIndependentCode
SPARC.CodeGen
RegAlloc.Liveness
RegAlloc.Graph.Main
RegAlloc.Graph.Stats
......@@ -488,6 +495,7 @@ Library
RegAlloc.Graph.Spill
RegAlloc.Graph.SpillClean
RegAlloc.Graph.SpillCost
RegAlloc.Graph.TrivColorable
RegAlloc.Linear.Main
RegAlloc.Linear.JoinToTargets
RegAlloc.Linear.State
......
......@@ -64,6 +64,7 @@ module DynFlags (
#include "HsVersions.h"
import Platform
import Module
import PackageConfig
import PrelNames ( mAIN, main_RDR_Unqual )
......@@ -339,6 +340,7 @@ data DynFlags = DynFlags {
specConstrCount :: Maybe Int, -- ^ Max number of specialisations for any one function
liberateCaseThreshold :: Maybe Int, -- ^ Threshold for LiberateCase
targetPlatform :: Platform, -- ^ The platform we're compiling for. Used by the NCG.
stolen_x86_regs :: Int,
cmdlineHcIncludes :: [String], -- ^ @\-\#includes@
importPaths :: [FilePath],
......@@ -584,6 +586,7 @@ defaultDynFlags =
specConstrThreshold = Just 200,
specConstrCount = Just 3,
liberateCaseThreshold = Just 200,
targetPlatform = defaultTargetPlatform,
stolen_x86_regs = 4,
cmdlineHcIncludes = [],
importPaths = ["."],
......
This diff is collapsed.
......@@ -10,13 +10,14 @@
#include "nativeGen/NCG.h"
module Alpha.Instr (
Cond(..),
Instr(..),
RI(..)
-- Cond(..),
-- Instr(..),
-- RI(..)
)
where
{-
import BlockId
import Regs
import Cmm
......@@ -138,3 +139,4 @@ data Instr
| FUNEND CLabel
-}
module ArchReg (
)
where
class ArchReg reg format where
classOfReg :: reg -> RegClass
mkVReg :: format -> VirtReg reg
......@@ -19,21 +19,56 @@ module AsmCodeGen ( nativeCodeGen ) where
#include "HsVersions.h"
#include "nativeGen/NCG.h"
import Instrs
import Regs
import MachCodeGen
import PprMach
import RegAllocInfo
import NCGMonad
import PositionIndependentCode
import RegAlloc.Liveness
import qualified RegAlloc.Linear.Main as Linear
#if alpha_TARGET_ARCH
import Alpha.CodeGen
import Alpha.Regs
import Alpha.RegInfo
import Alpha.Instr
import Alpha.Ppr
#elif i386_TARGET_ARCH || x86_64_TARGET_ARCH
import X86.CodeGen
import X86.Regs
import X86.RegInfo
import X86.Instr
import X86.Ppr
#elif sparc_TARGET_ARCH
import SPARC.CodeGen
import SPARC.Regs
import SPARC.RegInfo
import SPARC.Instr
import SPARC.Ppr
#elif powerpc_TARGET_ARCH
import PPC.CodeGen
import PPC.Regs
import PPC.RegInfo
import PPC.Instr
import PPC.Ppr
#else
#error "AsmCodeGen: unknown architecture"
#endif
import RegAlloc.Liveness
import qualified RegAlloc.Linear.Main as Linear
import qualified GraphColor as Color
import qualified RegAlloc.Graph.Main as Color
import qualified RegAlloc.Graph.Stats as Color
import qualified RegAlloc.Graph.Coalesce as Color
import qualified RegAlloc.Graph.TrivColorable as Color
import qualified TargetReg as Target
import Platform
import Instruction
import PIC
import Reg
import NCGMonad
import Cmm
import CmmOpt ( cmmMiniInline, cmmMachOpFold )
......@@ -160,7 +195,7 @@ nativeCodeGen dflags h us cmms
dumpIfSet_dyn dflags
Opt_D_dump_asm_conflicts "Register conflict graph"
$ Color.dotGraph Color.regDotColor trivColorable
$ Color.dotGraph Target.targetRegDotColor (Color.trivColorable Target.targetRegClass)
$ graphGlobal)
......@@ -172,7 +207,7 @@ nativeCodeGen dflags h us cmms
-- write out the imports
Pretty.printDoc Pretty.LeftMode h
$ makeImportsDoc (concat imports)
$ makeImportsDoc dflags (concat imports)
return ()
......@@ -225,13 +260,13 @@ cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc count
cmmNativeGen
:: DynFlags
-> UniqSupply
-> RawCmmTop -- ^ the cmm to generate code for
-> Int -- ^ sequence number of this top thing
-> RawCmmTop -- ^ the cmm to generate code for
-> Int -- ^ sequence number of this top thing
-> IO ( UniqSupply
, [NatCmmTop] -- native code
, [CLabel] -- things imported by this cmm
, Maybe [Color.RegAllocStats] -- stats for the coloring register allocator
, Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators
, [NatCmmTop Instr] -- native code
, [CLabel] -- things imported by this cmm
, Maybe [Color.RegAllocStats Instr] -- stats for the coloring register allocator
, Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators
cmmNativeGen dflags us cmm count
= do
......@@ -375,8 +410,8 @@ x86fp_kludge top@(CmmProc info lbl params (ListGraph code)) =
-- | Build a doc for all the imports.
--
makeImportsDoc :: [CLabel] -> Pretty.Doc
makeImportsDoc imports
makeImportsDoc :: DynFlags -> [CLabel] -> Pretty.Doc
makeImportsDoc dflags imports
= dyld_stubs imports
#if HAVE_SUBSECTIONS_VIA_SYMBOLS
......@@ -410,13 +445,16 @@ makeImportsDoc imports
{- dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $
map head $ group $ sort imps-}
arch = platformArch $ targetPlatform dflags
os = platformOS $ targetPlatform dflags
-- (Hack) sometimes two Labels pretty-print the same, but have
-- different uniques; so we compare their text versions...
dyld_stubs imps
| needImportedSymbols
| needImportedSymbols arch os
= Pretty.vcat $
(pprGotDeclaration :) $
map (pprImportedSymbol . fst . head) $
(pprGotDeclaration arch os :) $
map ( pprImportedSymbol arch os . fst . head) $
groupBy (\(_,a) (_,b) -> a == b) $
sortBy (\(_,a) (_,b) -> compare a b) $
map doPpr $
......@@ -437,7 +475,11 @@ makeImportsDoc imports
-- such that as many of the local jumps as possible turn into
-- fallthroughs.
sequenceTop :: NatCmmTop -> NatCmmTop
sequenceTop
:: Instruction instr
=> NatCmmTop instr
-> NatCmmTop instr
sequenceTop top@(CmmData _ _) = top
sequenceTop (CmmProc info lbl params (ListGraph blocks)) =
CmmProc info lbl params (ListGraph $ makeFarBranches $ sequenceBlocks blocks)
......@@ -452,21 +494,36 @@ sequenceTop (CmmProc info lbl params (ListGraph blocks)) =
-- FYI, the classic layout for basic blocks uses postorder DFS; this
-- algorithm is implemented in cmm/ZipCfg.hs (NR 6 Sep 2007).
sequenceBlocks :: [NatBasicBlock] -> [NatBasicBlock]
sequenceBlocks
:: Instruction instr
=> [NatBasicBlock instr]
-> [NatBasicBlock instr]
sequenceBlocks [] = []
sequenceBlocks (entry:blocks) =
seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
-- the first block is the entry point ==> it must remain at the start.
sccBlocks :: [NatBasicBlock] -> [SCC (NatBasicBlock,Unique,[Unique])]
sccBlocks
:: Instruction instr
=> [NatBasicBlock instr]
-> [SCC ( NatBasicBlock instr
, Unique
, [Unique])]
sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks)
getOutEdges :: [Instr] -> [Unique]
getOutEdges instrs = case jumpDests (last instrs) [] of
[one] -> [getUnique one]
_many -> []
-- we're only interested in the last instruction of
-- the block, and only if it has a single destination.
-- we're only interested in the last instruction of
-- the block, and only if it has a single destination.
getOutEdges
:: Instruction instr
=> [instr] -> [Unique]
getOutEdges instrs
= case jumpDestsOfInstr (last instrs) of
[one] -> [getUnique one]
_many -> []
mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)
......@@ -494,7 +551,10 @@ reorder id accum (b@(block,id',out) : rest)
-- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too
-- big, we have to work around this limitation.
makeFarBranches :: [NatBasicBlock] -> [NatBasicBlock]
makeFarBranches
:: Instruction instr
=> [NatBasicBlock instr]
-> [NatBasicBlock instr]
#if powerpc_TARGET_ARCH
makeFarBranches blocks
......@@ -530,7 +590,11 @@ makeFarBranches = id
-- -----------------------------------------------------------------------------
-- Shortcut branches
shortcutBranches :: DynFlags -> [NatCmmTop] -> [NatCmmTop]
shortcutBranches
:: DynFlags
-> [NatCmmTop Instr]
-> [NatCmmTop Instr]
shortcutBranches dflags tops
| optLevel dflags < 1 = tops -- only with -O or higher
| otherwise = map (apply_mapping mapping) tops'
......@@ -589,12 +653,17 @@ apply_mapping ufm (CmmProc info lbl params (ListGraph blocks))
-- Switching between the two monads whilst carrying along the same
-- Unique supply breaks abstraction. Is that bad?
genMachCode :: DynFlags -> RawCmmTop -> UniqSM ([NatCmmTop], [CLabel])
genMachCode
:: DynFlags
-> RawCmmTop
-> UniqSM
( [NatCmmTop Instr]
, [CLabel])
genMachCode dflags cmm_top
= do { initial_us <- getUs
; let initial_st = mkNatM_State initial_us 0 dflags
(new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
(new_tops, final_st) = initNat initial_st (cmmTopCodeGen dflags cmm_top)
final_delta = natm_delta final_st
final_imports = natm_imports final_st
; if final_delta == 0
......
{-# OPTIONS -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
-----------------------------------------------------------------------------
--
-- Machine-dependent assembly language
--
-- (c) The University of Glasgow 1993-2004
--
-----------------------------------------------------------------------------
#include "nativeGen/NCG.h"
module Instrs (
NatCmm,
NatCmmTop,
NatBasicBlock,
condUnsigned,
condToSigned,
condToUnsigned,
#if alpha_TARGET_ARCH
module Alpha.Instr
#elif powerpc_TARGET_ARCH
module PPC.Instr
#elif i386_TARGET_ARCH || x86_64_TARGET_ARCH
module X86.Instr
#elif sparc_TARGET_ARCH
module SPARC.Instr
#else
#error "Instrs: not defined for this architecture"
#endif
)
where
#include "HsVersions.h"
import BlockId
import Regs
import Cmm
import CLabel ( CLabel, pprCLabel )
import Panic ( panic )
import Outputable
import FastString
import Constants ( wORD_SIZE )
import GHC.Exts
#if alpha_TARGET_ARCH
import Alpha.Instr
#elif powerpc_TARGET_ARCH
import PPC.Instr
#elif i386_TARGET_ARCH || x86_64_TARGET_ARCH
import X86.Instr
#elif sparc_TARGET_ARCH
import SPARC.Instr
#else
#error "Instrs: not defined for this architecture"
#endif
-- Our flavours of the Cmm types
-- Type synonyms for Cmm populated with native code
type NatCmm = GenCmm CmmStatic [CmmStatic] (ListGraph Instr)
type NatCmmTop = GenCmmTop CmmStatic [CmmStatic] (ListGraph Instr)
type NatBasicBlock = GenBasicBlock Instr
-- Condition utils
condUnsigned GU = True
condUnsigned LU = True
condUnsigned GEU = True
condUnsigned LEU = True
condUnsigned _ = False
condToSigned GU = GTT
condToSigned LU = LTT
condToSigned GEU = GE
condToSigned LEU = LE
condToSigned x = x
condToUnsigned GTT = GU
condToUnsigned LTT = LU
condToUnsigned GE = GEU
condToUnsigned LE = LEU
condToUnsigned x = x
module Instruction (
RegUsage(..),
noUsage,
NatCmm,
NatCmmTop,
NatBasicBlock,
Instruction(..)
)
where
import Reg
import BlockId
import Cmm
-- | Holds a list of source and destination registers used by a
-- particular instruction.
--
-- Machine registers that are pre-allocated to stgRegs are filtered
-- out, because they are uninteresting from a register allocation
-- standpoint. (We wouldn't want them to end up on the free list!)
--
-- As far as we are concerned, the fixed registers simply don't exist
-- (for allocation purposes, anyway).
--
data RegUsage
= RU [Reg] [Reg]
-- | No regs read or written to.
noUsage :: RegUsage
noUsage = RU [] []
-- Our flavours of the Cmm types
-- Type synonyms for Cmm populated with native code
type NatCmm instr
= GenCmm
CmmStatic
[CmmStatic]
(ListGraph instr)
type NatCmmTop instr
= GenCmmTop
CmmStatic
[CmmStatic]
(ListGraph instr)
type NatBasicBlock instr
= GenBasicBlock instr
-- | Common things that we can do with instructions, on all architectures.
-- These are used by the shared parts of the native code generator,
-- specifically the register allocators.
--
class Instruction instr where
-- | Get the registers that are being used by this instruction.
-- regUsage doesn't need to do any trickery for jumps and such.
-- Just state precisely the regs read and written by that insn.
-- The consequences of control flow transfers, as far as register
-- allocation goes, are taken care of by the register allocator.
--
regUsageOfInstr
:: instr
-> RegUsage
-- | Apply a given mapping to all the register references in this
-- instruction.
patchRegsOfInstr
:: instr
-> (Reg -> Reg)
-> instr
-- | Checks whether this instruction is a jump/branch instruction.
-- One that can change the flow of control in a way that the
-- register allocator needs to worry about.
isJumpishInstr
:: instr -> Bool
-- | Give the possible destinations of this jump instruction.
-- Must be defined for all jumpish instructions.
jumpDestsOfInstr
:: instr -> [BlockId]
-- | Change the destination of this jump instruction.
-- Used in the linear allocator when adding fixup blocks for join
-- points.
patchJumpInstr
:: instr
-> (BlockId -> BlockId)
-> instr
-- | An instruction to spill a register into a spill slot.
mkSpillInstr
:: Reg -- ^ the reg to spill
-> Int -- ^ the current stack delta
-> Int -- ^ spill slot to use
-> instr
-- | An instruction to reload a register from a spill slot.
mkLoadInstr
:: Reg -- ^ the reg to reload.
-> Int -- ^ the current stack delta
-> Int -- ^ the spill slot to use
-> instr
-- | See if this instruction is telling us the current C stack delta
takeDeltaInstr
:: instr
-> Maybe Int
-- | Check whether this instruction is some meta thing inserted into
-- the instruction stream for other purposes.
--
-- Not something that has to be treated as a real machine instruction
-- and have its registers allocated.
--
-- eg, comments, delta, ldata, etc.
isMetaInstr
:: instr
-> Bool
-- | Copy the value in a register to another one.
-- Must work for all register classes.
mkRegRegMoveInstr
:: Reg -- ^ source register
-> Reg -- ^ destination register
-> instr
-- | Take the source and destination from this reg -> reg move instruction
-- or Nothing if it's not one
takeRegRegMoveInstr
:: instr
-> Maybe (Reg, Reg)
-- | Make an unconditional jump instruction.
-- For architectures with branch delay slots, its ok to put
-- a NOP after the jump. Don't fill the delay slot with an
-- instruction that references regs or you'll confuse the
-- linear allocator.
mkJumpInstr
:: BlockId
-> [instr]
......@@ -10,28 +10,43 @@ module NCGMonad (
NatM_State(..), mkNatM_State,
NatM, -- instance Monad
initNat, addImportNat, getUniqueNat,
mapAccumLNat, setDeltaNat, getDeltaNat,
getBlockIdNat, getNewLabelNat, getNewRegNat, getNewRegPairNat,
getPicBaseMaybeNat, getPicBaseNat, getDynFlagsNat
) where
initNat,
addImportNat,
getUniqueNat,
mapAccumLNat,
setDeltaNat,
getDeltaNat,
getBlockIdNat,
getNewLabelNat,
getNewRegNat,
getNewRegPairNat,
getPicBaseMaybeNat,
getPicBaseNat,
getDynFlagsNat
)
where
#include "HsVersions.h"
import Reg
import Size
import TargetReg
import BlockId
import CLabel ( CLabel, mkAsmTempLabel )
import Regs
import UniqSupply
import Unique ( Unique )
import DynFlags
data NatM_State = NatM_State {
natm_us :: UniqSupply,
natm_delta :: Int,
natm_imports :: [(CLabel)],
natm_pic :: Maybe Reg,
natm_dflags :: DynFlags
}
data NatM_State
= NatM_State {
natm_us :: UniqSupply,
natm_delta :: Int,
natm_imports :: [(CLabel)],
natm_pic :: Maybe Reg,
natm_dflags :: DynFlags
}
newtype NatM result = NatM (NatM_State -> (result, NatM_State))
......@@ -39,22 +54,27 @@ unNat :: NatM a -> NatM_State -> (a, NatM_State)
unNat (NatM a) = a
mkNatM_State :: UniqSupply -> Int -> DynFlags -> NatM_State
mkNatM_State us delta dflags = NatM_State us delta [] Nothing dflags
mkNatM_State us delta dflags
= NatM_State us delta [] Nothing dflags
initNat :: NatM_State -> NatM a -> (a, NatM_State)
initNat init_st m = case unNat m init_st of { (r,st) -> (r,st) }
initNat init_st m
= case unNat m init_st of { (r,st) -> (r,st) }
instance Monad NatM where
(>>=) = thenNat
return = returnNat
thenNat :: NatM a -> (a -> NatM b) -> NatM b
thenNat expr cont
= NatM $ \st -> case unNat expr st of
= NatM $ \st -> case unNat expr st of
(result, st') -> unNat (cont result) st'
returnNat :: a -> NatM a
returnNat result = NatM $ \st -> (result, st)
returnNat result
= NatM $ \st -> (result, st)
mapAccumLNat :: (acc -> x -> NatM (acc, y))
-> acc
......@@ -75,43 +95,64 @@ getUniqueNat = NatM $ \ (NatM_State us delta imports pic dflags) ->
getDynFlagsNat :: NatM DynFlags
getDynFlagsNat = NatM $ \ (NatM_State us delta imports pic dflags) ->
(dflags, (NatM_State us delta imports pic dflags))
getDynFlagsNat
= NatM $ \ (NatM_State us delta imports pic dflags) ->
(dflags, (NatM_State us delta imports pic dflags))
getDeltaNat :: NatM Int
getDeltaNat = NatM $ \ st -> (natm_delta st, st)
getDeltaNat
= NatM $ \ st -> (natm_delta st, st)
setDeltaNat :: Int -> NatM ()
setDeltaNat delta = NatM $ \ (NatM_State us _ imports pic dflags) ->
((), NatM_State us delta imports pic dflags)
setDeltaNat delta
= NatM $ \ (NatM_State us _ imports pic dflags) ->
((), NatM_State us delta imports pic dflags)
addImportNat :: CLabel -> NatM ()