Commit 33455e88 authored by simonm's avatar simonm

[project @ 1999-04-06 09:44:27 by simonm]

Add -funbox-strict-fields flag.
parent 1b919f1d
......@@ -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}
%
% (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
......
......@@ -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}
......
......@@ -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}
......
......@@ -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}
%************************************************************************
......
......@@ -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}
......
......@@ -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
......
......@@ -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),
......
......@@ -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 }
......
......@@ -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.
......
......@@ -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}
......
......@@ -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)
......
......@@ -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}
......
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