Skip to content

GitLab

Glasgow Haskell Compiler
Glasgow Haskell Compiler
Commit 3a4c64c1 authored by ian@well-typed.com's avatar ian@well-typed.com
Browse files
Options

Make StgHalfWord a portable type 

It's now a newtyped Integer. Perhaps a newtyped Word32 would make more
sense, though.
parent 8244ec34
Hide whitespace changes
Inline Side-by-side
Showing with 164 additions and 132 deletions
compiler/cmm/CmmBuildInfoTables.hs
View file @ 3a4c64c1
......@@ -228,7 +228,7 @@ 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 == [fromInteger (fromStgHalfWord (srt_escape dflags))]
= do id <- getUniqueM
let srt_desc_lbl = mkLargeSRTLabel id
tbl = CmmData RelocatableReadOnlyData $
......@@ -236,9 +236,9 @@ to_SRT dflags top_srt off len bmp
( cmmLabelOffW dflags top_srt off
: mkWordCLit 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 (srt_escape dflags))
| otherwise
= return (Nothing, C_SRT top_srt off (fromIntegral (head bmp)))
= return (Nothing, C_SRT top_srt off (toStgHalfWord dflags (toInteger (head bmp))))
-- The fromIntegral converts to StgHalfWord
-- Gather CAF info for a procedure, but only if the procedure
......
compiler/cmm/CmmInfo.hs
View file @ 3a4c64c1
......@@ -177,19 +177,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 (fromIntegral ptrs) (fromIntegral 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 +210,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 +219,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 +239,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)
......
compiler/cmm/CmmParse.y
View file @ 3a4c64c1
......@@ -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 ',' INT ',' 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) $
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,10 @@ typenot8 :: { CmmType }
| 'float32' { f32 }
| 'float64' { f64 }
| 'gcptr' {% do dflags <- getDynFlags; return $ gcWord dflags }
stgHalfWord :: { StgHalfWord }
: INT {% do dflags <- getDynFlags; return $ toStgHalfWord dflags $1 }
{
section :: String -> Section
section "text" = Text
......
compiler/cmm/CmmUtils.hs
View file @ 3a4c64c1
......@@ -168,8 +168,8 @@ packHalfWordsCLit dflags lower_half_word upper_half_word
= if wORDS_BIGENDIAN dflags
then mkWordCLit dflags ((l `shiftL` hALF_WORD_SIZE_IN_BITS) .|. u)
else mkWordCLit dflags (l .|. (u `shiftL` hALF_WORD_SIZE_IN_BITS))
where l = fromIntegral lower_half_word
u = fromIntegral upper_half_word
where l = fromInteger (fromStgHalfWord lower_half_word)
u = fromInteger (fromStgHalfWord upper_half_word)
---------------------------------------------------
--
......
compiler/cmm/PprCmmDecl.hs
View file @ 3a4c64c1
......@@ -127,7 +127,7 @@ pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep
instance Outputable C_SRT where
ppr NoC_SRT = ptext (sLit "_no_srt_")
ppr (C_SRT label off bitmap)
= parens (ppr label <> comma <> ppr off <> comma <> text (show bitmap))
= parens (ppr label <> comma <> ppr off <> comma <> ppr bitmap)
instance Outputable ForeignHint where
ppr NoHint = empty
......
compiler/cmm/SMRep.lhs
View file @ 3a4c64c1
......@@ -11,7 +11,8 @@ Other modules should access this info through ClosureInfo.
\begin{code}
module SMRep (
-- * Words and bytes
StgWord, StgHalfWord,
StgWord,
StgHalfWord, fromStgHalfWord, toStgHalfWord,
hALF_WORD_SIZE, hALF_WORD_SIZE_IN_BITS,
WordOff, ByteOff,
roundUpToWords,
......@@ -46,6 +47,7 @@ module SMRep (
import DynFlags
import Outputable
import Platform
import FastString
import Data.Char( ord )
......@@ -71,16 +73,32 @@ roundUpToWords dflags n = (n + (wORD_SIZE dflags - 1)) .&. (complement (wORD_SIZ
StgWord is a type representing an StgWord on the target platform.
\begin{code}
newtype StgHalfWord = StgHalfWord Integer
deriving Eq
fromStgHalfWord :: StgHalfWord -> Integer
fromStgHalfWord (StgHalfWord i) = i
toStgHalfWord :: DynFlags -> Integer -> StgHalfWord
toStgHalfWord dflags i
= case platformWordSize (targetPlatform dflags) of
-- These conversions mean that things like toStgHalfWord (-1)
-- do the right thing
4 -> StgHalfWord (toInteger (fromInteger i :: Word16))
8 -> StgHalfWord (toInteger (fromInteger i :: Word32))
w -> panic ("toStgHalfWord: Unknown platformWordSize: " ++ show w)
instance Outputable StgHalfWord where
ppr (StgHalfWord i) = integer i
#if SIZEOF_HSWORD == 4
type StgWord = Word32
type StgHalfWord = Word16
hALF_WORD_SIZE :: ByteOff
hALF_WORD_SIZE = 2
hALF_WORD_SIZE_IN_BITS :: Int
hALF_WORD_SIZE_IN_BITS = 16
#elif SIZEOF_HSWORD == 8
type StgWord = Word64
type StgHalfWord = Word32
hALF_WORD_SIZE :: ByteOff
hALF_WORD_SIZE = 4
hALF_WORD_SIZE_IN_BITS :: Int
......@@ -277,49 +295,52 @@ closureTypeHdrSize dflags ty = case ty of
-- Defines CONSTR, CONSTR_1_0 etc
-- | Derives the RTS closure type from an 'SMRep'
rtsClosureType :: SMRep -> StgHalfWord
rtsClosureType (RTSRep ty _) = ty
rtsClosureType (HeapRep False 1 0 Constr{}) = CONSTR_1_0
rtsClosureType (HeapRep False 0 1 Constr{}) = CONSTR_0_1
rtsClosureType (HeapRep False 2 0 Constr{}) = CONSTR_2_0
rtsClosureType (HeapRep False 1 1 Constr{}) = CONSTR_1_1
rtsClosureType (HeapRep False 0 2 Constr{}) = CONSTR_0_2
rtsClosureType (HeapRep False _ _ Constr{}) = CONSTR
rtsClosureType (HeapRep False 1 0 Fun{}) = FUN_1_0
rtsClosureType (HeapRep False 0 1 Fun{}) = FUN_0_1
rtsClosureType (HeapRep False 2 0 Fun{}) = FUN_2_0
rtsClosureType (HeapRep False 1 1 Fun{}) = FUN_1_1
rtsClosureType (HeapRep False 0 2 Fun{}) = FUN_0_2
rtsClosureType (HeapRep False _ _ Fun{}) = FUN
rtsClosureType (HeapRep False 1 0 Thunk{}) = THUNK_1_0
rtsClosureType (HeapRep False 0 1 Thunk{}) = THUNK_0_1
rtsClosureType (HeapRep False 2 0 Thunk{}) = THUNK_2_0
rtsClosureType (HeapRep False 1 1 Thunk{}) = THUNK_1_1
rtsClosureType (HeapRep False 0 2 Thunk{}) = THUNK_0_2
rtsClosureType (HeapRep False _ _ Thunk{}) = THUNK
rtsClosureType (HeapRep False _ _ ThunkSelector{}) = THUNK_SELECTOR
-- Approximation: we use the CONSTR_NOCAF_STATIC type for static constructors
-- that have no pointer words only.
rtsClosureType (HeapRep True 0 _ Constr{}) = CONSTR_NOCAF_STATIC -- See isStaticNoCafCon below
rtsClosureType (HeapRep True _ _ Constr{}) = CONSTR_STATIC
rtsClosureType (HeapRep True _ _ Fun{}) = FUN_STATIC
rtsClosureType (HeapRep True _ _ Thunk{}) = THUNK_STATIC
rtsClosureType (HeapRep False _ _ BlackHole{}) = BLACKHOLE
rtsClosureType _ = panic "rtsClosureType"
rtsClosureType :: DynFlags -> SMRep -> StgHalfWord
rtsClosureType dflags rep
= toStgHalfWord dflags
$ case rep of
RTSRep ty _ -> fromStgHalfWord ty
HeapRep False 1 0 Constr{} -> CONSTR_1_0
HeapRep False 0 1 Constr{} -> CONSTR_0_1
HeapRep False 2 0 Constr{} -> CONSTR_2_0
HeapRep False 1 1 Constr{} -> CONSTR_1_1
HeapRep False 0 2 Constr{} -> CONSTR_0_2
HeapRep False _ _ Constr{} -> CONSTR
HeapRep False 1 0 Fun{} -> FUN_1_0
HeapRep False 0 1 Fun{} -> FUN_0_1
HeapRep False 2 0 Fun{} -> FUN_2_0
HeapRep False 1 1 Fun{} -> FUN_1_1
HeapRep False 0 2 Fun{} -> FUN_0_2
HeapRep False _ _ Fun{} -> FUN
HeapRep False 1 0 Thunk{} -> THUNK_1_0
HeapRep False 0 1 Thunk{} -> THUNK_0_1
HeapRep False 2 0 Thunk{} -> THUNK_2_0
HeapRep False 1 1 Thunk{} -> THUNK_1_1
HeapRep False 0 2 Thunk{} -> THUNK_0_2
HeapRep False _ _ Thunk{} -> THUNK
HeapRep False _ _ ThunkSelector{} -> THUNK_SELECTOR
-- Approximation: we use the CONSTR_NOCAF_STATIC type for static
-- constructors -- that have no pointer words only.
HeapRep True 0 _ Constr{} -> CONSTR_NOCAF_STATIC -- See isStaticNoCafCon below
HeapRep True _ _ Constr{} -> CONSTR_STATIC
HeapRep True _ _ Fun{} -> FUN_STATIC
HeapRep True _ _ Thunk{} -> THUNK_STATIC
HeapRep False _ _ BlackHole{} -> BLACKHOLE
_ -> panic "rtsClosureType"
-- We export these ones
rET_SMALL, rET_BIG, aRG_GEN, aRG_GEN_BIG :: StgHalfWord
rET_SMALL = RET_SMALL
rET_BIG = RET_BIG
aRG_GEN = ARG_GEN
aRG_GEN_BIG = ARG_GEN_BIG
rET_SMALL, rET_BIG, aRG_GEN, aRG_GEN_BIG :: DynFlags -> StgHalfWord
rET_SMALL dflags = toStgHalfWord dflags RET_SMALL
rET_BIG dflags = toStgHalfWord dflags RET_BIG
aRG_GEN dflags = toStgHalfWord dflags ARG_GEN
aRG_GEN_BIG dflags = toStgHalfWord dflags ARG_GEN_BIG
\end{code}
Note [Static NoCaf constructors]
......@@ -360,18 +381,18 @@ instance Outputable SMRep where
ppr (RTSRep ty rep) = ptext (sLit "tag:") <> ppr ty <+> ppr rep
instance Outputable ArgDescr where
ppr (ArgSpec n) = ptext (sLit "ArgSpec") <+> integer (toInteger n)
ppr (ArgSpec n) = ptext (sLit "ArgSpec") <+> ppr n
ppr (ArgGen ls) = ptext (sLit "ArgGen") <+> ppr ls
pprTypeInfo :: ClosureTypeInfo -> SDoc
pprTypeInfo (Constr tag descr)
= ptext (sLit "Con") <+>
braces (sep [ ptext (sLit "tag:") <+> integer (toInteger tag)
braces (sep [ ptext (sLit "tag:") <+> ppr tag
, ptext (sLit "descr:") <> text (show descr) ])
pprTypeInfo (Fun arity args)
= ptext (sLit "Fun") <+>
braces (sep [ ptext (sLit "arity:") <+> integer (toInteger arity)
braces (sep [ ptext (sLit "arity:") <+> ppr arity
, ptext (sLit ("fun_type:")) <+> ppr args ])
pprTypeInfo (ThunkSelector offset)
......
compiler/codeGen/CgCallConv.hs
View file @ 3a4c64c1
......@@ -70,7 +70,7 @@ mkArgDescr _nm args
let arg_bits = argBits dflags arg_reps
arg_reps = filter nonVoidArg (map idCgRep args)
-- Getting rid of voids eases matching of standard patterns
case stdPattern arg_reps of
case stdPattern dflags arg_reps of
Just spec_id -> return (ArgSpec spec_id)
Nothing -> return (ArgGen arg_bits)
......@@ -79,33 +79,36 @@ argBits _ [] = []
argBits dflags (PtrArg : args) = False : argBits dflags args
argBits dflags (arg : args) = take (cgRepSizeW dflags arg) (repeat True) ++ argBits dflags args
stdPattern :: [CgRep] -> Maybe StgHalfWord
stdPattern [] = Just ARG_NONE -- just void args, probably
stdPattern [PtrArg] = Just ARG_P
stdPattern [FloatArg] = Just ARG_F
stdPattern [DoubleArg] = Just ARG_D
stdPattern [LongArg] = Just ARG_L
stdPattern [NonPtrArg] = Just ARG_N
stdPattern [NonPtrArg,NonPtrArg] = Just ARG_NN
stdPattern [NonPtrArg,PtrArg] = Just ARG_NP
stdPattern [PtrArg,NonPtrArg] = Just ARG_PN
stdPattern [PtrArg,PtrArg] = Just ARG_PP
stdPattern [NonPtrArg,NonPtrArg,NonPtrArg] = Just ARG_NNN
stdPattern [NonPtrArg,NonPtrArg,PtrArg] = Just ARG_NNP
stdPattern [NonPtrArg,PtrArg,NonPtrArg] = Just ARG_NPN
stdPattern [NonPtrArg,PtrArg,PtrArg] = Just ARG_NPP
stdPattern [PtrArg,NonPtrArg,NonPtrArg] = Just ARG_PNN
stdPattern [PtrArg,NonPtrArg,PtrArg] = Just ARG_PNP
stdPattern [PtrArg,PtrArg,NonPtrArg] = Just ARG_PPN
stdPattern [PtrArg,PtrArg,PtrArg] = Just ARG_PPP
stdPattern [PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPP
stdPattern [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPPP
stdPattern [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPPPP
stdPattern _ = Nothing
stdPattern :: DynFlags -> [CgRep] -> Maybe StgHalfWord
stdPattern dflags reps
= fmap (toStgHalfWord dflags)
$ case reps of
[] -> Just ARG_NONE -- just void args, probably
[PtrArg] -> Just ARG_P
[FloatArg] -> Just ARG_F
[DoubleArg] -> Just ARG_D
[LongArg] -> Just ARG_L
[NonPtrArg] -> Just ARG_N
[NonPtrArg,NonPtrArg] -> Just ARG_NN
[NonPtrArg,PtrArg] -> Just ARG_NP
[PtrArg,NonPtrArg] -> Just ARG_PN
[PtrArg,PtrArg] -> Just ARG_PP
[NonPtrArg,NonPtrArg,NonPtrArg] -> Just ARG_NNN
[NonPtrArg,NonPtrArg,PtrArg] -> Just ARG_NNP
[NonPtrArg,PtrArg,NonPtrArg] -> Just ARG_NPN
[NonPtrArg,PtrArg,PtrArg] -> Just ARG_NPP
[PtrArg,NonPtrArg,NonPtrArg] -> Just ARG_PNN
[PtrArg,NonPtrArg,PtrArg] -> Just ARG_PNP
[PtrArg,PtrArg,NonPtrArg] -> Just ARG_PPN
[PtrArg,PtrArg,PtrArg] -> Just ARG_PPP
[PtrArg,PtrArg,PtrArg,PtrArg] -> Just ARG_PPPP
[PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] -> Just ARG_PPPPP
[PtrArg,PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] -> Just ARG_PPPPPP
_ -> Nothing
-------------------------------------------------------------------------
......
compiler/codeGen/CgUtils.hs
View file @ 3a4c64c1
......@@ -795,21 +795,21 @@ getSRTInfo = do
NoSRT -> return NoC_SRT
SRTEntries {} -> panic "getSRTInfo: SRTEntries. Perhaps you forgot to run SimplStg?"
SRT off len bmp
| len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
| len > hALF_WORD_SIZE_IN_BITS || bmp == [fromInteger (fromStgHalfWord (srt_escape dflags))]
-> do id <- newUnique
let srt_desc_lbl = mkLargeSRTLabel id
emitRODataLits "getSRTInfo" srt_desc_lbl
( cmmLabelOffW dflags srt_lbl off
: mkWordCLit dflags (fromIntegral len)
: map (mkWordCLit dflags) bmp)
return (C_SRT srt_desc_lbl 0 srt_escape)
return (C_SRT srt_desc_lbl 0 (srt_escape dflags))
| otherwise
-> return (C_SRT srt_lbl off (fromIntegral (head bmp)))
-> return (C_SRT srt_lbl off (toStgHalfWord dflags (toInteger (head bmp))))
-- The fromIntegral converts to StgHalfWord
srt_escape :: StgHalfWord
srt_escape = -1
srt_escape :: DynFlags -> StgHalfWord
srt_escape dflags = toStgHalfWord dflags (-1)
-- -----------------------------------------------------------------------------
--
......
compiler/codeGen/ClosureInfo.lhs
View file @ 3a4c64c1
......@@ -480,7 +480,7 @@ mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds srt_info descr
-- anything else gets eta expanded.
where
name = idName id
sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info)
sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType dflags lf_info)
nonptr_wds = tot_wds - ptr_wds
mkConInfo :: DynFlags
......@@ -492,7 +492,7 @@ mkConInfo dflags is_static data_con tot_wds ptr_wds
= ConInfo { closureSMRep = sm_rep,
closureCon = data_con }
where
sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info)
sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType dflags lf_info)
lf_info = mkConLFInfo data_con
nonptr_wds = tot_wds - ptr_wds
\end{code}
......@@ -526,12 +526,12 @@ closureNeedsUpdSpace cl_info = closureUpdReqd cl_info
%************************************************************************
\begin{code}
lfClosureType :: LambdaFormInfo -> ClosureTypeInfo
lfClosureType (LFReEntrant _ arity _ argd) = Fun (fromIntegral arity) argd
lfClosureType (LFCon con) = Constr (fromIntegral (dataConTagZ con))
(dataConIdentity con)
lfClosureType (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel
lfClosureType _ = panic "lfClosureType"
lfClosureType :: DynFlags -> LambdaFormInfo -> ClosureTypeInfo
lfClosureType dflags (LFReEntrant _ arity _ argd) = Fun (toStgHalfWord dflags (toInteger arity)) argd
lfClosureType dflags (LFCon con) = Constr (toStgHalfWord dflags (toInteger (dataConTagZ con)))
(dataConIdentity con)
lfClosureType _ (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel
lfClosureType _ _ = panic "lfClosureType"
thunkClosureType :: StandardFormInfo -> ClosureTypeInfo
thunkClosureType (SelectorThunk off) = ThunkSelector (fromIntegral off)
......
compiler/codeGen/StgCmmClosure.hs
View file @ 3a4c64c1
......@@ -353,12 +353,12 @@ isLFReEntrant _ = False
-- Choosing SM reps
-----------------------------------------------------------------------------
lfClosureType :: LambdaFormInfo -> ClosureTypeInfo
lfClosureType (LFReEntrant _ arity _ argd) = Fun (fromIntegral arity) argd
lfClosureType (LFCon con) = Constr (fromIntegral (dataConTagZ con))
(dataConIdentity con)
lfClosureType (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel
lfClosureType _ = panic "lfClosureType"
lfClosureType :: DynFlags -> LambdaFormInfo -> ClosureTypeInfo
lfClosureType dflags (LFReEntrant _ arity _ argd) = Fun (toStgHalfWord dflags (toInteger arity)) argd
lfClosureType dflags (LFCon con) = Constr (toStgHalfWord dflags (toInteger (dataConTagZ con)))
(dataConIdentity con)
lfClosureType _ (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel
lfClosureType _ _ = panic "lfClosureType"
thunkClosureType :: StandardFormInfo -> ClosureTypeInfo
thunkClosureType (SelectorThunk off) = ThunkSelector (fromIntegral off)
......@@ -687,7 +687,7 @@ mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr
closureProf = prof } -- (we don't have an SRT yet)
where
name = idName id
sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info)
sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType dflags lf_info)
prof = mkProfilingInfo dflags id val_descr
nonptr_wds = tot_wds - ptr_wds
......@@ -899,8 +899,8 @@ mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds
sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type
cl_type = Constr (fromIntegral (dataConTagZ data_con))
(dataConIdentity data_con)
cl_type = Constr (toStgHalfWord dflags (toInteger (dataConTagZ data_con)))
(dataConIdentity data_con)
prof | not (dopt Opt_SccProfilingOn dflags) = NoProfilingInfo
| otherwise = ProfilingInfo ty_descr val_descr
......
compiler/codeGen/StgCmmLayout.hs
View file @ 3a4c64c1
......@@ -469,7 +469,7 @@ mkArgDescr _nm args
let arg_bits = argBits dflags arg_reps
arg_reps = filter isNonV (map idArgRep args)
-- Getting rid of voids eases matching of standard patterns
case stdPattern arg_reps of
case stdPattern dflags arg_reps of
Just spec_id -> return (ArgSpec spec_id)
Nothing -> return (ArgGen arg_bits)
......@@ -480,9 +480,10 @@ argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True)
++ argBits dflags args
----------------------
stdPattern :: [ArgRep] -> Maybe StgHalfWord
stdPattern reps
= case reps of
stdPattern :: DynFlags -> [ArgRep] -> Maybe StgHalfWord
stdPattern dflags reps
= fmap (toStgHalfWord dflags)
$ case reps of
[] -> Just ARG_NONE -- just void args, probably
[N] -> Just ARG_N
[P] -> Just ARG_P
......
compiler/codeGen/StgCmmUtils.hs
View file @ 3a4c64c1
......@@ -720,5 +720,5 @@ assignTemp' e
emitAssign reg e
return (CmmReg reg)
srt_escape :: StgHalfWord
srt_escape = -1
srt_escape :: DynFlags -> StgHalfWord
srt_escape dflags = toStgHalfWord dflags (-1)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment