Commit 1bbdbe55 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Merge branch 'master' of darcs.haskell.org:/home/darcs/ghc

parents 7dfbed23 0e7d2906
......@@ -27,7 +27,6 @@ import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel,
import DynFlags
import FastString
import ForeignCall
import Outputable
import Prelude hiding (succ)
import SMRep (ByteOff)
import UniqSupply
......@@ -70,53 +69,65 @@ flattenCmmAGraph id stmts =
CmmGraph { g_entry = id,
g_graph = GMany NothingO body NothingO }
where
(block, blocks) = flatten (fromOL stmts)
entry = blockJoinHead (CmmEntry id) block
body = foldr addBlock emptyBody (entry:blocks)
flatten :: [CgStmt] -> (Block CmmNode O C, [Block CmmNode C C])
flatten [] = panic "flatten []"
-- A label at the end of a function or fork: this label must not be reachable,
-- but it might be referred to from another BB that also isn't reachable.
-- Eliminating these has to be done with a dead-code analysis. For now,
-- we just make it into a well-formed block by adding a recursive jump.
flatten [CgLabel id]
= (goto_id, [blockJoinHead (CmmEntry id) goto_id] )
where goto_id = blockJoinTail emptyBlock (CmmBranch id)
-- A jump/branch: throw away all the code up to the next label, because
-- it is unreachable. Be careful to keep forks that we find on the way.
flatten (CgLast stmt : stmts)
= case dropWhile isOrdinaryStmt stmts of
[] ->
( sing, [] )
[CgLabel id] ->
( sing, [blockJoin (CmmEntry id) emptyBlock (CmmBranch id)] )
(CgLabel id : stmts) ->
( sing, blockJoinHead (CmmEntry id) block : blocks )
where (block,blocks) = flatten stmts
(CgFork fork_id stmts : ss) ->
flatten (CgFork fork_id stmts : CgLast stmt : ss)
_ -> panic "MkGraph.flatten"
where
sing = blockJoinTail emptyBlock stmt
flatten (s:ss) =
case s of
CgStmt stmt -> (blockCons stmt block, blocks)
CgLabel id -> (blockJoinTail emptyBlock (CmmBranch id),
blockJoinHead (CmmEntry id) block : blocks)
CgFork fork_id stmts ->
(block, blockJoinHead (CmmEntry fork_id) fork_block : fork_blocks ++ blocks)
where (fork_block, fork_blocks) = flatten (fromOL stmts)
_ -> panic "MkGraph.flatten"
where (block,blocks) = flatten ss
isOrdinaryStmt :: CgStmt -> Bool
isOrdinaryStmt (CgStmt _) = True
isOrdinaryStmt (CgLast _) = True
isOrdinaryStmt _ = False
blocks = flatten1 (fromOL stmts) (blockJoinHead (CmmEntry id) emptyBlock) []
body = foldr addBlock emptyBody blocks
--
-- flatten: turn a list of CgStmt into a list of Blocks. We know
-- that any code before the first label is unreachable, so just drop
-- it.
--
-- NB. avoid the quadratic-append trap by passing in the tail of the
-- list. This is important for Very Long Functions (e.g. in T783).
--
flatten :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten [] blocks = blocks
flatten (CgLabel id : stmts) blocks
= flatten1 stmts block blocks
where !block = blockJoinHead (CmmEntry id) emptyBlock
flatten (CgFork fork_id stmts : rest) blocks
= flatten1 (fromOL stmts) (blockJoinHead (CmmEntry fork_id) emptyBlock) $
flatten rest blocks
flatten (CgLast _ : stmts) blocks = flatten stmts blocks
flatten (CgStmt _ : stmts) blocks = flatten stmts blocks
--
-- flatten1: we have a partial block, collect statements until the
-- next last node to make a block, then call flatten to get the rest
-- of the blocks
--
flatten1 :: [CgStmt] -> Block CmmNode C O
-> [Block CmmNode C C] -> [Block CmmNode C C]
-- The current block falls through to the end of a function or fork:
-- this code should not be reachable, but it may be referenced by
-- other code that is not reachable. We'll remove it later with
-- dead-code analysis, but for now we have to keep the graph
-- well-formed, so we terminate the block with a branch to the
-- beginning of the current block.
flatten1 [] block blocks
= blockJoinTail block (CmmBranch (entryLabel block)) : blocks
flatten1 (CgLast stmt : stmts) block blocks
= block' : flatten stmts blocks
where !block' = blockJoinTail block stmt
flatten1 (CgStmt stmt : stmts) block blocks
= flatten1 stmts block' blocks
where !block' = blockSnoc block stmt
flatten1 (CgFork fork_id stmts : rest) block blocks
= flatten1 (fromOL stmts) (blockJoinHead (CmmEntry fork_id) emptyBlock) $
flatten1 rest block blocks
-- a label here means that we should start a new block, and the
-- current block should fall through to the new block.
flatten1 (CgLabel id : stmts) block blocks
= blockJoinTail block (CmmBranch id) :
flatten1 stmts (blockJoinHead (CmmEntry id) emptyBlock) blocks
......
module CallerSaves (callerSaves) where
import CmmExpr
import Platform
-- | Returns 'True' if this global register is stored in a caller-saves
-- machine register.
callerSaves :: Platform -> GlobalReg -> Bool
#define MACHREGS_NO_REGS 0
callerSaves (Platform { platformArch = ArchX86 }) = platformCallerSaves
where
#define MACHREGS_i386 1
#include "../../includes/CallerSaves.part.hs"
#undef MACHREGS_i386
callerSaves (Platform { platformArch = ArchX86_64 }) = platformCallerSaves
where
#define MACHREGS_x86_64 1
#include "../../includes/CallerSaves.part.hs"
#undef MACHREGS_x86_64
callerSaves (Platform { platformArch = ppcArch, platformOS = OSDarwin })
| ppcArch `elem` [ArchPPC, ArchPPC_64] = platformCallerSaves
where
#define MACHREGS_powerpc 1
#define MACHREGS_darwin 1
#include "../../includes/CallerSaves.part.hs"
#undef MACHREGS_powerpc
#undef MACHREGS_darwin
callerSaves (Platform { platformArch = ppcArch })
| ppcArch `elem` [ArchPPC, ArchPPC_64] = platformCallerSaves
where
#define MACHREGS_powerpc 1
#include "../../includes/CallerSaves.part.hs"
#undef MACHREGS_powerpc
callerSaves (Platform { platformArch = ArchSPARC }) = platformCallerSaves
where
#define MACHREGS_sparc 1
#include "../../includes/CallerSaves.part.hs"
#undef MACHREGS_sparc
callerSaves (Platform { platformArch = ArchARM {} }) = platformCallerSaves
where
#define MACHREGS_arm 1
#include "../../includes/CallerSaves.part.hs"
#undef MACHREGS_arm
callerSaves _ = platformCallerSaves
where
#undef MACHREGS_NO_REGS
#define MACHREGS_NO_REGS 1
#include "../../includes/CallerSaves.part.hs"
......@@ -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 ]
......
......@@ -45,10 +45,9 @@ module CgUtils (
) where
#include "HsVersions.h"
#include "../includes/stg/HaskellMachRegs.h"
import BlockId
import CallerSaves
import CodeGen.Platform
import CgMonad
import TyCon
import DataCon
......@@ -70,6 +69,7 @@ import Util
import DynFlags
import FastString
import Outputable
import Platform
import Data.Char
import Data.Word
......@@ -307,14 +307,15 @@ callerSaveVolatileRegs dflags vols = (caller_save, caller_load)
callerSaveGlobalReg reg next
| callerSaves platform reg =
CmmStore (get_GlobalReg_addr reg)
CmmStore (get_GlobalReg_addr platform reg)
(CmmReg (CmmGlobal reg)) : next
| otherwise = next
callerRestoreGlobalReg reg next
| callerSaves platform reg =
CmmAssign (CmmGlobal reg)
(CmmLoad (get_GlobalReg_addr reg) (globalRegType reg))
(CmmLoad (get_GlobalReg_addr platform reg)
(globalRegType reg))
: next
| otherwise = next
......@@ -805,83 +806,15 @@ 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
-- register table address for it.
get_GlobalReg_addr :: GlobalReg -> CmmExpr
get_GlobalReg_addr BaseReg = regTableOffset 0
get_GlobalReg_addr mid = get_Regtable_addr_from_offset
(globalRegType mid) (baseRegOffset mid)
get_GlobalReg_addr :: Platform -> GlobalReg -> CmmExpr
get_GlobalReg_addr _ BaseReg = regTableOffset 0
get_GlobalReg_addr platform mid
= get_Regtable_addr_from_offset platform
(globalRegType mid) (baseRegOffset mid)
-- Calculate a literal representing an offset into the register table.
-- Used when we don't have an actual BaseReg to offset from.
......@@ -889,70 +822,68 @@ regTableOffset :: Int -> CmmExpr
regTableOffset n =
CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n))
get_Regtable_addr_from_offset :: CmmType -> Int -> CmmExpr
get_Regtable_addr_from_offset _ offset =
#ifdef REG_Base
CmmRegOff (CmmGlobal BaseReg) offset
#else
regTableOffset offset
#endif
get_Regtable_addr_from_offset :: Platform -> CmmType -> Int -> CmmExpr
get_Regtable_addr_from_offset platform _ offset =
if haveRegBase platform
then CmmRegOff (CmmGlobal BaseReg) offset
else regTableOffset 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
baseAddr = get_GlobalReg_addr reg
in case reg `elem` activeStgRegs of
let src' = fixStgRegExpr platform src
baseAddr = get_GlobalReg_addr platform reg
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 +892,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
let baseAddr = get_GlobalReg_addr platform 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.Platform (callerSaves, activeStgRegs, haveRegBase) where
import CmmExpr
import Platform
import qualified CodeGen.Platform.ARM as ARM
import qualified CodeGen.Platform.PPC as PPC
import qualified CodeGen.Platform.PPC_Darwin as PPC_Darwin
import qualified CodeGen.Platform.SPARC as SPARC
import qualified CodeGen.Platform.X86 as X86
import qualified CodeGen.Platform.X86_64 as X86_64
import qualified CodeGen.Platform.NoRegs as NoRegs
-- | Returns 'True' if this global register is stored in a caller-saves
-- machine register.
callerSaves :: Platform -> GlobalReg -> Bool
callerSaves platform
| platformUnregisterised platform = NoRegs.callerSaves
| otherwise
= case platformArch platform of
ArchX86 -> X86.callerSaves
ArchX86_64 -> X86_64.callerSaves
ArchSPARC -> SPARC.callerSaves
ArchARM {} -> ARM.callerSaves
arch
| arch `elem` [ArchPPC, ArchPPC_64] ->
case platformOS platform of
OSDarwin -> PPC_Darwin.callerSaves
_ -> PPC.callerSaves
| 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
| platformUnregisterised platform = NoRegs.activeStgRegs
| otherwise
= 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
haveRegBase :: Platform -> Bool
haveRegBase platform
| platformUnregisterised platform = NoRegs.haveRegBase
| otherwise
= case platformArch platform of
ArchX86 -> X86.haveRegBase
ArchX86_64 -> X86_64.haveRegBase
ArchSPARC -> SPARC.haveRegBase
ArchARM {} -> ARM.haveRegBase
arch
| arch `elem` [ArchPPC, ArchPPC_64] ->
case platformOS platform of
OSDarwin -> PPC_Darwin.haveRegBase
_ -> PPC.haveRegBase
| otherwise -> NoRegs.haveRegBase
module CodeGen.Platform.ARM where
import CmmExpr
#define MACHREGS_NO_REGS 0
#define MACHREGS_arm 1
#include "../../../../includes/CodeGen.Platform.hs"
module CodeGen.Platform.NoRegs where
import CmmExpr
#define MACHREGS_NO_REGS 1
#include "../../../../includes/CodeGen.Platform.hs"
module CodeGen.Platform.PPC where
import CmmExpr
#define MACHREGS_NO_REGS 0
#define MACHREGS_powerpc 1
#include "../../../../includes/CodeGen.Platform.hs"
module CodeGen.Platform.PPC_Darwin where
import CmmExpr
#define MACHREGS_NO_REGS 0
#define MACHREGS_powerpc 1
#define MACHREGS_darwin 1
#include "../../../../includes/CodeGen.Platform.hs"
module CodeGen.Platform.SPARC where
import CmmExpr
#define MACHREGS_NO_REGS 0
#define MACHREGS_sparc 1
#include "../../../../includes/CodeGen.Platform.hs"
module CodeGen.Platform.X86 where
import CmmExpr
#define MACHREGS_NO_REGS 0
#define MACHREGS_i386 1
#include "../../../../includes/CodeGen.Platform.hs"
module CodeGen.Platform.X86_64 where
import CmmExpr
#define MACHREGS_NO_REGS 0
#define MACHREGS_x86_64 1
#include "../../../../includes/CodeGen.Platform.hs"
......@@ -6,13 +6,6 @@
--
-----------------------------------------------------------------------------
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See