diff options
Diffstat (limited to 'compiler')
49 files changed, 1401 insertions, 1308 deletions
diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs index a405a0befa..8952ba1803 100644 --- a/compiler/cmm/MkGraph.hs +++ b/compiler/cmm/MkGraph.hs @@ -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 diff --git a/compiler/codeGen/CallerSaves.hs b/compiler/codeGen/CallerSaves.hs deleted file mode 100644 index babee9e36e..0000000000 --- a/compiler/codeGen/CallerSaves.hs +++ /dev/null @@ -1,51 +0,0 @@ - -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" - diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs index c0c15131c4..2ce37cf565 100644 --- a/compiler/codeGen/CgHeapery.lhs +++ b/compiler/codeGen/CgHeapery.lhs @@ -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 ] diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index d64aaa87e3..298143bd08 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -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)]) diff --git a/compiler/codeGen/CodeGen/Platform.hs b/compiler/codeGen/CodeGen/Platform.hs new file mode 100644 index 0000000000..78fba978ec --- /dev/null +++ b/compiler/codeGen/CodeGen/Platform.hs @@ -0,0 +1,73 @@ + +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 + diff --git a/compiler/codeGen/CodeGen/Platform/ARM.hs b/compiler/codeGen/CodeGen/Platform/ARM.hs new file mode 100644 index 0000000000..cad3eb7f50 --- /dev/null +++ b/compiler/codeGen/CodeGen/Platform/ARM.hs @@ -0,0 +1,9 @@ + +module CodeGen.Platform.ARM where + +import CmmExpr + +#define MACHREGS_NO_REGS 0 +#define MACHREGS_arm 1 +#include "../../../../includes/CodeGen.Platform.hs" + diff --git a/compiler/codeGen/CodeGen/Platform/NoRegs.hs b/compiler/codeGen/CodeGen/Platform/NoRegs.hs new file mode 100644 index 0000000000..6d7c3342d0 --- /dev/null +++ b/compiler/codeGen/CodeGen/Platform/NoRegs.hs @@ -0,0 +1,8 @@ + +module CodeGen.Platform.NoRegs where + +import CmmExpr + +#define MACHREGS_NO_REGS 1 +#include "../../../../includes/CodeGen.Platform.hs" + diff --git a/compiler/codeGen/CodeGen/Platform/PPC.hs b/compiler/codeGen/CodeGen/Platform/PPC.hs new file mode 100644 index 0000000000..19d0609ae2 --- /dev/null +++ b/compiler/codeGen/CodeGen/Platform/PPC.hs @@ -0,0 +1,9 @@ + +module CodeGen.Platform.PPC where + +import CmmExpr + +#define MACHREGS_NO_REGS 0 +#define MACHREGS_powerpc 1 +#include "../../../../includes/CodeGen.Platform.hs" + diff --git a/compiler/codeGen/CodeGen/Platform/PPC_Darwin.hs b/compiler/codeGen/CodeGen/Platform/PPC_Darwin.hs new file mode 100644 index 0000000000..a53ee06cc2 --- /dev/null +++ b/compiler/codeGen/CodeGen/Platform/PPC_Darwin.hs @@ -0,0 +1,10 @@ + +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" + diff --git a/compiler/codeGen/CodeGen/Platform/SPARC.hs b/compiler/codeGen/CodeGen/Platform/SPARC.hs new file mode 100644 index 0000000000..391d6c8086 --- /dev/null +++ b/compiler/codeGen/CodeGen/Platform/SPARC.hs @@ -0,0 +1,9 @@ + +module CodeGen.Platform.SPARC where + +import CmmExpr + +#define MACHREGS_NO_REGS 0 +#define MACHREGS_sparc 1 +#include "../../../../includes/CodeGen.Platform.hs" + diff --git a/compiler/codeGen/CodeGen/Platform/X86.hs b/compiler/codeGen/CodeGen/Platform/X86.hs new file mode 100644 index 0000000000..c5ea94f68c --- /dev/null +++ b/compiler/codeGen/CodeGen/Platform/X86.hs @@ -0,0 +1,9 @@ + +module CodeGen.Platform.X86 where + +import CmmExpr + +#define MACHREGS_NO_REGS 0 +#define MACHREGS_i386 1 +#include "../../../../includes/CodeGen.Platform.hs" + diff --git a/compiler/codeGen/CodeGen/Platform/X86_64.hs b/compiler/codeGen/CodeGen/Platform/X86_64.hs new file mode 100644 index 0000000000..c5aa0808b6 --- /dev/null +++ b/compiler/codeGen/CodeGen/Platform/X86_64.hs @@ -0,0 +1,9 @@ + +module CodeGen.Platform.X86_64 where + +import CmmExpr + +#define MACHREGS_NO_REGS 0 +#define MACHREGS_x86_64 1 +#include "../../../../includes/CodeGen.Platform.hs" + diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 305c731ddf..b8ed1aa939 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.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 --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module StgCmm ( codeGen ) where #define FAST_STRING_NOT_NEEDED @@ -56,11 +49,11 @@ import Control.Monad (when,void) import Util codeGen :: DynFlags - -> Module - -> [TyCon] + -> Module + -> [TyCon] -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. - -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs - -> HpcInfo + -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs + -> HpcInfo -> Stream IO CmmGroup () -- Output as a stream, so codegen can -- be interleaved with output @@ -108,7 +101,7 @@ codeGen dflags this_mod data_tycons } --------------------------------------------------------------- --- Top-level bindings +-- Top-level bindings --------------------------------------------------------------- {- 'cgTopBinding' is only used for top-level bindings, since they need @@ -123,17 +116,17 @@ variable. -} cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> FCode () cgTopBinding dflags (StgNonRec id rhs, _srts) - = do { id' <- maybeExternaliseId dflags id + = do { id' <- maybeExternaliseId dflags id ; (info, fcode) <- cgTopRhs id' rhs ; fcode ; addBindC (cg_id info) info -- Add the *un-externalised* Id to the envt, - -- so we find it when we look up occurrences + -- so we find it when we look up occurrences } cgTopBinding dflags (StgRec pairs, _srts) - = do { let (bndrs, rhss) = unzip pairs + = do { let (bndrs, rhss) = unzip pairs ; bndrs' <- Prelude.mapM (maybeExternaliseId dflags) bndrs - ; let pairs' = zip bndrs' rhss + ; let pairs' = zip bndrs' rhss ; r <- sequence $ unzipWith cgTopRhs pairs' ; let (infos, fcodes) = unzip r ; addBindsC infos @@ -142,8 +135,8 @@ cgTopBinding dflags (StgRec pairs, _srts) cgTopRhs :: Id -> StgRhs -> FCode (CgIdInfo, FCode ()) - -- The Id is passed along for setting up a binding... - -- It's already been externalised if necessary + -- The Id is passed along for setting up a binding... + -- It's already been externalised if necessary cgTopRhs bndr (StgRhsCon _cc con args) = forkStatics (cgTopRhsCon bndr con args) @@ -155,18 +148,18 @@ cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag _srt args body) --------------------------------------------------------------- --- Module initialisation code +-- Module initialisation code --------------------------------------------------------------- {- The module initialisation code looks like this, roughly: - FN(__stginit_Foo) { - JMP_(__stginit_Foo_1_p) - } + FN(__stginit_Foo) { + JMP_(__stginit_Foo_1_p) + } - FN(__stginit_Foo_1_p) { - ... - } + FN(__stginit_Foo_1_p) { + ... + } We have one version of the init code with a module version and the 'way' attached to it. The version number helps to catch cases @@ -186,16 +179,16 @@ cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag _srt args body) has the version and way info appended to it. We initialise the module tree by keeping a work-stack, - * pointed to by Sp - * that grows downward - * Sp points to the last occupied slot + * pointed to by Sp + * that grows downward + * Sp points to the last occupied slot -} mkModuleInit :: CollectedCCs -- cost centre info - -> Module + -> Module -> HpcInfo - -> FCode () + -> FCode () mkModuleInit cost_centre_info this_mod hpc_info = do { initHpc this_mod hpc_info @@ -207,7 +200,7 @@ mkModuleInit cost_centre_info this_mod hpc_info --------------------------------------------------------------- --- Generating static stuff for algebraic data types +-- Generating static stuff for algebraic data types --------------------------------------------------------------- @@ -223,11 +216,11 @@ cgDataCon :: DataCon -> FCode () -- Generate the entry code, info tables, and (for niladic constructor) -- the static closure, for a constructor. cgDataCon data_con - = do { dflags <- getDynFlags + = do { dflags <- getDynFlags ; let (tot_wds, -- #ptr_wds + #nonptr_wds - ptr_wds, -- #ptr_wds - arg_things) = mkVirtConstrOffsets dflags arg_reps + ptr_wds, -- #ptr_wds + arg_things) = mkVirtConstrOffsets dflags arg_reps nonptr_wds = tot_wds - ptr_wds @@ -238,29 +231,29 @@ cgDataCon data_con = emitClosureAndInfoTable info_tbl NativeDirectCall [] $ mk_code ticky_code - mk_code ticky_code - = -- NB: We don't set CC when entering data (WDP 94/06) - do { _ <- ticky_code - ; ldvEnter (CmmReg nodeReg) - ; tickyReturnOldCon (length arg_things) + mk_code ticky_code + = -- NB: We don't set CC when entering data (WDP 94/06) + do { _ <- ticky_code + ; ldvEnter (CmmReg nodeReg) + ; tickyReturnOldCon (length arg_things) ; void $ emitReturn [cmmOffsetB (CmmReg nodeReg) (tagForCon data_con)] } -- The case continuation code expects a tagged pointer - arg_reps :: [(PrimRep, UnaryType)] - arg_reps = [(typePrimRep rep_ty, rep_ty) | ty <- dataConRepArgTys data_con, rep_ty <- flattenRepType (repType ty)] + arg_reps :: [(PrimRep, UnaryType)] + arg_reps = [(typePrimRep rep_ty, rep_ty) | ty <- dataConRepArgTys data_con, rep_ty <- flattenRepType (repType ty)] - -- Dynamic closure code for non-nullary constructors only - ; whenC (not (isNullaryRepDataCon data_con)) + -- Dynamic closure code for non-nullary constructors only + ; whenC (not (isNullaryRepDataCon data_con)) (emit_info dyn_info_tbl tickyEnterDynCon) - -- Dynamic-Closure first, to reduce forward references + -- Dynamic-Closure first, to reduce forward references ; emit_info sta_info_tbl tickyEnterStaticCon } --------------------------------------------------------------- --- Stuff to support splitting +-- Stuff to support splitting --------------------------------------------------------------- -- If we're splitting the object, we need to externalise all the @@ -269,17 +262,17 @@ cgDataCon data_con maybeExternaliseId :: DynFlags -> Id -> FCode Id maybeExternaliseId dflags id - | dopt Opt_SplitObjs dflags, -- Externalise the name for -split-objs + | dopt Opt_SplitObjs dflags, -- Externalise the name for -split-objs isInternalName name = do { mod <- getModuleName - ; returnFC (setIdName id (externalise mod)) } - | otherwise = returnFC id + ; returnFC (setIdName id (externalise mod)) } + | otherwise = returnFC id where externalise mod = mkExternalName uniq mod new_occ loc name = idName id uniq = nameUnique name new_occ = mkLocalOcc uniq (nameOccName name) loc = nameSrcSpan name - -- We want to conjure up a name that can't clash with any - -- existing name. So we generate - -- Mod_$L243foo - -- where 243 is the unique. + -- We want to conjure up a name that can't clash with any + -- existing name. So we generate + -- Mod_$L243foo + -- where 243 is the unique. diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 0e78eaf1fa..0f0bfb8467 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -6,17 +6,10 @@ -- ----------------------------------------------------------------------------- -{-# 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 --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module StgCmmBind ( - cgTopRhsClosure, - cgBind, - emitBlackHoleCode, + cgTopRhsClosure, + cgBind, + emitBlackHoleCode, pushUpdateFrame ) where @@ -36,7 +29,7 @@ import StgCmmClosure import StgCmmForeign (emitPrimCall) import MkGraph -import CoreSyn ( AltCon(..) ) +import CoreSyn ( AltCon(..) ) import SMRep import Cmm import CmmUtils @@ -57,18 +50,18 @@ import Maybes import DynFlags ------------------------------------------------------------------------ --- Top-level bindings +-- Top-level bindings ------------------------------------------------------------------------ -- For closures bound at top level, allocate in static space. -- They should have no free variables. cgTopRhsClosure :: Id - -> CostCentreStack -- Optional cost centre annotation - -> StgBinderInfo - -> UpdateFlag + -> CostCentreStack -- Optional cost centre annotation + -> StgBinderInfo + -> UpdateFlag -> [Id] -- Args - -> StgExpr + -> StgExpr -> FCode (CgIdInfo, FCode ()) cgTopRhsClosure id ccs _ upd_flag args body @@ -90,11 +83,11 @@ cgTopRhsClosure id ccs _ upd_flag args body info_tbl = mkCmmInfo closure_info -- XXX short-cut closure_rep = mkStaticClosureFields dflags info_tbl ccs caffy [] - -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY) + -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY) ; emitDataLits closure_label closure_rep ; let fv_details :: [(NonVoid Id, VirtualHpOffset)] (_, _, fv_details) = mkVirtHeapOffsets dflags (isLFThunk lf_info) - (addIdReps []) + (addIdReps []) -- Don't drop the non-void args until the closure info has been made ; forkClosureBody (closureCodeBody True id closure_info ccs (nonVoidIds args) (length args) body fv_details) @@ -102,7 +95,7 @@ cgTopRhsClosure id ccs _ upd_flag args body ; return () } ------------------------------------------------------------------------ --- Non-top-level bindings +-- Non-top-level bindings ------------------------------------------------------------------------ cgBind :: StgBinding -> FCode () @@ -192,19 +185,19 @@ cgRhs name (StgRhsClosure cc bi fvs upd_flag _srt args body) mkRhsClosure dflags name cc bi (nonVoidIds fvs) upd_flag args body ------------------------------------------------------------------------ --- Non-constructor right hand sides +-- Non-constructor right hand sides ------------------------------------------------------------------------ mkRhsClosure :: DynFlags -> Id -> CostCentreStack -> StgBinderInfo - -> [NonVoid Id] -- Free vars + -> [NonVoid Id] -- Free vars -> UpdateFlag - -> [Id] -- Args - -> StgExpr + -> [Id] -- Args + -> StgExpr -> FCode (CgIdInfo, FCode CmmAGraph) {- mkRhsClosure looks for two special forms of the right-hand side: - a) selector thunks - b) AP thunks + a) selector thunks + b) AP thunks If neither happens, it just calls mkClosureLFInfo. You might think that mkClosureLFInfo should do all this, but it seems wrong for the @@ -217,14 +210,14 @@ but nothing deep. We are looking for a closure of {\em exactly} the form: ... = [the_fv] \ u [] -> - case the_fv of - con a_1 ... a_n -> a_i + case the_fv of + con a_1 ... a_n -> a_i Note [Ap thunks] ~~~~~~~~~~~~~~~~ A more generic AP thunk of the form - x = [ x_1...x_n ] \.. [] -> x_1 ... x_n + x = [ x_1...x_n ] \.. [] -> x_1 ... x_n A set of these is compiled statically into the RTS, so we just use those. We could extend the idea to thunks where some of the x_i are @@ -239,17 +232,17 @@ for semi-obvious reasons. ---------- Note [Selectors] ------------------ mkRhsClosure dflags bndr _cc _bi - [NonVoid the_fv] -- Just one free var - upd_flag -- Updatable thunk + [NonVoid the_fv] -- Just one free var + upd_flag -- Updatable thunk [] -- A thunk (StgCase (StgApp scrutinee [{-no args-}]) - _ _ _ _ -- ignore uniq, etc. - (AlgAlt _) - [(DataAlt _, params, _use_mask, - (StgApp selectee [{-no args-}]))]) - | the_fv == scrutinee -- Scrutinee is the only free variable - && maybeToBool maybe_offset -- Selectee is a component of the tuple - && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough + _ _ _ _ -- ignore uniq, etc. + (AlgAlt _) + [(DataAlt _, params, _use_mask, + (StgApp selectee [{-no args-}]))]) + | the_fv == scrutinee -- Scrutinee is the only free variable + && maybeToBool maybe_offset -- Selectee is a component of the tuple + && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough = -- NOT TRUE: ASSERT(is_single_constructor) -- The simplifier may have statically determined that the single alternative -- is the only possible case and eliminated the others, even if there are @@ -260,25 +253,25 @@ mkRhsClosure dflags bndr _cc _bi -- srt is discarded; it must be empty cgRhsStdThunk bndr lf_info [StgVarArg the_fv] where - lf_info = mkSelectorLFInfo bndr offset_into_int - (isUpdatable upd_flag) + lf_info = mkSelectorLFInfo bndr offset_into_int + (isUpdatable upd_flag) (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps params) - -- Just want the layout - maybe_offset = assocMaybe params_w_offsets (NonVoid selectee) - Just the_offset = maybe_offset + -- Just want the layout + maybe_offset = assocMaybe params_w_offsets (NonVoid selectee) + Just the_offset = maybe_offset offset_into_int = the_offset - fixedHdrSize dflags ---------- Note [Ap thunks] ------------------ mkRhsClosure dflags bndr _cc _bi - fvs - upd_flag + fvs + upd_flag [] -- No args; a thunk (StgApp fun_id args) | args `lengthIs` (arity-1) - && all (isGcPtrRep . idPrimRep . stripNV) fvs - && isUpdatable upd_flag - && arity <= mAX_SPEC_AP_SIZE + && all (isGcPtrRep . idPrimRep . stripNV) fvs + && isUpdatable upd_flag + && arity <= mAX_SPEC_AP_SIZE && not (dopt Opt_SccProfilingOn dflags) -- not when profiling: we don't want to -- lose information about this particular @@ -288,11 +281,11 @@ mkRhsClosure dflags bndr _cc _bi = cgRhsStdThunk bndr lf_info payload where - lf_info = mkApLFInfo bndr upd_flag arity - -- the payload has to be in the correct order, hence we can't - -- just use the fvs. - payload = StgVarArg fun_id : args - arity = length fvs + lf_info = mkApLFInfo bndr upd_flag arity + -- the payload has to be in the correct order, hence we can't + -- just use the fvs. + payload = StgVarArg fun_id : args + arity = length fvs ---------- Default case ------------------ mkRhsClosure _ bndr cc _ fvs upd_flag args body @@ -302,42 +295,42 @@ mkRhsClosure _ bndr cc _ fvs upd_flag args body where gen_code lf_info reg = do { -- LAY OUT THE OBJECT - -- If the binder is itself a free variable, then don't store - -- it in the closure. Instead, just bind it to Node on entry. - -- NB we can be sure that Node will point to it, because we - -- haven't told mkClosureLFInfo about this; so if the binder - -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is* - -- stored in the closure itself, so it will make sure that - -- Node points to it... - ; let - is_elem = isIn "cgRhsClosure" - bndr_is_a_fv = (NonVoid bndr) `is_elem` fvs - reduced_fvs | bndr_is_a_fv = fvs `minusList` [NonVoid bndr] - | otherwise = fvs - - - -- MAKE CLOSURE INFO FOR THIS CLOSURE + -- If the binder is itself a free variable, then don't store + -- it in the closure. Instead, just bind it to Node on entry. + -- NB we can be sure that Node will point to it, because we + -- haven't told mkClosureLFInfo about this; so if the binder + -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is* + -- stored in the closure itself, so it will make sure that + -- Node points to it... + ; let + is_elem = isIn "cgRhsClosure" + bndr_is_a_fv = (NonVoid bndr) `is_elem` fvs + reduced_fvs | bndr_is_a_fv = fvs `minusList` [NonVoid bndr] + | otherwise = fvs + + + -- MAKE CLOSURE INFO FOR THIS CLOSURE ; mod_name <- getModuleName ; dflags <- getDynFlags ; let name = idName bndr descr = closureDescription dflags mod_name name fv_details :: [(NonVoid Id, VirtualHpOffset)] - (tot_wds, ptr_wds, fv_details) - = mkVirtHeapOffsets dflags (isLFThunk lf_info) - (addIdReps (map stripNV reduced_fvs)) - closure_info = mkClosureInfo dflags False -- Not static - bndr lf_info tot_wds ptr_wds + (tot_wds, ptr_wds, fv_details) + = mkVirtHeapOffsets dflags (isLFThunk lf_info) + (addIdReps (map stripNV reduced_fvs)) + closure_info = mkClosureInfo dflags False -- Not static + bndr lf_info tot_wds ptr_wds descr - -- BUILD ITS INFO TABLE AND CODE - ; forkClosureBody $ - -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere - -- (b) ignore Sequel from context; use empty Sequel - -- And compile the body - closureCodeBody False bndr closure_info cc (nonVoidIds args) + -- BUILD ITS INFO TABLE AND CODE + ; forkClosureBody $ + -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere + -- (b) ignore Sequel from context; use empty Sequel + -- And compile the body + closureCodeBody False bndr closure_info cc (nonVoidIds args) (length args) body fv_details - -- BUILD THE OBJECT + -- BUILD THE OBJECT -- ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body ; let use_cc = curCCS; blame_cc = curCCS ; emit (mkComment $ mkFastString "calling allocDynClosure") @@ -346,7 +339,7 @@ mkRhsClosure _ bndr cc _ fvs upd_flag args body ; hp_plus_n <- allocDynClosure info_tbl lf_info use_cc blame_cc (map toVarArg fv_details) - -- RETURN + -- RETURN ; return (mkRhsInit reg lf_info hp_plus_n) } @@ -367,36 +360,36 @@ cgRhsStdThunk bndr lf_info payload } where gen_code reg - = do -- AHA! A STANDARD-FORM THUNK - { -- LAY OUT THE OBJECT + = do -- AHA! A STANDARD-FORM THUNK + { -- LAY OUT THE OBJECT mod_name <- getModuleName ; dflags <- getDynFlags ; let (tot_wds, ptr_wds, payload_w_offsets) - = mkVirtHeapOffsets dflags (isLFThunk lf_info) (addArgReps payload) + = mkVirtHeapOffsets dflags (isLFThunk lf_info) (addArgReps payload) - descr = closureDescription dflags mod_name (idName bndr) - closure_info = mkClosureInfo dflags False -- Not static - bndr lf_info tot_wds ptr_wds + descr = closureDescription dflags mod_name (idName bndr) + closure_info = mkClosureInfo dflags False -- Not static + bndr lf_info tot_wds ptr_wds descr -- ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body ; let use_cc = curCCS; blame_cc = curCCS - -- BUILD THE OBJECT + -- BUILD THE OBJECT ; let info_tbl = mkCmmInfo closure_info ; hp_plus_n <- allocDynClosure info_tbl lf_info use_cc blame_cc payload_w_offsets - -- RETURN + -- RETURN ; return (mkRhsInit reg lf_info hp_plus_n) } -mkClosureLFInfo :: Id -- The binder - -> TopLevelFlag -- True of top level - -> [NonVoid Id] -- Free vars - -> UpdateFlag -- Update flag - -> [Id] -- Args - -> FCode LambdaFormInfo +mkClosureLFInfo :: Id -- The binder + -> TopLevelFlag -- True of top level + -> [NonVoid Id] -- Free vars + -> UpdateFlag -- Update flag + -> [Id] -- Args + -> FCode LambdaFormInfo mkClosureLFInfo bndr top fvs upd_flag args | null args = return (mkLFThunk (idType bndr) top (map stripNV fvs) upd_flag) | otherwise = @@ -405,18 +398,18 @@ mkClosureLFInfo bndr top fvs upd_flag args ------------------------------------------------------------------------ --- The code for closures} +-- The code for closures} ------------------------------------------------------------------------ closureCodeBody :: Bool -- whether this is a top-level binding -> Id -- the closure's name - -> ClosureInfo -- Lots of information about this closure - -> CostCentreStack -- Optional cost centre attached to closure - -> [NonVoid Id] -- incoming args to the closure - -> Int -- arity, including void args - -> StgExpr - -> [(NonVoid Id, VirtualHpOffset)] -- the closure's free vars - -> FCode () + -> ClosureInfo -- Lots of information about this closure + -> CostCentreStack -- Optional cost centre attached to closure + -> [NonVoid Id] -- incoming args to the closure + -> Int -- arity, including void args + -> StgExpr + -> [(NonVoid Id, VirtualHpOffset)] -- the closure's free vars + -> FCode () {- There are two main cases for the code for closures. @@ -549,7 +542,7 @@ thunkCode cl_info fv_details _cc node arity body ------------------------------------------------------------------------ --- Update and black-hole wrappers +-- Update and black-hole wrappers ------------------------------------------------------------------------ blackHoleIt :: ClosureInfo -> FCode () @@ -593,9 +586,9 @@ emitBlackHoleCode is_single_entry = do emitStore (CmmReg nodeReg) (CmmReg (CmmGlobal EagerBlackholeInfo)) setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode () - -- Nota Bene: this function does not change Node (even if it's a CAF), - -- so that the cost centre in the original closure can still be - -- extracted by a subsequent enterCostCentre + -- Nota Bene: this function does not change Node (even if it's a CAF), + -- so that the cost centre in the original closure can still be + -- extracted by a subsequent enterCostCentre setupUpdate closure_info node body | closureReEntrant closure_info = body @@ -616,14 +609,14 @@ setupUpdate closure_info node body pushUpdateFrame lbl (CmmReg (CmmLocal node)) body - | otherwise -- A static closure - = do { tickyUpdateBhCaf closure_info + | otherwise -- A static closure + = do { tickyUpdateBhCaf closure_info - ; if closureUpdReqd closure_info - then do -- Blackhole the (updatable) CAF: + ; if closureUpdReqd closure_info + then do -- Blackhole the (updatable) CAF: { upd_closure <- link_caf node True ; pushUpdateFrame mkBHUpdInfoLabel upd_closure body } - else do {tickyUpdateFrameOmitted; body} + else do {tickyUpdateFrameOmitted; body} } ----------------------------------------------------------------------------- @@ -693,7 +686,7 @@ link_caf :: LocalReg -- pointer to the closure link_caf node _is_upd = do { dflags <- getDynFlags -- Alloc black hole specifying CC_HDR(Node) as the cost centre - ; let use_cc = costCentreFrom (CmmReg nodeReg) + ; let use_cc = costCentreFrom (CmmReg nodeReg) blame_cc = use_cc tso = CmmReg (CmmGlobal CurrentTSO) @@ -708,8 +701,8 @@ link_caf node _is_upd = do -- Call the RTS function newCAF to add the CAF to the CafList -- so that the garbage collector can find them - -- This must be done *before* the info table pointer is overwritten, - -- because the old info table ptr is needed for reversion + -- This must be done *before* the info table pointer is overwritten, + -- because the old info table ptr is needed for reversion ; ret <- newTemp bWord ; emitRtsCallGen [(ret,NoHint)] rtsPackageId (fsLit "newCAF") [ (CmmReg (CmmGlobal BaseReg), AddrHint), @@ -731,7 +724,7 @@ link_caf node _is_upd = do ; return hp_rel } ------------------------------------------------------------------------ --- Profiling +-- Profiling ------------------------------------------------------------------------ -- For "global" data constructors the description is simply occurrence @@ -739,16 +732,16 @@ link_caf node _is_upd = do -- @closureDescription@ from the let binding information. closureDescription :: DynFlags - -> Module -- Module - -> Name -- Id of closure binding - -> String - -- Not called for StgRhsCon which have global info tables built in - -- CgConTbls.lhs with a description generated from the data constructor + -> Module -- Module + -> Name -- Id of closure binding + -> String + -- Not called for StgRhsCon which have global info tables built in + -- CgConTbls.lhs with a description generated from the data constructor closureDescription dflags mod_name name = showSDocDump dflags (char '<' <> - (if isExternalName name - then ppr name -- ppr will include the module name prefix - else pprModule mod_name <> char '.' <> ppr name) <> - char '>') + (if isExternalName name + then ppr name -- ppr will include the module name prefix + else pprModule mod_name <> char '.' <> ppr name) <> + char '>') -- showSDocDump, because we want to see the unique on the Name. diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 038503eee7..ab6f888835 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.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 --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module StgCmmExpr ( cgExpr ) where #define FAST_STRING_NOT_NEEDED @@ -44,7 +37,7 @@ import Id import PrimOp import TyCon import Type -import CostCentre ( CostCentreStack, currentCCS ) +import CostCentre ( CostCentreStack, currentCCS ) import Maybes import Util import FastString @@ -54,7 +47,7 @@ import UniqSupply import Control.Monad (when,void) ------------------------------------------------------------------------ --- cgExpr: the main function +-- cgExpr: the main function ------------------------------------------------------------------------ cgExpr :: StgExpr -> FCode ReturnKind @@ -87,16 +80,16 @@ cgExpr (StgCase expr _live_vars _save_vars bndr _srt alt_type alts) = cgExpr (StgLam {}) = panic "cgExpr: StgLam" ------------------------------------------------------------------------ --- Let no escape +-- Let no escape ------------------------------------------------------------------------ {- Generating code for a let-no-escape binding, aka join point is very very similar to what we do for a case expression. The duality is between - let-no-escape x = b - in e + let-no-escape x = b + in e and - case e of ... -> b + case e of ... -> b That is, the RHS of 'x' (ie 'b') will execute *later*, just like the alternative of the case; it needs to be compiled in an environment @@ -124,7 +117,7 @@ cgLneBinds join_id (StgRec pairs) ------------------------- cgLetNoEscapeRhs :: BlockId -- join point for successor of let-no-escape - -> Maybe LocalReg -- Saved cost centre + -> Maybe LocalReg -- Saved cost centre -> Id -> StgRhs -> FCode (CgIdInfo, FCode ()) @@ -138,7 +131,7 @@ cgLetNoEscapeRhs join_id local_cc bndr rhs = } cgLetNoEscapeRhsBody - :: Maybe LocalReg -- Saved cost centre + :: Maybe LocalReg -- Saved cost centre -> Id -> StgRhs -> FCode (CgIdInfo, FCode ()) @@ -146,18 +139,18 @@ cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd _ args body) = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args) = cgLetNoEscapeClosure bndr local_cc cc [] (StgConApp con args) - -- For a constructor RHS we want to generate a single chunk of - -- code which can be jumped to from many places, which will - -- return the constructor. It's easy; just behave as if it - -- was an StgRhsClosure with a ConApp inside! + -- For a constructor RHS we want to generate a single chunk of + -- code which can be jumped to from many places, which will + -- return the constructor. It's easy; just behave as if it + -- was an StgRhsClosure with a ConApp inside! ------------------------- cgLetNoEscapeClosure - :: Id -- binder - -> Maybe LocalReg -- Slot for saved current cost centre - -> CostCentreStack -- XXX: *** NOT USED *** why not? - -> [NonVoid Id] -- Args (as in \ args -> body) - -> StgExpr -- Body (as in above) + :: Id -- binder + -> Maybe LocalReg -- Slot for saved current cost centre + -> CostCentreStack -- XXX: *** NOT USED *** why not? + -> [NonVoid Id] -- Args (as in \ args -> body) + -> StgExpr -- Body (as in above) -> FCode (CgIdInfo, FCode ()) cgLetNoEscapeClosure bndr cc_slot _unused_cc args body @@ -168,12 +161,12 @@ cgLetNoEscapeClosure bndr cc_slot _unused_cc args body { restoreCurrentCostCentre cc_slot ; arg_regs <- bindArgsToRegs args ; void $ altHeapCheck arg_regs (cgExpr body) } - -- Using altHeapCheck just reduces - -- instructions to save on stack + -- Using altHeapCheck just reduces + -- instructions to save on stack ------------------------------------------------------------------------ --- Case expressions +-- Case expressions ------------------------------------------------------------------------ {- Note [Compiling case expressions] @@ -185,11 +178,11 @@ trigger GC. A more interesting situation is this (a Plan-B situation) - !P!; - ...P... - case x# of - 0# -> !Q!; ...Q... - default -> !R!; ...R... + !P!; + ...P... + case x# of + 0# -> !Q!; ...Q... + default -> !R!; ...R... where !x! indicates a possible heap-check point. The heap checks in the alternatives *can* be omitted, in which case the topmost @@ -209,8 +202,8 @@ In favour of omitting !Q!, !R!: Against omitting !Q!, !R! - May put a heap-check into the inner loop. Suppose - the main loop is P -> R -> P -> R... - Q is the loop exit, and only it does allocation. + the main loop is P -> R -> P -> R... + Q is the loop exit, and only it does allocation. This only hurts us if P does no allocation. If P allocates, then there is a heap check in the inner loop anyway. @@ -227,14 +220,14 @@ Suppose the inner loop is P->R->P->R etc. Then here is how many heap checks we get in the *inner loop* under various conditions - Alooc Heap check in branches (!Q!, !R!)? - P Q R yes no (absorb to !P!) + Alooc Heap check in branches (!Q!, !R!)? + P Q R yes no (absorb to !P!) -------------------------------------- - n n n 0 0 - n y n 0 1 - n . y 1 1 - y . y 2 1 - y . n 1 1 + n n n 0 0 + n y n 0 1 + n . y 1 1 + y . y 2 1 + y . n 1 1 Best choices: absorb heap checks from Q and R into !P! iff a) P itself does some allocation @@ -247,18 +240,18 @@ single-branch cases, we may have lots of things live Hence: two basic plans for - case e of r { alts } + case e of r { alts } ------ Plan A: the general case --------- - ...save current cost centre... + ...save current cost centre... - ...code for e, - with sequel (SetLocals r) + ...code for e, + with sequel (SetLocals r) ...restore current cost centre... - ...code for alts... - ...alts do their own heap checks + ...code for alts... + ...alts do their own heap checks ------ Plan B: special case when --------- (i) e does not allocate or call GC @@ -269,22 +262,22 @@ Hence: two basic plans for is absorbed by the upstream check. Very common example: primops on unboxed values - ...code for e, - with sequel (SetLocals r)... + ...code for e, + with sequel (SetLocals r)... - ...code for alts... - ...no heap check... + ...code for alts... + ...no heap check... -} ------------------------------------- data GcPlan - = GcInAlts -- Put a GC check at the start the case alternatives, - [LocalReg] -- which binds these registers + = GcInAlts -- Put a GC check at the start the case alternatives, + [LocalReg] -- which binds these registers | NoGcInAlts -- The scrutinee is a primitive value, or a call to a - -- primitive op which does no GC. Absorb the allocation - -- of the case alternative(s) into the upstream check + -- primitive op which does no GC. Absorb the allocation + -- of the case alternative(s) into the upstream check ------------------------------------- cgCase :: StgExpr -> Id -> AltType -> [StgAlt] -> FCode ReturnKind @@ -446,14 +439,14 @@ isSimpleScrut :: StgExpr -> AltType -> Bool -- NB: if you get this wrong, and claim that the expression doesn't allocate -- when it does, you'll deeply mess up allocation isSimpleScrut (StgOpApp op _ _) _ = isSimpleOp op -isSimpleScrut (StgLit _) _ = True -- case 1# of { 0# -> ..; ... } -isSimpleScrut (StgApp _ []) (PrimAlt _) = True -- case x# of { 0# -> ..; ... } -isSimpleScrut _ _ = False +isSimpleScrut (StgLit _) _ = True -- case 1# of { 0# -> ..; ... } +isSimpleScrut (StgApp _ []) (PrimAlt _) = True -- case x# of { 0# -> ..; ... } +isSimpleScrut _ _ = False isSimpleOp :: StgOp -> Bool -- True iff the op cannot block or allocate isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) = not (playSafe safe) -isSimpleOp (StgPrimOp op) = not (primOpOutOfLine op) +isSimpleOp (StgPrimOp op) = not (primOpOutOfLine op) isSimpleOp (StgPrimCallOp _) = False ----------------- @@ -465,16 +458,16 @@ chooseReturnBndrs bndr (PrimAlt _) _alts = nonVoidIds [bndr] chooseReturnBndrs _bndr (UbxTupAlt _) [(_, ids, _, _)] - = nonVoidIds ids -- 'bndr' is not assigned! + = nonVoidIds ids -- 'bndr' is not assigned! chooseReturnBndrs bndr (AlgAlt _) _alts - = nonVoidIds [bndr] -- Only 'bndr' is assigned + = nonVoidIds [bndr] -- Only 'bndr' is assigned chooseReturnBndrs bndr PolyAlt _alts - = nonVoidIds [bndr] -- Only 'bndr' is assigned + = nonVoidIds [bndr] -- Only 'bndr' is assigned chooseReturnBndrs _ _ _ = panic "chooseReturnBndrs" - -- UbxTupALt has only one alternative + -- UbxTupALt has only one alternative ------------------------------------- cgAlts :: (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [StgAlt] @@ -485,26 +478,26 @@ cgAlts gc_plan _bndr PolyAlt [(_, _, _, rhs)] cgAlts gc_plan _bndr (UbxTupAlt _) [(_, _, _, rhs)] = maybeAltHeapCheck gc_plan (cgExpr rhs) - -- Here bndrs are *already* in scope, so don't rebind them + -- Here bndrs are *already* in scope, so don't rebind them cgAlts gc_plan bndr (PrimAlt _) alts = do { tagged_cmms <- cgAltRhss gc_plan bndr alts - ; let bndr_reg = CmmLocal (idToReg bndr) - (DEFAULT,deflt) = head tagged_cmms - -- PrimAlts always have a DEFAULT case - -- and it always comes first + ; let bndr_reg = CmmLocal (idToReg bndr) + (DEFAULT,deflt) = head tagged_cmms + -- PrimAlts always have a DEFAULT case + -- and it always comes first - tagged_cmms' = [(lit,code) - | (LitAlt lit, code) <- tagged_cmms] + tagged_cmms' = [(lit,code) + | (LitAlt lit, code) <- tagged_cmms] ; emitCmmLitSwitch (CmmReg bndr_reg) tagged_cmms' deflt ; return AssignedDirectly } cgAlts gc_plan bndr (AlgAlt tycon) alts = do { (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts - ; let fam_sz = tyConFamilySize tycon - bndr_reg = CmmLocal (idToReg bndr) + ; let fam_sz = tyConFamilySize tycon + bndr_reg = CmmLocal (idToReg bndr) -- Is the constructor tag in the node reg? ; if isSmallFamily fam_sz @@ -515,7 +508,7 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts emitSwitch tag_expr branches' mb_deflt 1 fam_sz return AssignedDirectly - else -- No, get tag from info table + else -- No, get tag from info table do dflags <- getDynFlags let -- Note that ptr _always_ has tag 1 -- when the family size is big enough @@ -525,7 +518,7 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts return AssignedDirectly } cgAlts _ _ _ _ = panic "cgAlts" - -- UbxTupAlt and PolyAlt have only one alternative + -- UbxTupAlt and PolyAlt have only one alternative -- Note [alg-alt heap check] @@ -577,9 +570,9 @@ cgAltRhss gc_plan bndr alts base_reg = idToReg bndr cg_alt :: StgAlt -> FCode (AltCon, CmmAGraph) cg_alt (con, bndrs, _uses, rhs) - = getCodeR $ + = getCodeR $ maybeAltHeapCheck gc_plan $ - do { _ <- bindConArgs con base_reg bndrs + do { _ <- bindConArgs con base_reg bndrs ; _ <- cgExpr rhs ; return con } @@ -591,37 +584,37 @@ maybeAltHeapCheck (GcInAlts regs, ReturnedTo lret off) code = altHeapCheckReturnsTo regs lret off code ----------------------------------------------------------------------------- --- Tail calls +-- Tail calls ----------------------------------------------------------------------------- cgConApp :: DataCon -> [StgArg] -> FCode ReturnKind cgConApp con stg_args - | isUnboxedTupleCon con -- Unboxed tuple: assign and return + | isUnboxedTupleCon con -- Unboxed tuple: assign and return = do { arg_exprs <- getNonVoidArgAmodes stg_args ; tickyUnboxedTupleReturn (length arg_exprs) ; emitReturn arg_exprs } - | otherwise -- Boxed constructors; allocate and return + | otherwise -- Boxed constructors; allocate and return = ASSERT( stg_args `lengthIs` dataConRepRepArity con ) do { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) currentCCS con stg_args - -- The first "con" says that the name bound to this closure is - -- is "con", which is a bit of a fudge, but it only affects profiling + -- The first "con" says that the name bound to this closure is + -- is "con", which is a bit of a fudge, but it only affects profiling ; emit =<< fcode_init - ; emitReturn [idInfoToAmode idinfo] } + ; emitReturn [idInfoToAmode idinfo] } cgIdApp :: Id -> [StgArg] -> FCode ReturnKind cgIdApp fun_id [] | isVoidId fun_id = emitReturn [] cgIdApp fun_id args - = do { fun_info <- getCgIdInfo fun_id + = do { fun_info <- getCgIdInfo fun_id ; case maybeLetNoEscape fun_info of Just (blk_id, lne_regs) -> cgLneJump blk_id lne_regs args Nothing -> cgTailCall fun_id fun_info args } cgLneJump :: BlockId -> [LocalReg] -> [StgArg] -> FCode ReturnKind -cgLneJump blk_id lne_regs args -- Join point; discard sequel +cgLneJump blk_id lne_regs args -- Join point; discard sequel = do { adjustHpBackwards -- always do this before a tail-call ; cmm_args <- getNonVoidArgAmodes args ; emitMultiAssign lne_regs cmm_args @@ -633,25 +626,25 @@ cgTailCall fun_id fun_info args = do dflags <- getDynFlags case (getCallMethod dflags fun_name (idCafInfo fun_id) lf_info (length args)) of - -- A value in WHNF, so we can just return it. - ReturnIt -> emitReturn [fun] -- ToDo: does ReturnIt guarantee tagged? + -- A value in WHNF, so we can just return it. + ReturnIt -> emitReturn [fun] -- ToDo: does ReturnIt guarantee tagged? - EnterIt -> ASSERT( null args ) -- Discarding arguments + EnterIt -> ASSERT( null args ) -- Discarding arguments emitEnter fun SlowCall -> do -- A slow function call via the RTS apply routines - { tickySlowCall lf_info args + { tickySlowCall lf_info args ; emitComment $ mkFastString "slowCall" - ; slowCall fun args } + ; slowCall fun args } - -- A direct function call (possibly with some left-over arguments) - DirectEntry lbl arity -> do - { tickyDirectCall arity args + -- A direct function call (possibly with some left-over arguments) + DirectEntry lbl arity -> do + { tickyDirectCall arity args ; if node_points dflags then directCall NativeNodeCall lbl arity (fun_arg:args) else directCall NativeDirectCall lbl arity args } - JumpToIt {} -> panic "cgTailCall" -- ??? + JumpToIt {} -> panic "cgTailCall" -- ??? where fun_arg = StgVarArg fun_id diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 13c8eccb9a..100d821cb0 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -6,58 +6,50 @@ -- ----------------------------------------------------------------------------- -{-# 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 --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module StgCmmUtils ( - cgLit, mkSimpleLit, - emitDataLits, mkDataLits, + cgLit, mkSimpleLit, + emitDataLits, mkDataLits, emitRODataLits, mkRODataLits, emitRtsCall, emitRtsCallWithResult, emitRtsCallGen, assignTemp, newTemp, - newUnboxedTupleRegs, + newUnboxedTupleRegs, emitMultiAssign, emitCmmLitSwitch, emitSwitch, - tagToClosure, mkTaggedObjectLoad, + tagToClosure, mkTaggedObjectLoad, callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr, - cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord, + cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord, cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord, - cmmOffsetExprW, cmmOffsetExprB, - cmmRegOffW, cmmRegOffB, - cmmLabelOffW, cmmLabelOffB, - cmmOffsetW, cmmOffsetB, - cmmOffsetLitW, cmmOffsetLitB, - cmmLoadIndexW, + cmmOffsetExprW, cmmOffsetExprB, + cmmRegOffW, cmmRegOffB, + cmmLabelOffW, cmmLabelOffB, + cmmOffsetW, cmmOffsetB, + cmmOffsetLitW, cmmOffsetLitB, + cmmLoadIndexW, cmmConstrTag, cmmConstrTag1, cmmUntag, cmmIsTagged, cmmGetTag, - addToMem, addToMemE, addToMemLbl, - mkWordCLit, - newStringCLit, newByteStringCLit, - packHalfWordsCLit, + addToMem, addToMemE, addToMemLbl, + mkWordCLit, + newStringCLit, newByteStringCLit, + packHalfWordsCLit, blankWord, srt_escape ) where #include "HsVersions.h" -#include "../includes/stg/HaskellMachRegs.h" import StgCmmMonad import StgCmmClosure import Cmm import BlockId import MkGraph -import CallerSaves +import CodeGen.Platform import CLabel import CmmUtils @@ -76,6 +68,7 @@ import Unique import DynFlags import FastString import Outputable +import Platform import Data.Char import Data.List @@ -86,7 +79,7 @@ import Data.Maybe ------------------------------------------------------------------------- -- --- Literals +-- Literals -- ------------------------------------------------------------------------- @@ -100,11 +93,11 @@ mkLtOp :: Literal -> MachOp mkLtOp (MachInt _) = MO_S_Lt wordWidth mkLtOp (MachFloat _) = MO_F_Lt W32 mkLtOp (MachDouble _) = MO_F_Lt W64 -mkLtOp lit = MO_U_Lt (typeWidth (cmmLitType (mkSimpleLit lit))) - -- ToDo: seems terribly indirect! +mkLtOp lit = MO_U_Lt (typeWidth (cmmLitType (mkSimpleLit lit))) + -- ToDo: seems terribly indirect! mkSimpleLit :: Literal -> CmmLit -mkSimpleLit (MachChar c) = CmmInt (fromIntegral (ord c)) wordWidth +mkSimpleLit (MachChar c) = CmmInt (fromIntegral (ord c)) wordWidth mkSimpleLit MachNullAddr = zeroCLit mkSimpleLit (MachInt i) = CmmInt i wordWidth mkSimpleLit (MachInt64 i) = CmmInt i W64 @@ -112,12 +105,12 @@ mkSimpleLit (MachWord i) = CmmInt i wordWidth mkSimpleLit (MachWord64 i) = CmmInt i W64 mkSimpleLit (MachFloat r) = CmmFloat r W32 mkSimpleLit (MachDouble r) = CmmFloat r W64 -mkSimpleLit (MachLabel fs ms fod) - = CmmLabel (mkForeignLabel fs ms labelSrc fod) - where - -- TODO: Literal labels might not actually be in the current package... - labelSrc = ForeignLabelInThisPackage -mkSimpleLit other = pprPanic "mkSimpleLit" (ppr other) +mkSimpleLit (MachLabel fs ms fod) + = CmmLabel (mkForeignLabel fs ms labelSrc fod) + where + -- TODO: Literal labels might not actually be in the current package... + labelSrc = ForeignLabelInThisPackage +mkSimpleLit other = pprPanic "mkSimpleLit" (ppr other) -------------------------------------------------------------------------- -- @@ -128,40 +121,40 @@ mkSimpleLit other = pprPanic "mkSimpleLit" (ppr other) addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n -addToMem :: CmmType -- rep of the counter - -> CmmExpr -- Address - -> Int -- What to add (a word) - -> CmmAGraph +addToMem :: CmmType -- rep of the counter + -> CmmExpr -- Address + -> Int -- What to add (a word) + -> CmmAGraph addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep))) -addToMemE :: CmmType -- rep of the counter - -> CmmExpr -- Address - -> CmmExpr -- What to add (a word-typed expression) - -> CmmAGraph +addToMemE :: CmmType -- rep of the counter + -> CmmExpr -- Address + -> CmmExpr -- What to add (a word-typed expression) + -> CmmAGraph addToMemE rep ptr n = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep, n]) ------------------------------------------------------------------------- -- --- Loading a field from an object, --- where the object pointer is itself tagged +-- Loading a field from an object, +-- where the object pointer is itself tagged -- ------------------------------------------------------------------------- mkTaggedObjectLoad :: LocalReg -> LocalReg -> WordOff -> DynTag -> CmmAGraph -- (loadTaggedObjectField reg base off tag) generates assignment --- reg = bitsK[ base + off - tag ] +-- reg = bitsK[ base + off - tag ] -- where K is fixed by 'reg' mkTaggedObjectLoad reg base offset tag - = mkAssign (CmmLocal reg) - (CmmLoad (cmmOffsetB (CmmReg (CmmLocal base)) - (wORD_SIZE*offset - tag)) + = mkAssign (CmmLocal reg) + (CmmLoad (cmmOffsetB (CmmReg (CmmLocal base)) + (wORD_SIZE*offset - tag)) (localRegType reg)) ------------------------------------------------------------------------- -- --- Converting a closure tag to a closure for enumeration types +-- Converting a closure tag to a closure for enumeration types -- (this is the implementation of tagToEnum#). -- ------------------------------------------------------------------------- @@ -170,11 +163,11 @@ tagToClosure :: TyCon -> CmmExpr -> CmmExpr tagToClosure tycon tag = CmmLoad (cmmOffsetExprW closure_tbl tag) bWord where closure_tbl = CmmLit (CmmLabel lbl) - lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs + lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs ------------------------------------------------------------------------- -- --- Conditionals and rts calls +-- Conditionals and rts calls -- ------------------------------------------------------------------------- @@ -182,7 +175,7 @@ emitRtsCall :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCo emitRtsCall pkg fun args safe = emitRtsCallGen [] pkg fun args safe emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageId -> FastString - -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () + -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () emitRtsCallWithResult res hint pkg fun args safe = emitRtsCallGen [(res,hint)] pkg fun args safe @@ -215,7 +208,7 @@ emitRtsCallGen res pkg fun args safe ----------------------------------------------------------------------------- -- --- Caller-Save Registers +-- Caller-Save Registers -- ----------------------------------------------------------------------------- @@ -252,45 +245,44 @@ callerSaveVolatileRegs dflags = (caller_save, caller_load) caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save) system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery - {- ,SparkHd,SparkTl,SparkBase,SparkLim -} - , BaseReg ] + {- ,SparkHd,SparkTl,SparkBase,SparkLim -} + , BaseReg ] regs_to_save = filter (callerSaves platform) system_regs callerSaveGlobalReg reg - = mkStore (get_GlobalReg_addr reg) (CmmReg (CmmGlobal reg)) + = mkStore (get_GlobalReg_addr platform reg) (CmmReg (CmmGlobal reg)) callerRestoreGlobalReg reg - = mkAssign (CmmGlobal reg) - (CmmLoad (get_GlobalReg_addr reg) (globalRegType reg)) + = mkAssign (CmmGlobal reg) + (CmmLoad (get_GlobalReg_addr platform reg) (globalRegType reg)) -- ----------------------------------------------------------------------------- -- Global registers -- 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 +-- a GlobalReg, get_GlobalReg_addr always produces the -- register table address for it. -- (See also get_GlobalReg_reg_or_addr in MachRegs) -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. regTableOffset :: Int -> CmmExpr -regTableOffset n = +regTableOffset n = CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n)) -get_Regtable_addr_from_offset :: CmmType -> Int -> CmmExpr -get_Regtable_addr_from_offset _rep 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 _rep offset = + if haveRegBase platform + then CmmRegOff (CmmGlobal BaseReg) offset + else regTableOffset offset -- ----------------------------------------------------------------------------- @@ -298,22 +290,22 @@ get_Regtable_addr_from_offset _rep offset = baseRegOffset :: GlobalReg -> Int -baseRegOffset Sp = oFFSET_StgRegTable_rSp -baseRegOffset SpLim = oFFSET_StgRegTable_rSpLim +baseRegOffset Sp = oFFSET_StgRegTable_rSp +baseRegOffset SpLim = oFFSET_StgRegTable_rSpLim baseRegOffset (LongReg 1) = oFFSET_StgRegTable_rL1 -baseRegOffset Hp = oFFSET_StgRegTable_rHp -baseRegOffset HpLim = oFFSET_StgRegTable_rHpLim +baseRegOffset Hp = oFFSET_StgRegTable_rHp +baseRegOffset HpLim = oFFSET_StgRegTable_rHpLim baseRegOffset CCCS = oFFSET_StgRegTable_rCCCS baseRegOffset CurrentTSO = oFFSET_StgRegTable_rCurrentTSO -baseRegOffset CurrentNursery = oFFSET_StgRegTable_rCurrentNursery -baseRegOffset HpAlloc = oFFSET_StgRegTable_rHpAlloc -baseRegOffset GCEnter1 = oFFSET_stgGCEnter1 -baseRegOffset GCFun = oFFSET_stgGCFun -baseRegOffset reg = pprPanic "baseRegOffset:" (ppr reg) +baseRegOffset CurrentNursery = oFFSET_StgRegTable_rCurrentNursery +baseRegOffset HpAlloc = oFFSET_StgRegTable_rHpAlloc +baseRegOffset GCEnter1 = oFFSET_stgGCEnter1 +baseRegOffset GCFun = oFFSET_stgGCFun +baseRegOffset reg = pprPanic "baseRegOffset:" (ppr reg) ------------------------------------------------------------------------- -- --- Strings generate a top-level data block +-- Strings generate a top-level data block -- ------------------------------------------------------------------------- @@ -332,14 +324,14 @@ newStringCLit str = newByteStringCLit (map (fromIntegral . ord) str) newByteStringCLit :: [Word8] -> FCode CmmLit newByteStringCLit bytes - = do { uniq <- newUnique - ; let (lit, decl) = mkByteStringCLit uniq bytes - ; emitDecl decl - ; return lit } + = do { uniq <- newUnique + ; let (lit, decl) = mkByteStringCLit uniq bytes + ; emitDecl decl + ; return lit } ------------------------------------------------------------------------- -- --- Assigning expressions to temporaries +-- Assigning expressions to temporaries -- ------------------------------------------------------------------------- @@ -353,31 +345,31 @@ assignTemp :: CmmExpr -> FCode LocalReg -- the optimization pass doesn't have to do as much work) assignTemp (CmmReg (CmmLocal reg)) = return reg assignTemp e = do { uniq <- newUnique - ; let reg = LocalReg uniq (cmmExprType e) + ; let reg = LocalReg uniq (cmmExprType e) ; emitAssign (CmmLocal reg) e - ; return reg } + ; return reg } newTemp :: CmmType -> FCode LocalReg newTemp rep = do { uniq <- newUnique - ; return (LocalReg uniq rep) } + ; return (LocalReg uniq rep) } newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint]) -- Choose suitable local regs to use for the components --- of an unboxed tuple that we are about to return to +-- of an unboxed tuple that we are about to return to -- the Sequel. If the Sequel is a join point, using the -- regs it wants will save later assignments. -newUnboxedTupleRegs res_ty +newUnboxedTupleRegs res_ty = ASSERT( isUnboxedTupleType res_ty ) - do { sequel <- getSequel - ; regs <- choose_regs sequel - ; ASSERT( regs `equalLength` reps ) - return (regs, map primRepForeignHint reps) } + do { sequel <- getSequel + ; regs <- choose_regs sequel + ; ASSERT( regs `equalLength` reps ) + return (regs, map primRepForeignHint reps) } where UbxTupleRep ty_args = repType res_ty reps = [ rep - | ty <- ty_args - , let rep = typePrimRep ty - , not (isVoidRep rep) ] + | ty <- ty_args + , let rep = typePrimRep ty + , not (isVoidRep rep) ] choose_regs (AssignTo regs _) = return regs choose_regs _other = mapM (newTemp . primRepCmmType) reps @@ -392,15 +384,15 @@ emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode () -- input simultaneously, using temporary variables when necessary. type Key = Int -type Vrtx = (Key, Stmt) -- Give each vertex a unique number, - -- for fast comparison -type Stmt = (LocalReg, CmmExpr) -- r := e +type Vrtx = (Key, Stmt) -- Give each vertex a unique number, + -- for fast comparison +type Stmt = (LocalReg, CmmExpr) -- r := e -- We use the strongly-connected component algorithm, in which --- * the vertices are the statements --- * an edge goes from s1 to s2 iff --- s1 assigns to something s2 uses --- that is, if s1 should *follow* s2 in the final order +-- * the vertices are the statements +-- * an edge goes from s1 to s2 iff +-- s1 assigns to something s2 uses +-- that is, if s1 should *follow* s2 in the final order emitMultiAssign [] [] = return () emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs @@ -410,39 +402,39 @@ emitMultiAssign regs rhss = ASSERT( equalLength regs rhss ) unscramble :: [Vrtx] -> FCode () unscramble vertices = mapM_ do_component components where - edges :: [ (Vrtx, Key, [Key]) ] - edges = [ (vertex, key1, edges_from stmt1) - | vertex@(key1, stmt1) <- vertices ] + edges :: [ (Vrtx, Key, [Key]) ] + edges = [ (vertex, key1, edges_from stmt1) + | vertex@(key1, stmt1) <- vertices ] - edges_from :: Stmt -> [Key] - edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices, - stmt1 `mustFollow` stmt2 ] + edges_from :: Stmt -> [Key] + edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices, + stmt1 `mustFollow` stmt2 ] - components :: [SCC Vrtx] - components = stronglyConnCompFromEdgedVertices edges + components :: [SCC Vrtx] + components = stronglyConnCompFromEdgedVertices edges - -- do_components deal with one strongly-connected component - -- Not cyclic, or singleton? Just do it + -- do_components deal with one strongly-connected component + -- Not cyclic, or singleton? Just do it do_component :: SCC Vrtx -> FCode () do_component (AcyclicSCC (_,stmt)) = mk_graph stmt - do_component (CyclicSCC []) = panic "do_component" - do_component (CyclicSCC [(_,stmt)]) = mk_graph stmt + do_component (CyclicSCC []) = panic "do_component" + do_component (CyclicSCC [(_,stmt)]) = mk_graph stmt - -- Cyclic? Then go via temporaries. Pick one to - -- break the loop and try again with the rest. + -- Cyclic? Then go via temporaries. Pick one to + -- break the loop and try again with the rest. do_component (CyclicSCC ((_,first_stmt) : rest)) = do u <- newUnique - let (to_tmp, from_tmp) = split u first_stmt + let (to_tmp, from_tmp) = split u first_stmt mk_graph to_tmp unscramble rest mk_graph from_tmp - split :: Unique -> Stmt -> (Stmt, Stmt) - split uniq (reg, rhs) - = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp))) - where - rep = cmmExprType rhs - tmp = LocalReg uniq rep + split :: Unique -> Stmt -> (Stmt, Stmt) + split uniq (reg, rhs) + = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp))) + where + rep = cmmExprType rhs + tmp = LocalReg uniq rep mk_graph :: Stmt -> FCode () mk_graph (reg, rhs) = emitAssign (CmmLocal reg) rhs @@ -451,30 +443,31 @@ mustFollow :: Stmt -> Stmt -> Bool (reg, _) `mustFollow` (_, rhs) = CmmLocal reg `regUsedIn` rhs ------------------------------------------------------------------------- --- mkSwitch +-- mkSwitch ------------------------------------------------------------------------- -emitSwitch :: CmmExpr -- Tag to switch on - -> [(ConTagZ, CmmAGraph)] -- Tagged branches - -> Maybe CmmAGraph -- Default branch (if any) - -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour - -- outside this range is undefined - -> FCode () +emitSwitch :: CmmExpr -- Tag to switch on + -> [(ConTagZ, CmmAGraph)] -- Tagged branches + -> Maybe CmmAGraph -- Default branch (if any) + -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour + -- outside this range is undefined + -> FCode () emitSwitch tag_expr branches mb_deflt lo_tag hi_tag - = do { dflags <- getDynFlags + = do { dflags <- getDynFlags ; mkCmmSwitch (via_C dflags) tag_expr branches mb_deflt lo_tag hi_tag } where via_C dflags | HscC <- hscTarget dflags = True - | otherwise = False + | otherwise = False -mkCmmSwitch :: Bool -- True <=> never generate a conditional tree - -> CmmExpr -- Tag to switch on - -> [(ConTagZ, CmmAGraph)] -- Tagged branches - -> Maybe CmmAGraph -- Default branch (if any) - -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour - -- outside this range is undefined +mkCmmSwitch :: Bool -- True <=> never generate a + -- conditional tree + -> CmmExpr -- Tag to switch on + -> [(ConTagZ, CmmAGraph)] -- Tagged branches + -> Maybe CmmAGraph -- Default branch (if any) + -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour + -- outside this range is undefined -> FCode () -- First, two rather common cases in which there is no work to do @@ -487,7 +480,7 @@ mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag = do mb_deflt_lbl <- label_default join_lbl mb_deflt branches_lbls <- label_branches join_lbl branches tag_expr' <- assignTemp' tag_expr - + emit =<< mk_switch tag_expr' (sortBy (comparing fst) branches_lbls) mb_deflt_lbl lo_tag hi_tag via_C @@ -496,8 +489,8 @@ mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag = do emitLabel join_lbl mk_switch :: CmmExpr -> [(ConTagZ, BlockId)] - -> Maybe BlockId - -> ConTagZ -> ConTagZ -> Bool + -> Maybe BlockId + -> ConTagZ -> ConTagZ -> Bool -> FCode CmmAGraph -- SINGLETON TAG RANGE: no case analysis to do @@ -509,19 +502,19 @@ mk_switch _tag_expr [(tag, lbl)] _ lo_tag hi_tag _via_C -- SINGLETON BRANCH, NO DEFAULT: no case analysis to do mk_switch _tag_expr [(_tag,lbl)] Nothing _ _ _ = return (mkBranch lbl) - -- The simplifier might have eliminated a case - -- so we may have e.g. case xs of - -- [] -> e - -- In that situation we can be sure the (:) case - -- can't happen, so no need to test + -- The simplifier might have eliminated a case + -- so we may have e.g. case xs of + -- [] -> e + -- In that situation we can be sure the (:) case + -- can't happen, so no need to test -- SINGLETON BRANCH: one equality check to do mk_switch tag_expr [(tag,lbl)] (Just deflt) _ _ _ = return (mkCbranch cond deflt lbl) where cond = cmmNeWord tag_expr (CmmLit (mkIntCLit tag)) - -- We have lo_tag < hi_tag, but there's only one branch, - -- so there must be a default + -- We have lo_tag < hi_tag, but there's only one branch, + -- so there must be a default -- ToDo: we might want to check for the two branch case, where one of -- the branches is the tag 0, because comparing '== 0' is likely to be @@ -537,18 +530,18 @@ mk_switch tag_expr [(tag,lbl)] (Just deflt) _ _ _ -- time works around that problem. -- mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C - | use_switch -- Use a switch - = let - find_branch :: ConTagZ -> Maybe BlockId - find_branch i = case (assocMaybe branches i) of - Just lbl -> Just lbl - Nothing -> mb_deflt - - -- NB. we have eliminated impossible branches at - -- either end of the range (see below), so the first - -- tag of a real branch is real_lo_tag (not lo_tag). - arms :: [Maybe BlockId] - arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]] + | use_switch -- Use a switch + = let + find_branch :: ConTagZ -> Maybe BlockId + find_branch i = case (assocMaybe branches i) of + Just lbl -> Just lbl + Nothing -> mb_deflt + + -- NB. we have eliminated impossible branches at + -- either end of the range (see below), so the first + -- tag of a real branch is real_lo_tag (not lo_tag). + arms :: [Maybe BlockId] + arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]] in return (mkSwitch (cmmOffset tag_expr (- real_lo_tag)) arms) @@ -557,86 +550,86 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C = do stmts <- mk_switch tag_expr branches mb_deflt lowest_branch hi_tag via_C mkCmmIfThenElse - (cmmULtWord tag_expr (CmmLit (mkIntCLit lowest_branch))) - (mkBranch deflt) + (cmmULtWord tag_expr (CmmLit (mkIntCLit lowest_branch))) + (mkBranch deflt) stmts | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches = do stmts <- mk_switch tag_expr branches mb_deflt lo_tag highest_branch via_C mkCmmIfThenElse - (cmmUGtWord tag_expr (CmmLit (mkIntCLit highest_branch))) - (mkBranch deflt) + (cmmUGtWord tag_expr (CmmLit (mkIntCLit highest_branch))) + (mkBranch deflt) stmts - | otherwise -- Use an if-tree + | otherwise -- Use an if-tree = do lo_stmts <- mk_switch tag_expr lo_branches mb_deflt lo_tag (mid_tag-1) via_C hi_stmts <- mk_switch tag_expr hi_branches mb_deflt mid_tag hi_tag via_C mkCmmIfThenElse - (cmmUGeWord tag_expr (CmmLit (mkIntCLit mid_tag))) + (cmmUGeWord tag_expr (CmmLit (mkIntCLit mid_tag))) hi_stmts lo_stmts - -- we test (e >= mid_tag) rather than (e < mid_tag), because - -- the former works better when e is a comparison, and there - -- are two tags 0 & 1 (mid_tag == 1). In this case, the code - -- generator can reduce the condition to e itself without - -- having to reverse the sense of the comparison: comparisons - -- can't always be easily reversed (eg. floating - -- pt. comparisons). + -- we test (e >= mid_tag) rather than (e < mid_tag), because + -- the former works better when e is a comparison, and there + -- are two tags 0 & 1 (mid_tag == 1). In this case, the code + -- generator can reduce the condition to e itself without + -- having to reverse the sense of the comparison: comparisons + -- can't always be easily reversed (eg. floating + -- pt. comparisons). where - use_switch = {- pprTrace "mk_switch" ( - ppr tag_expr <+> text "n_tags:" <+> int n_tags <+> + use_switch = {- pprTrace "mk_switch" ( + ppr tag_expr <+> text "n_tags:" <+> int n_tags <+> text "branches:" <+> ppr (map fst branches) <+> - text "n_branches:" <+> int n_branches <+> - text "lo_tag:" <+> int lo_tag <+> - text "hi_tag:" <+> int hi_tag <+> - text "real_lo_tag:" <+> int real_lo_tag <+> - text "real_hi_tag:" <+> int real_hi_tag) $ -} - ASSERT( n_branches > 1 && n_tags > 1 ) - n_tags > 2 && (via_C || (dense && big_enough)) - -- up to 4 branches we use a decision tree, otherwise + text "n_branches:" <+> int n_branches <+> + text "lo_tag:" <+> int lo_tag <+> + text "hi_tag:" <+> int hi_tag <+> + text "real_lo_tag:" <+> int real_lo_tag <+> + text "real_hi_tag:" <+> int real_hi_tag) $ -} + ASSERT( n_branches > 1 && n_tags > 1 ) + n_tags > 2 && (via_C || (dense && big_enough)) + -- up to 4 branches we use a decision tree, otherwise -- a switch (== jump table in the NCG). This seems to be -- optimal, and corresponds with what gcc does. - big_enough = n_branches > 4 - dense = n_branches > (n_tags `div` 2) + big_enough = n_branches > 4 + dense = n_branches > (n_tags `div` 2) n_branches = length branches - - -- ignore default slots at each end of the range if there's + + -- ignore default slots at each end of the range if there's -- no default branch defined. lowest_branch = fst (head branches) highest_branch = fst (last branches) real_lo_tag - | isNothing mb_deflt = lowest_branch - | otherwise = lo_tag + | isNothing mb_deflt = lowest_branch + | otherwise = lo_tag real_hi_tag - | isNothing mb_deflt = highest_branch - | otherwise = hi_tag + | isNothing mb_deflt = highest_branch + | otherwise = hi_tag n_tags = real_hi_tag - real_lo_tag + 1 - -- INVARIANT: Provided hi_tag > lo_tag (which is true) - -- lo_tag <= mid_tag < hi_tag - -- lo_branches have tags < mid_tag - -- hi_branches have tags >= mid_tag + -- INVARIANT: Provided hi_tag > lo_tag (which is true) + -- lo_tag <= mid_tag < hi_tag + -- lo_branches have tags < mid_tag + -- hi_branches have tags >= mid_tag (mid_tag,_) = branches !! (n_branches `div` 2) - -- 2 branches => n_branches `div` 2 = 1 - -- => branches !! 1 give the *second* tag - -- There are always at least 2 branches here + -- 2 branches => n_branches `div` 2 = 1 + -- => branches !! 1 give the *second* tag + -- There are always at least 2 branches here (lo_branches, hi_branches) = span is_lo branches is_lo (t,_) = t < mid_tag -------------- emitCmmLitSwitch :: CmmExpr -- Tag to switch on - -> [(Literal, CmmAGraph)] -- Tagged branches - -> CmmAGraph -- Default branch (always) + -> [(Literal, CmmAGraph)] -- Tagged branches + -> CmmAGraph -- Default branch (always) -> FCode () -- Emit the code --- Used for general literals, whose size might not be a word, +-- Used for general literals, whose size might not be a word, -- where there is always a default case, and where we don't know -- the range of values for certain. For simplicity we always generate a tree. -- @@ -652,10 +645,10 @@ emitCmmLitSwitch scrut branches deflt = do (sortBy (comparing fst) branches_lbls) emitLabel join_lbl -mk_lit_switch :: CmmExpr -> BlockId - -> [(Literal,BlockId)] +mk_lit_switch :: CmmExpr -> BlockId + -> [(Literal,BlockId)] -> FCode CmmAGraph -mk_lit_switch scrut deflt [(lit,blk)] +mk_lit_switch scrut deflt [(lit,blk)] = return (mkCbranch (CmmMachOp ne [scrut, CmmLit cmm_lit]) deflt blk) where cmm_lit = mkSimpleLit lit @@ -670,13 +663,13 @@ mk_lit_switch scrut deflt_blk_id branches where n_branches = length branches (mid_lit,_) = branches !! (n_branches `div` 2) - -- See notes above re mid_tag + -- See notes above re mid_tag (lo_branches, hi_branches) = span is_lo branches is_lo (t,_) = t < mid_lit - cond = CmmMachOp (mkLtOp mid_lit) - [scrut, CmmLit (mkSimpleLit mid_lit)] + cond = CmmMachOp (mkLtOp mid_lit) + [scrut, CmmLit (mkSimpleLit mid_lit)] -------------- @@ -699,7 +692,7 @@ label_branches join_lbl ((tag,code):branches) -------------- label_code :: BlockId -> CmmAGraph -> FCode BlockId -- label_code J code --- generates +-- generates -- [L: code; goto J] -- and returns L label_code join_lbl code = do diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index d3fbe4cf47..34500bb109 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -89,6 +89,12 @@ addTicksToBinds dflags mod mod_loc exports tyCons binds = | tyCon <- tyCons ] , density = mkDensity dflags , this_mod = mod + , tickishType = case hscTarget dflags of + HscInterpreted -> Breakpoints + _ | opt_Hpc -> HpcTicks + | dopt Opt_SccProfilingOn dflags + -> ProfNotes + | otherwise -> error "addTicksToBinds: No way to annotate!" }) (TT { tickBoxCount = 0 @@ -910,10 +916,21 @@ data TickTransEnv = TTE { fileName :: FastString , inScope :: VarSet , blackList :: Map SrcSpan () , this_mod :: Module + , tickishType :: TickishType } -- deriving Show +data TickishType = ProfNotes | HpcTicks | Breakpoints + + +-- | Tickishs that only make sense when their source code location +-- refers to the current file. This might not always be true due to +-- LINE pragmas in the code - which would confuse at least HPC. +tickSameFileOnly :: TickishType -> Bool +tickSameFileOnly HpcTicks = True +tickSameFileOnly _other = False + type FreeVars = OccEnv Id noFVs :: FreeVars noFVs = emptyOccEnv @@ -982,13 +999,22 @@ getPathEntry = declPath `liftM` getEnv getFileName :: TM FastString getFileName = fileName `liftM` getEnv -sameFileName :: SrcSpan -> TM a -> TM a -> TM a -sameFileName pos out_of_scope in_scope = do +isGoodSrcSpan' :: SrcSpan -> Bool +isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos +isGoodSrcSpan' (UnhelpfulSpan _) = False + +isGoodTickSrcSpan :: SrcSpan -> TM Bool +isGoodTickSrcSpan pos = do file_name <- getFileName - case srcSpanFileName_maybe pos of - Just file_name2 - | file_name == file_name2 -> in_scope - _ -> out_of_scope + tickish <- tickishType `liftM` getEnv + let need_same_file = tickSameFileOnly tickish + same_file = Just file_name == srcSpanFileName_maybe pos + return (isGoodSrcSpan' pos && (not need_same_file || same_file)) + +ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a +ifGoodTickSrcSpan pos then_code else_code = do + good <- isGoodTickSrcSpan pos + if good then then_code else else_code bindLocals :: [Id] -> TM a -> TM a bindLocals new_ids (TM m) @@ -1007,23 +1033,23 @@ isBlackListed pos = TM $ \ env st -> -- expression argument to support nested box allocations allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr Id) -> TM (LHsExpr Id) -allocTickBox boxLabel countEntries topOnly pos m | isGoodSrcSpan' pos = - sameFileName pos (do e <- m; return (L pos e)) $ do +allocTickBox boxLabel countEntries topOnly pos m = + ifGoodTickSrcSpan pos (do (fvs, e) <- getFreeVars m env <- getEnv tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env) return (L pos (HsTick tickish (L pos e))) -allocTickBox _boxLabel _countEntries _topOnly pos m = do - e <- m - return (L pos e) - + ) (do + e <- m + return (L pos e) + ) -- the tick application inherits the source position of its -- expression argument to support nested box allocations allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id)) -allocATickBox boxLabel countEntries topOnly pos fvs | isGoodSrcSpan' pos = - sameFileName pos (return Nothing) $ do +allocATickBox boxLabel countEntries topOnly pos fvs = + ifGoodTickSrcSpan pos (do let mydecl_path = case boxLabel of TopLevelBox x -> x @@ -1031,8 +1057,7 @@ allocATickBox boxLabel countEntries topOnly pos fvs | isGoodSrcSpan' pos = _ -> panic "allocATickBox" tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path return (Just tickish) -allocATickBox _boxLabel _countEntries _topOnly _pos _fvs = - return Nothing + ) (return Nothing) mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String] @@ -1059,10 +1084,10 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = count = countEntries && dopt Opt_ProfCountEntries dflags - tickish - | opt_Hpc = HpcTick (this_mod env) c - | dopt Opt_SccProfilingOn dflags = ProfNote cc count True{-scopes-} - | otherwise = Breakpoint c ids + tickish = case tickishType env of + HpcTicks -> HpcTick (this_mod env) c + ProfNotes -> ProfNote cc count True{-scopes-} + Breakpoints -> Breakpoint c ids in ( tickish , fvs @@ -1072,11 +1097,18 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr Id) -> TM (LHsExpr Id) -allocBinTickBox boxLabel pos m - | not opt_Hpc = allocTickBox (ExpBox False) False False pos m - | isGoodSrcSpan' pos = - do - e <- m +allocBinTickBox boxLabel pos m = do + env <- getEnv + case tickishType env of + HpcTicks -> do e <- liftM (L pos) m + ifGoodTickSrcSpan pos + (mkBinTickBoxHpc boxLabel pos e) + (return e) + _other -> allocTickBox (ExpBox False) False False pos m + +mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr Id + -> TM (LHsExpr Id) +mkBinTickBoxHpc boxLabel pos e = TM $ \ env st -> let meT = (pos,declPath env, [],boxLabel True) meF = (pos,declPath env, [],boxLabel False) @@ -1084,18 +1116,13 @@ allocBinTickBox boxLabel pos m c = tickBoxCount st mes = mixEntries st in - ( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) (L pos e) + ( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) e -- notice that F and T are reversed, -- because we are building the list in -- reverse... , noFVs , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes} ) -allocBinTickBox _boxLabel pos m = do e <- m; return (L pos e) - -isGoodSrcSpan' :: SrcSpan -> Bool -isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos -isGoodSrcSpan' (UnhelpfulSpan _) = False mkHpcPos :: SrcSpan -> HpcPos mkHpcPos pos@(RealSrcSpan s) diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 9eaa0ef1de..12ed631f0f 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -200,7 +200,14 @@ Library PprCmmDecl PprCmmExpr Bitmap - CallerSaves + CodeGen.Platform + CodeGen.Platform.ARM + CodeGen.Platform.NoRegs + CodeGen.Platform.PPC + CodeGen.Platform.PPC_Darwin + CodeGen.Platform.SPARC + CodeGen.Platform.X86 + CodeGen.Platform.X86_64 CgBindery CgCallConv CgCase diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index c94b19a255..93ca3853e2 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1782,10 +1782,9 @@ coreRuleToIfaceRule mod rule@(Rule { ru_name = name, ru_fn = fn, -- level. Reason: so that when we read it back in we'll -- construct the same ru_rough field as we have right now; -- see tcIfaceRule - do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty)) - do_arg (Coercion co) = IfaceType (coToIfaceType co) - - do_arg arg = toIfaceExpr arg + do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty)) + do_arg (Coercion co) = IfaceCo (coToIfaceType co) + do_arg arg = toIfaceExpr arg -- Compute orphanhood. See Note [Orphans] in IfaceSyn -- A rule is an orphan only if none of the variables diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index a813433f64..2ff1ed9829 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -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]) diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index a9dfebb868..d9a43fb249 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -85,8 +85,8 @@ widthToLlvmInt w = LMInt $ widthInBits w -- | GHC Call Convention for LLVM llvmGhcCC :: DynFlags -> LlvmCallConvention llvmGhcCC dflags - | platformUnregisterised (targetPlatform dflags) = CC_Ncc 10 - | otherwise = CC_Ccc + | platformUnregisterised (targetPlatform dflags) = CC_Ccc + | otherwise = CC_Ncc 10 -- | Llvm Function type for Cmm function llvmFunTy :: DynFlags -> LlvmType @@ -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] diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 25152a9c65..7f80cab617 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -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 diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 3bed3d0cd9..fe158460cb 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -1489,12 +1489,7 @@ mkExtraObj dflags extn xs -- mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath mkExtraObjToLinkIntoBinary dflags = do - let have_rts_opts_flags = - isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of - RtsOptsSafeOnly -> False - _ -> True - - when (dopt Opt_NoHsMain dflags && have_rts_opts_flags) $ do + when (dopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do log_action dflags dflags SevInfo noSrcSpan defaultUserStyle (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$ text " Call hs_init_ghc() from your main() function to set these options.") @@ -1881,7 +1876,13 @@ maybeCreateManifest dflags exe_filename linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO () -linkDynLib dflags o_files dep_packages = do +linkDynLib dflags o_files dep_packages + = do + when (haveRtsOptsFlags dflags) $ do + log_action dflags dflags SevInfo noSrcSpan defaultUserStyle + (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$ + text " Call hs_init_ghc() from your main() function to set these options.") + let verbFlags = getVerbFlags dflags let o_file = outputFile dflags @@ -2146,3 +2147,8 @@ touchObjectFile dflags path = do createDirectoryIfMissing True $ takeDirectory path SysTools.touch dflags "Touching object file" path +haveRtsOptsFlags :: DynFlags -> Bool +haveRtsOptsFlags dflags = + isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of + RtsOptsSafeOnly -> False + _ -> True diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index bedb30002a..b1cc786840 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -91,6 +91,7 @@ module GHC ( findModule, lookupModule, #ifdef GHCI isModuleTrusted, + moduleTrustReqs, setContext, getContext, getNamesInScope, getRdrNamesInScope, @@ -1335,6 +1336,11 @@ isModuleTrusted :: GhcMonad m => Module -> m Bool isModuleTrusted m = withSession $ \hsc_env -> liftIO $ hscCheckSafe hsc_env m noSrcSpan +-- | Return if a module is trusted and the pkgs it depends on to be trusted. +moduleTrustReqs :: GhcMonad m => Module -> m (Bool, [PackageId]) +moduleTrustReqs m = withSession $ \hsc_env -> + liftIO $ hscGetSafe hsc_env m noSrcSpan + -- | EXPERIMENTAL: DO NOT USE. -- -- Set the monad GHCi lifts user statements into. diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 70b7d063b7..22684126c2 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -61,6 +61,7 @@ module HscMain , hscTcRcLookupName , hscTcRnGetInfo , hscCheckSafe + , hscGetSafe #ifdef GHCI , hscIsGHCiMonad , hscGetModuleInterface @@ -1023,6 +1024,21 @@ hscCheckSafe hsc_env m l = runHsc hsc_env $ do errs <- getWarnings return $ isEmptyBag errs +-- | Return if a module is trusted and the pkgs it depends on to be trusted. +hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, [PackageId]) +hscGetSafe hsc_env m l = runHsc hsc_env $ do + dflags <- getDynFlags + (self, pkgs) <- hscCheckSafe' dflags m l + good <- isEmptyBag `fmap` getWarnings + clearWarnings -- don't want them printed... + let pkgs' | Just p <- self = p:pkgs + | otherwise = pkgs + return (good, pkgs') + +-- | Is a module trusted? If not, throw or log errors depending on the type. +-- Return (regardless of trusted or not) if the trust type requires the modules +-- own package be trusted and a list of other packages required to be trusted +-- (these later ones haven't been checked) but the own package trust has been. hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe PackageId, [PackageId]) hscCheckSafe' dflags m l = do (tw, pkgs) <- isModSafe m l @@ -1031,10 +1047,6 @@ hscCheckSafe' dflags m l = do True | isHomePkg m -> return (Nothing, pkgs) | otherwise -> return (Just $ modulePackageId m, pkgs) where - -- Is a module trusted? If not, throw or log errors depending on the type. - -- Return (regardless of trusted or not) if the trust type requires the - -- modules own package be trusted and a list of other packages required to - -- be trusted (these later ones haven't been checked) isModSafe :: Module -> SrcSpan -> Hsc (Bool, [PackageId]) isModSafe m l = do iface <- lookup' m @@ -1045,7 +1057,7 @@ hscCheckSafe' dflags m l = do <> text ", to check that it can be safely imported" -- got iface, check trust - Just iface' -> do + Just iface' -> let trust = getSafeMode $ mi_trust iface' trust_own_pkg = mi_trust_pkg iface' -- check module is trusted @@ -1054,15 +1066,17 @@ hscCheckSafe' dflags m l = do safeP = packageTrusted trust trust_own_pkg m -- pkg trust reqs pkgRs = map fst $ filter snd $ dep_pkgs $ mi_deps iface' - case (safeM, safeP) of -- General errors we throw but Safe errors we log - (True, True ) -> return (trust == Sf_Trustworthy, pkgRs) - (True, False) -> liftIO . throwIO $ pkgTrustErr - (False, _ ) -> logWarnings modTrustErr >> - return (trust == Sf_Trustworthy, pkgRs) + errs = case (safeM, safeP) of + (True, True ) -> emptyBag + (True, False) -> pkgTrustErr + (False, _ ) -> modTrustErr + in do + logWarnings errs + return (trust == Sf_Trustworthy, pkgRs) where - pkgTrustErr = mkSrcErr $ unitBag $ mkPlainErrMsg dflags l $ + pkgTrustErr = unitBag $ mkPlainErrMsg dflags l $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!" , text "The package (" <> ppr (modulePackageId m) @@ -1078,6 +1092,8 @@ hscCheckSafe' dflags m l = do -- trustworthy modules, modules in the home package are trusted but -- otherwise we check the package trust flag. packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool + packageTrusted Sf_None _ _ = False -- shouldn't hit these cases + packageTrusted Sf_Unsafe _ _ = False -- prefer for completeness. packageTrusted _ _ _ | not (packageTrustOn dflags) = True packageTrusted Sf_Safe False _ = True diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 6b8bc5dd96..65fc4e339c 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -140,7 +140,7 @@ data NcgImpl statics instr jumpDest = NcgImpl { shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr, pprNatCmmDecl :: NatCmmDecl statics instr -> SDoc, maxSpillSlots :: Int, - allocatableRegs :: [RealReg], + allocatableRegs :: Platform -> [RealReg], ncg_x86fp_kludge :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr], ncgExpandTop :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr], ncgMakeFarBranches :: [NatBasicBlock instr] -> [NatBasicBlock instr] @@ -179,7 +179,7 @@ nativeCodeGen dflags h us cmms ,shortcutJump = PPC.RegInfo.shortcutJump ,pprNatCmmDecl = PPC.Ppr.pprNatCmmDecl ,maxSpillSlots = PPC.Instr.maxSpillSlots - ,allocatableRegs = PPC.Regs.allocatableRegs + ,allocatableRegs = \_ -> PPC.Regs.allocatableRegs ,ncg_x86fp_kludge = id ,ncgExpandTop = id ,ncgMakeFarBranches = makeFarBranches @@ -194,7 +194,7 @@ nativeCodeGen dflags h us cmms ,shortcutJump = SPARC.ShortcutJump.shortcutJump ,pprNatCmmDecl = SPARC.Ppr.pprNatCmmDecl ,maxSpillSlots = SPARC.Instr.maxSpillSlots - ,allocatableRegs = SPARC.Regs.allocatableRegs + ,allocatableRegs = \_ -> SPARC.Regs.allocatableRegs ,ncg_x86fp_kludge = id ,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop ,ncgMakeFarBranches = id @@ -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) = @@ -402,7 +402,7 @@ cmmNativeGen dflags ncgImpl us cmm count let (withLiveness, usLive) = {-# SCC "regLiveness" #-} initUs usGen - $ mapM regLiveness + $ mapM (regLiveness platform) $ map natCmmTopToLive native dumpIfSet_dyn dflags @@ -419,7 +419,7 @@ cmmNativeGen dflags ncgImpl us cmm count = foldr (\r -> plusUFM_C unionUniqSets $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r)) emptyUFM - $ allocatableRegs ncgImpl + $ allocatableRegs ncgImpl platform -- do the graph coloring register allocation let ((alloced, regAllocStats), usAlloc) @@ -980,6 +980,12 @@ cmmExprNative referenceKind expr = do -> do args' <- mapM (cmmExprNative DataReference) args return $ CmmMachOp mop args' + CmmLit (CmmBlock id) + -> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id))) + -- we must convert block Ids to CLabels here, because we + -- might have to do the PIC transformation. Hence we must + -- not modify BlockIds beyond this point. + CmmLit (CmmLabel lbl) -> do cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl diff --git a/compiler/nativeGen/Instruction.hs b/compiler/nativeGen/Instruction.hs index b67ff9d40f..292cf82f6a 100644 --- a/compiler/nativeGen/Instruction.hs +++ b/compiler/nativeGen/Instruction.hs @@ -68,7 +68,8 @@ class Instruction instr where -- allocation goes, are taken care of by the register allocator. -- regUsageOfInstr - :: instr + :: Platform + -> instr -> RegUsage diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index c725dd2f0c..b6c83eec0a 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -178,7 +178,7 @@ getRegisterReg (CmmLocal (LocalReg u pk)) getRegisterReg (CmmGlobal mid) = case globalRegMaybe mid of - Just reg -> reg + Just reg -> RegReal reg Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) -- By this stage, the only MagicIds remaining should be the -- ones which map to a real machine register on this @@ -320,15 +320,15 @@ iselExpr64 (CmmLit (CmmInt i _)) = do (rlo,rhi) <- getNewRegPairNat II32 let half0 = fromIntegral (fromIntegral i :: Word16) - half1 = fromIntegral ((fromIntegral i `shiftR` 16) :: Word16) - half2 = fromIntegral ((fromIntegral i `shiftR` 32) :: Word16) - half3 = fromIntegral ((fromIntegral i `shiftR` 48) :: Word16) + half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16) + half2 = fromIntegral (fromIntegral (i `shiftR` 32) :: Word16) + half3 = fromIntegral (fromIntegral (i `shiftR` 48) :: Word16) code = toOL [ LIS rlo (ImmInt half1), OR rlo rlo (RIImm $ ImmInt half0), LIS rhi (ImmInt half3), - OR rlo rlo (RIImm $ ImmInt half2) + OR rhi rhi (RIImm $ ImmInt half2) ] return (ChildCode64 code rlo) diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs index 63872e163a..2e25bd5b16 100644 --- a/compiler/nativeGen/PPC/Instr.hs +++ b/compiler/nativeGen/PPC/Instr.hs @@ -177,8 +177,8 @@ data Instr -- The consequences of control flow transfers, as far as register -- allocation goes, are taken care of by the register allocator. -- -ppc_regUsageOfInstr :: Instr -> RegUsage -ppc_regUsageOfInstr instr +ppc_regUsageOfInstr :: Platform -> Instr -> RegUsage +ppc_regUsageOfInstr _ instr = case instr of LD _ reg addr -> usage (regAddr addr, [reg]) LA _ reg addr -> usage (regAddr addr, [reg]) diff --git a/compiler/nativeGen/PPC/Regs.hs b/compiler/nativeGen/PPC/Regs.hs index 0d1c5705af..b86df54b1e 100644 --- a/compiler/nativeGen/PPC/Regs.hs +++ b/compiler/nativeGen/PPC/Regs.hs @@ -1,53 +1,46 @@ -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 1994-2004 --- +-- -- ----------------------------------------------------------------------------- -{-# 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 --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module PPC.Regs ( - -- squeeze functions - virtualRegSqueeze, - realRegSqueeze, - - mkVirtualReg, - regDotColor, - - -- immediates - Imm(..), - strImmLit, - litToImm, - - -- addressing modes - AddrMode(..), - addrOffset, - - -- registers - spRel, - argRegs, - allArgRegs, - callClobberedRegs, - allMachRegNos, - classOfRealReg, - showReg, - - -- machine specific - allFPArgRegs, - fits16Bits, - makeImmediate, - fReg, - sp, r3, r4, r27, r28, f1, f20, f21, - - -- horrow show - freeReg, - globalRegMaybe, - allocatableRegs + -- squeeze functions + virtualRegSqueeze, + realRegSqueeze, + + mkVirtualReg, + regDotColor, + + -- immediates + Imm(..), + strImmLit, + litToImm, + + -- addressing modes + AddrMode(..), + addrOffset, + + -- registers + spRel, + argRegs, + allArgRegs, + callClobberedRegs, + allMachRegNos, + classOfRealReg, + showReg, + + -- machine specific + allFPArgRegs, + fits16Bits, + makeImmediate, + fReg, + sp, r3, r4, r27, r28, f1, f20, f21, + + -- horrow show + freeReg, + globalRegMaybe, + allocatableRegs ) @@ -61,7 +54,6 @@ import Reg import RegClass import Size -import BlockId import OldCmm import CLabel ( CLabel ) import Unique @@ -71,31 +63,31 @@ import Constants import FastBool import FastTypes -import Data.Word ( Word8, Word16, Word32 ) -import Data.Int ( Int8, Int16, Int32 ) +import Data.Word ( Word8, Word16, Word32 ) +import Data.Int ( Int8, Int16, Int32 ) -- squeese functions for the graph allocator ----------------------------------- -- | regSqueeze_class reg --- Calculuate the maximum number of register colors that could be --- denied to a node of this class due to having this reg --- as a neighbour. +-- Calculuate the maximum number of register colors that could be +-- denied to a node of this class due to having this reg +-- as a neighbour. -- {-# INLINE virtualRegSqueeze #-} virtualRegSqueeze :: RegClass -> VirtualReg -> FastInt virtualRegSqueeze cls vr = case cls of - RcInteger - -> case vr of - VirtualRegI{} -> _ILIT(1) - VirtualRegHi{} -> _ILIT(1) + RcInteger + -> case vr of + VirtualRegI{} -> _ILIT(1) + VirtualRegHi{} -> _ILIT(1) _other -> _ILIT(0) - RcDouble - -> case vr of - VirtualRegD{} -> _ILIT(1) - VirtualRegF{} -> _ILIT(0) + RcDouble + -> case vr of + VirtualRegD{} -> _ILIT(1) + VirtualRegF{} -> _ILIT(0) _other -> _ILIT(0) _other -> _ILIT(0) @@ -104,21 +96,21 @@ virtualRegSqueeze cls vr realRegSqueeze :: RegClass -> RealReg -> FastInt realRegSqueeze cls rr = case cls of - RcInteger - -> case rr of - RealRegSingle regNo - | regNo < 32 -> _ILIT(1) -- first fp reg is 32 - | otherwise -> _ILIT(0) - - RealRegPair{} -> _ILIT(0) - - RcDouble - -> case rr of - RealRegSingle regNo - | regNo < 32 -> _ILIT(0) - | otherwise -> _ILIT(1) - - RealRegPair{} -> _ILIT(0) + RcInteger + -> case rr of + RealRegSingle regNo + | regNo < 32 -> _ILIT(1) -- first fp reg is 32 + | otherwise -> _ILIT(0) + + RealRegPair{} -> _ILIT(0) + + RcDouble + -> case rr of + RealRegSingle regNo + | regNo < 32 -> _ILIT(0) + | otherwise -> _ILIT(1) + + RealRegPair{} -> _ILIT(0) _other -> _ILIT(0) @@ -142,18 +134,18 @@ regDotColor reg -- immediates ------------------------------------------------------------------ data Imm - = ImmInt Int - | ImmInteger Integer -- Sigh. - | ImmCLbl CLabel -- AbstractC Label (with baggage) - | ImmLit SDoc -- Simple string - | ImmIndex CLabel Int - | ImmFloat Rational - | ImmDouble Rational - | ImmConstantSum Imm Imm - | ImmConstantDiff Imm Imm - | LO Imm - | HI Imm - | HA Imm {- high halfword adjusted -} + = ImmInt Int + | ImmInteger Integer -- Sigh. + | ImmCLbl CLabel -- AbstractC Label (with baggage) + | ImmLit SDoc -- Simple string + | ImmIndex CLabel Int + | ImmFloat Rational + | ImmDouble Rational + | ImmConstantSum Imm Imm + | ImmConstantDiff Imm Imm + | LO Imm + | HI Imm + | HA Imm {- high halfword adjusted -} strImmLit :: String -> Imm @@ -173,15 +165,14 @@ litToImm (CmmLabelDiffOff l1 l2 off) = ImmConstantSum (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) (ImmInt off) -litToImm (CmmBlock id) = ImmCLbl (infoTblLbl id) litToImm _ = panic "PPC.Regs.litToImm: no match" -- addressing modes ------------------------------------------------------------ data AddrMode - = AddrRegReg Reg Reg - | AddrRegImm Reg Imm + = AddrRegReg Reg Reg + | AddrRegImm Reg Imm addrOffset :: AddrMode -> Int -> Maybe AddrMode @@ -196,7 +187,7 @@ addrOffset addr off | fits16Bits n2 -> Just (AddrRegImm r (ImmInt (fromInteger n2))) | otherwise -> Nothing where n2 = n + toInteger off - + _ -> Nothing @@ -205,10 +196,10 @@ addrOffset addr off -- temporaries and for excess call arguments. @fpRel@, where -- applicable, is the same but for the frame pointer. -spRel :: Int -- desired stack offset in words, positive or negative +spRel :: Int -- desired stack offset in words, positive or negative -> AddrMode -spRel n = AddrRegImm sp (ImmInt (n * wORD_SIZE)) +spRel n = AddrRegImm sp (ImmInt (n * wORD_SIZE)) -- argRegs is the set of regs which are read for an n-argument call to C. @@ -231,7 +222,7 @@ allArgRegs :: [Reg] allArgRegs = map regSingle [3..10] --- these are the regs which we cannot assume stay alive over a C call. +-- these are the regs which we cannot assume stay alive over a C call. callClobberedRegs :: [Reg] #if defined(darwin_TARGET_OS) callClobberedRegs @@ -243,26 +234,26 @@ callClobberedRegs #else callClobberedRegs - = panic "PPC.Regs.callClobberedRegs: not defined for this architecture" + = panic "PPC.Regs.callClobberedRegs: not defined for this architecture" #endif -allMachRegNos :: [RegNo] -allMachRegNos = [0..63] +allMachRegNos :: [RegNo] +allMachRegNos = [0..63] {-# INLINE classOfRealReg #-} classOfRealReg :: RealReg -> RegClass classOfRealReg (RealRegSingle i) - | i < 32 = RcInteger - | otherwise = RcDouble + | i < 32 = RcInteger + | otherwise = RcDouble classOfRealReg (RealRegPair{}) - = panic "regClass(ppr): no reg pairs on this architecture" + = panic "regClass(ppr): no reg pairs on this architecture" showReg :: RegNo -> String showReg n - | n >= 0 && n <= 31 = "%r" ++ show n + | n >= 0 && n <= 31 = "%r" ++ show n | n >= 32 && n <= 63 = "%f" ++ show (n - 32) | otherwise = "%unknown_powerpc_real_reg_" ++ show n @@ -294,10 +285,10 @@ makeImmediate rep signed x = fmap ImmInt (toI16 rep signed) narrow W32 True = fromIntegral (fromIntegral x :: Int32) narrow W16 True = fromIntegral (fromIntegral x :: Int16) narrow W8 True = fromIntegral (fromIntegral x :: Int8) - narrow _ _ = panic "PPC.Regs.narrow: no match" - + narrow _ _ = panic "PPC.Regs.narrow: no match" + narrowed = narrow rep signed - + toI16 W32 True | narrowed >= -32768 && narrowed < 32768 = Just narrowed | otherwise = Nothing @@ -316,20 +307,20 @@ fReg :: Int -> RegNo fReg x = (32 + x) sp, r3, r4, r27, r28, f1, f20, f21 :: Reg -sp = regSingle 1 -r3 = regSingle 3 -r4 = regSingle 4 -r27 = regSingle 27 -r28 = regSingle 28 -f1 = regSingle $ fReg 1 -f20 = regSingle $ fReg 20 -f21 = regSingle $ fReg 21 +sp = regSingle 1 +r3 = regSingle 3 +r4 = regSingle 4 +r27 = regSingle 27 +r28 = regSingle 28 +f1 = regSingle $ fReg 1 +f20 = regSingle $ fReg 20 +f21 = regSingle $ fReg 21 -- horror show ----------------------------------------------------------------- freeReg :: RegNo -> FastBool -globalRegMaybe :: GlobalReg -> Maybe Reg +globalRegMaybe :: GlobalReg -> Maybe RealReg #if powerpc_TARGET_ARCH @@ -448,26 +439,26 @@ freeReg REG_Base = fastBool False #endif #ifdef REG_R1 freeReg REG_R1 = fastBool False -#endif -#ifdef REG_R2 +#endif +#ifdef REG_R2 freeReg REG_R2 = fastBool False -#endif -#ifdef REG_R3 +#endif +#ifdef REG_R3 freeReg REG_R3 = fastBool False -#endif -#ifdef REG_R4 +#endif +#ifdef REG_R4 freeReg REG_R4 = fastBool False -#endif -#ifdef REG_R5 +#endif +#ifdef REG_R5 freeReg REG_R5 = fastBool False -#endif -#ifdef REG_R6 +#endif +#ifdef REG_R6 freeReg REG_R6 = fastBool False -#endif -#ifdef REG_R7 +#endif +#ifdef REG_R7 freeReg REG_R7 = fastBool False -#endif -#ifdef REG_R8 +#endif +#ifdef REG_R8 freeReg REG_R8 = fastBool False #endif #ifdef REG_R9 @@ -494,16 +485,16 @@ freeReg REG_D1 = fastBool False #ifdef REG_D2 freeReg REG_D2 = fastBool False #endif -#ifdef REG_Sp +#ifdef REG_Sp freeReg REG_Sp = fastBool False -#endif +#endif #ifdef REG_Su freeReg REG_Su = fastBool False -#endif -#ifdef REG_SpLim +#endif +#ifdef REG_SpLim freeReg REG_SpLim = fastBool False -#endif -#ifdef REG_Hp +#endif +#ifdef REG_Hp freeReg REG_Hp = fastBool False #endif #ifdef REG_HpLim @@ -518,87 +509,87 @@ freeReg _ = fastBool True #ifdef REG_Base -globalRegMaybe BaseReg = Just (regSingle REG_Base) +globalRegMaybe BaseReg = Just (RealRegSingle REG_Base) #endif #ifdef REG_R1 -globalRegMaybe (VanillaReg 1 _) = Just (regSingle REG_R1) -#endif -#ifdef REG_R2 -globalRegMaybe (VanillaReg 2 _) = Just (regSingle REG_R2) -#endif -#ifdef REG_R3 -globalRegMaybe (VanillaReg 3 _) = Just (regSingle REG_R3) -#endif -#ifdef REG_R4 -globalRegMaybe (VanillaReg 4 _) = Just (regSingle REG_R4) -#endif -#ifdef REG_R5 -globalRegMaybe (VanillaReg 5 _) = Just (regSingle REG_R5) -#endif -#ifdef REG_R6 -globalRegMaybe (VanillaReg 6 _) = Just (regSingle REG_R6) -#endif -#ifdef REG_R7 -globalRegMaybe (VanillaReg 7 _) = Just (regSingle REG_R7) -#endif -#ifdef REG_R8 -globalRegMaybe (VanillaReg 8 _) = Just (regSingle REG_R8) -#endif -#ifdef REG_R9 -globalRegMaybe (VanillaReg 9 _) = Just (regSingle REG_R9) -#endif -#ifdef REG_R10 -globalRegMaybe (VanillaReg 10 _) = Just (regSingle REG_R10) +globalRegMaybe (VanillaReg 1 _) = Just (RealRegSingle REG_R1) +#endif +#ifdef REG_R2 +globalRegMaybe (VanillaReg 2 _) = Just (RealRegSingle REG_R2) +#endif +#ifdef REG_R3 +globalRegMaybe (VanillaReg 3 _) = Just (RealRegSingle REG_R3) +#endif +#ifdef REG_R4 +globalRegMaybe (VanillaReg 4 _) = Just (RealRegSingle REG_R4) +#endif +#ifdef REG_R5 +globalRegMaybe (VanillaReg 5 _) = Just (RealRegSingle REG_R5) +#endif +#ifdef REG_R6 +globalRegMaybe (VanillaReg 6 _) = Just (RealRegSingle REG_R6) +#endif +#ifdef REG_R7 +globalRegMaybe (VanillaReg 7 _) = Just (RealRegSingle REG_R7) +#endif +#ifdef REG_R8 +globalRegMaybe (VanillaReg 8 _) = Just (RealRegSingle REG_R8) +#endif +#ifdef REG_R9 +globalRegMaybe (VanillaReg 9 _) = Just (RealRegSingle REG_R9) +#endif +#ifdef REG_R10 +globalRegMaybe (VanillaReg 10 _) = Just (RealRegSingle REG_R10) #endif #ifdef REG_F1 -globalRegMaybe (FloatReg 1) = Just (regSingle REG_F1) -#endif -#ifdef REG_F2 -globalRegMaybe (FloatReg 2) = Just (regSingle REG_F2) -#endif -#ifdef REG_F3 -globalRegMaybe (FloatReg 3) = Just (regSingle REG_F3) -#endif -#ifdef REG_F4 -globalRegMaybe (FloatReg 4) = Just (regSingle REG_F4) -#endif -#ifdef REG_D1 -globalRegMaybe (DoubleReg 1) = Just (regSingle REG_D1) -#endif -#ifdef REG_D2 -globalRegMaybe (DoubleReg 2) = Just (regSingle REG_D2) -#endif -#ifdef REG_Sp -globalRegMaybe Sp = Just (regSingle REG_Sp) -#endif -#ifdef REG_Lng1 -globalRegMaybe (LongReg 1) = Just (regSingle REG_Lng1) -#endif -#ifdef REG_Lng2 -globalRegMaybe (LongReg 2) = Just (regSingle REG_Lng2) -#endif -#ifdef REG_SpLim -globalRegMaybe SpLim = Just (regSingle REG_SpLim) -#endif -#ifdef REG_Hp -globalRegMaybe Hp = Just (regSingle REG_Hp) -#endif -#ifdef REG_HpLim -globalRegMaybe HpLim = Just (regSingle REG_HpLim) -#endif -#ifdef REG_CurrentTSO -globalRegMaybe CurrentTSO = Just (regSingle REG_CurrentTSO) -#endif -#ifdef REG_CurrentNursery -globalRegMaybe CurrentNursery = Just (regSingle REG_CurrentNursery) -#endif -globalRegMaybe _ = Nothing +globalRegMaybe (FloatReg 1) = Just (RealRegSingle REG_F1) +#endif +#ifdef REG_F2 +globalRegMaybe (FloatReg 2) = Just (RealRegSingle REG_F2) +#endif +#ifdef REG_F3 +globalRegMaybe (FloatReg 3) = Just (RealRegSingle REG_F3) +#endif +#ifdef REG_F4 +globalRegMaybe (FloatReg 4) = Just (RealRegSingle REG_F4) +#endif +#ifdef REG_D1 +globalRegMaybe (DoubleReg 1) = Just (RealRegSingle REG_D1) +#endif +#ifdef REG_D2 +globalRegMaybe (DoubleReg 2) = Just (RealRegSingle REG_D2) +#endif +#ifdef REG_Sp +globalRegMaybe Sp = Just (RealRegSingle REG_Sp) +#endif +#ifdef REG_Lng1 +globalRegMaybe (LongReg 1) = Just (RealRegSingle REG_Lng1) +#endif +#ifdef REG_Lng2 +globalRegMaybe (LongReg 2) = Just (RealRegSingle REG_Lng2) +#endif +#ifdef REG_SpLim +globalRegMaybe SpLim = Just (RealRegSingle REG_SpLim) +#endif +#ifdef REG_Hp +globalRegMaybe Hp = Just (RealRegSingle REG_Hp) +#endif +#ifdef REG_HpLim +globalRegMaybe HpLim = Just (RealRegSingle REG_HpLim) +#endif +#ifdef REG_CurrentTSO +globalRegMaybe CurrentTSO = Just (RealRegSingle REG_CurrentTSO) +#endif +#ifdef REG_CurrentNursery +globalRegMaybe CurrentNursery = Just (RealRegSingle REG_CurrentNursery) +#endif +globalRegMaybe _ = Nothing #else /* powerpc_TARGET_ARCH */ -freeReg _ = 0# -globalRegMaybe _ = panic "PPC.Regs.globalRegMaybe: not defined" +freeReg _ = 0# +globalRegMaybe _ = panic "PPC.Regs.globalRegMaybe: not defined" #endif /* powerpc_TARGET_ARCH */ diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs index 46a32e2b6d..32b5e41402 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Main.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs @@ -119,7 +119,7 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code -- build a map of the cost of spilling each instruction -- this will only actually be computed if we have to spill something. let spillCosts = foldl' plusSpillCostInfo zeroSpillCostInfo - $ map slurpSpillCostInfo code + $ map (slurpSpillCostInfo platform) code -- the function to choose regs to leave uncolored let spill = chooseSpill spillCosts @@ -213,13 +213,13 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code -- spill the uncolored regs (code_spilled, slotsFree', spillStats) - <- regSpill code_coalesced slotsFree rsSpill + <- regSpill platform code_coalesced slotsFree rsSpill -- recalculate liveness -- NOTE: we have to reverse the SCCs here to get them back into the reverse-dependency -- order required by computeLiveness. If they're not in the correct order -- that function will panic. - code_relive <- mapM (regLiveness . reverseBlocksInTops) code_spilled + code_relive <- mapM (regLiveness platform . reverseBlocksInTops) code_spilled -- record what happened in this stage for debugging let stat = diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs index d8a654a6a5..6e110266d1 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs @@ -20,6 +20,7 @@ import UniqFM import UniqSet import UniqSupply import Outputable +import Platform import Data.List import Data.Maybe @@ -40,7 +41,8 @@ import qualified Data.Set as Set -- regSpill :: Instruction instr - => [LiveCmmDecl statics instr] -- ^ the code + => Platform + -> [LiveCmmDecl statics instr] -- ^ the code -> UniqSet Int -- ^ available stack slots -> UniqSet VirtualReg -- ^ the regs to spill -> UniqSM @@ -48,7 +50,7 @@ regSpill , UniqSet Int -- left over slots , SpillStats ) -- stats about what happened during spilling -regSpill code slotsFree regs +regSpill platform code slotsFree regs -- not enough slots to spill these regs | sizeUniqSet slotsFree < sizeUniqSet regs @@ -68,7 +70,7 @@ regSpill code slotsFree regs -- run the spiller on all the blocks let (code', state') = - runState (mapM (regSpill_top regSlotMap) code) + runState (mapM (regSpill_top platform regSlotMap) code) (initSpillS us) return ( code' @@ -79,11 +81,12 @@ regSpill code slotsFree regs -- | Spill some registers to stack slots in a top-level thing. regSpill_top :: Instruction instr - => RegMap Int -- ^ map of vregs to slots they're being spilled to. + => Platform + -> RegMap Int -- ^ map of vregs to slots they're being spilled to. -> LiveCmmDecl statics instr -- ^ the top level thing. -> SpillM (LiveCmmDecl statics instr) -regSpill_top regSlotMap cmm +regSpill_top platform regSlotMap cmm = case cmm of CmmData{} -> return cmm @@ -110,7 +113,7 @@ regSpill_top regSlotMap cmm liveSlotsOnEntry' -- Apply the spiller to all the basic blocks in the CmmProc. - sccs' <- mapM (mapSCCM (regSpill_block regSlotMap)) sccs + sccs' <- mapM (mapSCCM (regSpill_block platform regSlotMap)) sccs return $ CmmProc info' label sccs' @@ -137,12 +140,13 @@ regSpill_top regSlotMap cmm -- | Spill some registers to stack slots in a basic block. regSpill_block :: Instruction instr - => UniqFM Int -- ^ map of vregs to slots they're being spilled to. + => Platform + -> UniqFM Int -- ^ map of vregs to slots they're being spilled to. -> LiveBasicBlock instr -> SpillM (LiveBasicBlock instr) -regSpill_block regSlotMap (BasicBlock i instrs) - = do instrss' <- mapM (regSpill_instr regSlotMap) instrs +regSpill_block platform regSlotMap (BasicBlock i instrs) + = do instrss' <- mapM (regSpill_instr platform regSlotMap) instrs return $ BasicBlock i (concat instrss') @@ -151,18 +155,19 @@ regSpill_block regSlotMap (BasicBlock i instrs) -- the appropriate RELOAD or SPILL meta instructions. regSpill_instr :: Instruction instr - => UniqFM Int -- ^ map of vregs to slots they're being spilled to. + => Platform + -> UniqFM Int -- ^ map of vregs to slots they're being spilled to. -> LiveInstr instr -> SpillM [LiveInstr instr] -regSpill_instr _ li@(LiveInstr _ Nothing) +regSpill_instr _ _ li@(LiveInstr _ Nothing) = do return [li] -regSpill_instr regSlotMap +regSpill_instr platform regSlotMap (LiveInstr instr (Just _)) = do -- work out which regs are read and written in this instr - let RU rlRead rlWritten = regUsageOfInstr instr + let RU rlRead rlWritten = regUsageOfInstr platform instr -- sometimes a register is listed as being read more than once, -- nub this so we don't end up inserting two lots of spill code. diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs index 64069ddec9..9348dca936 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs @@ -211,7 +211,7 @@ cleanForward platform blockId assoc acc (li : instrs) -- writing to a reg changes its value. | LiveInstr instr _ <- li - , RU _ written <- regUsageOfInstr instr + , RU _ written <- regUsageOfInstr platform instr = let assoc' = foldr delAssoc assoc (map SReg $ nub written) in cleanForward platform blockId assoc' (li : acc) instrs diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs index 44e1ed7e0f..abcc6a69b6 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs @@ -36,6 +36,7 @@ import UniqFM import UniqSet import Digraph (flattenSCCs) import Outputable +import Platform import State import Data.List (nub, minimumBy) @@ -70,10 +71,11 @@ plusSpillCostRecord (r1, a1, b1, c1) (r2, a2, b2, c2) -- and the number of instructions it was live on entry to (lifetime) -- slurpSpillCostInfo :: (Outputable instr, Instruction instr) - => LiveCmmDecl statics instr + => Platform + -> LiveCmmDecl statics instr -> SpillCostInfo -slurpSpillCostInfo cmm +slurpSpillCostInfo platform cmm = execState (countCmm cmm) zeroSpillCostInfo where countCmm CmmData{} = return () @@ -110,7 +112,7 @@ slurpSpillCostInfo cmm mapM_ incLifetime $ uniqSetToList rsLiveEntry -- increment counts for what regs were read/written from - let (RU read written) = regUsageOfInstr instr + let (RU read written) = regUsageOfInstr platform instr mapM_ incUses $ catMaybes $ map takeVirtualReg $ nub read mapM_ incDefs $ catMaybes $ map takeVirtualReg $ nub written diff --git a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs index fd1fd272bd..724d7d6b25 100644 --- a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs @@ -43,8 +43,8 @@ import qualified X86.Instr class Show freeRegs => FR freeRegs where frAllocateReg :: RealReg -> freeRegs -> freeRegs - frGetFreeRegs :: RegClass -> freeRegs -> [RealReg] - frInitFreeRegs :: freeRegs + frGetFreeRegs :: Platform -> RegClass -> freeRegs -> [RealReg] + frInitFreeRegs :: Platform -> freeRegs frReleaseReg :: RealReg -> freeRegs -> freeRegs instance FR X86.FreeRegs where @@ -55,14 +55,14 @@ instance FR X86.FreeRegs where instance FR PPC.FreeRegs where frAllocateReg = PPC.allocateReg - frGetFreeRegs = PPC.getFreeRegs - frInitFreeRegs = PPC.initFreeRegs + frGetFreeRegs = \_ -> PPC.getFreeRegs + frInitFreeRegs = \_ -> PPC.initFreeRegs frReleaseReg = PPC.releaseReg instance FR SPARC.FreeRegs where frAllocateReg = SPARC.allocateReg - frGetFreeRegs = SPARC.getFreeRegs - frInitFreeRegs = SPARC.initFreeRegs + frGetFreeRegs = \_ -> SPARC.getFreeRegs + frInitFreeRegs = \_ -> SPARC.initFreeRegs frReleaseReg = SPARC.releaseReg maxSpillSlots :: Platform -> Int diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index 07b6e33d25..54c6990948 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -191,10 +191,10 @@ linearRegAlloc linearRegAlloc dflags first_id block_live sccs = let platform = targetPlatform dflags in case platformArch platform of - ArchX86 -> linearRegAlloc' platform (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs - ArchX86_64 -> linearRegAlloc' platform (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs - ArchSPARC -> linearRegAlloc' platform (frInitFreeRegs :: SPARC.FreeRegs) first_id block_live sccs - ArchPPC -> linearRegAlloc' platform (frInitFreeRegs :: PPC.FreeRegs) first_id block_live sccs + ArchX86 -> linearRegAlloc' platform (frInitFreeRegs platform :: X86.FreeRegs) first_id block_live sccs + ArchX86_64 -> linearRegAlloc' platform (frInitFreeRegs platform :: X86.FreeRegs) first_id block_live sccs + ArchSPARC -> linearRegAlloc' platform (frInitFreeRegs platform :: SPARC.FreeRegs) first_id block_live sccs + ArchPPC -> linearRegAlloc' platform (frInitFreeRegs platform :: PPC.FreeRegs) first_id block_live sccs ArchARM _ _ _ -> panic "linearRegAlloc ArchARM" ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64" ArchUnknown -> panic "linearRegAlloc ArchUnknown" @@ -304,7 +304,7 @@ processBlock -> RegM freeRegs [NatBasicBlock instr] -- ^ block with registers allocated processBlock platform block_live (BasicBlock id instrs) - = do initBlock id block_live + = do initBlock platform id block_live (instrs', fixups) <- linearRA platform block_live [] [] id instrs return $ BasicBlock id instrs' : fixups @@ -312,8 +312,9 @@ processBlock platform block_live (BasicBlock id instrs) -- | Load the freeregs and current reg assignment into the RegM state -- for the basic block with this BlockId. -initBlock :: FR freeRegs => BlockId -> BlockMap RegSet -> RegM freeRegs () -initBlock id block_live +initBlock :: FR freeRegs + => Platform -> BlockId -> BlockMap RegSet -> RegM freeRegs () +initBlock platform id block_live = do block_assig <- getBlockAssigR case mapLookup id block_assig of -- no prior info about this block: we must consider @@ -325,9 +326,9 @@ initBlock id block_live -> do -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ()) case mapLookup id block_live of Nothing -> - setFreeRegsR frInitFreeRegs + setFreeRegsR (frInitFreeRegs platform) Just live -> - setFreeRegsR $ foldr frAllocateReg frInitFreeRegs [ r | RegReal r <- uniqSetToList live ] + setFreeRegsR $ foldr frAllocateReg (frInitFreeRegs platform) [ r | RegReal r <- uniqSetToList live ] setAssigR emptyRegMap -- load info about register assignments leading into this block. @@ -447,7 +448,7 @@ genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr) -> RegM freeRegs ([instr], [NatBasicBlock instr]) genRaInsn platform block_live new_instrs block_id instr r_dying w_dying = - case regUsageOfInstr instr of { RU read written -> + case regUsageOfInstr platform instr of { RU read written -> do let real_written = [ rr | (RegReal rr) <- written ] let virt_written = [ vr | (RegVirtual vr) <- written ] @@ -603,7 +604,7 @@ saveClobberedTemps platform clobbered dying = do freeRegs <- getFreeRegsR let regclass = targetClassOfRealReg platform reg - freeRegs_thisClass = frGetFreeRegs regclass freeRegs + freeRegs_thisClass = frGetFreeRegs platform regclass freeRegs case filter (`notElem` clobbered) freeRegs_thisClass of @@ -744,7 +745,7 @@ allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr) allocRegsAndSpill_spill platform reading keep spills alloc r rs assig spill_loc = do freeRegs <- getFreeRegsR - let freeRegs_thisClass = frGetFreeRegs (classOfVirtualReg r) freeRegs + let freeRegs_thisClass = frGetFreeRegs platform (classOfVirtualReg r) freeRegs case freeRegs_thisClass of @@ -822,7 +823,7 @@ allocRegsAndSpill_spill platform reading keep spills alloc r rs assig spill_loc [ text "allocating vreg: " <> text (show r) , text "assignment: " <> text (show $ ufmToList assig) , text "freeRegs: " <> text (show freeRegs) - , text "initFreeRegs: " <> text (show (frInitFreeRegs `asTypeOf` freeRegs)) ] + , text "initFreeRegs: " <> text (show (frInitFreeRegs platform `asTypeOf` freeRegs)) ] result diff --git a/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs index 7e7d99b008..6309b24b45 100644 --- a/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs @@ -1,11 +1,4 @@ -{-# 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 --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -- | Free regs map for i386 and x86_64 module RegAlloc.Linear.X86.FreeRegs where @@ -14,49 +7,50 @@ import X86.Regs import RegClass import Reg import Panic +import Platform import Data.Word import Data.Bits -type FreeRegs +type FreeRegs #ifdef i386_TARGET_ARCH - = Word32 + = Word32 #else - = Word64 + = Word64 #endif noFreeRegs :: FreeRegs noFreeRegs = 0 releaseReg :: RealReg -> FreeRegs -> FreeRegs -releaseReg (RealRegSingle n) f - = f .|. (1 `shiftL` n) +releaseReg (RealRegSingle n) f + = f .|. (1 `shiftL` n) -releaseReg _ _ - = panic "RegAlloc.Linear.X86.FreeRegs.realeaseReg: no reg" +releaseReg _ _ + = panic "RegAlloc.Linear.X86.FreeRegs.realeaseReg: no reg" -initFreeRegs :: FreeRegs -initFreeRegs - = foldr releaseReg noFreeRegs allocatableRegs +initFreeRegs :: Platform -> FreeRegs +initFreeRegs platform + = foldr releaseReg noFreeRegs (allocatableRegs platform) -getFreeRegs :: RegClass -> FreeRegs -> [RealReg] -- lazilly -getFreeRegs cls f = go f 0 +getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazilly +getFreeRegs platform cls f = go f 0 where go 0 _ = [] - go n m - | n .&. 1 /= 0 && classOfRealReg (RealRegSingle m) == cls - = RealRegSingle m : (go (n `shiftR` 1) $! (m+1)) + go n m + | n .&. 1 /= 0 && classOfRealReg platform (RealRegSingle m) == cls + = RealRegSingle m : (go (n `shiftR` 1) $! (m+1)) - | otherwise - = go (n `shiftR` 1) $! (m+1) - -- ToDo: there's no point looking through all the integer registers - -- in order to find a floating-point one. + | otherwise + = go (n `shiftR` 1) $! (m+1) + -- ToDo: there's no point looking through all the integer registers + -- in order to find a floating-point one. allocateReg :: RealReg -> FreeRegs -> FreeRegs -allocateReg (RealRegSingle r) f +allocateReg (RealRegSingle r) f = f .&. complement (1 `shiftL` r) allocateReg _ _ - = panic "RegAlloc.Linear.X86.FreeRegs.allocateReg: no reg" + = panic "RegAlloc.Linear.X86.FreeRegs.allocateReg: no reg" diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index fc585d9438..2483e12213 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -87,9 +87,9 @@ data InstrSR instr | RELOAD Int Reg instance Instruction instr => Instruction (InstrSR instr) where - regUsageOfInstr i + regUsageOfInstr platform i = case i of - Instr instr -> regUsageOfInstr instr + Instr instr -> regUsageOfInstr platform instr SPILL reg _ -> RU [reg] [] RELOAD _ reg -> RU [] [reg] @@ -663,21 +663,22 @@ sccBlocks blocks = stronglyConnCompFromEdgedVertices graph -- regLiveness :: (Outputable instr, Instruction instr) - => LiveCmmDecl statics instr + => Platform + -> LiveCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr) -regLiveness (CmmData i d) +regLiveness _ (CmmData i d) = return $ CmmData i d -regLiveness (CmmProc info lbl []) +regLiveness _ (CmmProc info lbl []) | LiveInfo static mFirst _ _ <- info = return $ CmmProc (LiveInfo static mFirst (Just mapEmpty) Map.empty) lbl [] -regLiveness (CmmProc info lbl sccs) +regLiveness platform (CmmProc info lbl sccs) | LiveInfo static mFirst _ liveSlotsOnEntry <- info - = let (ann_sccs, block_live) = computeLiveness sccs + = let (ann_sccs, block_live) = computeLiveness platform sccs in return $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry) lbl ann_sccs @@ -742,15 +743,16 @@ reverseBlocksInTops top -- computeLiveness :: (Outputable instr, Instruction instr) - => [SCC (LiveBasicBlock instr)] + => Platform + -> [SCC (LiveBasicBlock instr)] -> ([SCC (LiveBasicBlock instr)], -- instructions annotated with list of registers -- which are "dead after this instruction". BlockMap RegSet) -- blocks annontated with set of live registers -- on entry to the block. -computeLiveness sccs +computeLiveness platform sccs = case checkIsReverseDependent sccs of - Nothing -> livenessSCCs emptyBlockMap [] sccs + Nothing -> livenessSCCs platform emptyBlockMap [] sccs Just bad -> pprPanic "RegAlloc.Liveness.computeLivenss" (vcat [ text "SCCs aren't in reverse dependent order" , text "bad blockId" <+> ppr bad @@ -758,22 +760,23 @@ computeLiveness sccs livenessSCCs :: Instruction instr - => BlockMap RegSet + => Platform + -> BlockMap RegSet -> [SCC (LiveBasicBlock instr)] -- accum -> [SCC (LiveBasicBlock instr)] -> ( [SCC (LiveBasicBlock instr)] , BlockMap RegSet) -livenessSCCs blockmap done [] +livenessSCCs _ blockmap done [] = (done, blockmap) -livenessSCCs blockmap done (AcyclicSCC block : sccs) - = let (blockmap', block') = livenessBlock blockmap block - in livenessSCCs blockmap' (AcyclicSCC block' : done) sccs +livenessSCCs platform blockmap done (AcyclicSCC block : sccs) + = let (blockmap', block') = livenessBlock platform blockmap block + in livenessSCCs platform blockmap' (AcyclicSCC block' : done) sccs -livenessSCCs blockmap done +livenessSCCs platform blockmap done (CyclicSCC blocks : sccs) = - livenessSCCs blockmap' (CyclicSCC blocks':done) sccs + livenessSCCs platform blockmap' (CyclicSCC blocks':done) sccs where (blockmap', blocks') = iterateUntilUnchanged linearLiveness equalBlockMaps blockmap blocks @@ -796,7 +799,7 @@ livenessSCCs blockmap done => BlockMap RegSet -> [LiveBasicBlock instr] -> (BlockMap RegSet, [LiveBasicBlock instr]) - linearLiveness = mapAccumL livenessBlock + linearLiveness = mapAccumL (livenessBlock platform) -- probably the least efficient way to compare two -- BlockMaps for equality. @@ -812,17 +815,18 @@ livenessSCCs blockmap done -- livenessBlock :: Instruction instr - => BlockMap RegSet + => Platform + -> BlockMap RegSet -> LiveBasicBlock instr -> (BlockMap RegSet, LiveBasicBlock instr) -livenessBlock blockmap (BasicBlock block_id instrs) +livenessBlock platform blockmap (BasicBlock block_id instrs) = let (regsLiveOnEntry, instrs1) - = livenessBack emptyUniqSet blockmap [] (reverse instrs) + = livenessBack platform emptyUniqSet blockmap [] (reverse instrs) blockmap' = mapInsert block_id regsLiveOnEntry blockmap - instrs2 = livenessForward regsLiveOnEntry instrs1 + instrs2 = livenessForward platform regsLiveOnEntry instrs1 output = BasicBlock block_id instrs2 @@ -833,16 +837,17 @@ livenessBlock blockmap (BasicBlock block_id instrs) livenessForward :: Instruction instr - => RegSet -- regs live on this instr + => Platform + -> RegSet -- regs live on this instr -> [LiveInstr instr] -> [LiveInstr instr] -livenessForward _ [] = [] -livenessForward rsLiveEntry (li@(LiveInstr instr mLive) : lis) +livenessForward _ _ [] = [] +livenessForward platform rsLiveEntry (li@(LiveInstr instr mLive) : lis) | Nothing <- mLive - = li : livenessForward rsLiveEntry lis + = li : livenessForward platform rsLiveEntry lis | Just live <- mLive - , RU _ written <- regUsageOfInstr instr + , RU _ written <- regUsageOfInstr platform instr = let -- Regs that are written to but weren't live on entry to this instruction -- are recorded as being born here. @@ -854,9 +859,9 @@ livenessForward rsLiveEntry (li@(LiveInstr instr mLive) : lis) `minusUniqSet` (liveDieWrite live) in LiveInstr instr (Just live { liveBorn = rsBorn }) - : livenessForward rsLiveNext lis + : livenessForward platform rsLiveNext lis -livenessForward _ _ = panic "RegLiveness.livenessForward: no match" +livenessForward _ _ _ = panic "RegLiveness.livenessForward: no match" -- | Calculate liveness going backwards, @@ -864,32 +869,34 @@ livenessForward _ _ = panic "RegLiveness.livenessForward: no match" livenessBack :: Instruction instr - => RegSet -- regs live on this instr + => Platform + -> RegSet -- regs live on this instr -> BlockMap RegSet -- regs live on entry to other BBs -> [LiveInstr instr] -- instructions (accum) -> [LiveInstr instr] -- instructions -> (RegSet, [LiveInstr instr]) -livenessBack liveregs _ done [] = (liveregs, done) +livenessBack _ liveregs _ done [] = (liveregs, done) -livenessBack liveregs blockmap acc (instr : instrs) - = let (liveregs', instr') = liveness1 liveregs blockmap instr - in livenessBack liveregs' blockmap (instr' : acc) instrs +livenessBack platform liveregs blockmap acc (instr : instrs) + = let (liveregs', instr') = liveness1 platform liveregs blockmap instr + in livenessBack platform liveregs' blockmap (instr' : acc) instrs -- don't bother tagging comments or deltas with liveness liveness1 :: Instruction instr - => RegSet + => Platform + -> RegSet -> BlockMap RegSet -> LiveInstr instr -> (RegSet, LiveInstr instr) -liveness1 liveregs _ (LiveInstr instr _) +liveness1 _ liveregs _ (LiveInstr instr _) | isMetaInstr instr = (liveregs, LiveInstr instr Nothing) -liveness1 liveregs blockmap (LiveInstr instr _) +liveness1 platform liveregs blockmap (LiveInstr instr _) | not_a_branch = (liveregs1, LiveInstr instr @@ -906,7 +913,7 @@ liveness1 liveregs blockmap (LiveInstr instr _) , liveDieWrite = mkUniqSet w_dying })) where - !(RU read written) = regUsageOfInstr instr + !(RU read written) = regUsageOfInstr platform instr -- registers that were written here are dead going backwards. -- registers that were read here are live going backwards. diff --git a/compiler/nativeGen/SPARC/Imm.hs b/compiler/nativeGen/SPARC/Imm.hs index eacc905122..fe64738f7b 100644 --- a/compiler/nativeGen/SPARC/Imm.hs +++ b/compiler/nativeGen/SPARC/Imm.hs @@ -17,7 +17,6 @@ where import OldCmm import CLabel -import BlockId import Outputable @@ -71,7 +70,6 @@ litToImm lit (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) (ImmInt off) - CmmBlock id -> ImmCLbl (infoTblLbl id) - _ -> panic "SPARC.Regs.litToImm: no match" + _ -> panic "SPARC.Regs.litToImm: no match" diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs index 82e16eee72..b3429f7587 100644 --- a/compiler/nativeGen/SPARC/Instr.hs +++ b/compiler/nativeGen/SPARC/Instr.hs @@ -221,8 +221,8 @@ data Instr -- consequences of control flow transfers, as far as register -- allocation goes, are taken care of by the register allocator. -- -sparc_regUsageOfInstr :: Instr -> RegUsage -sparc_regUsageOfInstr instr +sparc_regUsageOfInstr :: Platform -> Instr -> RegUsage +sparc_regUsageOfInstr _ instr = case instr of LD _ addr reg -> usage (regAddr addr, [reg]) ST _ reg addr -> usage (reg : regAddr addr, []) diff --git a/compiler/nativeGen/TargetReg.hs b/compiler/nativeGen/TargetReg.hs index 13293deeee..71e02a4c15 100644 --- a/compiler/nativeGen/TargetReg.hs +++ b/compiler/nativeGen/TargetReg.hs @@ -21,7 +21,6 @@ module TargetReg ( targetRealRegSqueeze, targetClassOfRealReg, targetMkVirtualReg, - targetWordSize, targetRegDotColor, targetClassOfReg ) @@ -34,7 +33,6 @@ import Reg import RegClass import Size -import CmmType (wordWidth) import Outputable import Unique import FastTypes @@ -72,18 +70,14 @@ targetRealRegSqueeze platform targetClassOfRealReg :: Platform -> RealReg -> RegClass targetClassOfRealReg platform = case platformArch platform of - ArchX86 -> X86.classOfRealReg - ArchX86_64 -> X86.classOfRealReg + ArchX86 -> X86.classOfRealReg platform + ArchX86_64 -> X86.classOfRealReg platform ArchPPC -> PPC.classOfRealReg ArchSPARC -> SPARC.classOfRealReg ArchPPC_64 -> panic "targetClassOfRealReg ArchPPC_64" ArchARM _ _ _ -> panic "targetClassOfRealReg ArchARM" ArchUnknown -> panic "targetClassOfRealReg ArchUnknown" --- TODO: This should look at targetPlatform too -targetWordSize :: Size -targetWordSize = intSize wordWidth - targetMkVirtualReg :: Platform -> Unique -> Size -> VirtualReg targetMkVirtualReg platform = case platformArch platform of diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 63a45764ea..c00a0d544a 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -926,6 +926,7 @@ getByteReg expr = do -- be modified by code to evaluate an arbitrary expression. getNonClobberedReg :: CmmExpr -> NatM (Reg, InstrBlock) getNonClobberedReg expr = do + dflags <- getDynFlags r <- getRegister expr case r of Any rep code -> do @@ -933,8 +934,7 @@ getNonClobberedReg expr = do return (tmp, code tmp) Fixed rep reg code -- only certain regs can be clobbered - | RegReal real <- reg - , real `elem` instrClobberedRegs + | reg `elem` instrClobberedRegs (targetPlatform dflags) -> do tmp <- getNewRegNat rep return (tmp, code `snocOL` reg2reg rep reg tmp) @@ -1978,11 +1978,11 @@ genCCall64' platform target dest_regs args = do (stack_args, int_regs_used, fp_regs_used, load_args_code) <- if platformOS platform == OSMinGW32 - then load_args_win args [] [] allArgRegs nilOL + then load_args_win args [] [] (allArgRegs platform) nilOL else do (stack_args, aregs, fregs, load_args_code) - <- load_args args allIntArgRegs allFPArgRegs nilOL - let fp_regs_used = reverse (drop (length fregs) (reverse allFPArgRegs)) - int_regs_used = reverse (drop (length aregs) (reverse allIntArgRegs)) + <- load_args args (allIntArgRegs platform) (allFPArgRegs platform) nilOL + let fp_regs_used = reverse (drop (length fregs) (reverse (allFPArgRegs platform))) + int_regs_used = reverse (drop (length aregs) (reverse (allIntArgRegs platform))) return (stack_args, int_regs_used, fp_regs_used, load_args_code) let @@ -1991,7 +1991,7 @@ genCCall64' platform target dest_regs args = do -- for annotating the call instruction with sse_regs = length fp_regs_used arg_stack_slots = if platformOS platform == OSMinGW32 - then length stack_args + length allArgRegs + then length stack_args + length (allArgRegs platform) else length stack_args tot_arg_size = arg_size * arg_stack_slots @@ -2014,7 +2014,7 @@ genCCall64' platform target dest_regs args = do -- On Win64, we also have to leave stack space for the arguments -- that we are passing in registers lss_code <- if platformOS platform == OSMinGW32 - then leaveStackSpace (length allArgRegs) + then leaveStackSpace (length (allArgRegs platform)) else return nilOL delta <- getDeltaNat diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index f31bf0349f..91d6ae4479 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -320,8 +320,8 @@ data Operand -x86_regUsageOfInstr :: Instr -> RegUsage -x86_regUsageOfInstr instr +x86_regUsageOfInstr :: Platform -> Instr -> RegUsage +x86_regUsageOfInstr platform instr = case instr of MOV _ src dst -> usageRW src dst MOVZxL _ src dst -> usageRW src dst @@ -359,8 +359,8 @@ x86_regUsageOfInstr instr JXX_GBL _ _ -> mkRU [] [] JMP op regs -> mkRUR (use_R op regs) JMP_TBL op _ _ _ -> mkRUR (use_R op []) - CALL (Left _) params -> mkRU params callClobberedRegs - CALL (Right reg) params -> mkRU (reg:params) callClobberedRegs + CALL (Left _) params -> mkRU params (callClobberedRegs platform) + CALL (Right reg) params -> mkRU (reg:params) (callClobberedRegs platform) CLTD _ -> mkRU [eax] [edx] NOP -> mkRU [] [] diff --git a/compiler/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs index 44052582b6..a53c4fcbf7 100644 --- a/compiler/nativeGen/X86/Regs.hs +++ b/compiler/nativeGen/X86/Regs.hs @@ -51,12 +51,22 @@ where #include "nativeGen/NCG.h" #include "HsVersions.h" +#if i386_TARGET_ARCH == 0 && x86_64_TARGET_ARCH == 0 +-- Compiling for some arch other than Intel so we choose x86-64 as default. +#undef arm_TARGET_ARCH +#undef powerpc_TARGET_ARCH +#undef powerpc64_TARGET_ARCH +#undef sparc_TARGET_ARCH + +#undef x86_64_TARGET_ARCH +#define x86_64_TARGET_ARCH 1 +#endif + #include "../includes/stg/HaskellMachRegs.h" import Reg import RegClass -import BlockId import OldCmm import CmmCallConv import CLabel ( CLabel ) @@ -155,7 +165,6 @@ litToImm (CmmLabelDiffOff l1 l2 off) = ImmConstantSum (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) (ImmInt off) -litToImm (CmmBlock id) = ImmCLbl (infoTblLbl id) litToImm _ = panic "X86.Regs.litToImm: no match" -- addressing modes ------------------------------------------------------------ @@ -219,26 +228,30 @@ firstfake, lastfake :: RegNo firstfake = 16 lastfake = 21 -firstxmm, lastxmm :: RegNo +firstxmm :: RegNo firstxmm = 24 -#if i386_TARGET_ARCH -lastxmm = 31 -#else -lastxmm = 39 -#endif -lastint :: RegNo -#if i386_TARGET_ARCH -lastint = 7 -- not %r8..%r15 -#else -lastint = 15 -#endif +lastxmm :: Platform -> RegNo +lastxmm platform + | target32Bit platform = 31 + | otherwise = 39 -intregnos, fakeregnos, xmmregnos, floatregnos :: [RegNo] -intregnos = [0..lastint] +lastint :: Platform -> RegNo +lastint platform + | target32Bit platform = 7 -- not %r8..%r15 + | otherwise = 15 + +intregnos :: Platform -> [RegNo] +intregnos platform = [0 .. lastint platform] + +fakeregnos :: [RegNo] fakeregnos = [firstfake .. lastfake] -xmmregnos = [firstxmm .. lastxmm] -floatregnos = fakeregnos ++ xmmregnos; + +xmmregnos :: Platform -> [RegNo] +xmmregnos platform = [firstxmm .. lastxmm platform] + +floatregnos :: Platform -> [RegNo] +floatregnos platform = fakeregnos ++ xmmregnos platform -- argRegs is the set of regs which are read for an n-argument call to C. @@ -248,22 +261,22 @@ argRegs :: RegNo -> [Reg] argRegs _ = panic "MachRegs.argRegs(x86): should not be used!" -- | The complete set of machine registers. -allMachRegNos :: [RegNo] -allMachRegNos = intregnos ++ floatregnos +allMachRegNos :: Platform -> [RegNo] +allMachRegNos platform = intregnos platform ++ floatregnos platform -- | Take the class of a register. -{-# INLINE classOfRealReg #-} -classOfRealReg :: RealReg -> RegClass +{-# INLINE classOfRealReg #-} +classOfRealReg :: Platform -> RealReg -> RegClass -- On x86, we might want to have an 8-bit RegClass, which would -- contain just regs 1-4 (the others don't have 8-bit versions). -- However, we can get away without this at the moment because the -- only allocatable integer regs are also 8-bit compatible (1, 3, 4). -classOfRealReg reg +classOfRealReg platform reg = case reg of RealRegSingle i - | i <= lastint -> RcInteger - | i <= lastfake -> RcDouble - | otherwise -> RcDoubleSSE + | i <= lastint platform -> RcInteger + | i <= lastfake -> RcDouble + | otherwise -> RcDoubleSSE RealRegPair{} -> panic "X86.Regs.classOfRealReg: RegPairs on this arch" @@ -406,12 +419,43 @@ xmm n = regSingle (firstxmm+n) -- horror show ----------------------------------------------------------------- freeReg :: RegNo -> FastBool globalRegMaybe :: GlobalReg -> Maybe RealReg -allArgRegs :: [(Reg, Reg)] -allIntArgRegs :: [Reg] -allFPArgRegs :: [Reg] -callClobberedRegs :: [Reg] -#if defined(i386_TARGET_ARCH) || defined(x86_64_TARGET_ARCH) +-- | these are the regs which we cannot assume stay alive over a C call. +callClobberedRegs :: Platform -> [Reg] +-- caller-saves registers +callClobberedRegs platform + | target32Bit platform = [eax,ecx,edx] ++ map regSingle (floatregnos platform) + | otherwise + -- all xmm regs are caller-saves + -- caller-saves registers + = [rax,rcx,rdx,rsi,rdi,r8,r9,r10,r11] + ++ map regSingle (floatregnos platform) + +allArgRegs :: Platform -> [(Reg, Reg)] +allArgRegs platform + | platformOS platform == OSMinGW32 = zip [rcx,rdx,r8,r9] + (map regSingle [firstxmm ..]) + | otherwise = panic "X86.Regs.allArgRegs: not defined for this arch" + +allIntArgRegs :: Platform -> [Reg] +allIntArgRegs platform + | (platformOS platform == OSMinGW32) || target32Bit platform + = panic "X86.Regs.allIntArgRegs: not defined for this platform" + | otherwise = [rdi,rsi,rdx,rcx,r8,r9] + +allFPArgRegs :: Platform -> [Reg] +allFPArgRegs platform + | platformOS platform == OSMinGW32 + = panic "X86.Regs.allFPArgRegs: not defined for this platform" + | otherwise = map regSingle [firstxmm .. firstxmm+7] + +-- Machine registers which might be clobbered by instructions that +-- generate results into fixed registers, or need arguments in a fixed +-- register. +instrClobberedRegs :: Platform -> [Reg] +instrClobberedRegs platform + | target32Bit platform = [ eax, ecx, edx ] + | otherwise = [ rax, rcx, rdx ] #if i386_TARGET_ARCH #define eax 0 @@ -588,88 +632,17 @@ globalRegMaybe _ = Nothing -- -#if defined(mingw32_HOST_OS) && x86_64_TARGET_ARCH - -allArgRegs = zip (map regSingle [rcx,rdx,r8,r9]) - (map regSingle [firstxmm ..]) -allIntArgRegs = panic "X86.Regs.allIntArgRegs: not defined for this platform" -allFPArgRegs = panic "X86.Regs.allFPArgRegs: not defined for this platform" - -#else - -allArgRegs = panic "X86.Regs.allArgRegs: not defined for this arch" - -# if i386_TARGET_ARCH -allIntArgRegs = panic "X86.Regs.allIntArgRegs: should not be used!" -# elif x86_64_TARGET_ARCH -allIntArgRegs = map regSingle [rdi,rsi,rdx,rcx,r8,r9] -# else -allIntArgRegs = panic "X86.Regs.allIntArgRegs: not defined for this arch" -# endif - -allFPArgRegs = map regSingle [firstxmm .. firstxmm+7] - -#endif - -- All machine registers that are used for argument-passing to Haskell functions allHaskellArgRegs :: [Reg] allHaskellArgRegs = [ RegReal r | Just r <- map globalRegMaybe globalArgRegs ] --- Machine registers which might be clobbered by instructions that --- generate results into fixed registers, or need arguments in a fixed --- register. -instrClobberedRegs :: [RealReg] -#if i386_TARGET_ARCH -instrClobberedRegs = map RealRegSingle [ eax, ecx, edx ] -#elif x86_64_TARGET_ARCH -instrClobberedRegs = map RealRegSingle [ rax, rcx, rdx ] -#endif - --- | these are the regs which we cannot assume stay alive over a C call. - -#if i386_TARGET_ARCH --- caller-saves registers -callClobberedRegs - = map regSingle ([eax,ecx,edx] ++ floatregnos) - -#elif x86_64_TARGET_ARCH --- all xmm regs are caller-saves --- caller-saves registers -callClobberedRegs - = map regSingle ([rax,rcx,rdx,rsi,rdi,r8,r9,r10,r11] ++ floatregnos) - -#else -callClobberedRegs - = panic "X86.Regs.callClobberedRegs: not defined for this architecture" -#endif - -#else /* i386_TARGET_ARCH || x86_64_TARGET_ARCH */ - - - -freeReg _ = 0# -globalRegMaybe _ = panic "X86.Regs.globalRegMaybe: not defined" - -allArgRegs = panic "X86.Regs.allArgRegs: not defined" -allIntArgRegs = panic "X86.Regs.allIntArgRegs: not defined" -allFPArgRegs = panic "X86.Regs.allFPArgRegs: not defined" -callClobberedRegs = panic "X86.Regs.callClobberedRegs: not defined" - -instrClobberedRegs :: [RealReg] -instrClobberedRegs = panic "X86.Regs.instrClobberedRegs: not defined for this arch" - -allHaskellArgRegs :: [Reg] -allHaskellArgRegs = panic "X86.Regs.allHaskellArgRegs: not defined for this arch" - -#endif - -- allocatableRegs is allMachRegNos with the fixed-use regs removed. -- i.e., these are the regs for which we are prepared to allow the -- register allocator to attempt to map VRegs to. -allocatableRegs :: [RealReg] -allocatableRegs +allocatableRegs :: Platform -> [RealReg] +allocatableRegs platform = let isFree i = isFastTrue (freeReg i) - in map RealRegSingle $ filter isFree allMachRegNos + in map RealRegSingle $ filter isFree (allMachRegNos platform) {- Note [esi/edi not allocatable] diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index cddb62a7d5..42162a87ea 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -1892,7 +1892,7 @@ primop MakeStableNameOp "makeStableName#" GenPrimOp out_of_line = True primop EqStableNameOp "eqStableName#" GenPrimOp - StableName# a -> StableName# a -> Int# + StableName# a -> StableName# b -> Int# primop StableNameToIntOp "stableNameToInt#" GenPrimOp StableName# a -> Int# diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 4ce57024b5..0a20f59061 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -644,24 +644,32 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) lookup_lie :: Bool -> LIE RdrName -> TcRn [(LIE Name, AvailInfo)] lookup_lie opt_typeFamilies (L loc ieRdr) = do - stuff <- setSrcSpan loc $ - case lookup_ie opt_typeFamilies ieRdr of - Failed err -> addErr err >> return [] - Succeeded a -> return a - checkDodgyImport stuff + (stuff, warns) <- setSrcSpan loc . + liftM (fromMaybe ([],[])) $ + run_lookup (lookup_ie opt_typeFamilies ieRdr) + mapM_ emit_warning warns return [ (L loc ie, avail) | (ie,avail) <- stuff ] where -- Warn when importing T(..) if T was exported abstractly - checkDodgyImport stuff - | IEThingAll n <- ieRdr, (_, AvailTC _ [_]):_ <- stuff - = ifWOptM Opt_WarnDodgyImports (addWarn (dodgyImportWarn n)) - -- NB. use the RdrName for reporting the warning - | IEThingAll {} <- ieRdr - , not (is_qual decl_spec) - = ifWOptM Opt_WarnMissingImportList $ - addWarn (missingImportListItem ieRdr) - checkDodgyImport _ - = return () + emit_warning (DodgyImport n) = ifWOptM Opt_WarnDodgyImports $ + addWarn (dodgyImportWarn n) + emit_warning MissingImportList = ifWOptM Opt_WarnMissingImportList $ + addWarn (missingImportListItem ieRdr) + emit_warning BadImportW = ifWOptM Opt_WarnDodgyImports $ + addWarn (lookup_err_msg BadImport) + + run_lookup :: IELookupM a -> TcRn (Maybe a) + run_lookup m = case m of + Failed err -> addErr (lookup_err_msg err) >> return Nothing + Succeeded a -> return (Just a) + + lookup_err_msg err = case err of + BadImport -> badImportItemErr iface decl_spec ieRdr all_avails + IllegalImport -> illegalImportItemErr + QualImportError rdr -> qualImportItemErr rdr + TypeItemError children -> typeItemErr + (head . filter isTyConName $ children) + (text "in import list") -- For each import item, we convert its RdrNames to Names, -- and at the same time construct an AvailInfo corresponding @@ -673,78 +681,111 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) -- data constructors of an associated family, we need separate -- AvailInfos for the data constructors and the family (as they have -- different parents). See the discussion at occ_env. - lookup_ie :: Bool -> IE RdrName -> MaybeErr MsgDoc [(IE Name,AvailInfo)] - lookup_ie opt_typeFamilies ie - = let bad_ie :: MaybeErr MsgDoc a - bad_ie = Failed (badImportItemErr iface decl_spec ie all_avails) - - lookup_name rdr - | isQual rdr = Failed (qualImportItemErr rdr) - | Just nm <- lookupOccEnv occ_env (rdrNameOcc rdr) = return nm - | otherwise = bad_ie - in - case ie of - IEVar n -> do - (name, avail, _) <- lookup_name n - return [(IEVar name, trimAvail avail name)] - - IEThingAll tc -> do - (name, avail@(AvailTC name2 subs), mb_parent) <- lookup_name tc - case mb_parent of - -- non-associated ty/cls - Nothing -> return [(IEThingAll name, avail)] - -- associated ty - Just parent -> return [(IEThingAll name, - AvailTC name2 (subs \\ [name])), - (IEThingAll name, AvailTC parent [name])] - - IEThingAbs tc - | want_hiding -- hiding ( C ) - -- Here the 'C' can be a data constructor - -- *or* a type/class, or even both - -> let tc_name = lookup_name tc - dc_name = lookup_name (setRdrNameSpace tc srcDataName) - in - case catMaybeErr [ tc_name, dc_name ] of - [] -> bad_ie - names -> return [mkIEThingAbs name | name <- names] - | otherwise - -> do nameAvail <- lookup_name tc - return [mkIEThingAbs nameAvail] - - IEThingWith tc ns -> do - (name, AvailTC _ subnames, mb_parent) <- lookup_name tc - let - env = mkOccEnv [(nameOccName s, s) | s <- subnames] - mb_children = map (lookupOccEnv env . rdrNameOcc) ns - children <- if any isNothing mb_children - then bad_ie - else return (catMaybes mb_children) - -- check for proper import of type families - when (not opt_typeFamilies && any isTyConName children) $ - Failed (typeItemErr (head . filter isTyConName $ children) - (text "in import list")) + lookup_ie :: Bool -> IE RdrName -> IELookupM ([(IE Name, AvailInfo)], [IELookupWarning]) + lookup_ie opt_typeFamilies ie = handle_bad_import $ do + let lookup_name rdr + | isQual rdr + = failLookupWith (QualImportError rdr) + | Just nm <- lookupOccEnv occ_env (rdrNameOcc rdr) + = return nm + | otherwise + = failLookupWith BadImport + case ie of + IEVar n -> do + (name, avail, _) <- lookup_name n + return ([(IEVar name, trimAvail avail name)], []) + + IEThingAll tc -> do + (name, avail@(AvailTC name2 subs), mb_parent) <- lookup_name tc + let warns + | null (drop 1 subs) + = [DodgyImport tc] + | not (is_qual decl_spec) + = [MissingImportList] + | otherwise + = [] case mb_parent of -- non-associated ty/cls - Nothing -> return [(IEThingWith name children, - AvailTC name (name:children))] + Nothing -> return ([(IEThingAll name, avail)], warns) -- associated ty - Just parent -> return [(IEThingWith name children, + Just parent -> return ([(IEThingAll name, + AvailTC name2 (subs \\ [name])), + (IEThingAll name, AvailTC parent [name])], + warns) + + IEThingAbs tc + | want_hiding -- hiding ( C ) + -- Here the 'C' can be a data constructor + -- *or* a type/class, or even both + -> let tc_name = lookup_name tc + dc_name = lookup_name (setRdrNameSpace tc srcDataName) + in + case catIELookupM [ tc_name, dc_name ] of + [] -> failLookupWith BadImport + names -> return ([mkIEThingAbs name | name <- names], []) + | otherwise + -> do nameAvail <- lookup_name tc + return ([mkIEThingAbs nameAvail], []) + + IEThingWith tc ns -> do + (name, AvailTC _ subnames, mb_parent) <- lookup_name tc + let + env = mkOccEnv [(nameOccName s, s) | s <- subnames] + mb_children = map (lookupOccEnv env . rdrNameOcc) ns + children <- if any isNothing mb_children + then failLookupWith BadImport + else return (catMaybes mb_children) + -- check for proper import of type families + when (not opt_typeFamilies && any isTyConName children) $ + failLookupWith (TypeItemError children) + case mb_parent of + -- non-associated ty/cls + Nothing -> return ([(IEThingWith name children, + AvailTC name (name:children))], + []) + -- associated ty + Just parent -> return ([(IEThingWith name children, AvailTC name children), (IEThingWith name children, - AvailTC parent [name])] + AvailTC parent [name])], + []) - _other -> Failed illegalImportItemErr - -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed - -- all errors. + _other -> failLookupWith IllegalImport + -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed + -- all errors. where mkIEThingAbs (n, av, Nothing ) = (IEThingAbs n, trimAvail av n) mkIEThingAbs (n, _, Just parent) = (IEThingAbs n, AvailTC parent [n]) + handle_bad_import m = catchIELookup m $ \err -> case err of + BadImport | want_hiding -> return ([], [BadImportW]) + _ -> failLookupWith err + +type IELookupM = MaybeErr IELookupError + +data IELookupWarning + = BadImportW + | MissingImportList + | DodgyImport RdrName + -- NB. use the RdrName for reporting a "dodgy" import + +data IELookupError + = QualImportError RdrName + | BadImport + | IllegalImport + | TypeItemError [Name] + +failLookupWith :: IELookupError -> IELookupM a +failLookupWith err = Failed err + +catchIELookup :: IELookupM a -> (IELookupError -> IELookupM a) -> IELookupM a +catchIELookup m h = case m of + Succeeded r -> return r + Failed err -> h err -catMaybeErr :: [MaybeErr err a] -> [a] -catMaybeErr ms = [ a | Succeeded a <- ms ] +catIELookupM :: [IELookupM a] -> [a] +catIELookupM ms = [ a | Succeeded a <- ms ] \end{code} %************************************************************************ diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs index 0cf858e7b5..231fd27ac6 100644 --- a/compiler/specialise/Rules.lhs +++ b/compiler/specialise/Rules.lhs @@ -725,8 +725,13 @@ match_co :: RuleEnv -> Maybe RuleSubst match_co renv subst (CoVarCo cv) co = match_var renv subst cv (Coercion co) +match_co renv subst (Refl ty1) co + = case co of + Refl ty2 -> match_ty renv subst ty1 ty2 + _ -> Nothing match_co _ _ co1 _ - = pprTrace "match_co bailing out" (ppr co1) Nothing + = pprTrace "match_co: needs more cases" (ppr co1) Nothing + -- Currently just deals with CoVarCo and Refl ------------- rnMatchBndr2 :: RuleEnv -> RuleSubst -> Var -> Var -> RuleEnv diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs index 995d6212ce..7661878ac1 100644 --- a/compiler/specialise/SpecConstr.lhs +++ b/compiler/specialise/SpecConstr.lhs @@ -1585,9 +1585,6 @@ argToPat :: ScEnv argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ = return (False, arg) -argToPat _env _in_scope _val_env arg@(Coercion {}) _arg_occ - = return (False, arg) - argToPat env in_scope val_env (Tick _ arg) arg_occ = argToPat env in_scope val_env arg arg_occ -- Note [Notes in call patterns] @@ -1696,6 +1693,7 @@ argToPat env in_scope val_env (Var v) arg_occ -- We don't want to specialise for that *particular* x,y -- The default case: make a wild-card + -- We use this for coercions too argToPat _env _in_scope _val_env arg _arg_occ = wildCardPat (exprType arg) @@ -1703,7 +1701,7 @@ wildCardPat :: Type -> UniqSM (Bool, CoreArg) wildCardPat ty = do { uniq <- getUniqueUs ; let id = mkSysLocal (fsLit "sc") uniq ty - ; return (False, Var id) } + ; return (False, varToCoreExpr id) } argsToPats :: ScEnv -> InScopeSet -> ValueEnv -> [CoreArg] -> [ArgOcc] -- Should be same length diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index 6892c9c6ad..4307ff75df 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -1573,10 +1573,7 @@ mkCallUDs :: Id -> [CoreExpr] -> UsageDetails mkCallUDs f args | not (want_calls_for f) -- Imported from elsewhere || null theta -- Not overloaded - || not (all isClassPred theta) - -- Only specialise if all overloading is on class params. - -- In ptic, with implicit params, the type args - -- *don't* say what the value of the implicit param is! + || not (all type_determines_value theta) || not (spec_tys `lengthIs` n_tyvars) || not ( dicts `lengthIs` n_dicts) || not (any interestingDict dicts) -- Note [Interesting dictionary arguments] @@ -1603,6 +1600,13 @@ mkCallUDs f args | otherwise = Nothing want_calls_for f = isLocalId f || isInlinablePragma (idInlinePragma f) + + type_determines_value pred = isClassPred pred && not (isIPPred pred) + -- Only specialise if all overloading is on non-IP *class* params, + -- because these are the ones whose *type* determines their *value*. + -- In ptic, with implicit params, the type args + -- *don't* say what the value of the implicit param is! + -- See Trac #7101 \end{code} Note [Interesting dictionary arguments] |