Commit 09987de4 authored by batterseapower's avatar batterseapower

Support code generation for unboxed-tuple function arguments

This is done by a 'unarisation' pre-pass at the STG level which
translates away all (live) binders binding something of unboxed
tuple type.

This has the following knock-on effects:
  * The subkind hierarchy is vastly simplified (no UbxTupleKind or ArgKind)
  * Various relaxed type checks in typechecker, 'foreign import prim' etc
  * All case binders may be live at the Core level
parent 7950f46c
......@@ -26,7 +26,7 @@ types that
module BasicTypes(
Version, bumpVersion, initialVersion,
Arity,
Arity, RepArity,
Alignment,
......@@ -101,7 +101,18 @@ import Data.Function (on)
%************************************************************************
\begin{code}
-- | The number of value arguments that can be applied to a value before it does
-- "real work". So:
-- fib 100 has arity 0
-- \x -> fib x has arity 1
type Arity = Int
-- | The number of represented arguments that can be applied to a value before it does
-- "real work". So:
-- fib 100 has representation arity 0
-- \x -> fib x has representation arity 1
-- \(# x, y #) -> fib (x + y) has representation arity 2
type RepArity = Int
\end{code}
%************************************************************************
......
......@@ -31,7 +31,7 @@ module DataCon (
dataConInstOrigArgTys, dataConRepArgTys,
dataConFieldLabels, dataConFieldType,
dataConStrictMarks, dataConExStricts,
dataConSourceArity, dataConRepArity,
dataConSourceArity, dataConRepArity, dataConRepRepArity,
dataConIsInfix,
dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds,
dataConRepStrictness,
......@@ -692,9 +692,14 @@ dataConSourceArity dc = length (dcOrigArgTys dc)
-- | Gives the number of actual fields in the /representation/ of the
-- data constructor. This may be more than appear in the source code;
-- the extra ones are the existentially quantified dictionaries
dataConRepArity :: DataCon -> Int
dataConRepArity :: DataCon -> Arity
dataConRepArity (MkData {dcRepArgTys = arg_tys}) = length arg_tys
-- | The number of fields in the /representation/ of the constructor
-- AFTER taking into account the unpacking of any unboxed tuple fields
dataConRepRepArity :: DataCon -> RepArity
dataConRepRepArity dc = typeRepArity (dataConRepArity dc) (dataConRepType dc)
-- | Return whether there are any argument types for this 'DataCon's original source type
isNullarySrcDataCon :: DataCon -> Bool
isNullarySrcDataCon dc = null (dcOrigArgTys dc)
......
......@@ -41,8 +41,8 @@ module Id (
mkWorkerId, mkWiredInIdName,
-- ** Taking an Id apart
idName, idType, idUnique, idInfo, idDetails,
idPrimRep, recordSelectorFieldLabel,
idName, idType, idUnique, idInfo, idDetails, idRepArity,
recordSelectorFieldLabel,
-- ** Modifying an Id
setIdName, setIdUnique, Id.setIdType,
......@@ -158,9 +158,6 @@ idUnique = Var.varUnique
idType :: Id -> Kind
idType = Var.varType
idPrimRep :: Id -> PrimRep
idPrimRep id = typePrimRep (idType id)
setIdName :: Id -> Name -> Id
setIdName = Var.setVarName
......@@ -462,6 +459,9 @@ idArity id = arityInfo (idInfo id)
setIdArity :: Id -> Arity -> Id
setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id
idRepArity :: Id -> RepArity
idRepArity x = typeRepArity (idArity x) (idType x)
-- | Returns true if an application to n args would diverge
isBottomingId :: Id -> Bool
isBottomingId id = isBottomingSig (idStrictness id)
......
......@@ -72,7 +72,7 @@ module CmmUtils(
#include "HsVersions.h"
import TyCon ( PrimRep(..) )
import Type ( Type, typePrimRep )
import Type ( UnaryType, typePrimRep )
import SMRep
import Cmm
......@@ -107,7 +107,7 @@ primRepCmmType AddrRep = bWord
primRepCmmType FloatRep = f32
primRepCmmType DoubleRep = f64
typeCmmType :: Type -> CmmType
typeCmmType :: UnaryType -> CmmType
typeCmmType ty = primRepCmmType (typePrimRep ty)
primRepForeignHint :: PrimRep -> ForeignHint
......@@ -121,7 +121,7 @@ primRepForeignHint AddrRep = AddrHint -- NB! AddrHint, but NonPtrArg
primRepForeignHint FloatRep = NoHint
primRepForeignHint DoubleRep = NoHint
typeForeignHint :: Type -> ForeignHint
typeForeignHint :: UnaryType -> ForeignHint
typeForeignHint = primRepForeignHint . typePrimRep
---------------------------------------------------
......
......@@ -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)
......
......@@ -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 ]
......
......@@ -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
......@@ -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
......
......@@ -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))
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -352,17 +352,11 @@ lintCoreExpr e@(Case scrut var alt_ty alts) =
; subst <- getTvSubst
; checkTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)
-- If the binder is an unboxed tuple type, don't put it in scope
; let scope = if (isUnboxedTupleType (idType var)) then
pass_var
else lintAndScopeId var
; scope $ \_ ->
; lintAndScopeId var $ \_ ->
do { -- Check the alternatives
mapM_ (lintCoreAlt scrut_ty alt_ty) alts
; checkCaseAlts e scrut_ty alts
; return alt_ty } }
where
pass_var f = f var
lintCoreExpr (Type ty)
= do { ty' <- lintInTy ty
......@@ -598,10 +592,7 @@ lintIdBndr :: Id -> (Id -> LintM a) -> LintM a
-- ToDo: lint its rules
lintIdBndr id linterF
= do { checkL (not (isUnboxedTupleType (idType id)))
(mkUnboxedTupleMsg id)
-- No variable can be bound to an unboxed tuple.
; lintAndScopeId id $ \id' -> linterF id' }
= do { lintAndScopeId id $ \id' -> linterF id' }
lintAndScopeIds :: [Var] -> ([Var] -> LintM a) -> LintM a
lintAndScopeIds ids linterF
......@@ -1257,11 +1248,6 @@ mkArityMsg binder
]
where (StrictSig dmd_ty) = idStrictness binder
mkUnboxedTupleMsg :: Id -> MsgDoc
mkUnboxedTupleMsg binder
= vcat [hsep [ptext (sLit "A variable has unboxed tuple type:"), ppr binder],
hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]]
mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc
mkCastErr expr co from_ty expr_ty
= vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"),
......
......@@ -154,7 +154,7 @@ dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
eqn_rhs = cantFailMatchResult body }
; var <- selectMatchVar upat
; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
; return (scrungleMatch var rhs result) }
; return (bindNonRec var rhs result) }
dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
......@@ -163,38 +163,13 @@ strictMatchOnly :: HsBind Id -> Bool
strictMatchOnly (AbsBinds { abs_binds = binds })
= anyBag (strictMatchOnly . unLoc) binds
strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = ty })
= isUnboxedTupleType ty
= isUnLiftedType ty
|| isBangLPat lpat
|| any (isUnLiftedType . idType) (collectPatBinders lpat)
strictMatchOnly (FunBind { fun_id = L _ id })
= isUnLiftedType (idType id)
strictMatchOnly _ = False -- I hope! Checked immediately by caller in fact
scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
-- Returns something like (let var = scrut in body)
-- but if var is an unboxed-tuple type, it inlines it in a fragile way
-- Special case to handle unboxed tuple patterns; they can't appear nested
-- The idea is that
-- case e of (# p1, p2 #) -> rhs
-- should desugar to
-- case e of (# x1, x2 #) -> ... match p1, p2 ...
-- NOT
-- let x = e in case x of ....
--
-- But there may be a big
-- let fail = ... in case e of ...
-- wrapping the whole case, which complicates matters slightly
-- It all seems a bit fragile. Test is dsrun013.
scrungleMatch var scrut body
| isUnboxedTupleType (idType var) = scrungle body
| otherwise = bindNonRec var scrut body
where
scrungle (Case (Var x) bndr ty alts)
| x == var = Case scrut bndr ty alts
scrungle (Let binds body) = Let binds (scrungle body)
scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
\end{code}
%************************************************************************
......@@ -326,7 +301,7 @@ dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty))
| otherwise
= do { core_discrim <- dsLExpr discrim
; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
; return (scrungleMatch discrim_var core_discrim matching_code) }
; return (bindNonRec discrim_var core_discrim matching_code) }
-- Pepe: The binds are in scope in the body but NOT in the binding group
-- This is to avoid silliness in breakpoints
......
......@@ -707,9 +707,12 @@ toCType = f False
= pprPanic "toCType" (ppr t)
typeTyCon :: Type -> TyCon
typeTyCon ty = case tcSplitTyConApp_maybe (repType ty) of
Just (tc,_) -> tc
Nothing -> pprPanic "DsForeign.typeTyCon" (ppr ty)
typeTyCon ty
| UnaryRep rep_ty <- repType ty
, Just (tc, _) <- tcSplitTyConApp_maybe rep_ty
= tc
| otherwise
= pprPanic "DsForeign.typeTyCon" (ppr ty)
insertRetAddr :: DynFlags -> CCallConv
-> [(SDoc, SDoc, Type, CmmType)]
......@@ -739,7 +742,7 @@ ret_addr_arg = (text "original_return_addr", text "void*", undefined,
-- This function returns the primitive type associated with the boxed
-- type argument to a foreign export (eg. Int ==> Int#).
getPrimTyOf :: Type -> Type
getPrimTyOf :: Type -> UnaryType
getPrimTyOf ty
| isBoolTy rep_ty = intPrimTy
-- Except for Bool, the types we are interested in have a single constructor
......@@ -752,7 +755,7 @@ getPrimTyOf ty
prim_ty
_other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
where
rep_ty = repType ty
UnaryRep rep_ty = repType ty
-- represent a primitive type as a Char, for building a string that
-- described the foreign function type. The types are size-dependent,
......
......@@ -360,6 +360,7 @@ Library
SRT
SimplStg
StgStats
UnariseStg
Rules
SpecConstr
Specialise
......
......@@ -271,8 +271,12 @@ collect :: AnnExpr Id VarSet -> ([Var], AnnExpr' Id VarSet)
collect (_, e) = go [] e
where
go xs e | Just e' <- bcView e = go xs e'
go xs (AnnLam x (_,e)) = go (x:xs) e
go xs not_lambda = (reverse xs, not_lambda)
go xs (AnnLam x (_,e))
| UbxTupleRep _ <- repType (idType x)
= unboxedTupleException
| otherwise
= go (x:xs) e
go xs not_lambda = (reverse xs, not_lambda)
schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name)
schemeR_wrk fvs nm original_body (args, body)
......@@ -486,7 +490,7 @@ schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut
-- no alts: scrut is guaranteed to diverge
schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1, bind2], rhs)])
| isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1)