Commit 75700644 authored by ian@well-typed.com's avatar ian@well-typed.com

Move activeStgRegs into CodeGen.Platform

parent 07295e96
......@@ -526,8 +526,10 @@ do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl live
\begin{code}
hpChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code
hpChkGen bytes liveness reentry
= do_checks' (CmmLit (mkIntCLit 0)) bytes False True assigns
stg_gc_gen (Just activeStgRegs)
= do dflags <- getDynFlags
let platform = targetPlatform dflags
do_checks' (CmmLit (mkIntCLit 0)) bytes False True assigns
stg_gc_gen (Just (activeStgRegs platform))
where
assigns = mkStmts [ mk_vanilla_assignment 9 liveness,
mk_vanilla_assignment 10 reentry ]
......@@ -542,8 +544,10 @@ hpChkNodePointsAssignSp0 bytes sp0
stkChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code
stkChkGen bytes liveness reentry
= do_checks' bytes (CmmLit (mkIntCLit 0)) True False assigns
stg_gc_gen (Just activeStgRegs)
= do dflags <- getDynFlags
let platform = targetPlatform dflags
do_checks' bytes (CmmLit (mkIntCLit 0)) True False assigns
stg_gc_gen (Just (activeStgRegs platform))
where
assigns = mkStmts [ mk_vanilla_assignment 9 liveness,
mk_vanilla_assignment 10 reentry ]
......
......@@ -48,7 +48,7 @@ module CgUtils (
#include "../includes/stg/HaskellMachRegs.h"
import BlockId
import CodeGen.CallerSaves
import CodeGen.Platform
import CgMonad
import TyCon
import DataCon
......@@ -70,6 +70,7 @@ import Util
import DynFlags
import FastString
import Outputable
import Platform
import Data.Char
import Data.Word
......@@ -805,75 +806,6 @@ srt_escape = -1
--
-- -----------------------------------------------------------------------------
-- | Here is where the STG register map is defined for each target arch.
-- The order matters (for the llvm backend anyway)! We must make sure to
-- maintain the order here with the order used in the LLVM calling conventions.
-- Note that also, this isn't all registers, just the ones that are currently
-- possbily mapped to real registers.
activeStgRegs :: [GlobalReg]
activeStgRegs = [
#ifdef REG_Base
BaseReg
#endif
#ifdef REG_Sp
,Sp
#endif
#ifdef REG_Hp
,Hp
#endif
#ifdef REG_R1
,VanillaReg 1 VGcPtr
#endif
#ifdef REG_R2
,VanillaReg 2 VGcPtr
#endif
#ifdef REG_R3
,VanillaReg 3 VGcPtr
#endif
#ifdef REG_R4
,VanillaReg 4 VGcPtr
#endif
#ifdef REG_R5
,VanillaReg 5 VGcPtr
#endif
#ifdef REG_R6
,VanillaReg 6 VGcPtr
#endif
#ifdef REG_R7
,VanillaReg 7 VGcPtr
#endif
#ifdef REG_R8
,VanillaReg 8 VGcPtr
#endif
#ifdef REG_R9
,VanillaReg 9 VGcPtr
#endif
#ifdef REG_R10
,VanillaReg 10 VGcPtr
#endif
#ifdef REG_SpLim
,SpLim
#endif
#ifdef REG_F1
,FloatReg 1
#endif
#ifdef REG_F2
,FloatReg 2
#endif
#ifdef REG_F3
,FloatReg 3
#endif
#ifdef REG_F4
,FloatReg 4
#endif
#ifdef REG_D1
,DoubleReg 1
#endif
#ifdef REG_D2
,DoubleReg 2
#endif
]
-- | We map STG registers onto appropriate CmmExprs. Either they map
-- to real machine registers or stored as offsets from BaseReg. Given
-- a GlobalReg, get_GlobalReg_addr always produces the
......@@ -899,60 +831,60 @@ get_Regtable_addr_from_offset _ offset =
-- | Fixup global registers so that they assign to locations within the
-- RegTable if they aren't pinned for the current target.
fixStgRegisters :: RawCmmDecl -> RawCmmDecl
fixStgRegisters top@(CmmData _ _) = top
fixStgRegisters :: Platform -> RawCmmDecl -> RawCmmDecl
fixStgRegisters _ top@(CmmData _ _) = top
fixStgRegisters (CmmProc info lbl (ListGraph blocks)) =
let blocks' = map fixStgRegBlock blocks
fixStgRegisters platform (CmmProc info lbl (ListGraph blocks)) =
let blocks' = map (fixStgRegBlock platform) blocks
in CmmProc info lbl $ ListGraph blocks'
fixStgRegBlock :: CmmBasicBlock -> CmmBasicBlock
fixStgRegBlock (BasicBlock id stmts) =
let stmts' = map fixStgRegStmt stmts
fixStgRegBlock :: Platform -> CmmBasicBlock -> CmmBasicBlock
fixStgRegBlock platform (BasicBlock id stmts) =
let stmts' = map (fixStgRegStmt platform) stmts
in BasicBlock id stmts'
fixStgRegStmt :: CmmStmt -> CmmStmt
fixStgRegStmt stmt
fixStgRegStmt :: Platform -> CmmStmt -> CmmStmt
fixStgRegStmt platform stmt
= case stmt of
CmmAssign (CmmGlobal reg) src ->
let src' = fixStgRegExpr src
let src' = fixStgRegExpr platform src
baseAddr = get_GlobalReg_addr reg
in case reg `elem` activeStgRegs of
in case reg `elem` activeStgRegs platform of
True -> CmmAssign (CmmGlobal reg) src'
False -> CmmStore baseAddr src'
CmmAssign reg src ->
let src' = fixStgRegExpr src
let src' = fixStgRegExpr platform src
in CmmAssign reg src'
CmmStore addr src -> CmmStore (fixStgRegExpr addr) (fixStgRegExpr src)
CmmStore addr src -> CmmStore (fixStgRegExpr platform addr) (fixStgRegExpr platform src)
CmmCall target regs args returns ->
let target' = case target of
CmmCallee e conv -> CmmCallee (fixStgRegExpr e) conv
CmmCallee e conv -> CmmCallee (fixStgRegExpr platform e) conv
CmmPrim op mStmts ->
CmmPrim op (fmap (map fixStgRegStmt) mStmts)
CmmPrim op (fmap (map (fixStgRegStmt platform)) mStmts)
args' = map (\(CmmHinted arg hint) ->
(CmmHinted (fixStgRegExpr arg) hint)) args
(CmmHinted (fixStgRegExpr platform arg) hint)) args
in CmmCall target' regs args' returns
CmmCondBranch test dest -> CmmCondBranch (fixStgRegExpr test) dest
CmmCondBranch test dest -> CmmCondBranch (fixStgRegExpr platform test) dest
CmmSwitch expr ids -> CmmSwitch (fixStgRegExpr expr) ids
CmmSwitch expr ids -> CmmSwitch (fixStgRegExpr platform expr) ids
CmmJump addr live -> CmmJump (fixStgRegExpr addr) live
CmmJump addr live -> CmmJump (fixStgRegExpr platform addr) live
-- CmmNop, CmmComment, CmmBranch, CmmReturn
_other -> stmt
fixStgRegExpr :: CmmExpr -> CmmExpr
fixStgRegExpr expr
fixStgRegExpr :: Platform -> CmmExpr -> CmmExpr
fixStgRegExpr platform expr
= case expr of
CmmLoad addr ty -> CmmLoad (fixStgRegExpr addr) ty
CmmLoad addr ty -> CmmLoad (fixStgRegExpr platform addr) ty
CmmMachOp mop args -> CmmMachOp mop args'
where args' = map fixStgRegExpr args
where args' = map (fixStgRegExpr platform) args
CmmReg (CmmGlobal reg) ->
-- Replace register leaves with appropriate StixTrees for
......@@ -961,22 +893,22 @@ fixStgRegExpr expr
-- to mean the address of the reg table in MainCapability,
-- and for all others we generate an indirection to its
-- location in the register table.
case reg `elem` activeStgRegs of
case reg `elem` activeStgRegs platform of
True -> expr
False ->
let baseAddr = get_GlobalReg_addr reg
in case reg of
BaseReg -> fixStgRegExpr baseAddr
_other -> fixStgRegExpr
BaseReg -> fixStgRegExpr platform baseAddr
_other -> fixStgRegExpr platform
(CmmLoad baseAddr (globalRegType reg))
CmmRegOff (CmmGlobal reg) offset ->
-- RegOf leaves are just a shorthand form. If the reg maps
-- to a real reg, we keep the shorthand, otherwise, we just
-- expand it and defer to the above code.
case reg `elem` activeStgRegs of
case reg `elem` activeStgRegs platform of
True -> expr
False -> fixStgRegExpr (CmmMachOp (MO_Add wordWidth) [
False -> fixStgRegExpr platform (CmmMachOp (MO_Add wordWidth) [
CmmReg (CmmGlobal reg),
CmmLit (CmmInt (fromIntegral offset)
wordWidth)])
......
module CodeGen.CallerSaves (callerSaves) where
module CodeGen.Platform (callerSaves, activeStgRegs) where
import CmmExpr
import Platform
......@@ -30,3 +30,23 @@ callerSaves platform
| otherwise -> NoRegs.callerSaves
-- | Here is where the STG register map is defined for each target arch.
-- The order matters (for the llvm backend anyway)! We must make sure to
-- maintain the order here with the order used in the LLVM calling conventions.
-- Note that also, this isn't all registers, just the ones that are currently
-- possbily mapped to real registers.
activeStgRegs :: Platform -> [GlobalReg]
activeStgRegs platform
= case platformArch platform of
ArchX86 -> X86.activeStgRegs
ArchX86_64 -> X86_64.activeStgRegs
ArchSPARC -> SPARC.activeStgRegs
ArchARM {} -> ARM.activeStgRegs
arch
| arch `elem` [ArchPPC, ArchPPC_64] ->
case platformOS platform of
OSDarwin -> PPC_Darwin.activeStgRegs
_ -> PPC.activeStgRegs
| otherwise -> NoRegs.activeStgRegs
module CodeGen.Platform.ARM (callerSaves) where
module CodeGen.Platform.ARM where
import CmmExpr
#define MACHREGS_NO_REGS 0
#define MACHREGS_arm 1
#include "../../../../includes/CallerSaves.part.hs"
#include "../../../../includes/CodeGen.Platform.hs"
module CodeGen.Platform.NoRegs (callerSaves) where
module CodeGen.Platform.NoRegs where
import CmmExpr
#define MACHREGS_NO_REGS 1
#include "../../../../includes/CallerSaves.part.hs"
#include "../../../../includes/CodeGen.Platform.hs"
module CodeGen.Platform.PPC (callerSaves) where
module CodeGen.Platform.PPC where
import CmmExpr
#define MACHREGS_NO_REGS 0
#define MACHREGS_powerpc 1
#include "../../../../includes/CallerSaves.part.hs"
#include "../../../../includes/CodeGen.Platform.hs"
module CodeGen.Platform.PPC_Darwin (callerSaves) where
module CodeGen.Platform.PPC_Darwin where
import CmmExpr
#define MACHREGS_NO_REGS 0
#define MACHREGS_powerpc 1
#define MACHREGS_darwin 1
#include "../../../../includes/CallerSaves.part.hs"
#include "../../../../includes/CodeGen.Platform.hs"
module CodeGen.Platform.SPARC (callerSaves) where
module CodeGen.Platform.SPARC where
import CmmExpr
#define MACHREGS_NO_REGS 0
#define MACHREGS_sparc 1
#include "../../../../includes/CallerSaves.part.hs"
#include "../../../../includes/CodeGen.Platform.hs"
module CodeGen.Platform.X86 (callerSaves) where
module CodeGen.Platform.X86 where
import CmmExpr
#define MACHREGS_NO_REGS 0
#define MACHREGS_i386 1
#include "../../../../includes/CallerSaves.part.hs"
#include "../../../../includes/CodeGen.Platform.hs"
module CodeGen.Platform.X86_64 (callerSaves) where
module CodeGen.Platform.X86_64 where
import CmmExpr
#define MACHREGS_NO_REGS 0
#define MACHREGS_x86_64 1
#include "../../../../includes/CallerSaves.part.hs"
#include "../../../../includes/CodeGen.Platform.hs"
......@@ -57,7 +57,7 @@ import StgCmmClosure
import Cmm
import BlockId
import MkGraph
import CodeGen.CallerSaves
import CodeGen.Platform
import CLabel
import CmmUtils
......
......@@ -200,7 +200,7 @@ Library
PprCmmDecl
PprCmmExpr
Bitmap
CodeGen.CallerSaves
CodeGen.Platform
CodeGen.Platform.ARM
CodeGen.Platform.NoRegs
CodeGen.Platform.PPC
......
......@@ -146,7 +146,7 @@ cmmLlvmGen :: DynFlags -> UniqSupply -> LlvmEnv -> RawCmmDecl
cmmLlvmGen dflags us env cmm = do
-- rewrite assignments to global regs
let fixed_cmm = {-# SCC "llvm_fix_regs" #-}
fixStgRegisters cmm
fixStgRegisters (targetPlatform dflags) cmm
dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm"
(pprCmmGroup [fixed_cmm])
......
......@@ -99,17 +99,20 @@ llvmFunSig env lbl link
llvmFunSig' :: DynFlags -> LMString -> LlvmLinkageType -> LlvmFunctionDecl
llvmFunSig' dflags lbl link
= let toParams x | isPointer x = (x, [NoAlias, NoCapture])
= let platform = targetPlatform dflags
toParams x | isPointer x = (x, [NoAlias, NoCapture])
| otherwise = (x, [])
in LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs
(map (toParams . getVarType) llvmFunArgs) llvmFunAlign
(map (toParams . getVarType) (llvmFunArgs platform))
llvmFunAlign
-- | Create a Haskell function in LLVM.
mkLlvmFunc :: LlvmEnv -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks
-> LlvmFunction
mkLlvmFunc env lbl link sec blks
= let funDec = llvmFunSig env lbl link
funArgs = map (fsLit . getPlainName) llvmFunArgs
= let platform = targetPlatform $ getDflags env
funDec = llvmFunSig env lbl link
funArgs = map (fsLit . getPlainName) (llvmFunArgs platform)
in LlvmFunction funDec funArgs llvmStdFunAttrs sec blks
-- | Alignment to use for functions
......@@ -121,8 +124,8 @@ llvmInfAlign :: LMAlign
llvmInfAlign = Just wORD_SIZE
-- | A Function's arguments
llvmFunArgs :: [LlvmVar]
llvmFunArgs = map lmGlobalRegArg activeStgRegs
llvmFunArgs :: Platform -> [LlvmVar]
llvmFunArgs platform = map lmGlobalRegArg (activeStgRegs platform)
-- | Llvm standard fun attributes
llvmStdFunAttrs :: [LlvmFuncAttr]
......
......@@ -55,10 +55,11 @@ basicBlocksCodeGen :: LlvmEnv
-> ( [LlvmBasicBlock] , [LlvmCmmDecl] )
-> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmDecl] )
basicBlocksCodeGen env ([]) (blocks, tops)
= do let (blocks', allocs) = mapAndUnzip dominateAllocs blocks
= do let platform = targetPlatform $ getDflags env
let (blocks', allocs) = mapAndUnzip dominateAllocs blocks
let allocs' = concat allocs
let ((BasicBlock id fstmts):rblks) = blocks'
let fblocks = (BasicBlock id $ funPrologue ++ allocs' ++ fstmts):rblks
let fblocks = (BasicBlock id $ funPrologue platform ++ allocs' ++ fstmts):rblks
return (env, fblocks, tops)
basicBlocksCodeGen env (block:blocks) (lblocks', ltops')
......@@ -1226,8 +1227,8 @@ genLit _ CmmHighStackMark
--
-- | Function prologue. Load STG arguments into variables for function.
funPrologue :: [LlvmStatement]
funPrologue = concat $ map getReg activeStgRegs
funPrologue :: Platform -> [LlvmStatement]
funPrologue platform = concat $ map getReg $ activeStgRegs platform
where getReg rr =
let reg = lmGlobalRegVar rr
arg = lmGlobalRegArg rr
......@@ -1240,11 +1241,13 @@ funPrologue = concat $ map getReg activeStgRegs
funEpilogue :: LlvmEnv -> Maybe [GlobalReg] -> UniqSM ([LlvmVar], LlvmStatements)
-- Have information and liveness optimisation is enabled
funEpilogue env (Just live) | dopt Opt_RegLiveness (getDflags env) = do
loads <- mapM loadExpr activeStgRegs
funEpilogue env (Just live) | dopt Opt_RegLiveness dflags = do
loads <- mapM loadExpr (activeStgRegs platform)
let (vars, stmts) = unzip loads
return (vars, concatOL stmts)
where
dflags = getDflags env
platform = targetPlatform dflags
loadExpr r | r `elem` alwaysLive || r `elem` live = do
let reg = lmGlobalRegVar r
(v,s) <- doExpr (pLower $ getVarType reg) $ Load reg
......@@ -1254,11 +1257,13 @@ funEpilogue env (Just live) | dopt Opt_RegLiveness (getDflags env) = do
return (LMLitVar $ LMUndefLit ty, unitOL Nop)
-- don't do liveness optimisation
funEpilogue _ _ = do
loads <- mapM loadExpr activeStgRegs
funEpilogue env _ = do
loads <- mapM loadExpr (activeStgRegs platform)
let (vars, stmts) = unzip loads
return (vars, concatOL stmts)
where
dflags = getDflags env
platform = targetPlatform dflags
loadExpr r = do
let reg = lmGlobalRegVar r
(v,s) <- doExpr (pLower $ getVarType reg) $ Load reg
......@@ -1277,8 +1282,9 @@ funEpilogue _ _ = do
-- need are restored from the Cmm local var and the ones we don't need
-- are fine to be trashed.
trashStmts :: DynFlags -> LlvmStatements
trashStmts dflags = concatOL $ map trashReg activeStgRegs
where trashReg r =
trashStmts dflags = concatOL $ map trashReg $ activeStgRegs platform
where platform = targetPlatform dflags
trashReg r =
let reg = lmGlobalRegVar r
ty = (pLower . getVarType) reg
trash = unitOL $ Store (LMLitVar $ LMUndefLit ty) reg
......
......@@ -378,7 +378,7 @@ cmmNativeGen dflags ncgImpl us cmm count
-- rewrite assignments to global regs
let fixed_cmm =
{-# SCC "fixStgRegisters" #-}
fixStgRegisters cmm
fixStgRegisters platform cmm
-- cmm to cmm optimisations
let (opt_cmm, imports) =
......
......@@ -79,3 +79,67 @@ callerSaves CurrentNursery = True
#endif
callerSaves _ = False
activeStgRegs :: [GlobalReg]
activeStgRegs = [
#ifdef REG_Base
BaseReg
#endif
#ifdef REG_Sp
,Sp
#endif
#ifdef REG_Hp
,Hp
#endif
#ifdef REG_R1
,VanillaReg 1 VGcPtr
#endif
#ifdef REG_R2
,VanillaReg 2 VGcPtr
#endif
#ifdef REG_R3
,VanillaReg 3 VGcPtr
#endif
#ifdef REG_R4
,VanillaReg 4 VGcPtr
#endif
#ifdef REG_R5
,VanillaReg 5 VGcPtr
#endif
#ifdef REG_R6
,VanillaReg 6 VGcPtr
#endif
#ifdef REG_R7
,VanillaReg 7 VGcPtr
#endif
#ifdef REG_R8
,VanillaReg 8 VGcPtr
#endif
#ifdef REG_R9
,VanillaReg 9 VGcPtr
#endif
#ifdef REG_R10
,VanillaReg 10 VGcPtr
#endif
#ifdef REG_SpLim
,SpLim
#endif
#ifdef REG_F1
,FloatReg 1
#endif
#ifdef REG_F2
,FloatReg 2
#endif
#ifdef REG_F3
,FloatReg 3
#endif
#ifdef REG_F4
,FloatReg 4
#endif
#ifdef REG_D1
,DoubleReg 1
#endif
#ifdef REG_D2
,DoubleReg 2
#endif
]
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment