Commit a47ee23a authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Merge branch 'master' of http://darcs.haskell.org/ghc

parents 829be066 388e1e82
......@@ -61,18 +61,25 @@ AC_DEFUN([FPTOOLS_SET_PLATFORM_VARS],
if test "$target_alias" = ""
then
if test "$bootstrap_target" != ""
if test "$host_alias" != ""
then
target=$bootstrap_target
echo "Target platform inferred as: $target"
GHC_CONVERT_CPU([$host_cpu], [TargetArch])
GHC_CONVERT_VENDOR([$host_vendor], [TargetVendor])
GHC_CONVERT_OS([$host_os], [TargetOS])
else
echo "Can't work out target platform"
exit 1
if test "$bootstrap_target" != ""
then
target=$bootstrap_target
echo "Target platform inferred as: $target"
else
echo "Can't work out target platform"
exit 1
fi
TargetArch=`echo "$target" | sed 's/-.*//'`
TargetVendor=`echo "$target" | sed -e 's/.*-\(.*\)-.*/\1/'`
TargetOS=`echo "$target" | sed 's/.*-//'`
fi
TargetArch=`echo "$target" | sed 's/-.*//'`
TargetVendor=`echo "$target" | sed -e 's/.*-\(.*\)-.*/\1/'`
TargetOS=`echo "$target" | sed 's/.*-//'`
else
GHC_CONVERT_CPU([$target_cpu], [TargetArch])
GHC_CONVERT_VENDOR([$target_vendor], [TargetVendor])
......@@ -238,9 +245,15 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS],
osf3)
test -z "[$]2" || eval "[$]2=OSOsf3"
;;
nto-qnx)
test -z "[$]2" || eval "[$]2=OSQNXNTO"
;;
dragonfly|osf1|hpux|linuxaout|freebsd2|cygwin32|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix)
test -z "[$]2" || eval "[$]2=OSUnknown"
;;
linux-android)
test -z "[$]2" || eval "[$]2=OSAndroid"
;;
*)
echo "Unknown OS '[$]1'"
exit 1
......@@ -377,6 +390,7 @@ AC_DEFUN([FP_SETTINGS],
then
mingw_bin_prefix=mingw/bin/
SettingsCCompilerCommand="\$topdir/../${mingw_bin_prefix}gcc.exe"
SettingsLdCommand="\$topdir/../${mingw_bin_prefix}ld.exe"
SettingsArCommand="\$topdir/../${mingw_bin_prefix}ar.exe"
SettingsPerlCommand='$topdir/../perl/perl.exe'
SettingsDllWrapCommand="\$topdir/../${mingw_bin_prefix}dllwrap.exe"
......@@ -384,6 +398,7 @@ AC_DEFUN([FP_SETTINGS],
SettingsTouchCommand='$topdir/touchy.exe'
else
SettingsCCompilerCommand="$WhatGccIsCalled"
SettingsLdCommand="$LdCmd"
SettingsArCommand="$ArCmd"
SettingsPerlCommand="$PerlCmd"
SettingsDllWrapCommand="/bin/false"
......@@ -406,6 +421,7 @@ AC_DEFUN([FP_SETTINGS],
SettingsLdFlags="$CONF_LD_LINKER_OPTS_STAGE2"
AC_SUBST(SettingsCCompilerCommand)
AC_SUBST(SettingsCCompilerFlags)
AC_SUBST(SettingsLdCommand)
AC_SUBST(SettingsLdFlags)
AC_SUBST(SettingsArCommand)
AC_SUBST(SettingsPerlCommand)
......@@ -1808,6 +1824,9 @@ AC_DEFUN([GHC_CONVERT_VENDOR],[
# converts os from gnu to ghc naming, and assigns the result to $target_var
AC_DEFUN([GHC_CONVERT_OS],[
case "$1" in
linux-android*)
$2="linux-android"
;;
linux-*|linux)
$2="linux"
;;
......@@ -1820,6 +1839,9 @@ case "$1" in
# i686-gentoo-freebsd8.2
$2="freebsd"
;;
nto-qnx*)
$2="nto-qnx"
;;
*)
echo "Unknown OS $1"
exit 1
......
......@@ -563,6 +563,7 @@ instance Outputable StrictnessMark where
eqHsBang :: HsBang -> HsBang -> Bool
eqHsBang HsNoBang HsNoBang = True
eqHsBang HsStrict HsStrict = True
eqHsBang (HsUserBang u1 b1) (HsUserBang u2 b2) = u1==u2 && b1==b2
eqHsBang (HsUnpack Nothing) (HsUnpack Nothing) = True
......
This diff is collapsed.
......@@ -38,15 +38,15 @@ module Id (
recordSelectorFieldLabel,
-- ** Modifying an Id
setIdName, setIdUnique, Id.setIdType,
setIdExported, setIdNotExported,
globaliseId, localiseId,
setIdName, setIdUnique, Id.setIdType,
setIdExported, setIdNotExported,
globaliseId, localiseId,
setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
zapLamIdInfo, zapDemandIdInfo, zapFragileIdInfo, transferPolyIdInfo,
zapIdStrictness,
-- ** Predicates on Ids
isImplicitId, isDeadBinder,
isImplicitId, isDeadBinder,
isStrictId,
isExportedId, isLocalId, isGlobalId,
isRecordSelector, isNaughtyRecordSelector,
......@@ -69,9 +69,7 @@ module Id (
setOneShotLambda, clearOneShotLambda,
-- ** Reading 'IdInfo' fields
idArity,
idDemandInfo, idDemandInfo_maybe,
idStrictness, idStrictness_maybe,
idArity,
idUnfolding, realIdUnfolding,
idSpecialisation, idCoreRules, idHasRules,
idCafInfo,
......@@ -82,12 +80,17 @@ module Id (
setIdUnfoldingLazily,
setIdUnfolding,
setIdArity,
setIdDemandInfo,
setIdStrictness, zapIdStrictness,
setIdSpecialisation,
setIdCafInfo,
setIdOccInfo, zapIdOccInfo,
setIdDemandInfo,
setIdStrictness,
idDemandInfo,
idStrictness,
) where
#include "HsVersions.h"
......@@ -127,12 +130,14 @@ infixl 1 `setIdUnfoldingLazily`,
`setIdUnfolding`,
`setIdArity`,
`setIdOccInfo`,
`setIdDemandInfo`,
`setIdStrictness`,
`setIdSpecialisation`,
`setInlinePragma`,
`setInlineActivation`,
`idCafInfo`
`idCafInfo`,
`setIdDemandInfo`,
`setIdStrictness`
\end{code}
%************************************************************************
......@@ -464,17 +469,14 @@ idRepArity x = typeRepArity (idArity x) (idType x)
isBottomingId :: Id -> Bool
isBottomingId id = isBottomingSig (idStrictness id)
idStrictness_maybe :: Id -> Maybe StrictSig
idStrictness :: Id -> StrictSig
idStrictness_maybe id = strictnessInfo (idInfo id)
idStrictness id = idStrictness_maybe id `orElse` topSig
idStrictness id = strictnessInfo (idInfo id)
setIdStrictness :: Id -> StrictSig -> Id
setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` Just sig) id
setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` sig) id
zapIdStrictness :: Id -> Id
zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` Nothing) id
zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` topSig) id
-- | This predicate says whether the 'Id' has a strict demand placed on it or
-- has a type such that it can always be evaluated strictly (e.g., an
......@@ -485,8 +487,9 @@ zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` Nothing) id
isStrictId :: Id -> Bool
isStrictId id
= ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id )
(isStrictDmd (idDemandInfo id)) ||
(isStrictType (idType id))
(isStrictType (idType id)) ||
-- Take the best of both strictnesses - old and new
(isStrictDmd (idDemandInfo id))
---------------------------------
-- UNFOLDING
......@@ -508,14 +511,11 @@ setIdUnfoldingLazily id unfolding = modifyIdInfo (`setUnfoldingInfoLazily` unfol
setIdUnfolding :: Id -> Unfolding -> Id
setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id
idDemandInfo_maybe :: Id -> Maybe Demand
idDemandInfo :: Id -> Demand
idDemandInfo_maybe id = demandInfo (idInfo id)
idDemandInfo id = demandInfo (idInfo id) `orElse` topDmd
idDemandInfo id = demandInfo (idInfo id)
setIdDemandInfo :: Id -> Demand -> Id
setIdDemandInfo id dmd = modifyIdInfo (`setDemandInfo` Just dmd) id
setIdDemandInfo id dmd = modifyIdInfo (`setDemandInfo` dmd) id
---------------------------------
-- SPECIALISATION
......@@ -654,11 +654,11 @@ zapInfo zapper id = maybeModifyIdInfo (zapper (idInfo id)) id
zapLamIdInfo :: Id -> Id
zapLamIdInfo = zapInfo zapLamInfo
zapFragileIdInfo :: Id -> Id
zapFragileIdInfo = zapInfo zapFragileInfo
zapDemandIdInfo :: Id -> Id
zapDemandIdInfo = zapInfo zapDemandInfo
zapFragileIdInfo :: Id -> Id
zapFragileIdInfo = zapInfo zapFragileInfo
\end{code}
Note [transferPolyIdInfo]
......@@ -725,11 +725,12 @@ transferPolyIdInfo old_id abstract_wrt new_id
old_inline_prag = inlinePragInfo old_info
old_occ_info = occInfo old_info
new_arity = old_arity + arity_increase
old_strictness = strictnessInfo old_info
new_strictness = fmap (increaseStrictSigArity arity_increase) old_strictness
new_strictness = increaseStrictSigArity arity_increase old_strictness
transfer new_info = new_info `setStrictnessInfo` new_strictness
`setArityInfo` new_arity
transfer new_info = new_info `setArityInfo` new_arity
`setInlinePragInfo` old_inline_prag
`setOccInfo` old_occ_info
`setStrictnessInfo` new_strictness
\end{code}
......@@ -25,7 +25,9 @@ module IdInfo (
seqIdInfo, megaSeqIdInfo,
-- ** Zapping various forms of Info
zapLamInfo, zapDemandInfo, zapFragileInfo,
zapLamInfo, zapFragileInfo,
zapDemandInfo,
-- ** The ArityInfo type
ArityInfo,
......@@ -82,12 +84,10 @@ import BasicTypes
import DataCon
import TyCon
import ForeignCall
import Demand
import Outputable
import Module
import FastString
import Data.Maybe
import Demand
-- infixl so you can say (id `set` a `set` b)
infixl 1 `setSpecInfo`,
......@@ -203,14 +203,10 @@ data IdInfo
inlinePragInfo :: InlinePragma, -- ^ Any inline pragma atached to the 'Id'
occInfo :: OccInfo, -- ^ How the 'Id' occurs in the program
strictnessInfo :: Maybe StrictSig, -- ^ Id strictness information. Reason for Maybe:
-- the DmdAnal phase needs to know whether
-- this is the first visit, so it can assign botSig.
-- Other customers want topSig. So @Nothing@ is good.
strictnessInfo :: StrictSig, -- ^ A strictness signature
demandInfo :: Demand -- ^ ID demand information
demandInfo :: Maybe Demand -- ^ Id demand information. Similarly we want to know
-- if there's no known demand yet, for when we are looking
-- for CPR info
}
-- | Just evaluate the 'IdInfo' to WHNF
......@@ -227,20 +223,18 @@ megaSeqIdInfo info
-- some unfoldings are not calculated at all
-- seqUnfolding (unfoldingInfo info) `seq`
seqDemandInfo (demandInfo info) `seq`
seqDemandInfo (demandInfo info) `seq`
seqStrictnessInfo (strictnessInfo info) `seq`
seqCaf (cafInfo info) `seq`
seqLBVar (lbvarInfo info) `seq`
seqOccInfo (occInfo info)
seqStrictnessInfo :: Maybe StrictSig -> ()
seqStrictnessInfo Nothing = ()
seqStrictnessInfo (Just ty) = seqStrictSig ty
seqStrictnessInfo :: StrictSig -> ()
seqStrictnessInfo ty = seqStrictSig ty
seqDemandInfo :: Maybe Demand -> ()
seqDemandInfo Nothing = ()
seqDemandInfo (Just dmd) = seqDemand dmd
seqDemandInfo :: Demand -> ()
seqDemandInfo dmd = seqDemand dmd
\end{code}
Setters
......@@ -275,10 +269,10 @@ setCafInfo info caf = info { cafInfo = caf }
setLBVarInfo :: IdInfo -> LBVarInfo -> IdInfo
setLBVarInfo info lb = {-lb `seq`-} info { lbvarInfo = lb }
setDemandInfo :: IdInfo -> Maybe Demand -> IdInfo
setDemandInfo info dd = dd `seq` info { demandInfo = dd }
setDemandInfo :: IdInfo -> Demand -> IdInfo
setDemandInfo info dd = dd `seq` info { demandInfo = dd }
setStrictnessInfo :: IdInfo -> Maybe StrictSig -> IdInfo
setStrictnessInfo :: IdInfo -> StrictSig -> IdInfo
setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd }
\end{code}
......@@ -295,8 +289,8 @@ vanillaIdInfo
lbvarInfo = NoLBVarInfo,
inlinePragInfo = defaultInlinePragma,
occInfo = NoOccInfo,
demandInfo = Nothing,
strictnessInfo = Nothing
demandInfo = topDmd,
strictnessInfo = topSig
}
-- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references
......@@ -363,9 +357,8 @@ type InlinePragInfo = InlinePragma
%************************************************************************
\begin{code}
pprStrictness :: Maybe StrictSig -> SDoc
pprStrictness Nothing = empty
pprStrictness (Just sig) = ppr sig
pprStrictness :: StrictSig -> SDoc
pprStrictness sig = ppr sig
\end{code}
......@@ -524,7 +517,7 @@ zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand})
| is_safe_occ occ && is_safe_dmd demand
= Nothing
| otherwise
= Just (info {occInfo = safe_occ, demandInfo = Nothing})
= Just (info {occInfo = safe_occ, demandInfo = topDmd})
where
-- The "unsafe" occ info is the ones that say I'm not in a lambda
-- because that might not be true for an unsaturated lambda
......@@ -535,16 +528,13 @@ zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand})
OneOcc _ once int_cxt -> OneOcc insideLam once int_cxt
_other -> occ
is_safe_dmd Nothing = True
is_safe_dmd (Just dmd) = not (isStrictDmd dmd)
is_safe_dmd dmd = not (isStrictDmd dmd)
\end{code}
\begin{code}
-- | Remove demand info on the 'IdInfo' if it is present, otherwise return @Nothing@
zapDemandInfo :: IdInfo -> Maybe IdInfo
zapDemandInfo info@(IdInfo {demandInfo = dmd})
| isJust dmd = Just (info {demandInfo = Nothing})
| otherwise = Nothing
zapDemandInfo info = Just (info {demandInfo = topDmd})
\end{code}
\begin{code}
......
......@@ -230,7 +230,6 @@ Hence we translate to
-- Coercion from family type to representation type
Co7T a :: T [a] ~ :R7T a
Note [Newtype datacons]
~~~~~~~~~~~~~~~~~~~~~~~
The "data constructor" for a newtype should always be vanilla. At one
......@@ -286,10 +285,10 @@ mkDictSelId dflags no_unf name clas
-- to get (say) C a -> (a -> a)
base_info = noCafIdInfo
`setArityInfo` 1
`setStrictnessInfo` Just strict_sig
`setUnfoldingInfo` (if no_unf then noUnfolding
else mkImplicitUnfolding dflags rhs)
`setArityInfo` 1
`setStrictnessInfo` strict_sig
`setUnfoldingInfo` (if no_unf then noUnfolding
else mkImplicitUnfolding dflags rhs)
-- In module where class op is defined, we must add
-- the unfolding, even though it'll never be inlined
-- becuase we use that to generate a top-level binding
......@@ -318,10 +317,12 @@ mkDictSelId dflags no_unf name clas
-- where the V depends on which item we are selecting
-- It's worth giving one, so that absence info etc is generated
-- even if the selector isn't inlined
strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] TopRes)
strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] topRes)
arg_dmd | new_tycon = evalDmd
| otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
| id <- arg_ids ])
| otherwise = mkProdDmd [ if the_arg_id == id then evalDmd else absDmd
| id <- arg_ids ]
tycon = classTyCon clas
new_tycon = isNewTyCon tycon
......@@ -384,7 +385,7 @@ mkDataConWorkId wkr_name data_con
wkr_arity = dataConRepArity data_con
wkr_info = noCafIdInfo
`setArityInfo` wkr_arity
`setStrictnessInfo` Just wkr_sig
`setStrictnessInfo` wkr_sig
`setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated,
-- even if arity = 0
......@@ -428,9 +429,9 @@ dataConCPR con
, isDataTyCon tycon
, wkr_arity > 0
, wkr_arity <= mAX_CPR_SIZE
= retCPR
= cprRes
| otherwise
= TopRes
= topRes
-- RetCPR is only true for products that are real data types;
-- that is, not unboxed tuples or [non-recursive] newtypes
where
......@@ -486,7 +487,7 @@ mkDataConRep dflags fam_envs wrap_name data_con
-- applications are treated as values
`setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` wrap_unf
`setStrictnessInfo` Just wrap_sig
`setStrictnessInfo` wrap_sig
-- We need to get the CAF info right here because TidyPgm
-- does not tidy the IdInfo of implicit bindings (like the wrapper)
-- so it not make sure that the CAF info is sane
......@@ -494,7 +495,7 @@ mkDataConRep dflags fam_envs wrap_name data_con
wrap_sig = mkStrictSig (mkTopDmdType wrap_arg_dmds (dataConCPR data_con))
wrap_arg_dmds = map mk_dmd (dropList eq_spec wrap_bangs)
mk_dmd str | isBanged str = evalDmd
| otherwise = lazyDmd
| otherwise = topDmd
-- The Cpr info can be important inside INLINE rhss, where the
-- wrapper constructor isn't inlined.
-- And the argument strictness can be important too; we
......@@ -599,10 +600,10 @@ dataConArgRep _ _ arg_ty (HsUserBang _ False) -- No '!'
dataConArgRep dflags fam_envs arg_ty
(HsUserBang unpk_prag True) -- {-# UNPACK #-} !
| not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas
-- Don't unpack if we aren't optimising;
-- rather arbitrarily, we use -fomit-iface-pragmas
-- as the indication
-- Don't unpack if we aren't optimising; rather arbitrarily,
-- we use -fomit-iface-pragmas as the indication
, let mb_co = topNormaliseType fam_envs arg_ty
-- Unwrap type families and newtypes
arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty }
, isUnpackableType fam_envs arg_ty'
, (rep_tys, wrappers) <- dataConArgUnpack arg_ty'
......@@ -670,7 +671,10 @@ dataConArgUnpack
dataConArgUnpack arg_ty
| Just (tc, tc_args) <- splitTyConApp_maybe arg_ty
, Just con <- tyConSingleDataCon_maybe tc
, Just con <- tyConSingleAlgDataCon_maybe tc
-- NB: check for an *algebraic* data type
-- A recursive newtype might mean that
-- 'arg_ty' is a newtype
, let rep_tys = dataConInstArgTys con tc_args
= ASSERT( isVanillaDataCon con )
( rep_tys `zip` dataConRepStrictness con
......@@ -698,7 +702,7 @@ isUnpackableType :: FamInstEnvs -> Type -> Bool
-- end up relying on ourselves!
isUnpackableType fam_envs ty
| Just (tc, _) <- splitTyConApp_maybe ty
, Just con <- tyConSingleDataCon_maybe tc
, Just con <- tyConSingleAlgDataCon_maybe tc
, isVanillaDataCon con
= ok_con_args (unitNameSet (getName tc)) con
| otherwise
......@@ -713,7 +717,7 @@ isUnpackableType fam_envs ty
| Just (tc, _) <- splitTyConApp_maybe ty
, let tc_name = getName tc
= not (tc_name `elemNameSet` tcs)
&& case tyConSingleDataCon_maybe tc of
&& case tyConSingleAlgDataCon_maybe tc of
Just con | isVanillaDataCon con
-> ok_con_args (tcs `addOneToNameSet` getName tc) con
_ -> True
......@@ -888,10 +892,10 @@ mkPrimOpId prim_op
id = mkGlobalId (PrimOpId prim_op) name ty info
info = noCafIdInfo
`setSpecInfo` mkSpecInfo (maybeToList $ primOpRules name prim_op)
`setArityInfo` arity
`setStrictnessInfo` Just strict_sig
`setInlinePragInfo` neverInlinePragma
`setSpecInfo` mkSpecInfo (maybeToList $ primOpRules name prim_op)
`setArityInfo` arity
`setStrictnessInfo` strict_sig
`setInlinePragInfo` neverInlinePragma
-- We give PrimOps a NOINLINE pragma so that we don't
-- get silly warnings from Desugar.dsRule (the inline_shadows_rule
-- test) about a RULE conflicting with a possible inlining
......@@ -921,12 +925,12 @@ mkFCallId dflags uniq fcall ty
info = noCafIdInfo
`setArityInfo` arity
`setStrictnessInfo` Just strict_sig
`setStrictnessInfo` strict_sig
(_, tau) = tcSplitForAllTys ty
(arg_tys, _) = tcSplitFunTys tau
arity = length arg_tys
strict_sig = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes)
(_, tau) = tcSplitForAllTys ty
(arg_tys, _) = tcSplitFunTys tau
arity = length arg_tys
strict_sig = mkStrictSig (mkTopDmdType (replicate arity evalDmd) topRes)
\end{code}
......
......@@ -9,7 +9,31 @@ module CmmInfo (
mkEmptyContInfoTable,
cmmToRawCmm,
mkInfoTable,
srtEscape
srtEscape,
-- info table accessors
closureInfoPtr,
entryCode,
getConstrTag,
cmmGetClosureType,
infoTable,
infoTableConstrTag,
infoTableSrtBitmap,
infoTableClosureType,
infoTablePtrs,
infoTableNonPtrs,
funInfoTable,
-- info table sizes and offsets
stdInfoTableSizeW,
fixedInfoTableSizeW,
profInfoTableSizeW,
maxStdInfoTableSizeW,
maxRetInfoTableSizeW,
stdInfoTableSizeB,
stdSrtBitmapOffset,
stdClosureTypeOffset,
stdPtrsOffset, stdNonPtrsOffset,
) where
#include "HsVersions.h"
......@@ -388,3 +412,132 @@ newStringLit bytes
-- | Value of the srt field of an info table when using an StgLargeSRT
srtEscape :: DynFlags -> StgHalfWord
srtEscape dflags = toStgHalfWord dflags (-1)
-------------------------------------------------------------------------
--
-- Accessing fields of an info table
--
-------------------------------------------------------------------------
closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr
-- Takes a closure pointer and returns the info table pointer
closureInfoPtr dflags e = CmmLoad e (bWord dflags)
entryCode :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info pointer (the first word of a closure)
-- and returns its entry code
entryCode dflags e
| tablesNextToCode dflags = e
| otherwise = CmmLoad e (bWord dflags)
getConstrTag :: DynFlags -> CmmExpr -> CmmExpr
-- Takes a closure pointer, and return the *zero-indexed*
-- constructor tag obtained from the info table
-- This lives in the SRT field of the info table
-- (constructors don't need SRTs).
getConstrTag dflags closure_ptr
= CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table]
where
info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr
-- Takes a closure pointer, and return the closure type
-- obtained from the info table
cmmGetClosureType dflags closure_ptr
= CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table]
where
info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
infoTable :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info pointer (the first word of a closure)
-- and returns a pointer to the first word of the standard-form
-- info table, excluding the entry-code word (if present)
infoTable dflags info_ptr
| tablesNextToCode dflags = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags)
| otherwise = cmmOffsetW dflags info_ptr 1 -- Past the entry code pointer
infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info table pointer (from infoTable) and returns the constr tag
-- field of the info table (same as the srt_bitmap field)
infoTableConstrTag = infoTableSrtBitmap
infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info table pointer (from infoTable) and returns the srt_bitmap
-- field of the info table
infoTableSrtBitmap dflags info_tbl
= CmmLoad (cmmOffsetB dflags info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord dflags)
infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info table pointer (from infoTable) and returns the closure type
-- field of the info table.
infoTableClosureType dflags info_tbl
= CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags)
infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr
infoTablePtrs dflags info_tbl
= CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags)
infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr
infoTableNonPtrs dflags info_tbl
= CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags)
funInfoTable :: DynFlags -> CmmExpr -> CmmExpr
-- Takes the info pointer of a function,
-- and returns a pointer to the first word of the StgFunInfoExtra struct
-- in the info table.
funInfoTable dflags info_ptr
| tablesNextToCode dflags
= cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags)
| otherwise
= cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags)
-- Past the entry code pointer
-----------------------------------------------------------------------------