summaryrefslogtreecommitdiff
path: root/compiler/codeGen
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/codeGen')
-rw-r--r--compiler/codeGen/CgCallConv.hs59
-rw-r--r--compiler/codeGen/CgUtils.hs10
-rw-r--r--compiler/codeGen/ClosureInfo.lhs16
-rw-r--r--compiler/codeGen/StgCmmClosure.hs18
-rw-r--r--compiler/codeGen/StgCmmLayout.hs9
-rw-r--r--compiler/codeGen/StgCmmUtils.hs4
6 files changed, 60 insertions, 56 deletions
diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs
index 45edd64666..e468936a7a 100644
--- a/compiler/codeGen/CgCallConv.hs
+++ b/compiler/codeGen/CgCallConv.hs
@@ -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
-------------------------------------------------------------------------
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index c52c8a8c99..2abdb0e589 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -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)
-- -----------------------------------------------------------------------------
--
diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs
index 7a72a00602..f06ee7840c 100644
--- a/compiler/codeGen/ClosureInfo.lhs
+++ b/compiler/codeGen/ClosureInfo.lhs
@@ -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)
diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index 85346da205..2d767a6c6d 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -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
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index 142100e109..df4cef4a31 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -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
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index 4471b78151..f5dc2b6d31 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -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)
View Lorry Controller Status