diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs
index cec3fa8e28c2b5144f2251f176efcb7d612eff18..5625103a86e9c7a9349e51cf60c25f6a74c95d01 100644
--- a/ghc/compiler/basicTypes/BasicTypes.lhs
+++ b/ghc/compiler/basicTypes/BasicTypes.lhs
@@ -22,6 +22,8 @@ module BasicTypes(
#include "HsVersions.h"
+import {-# SOURCE #-} DataCon ( DataCon )
+import {-# SOURCE #-} Type ( Type )
import Outputable
\end{code}
@@ -101,9 +103,6 @@ data NewOrData
deriving( Eq ) -- Needed because Demand derives Eq
\end{code}
-The @RecFlag@ tells whether the thing is part of a recursive group or not.
-
-
%************************************************************************
%* *
\subsection[Top-level/local]{Top-level/not-top level flag}
@@ -116,10 +115,9 @@ data TopLevelFlag
| NotTopLevel
\end{code}
-
%************************************************************************
%* *
-\subsection[Top-level/local]{Top-level/not-top level flag}
+\subsection[Recursive/Non-Recursive]{Recursive/Non-Recursive flag}
%* *
%************************************************************************
@@ -136,5 +134,6 @@ data RecFlag = Recursive
\begin{code}
data StrictnessMark = MarkedStrict
+ | MarkedUnboxed DataCon [Type]
| NotMarkedStrict
\end{code}
diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs
index 3ecd9689e692c81837478f3820b49cbd1ca1bd23..ffa98ea621269f3a73e48c5ab27970fcc247649e 100644
--- a/ghc/compiler/basicTypes/DataCon.lhs
+++ b/ghc/compiler/basicTypes/DataCon.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1998
%
-\section[Literal]{@Literal@: Machine literals (unboxed, of course)}
+\section[DataCon]{@DataCon@: Data Constructors}
\begin{code}
module DataCon (
@@ -9,7 +9,7 @@ module DataCon (
ConTag, fIRST_TAG,
mkDataCon,
dataConType, dataConSig, dataConName, dataConTag,
- dataConArgTys, dataConRawArgTys, dataConTyCon,
+ dataConOrigArgTys, dataConArgTys, dataConRawArgTys, dataConTyCon,
dataConFieldLabels, dataConStrictMarks, dataConSourceArity,
dataConNumFields, dataConNumInstArgs, dataConId,
isNullaryDataCon, isTupleCon, isUnboxedTupleCon,
@@ -22,18 +22,23 @@ import CmdLineOpts ( opt_DictsStrict )
import TysPrim
import Type ( Type, ThetaType, TauType,
mkSigmaTy, mkFunTys, mkTyConApp,
- mkTyVarTys, mkDictTy, substTy
+ mkTyVarTys, mkDictTy, substTy,
+ splitAlgTyConApp_maybe
)
+import PprType
import TyCon ( TyCon, tyConDataCons, isDataTyCon,
isTupleTyCon, isUnboxedTupleTyCon )
import Class ( classTyCon )
-import Name ( Name, NamedThing(..), nameUnique )
+import Name ( Name, NamedThing(..), nameUnique, isLocallyDefinedName )
import Var ( TyVar, Id )
import VarEnv
import FieldLabel ( FieldLabel )
import BasicTypes ( StrictnessMark(..), Arity )
import Outputable
import Unique ( Unique, Uniquable(..) )
+import CmdLineOpts ( opt_UnboxStrictFields )
+import UniqSet
+import Maybe
import Util ( assoc )
\end{code}
@@ -68,7 +73,7 @@ data DataCon
-- dcTheta = [Eq a]
-- dcExTyVars = [b]
-- dcExTheta = [Ord b]
- -- dcArgTys = [a,List b]
+ -- dcOrigArgTys = [a,List b]
-- dcTyCon = T
dcTyVars :: [TyVar], -- Type vars and context for the data type decl
@@ -77,16 +82,28 @@ data DataCon
dcExTyVars :: [TyVar], -- Ditto for the context of the constructor,
dcExTheta :: ThetaType, -- the existentially quantified stuff
- dcArgTys :: [Type], -- Argument types
+ dcOrigArgTys :: [Type], -- Original argument types
+ -- (before unboxing and flattening of
+ -- strict fields)
+ dcRepArgTys :: [Type], -- Constructor Argument types
dcTyCon :: TyCon, -- Result tycon
-- Now the strictness annotations and field labels of the constructor
- dcStricts :: [StrictnessMark], -- Strict args, in the same order as the argument types;
- -- length = dataConNumFields dataCon
-
- dcFields :: [FieldLabel], -- Field labels for this constructor, in the
- -- same order as the argument types;
- -- length = 0 (if not a record) or dataConSourceArity.
+ dcUserStricts :: [StrictnessMark],
+ -- Strictness annotations, as placed on the data type defn,
+ -- in the same order as the argument types;
+ -- length = dataConNumFields dataCon
+
+ dcRealStricts :: [StrictnessMark],
+ -- Strictness annotations as deduced by the compiler. May
+ -- include some MarkedUnboxed fields that are MarkedStrict
+ -- in dcUserStricts.
+ -- length = dataConNumFields dataCon
+
+ dcFields :: [FieldLabel],
+ -- Field labels for this constructor, in the
+ -- same order as the argument types;
+ -- length = 0 (if not a record) or dataConSourceArity.
-- Finally, the curried function that corresponds to the constructor
-- mkT :: forall a b. (Eq a, Ord b) => a -> [b] -> T a
@@ -154,32 +171,103 @@ mkDataCon :: Name
-> DataCon
-- Can get the tag from the TyCon
-mkDataCon name arg_stricts fields tyvars theta ex_tyvars ex_theta arg_tys tycon id
- = ASSERT(length arg_stricts == length arg_tys)
+mkDataCon name arg_stricts fields tyvars theta ex_tyvars ex_theta orig_arg_tys tycon id
+ = ASSERT(length arg_stricts == length orig_arg_tys)
-- The 'stricts' passed to mkDataCon are simply those for the
-- source-language arguments. We add extra ones for the
-- dictionary arguments right here.
con
where
con = MkData {dcName = name, dcUnique = nameUnique name,
- dcTyVars = tyvars, dcTheta = theta, dcArgTys = arg_tys,
+ dcTyVars = tyvars, dcTheta = theta,
+ dcOrigArgTys = orig_arg_tys,
+ dcRepArgTys = rep_arg_tys,
dcExTyVars = ex_tyvars, dcExTheta = ex_theta,
- dcStricts = all_stricts, dcFields = fields,
- dcTag = tag, dcTyCon = tycon, dcType = ty,
+ dcRealStricts = all_stricts, dcUserStricts = user_stricts,
+ dcFields = fields, dcTag = tag, dcTyCon = tycon, dcType = ty,
dcId = id}
- all_stricts = (map mk_dict_strict_mark ex_theta) ++ arg_stricts
+ (real_arg_stricts, strict_arg_tyss)
+ = unzip (zipWith (unbox_strict_arg_ty tycon) arg_stricts orig_arg_tys)
+ rep_arg_tys = concat strict_arg_tyss
+
+ all_stricts = (map mk_dict_strict_mark ex_theta) ++ real_arg_stricts
+ user_stricts = (map mk_dict_strict_mark ex_theta) ++ arg_stricts
-- Add a strictness flag for the existential dictionary arguments
tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con
ty = mkSigmaTy (tyvars ++ ex_tyvars)
ex_theta
- (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)))
+ (mkFunTys rep_arg_tys
+ (mkTyConApp tycon (mkTyVarTys tyvars)))
mk_dict_strict_mark (clas,tys)
| opt_DictsStrict &&
- isDataTyCon (classTyCon clas) = MarkedStrict -- Don't mark newtype things as strict!
+ -- Don't mark newtype things as strict!
+ isDataTyCon (classTyCon clas) = MarkedStrict
| otherwise = NotMarkedStrict
+
+-- We attempt to unbox/unpack a strict field when either:
+-- (i) The tycon is imported, and the field is marked '! !', or
+-- (ii) The tycon is defined in this module, the field is marked '!',
+-- and the -funbox-strict-fields flag is on.
+--
+-- This ensures that if we compile some modules with -funbox-strict-fields and
+-- some without, the compiler doesn't get confused about the constructor
+-- representations.
+
+unbox_strict_arg_ty :: TyCon -> StrictnessMark -> Type -> (StrictnessMark, [Type])
+unbox_strict_arg_ty tycon NotMarkedStrict ty
+ = (NotMarkedStrict, [ty])
+unbox_strict_arg_ty tycon MarkedStrict ty
+ | not opt_UnboxStrictFields
+ || not (isLocallyDefinedName (getName tycon)) = (MarkedStrict, [ty])
+unbox_strict_arg_ty tycon marked_unboxed ty
+ -- MarkedUnboxed || (MarkedStrict && opt_UnboxStrictFields && not imported)
+ = case splitAlgTyConApp_maybe ty of
+ Just (tycon,_,[])
+ -> panic (showSDoc (hcat [
+ text "unbox_strict_arg_ty: constructors for ",
+ ppr tycon,
+ text " not available."
+ ]))
+ Just (tycon,ty_args,[con])
+ -> case maybe_unpack_fields emptyUniqSet
+ (zip (dataConOrigArgTys con ty_args)
+ (dcUserStricts con))
+ of
+ Nothing -> (MarkedStrict, [ty])
+ Just tys -> (MarkedUnboxed con tys, tys)
+ _ -> (MarkedStrict, [ty])
+
+-- bail out if we encounter the same tycon twice. This avoids problems like
+--
+-- data A = !B
+-- data B = !A
+--
+-- where no useful unpacking can be done.
+
+maybe_unpack_field :: UniqSet TyCon -> Type -> StrictnessMark -> Maybe [Type]
+maybe_unpack_field set ty NotMarkedStrict
+ = Just [ty]
+maybe_unpack_field set ty MarkedStrict | not opt_UnboxStrictFields
+ = Just [ty]
+maybe_unpack_field set ty strict
+ = case splitAlgTyConApp_maybe ty of
+ Just (tycon,ty_args,[con])
+ | tycon `elementOfUniqSet` set -> Nothing
+ | otherwise ->
+ let set' = addOneToUniqSet set tycon in
+ maybe_unpack_fields set'
+ (zip (dataConOrigArgTys con ty_args)
+ (dcUserStricts con))
+ _ -> Just [ty]
+
+maybe_unpack_fields :: UniqSet TyCon -> [(Type,StrictnessMark)] -> Maybe [Type]
+maybe_unpack_fields set tys
+ | any isNothing unpacked_fields = Nothing
+ | otherwise = Just (concat (catMaybes unpacked_fields))
+ where unpacked_fields = map (\(ty,str) -> maybe_unpack_field set ty str) tys
\end{code}
@@ -204,14 +292,14 @@ dataConFieldLabels :: DataCon -> [FieldLabel]
dataConFieldLabels = dcFields
dataConStrictMarks :: DataCon -> [StrictnessMark]
-dataConStrictMarks = dcStricts
+dataConStrictMarks = dcRealStricts
dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience
-dataConRawArgTys = dcArgTys
+dataConRawArgTys = dcRepArgTys
dataConSourceArity :: DataCon -> Arity
-- Source-level arity of the data constructor
-dataConSourceArity dc = length (dcArgTys dc)
+dataConSourceArity dc = length (dcOrigArgTys dc)
dataConSig :: DataCon -> ([TyVar], ThetaType,
[TyVar], ThetaType,
@@ -219,17 +307,22 @@ dataConSig :: DataCon -> ([TyVar], ThetaType,
dataConSig (MkData {dcTyVars = tyvars, dcTheta = theta,
dcExTyVars = ex_tyvars, dcExTheta = ex_theta,
- dcArgTys = arg_tys, dcTyCon = tycon})
+ dcOrigArgTys = arg_tys, dcTyCon = tycon})
= (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon)
-dataConArgTys :: DataCon
+dataConArgTys, dataConOrigArgTys :: DataCon
-> [Type] -- Instantiated at these types
-- NB: these INCLUDE the existentially quantified arg types
-> [Type] -- Needs arguments of these types
-- NB: these INCLUDE the existentially quantified dict args
-- but EXCLUDE the data-decl context which is discarded
-dataConArgTys (MkData {dcArgTys = arg_tys, dcTyVars = tyvars,
+dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars,
+ dcExTyVars = ex_tyvars, dcExTheta = ex_theta}) inst_tys
+ = map (substTy (zipVarEnv (tyvars ++ ex_tyvars) inst_tys))
+ ([mkDictTy cls tys | (cls,tys) <- ex_theta] ++ arg_tys)
+
+dataConOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars,
dcExTyVars = ex_tyvars, dcExTheta = ex_theta}) inst_tys
= map (substTy (zipVarEnv (tyvars ++ ex_tyvars) inst_tys))
([mkDictTy cls tys | (cls,tys) <- ex_theta] ++ arg_tys)
@@ -246,7 +339,7 @@ dictionaries
-- stored in the DataCon, and are matched in a case expression
dataConNumInstArgs (MkData {dcTyVars = tyvars}) = length tyvars
-dataConNumFields (MkData {dcExTheta = theta, dcArgTys = arg_tys})
+dataConNumFields (MkData {dcExTheta = theta, dcRepArgTys = arg_tys})
= length theta + length arg_tys
isNullaryDataCon con
diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 4ac8170d677623ed4f87ecf964463df2c56fbe64..f5bff89ff0baf67f0636be3debedfcae3207c2ad 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -9,7 +9,7 @@ module Id (
-- Simple construction
mkVanillaId, mkImportedId, mkSysLocal, mkUserLocal,
- mkTemplateLocals, mkWildId, mkUserId,
+ mkTemplateLocals, mkTemplateLocal, mkWildId, mkUserId,
-- Taking an Id apart
idName, idType, idUnique, idInfo, idDetails,
@@ -131,6 +131,9 @@ mkTemplateLocals :: [Type] -> [Id]
mkTemplateLocals tys = zipWith (mkSysLocal SLIT("tpl"))
(getBuiltinUniques (length tys))
tys
+
+mkTemplateLocal :: Int -> Type -> Id
+mkTemplateLocal i ty = mkSysLocal SLIT("tpl") (mkBuiltinUnique i) ty
\end{code}
diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index 1c6b5d0dbd1830e562b1e66769f6a3a5c090b14b..cb53da0c120867084fef98c48cfa648ce5e8f965 100644
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -46,11 +46,11 @@ import Name ( mkDerivedName, mkWiredInIdName,
)
import PrimOp ( PrimOp, primOpType, primOpOcc, primOpUniq )
import DataCon ( DataCon, dataConStrictMarks, dataConFieldLabels,
- dataConArgTys, dataConSig
+ dataConArgTys, dataConSig, dataConRawArgTys
)
import Id ( idType,
mkUserLocal, mkVanillaId, mkTemplateLocals,
- setInlinePragma
+ mkTemplateLocal, setInlinePragma
)
import IdInfo ( noIdInfo,
exactArity, setUnfoldingInfo,
@@ -139,44 +139,68 @@ Notice that
dataConInfo :: DataCon -> IdInfo
dataConInfo data_con
- = setInlinePragInfo IMustBeINLINEd $
- -- Always inline constructors; we won't create a binding for them
- setArityInfo (exactArity (length locals)) $
+ = setInlinePragInfo IMustBeINLINEd $ -- Always inline constructors
+ setArityInfo (exactArity (n_dicts + n_ex_dicts + n_id_args)) $
setUnfoldingInfo unfolding $
noIdInfo
where
unfolding = mkUnfolding con_rhs
- (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon) = dataConSig data_con
+ (tyvars, theta, ex_tyvars, ex_theta, orig_arg_tys, tycon)
+ = dataConSig data_con
+ rep_arg_tys = dataConRawArgTys data_con
all_tyvars = tyvars ++ ex_tyvars
dict_tys = [mkDictTy clas tys | (clas,tys) <- theta]
ex_dict_tys = [mkDictTy clas tys | (clas,tys) <- ex_theta]
+
n_dicts = length dict_tys
+ n_ex_dicts = length ex_dict_tys
+ n_id_args = length orig_arg_tys
+ n_rep_args = length rep_arg_tys
+
result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
- locals = mkTemplateLocals (dict_tys ++ ex_dict_tys ++ arg_tys)
- data_args = drop n_dicts locals
- (data_arg1:_) = data_args -- Used for newtype only
+ mkLocals i n tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
+ (dict_args, i1) = mkLocals 1 n_dicts dict_tys
+ (ex_dict_args,i2) = mkLocals i1 n_ex_dicts ex_dict_tys
+ (id_args,i3) = mkLocals i2 n_id_args orig_arg_tys
+
+ (id_arg1:_) = id_args -- Used for newtype only
strict_marks = dataConStrictMarks data_con
- strict_args = [arg | (arg,MarkedStrict) <- data_args `zip` strict_marks]
- -- NB: we can't call mkTemplateLocals twice, because it
- -- always starts from the same unique.
- con_app | isNewTyCon tycon
- = ASSERT( length arg_tys == 1)
- Note (Coerce result_ty (head arg_tys)) (Var data_arg1)
+ con_app i rep_ids
+ | isNewTyCon tycon
+ = ASSERT( length orig_arg_tys == 1 )
+ Note (Coerce result_ty (head orig_arg_tys)) (Var id_arg1)
| otherwise
- = mkConApp data_con (map Type (mkTyVarTys all_tyvars) ++ map Var data_args)
-
- con_rhs = mkLams all_tyvars $ mkLams locals $
- foldr mk_case con_app strict_args
-
- mk_case arg body | isUnLiftedType (idType arg)
- = body -- "!" on unboxed arg does nothing
- | otherwise
- = Case (Var arg) arg [(DEFAULT,[],body)]
- -- This case shadows "arg" but that's fine
+ = mkConApp data_con
+ (map Type (mkTyVarTys all_tyvars) ++
+ map Var (reverse rep_ids))
+
+ con_rhs = mkLams all_tyvars $ mkLams dict_args $
+ mkLams ex_dict_args $ mkLams id_args $
+ foldr mk_case con_app (zip id_args strict_marks) i3 []
+
+ mk_case
+ :: (Id, StrictnessMark) -- arg, strictness
+ -> (Int -> [Id] -> CoreExpr) -- body
+ -> Int -- next rep arg id
+ -> [Id] -- rep args so far
+ -> CoreExpr
+ mk_case (arg,strict) body i rep_args
+ = case strict of
+ NotMarkedStrict -> body i (arg:rep_args)
+ MarkedStrict
+ | isUnLiftedType (idType arg) -> body i (arg:rep_args)
+ | otherwise ->
+ Case (Var arg) arg [(DEFAULT,[], body i (arg:rep_args))]
+
+ MarkedUnboxed con tys ->
+ Case (Var arg) arg [(DataCon con, con_args,
+ body i' (reverse con_args++rep_args))]
+ where n_tys = length tys
+ (con_args,i') = mkLocals i (length tys) tys
\end{code}
diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index a26082fb8348e49487232846f6a54e1f0168fc77..9da5d956f92b05ce9f61e0f88d11c778fb059c35 100644
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -39,7 +39,8 @@ import PrelVals ( iRREFUT_PAT_ERROR_ID )
import Id ( idType, Id, mkWildId )
import Const ( Literal(..), Con(..) )
import TyCon ( isNewTyCon, tyConDataCons )
-import DataCon ( DataCon )
+import DataCon ( DataCon, dataConStrictMarks, dataConArgTys )
+import BasicTypes ( StrictnessMark(..) )
import Type ( mkFunTy, isUnLiftedType, splitAlgTyConApp,
Type
)
@@ -216,7 +217,9 @@ mkCoAlgCaseMatchResult var match_alts
mk_alt fail (con, args, MatchResult _ body_fn)
= body_fn fail `thenDs` \ body ->
- returnDs (DataCon con, args, body)
+ rebuildConArgs con args (dataConStrictMarks con) body
+ `thenDs` \ (body', real_args) ->
+ returnDs (DataCon con, real_args, body')
mk_default fail | exhaustive_case = []
| otherwise = [(DEFAULT, [], fail)]
@@ -225,7 +228,32 @@ mkCoAlgCaseMatchResult var match_alts
= mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
exhaustive_case = isEmptyUniqSet un_mentioned_constructors
-
+-- for each constructor we match on, we might need to re-pack some
+-- of the strict fields if they are unpacked in the constructor.
+
+rebuildConArgs
+ :: DataCon -- the con we're matching on
+ -> [Id] -- the source-level args
+ -> [StrictnessMark] -- the strictness annotations (per-arg)
+ -> CoreExpr -- the body
+ -> DsM (CoreExpr, [Id])
+
+rebuildConArgs con [] stricts body = returnDs (body, [])
+rebuildConArgs con (arg:args) (str:stricts) body
+ = rebuildConArgs con args stricts body `thenDs` \ (body', real_args) ->
+ case str of
+ MarkedUnboxed pack_con tys ->
+ let id_tys = dataConArgTys pack_con ty_args in
+ newSysLocalsDs id_tys `thenDs` \ unpacked_args ->
+ returnDs (
+ Let (NonRec arg (Con (DataCon pack_con)
+ (map Type ty_args ++
+ map Var unpacked_args))) body',
+ unpacked_args ++ real_args
+ )
+ _ -> returnDs (body', arg:real_args)
+
+ where ty_args = case splitAlgTyConApp (idType arg) of { (_,args,_) -> args }
\end{code}
%************************************************************************
diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index d5f0b1b504d569ed21a9d46a9baeca2f0b5189aa..fe026da2cca4ced32555ccc385aecbbb9590aa9e 100644
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -282,6 +282,7 @@ data ConDetails name
data BangType name
= Banged (HsType name) -- HsType: to allow Haskell extensions
| Unbanged (HsType name) -- (MonoType only needed for straight Haskell)
+ | Unpacked (HsType name) -- Field is strict and to be unpacked if poss.
\end{code}
\begin{code}
@@ -312,6 +313,7 @@ ppr_con_details con (RecCon fields)
ppr_bang (Banged ty) = ptext SLIT("!") <> pprParendHsType ty
ppr_bang (Unbanged ty) = pprParendHsType ty
+ppr_bang (Unpacked ty) = ptext SLIT("! !") <> pprParendHsType ty
\end{code}
diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index 08aa38feba7a14e83428245306c72288ada4bec5..87b89395d31d716755f07e9afd467abfb19ee66e 100644
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -55,6 +55,7 @@ module CmdLineOpts (
opt_EmitCExternDecls,
opt_EnsureSplittableC,
opt_FoldrBuildOn,
+ opt_UnboxStrictFields,
opt_GlasgowExts,
opt_GranMacros,
opt_HiMap,
@@ -324,6 +325,7 @@ opt_DoTickyProfiling = lookUp SLIT("-fticky-ticky")
opt_EmitCExternDecls = lookUp SLIT("-femit-extern-decls")
opt_EnsureSplittableC = lookUp SLIT("-fglobalise-toplev-names")
opt_FoldrBuildOn = lookUp SLIT("-ffoldr-build-on")
+opt_UnboxStrictFields = lookUp SLIT("-funbox-strict-fields")
opt_GranMacros = lookUp SLIT("-fgransim")
opt_GlasgowExts = lookUp SLIT("-fglasgow-exts")
opt_HiMap = lookup_str "-himap=" -- file saying where to look for .hi files
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 4a41a101feebe1861abd36460a4db1971b9cdd0f..088de6a2fa9f790a136aa1577da7be8e27a9de9e 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -498,11 +498,9 @@ ifaceTyCon tycon
ppr_arg_ty (strict_mark, ty) = ppr_strict_mark strict_mark <> pprParendType ty
- ppr_strict_mark NotMarkedStrict = empty
- ppr_strict_mark MarkedStrict = ptext SLIT("! ")
- -- The extra space helps the lexical analyser that lexes
- -- interface files; it doesn't make the rigid operator/identifier
- -- distinction, so "!a" is a valid identifier so far as it is concerned
+ ppr_strict_mark NotMarkedStrict = empty
+ ppr_strict_mark (MarkedUnboxed _ _) = ptext SLIT("! ! ")
+ ppr_strict_mark MarkedStrict = ptext SLIT("! ")
ppr_field (strict_mark, field_label)
= hsep [ ppr (fieldLabelName field_label),
diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index bcf592d070a6dde2d631a5c4f6b62c137d87af41..aac197f6d44680364b70c56b18df3343a48848d0 100644
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -348,6 +348,7 @@ batypes : { [] }
batype :: { RdrNameBangType }
batype : atype { Unbanged $1 }
| '!' atype { Banged $2 }
+ | '!' '!' atype { Unpacked $3 }
fields1 :: { [([RdrName], RdrNameBangType)] }
fields1 : field { [$1] }
@@ -356,6 +357,7 @@ fields1 : field { [$1] }
field :: { ([RdrName], RdrNameBangType) }
field : var_names1 '::' type { ($1, Unbanged $3) }
| var_names1 '::' '!' type { ($1, Banged $4) }
+ | var_names1 '::' '!' '!' type { ($1, Unpacked $5) }
--------------------------------------------------------------------------
type :: { RdrNameHsType }
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index b43f6cbe405517cb5681b2a210f1a8ead0fd0d13..498d309fceab17635862baecc2dfb10a7787b523 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -428,9 +428,13 @@ rnBangTy doc (Banged ty)
returnRn (Banged new_ty, fvs)
rnBangTy doc (Unbanged ty)
- = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
+ = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
returnRn (Unbanged new_ty, fvs)
+rnBangTy doc (Unpacked ty)
+ = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
+ returnRn (Unpacked new_ty, fvs)
+
-- This data decl will parse OK
-- data T = a Int
-- treating "a" as the constructor.
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index a4c5e70b997d911d0789f0428d830167ecb569ba..bb2df3ed7745a03dbda261f6081fd03204228dab 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -1480,20 +1480,26 @@ simplAlts zap_occ_info scrut_cons case_bndr'' alts cont'
-- case x of { T a b -> T (a+1) b }
--
-- We really must record that b is already evaluated so that we don't
- -- go and re-evaluated it when constructing the result.
+ -- go and re-evaluate it when constructing the result.
- add_evals (DataCon dc) vs = stretchZipEqual add_eval vs (dataConStrictMarks dc)
+ add_evals (DataCon dc) vs = cat_evals vs (dataConStrictMarks dc)
add_evals other_con vs = vs
- add_eval v m | isTyVar v = Nothing
- | otherwise = case m of
- MarkedStrict -> Just (zap_occ_info v `setIdUnfolding` OtherCon [])
- NotMarkedStrict -> Just (zap_occ_info v)
+ cat_evals [] [] = []
+ cat_evals (v:vs) (str:strs)
+ | isTyVar v = cat_evals vs (str:strs)
+ | otherwise =
+ case str of
+ MarkedStrict ->
+ (zap_occ_info v `setIdUnfolding` OtherCon [])
+ : cat_evals vs strs
+ MarkedUnboxed con _ ->
+ cat_evals (v:vs) (dataConStrictMarks con ++ strs)
+ NotMarkedStrict -> zap_occ_info v : cat_evals vs strs
\end{code}
-
%************************************************************************
%* *
\subsection{Duplicating continuations}
diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 00104dbe2e901b30d279033e4df9654d26ecdd5e..995d0a1c5a98b9cf28b3c2a0c32d340025cfe295 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -302,6 +302,7 @@ get_con_details (RecCon nbtys) = unionManyUniqSets (map (get_bty.snd) nbty
----------------------------------------------------
get_bty (Banged ty) = get_ty ty
get_bty (Unbanged ty) = get_ty ty
+get_bty (Unpacked ty) = get_ty ty
----------------------------------------------------
get_ty (MonoTyVar name)
diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index 5d549435163559652b6bcea505c87dcc97797e0e..d33163cf519e5dcd9552710dcb094ceaa4ae6a7c 100644
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -91,6 +91,7 @@ kcConDecl (ConDecl _ ex_tvs ex_ctxt details loc)
kc_bty (Banged ty) = tcHsType ty
kc_bty (Unbanged ty) = tcHsType ty
+ kc_bty (Unpacked ty) = tcHsType ty
kc_field (_, bty) = kc_bty bty
\end{code}
@@ -237,9 +238,12 @@ thinContext arg_tys ctxt
get_strictness (Banged _) = MarkedStrict
get_strictness (Unbanged _) = NotMarkedStrict
+get_strictness (Unpacked _) = MarkedUnboxed bot bot
+ where bot = error "get_strictness"
get_pty (Banged ty) = ty
get_pty (Unbanged ty) = ty
+get_pty (Unpacked ty) = ty
\end{code}