Skip to content
GitLab
Commit cf02909e authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Merge remote branch 'origin/master'

parents 7d83fdea c3f4c6fa
Expand all Hide whitespace changes
Inline Side-by-side
aclocal.m4
View file @ cf02909e
......@@ -226,7 +226,10 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS],
haiku)
test -z "[$]2" || eval "[$]2=OSHaiku"
;;
dragonfly|osf1|osf3|hpux|linuxaout|freebsd2|cygwin32|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix)
osf3)
test -z "[$]2" || eval "[$]2=OSOsf3"
;;
dragonfly|osf1|hpux|linuxaout|freebsd2|cygwin32|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix)
test -z "[$]2" || eval "[$]2=OSUnknown"
;;
*)
......
compiler/cmm/Bitmap.hs
View file @ cf02909e
......@@ -25,6 +25,7 @@ module Bitmap (
import SMRep
import Constants
import DynFlags
import Util
import Data.Bits
......@@ -37,10 +38,10 @@ generated code which need to be emitted as sequences of StgWords.
type Bitmap = [StgWord]
-- | Make a bitmap from a sequence of bits
mkBitmap :: [Bool] -> Bitmap
mkBitmap [] = []
mkBitmap stuff = chunkToBitmap chunk : mkBitmap rest
where (chunk, rest) = splitAt wORD_SIZE_IN_BITS stuff
mkBitmap :: DynFlags -> [Bool] -> Bitmap
mkBitmap _ [] = []
mkBitmap dflags stuff = chunkToBitmap chunk : mkBitmap dflags rest
where (chunk, rest) = splitAt (wORD_SIZE_IN_BITS dflags) stuff
chunkToBitmap :: [Bool] -> StgWord
chunkToBitmap chunk =
......@@ -50,31 +51,31 @@ chunkToBitmap chunk =
-- eg. @[0,1,3], size 4 ==> 0xb@.
--
-- The list of @Int@s /must/ be already sorted.
intsToBitmap :: Int -> [Int] -> Bitmap
intsToBitmap size slots{- must be sorted -}
intsToBitmap :: DynFlags -> Int -> [Int] -> Bitmap
intsToBitmap dflags size slots{- must be sorted -}
| size <= 0 = []
| otherwise =
(foldr (.|.) 0 (map (1 `shiftL`) these)) :
intsToBitmap (size - wORD_SIZE_IN_BITS)
(map (\x -> x - wORD_SIZE_IN_BITS) rest)
where (these,rest) = span (<wORD_SIZE_IN_BITS) slots
intsToBitmap dflags (size - wORD_SIZE_IN_BITS dflags)
(map (\x -> x - wORD_SIZE_IN_BITS dflags) rest)
where (these,rest) = span (< wORD_SIZE_IN_BITS dflags) slots
-- | Make a bitmap where the slots specified are the /zeros/ in the bitmap.
-- eg. @[0,1,3], size 4 ==> 0x4@ (we leave any bits outside the size as zero,
-- just to make the bitmap easier to read).
--
-- The list of @Int@s /must/ be already sorted and duplicate-free.
intsToReverseBitmap :: Int -> [Int] -> Bitmap
intsToReverseBitmap size slots{- must be sorted -}
intsToReverseBitmap :: DynFlags -> Int -> [Int] -> Bitmap
intsToReverseBitmap dflags size slots{- must be sorted -}
| size <= 0 = []
| otherwise =
(foldr xor init (map (1 `shiftL`) these)) :
intsToReverseBitmap (size - wORD_SIZE_IN_BITS)
(map (\x -> x - wORD_SIZE_IN_BITS) rest)
where (these,rest) = span (<wORD_SIZE_IN_BITS) slots
init
| size >= wORD_SIZE_IN_BITS = complement 0
| otherwise = (1 `shiftL` size) - 1
(foldr xor init (map (1 `shiftL`) these)) :
intsToReverseBitmap dflags (size - wORD_SIZE_IN_BITS dflags)
(map (\x -> x - wORD_SIZE_IN_BITS dflags) rest)
where (these,rest) = span (< wORD_SIZE_IN_BITS dflags) slots
init
| size >= wORD_SIZE_IN_BITS dflags = complement 0
| otherwise = (1 `shiftL` size) - 1
{- |
Magic number, must agree with @BITMAP_BITS_SHIFT@ in InfoTables.h.
......
compiler/cmm/CmmBuildInfoTables.hs
View file @ cf02909e
......@@ -33,6 +33,7 @@ import CLabel
import Cmm
import CmmUtils
import Data.List
import DynFlags
import Maybes
import Module
import Outputable
......@@ -166,17 +167,17 @@ srtToData srt = [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)]
-- in the SRT. Then, if the number of CAFs is small enough to fit in a bitmap,
-- we make sure they're all close enough to the bottom of the table that the
-- bitmap will be able to cover all of them.
buildSRT :: TopSRT -> CAFSet -> UniqSM (TopSRT, Maybe CmmDecl, C_SRT)
buildSRT topSRT cafs =
buildSRT :: DynFlags -> TopSRT -> CAFSet -> UniqSM (TopSRT, Maybe CmmDecl, C_SRT)
buildSRT dflags topSRT cafs =
do let
-- For each label referring to a function f without a static closure,
-- replace it with the CAFs that are reachable from f.
sub_srt topSRT localCafs =
let cafs = Set.elems localCafs
mkSRT topSRT =
do localSRTs <- procpointSRT (lbl topSRT) (elt_map topSRT) cafs
do localSRTs <- procpointSRT dflags (lbl topSRT) (elt_map topSRT) cafs
return (topSRT, localSRTs)
in if length cafs > maxBmpSize then
in if length cafs > maxBmpSize dflags then
mkSRT (foldl add_if_missing topSRT cafs)
else -- make sure all the cafs are near the bottom of the srt
mkSRT (add_if_too_far topSRT cafs)
......@@ -196,7 +197,7 @@ buildSRT topSRT cafs =
add srt [] = srt
add srt@(TopSRT {next_elt = next}) (caf : rst) =
case cafOffset srt caf of
Just ix -> if next - ix > maxBmpSize then
Just ix -> if next - ix > maxBmpSize dflags then
add (addCAF caf srt) rst
else srt
Nothing -> add (addCAF caf srt) rst
......@@ -206,12 +207,12 @@ buildSRT topSRT cafs =
-- Construct an SRT bitmap.
-- Adapted from simpleStg/SRT.lhs, which expects Id's.
procpointSRT :: CLabel -> Map CLabel Int -> [CLabel] ->
procpointSRT :: DynFlags -> CLabel -> Map CLabel Int -> [CLabel] ->
UniqSM (Maybe CmmDecl, C_SRT)
procpointSRT _ _ [] =
procpointSRT _ _ _ [] =
return (Nothing, NoC_SRT)
procpointSRT top_srt top_table entries =
do (top, srt) <- bitmap `seq` to_SRT top_srt offset len bitmap
procpointSRT dflags top_srt top_table entries =
do (top, srt) <- bitmap `seq` to_SRT dflags top_srt offset len bitmap
return (top, srt)
where
ints = map (expectJust "constructSRT" . flip Map.lookup top_table) entries
......@@ -219,22 +220,22 @@ procpointSRT top_srt top_table entries =
offset = head sorted_ints
bitmap_entries = map (subtract offset) sorted_ints
len = P.last bitmap_entries + 1
bitmap = intsToBitmap len bitmap_entries
bitmap = intsToBitmap dflags len bitmap_entries
maxBmpSize :: Int
maxBmpSize = widthInBits wordWidth `div` 2
maxBmpSize :: DynFlags -> Int
maxBmpSize dflags = widthInBits (wordWidth dflags) `div` 2
-- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT.
to_SRT :: CLabel -> Int -> Int -> Bitmap -> UniqSM (Maybe CmmDecl, C_SRT)
to_SRT top_srt off len bmp
| len > maxBmpSize || bmp == [fromIntegral srt_escape]
to_SRT :: DynFlags -> CLabel -> Int -> Int -> Bitmap -> UniqSM (Maybe CmmDecl, C_SRT)
to_SRT dflags top_srt off len bmp
| len > maxBmpSize dflags || bmp == [fromIntegral srt_escape]
= do id <- getUniqueM
let srt_desc_lbl = mkLargeSRTLabel id
tbl = CmmData RelocatableReadOnlyData $
Statics srt_desc_lbl $ map CmmStaticLit
( cmmLabelOffW top_srt off
: mkWordCLit (fromIntegral len)
: map mkWordCLit bmp)
: mkWordCLit dflags (fromIntegral len)
: map (mkWordCLit dflags) bmp)
return (Just tbl, C_SRT srt_desc_lbl 0 srt_escape)
| otherwise
= return (Nothing, C_SRT top_srt off (fromIntegral (head bmp)))
......@@ -318,11 +319,12 @@ flattenCAFSets cpsdecls = zipWith (bundle flatmap) zipped localCAFs
localCAFs = unzipWith localCAFInfo zipped
flatmap = mkTopCAFInfo localCAFs -- transitive closure of localCAFs
doSRTs :: TopSRT
doSRTs :: DynFlags
-> TopSRT
-> [(CAFEnv, [CmmDecl])]
-> IO (TopSRT, [CmmDecl])
doSRTs topSRT tops
doSRTs dflags topSRT tops
= do
let caf_decls = flattenCAFSets tops
us <- mkSplitUniqSupply 'u'
......@@ -330,19 +332,19 @@ doSRTs topSRT tops
return (topSRT', reverse gs' {- Note [reverse gs] -})
where
setSRT (topSRT, rst) (caf_map, decl@(CmmProc{})) = do
(topSRT, srt_tables, srt_env) <- buildSRTs topSRT caf_map
(topSRT, srt_tables, srt_env) <- buildSRTs dflags topSRT caf_map
let decl' = updInfoSRTs srt_env decl
return (topSRT, decl': srt_tables ++ rst)
setSRT (topSRT, rst) (_, decl) =
return (topSRT, decl : rst)
buildSRTs :: TopSRT -> BlockEnv CAFSet
buildSRTs :: DynFlags -> TopSRT -> BlockEnv CAFSet
-> UniqSM (TopSRT, [CmmDecl], BlockEnv C_SRT)
buildSRTs top_srt caf_map
buildSRTs dflags top_srt caf_map
= foldM doOne (top_srt, [], mapEmpty) (mapToList caf_map)
where
doOne (top_srt, decls, srt_env) (l, cafs)
= do (top_srt, mb_decl, srt) <- buildSRT top_srt cafs
= do (top_srt, mb_decl, srt) <- buildSRT dflags top_srt cafs
return ( top_srt, maybeToList mb_decl ++ decls
, mapInsert l srt srt_env )
......
compiler/cmm/CmmCallConv.hs
View file @ cf02909e
......@@ -46,12 +46,12 @@ assignArgumentsPos dflags conv arg_ty reps = assignments
regs = case (reps, conv) of
(_, NativeNodeCall) -> getRegsWithNode dflags
(_, NativeDirectCall) -> getRegsWithoutNode dflags
([_], NativeReturn) -> allRegs
([_], NativeReturn) -> allRegs dflags
(_, NativeReturn) -> getRegsWithNode dflags
-- GC calling convention *must* put values in registers
(_, GC) -> allRegs
(_, PrimOpCall) -> allRegs
([_], PrimOpReturn) -> allRegs
(_, GC) -> allRegs dflags
(_, PrimOpCall) -> allRegs dflags
([_], PrimOpReturn) -> allRegs dflags
(_, PrimOpReturn) -> getRegsWithNode dflags
(_, Slow) -> noRegs
-- The calling conventions first assign arguments to registers,
......@@ -78,9 +78,9 @@ assignArgumentsPos dflags conv arg_ty reps = assignments
_ -> (assts, (r:rs))
int = case (w, regs) of
(W128, _) -> panic "W128 unsupported register type"
(_, (v:vs, fs, ds, ls)) | widthInBits w <= widthInBits wordWidth
(_, (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
(_, (vs, fs, ds, l:ls)) | widthInBits w > widthInBits (wordWidth dflags)
-> k (RegisterParam l, (vs, fs, ds, ls))
_ -> (assts, (r:rs))
k (asst, regs') = assign_regs ((r, asst) : assts) rs regs'
......@@ -111,46 +111,51 @@ type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs.
-- that are guaranteed to map to machine registers.
getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs
getRegsWithoutNode _dflags =
( filter (\r -> r VGcPtr /= node) realVanillaRegs
, realFloatRegs
, realDoubleRegs
, realLongRegs )
getRegsWithoutNode dflags =
( filter (\r -> r VGcPtr /= node) (realVanillaRegs dflags)
, realFloatRegs dflags
, realDoubleRegs dflags
, realLongRegs dflags)
-- getRegsWithNode uses R1/node even if it isn't a register
getRegsWithNode _dflags =
( if null realVanillaRegs then [VanillaReg 1] else realVanillaRegs
, realFloatRegs
, realDoubleRegs
, realLongRegs )
allFloatRegs, allDoubleRegs, allLongRegs :: [GlobalReg]
allVanillaRegs :: [VGcPtr -> GlobalReg]
allVanillaRegs = map VanillaReg $ regList mAX_Vanilla_REG
allFloatRegs = map FloatReg $ regList mAX_Float_REG
allDoubleRegs = map DoubleReg $ regList mAX_Double_REG
allLongRegs = map LongReg $ regList mAX_Long_REG
realFloatRegs, realDoubleRegs, realLongRegs :: [GlobalReg]
realVanillaRegs :: [VGcPtr -> GlobalReg]
realVanillaRegs = map VanillaReg $ regList mAX_Real_Vanilla_REG
realFloatRegs = map FloatReg $ regList mAX_Real_Float_REG
realDoubleRegs = map DoubleReg $ regList mAX_Real_Double_REG
realLongRegs = map LongReg $ regList mAX_Real_Long_REG
getRegsWithNode dflags =
( if null (realVanillaRegs dflags)
then [VanillaReg 1]
else realVanillaRegs dflags
, realFloatRegs dflags
, realDoubleRegs dflags
, realLongRegs dflags)
allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg]
allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]
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)
realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg]
realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]
realVanillaRegs dflags = map VanillaReg $ regList (mAX_Real_Vanilla_REG dflags)
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)
regList :: Int -> [Int]
regList n = [1 .. n]
allRegs :: AvailRegs
allRegs = (allVanillaRegs, allFloatRegs, allDoubleRegs, allLongRegs)
allRegs :: DynFlags -> AvailRegs
allRegs dflags = (allVanillaRegs dflags,
allFloatRegs dflags,
allDoubleRegs dflags,
allLongRegs dflags)
noRegs :: AvailRegs
noRegs = ([], [], [], [])
globalArgRegs :: [GlobalReg]
globalArgRegs = map ($VGcPtr) allVanillaRegs ++
allFloatRegs ++
allDoubleRegs ++
allLongRegs
globalArgRegs :: DynFlags -> [GlobalReg]
globalArgRegs dflags = map ($ VGcPtr) (allVanillaRegs dflags) ++
allFloatRegs dflags ++
allDoubleRegs dflags ++
allLongRegs dflags
compiler/cmm/CmmExpr.hs
View file @ cf02909e
{-# 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 CmmExpr
( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr
, CmmReg(..), cmmRegType
, CmmLit(..), cmmLitType
, LocalReg(..), localRegType
, GlobalReg(..), globalRegType, spReg, hpReg, spLimReg, nodeReg, node, baseReg
, VGcPtr(..), vgcFlag -- Temporary!
, VGcPtr(..), vgcFlag -- Temporary!
, DefinerOfLocalRegs, UserOfLocalRegs, foldRegsDefd, foldRegsUsed, filterRegsUsed
, RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
, plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet
......@@ -30,13 +23,14 @@ import CmmType
import CmmMachOp
import BlockId
import CLabel
import DynFlags
import Unique
import Data.Set (Set)
import qualified Data.Set as Set
-----------------------------------------------------------------------------
-- CmmExpr
-- CmmExpr
-- An expression. Expressions have no side effects.
-----------------------------------------------------------------------------
......@@ -48,19 +42,19 @@ data CmmExpr
| CmmStackSlot Area {-# UNPACK #-} !Int
-- addressing expression of a stack slot
| CmmRegOff !CmmReg Int
-- CmmRegOff reg i
-- ** is shorthand only, meaning **
-- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]
-- where rep = typeWidth (cmmRegType reg)
instance Eq CmmExpr where -- Equality ignores the types
CmmLit l1 == CmmLit l2 = l1==l2
CmmLoad e1 _ == CmmLoad e2 _ = e1==e2
CmmReg r1 == CmmReg r2 = r1==r2
CmmRegOff r1 i1 == CmmRegOff r2 i2 = r1==r2 && i1==i2
CmmMachOp op1 es1 == CmmMachOp op2 es2 = op1==op2 && es1==es2
-- CmmRegOff reg i
-- ** is shorthand only, meaning **
-- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]
-- where rep = typeWidth (cmmRegType reg)
instance Eq CmmExpr where -- Equality ignores the types
CmmLit l1 == CmmLit l2 = l1==l2
CmmLoad e1 _ == CmmLoad e2 _ = e1==e2
CmmReg r1 == CmmReg r2 = r1==r2
CmmRegOff r1 i1 == CmmRegOff r2 i2 = r1==r2 && i1==i2
CmmMachOp op1 es1 == CmmMachOp op2 es2 = op1==op2 && es1==es2
CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2
_e1 == _e2 = False
_e1 == _e2 = False
data CmmReg
= CmmLocal {-# UNPACK #-} !LocalReg
......@@ -75,14 +69,14 @@ data Area
-- See Note [Continuation BlockId] in CmmNode.
deriving (Eq, Ord)
{- Note [Old Area]
{- Note [Old Area]
~~~~~~~~~~~~~~~~~~
There is a single call area 'Old', allocated at the extreme old
end of the stack frame (ie just younger than the return address)
which holds:
* incoming (overflow) parameters,
* incoming (overflow) parameters,
* outgoing (overflow) parameter to tail calls,
* outgoing (overflow) result values
* outgoing (overflow) result values
* the update frame (if any)
Its size is the max of all these requirements. On entry, the stack
......@@ -93,22 +87,22 @@ End of note -}
data CmmLit
= CmmInt !Integer Width
-- Interpretation: the 2's complement representation of the value
-- is truncated to the specified size. This is easier than trying
-- to keep the value within range, because we don't know whether
-- it will be used as a signed or unsigned value (the CmmType doesn't
-- distinguish between signed & unsigned).
-- Interpretation: the 2's complement representation of the value
-- is truncated to the specified size. This is easier than trying
-- to keep the value within range, because we don't know whether
-- it will be used as a signed or unsigned value (the CmmType doesn't
-- distinguish between signed & unsigned).
| CmmFloat Rational Width
| CmmLabel CLabel -- Address of label
| CmmLabelOff CLabel Int -- Address of label + byte offset
| CmmLabel CLabel -- Address of label
| CmmLabelOff CLabel Int -- Address of label + byte offset
-- Due to limitations in the C backend, the following
-- MUST ONLY be used inside the info table indicated by label2
-- (label2 must be the info label), and label1 must be an
-- SRT, a slow entrypoint or a large bitmap (see the Mangler)
-- Don't use it at all unless tablesNextToCode.
-- It is also used inside the NCG during when generating
-- position-independent code.
-- position-independent code.
| CmmLabelDiffOff CLabel CLabel Int -- label1 - label2 + offset
| CmmBlock {-# UNPACK #-} !BlockId -- Code label
......@@ -118,31 +112,32 @@ data CmmLit
| CmmHighStackMark -- stands for the max stack space used during a procedure
deriving Eq
cmmExprType :: CmmExpr -> CmmType
cmmExprType (CmmLit lit) = cmmLitType lit
cmmExprType (CmmLoad _ rep) = rep
cmmExprType (CmmReg reg) = cmmRegType reg
cmmExprType (CmmMachOp op args) = machOpResultType op (map cmmExprType args)
cmmExprType (CmmRegOff reg _) = cmmRegType reg
cmmExprType (CmmStackSlot _ _) = bWord -- an address
cmmExprType :: DynFlags -> CmmExpr -> CmmType
cmmExprType dflags (CmmLit lit) = cmmLitType dflags lit
cmmExprType _ (CmmLoad _ rep) = rep
cmmExprType dflags (CmmReg reg) = cmmRegType dflags reg
cmmExprType dflags (CmmMachOp op args) = machOpResultType dflags op (map (cmmExprType dflags) args)
cmmExprType dflags (CmmRegOff reg _) = cmmRegType dflags reg
cmmExprType dflags (CmmStackSlot _ _) = bWord dflags -- an address
-- Careful though: what is stored at the stack slot may be bigger than
-- an address
cmmLitType :: CmmLit -> CmmType
cmmLitType (CmmInt _ width) = cmmBits width
cmmLitType (CmmFloat _ width) = cmmFloat width
cmmLitType (CmmLabel lbl) = cmmLabelType lbl
cmmLitType (CmmLabelOff lbl _) = cmmLabelType lbl
cmmLitType (CmmLabelDiffOff {}) = bWord
cmmLitType (CmmBlock _) = bWord
cmmLitType (CmmHighStackMark) = bWord
cmmLitType :: DynFlags -> CmmLit -> CmmType
cmmLitType _ (CmmInt _ width) = cmmBits width
cmmLitType _ (CmmFloat _ width) = cmmFloat width
cmmLitType dflags (CmmLabel lbl) = cmmLabelType dflags lbl
cmmLitType dflags (CmmLabelOff lbl _) = cmmLabelType dflags lbl
cmmLitType dflags (CmmLabelDiffOff {}) = bWord dflags
cmmLitType dflags (CmmBlock _) = bWord dflags
cmmLitType dflags (CmmHighStackMark) = bWord dflags
cmmLabelType :: CLabel -> CmmType
cmmLabelType lbl | isGcPtrLabel lbl = gcWord
| otherwise = bWord
cmmLabelType :: DynFlags -> CLabel -> CmmType
cmmLabelType dflags lbl
| isGcPtrLabel lbl = gcWord dflags
| otherwise = bWord dflags
cmmExprWidth :: CmmExpr -> Width
cmmExprWidth e = typeWidth (cmmExprType e)
cmmExprWidth :: DynFlags -> CmmExpr -> Width
cmmExprWidth dflags e = typeWidth (cmmExprType dflags e)
--------
--- Negation for conditional branches
......@@ -153,7 +148,7 @@ maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op
maybeInvertCmmExpr _ = Nothing
-----------------------------------------------------------------------------
-- Local registers
-- Local registers
-----------------------------------------------------------------------------
data LocalReg
......@@ -171,15 +166,15 @@ instance Ord LocalReg where
instance Uniquable LocalReg where
getUnique (LocalReg uniq _) = uniq
cmmRegType :: CmmReg -> CmmType
cmmRegType (CmmLocal reg) = localRegType reg
cmmRegType (CmmGlobal reg) = globalRegType reg
cmmRegType :: DynFlags -> CmmReg -> CmmType
cmmRegType _ (CmmLocal reg) = localRegType reg
cmmRegType dflags (CmmGlobal reg) = globalRegType dflags reg
localRegType :: LocalReg -> CmmType
localRegType (LocalReg _ rep) = rep
-----------------------------------------------------------------------------
-- Register-use information for expressions and other types
-- Register-use information for expressions and other types
-----------------------------------------------------------------------------
-- | Sets of local registers
......@@ -270,58 +265,58 @@ instance DefinerOfLocalRegs a => DefinerOfLocalRegs (Maybe a) where
-- Another reg utility
regUsedIn :: CmmReg -> CmmExpr -> Bool
_ `regUsedIn` CmmLit _ = False
reg `regUsedIn` CmmLoad e _ = reg `regUsedIn` e
reg `regUsedIn` CmmReg reg' = reg == reg'
_ `regUsedIn` CmmLit _ = False
reg `regUsedIn` CmmLoad e _ = reg `regUsedIn` e
reg `regUsedIn` CmmReg reg' = reg == reg'
reg `regUsedIn` CmmRegOff reg' _ = reg == reg'
reg `regUsedIn` CmmMachOp _ es = any (reg `regUsedIn`) es
_ `regUsedIn` CmmStackSlot _ _ = False
-----------------------------------------------------------------------------
-- Global STG registers
-- Global STG registers
-----------------------------------------------------------------------------
data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show )
-- TEMPORARY!!!
-- TEMPORARY!!!
-----------------------------------------------------------------------------
-- Global STG registers
-- Global STG registers
-----------------------------------------------------------------------------
vgcFlag :: CmmType -> VGcPtr
vgcFlag ty | isGcPtrType ty = VGcPtr
| otherwise = VNonGcPtr
| otherwise = VNonGcPtr
data GlobalReg
-- Argument and return registers
= VanillaReg -- pointers, unboxed ints and chars
{-# UNPACK #-} !Int -- its number
VGcPtr
= VanillaReg -- pointers, unboxed ints and chars
{-# UNPACK #-} !Int -- its number
VGcPtr
| FloatReg -- single-precision floating-point registers
{-# UNPACK #-} !Int -- its number
| FloatReg -- single-precision floating-point registers
{-# UNPACK #-} !Int -- its number
| DoubleReg -- double-precision floating-point registers
{-# UNPACK #-} !Int -- its number
| DoubleReg -- double-precision floating-point registers
{-# UNPACK #-} !Int -- its number
| LongReg -- long int registers (64-bit, really)
{-# UNPACK #-} !Int -- its number
| LongReg -- long int registers (64-bit, really)
{-# UNPACK #-} !Int -- its number
-- STG registers
| Sp -- Stack ptr; points to last occupied stack location.
| SpLim -- Stack limit
| Hp -- Heap ptr; points to last occupied heap location.
| HpLim -- Heap limit register
| Sp -- Stack ptr; points to last occupied stack location.
| SpLim -- Stack limit
| Hp -- Heap ptr; points to last occupied heap location.
| HpLim -- Heap limit register
| CCCS -- Current cost-centre stack
| CurrentTSO -- pointer to current thread's TSO
| CurrentNursery -- pointer to allocation area
| HpAlloc -- allocation count for heap check failure
| CurrentNursery -- pointer to allocation area
| HpAlloc -- allocation count for heap check failure
-- We keep the address of some commonly-called
-- functions in the register table, to keep code
-- size down:
-- We keep the address of some commonly-called
-- functions in the register table, to keep code
-- size down:
| EagerBlackholeInfo -- stg_EAGER_BLACKHOLE_info
| GCEnter1 -- stg_gc_enter_1
| GCFun -- stg_gc_fun
| GCEnter1 -- stg_gc_enter_1