summaryrefslogtreecommitdiff
path: root/compiler/codeGen
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/codeGen')
-rw-r--r--compiler/codeGen/CgCon.lhs8
-rw-r--r--compiler/codeGen/CgExpr.lhs2
-rw-r--r--compiler/codeGen/CgForeignCall.hs3
-rw-r--r--compiler/codeGen/ClosureInfo.lhs35
-rw-r--r--compiler/codeGen/StgCmm.hs4
-rw-r--r--compiler/codeGen/StgCmmClosure.hs33
-rw-r--r--compiler/codeGen/StgCmmCon.hs2
-rw-r--r--compiler/codeGen/StgCmmExpr.hs2
-rw-r--r--compiler/codeGen/StgCmmForeign.hs3
-rw-r--r--compiler/codeGen/StgCmmLayout.hs8
-rw-r--r--compiler/codeGen/StgCmmTicky.hs6
-rw-r--r--compiler/codeGen/StgCmmUtils.hs2
12 files changed, 61 insertions, 47 deletions
diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs
index 9049504dca..9ad8d13b5f 100644
--- a/compiler/codeGen/CgCon.lhs
+++ b/compiler/codeGen/CgCon.lhs
@@ -72,7 +72,7 @@ cgTopRhsCon id con args
; when (platformOS (targetPlatform dflags) == OSMinGW32) $
-- Windows DLLs have a problem with static cross-DLL refs.
ASSERT( not (isDllConApp dflags con args) ) return ()
- ; ASSERT( args `lengthIs` dataConRepArity con ) return ()
+ ; ASSERT( args `lengthIs` dataConRepRepArity con ) return ()
-- LAY IT OUT
; amodes <- getArgAmodes args
@@ -324,7 +324,7 @@ cgReturnDataCon con amodes
-- for it to be marked as "used" for LDV profiling.
| opt_SccProfilingOn = build_it_then enter_it
| otherwise
- = ASSERT( amodes `lengthIs` dataConRepArity con )
+ = ASSERT( amodes `lengthIs` dataConRepRepArity con )
do { EndOfBlockInfo _ sequel <- getEndOfBlockInfo
; case sequel of
CaseAlts _ (Just (alts, deflt_lbl)) bndr
@@ -466,8 +466,8 @@ cgDataCon data_con
; ldvEnter (CmmReg nodeReg)
; body_code }
- arg_reps :: [(CgRep, Type)]
- arg_reps = [(typeCgRep ty, ty) | ty <- dataConRepArgTys data_con]
+ arg_reps :: [(CgRep, UnaryType)]
+ arg_reps = [(typeCgRep rep_ty, rep_ty) | ty <- dataConRepArgTys data_con, rep_ty <- flattenRepType (repType ty)]
body_code = do {
-- NB: We don't set CC when entering data (WDP 94/06)
diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs
index cb3a86ef7f..f935f95726 100644
--- a/compiler/codeGen/CgExpr.lhs
+++ b/compiler/codeGen/CgExpr.lhs
@@ -480,7 +480,7 @@ Little helper for primitives that return unboxed tuples.
newUnboxedTupleRegs :: Type -> FCode ([CgRep], [LocalReg], [ForeignHint])
newUnboxedTupleRegs res_ty =
let
- ty_args = tyConAppArgs (repType res_ty)
+ UbxTupleRep ty_args = repType res_ty
(reps,hints) = unzip [ (rep, typeForeignHint ty) | ty <- ty_args,
let rep = typeCgRep ty,
nonVoidArg rep ]
diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs
index 16e77eca35..600bbbe0df 100644
--- a/compiler/codeGen/CgForeignCall.hs
+++ b/compiler/codeGen/CgForeignCall.hs
@@ -311,4 +311,5 @@ shimForeignCallArg arg expr
| otherwise = expr
where
-- should be a tycon app, since this is a foreign call
- tycon = tyConAppTyCon (repType (stgArgType arg))
+ UnaryRep rep_ty = repType (stgArgType arg)
+ tycon = tyConAppTyCon rep_ty
diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs
index d8fd07fead..dbfad986a7 100644
--- a/compiler/codeGen/ClosureInfo.lhs
+++ b/compiler/codeGen/ClosureInfo.lhs
@@ -20,6 +20,8 @@ the STG paper.
-- for details
module ClosureInfo (
+ idRepArity,
+
ClosureInfo(..), LambdaFormInfo(..), -- would be abstract but
StandardFormInfo(..), -- mkCmmInfo looks inside
SMRep,
@@ -156,7 +158,7 @@ ClosureInfo contains a LambdaFormInfo.
data LambdaFormInfo
= LFReEntrant -- Reentrant closure (a function)
TopLevelFlag -- True if top level
- !Int -- Arity. Invariant: always > 0
+ !RepArity -- Arity. Invariant: always > 0
!Bool -- True <=> no fvs
ArgDescr -- Argument descriptor (should reall be in ClosureInfo)
@@ -180,7 +182,7 @@ data LambdaFormInfo
| LFLetNoEscape -- See LetNoEscape module for precise description of
-- these "lets".
- !Int -- arity;
+ !RepArity -- arity;
| LFBlackHole -- Used for the closures allocated to hold the result
-- of a CAF. We want the target of the update frame to
@@ -211,7 +213,7 @@ data StandardFormInfo
-- The code for the thunk just pushes x2..xn on the stack and enters x1.
-- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
-- in the RTS to save space.
- Int -- Arity, n
+ RepArity -- Arity, n
\end{code}
@@ -288,7 +290,7 @@ idCgRep x = typeCgRep . idType $ x
tyConCgRep :: TyCon -> CgRep
tyConCgRep = primRepToCgRep . tyConPrimRep
-typeCgRep :: Type -> CgRep
+typeCgRep :: UnaryType -> CgRep
typeCgRep = primRepToCgRep . typePrimRep
\end{code}
@@ -384,9 +386,12 @@ might_be_a_function :: Type -> Bool
-- Return False only if we are *sure* it's a data type
-- Look through newtypes etc as much as poss
might_be_a_function ty
- = case tyConAppTyCon_maybe (repType ty) of
- Just tc -> not (isDataTyCon tc)
- Nothing -> True
+ | UnaryRep rep <- repType ty
+ , Just tc <- tyConAppTyCon_maybe rep
+ , isDataTyCon tc
+ = False
+ | otherwise
+ = True
\end{code}
@mkConLFInfo@ is similar, for constructors.
@@ -404,7 +409,7 @@ mkSelectorLFInfo id offset updatable
= LFThunk NotTopLevel False updatable (SelectorThunk offset)
(might_be_a_function (idType id))
-mkApLFInfo :: Id -> UpdateFlag -> Int -> LambdaFormInfo
+mkApLFInfo :: Id -> UpdateFlag -> RepArity -> LambdaFormInfo
mkApLFInfo id upd_flag arity
= LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
(might_be_a_function (idType id))
@@ -416,12 +421,12 @@ Miscellaneous LF-infos.
mkLFArgument :: Id -> LambdaFormInfo
mkLFArgument id = LFUnknown (might_be_a_function (idType id))
-mkLFLetNoEscape :: Int -> LambdaFormInfo
+mkLFLetNoEscape :: RepArity -> LambdaFormInfo
mkLFLetNoEscape = LFLetNoEscape
mkLFImported :: Id -> LambdaFormInfo
mkLFImported id
- = case idArity id of
+ = case idRepArity id of
n | n > 0 -> LFReEntrant TopLevel n True (panic "arg_descr") -- n > 0
_ -> mkLFArgument id -- Not sure of exact arity
\end{code}
@@ -634,13 +639,13 @@ data CallMethod
| DirectEntry -- Jump directly, with args in regs
CLabel -- The code label
- Int -- Its arity
+ RepArity -- Its arity
getCallMethod :: DynFlags
-> Name -- Function being applied
-> CafInfo -- Can it refer to CAF's?
-> LambdaFormInfo -- Its info
- -> Int -- Number of available arguments
+ -> RepArity -- Number of available arguments
-> CallMethod
getCallMethod _ _ _ lf_info _
@@ -911,11 +916,11 @@ isConstrClosure_maybe :: ClosureInfo -> Maybe DataCon
isConstrClosure_maybe (ConInfo { closureCon = data_con }) = Just data_con
isConstrClosure_maybe _ = Nothing
-closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr)
+closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr)
closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info
closureFunInfo _ = Nothing
-lfFunInfo :: LambdaFormInfo -> Maybe (Int, ArgDescr)
+lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr)
lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc)
lfFunInfo _ = Nothing
@@ -935,7 +940,7 @@ funTagLFInfo lf
| otherwise
= 0
-tagForArity :: Int -> Maybe Int
+tagForArity :: RepArity -> Maybe Int
tagForArity i | i <= mAX_PTR_TAG = Just i
| otherwise = Nothing
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index 7aa159844b..a8db8f9d4e 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -273,8 +273,8 @@ cgDataCon data_con
(tagForCon data_con)] }
-- The case continuation code expects a tagged pointer
- arg_reps :: [(PrimRep, Type)]
- arg_reps = [(typePrimRep ty, ty) | ty <- dataConRepArgTys data_con]
+ arg_reps :: [(PrimRep, UnaryType)]
+ arg_reps = [(typePrimRep rep_ty, rep_ty) | ty <- dataConRepArgTys data_con, rep_ty <- flattenRepType (repType ty)]
-- Dynamic closure code for non-nullary constructors only
; whenC (not (isNullaryRepDataCon data_con))
diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index d4ba62c6ca..0f4c9bf81d 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -21,8 +21,8 @@ module StgCmmClosure (
DynTag, tagForCon, isSmallFamily,
ConTagZ, dataConTagZ,
- isVoidRep, isGcPtrRep, addIdReps, addArgReps,
- argPrimRep,
+ idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps,
+ argPrimRep,
-- * LambdaFormInfo
LambdaFormInfo, -- Abstract
@@ -97,6 +97,10 @@ import DynFlags
-- Why are these here?
+-- NB: this is reliable because by StgCmm no Ids have unboxed tuple type
+idPrimRep :: Id -> PrimRep
+idPrimRep id = typePrimRep (idType id)
+
addIdReps :: [Id] -> [(PrimRep, Id)]
addIdReps ids = [(idPrimRep id, id) | id <- ids]
@@ -127,7 +131,7 @@ isGcPtrRep _ = False
data LambdaFormInfo
= LFReEntrant -- Reentrant closure (a function)
TopLevelFlag -- True if top level
- !Int -- Arity. Invariant: always > 0
+ !RepArity -- Arity. Invariant: always > 0
!Bool -- True <=> no fvs
ArgDescr -- Argument descriptor (should really be in ClosureInfo)
@@ -188,7 +192,7 @@ data StandardFormInfo
-- The code for the thunk just pushes x2..xn on the stack and enters x1.
-- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
-- in the RTS to save space.
- Int -- Arity, n
+ RepArity -- Arity, n
------------------------------------------------------
@@ -231,9 +235,12 @@ might_be_a_function :: Type -> Bool
-- Return False only if we are *sure* it's a data type
-- Look through newtypes etc as much as poss
might_be_a_function ty
- = case tyConAppTyCon_maybe (repType ty) of
- Just tc -> not (isDataTyCon tc)
- Nothing -> True
+ | UnaryRep rep <- repType ty
+ , Just tc <- tyConAppTyCon_maybe rep
+ , isDataTyCon tc
+ = False
+ | otherwise
+ = True
-------------
mkConLFInfo :: DataCon -> LambdaFormInfo
@@ -266,7 +273,7 @@ mkLFImported id
| otherwise
= mkLFArgument id -- Not sure of exact arity
where
- arity = idArity id
+ arity = idRepArity id
------------
mkLFBlackHole :: LambdaFormInfo
@@ -309,7 +316,7 @@ tagForCon con
con_tag = dataConTagZ con
fam_size = tyConFamilySize (dataConTyCon con)
-tagForArity :: Int -> DynTag
+tagForArity :: RepArity -> DynTag
tagForArity arity | isSmallFamily arity = arity
| otherwise = 0
@@ -458,13 +465,13 @@ data CallMethod
| DirectEntry -- Jump directly, with args in regs
CLabel -- The code label
- Int -- Its arity
+ RepArity -- Its arity
getCallMethod :: DynFlags
-> Name -- Function being applied
-> CafInfo -- Can it refer to CAF's?
-> LambdaFormInfo -- Its info
- -> Int -- Number of available arguments
+ -> RepArity -- Number of available arguments
-> CallMethod
getCallMethod _ _name _ lf_info _n_args
@@ -744,10 +751,10 @@ closureReEntrant :: ClosureInfo -> Bool
closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True
closureReEntrant _ = False
-closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr)
+closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr)
closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info
-lfFunInfo :: LambdaFormInfo -> Maybe (Int, ArgDescr)
+lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr)
lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc)
lfFunInfo _ = Nothing
diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs
index e17ac4fd32..efb20186d3 100644
--- a/compiler/codeGen/StgCmmCon.hs
+++ b/compiler/codeGen/StgCmmCon.hs
@@ -62,7 +62,7 @@ cgTopRhsCon id con args
; when (platformOS (targetPlatform dflags) == OSMinGW32) $
-- Windows DLLs have a problem with static cross-DLL refs.
ASSERT( not (isDllConApp dflags con args) ) return ()
- ; ASSERT( args `lengthIs` dataConRepArity con ) return ()
+ ; ASSERT( args `lengthIs` dataConRepRepArity con ) return ()
-- LAY IT OUT
; let
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 5ea935984d..9faad02f46 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -497,7 +497,7 @@ cgConApp con stg_args
; emitReturn arg_exprs }
| otherwise -- Boxed constructors; allocate and return
- = ASSERT( stg_args `lengthIs` dataConRepArity con )
+ = ASSERT( stg_args `lengthIs` dataConRepRepArity con )
do { (idinfo, init) <- buildDynCon (dataConWorkId con) currentCCS con stg_args
-- The first "con" says that the name bound to this closure is
-- is "con", which is a bit of a fudge, but it only affects profiling
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index c41832a0ab..5bc0f7af4e 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -304,5 +304,6 @@ add_shim arg_ty expr
| otherwise = expr
where
- tycon = tyConAppTyCon (repType arg_ty)
+ UnaryRep rep_ty = repType arg_ty
+ tycon = tyConAppTyCon rep_ty
-- should be a tycon app, since this is a foreign call
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index 9afcd029a4..c33524636b 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -50,7 +50,7 @@ import StgSyn
import Id
import Name
import TyCon ( PrimRep(..) )
-import BasicTypes ( Arity )
+import BasicTypes ( RepArity )
import DynFlags
import StaticFlags
@@ -128,7 +128,7 @@ adjustHpBackwards
-- Making calls: directCall and slowCall
-------------------------------------------------------------------------
-directCall :: CLabel -> Arity -> [StgArg] -> FCode ()
+directCall :: CLabel -> RepArity -> [StgArg] -> FCode ()
-- (directCall f n args)
-- calls f(arg1, ..., argn), and applies the result to the remaining args
-- The function f has arity n, and there are guaranteed at least n args
@@ -144,7 +144,7 @@ slowCall fun stg_args
; slow_call fun cmm_args (argsReps stg_args) }
--------------
-direct_call :: String -> CLabel -> Arity -> [CmmExpr] -> [ArgRep] -> FCode ()
+direct_call :: String -> CLabel -> RepArity -> [CmmExpr] -> [ArgRep] -> FCode ()
-- NB1: (length args) may be less than (length reps), because
-- the args exclude the void ones
-- NB2: 'arity' refers to the *reps*
@@ -186,7 +186,7 @@ slow_call fun args reps
(rts_fun, arity) = slowCallPattern reps
-- These cases were found to cover about 99% of all slow calls:
-slowCallPattern :: [ArgRep] -> (FastString, Arity)
+slowCallPattern :: [ArgRep] -> (FastString, RepArity)
-- Returns the generic apply function and arity
slowCallPattern (P: P: P: P: P: P: _) = (fsLit "stg_ap_pppppp", 6)
slowCallPattern (P: P: P: P: P: _) = (fsLit "stg_ap_ppppp", 5)
diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs
index a6c592cfd8..da69030ddf 100644
--- a/compiler/codeGen/StgCmmTicky.hs
+++ b/compiler/codeGen/StgCmmTicky.hs
@@ -197,7 +197,7 @@ registerTickyCtr ctr_lbl
(CmmLit (mkIntCLit 1)) ]
ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs"))
-tickyReturnOldCon, tickyReturnNewCon :: Arity -> FCode ()
+tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode ()
tickyReturnOldCon arity
= ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr")
; bumpHistogram (fsLit "RET_OLD_hst") arity }
@@ -205,7 +205,7 @@ tickyReturnNewCon arity
= ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr")
; bumpHistogram (fsLit "RET_NEW_hst") arity }
-tickyUnboxedTupleReturn :: Int -> FCode ()
+tickyUnboxedTupleReturn :: RepArity -> FCode ()
tickyUnboxedTupleReturn arity
= ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr")
; bumpHistogram (fsLit "RET_UNBOXED_TUP_hst") arity }
@@ -219,7 +219,7 @@ tickyVectoredReturn family_size
-- Ticky calls
-- Ticks at a *call site*:
-tickyDirectCall :: Arity -> [StgArg] -> FCode ()
+tickyDirectCall :: RepArity -> [StgArg] -> FCode ()
tickyDirectCall arity args
| arity == length args = tickyKnownCallExact
| otherwise = do tickyKnownCallExtraArgs
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index c3327138b3..dda2260a04 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -458,7 +458,7 @@ newUnboxedTupleRegs res_ty
; ASSERT( regs `equalLength` reps )
return (regs, map primRepForeignHint reps) }
where
- ty_args = tyConAppArgs (repType res_ty)
+ UbxTupleRep ty_args = repType res_ty
reps = [ rep
| ty <- ty_args
, let rep = typePrimRep ty
View Lorry Controller Status