Commit 121768de authored by Iavor S. Diatchki's avatar Iavor S. Diatchki

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

parents df04d2d8 b78b6b34
......@@ -84,6 +84,27 @@ _darcs/
/utils/haddock/
/utils/hsc2hs/
# -----------------------------------------------------------------------------
# Cabal dist directories
/driver/ghc/dist/
/driver/haddock/dist/
/driver/ghci/dist/
/driver/split/dist/
/includes/dist-*/
/libffi/dist-install/
/libraries/*/dist-boot/
/libraries/*/dist-install/
/libraries/dist-haddock/
/rts/dist/
/utils/*/dist*/
/compiler/stage1/
/compiler/stage2/
/compiler/stage3/
/ghc/stage1/
/ghc/stage2/
/ghc/stage3/
# -----------------------------------------------------------------------------
# specific generated files
......@@ -95,9 +116,6 @@ _darcs/
/ch02.html
/compiler/ghc.cabal
/compiler/ghc.cabal.old
/compiler/stage1/
/compiler/stage2/
/compiler/stage3/
/distrib/configure.ac
/distrib/ghc.iss
/docs/index.html
......@@ -111,36 +129,18 @@ _darcs/
/docs/users_guide/users_guide.ps
/docs/users_guide/users_guide/
/docs/users_guide/what_glasgow_exts_does.gen.xml
/driver/ghc/dist/
/driver/haddock/dist/
/driver/ghci/ghc-pkg-inplace
/driver/ghci/ghci-inplace
/driver/ghci/dist/
/driver/ghci/ghci.res
/driver/mangler/dist/ghc-asm
/driver/mangler/dist/ghc-asm.prl
/driver/package.conf
/driver/package.conf.inplace.old
/driver/split/dist/ghc-split
/driver/split/dist/ghc-split.prl
/driver/stamp-pkg-conf-rts
/settings
/ghc.spec
/ghc/ghc-bin.cabal
/ghc/stage1/
/ghc/stage2/
/ghc/stage3/
/includes/DerivedConstants.h
/includes/GHCConstants.h
/includes/dist-*/
/includes/ghcautoconf.h
/includes/ghcplatform.h
/includes/mkDerivedConstantsHdr
/includes/mkGHCConstants
/inplace-datadir/
/index.html
/inplace/
/libffi/dist-install/
/libffi/build/
/libffi/ffi.h
/libffi/package.conf.inplace
......@@ -164,9 +164,6 @@ _darcs/
/libraries/synopsis.png
/libraries/stamp/
/libraries/time/
/libraries/*/dist-boot/
/libraries/*/dist-install/
/libraries/dist-haddock/
/mk/are-validating.mk
/mk/build.mk
/mk/config.h
......@@ -178,23 +175,13 @@ _darcs/
/mk/project.mk.old
/mk/stamp-h
/mk/validate.mk
/rts/dist/
/rts/AutoApply.*cmm
/rts/package.conf.inplace
/rts/package.conf.inplace.raw
/rts/sm/Evac_thr.c
/rts/sm/Scav_thr.c
/rts/package.conf.install
/rts/package.conf.install.raw
/stage3.package.conf
/testsuite_summary.txt
/testlog
/utils/*/dist*/
/utils/ext-core/Driver
/utils/ext-core/PrimEnv.hs
/utils/genapply/genapply
/utils/ghc-pkg/Version.hs
/utils/ghc-pwd/dist-boot/ghc-pwd
/utils/runghc/runghc.cabal
/extra-gcc-opts
......
......@@ -273,7 +273,7 @@ data DataCon
-- dcExTyVars = [x,y]
-- dcEqSpec = [a~(x,y)]
-- dcOtherTheta = [x~y, Ord x]
-- dcOrigArgTys = [a,List b]
-- dcOrigArgTys = [x,y]
-- dcRepTyCon = T
dcVanilla :: Bool, -- True <=> This is a vanilla Haskell 98 data constructor
......
This diff is collapsed.
......@@ -48,6 +48,8 @@ module Module
pprModule,
mkModule,
stableModuleCmp,
HasModule(..),
ContainsModule(..),
-- * The ModuleLocation type
ModLocation(..),
......@@ -276,6 +278,12 @@ pprPackagePrefix p mod = getPprStyle doc
-- the PrintUnqualified tells us which modules have to
-- be qualified with package names
| otherwise = empty
class ContainsModule t where
extractModule :: t -> Module
class HasModule m where
getModule :: m Module
\end{code}
%************************************************************************
......
This diff is collapsed.
......@@ -71,6 +71,14 @@ data GenCmmDecl d h g
= CmmProc -- A procedure
h -- Extra header such as the info table
CLabel -- Entry label
[GlobalReg] -- Registers live on entry. Note that the set of live
-- registers will be correct in generated C-- code, but
-- not in hand-written C-- code. However,
-- splitAtProcPoints calculates correct liveness
-- information for CmmProc's. Right now only the LLVM
-- back-end relies on correct liveness information and
-- for that back-end we always call splitAtProcPoints, so
-- all is good.
g -- Control-flow graph for the procedure's code
| CmmData -- Static data
......@@ -100,8 +108,8 @@ data CmmTopInfo = TopInfo { info_tbls :: BlockEnv CmmInfoTable
, stack_info :: CmmStackInfo }
topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable
topInfoTable (CmmProc infos _ g) = mapLookup (g_entry g) (info_tbls infos)
topInfoTable _ = Nothing
topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos)
topInfoTable _ = Nothing
data CmmStackInfo
= StackInfo {
......
......@@ -250,7 +250,7 @@ to_SRT dflags top_srt off len bmp
-- any CAF that is reachable from c.
localCAFInfo :: CAFEnv -> CmmDecl -> (CAFSet, Maybe CLabel)
localCAFInfo _ (CmmData _ _) = (Set.empty, Nothing)
localCAFInfo cafEnv proc@(CmmProc _ top_l (CmmGraph {g_entry=entry})) =
localCAFInfo cafEnv proc@(CmmProc _ top_l _ (CmmGraph {g_entry=entry})) =
case topInfoTable proc of
Just (CmmInfoTable { cit_rep = rep })
| not (isStaticRep rep) && not (isStackRep rep)
......@@ -295,7 +295,7 @@ bundle :: Map CLabel CAFSet
-> (CAFEnv, CmmDecl)
-> (CAFSet, Maybe CLabel)
-> (BlockEnv CAFSet, CmmDecl)
bundle flatmap (env, decl@(CmmProc infos lbl g)) (closure_cafs, mb_lbl)
bundle flatmap (env, decl@(CmmProc infos lbl _ g)) (closure_cafs, mb_lbl)
= ( mapMapWithKey get_cafs (info_tbls infos), decl )
where
entry = g_entry g
......@@ -371,8 +371,8 @@ buildSRTs dflags top_srt caf_map
-}
updInfoSRTs :: BlockEnv C_SRT -> CmmDecl -> CmmDecl
updInfoSRTs srt_env (CmmProc top_info top_l g) =
CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l g
updInfoSRTs srt_env (CmmProc top_info top_l live g) =
CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l live g
where updInfoTbl l info_tbl
= info_tbl { cit_srt = expectJust "updInfo" $ mapLookup l srt_env }
updInfoSRTs _ t = t
......@@ -9,7 +9,7 @@ module CmmCallConv (
ParamLocation(..),
assignArgumentsPos,
assignStack,
globalArgRegs, realArgRegs
globalArgRegs, realArgRegsCover
) where
#include "HsVersions.h"
......@@ -69,22 +69,27 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
assign_regs assts [] _ = (assts, [])
assign_regs assts (r:rs) regs = if isFloatType ty then float else int
where float = case (w, regs) of
(W32, (vs, f:fs, ds, ls)) -> k (RegisterParam f, (vs, fs, ds, ls))
(W64, (vs, fs, d:ds, ls)) -> k (RegisterParam d, (vs, fs, ds, ls))
(W32, (vs, fs, ds, ls, s:ss)) -> k (RegisterParam (FloatReg s), (vs, fs, ds, ls, ss))
(W32, (vs, f:fs, ds, ls, ss))
| not hasSseRegs -> k (RegisterParam f, (vs, fs, ds, ls, ss))
(W64, (vs, fs, ds, ls, s:ss)) -> k (RegisterParam (DoubleReg s), (vs, fs, ds, ls, ss))
(W64, (vs, fs, d:ds, ls, ss))
| not hasSseRegs -> k (RegisterParam d, (vs, fs, ds, ls, ss))
(W80, _) -> panic "F80 unsupported register type"
_ -> (assts, (r:rs))
int = case (w, regs) of
(W128, _) -> panic "W128 unsupported register type"
(_, (v:vs, fs, ds, ls)) | widthInBits w <= widthInBits (wordWidth dflags)
-> k (RegisterParam (v gcp), (vs, fs, ds, ls))
(_, (vs, fs, ds, l:ls)) | widthInBits w > widthInBits (wordWidth dflags)
-> k (RegisterParam l, (vs, fs, ds, ls))
(_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth dflags)
-> k (RegisterParam (v gcp), (vs, fs, ds, ls, ss))
(_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth dflags)
-> k (RegisterParam l, (vs, fs, ds, ls, ss))
_ -> (assts, (r:rs))
k (asst, regs') = assign_regs ((r, asst) : assts) rs regs'
ty = arg_ty r
w = typeWidth ty
gcp | isGcPtrType ty = VGcPtr
| otherwise = VNonGcPtr
hasSseRegs = mAX_Real_SSE_REG dflags /= 0
assignStack :: DynFlags -> ByteOff -> (a -> CmmType) -> [a]
......@@ -109,6 +114,7 @@ type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs.
, [GlobalReg] -- floats
, [GlobalReg] -- doubles
, [GlobalReg] -- longs (int64 and word64)
, [Int] -- SSE (floats and doubles)
)
-- Vanilla registers can contain pointers, Ints, Chars.
......@@ -122,7 +128,8 @@ getRegsWithoutNode dflags =
( filter (\r -> r VGcPtr /= node) (realVanillaRegs dflags)
, realFloatRegs dflags
, realDoubleRegs dflags
, realLongRegs dflags)
, realLongRegs dflags
, sseRegNos dflags)
-- getRegsWithNode uses R1/node even if it isn't a register
getRegsWithNode dflags =
......@@ -131,15 +138,18 @@ getRegsWithNode dflags =
else realVanillaRegs dflags
, realFloatRegs dflags
, realDoubleRegs dflags
, realLongRegs dflags)
, realLongRegs dflags
, sseRegNos dflags)
allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg]
allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]
allSseRegs :: DynFlags -> [Int]
allVanillaRegs dflags = map VanillaReg $ regList (mAX_Vanilla_REG dflags)
allFloatRegs dflags = map FloatReg $ regList (mAX_Float_REG dflags)
allDoubleRegs dflags = map DoubleReg $ regList (mAX_Double_REG dflags)
allLongRegs dflags = map LongReg $ regList (mAX_Long_REG dflags)
allSseRegs dflags = regList (mAX_SSE_REG dflags)
realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg]
realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]
......@@ -149,6 +159,9 @@ realFloatRegs dflags = map FloatReg $ regList (mAX_Real_Float_REG dflags)
realDoubleRegs dflags = map DoubleReg $ regList (mAX_Real_Double_REG dflags)
realLongRegs dflags = map LongReg $ regList (mAX_Real_Long_REG dflags)
sseRegNos :: DynFlags -> [Int]
sseRegNos dflags =regList (mAX_SSE_REG dflags)
regList :: Int -> [Int]
regList n = [1 .. n]
......@@ -156,10 +169,11 @@ allRegs :: DynFlags -> AvailRegs
allRegs dflags = (allVanillaRegs dflags,
allFloatRegs dflags,
allDoubleRegs dflags,
allLongRegs dflags)
allLongRegs dflags,
allSseRegs dflags)
noRegs :: AvailRegs
noRegs = ([], [], [], [])
noRegs = ([], [], [], [], [])
globalArgRegs :: DynFlags -> [GlobalReg]
globalArgRegs dflags = map ($ VGcPtr) (allVanillaRegs dflags) ++
......@@ -167,8 +181,19 @@ globalArgRegs dflags = map ($ VGcPtr) (allVanillaRegs dflags) ++
allDoubleRegs dflags ++
allLongRegs dflags
realArgRegs :: DynFlags -> [GlobalReg]
realArgRegs dflags = map ($VGcPtr) (realVanillaRegs dflags) ++
realFloatRegs dflags ++
realDoubleRegs dflags ++
realLongRegs dflags
-- This returns the set of global registers that *cover* the machine registers
-- used for argument passing. On platforms where registers can overlap---right
-- now just x86-64, where Float and Double registers overlap---passing this set
-- of registers is guaranteed to preserve the contents of all live registers. We
-- only use this functionality in hand-written C-- code in the RTS.
realArgRegsCover :: DynFlags -> [GlobalReg]
realArgRegsCover dflags
| hasSseRegs = map ($VGcPtr) (realVanillaRegs dflags) ++
realDoubleRegs dflags ++
realLongRegs dflags
| otherwise = map ($VGcPtr) (realVanillaRegs dflags) ++
realFloatRegs dflags ++
realDoubleRegs dflags ++
realLongRegs dflags
where
hasSseRegs = mAX_Real_SSE_REG dflags /= 0
......@@ -28,7 +28,7 @@ cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph
cmmCfgOpts split g = fst (blockConcat split g)
cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl
cmmCfgOptsProc split (CmmProc info lbl g) = CmmProc info' lbl g'
cmmCfgOptsProc split (CmmProc info lbl live g) = CmmProc info' lbl live g'
where (g', env) = blockConcat split g
info' = info{ info_tbls = new_info_tbls }
new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info)))
......
......@@ -19,7 +19,7 @@ import Outputable
cmmOfZgraph :: CmmGroup -> Old.CmmGroup
cmmOfZgraph tops = map mapTop tops
where mapTop (CmmProc h l g) = CmmProc (info_tbls h) l (ofZgraph g)
where mapTop (CmmProc h l v g) = CmmProc (info_tbls h) l v (ofZgraph g)
mapTop (CmmData s ds) = CmmData s ds
add_hints :: [a] -> [ForeignHint] -> [Old.CmmHinted a]
......@@ -109,7 +109,7 @@ ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g
| otherwise -> [Old.CmmCondBranch expr tid, Old.CmmBranch fid]
CmmSwitch arg ids -> [Old.CmmSwitch arg ids]
-- ToDo: STG Live
CmmCall e _ r _ _ _ -> [Old.CmmJump e (Just r)]
CmmCall e _ r _ _ _ -> [Old.CmmJump e r]
CmmForeignCall {} -> panic "ofZgraph: CmmForeignCall"
tail_of bid = case foldBlockNodesB3 (first, middle, last) block () of
Old.BasicBlock _ stmts -> stmts
......
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
module CmmExpr
( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr
, CmmReg(..), cmmRegType
, CmmLit(..), cmmLitType
, LocalReg(..), localRegType
, GlobalReg(..), globalRegType, spReg, hpReg, spLimReg, nodeReg, node, baseReg
, GlobalReg(..), isArgReg, globalRegType, spReg, hpReg, spLimReg, nodeReg, node, baseReg
, VGcPtr(..), vgcFlag -- Temporary!
, DefinerOfLocalRegs, UserOfLocalRegs, foldRegsDefd, foldRegsUsed, filterRegsUsed
, RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
, plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet
, regSetToList
, DefinerOfRegs, UserOfRegs
, foldRegsDefd, foldRegsUsed, filterRegsUsed
, foldLocalRegsDefd, foldLocalRegsUsed
, RegSet, LocalRegSet, GlobalRegSet
, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
, plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet
, regSetToList
, regUsedIn
, Area(..)
, module CmmMachOp
, module CmmType
......@@ -177,7 +185,7 @@ localRegType (LocalReg _ rep) = rep
-- Register-use information for expressions and other types
-----------------------------------------------------------------------------
-- | Sets of local registers
-- | Sets of registers
-- These are used for dataflow facts, and a common operation is taking
-- the union of two RegSets and then asking whether the union is the
......@@ -185,16 +193,19 @@ localRegType (LocalReg _ rep) = rep
-- sizeUniqSet is O(n) whereas Set.size is O(1), so we use ordinary
-- Sets.
type RegSet = Set LocalReg
emptyRegSet :: RegSet
nullRegSet :: RegSet -> Bool
elemRegSet :: LocalReg -> RegSet -> Bool
extendRegSet :: RegSet -> LocalReg -> RegSet
deleteFromRegSet :: RegSet -> LocalReg -> RegSet
mkRegSet :: [LocalReg] -> RegSet
minusRegSet, plusRegSet, timesRegSet :: RegSet -> RegSet -> RegSet
sizeRegSet :: RegSet -> Int
regSetToList :: RegSet -> [LocalReg]
type RegSet r = Set r
type LocalRegSet = RegSet LocalReg
type GlobalRegSet = RegSet GlobalReg
emptyRegSet :: Ord r => RegSet r
nullRegSet :: Ord r => RegSet r -> Bool
elemRegSet :: Ord r => r -> RegSet r -> Bool
extendRegSet :: Ord r => RegSet r -> r -> RegSet r
deleteFromRegSet :: Ord r => RegSet r -> r -> RegSet r
mkRegSet :: Ord r => [r] -> RegSet r
minusRegSet, plusRegSet, timesRegSet :: Ord r => RegSet r -> RegSet r -> RegSet r
sizeRegSet :: Ord r => RegSet r -> Int
regSetToList :: Ord r => RegSet r -> [r]
emptyRegSet = Set.empty
nullRegSet = Set.null
......@@ -208,58 +219,75 @@ timesRegSet = Set.intersection
sizeRegSet = Set.size
regSetToList = Set.toList
class UserOfLocalRegs a where
foldRegsUsed :: (b -> LocalReg -> b) -> b -> a -> b
class Ord r => UserOfRegs r a where
foldRegsUsed :: DynFlags -> (b -> r -> b) -> b -> a -> b
foldLocalRegsUsed :: UserOfRegs LocalReg a
=> DynFlags -> (b -> LocalReg -> b) -> b -> a -> b
foldLocalRegsUsed = foldRegsUsed
class DefinerOfLocalRegs a where
foldRegsDefd :: (b -> LocalReg -> b) -> b -> a -> b
class Ord r => DefinerOfRegs r a where
foldRegsDefd :: DynFlags -> (b -> r -> b) -> b -> a -> b
filterRegsUsed :: UserOfLocalRegs e => (LocalReg -> Bool) -> e -> RegSet
filterRegsUsed p e =
foldRegsUsed (\regs r -> if p r then extendRegSet regs r else regs)
foldLocalRegsDefd :: DefinerOfRegs LocalReg a
=> DynFlags -> (b -> LocalReg -> b) -> b -> a -> b
foldLocalRegsDefd = foldRegsDefd
filterRegsUsed :: UserOfRegs r e => DynFlags -> (r -> Bool) -> e -> RegSet r
filterRegsUsed dflags p e =
foldRegsUsed dflags
(\regs r -> if p r then extendRegSet regs r else regs)
emptyRegSet e
instance UserOfLocalRegs a => UserOfLocalRegs (Maybe a) where
foldRegsUsed f z (Just x) = foldRegsUsed f z x
foldRegsUsed _ z Nothing = z
instance UserOfRegs LocalReg CmmReg where
foldRegsUsed _ f z (CmmLocal reg) = f z reg
foldRegsUsed _ _ z (CmmGlobal _) = z
instance DefinerOfRegs LocalReg CmmReg where
foldRegsDefd _ f z (CmmLocal reg) = f z reg
foldRegsDefd _ _ z (CmmGlobal _) = z
instance UserOfLocalRegs CmmReg where
foldRegsUsed f z (CmmLocal reg) = f z reg
foldRegsUsed _ z (CmmGlobal _) = z
instance UserOfRegs GlobalReg CmmReg where
foldRegsUsed _ _ z (CmmLocal _) = z
foldRegsUsed _ f z (CmmGlobal reg) = f z reg
instance DefinerOfLocalRegs CmmReg where
foldRegsDefd f z (CmmLocal reg) = f z reg
foldRegsDefd _ z (CmmGlobal _) = z
instance DefinerOfRegs GlobalReg CmmReg where
foldRegsDefd _ _ z (CmmLocal _) = z
foldRegsDefd _ f z (CmmGlobal reg) = f z reg
instance UserOfLocalRegs LocalReg where
foldRegsUsed f z r = f z r
instance Ord r => UserOfRegs r r where
foldRegsUsed _ f z r = f z r
instance DefinerOfLocalRegs LocalReg where
foldRegsDefd f z r = f z r
instance Ord r => DefinerOfRegs r r where
foldRegsDefd _ f z r = f z r
instance UserOfLocalRegs RegSet where
foldRegsUsed f = Set.fold (flip f)
instance Ord r => UserOfRegs r (RegSet r) where
foldRegsUsed _ f = Set.fold (flip f)
instance UserOfLocalRegs CmmExpr where
foldRegsUsed f z e = expr z e
instance UserOfRegs r CmmReg => UserOfRegs r CmmExpr where
foldRegsUsed dflags f z e = expr z e
where expr z (CmmLit _) = z
expr z (CmmLoad addr _) = foldRegsUsed f z addr
expr z (CmmReg r) = foldRegsUsed f z r
expr z (CmmMachOp _ exprs) = foldRegsUsed f z exprs
expr z (CmmRegOff r _) = foldRegsUsed f z r
expr z (CmmLoad addr _) = foldRegsUsed dflags f z addr
expr z (CmmReg r) = foldRegsUsed dflags f z r
expr z (CmmMachOp _ exprs) = foldRegsUsed dflags f z exprs
expr z (CmmRegOff r _) = foldRegsUsed dflags f z r
expr z (CmmStackSlot _ _) = z
instance UserOfLocalRegs a => UserOfLocalRegs [a] where
foldRegsUsed _ set [] = set
foldRegsUsed f set (x:xs) = foldRegsUsed f (foldRegsUsed f set x) xs
instance UserOfRegs r a => UserOfRegs r (Maybe a) where
foldRegsUsed dflags f z (Just x) = foldRegsUsed dflags f z x
foldRegsUsed _ _ z Nothing = z
instance DefinerOfLocalRegs a => DefinerOfLocalRegs [a] where
foldRegsDefd _ set [] = set
foldRegsDefd f set (x:xs) = foldRegsDefd f (foldRegsDefd f set x) xs
instance UserOfRegs r a => UserOfRegs r [a] where
foldRegsUsed _ _ set [] = set
foldRegsUsed dflags f set (x:xs) = foldRegsUsed dflags f (foldRegsUsed dflags f set x) xs
instance DefinerOfLocalRegs a => DefinerOfLocalRegs (Maybe a) where
foldRegsDefd _ set Nothing = set
foldRegsDefd f set (Just x) = foldRegsDefd f set x
instance DefinerOfRegs r a => DefinerOfRegs r [a] where
foldRegsDefd _ _ set [] = set
foldRegsDefd dflags f set (x:xs) = foldRegsDefd dflags f (foldRegsDefd dflags f set x) xs
instance DefinerOfRegs r a => DefinerOfRegs r (Maybe a) where
foldRegsDefd _ _ set Nothing = set
foldRegsDefd dflags f set (Just x) = foldRegsDefd dflags f set x
-----------------------------------------------------------------------------
-- Another reg utility
......@@ -424,3 +452,10 @@ globalRegType dflags Hp = gcWord dflags
-- The initialiser for all
-- dynamically allocated closures
globalRegType dflags _ = bWord dflags
isArgReg :: GlobalReg -> Bool
isArgReg (VanillaReg {}) = True
isArgReg (FloatReg {}) = True
isArgReg (DoubleReg {}) = True
isArgReg (LongReg {}) = True
isArgReg _ = False
......@@ -90,7 +90,7 @@ mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl]
mkInfoTable _ (CmmData sec dat)
= return [CmmData sec dat]
mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks)
mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)
--
-- in the non-tables-next-to-code case, procs can have at most a
-- single info table associated with the entry label of the proc.
......@@ -99,7 +99,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks)
= case topInfoTable proc of -- must be at most one
-- no info table
Nothing ->
return [CmmProc mapEmpty entry_lbl blocks]
return [CmmProc mapEmpty entry_lbl live blocks]
Just info@CmmInfoTable { cit_lbl = info_lbl } -> do
(top_decls, (std_info, extra_bits)) <-
......@@ -120,7 +120,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks)
-- Separately emit info table (with the function entry
-- point as first entry) and the entry code
return (top_decls ++
[CmmProc mapEmpty entry_lbl blocks,
[CmmProc mapEmpty entry_lbl live blocks,
mkDataLits Data info_lbl
(CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])
......@@ -134,7 +134,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks)
= do
(top_declss, raw_infos) <- unzip `fmap` mapM do_one_info (mapToList infos)
return (concat top_declss ++
[CmmProc (mapFromList raw_infos) entry_lbl blocks])
[CmmProc (mapFromList raw_infos) entry_lbl live blocks])
where
do_one_info (lbl,itbl) = do
......
......@@ -111,9 +111,9 @@ cmmLayoutStack dflags procpoints entry_args
-- We need liveness info. We could do removeDeadAssignments at
-- the same time, but it buys nothing over doing cmmSink later,
-- and costs a lot more than just cmmLiveness.
-- and costs a lot more than just cmmLocalLiveness.
-- (graph, liveness) <- removeDeadAssignments graph0
let (graph, liveness) = (graph0, cmmLiveness graph0)
let (graph, liveness) = (graph0, cmmLocalLiveness dflags graph0)
-- pprTrace "liveness" (ppr liveness) $ return ()
let blocks = postorderDfs graph
......@@ -132,7 +132,7 @@ cmmLayoutStack dflags procpoints entry_args
layout :: DynFlags
-> BlockSet -- proc points
-> BlockEnv CmmLive -- liveness
-> BlockEnv CmmLocalLive -- liveness
-> BlockId -- entry
-> ByteOff -- stack args on entry
......@@ -319,7 +319,7 @@ getStackLoc (Young l) n stackmaps =
-- extra code that goes *after* the Sp adjustment.
handleLastNode
:: DynFlags -> ProcPointSet -> BlockEnv CmmLive -> BlockEnv ByteOff
:: DynFlags -> ProcPointSet -> BlockEnv CmmLocalLive -> BlockEnv ByteOff
-> BlockEnv StackMap -> StackMap
-> Block CmmNode O O
-> CmmNode O C
......@@ -499,7 +499,7 @@ fixupStack old_stack new_stack = concatMap move new_locs
setupStackFrame
:: DynFlags
-> BlockId -- label of continuation
-> BlockEnv CmmLive -- liveness
-> BlockEnv CmmLocalLive -- liveness
-> ByteOff -- updfr
-> ByteOff -- bytes of return values on stack
-> StackMap -- current StackMap
......@@ -602,7 +602,7 @@ futureContinuation middle = foldBlockNodesB f middle Nothing
-- on the stack and return the new StackMap and the assignments to do
-- the saving.
--
allocate :: DynFlags -> ByteOff -> RegSet -> StackMap
allocate :: DynFlags -> ByteOff -> LocalRegSet -> StackMap
-> (StackMap, [CmmNode O O])
allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0
, sm_regs = regs0 }
......@@ -847,8 +847,8 @@ elimStackStores stackmap stackmaps area_off nodes
setInfoTableStackMap :: DynFlags -> BlockEnv StackMap -> CmmDecl -> CmmDecl
setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l g)
= CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l g
setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g)
= CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g
where
fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } =
info_tbl { cit_rep = StackRep (get_liveness lbl) }
......
......@@ -32,10 +32,10 @@ import Data.Maybe
cmmLint :: (Outputable d, Outputable h)
=> DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc
cmmLint dflags tops = runCmmLint dflags (mapM_ lintCmmDecl) tops
cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops
cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc
cmmLintGraph dflags g = runCmmLint dflags lintCmmGraph g