Commit 74d65116 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Merge remote-tracking branch 'origin/master'

parents ad0139ab 2d96202a
......@@ -52,6 +52,7 @@ import FastString
import BasicTypes
import Binary
import Constants
import DynFlags
import UniqFM
import Util
......@@ -216,14 +217,14 @@ instance Ord Literal where
~~~~~~~~~~~~
\begin{code}
-- | Creates a 'Literal' of type @Int#@
mkMachInt :: Integer -> Literal
mkMachInt x = ASSERT2( inIntRange x, integer x )
MachInt x
mkMachInt :: DynFlags -> Integer -> Literal
mkMachInt dflags x = ASSERT2( inIntRange dflags x, integer x )
MachInt x
-- | Creates a 'Literal' of type @Word#@
mkMachWord :: Integer -> Literal
mkMachWord x = ASSERT2( inWordRange x, integer x )
MachWord x
mkMachWord :: DynFlags -> Integer -> Literal
mkMachWord dflags x = ASSERT2( inWordRange dflags x, integer x )
MachWord x
-- | Creates a 'Literal' of type @Int64#@
mkMachInt64 :: Integer -> Literal
......@@ -254,9 +255,9 @@ mkMachString s = MachStr (fastStringToFastBytes $ mkFastString s)
mkLitInteger :: Integer -> Type -> Literal
mkLitInteger = LitInteger
inIntRange, inWordRange :: Integer -> Bool
inIntRange x = x >= tARGET_MIN_INT && x <= tARGET_MAX_INT
inWordRange x = x >= 0 && x <= tARGET_MAX_WORD
inIntRange, inWordRange :: DynFlags -> Integer -> Bool
inIntRange dflags x = x >= tARGET_MIN_INT dflags && x <= tARGET_MAX_INT dflags
inWordRange dflags x = x >= 0 && x <= tARGET_MAX_WORD dflags
inCharRange :: Char -> Bool
inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR
......@@ -275,23 +276,23 @@ isZeroLit _ = False
Coercions
~~~~~~~~~
\begin{code}
word2IntLit, int2WordLit,
narrow8IntLit, narrow16IntLit, narrow32IntLit,
narrow8IntLit, narrow16IntLit, narrow32IntLit,
narrow8WordLit, narrow16WordLit, narrow32WordLit,
char2IntLit, int2CharLit,
float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit,
float2DoubleLit, double2FloatLit
:: Literal -> Literal
word2IntLit (MachWord w)
| w > tARGET_MAX_INT = MachInt (w - tARGET_MAX_WORD - 1)
| otherwise = MachInt w
word2IntLit l = pprPanic "word2IntLit" (ppr l)
word2IntLit, int2WordLit :: DynFlags -> Literal -> Literal
word2IntLit dflags (MachWord w)
| w > tARGET_MAX_INT dflags = MachInt (w - tARGET_MAX_WORD dflags - 1)
| otherwise = MachInt w
word2IntLit _ l = pprPanic "word2IntLit" (ppr l)
int2WordLit (MachInt i)
| i < 0 = MachWord (1 + tARGET_MAX_WORD + i) -- (-1) ---> tARGET_MAX_WORD
int2WordLit dflags (MachInt i)
| i < 0 = MachWord (1 + tARGET_MAX_WORD dflags + i) -- (-1) ---> tARGET_MAX_WORD
| otherwise = MachWord i
int2WordLit l = pprPanic "int2WordLit" (ppr l)
int2WordLit _ l = pprPanic "int2WordLit" (ppr l)
narrow8IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int8))
narrow8IntLit l = pprPanic "narrow8IntLit" (ppr l)
......@@ -343,17 +344,16 @@ litIsTrivial _ = True
-- | True if code space does not go bad if we duplicate this literal
-- Currently we treat it just like 'litIsTrivial'
litIsDupable :: Literal -> Bool
litIsDupable :: DynFlags -> Literal -> Bool
-- c.f. CoreUtils.exprIsDupable
litIsDupable (MachStr _) = False
litIsDupable (LitInteger i _) = inIntRange i
litIsDupable _ = True
litIsDupable _ (MachStr _) = False
litIsDupable dflags (LitInteger i _) = inIntRange dflags i
litIsDupable _ _ = True
litFitsInChar :: Literal -> Bool
litFitsInChar (MachInt i)
= fromInteger i <= ord minBound
&& fromInteger i >= ord maxBound
litFitsInChar _ = False
litFitsInChar (MachInt i) = i >= toInteger (ord minBound)
&& i <= toInteger (ord maxBound)
litFitsInChar _ = False
litIsLifted :: Literal -> Bool
litIsLifted (LitInteger {}) = True
......
......@@ -505,14 +505,14 @@ mkDictSelId no_unf name clas
-- varToCoreExpr needed for equality superclass selectors
-- sel a b d = case x of { MkC _ (g:a~b) _ -> CO g }
dictSelRule :: Int -> Arity
-> Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
dictSelRule :: Int -> Arity
-> DynFlags -> Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
-- Tries to persuade the argument to look like a constructor
-- application, using exprIsConApp_maybe, and then selects
-- from it
-- sel_i t1..tk (D t1..tk op1 ... opm) = opi
--
dictSelRule val_index n_ty_args _ id_unf args
dictSelRule val_index n_ty_args _ _ id_unf args
| (dict_arg : _) <- drop n_ty_args args
, Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg
= Just (con_args !! val_index)
......@@ -935,12 +935,13 @@ seqId = pcMiscPrelId seqName ty info
, ru_try = match_seq_of_cast
}
match_seq_of_cast :: Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
match_seq_of_cast :: DynFlags -> Id -> IdUnfoldingFun -> [CoreExpr]
-> Maybe CoreExpr
-- See Note [Built-in RULES for seq]
match_seq_of_cast _ _ [Type _, Type res_ty, Cast scrut co, expr]
match_seq_of_cast _ _ _ [Type _, Type res_ty, Cast scrut co, expr]
= Just (Var seqId `mkApps` [Type (pFst (coercionKind co)), Type res_ty,
scrut, expr])
match_seq_of_cast _ _ _ = Nothing
match_seq_of_cast _ _ _ _ = Nothing
------------------------------------------------
lazyId :: Id -- See Note [lazyId magic]
......
......@@ -39,12 +39,12 @@ type Bitmap = [StgWord]
-- | Make a bitmap from a sequence of bits
mkBitmap :: DynFlags -> [Bool] -> Bitmap
mkBitmap _ [] = []
mkBitmap dflags stuff = chunkToBitmap chunk : mkBitmap dflags rest
mkBitmap dflags stuff = chunkToBitmap dflags chunk : mkBitmap dflags rest
where (chunk, rest) = splitAt (wORD_SIZE_IN_BITS dflags) stuff
chunkToBitmap :: [Bool] -> StgWord
chunkToBitmap chunk =
foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ]
chunkToBitmap :: DynFlags -> [Bool] -> StgWord
chunkToBitmap dflags chunk =
foldr (.|.) (toStgWord dflags 0) [ toStgWord dflags 1 `shiftL` n | (True,n) <- zip chunk [0..] ]
-- | Make a bitmap where the slots specified are the /ones/ in the bitmap.
-- eg. @[0,1,3], size 4 ==> 0xb@.
......@@ -54,7 +54,7 @@ intsToBitmap :: DynFlags -> Int -> [Int] -> Bitmap
intsToBitmap dflags size slots{- must be sorted -}
| size <= 0 = []
| otherwise =
(foldr (.|.) 0 (map (1 `shiftL`) these)) :
(foldr (.|.) (toStgWord dflags 0) (map (toStgWord dflags 1 `shiftL`) these)) :
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
......@@ -68,12 +68,12 @@ intsToReverseBitmap :: DynFlags -> Int -> [Int] -> Bitmap
intsToReverseBitmap dflags size slots{- must be sorted -}
| size <= 0 = []
| otherwise =
(foldr xor init (map (1 `shiftL`) these)) :
(foldr xor (toStgWord dflags init) (map (toStgWord dflags 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
| size >= wORD_SIZE_IN_BITS dflags = -1
| otherwise = (1 `shiftL` size) - 1
{- |
......
......@@ -13,7 +13,7 @@ module CLabel (
mkClosureLabel,
mkSRTLabel,
mkModSRTLabel,
mkTopSRTLabel,
mkInfoTableLabel,
mkEntryLabel,
mkSlowEntryLabel,
......@@ -120,8 +120,6 @@ import DynFlags
import Platform
import UniqSet
import Data.Maybe (isJust)
-- -----------------------------------------------------------------------------
-- The CLabel type
......@@ -218,7 +216,7 @@ data CLabel
| HpcTicksLabel Module
-- | Static reference table
| SRTLabel (Maybe Module) !Unique
| SRTLabel !Unique
-- | Label of an StgLargeSRT
| LargeSRTLabel
......@@ -355,8 +353,8 @@ data DynamicLinkerLabelInfo
mkSlowEntryLabel :: Name -> CafInfo -> CLabel
mkSlowEntryLabel name c = IdLabel name c Slow
mkModSRTLabel :: Maybe Module -> Unique -> CLabel
mkModSRTLabel mb_mod u = SRTLabel mb_mod u
mkTopSRTLabel :: Unique -> CLabel
mkTopSRTLabel u = SRTLabel u
mkSRTLabel :: Name -> CafInfo -> CLabel
mkRednCountsLabel :: Name -> CafInfo -> CLabel
......@@ -590,9 +588,9 @@ hasCAF _ = False
needsCDecl :: CLabel -> Bool
-- False <=> it's pre-declared; don't bother
-- don't bother declaring SRT & Bitmap labels, we always make sure
-- don't bother declaring Bitmap labels, we always make sure
-- they are defined before use.
needsCDecl (SRTLabel _ _) = False
needsCDecl (SRTLabel _) = True
needsCDecl (LargeSRTLabel _) = False
needsCDecl (LargeBitmapLabel _) = False
needsCDecl (IdLabel _ _ _) = True
......@@ -740,7 +738,7 @@ externallyVisibleCLabel (CCS_Label _) = True
externallyVisibleCLabel (DynamicLinkerLabel _ _) = False
externallyVisibleCLabel (HpcTicksLabel _) = True
externallyVisibleCLabel (LargeBitmapLabel _) = False
externallyVisibleCLabel (SRTLabel mb_mod _) = isJust mb_mod
externallyVisibleCLabel (SRTLabel _) = False
externallyVisibleCLabel (LargeSRTLabel _) = False
externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel"
externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer"
......@@ -788,7 +786,7 @@ labelType (RtsLabel (RtsApFast _)) = CodeLabel
labelType (CaseLabel _ CaseReturnInfo) = DataLabel
labelType (CaseLabel _ _) = CodeLabel
labelType (PlainModuleInitLabel _) = CodeLabel
labelType (SRTLabel _ _) = CodeLabel
labelType (SRTLabel _) = DataLabel
labelType (LargeSRTLabel _) = DataLabel
labelType (LargeBitmapLabel _) = DataLabel
labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel
......@@ -991,10 +989,8 @@ pprCLbl (CaseLabel u (CaseAlt tag))
pprCLbl (CaseLabel u CaseDefault)
= hcat [pprUnique u, ptext (sLit "_dflt")]
pprCLbl (SRTLabel mb_mod u)
= pp_mod <> pprUnique u <> pp_cSEP <> ptext (sLit "srt")
where pp_mod | Just mod <- mb_mod = ppr mod <> pp_cSEP
| otherwise = empty
pprCLbl (SRTLabel u)
= pprUnique u <> pp_cSEP <> ptext (sLit "srt")
pprCLbl (LargeSRTLabel u) = pprUnique u <> pp_cSEP <> ptext (sLit "srtd")
pprCLbl (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLit "btm")
......
......@@ -14,28 +14,23 @@
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
module CmmBuildInfoTables
( CAFSet, CAFEnv, cafAnal
, doSRTs, TopSRT, emptySRT, srtToData )
, doSRTs, TopSRT, emptySRT, isEmptySRT, srtToData )
where
#include "HsVersions.h"
-- These should not be imported here!
import StgCmmUtils
import Hoopl
import Digraph
import qualified Prelude as P
import Prelude hiding (succ)
import BlockId
import Bitmap
import CLabel
import PprCmmDecl ()
import Cmm
import CmmUtils
import CmmInfo
import Data.List
import DynFlags
import Maybes
import Module
import Outputable
import SMRep
import UniqSupply
......@@ -47,6 +42,9 @@ import Data.Set (Set)
import qualified Data.Set as Set
import Control.Monad
import qualified Prelude as P
import Prelude hiding (succ)
foldSet :: (a -> b -> b) -> b -> Set a -> b
foldSet = Set.foldr
......@@ -137,11 +135,14 @@ instance Outputable TopSRT where
<+> ppr elts
<+> ppr eltmap
emptySRT :: MonadUnique m => Maybe Module -> m TopSRT
emptySRT mb_mod =
do top_lbl <- getUniqueM >>= \ u -> return $ mkModSRTLabel mb_mod u
emptySRT :: MonadUnique m => m TopSRT
emptySRT =
do top_lbl <- getUniqueM >>= \ u -> return $ mkTopSRTLabel u
return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = Map.empty }
isEmptySRT :: TopSRT -> Bool
isEmptySRT srt = null (rev_elts srt)
cafMember :: TopSRT -> CLabel -> Bool
cafMember srt lbl = Map.member lbl (elt_map srt)
......@@ -228,17 +229,17 @@ maxBmpSize dflags = widthInBits (wordWidth dflags) `div` 2
-- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT.
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]
| len > maxBmpSize dflags || bmp == [toStgWord dflags (fromStgHalfWord (srtEscape dflags))]
= do id <- getUniqueM
let srt_desc_lbl = mkLargeSRTLabel id
tbl = CmmData RelocatableReadOnlyData $
Statics srt_desc_lbl $ map CmmStaticLit
( cmmLabelOffW dflags top_srt off
: mkWordCLit dflags (fromIntegral len)
: mkWordCLit dflags (toStgWord dflags (fromIntegral len))
: map (mkWordCLit dflags) bmp)
return (Just tbl, C_SRT srt_desc_lbl 0 srt_escape)
return (Just tbl, C_SRT srt_desc_lbl 0 (srtEscape dflags))
| otherwise
= return (Nothing, C_SRT top_srt off (fromIntegral (head bmp)))
= return (Nothing, C_SRT top_srt off (toStgHalfWord dflags (fromStgWord (head bmp))))
-- The fromIntegral converts to StgHalfWord
-- Gather CAF info for a procedure, but only if the procedure
......
......@@ -9,6 +9,7 @@ module CmmInfo (
mkEmptyContInfoTable,
cmmToRawCmm,
mkInfoTable,
srtEscape
) where
#include "HsVersions.h"
......@@ -177,19 +178,22 @@ mkInfoTableContents dflags
; let
std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit
rts_tag | Just tag <- mb_rts_tag = tag
| null liveness_data = rET_SMALL -- Fits in extra_bits
| otherwise = rET_BIG -- Does not; extra_bits is
-- a label
| null liveness_data = rET_SMALL dflags -- Fits in extra_bits
| otherwise = rET_BIG dflags -- Does not; extra_bits is
-- a label
; return (prof_data ++ liveness_data, (std_info, srt_label)) }
| HeapRep _ ptrs nonptrs closure_type <- smrep
= do { let layout = packHalfWordsCLit dflags ptrs nonptrs
= do { let layout = packHalfWordsCLit
dflags
(toStgHalfWord dflags (toInteger ptrs))
(toStgHalfWord dflags (toInteger nonptrs))
; (prof_lits, prof_data) <- mkProfLits dflags prof
; let (srt_label, srt_bitmap) = mkSRTLit dflags srt
; (mb_srt_field, mb_layout, extra_bits, ct_data)
<- mk_pieces closure_type srt_label
; let std_info = mkStdInfoTable dflags prof_lits
(mb_rts_tag `orElse` rtsClosureType smrep)
(mb_rts_tag `orElse` rtsClosureType dflags smrep)
(mb_srt_field `orElse` srt_bitmap)
(mb_layout `orElse` layout)
; return (prof_data ++ ct_data, (std_info, extra_bits)) }
......@@ -207,7 +211,7 @@ mkInfoTableContents dflags
= return (Nothing, Nothing, srt_label, [])
mk_pieces (ThunkSelector offset) _no_srt
= return (Just 0, Just (mkWordCLit dflags offset), [], [])
= return (Just (toStgHalfWord dflags 0), Just (mkWordCLit dflags offset), [], [])
-- Layout known (one free var); we use the layout field for offset
mk_pieces (Fun arity (ArgSpec fun_type)) srt_label
......@@ -216,8 +220,8 @@ mkInfoTableContents dflags
mk_pieces (Fun arity (ArgGen arg_bits)) srt_label
= do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits
; let fun_type | null liveness_data = aRG_GEN
| otherwise = aRG_GEN_BIG
; let fun_type | null liveness_data = aRG_GEN dflags
| otherwise = aRG_GEN_BIG dflags
extra_bits = [ packHalfWordsCLit dflags fun_type arity
, srt_lit, liveness_lit, slow_entry ]
; return (Nothing, Nothing, extra_bits, liveness_data) }
......@@ -236,7 +240,7 @@ mkSRTLit :: DynFlags
-> C_SRT
-> ([CmmLit], -- srt_label, if any
StgHalfWord) -- srt_bitmap
mkSRTLit _ NoC_SRT = ([], 0)
mkSRTLit dflags NoC_SRT = ([], toStgHalfWord dflags 0)
mkSRTLit dflags (C_SRT lbl off bitmap) = ([cmmLabelOffW dflags lbl off], bitmap)
......@@ -318,13 +322,13 @@ mkLivenessBits dflags liveness
bitmap = mkBitmap dflags liveness
small_bitmap = case bitmap of
[] -> 0
[] -> toStgWord dflags 0
[b] -> b
_ -> panic "mkLiveness"
bitmap_word = fromIntegral n_bits
bitmap_word = toStgWord dflags (fromIntegral n_bits)
.|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags)
lits = mkWordCLit dflags (fromIntegral n_bits) : map (mkWordCLit dflags) bitmap
lits = mkWordCLit dflags (toStgWord dflags (fromIntegral n_bits)) : map (mkWordCLit dflags) bitmap
-- The first word is the size. The structure must match
-- StgLargeBitmap in includes/rts/storage/InfoTable.h
......@@ -381,3 +385,9 @@ newStringLit bytes
= do { uniq <- getUniqueUs
; return (mkByteStringCLit uniq bytes) }
-- Misc utils
-- | Value of the srt field of an info table when using an StgLargeSRT
srtEscape :: DynFlags -> StgHalfWord
srtEscape dflags = toStgHalfWord dflags (-1)
......@@ -3,8 +3,9 @@ module CmmLayoutStack (
cmmLayoutStack, setInfoTableStackMap
) where
import StgCmmUtils ( callerSaveVolatileRegs ) -- XXX
import StgCmmForeign ( saveThreadState, loadThreadState ) -- XXX
import StgCmmUtils ( callerSaveVolatileRegs ) -- XXX layering violation
import StgCmmForeign ( saveThreadState, loadThreadState ) -- XXX layering violation
import StgCmmLayout ( entryCode ) -- XXX layering violation
import Cmm
import BlockId
......@@ -939,7 +940,8 @@ lowerSafeForeignCall dflags block
-- received an exception during the call, then the stack might be
-- different. Hence we continue by jumping to the top stack frame,
-- not by jumping to succ.
jump = CmmCall { cml_target = CmmLoad (CmmReg spReg) (bWord dflags)
jump = CmmCall { cml_target = entryCode dflags $
CmmLoad (CmmReg spReg) (bWord dflags)
, cml_cont = Just succ
, cml_args_regs = regs
, cml_args = widthInBytes (wordWidth dflags)
......
This diff is collapsed.
......@@ -259,12 +259,12 @@ cmmproc :: { ExtCode }
code (emitProc Nothing (mkCmmCodeLabel pkg $1) formals blks) }
info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' stgHalfWord ',' STRING ',' STRING ')'
-- ptrs, nptrs, closure type, description, type
{% withThisPackage $ \pkg ->
do dflags <- getDynFlags
let prof = profilingInfo dflags $11 $13
rep = mkRTSRep (fromIntegral $9) $
rep = mkRTSRep $9 $
mkHeapRep dflags False (fromIntegral $5)
(fromIntegral $7) Thunk
-- not really Thunk, but that makes the info table
......@@ -275,14 +275,14 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
, cit_prof = prof, cit_srt = NoC_SRT },
[]) }
| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' stgHalfWord ',' STRING ',' STRING ',' stgHalfWord ')'
-- ptrs, nptrs, closure type, description, type, fun type
{% withThisPackage $ \pkg ->
do dflags <- getDynFlags
let prof = profilingInfo dflags $11 $13
ty = Fun 0 (ArgSpec (fromIntegral $15))
ty = Fun (toStgHalfWord dflags 0) (ArgSpec $15)
-- Arity zero, arg_type $15
rep = mkRTSRep (fromIntegral $9) $
rep = mkRTSRep $9 $
mkHeapRep dflags False (fromIntegral $5)
(fromIntegral $7) ty
return (mkCmmEntryLabel pkg $3,
......@@ -293,14 +293,14 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
-- we leave most of the fields zero here. This is only used
-- to generate the BCO info table in the RTS at the moment.
| 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
| 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' stgHalfWord ',' stgHalfWord ',' STRING ',' STRING ')'
-- ptrs, nptrs, tag, closure type, description, type
{% withThisPackage $ \pkg ->
do dflags <- getDynFlags
let prof = profilingInfo dflags $13 $15
ty = Constr (fromIntegral $9) -- Tag
ty = Constr $9 -- Tag
(stringToWord8s $13)
rep = mkRTSRep (fromIntegral $11) $
rep = mkRTSRep $11 $
mkHeapRep dflags False (fromIntegral $5)
(fromIntegral $7) ty
return (mkCmmEntryLabel pkg $3,
......@@ -312,13 +312,13 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
-- If profiling is on, this string gets duplicated,
-- but that's the way the old code did it we can fix it some other time.
| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
| 'INFO_TABLE_SELECTOR' '(' NAME ',' stgWord ',' stgHalfWord ',' STRING ',' STRING ')'
-- selector, closure type, description, type
{% withThisPackage $ \pkg ->
do dflags <- getDynFlags
let prof = profilingInfo dflags $9 $11
ty = ThunkSelector (fromIntegral $5)
rep = mkRTSRep (fromIntegral $7) $
ty = ThunkSelector $5
rep = mkRTSRep $7 $
mkHeapRep dflags False 0 0 ty
return (mkCmmEntryLabel pkg $3,
CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
......@@ -326,25 +326,25 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
, cit_prof = prof, cit_srt = NoC_SRT },
[]) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ')'
| 'INFO_TABLE_RET' '(' NAME ',' stgHalfWord ')'
-- closure type (no live regs)
{% withThisPackage $ \pkg ->
do let prof = NoProfilingInfo
rep = mkRTSRep (fromIntegral $5) $ mkStackRep []
rep = mkRTSRep $5 $ mkStackRep []
return (mkCmmRetLabel pkg $3,
CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
, cit_rep = rep
, cit_prof = prof, cit_srt = NoC_SRT },
[]) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals_without_hints0 ')'
| 'INFO_TABLE_RET' '(' NAME ',' stgHalfWord ',' formals_without_hints0 ')'
-- closure type, live regs
{% withThisPackage $ \pkg ->
do dflags <- getDynFlags
live <- sequence (map (liftM Just) $7)
let prof = NoProfilingInfo
bitmap = mkLiveness dflags live
rep = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap
rep = mkRTSRep $5 $ mkStackRep bitmap
return (mkCmmRetLabel pkg $3,
CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
, cit_rep = rep
......@@ -613,6 +613,13 @@ typenot8 :: { CmmType }
| 'float32' { f32 }
| 'float64' { f64 }
| 'gcptr' {% do dflags <- getDynFlags; return $ gcWord dflags }
stgWord :: { StgWord }
: INT {% do dflags <- getDynFlags; return $ toStgWord dflags $1 }
stgHalfWord :: { StgHalfWord }
: INT {% do dflags <- getDynFlags; return $ toStgHalfWord dflags $1 }
{
section :: String -> Section
section "text" = Text
......
......@@ -82,7 +82,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
return call_pps
let noncall_pps = proc_points `setDifference` call_pps
when (not (setNull noncall_pps)) $
when (not (setNull noncall_pps) && dopt Opt_D_dump_cmmz dflags) $
pprTrace "Non-call proc points: " (ppr noncall_pps) $ return ()
----------- Sink and inline assignments *before* stack layout -----------
......@@ -114,7 +114,8 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
procPointAnalysis proc_points g
dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" pp_map
gs <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
splitAtProcPoints l call_pps proc_points pp_map (CmmProc h l g)
splitAtProcPoints dflags l call_pps proc_points pp_map
(CmmProc h l g)
dumps Opt_D_dump_cmmz_split "Post splitting" gs
------------- Populate info tables with stack info -----------------
......
......@@ -11,6 +11,7 @@ where
import Prelude hiding (last, unzip, succ, zip)
import DynFlags
import BlockId
import CLabel
import Cmm
......@@ -26,8 +27,6 @@ import UniqSupply
import Hoopl
import qualified Data.Map as Map
-- Compute a minimal set of proc points for a control-flow graph.
-- Determine a protocol for each proc point (which live variables will
......@@ -207,9 +206,9 @@ extendPPSet platform g blocks procPoints =
-- Input invariant: A block should only be reachable from a single ProcPoint.
-- ToDo: use the _ret naming convention that the old code generator
-- used. -- EZY
splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
CmmDecl -> UniqSM [CmmDecl]
splitAtProcPoints entry_label callPPs procPoints procMap
splitAtProcPoints dflags entry_label callPPs procPoints procMap
(CmmProc (TopInfo {info_tbls = info_tbls})
top_l g@(CmmGraph {g_entry=entry})) =
do -- Build a map from procpoints to the blocks they reach
......@@ -234,12 +233,15 @@ splitAtProcPoints entry_label callPPs procPoints procMap
-- * Labels for the info tables of their new procedures (only if
-- the proc point is a callPP)
-- Due to common blockification, we may overestimate the set of procpoints.
let add_label map pp = Map.insert pp lbls map
let add_label map pp = mapInsert pp lbls map
where lbls | pp == entry = (entry_label, Just (toInfoLbl entry_label))
| otherwise = (blockLbl pp, guard (setMember pp callPPs) >>
Just (infoTblLbl pp))
procLabels = foldl add_label Map.empty
procLabels :: LabelMap (CLabel, Maybe CLabel)
procLabels = foldl add_label mapEmpty
(filter (flip mapMember (toBlockMap g)) (setElems procPoints))
-- In each new graph, add blocks jumping off to the new procedures,
-- and replace branches to procpoints with branches to the jump-off blocks
let add_jump_block (env, bs) (pp, l) =
......@@ -259,8 +261,17 @@ splitAtProcPoints entry_label callPPs procPoints procMap
CmmCondBranch _ ti fi -> add_if_pp ti (add_if_pp fi rst)
CmmSwitch _ tbl -> foldr add_if_pp rst (catMaybes tbl)
_ -> rst
add_if_pp id rst = case Map.lookup id procLabels of
Just (lbl, mb_info_lbl) -> (id, mb_info_lbl `orElse` lbl) : rst
-- when jumping to a PP that has an info table, if
-- tablesNextToCode is off we must jump to the entry
-- label instead.
jump_label (Just info_lbl) _
| tablesNextToCode dflags = info_lbl
| otherwise = toEntryLbl info_lbl
jump_label Nothing block_lbl = block_lbl
add_if_pp id rst = case mapLookup id procLabels of
Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst
Nothing -> rst
(jumpEnv, jumpBlocks) <-
foldM add_jump_block (mapEmpty, []) needed_jumps
......@@ -274,8 +285,10 @@ splitAtProcPoints entry_label callPPs procPoints procMap
let g' = ofBlockMap ppId blockEnv'''
-- pprTrace "g' pre jumps" (ppr g') $ do
return (mapInsert ppId g' newGraphEnv)
graphEnv <- foldM add_jumps emptyBlockMap $ mapToList graphEnv
let to_proc (bid, g) = case expectJust "pp label" $ Map.lookup bid procLabels of
let to_proc (bid, g) = case expectJust "pp label" $ mapLookup bid procLabels of
(lbl, Just info_lbl)
| bid == entry
-> CmmProc (TopInfo {info_tbls=info_tbls, stack_info=stack_info})
......@@ -295,7 +308,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap
replacePPIds g = {-# SCC "replacePPIds" #-}
mapGraphNodes (id, mapExp repl, mapExp repl) g
where repl e@(CmmLit (CmmBlock bid)) =
case Map.lookup bid procLabels of
case mapLookup bid procLabels of
Just (_, Just info_lbl) -> CmmLit (CmmLabel info_lbl)
_ -> e
repl e = e
......@@ -312,7 +325,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap
return -- pprTrace "procLabels" (ppr procLabels)
-- pprTrace "splitting graphs" (ppr procs)
procs
splitAtProcPoints _ _ _ _ t@(CmmData _ _) = return [t]
splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]