Commit 68a1f023 authored by partain's avatar partain
Browse files

[project @ 1996-01-18 16:33:17 by partain]

Alleged post-Sansom 0.27+ code
parent ed746436
......@@ -66,37 +66,6 @@ collectTopLevelBinders (BindWith b _) = collectBinders b
collectTopLevelBinders (ThenBinds b1 b2)
= (collectTopLevelBinders b1) ++ (collectTopLevelBinders b2)
{- --------- DO THIS WHEN VarMonoBind binds a "name" rather than a "Id"
collectBinders :: Bind name (InPat name) -> [name]
collectBinders = collectGenericBinders collectPatBinders
collectTypedBinders :: TypecheckedBind -> TypecheckedPat -> [name]
collectTypedBinders = collectGenericBinders collectTypedPatBinders
collectGenericBinders :: (pat -> [name]) -> Bind name pat -> [name]
collectGenericBinders pat_fn EmptyBind = []
collectGenericBinders pat_fn (NonRecBind monobinds)
= collectGenericMonoBinders pat_fn monobinds
collectGenericBinders pat_fn (RecBind monobinds)
= collectGenericMonoBinders pat_fn monobinds
collectMonoBinders :: MonoBinds name (InPat name) -> [name]
collectMonoBinders = collectGenericMonoBinders collectPatBinders
collectGenericMonoBinders :: (pat -> [name]) -> MonoBinds name pat -> [name]
collectGenericMonoBinders pat_fn EmptyMonoBinds = []
collectGenericMonoBinders pat_fn (AndMonoBinds bs1 bs2)
= (collectGenericMonoBinders pat_fn bs1) ++ (collectGenericMonoBinders pat_fn bs2)
collectGenericMonoBinders pat_fn (PatMonoBind pat grhss_w_binds locn)
= pat_fn pat
collectGenericMonoBinders pat_fn (FunMonoBind f matches locn) = [f]
collectGenericMonoBinders pat_fn (VarMonoBind v expr) = [v]
------------------ -}
-- ------- UNTIL THEN, WE DUPLICATE CODE -----------}
collectBinders :: Bind name (InPat name) -> [name]
collectBinders EmptyBind = []
collectBinders (NonRecBind monobinds) = collectMonoBinders monobinds
......@@ -123,8 +92,6 @@ collectTypedMonoBinders (VarMonoBind v expr) = [v]
collectTypedMonoBinders (AndMonoBinds bs1 bs2)
= (collectTypedMonoBinders bs1) ++ (collectTypedMonoBinders bs2)
-- ---------- END OF DUPLICATED CODE
-- We'd like the binders -- and where they came from --
-- so we can make new ones with equally-useful origin info.
......
......@@ -63,11 +63,14 @@ import AbsUniType ( showTyCon, cmpTyCon, isBigTupleTyCon,
TyCon, Unique
)
import Id ( externallyVisibleId, cmpId_withSpecDataCon,
DataCon(..), Id, fIRST_TAG, ConTag(..)
isDataCon, isDictFunId, isConstMethodId_maybe,
isClassOpId, isDefaultMethodId_maybe, isSuperDictSelId_maybe,
Id, Class, ClassOp, DataCon(..), ConTag(..), fIRST_TAG
#ifdef DPH
,isInventedTopLevId
#endif {- Data Parallel Haskell -}
)
import Maybes
import Outputable
import Pretty ( ppNil, ppChar, ppStr, ppPStr, ppDouble, ppInt,
ppInteger, ppBeside, ppIntersperse, prettyToUn
......@@ -317,17 +320,25 @@ isAsmTemp _ = False
C ``static'' or not...
\begin{code}
externallyVisibleCLabel (TyConLabel tc _) = not (isBigTupleTyCon tc)
-- i.e. not generated for
-- purely-local use...
externallyVisibleCLabel (TyConLabel tc _) = True
externallyVisibleCLabel (CaseLabel _ _) = False
externallyVisibleCLabel (AsmTempLabel _) = False
externallyVisibleCLabel (RtsLabel _) = True
#ifndef DPH
externallyVisibleCLabel (IdLabel (CLabelId id) _) = externallyVisibleId id
externallyVisibleCLabel (IdLabel (CLabelId id) _)
| isDataCon id = True
| is_ConstMethodId id = True -- These are here to ensure splitting works
| isDictFunId id = True -- when these values have not been exported
| isClassOpId id = True
| is_DefaultMethodId id = True
| is_SuperDictSelId id = True
| otherwise = externallyVisibleId id
where
is_ConstMethodId id = maybeToBool (isConstMethodId_maybe id)
is_DefaultMethodId id = maybeToBool (isDefaultMethodId_maybe id)
is_SuperDictSelId id = maybeToBool (isSuperDictSelId_maybe id)
#else
-- DPH pays a big price for exported identifiers. For example with
-- a statically allocated closure, if it is local to a file it will
......
......@@ -93,15 +93,16 @@ getIdStrictness :: Id -> StrictnessInfo
getIdUnfolding :: Id -> UnfoldingDetails
getIdUniType :: Id -> UniType
getIdUpdateInfo :: Id -> UpdateInfo
getInstIdModule :: Id -> _PackedString
getInstNamePieces :: Bool -> Inst -> [_PackedString]
getInstantiatedDataConSig :: Id -> [UniType] -> ([UniType], [UniType], UniType)
getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)
idWantsToBeINLINEd :: Id -> Bool
isBottomingId :: Id -> Bool
isClassOpId :: Id -> Bool
isConstMethodId :: Id -> Bool
isConstMethodId_maybe :: Id -> Labda (Class, UniType, ClassOp)
isDataCon :: Id -> Bool
isDefaultMethodId :: Id -> Bool
isDefaultMethodId_maybe :: Id -> Labda (Class, ClassOp, Bool)
isDictFunId :: Id -> Bool
isImportedId :: Id -> Bool
isInstId_maybe :: Id -> Labda Inst
......@@ -116,10 +117,10 @@ isWorkerId :: Id -> Bool
isWrapperId :: Id -> Bool
localiseId :: Id -> Id
mkClassOpId :: Unique -> Class -> ClassOp -> UniType -> IdInfo -> Id
mkConstMethodId :: Unique -> Class -> ClassOp -> UniType -> UniType -> Bool -> IdInfo -> Id
mkConstMethodId :: Unique -> Class -> ClassOp -> UniType -> UniType -> Bool -> _PackedString -> IdInfo -> Id
mkDataCon :: Unique -> FullName -> [TyVarTemplate] -> [(Class, UniType)] -> [UniType] -> TyCon -> SpecEnv -> Id
mkDefaultMethodId :: Unique -> Class -> ClassOp -> Bool -> UniType -> IdInfo -> Id
mkDictFunId :: Unique -> Class -> UniType -> UniType -> Bool -> IdInfo -> Id
mkDictFunId :: Unique -> Class -> UniType -> UniType -> Bool -> _PackedString -> IdInfo -> Id
mkId :: Name -> UniType -> IdInfo -> Id
mkIdWithNewUniq :: Id -> Unique -> Id
mkImported :: Unique -> FullName -> UniType -> IdInfo -> Id
......@@ -138,6 +139,7 @@ myWrapperMaybe :: Id -> Labda Id
nullSpecEnv :: SpecEnv
pprIdInUnfolding :: UniqFM Id -> Id -> Int -> Bool -> PrettyRep
replaceIdInfo :: Id -> IdInfo -> Id
selectIdInfoForSpecId :: Id -> IdInfo
showId :: PprStyle -> Id -> [Char]
toplevelishId :: Id -> Bool
unfoldingUnfriendlyId :: Id -> Bool
......
......@@ -15,6 +15,7 @@ module Id (
mkSysLocal, mkUserLocal,
mkSpecPragmaId,
mkSpecId, mkSameSpecCon,
selectIdInfoForSpecId,
mkTemplateLocals,
mkImported, mkPreludeId,
mkDataCon, mkTupleCon,
......@@ -34,7 +35,7 @@ module Id (
-- DESTRUCTION
getIdUniType,
getInstNamePieces, getIdInfo, replaceIdInfo,
getIdKind,
getIdKind, getInstIdModule,
getMentionedTyConsAndClassesFromId,
getDataConTag,
getDataConSig, getInstantiatedDataConSig,
......@@ -50,8 +51,8 @@ module Id (
isTopLevId, isWorkerId, isWrapperId,
isImportedId, isSysLocalId,
isBottomingId,
isClassOpId, isConstMethodId, isDefaultMethodId,
isDictFunId, isInstId_maybe, isSuperDictSelId_maybe,
isClassOpId, isDefaultMethodId_maybe, isSuperDictSelId_maybe,
isDictFunId, isInstId_maybe, isConstMethodId_maybe,
#ifdef DPH
isInventedTopLevId,
isProcessorCon,
......@@ -128,9 +129,9 @@ import NameTypes
import Outputable
import Pretty -- for pretty-printing
import SrcLoc
import Subst ( applySubstToTy ) -- PRETTY GRIMY TO LOOK IN HERE
import Subst ( applySubstToTy ) -- PRETTY GRIMY TO LOOK IN HERE
import PlainCore
import PrelFuns ( pcGenerateDataSpecs ) -- PRETTY GRIMY TO LOOK IN HERE
import PrelFuns ( pcGenerateTupleSpecs ) -- PRETTY GRIMY TO LOOK IN HERE
import UniqFM
import UniqSet
import Unique
......@@ -263,6 +264,7 @@ The type variables in the name are irrelevant; we print them as stars.
-- actually do comparisons that way, we kindly supply
-- a Unique for that purpose.
Bool -- True <=> from an instance decl in this mod
FAST_STRING -- module where instance came from
\end{code}
Constant method ids are generated from instance decls where
......@@ -298,6 +300,7 @@ The type variables in the type are irrelevant.
UniType -- (class, type, classop) triple
ClassOp
Bool -- True <=> from an instance decl in this mod
FAST_STRING -- module where instance came from
| InstId Inst -- An instance of a dictionary, class operation,
-- or overloaded value
......@@ -518,8 +521,8 @@ toplevelishId (Id _ _ _ details)
chk (SuperDictSelId _ _) = True
chk (ClassOpId _ _) = True
chk (DefaultMethodId _ _ _) = True
chk (DictFunId _ _ _) = True
chk (ConstMethodId _ _ _ _) = True
chk (DictFunId _ _ _ _) = True
chk (ConstMethodId _ _ _ _ _) = True
chk (SpecId unspec _ _) = toplevelishId unspec
-- depends what the unspecialised thing is
chk (WorkerId unwrkr) = toplevelishId unwrkr
......@@ -543,8 +546,8 @@ idHasNoFreeTyVars (Id _ _ info details)
chk (SuperDictSelId _ _) = True
chk (ClassOpId _ _) = True
chk (DefaultMethodId _ _ _) = True
chk (DictFunId _ _ _) = True
chk (ConstMethodId _ _ _ _) = True
chk (DictFunId _ _ _ _) = True
chk (ConstMethodId _ _ _ _ _) = True
chk (WorkerId unwrkr) = idHasNoFreeTyVars unwrkr
chk (InstId _) = False -- these are local
chk (SpecId _ _ no_free_tvs) = no_free_tvs
......@@ -606,23 +609,23 @@ isSpecPragmaId other = False
isClassOpId (Id _ _ _ (ClassOpId _ _)) = True
isClassOpId _ = False
isDefaultMethodId (Id _ _ _ (DefaultMethodId _ _ _)) = True
isDefaultMethodId_maybe (Id _ _ _ (DefaultMethodId cls clsop err)) = Just (cls, clsop, err)
#ifdef DPH
isDefaultMethodId (PodId _ _ id) = isDefaultMethodId id
isDefaultMethodId_maybe (PodId _ _ id) = isDefaultMethodId_maybe id
#endif {- Data Parallel Haskell -}
isDefaultMethodId other = False
isDefaultMethodId_maybe other = Nothing
isDictFunId (Id _ _ _ (DictFunId _ _ _)) = True
isDictFunId (Id _ _ _ (DictFunId _ _ _ _)) = True
#ifdef DPH
isDictFunId (PodId _ _ id) = isDictFunId id
isDictFunId (PodId _ _ id) = isDictFunId id
#endif {- Data Parallel Haskell -}
isDictFunId other = False
isDictFunId other = False
isConstMethodId (Id _ _ _ (ConstMethodId _ _ _ _)) = True
isConstMethodId_maybe (Id _ _ _ (ConstMethodId cls ty clsop _ _)) = Just (cls, ty, clsop)
#ifdef DPH
isConstMethodId (PodId _ _ id) = isConstMethodId id
isConstMethodId_maybe (PodId _ _ id) = isConstMethodId_maybe id
#endif {- Data Parallel Haskell -}
isConstMethodId other = False
isConstMethodId_maybe other = Nothing
isInstId_maybe (Id _ _ _ (InstId inst)) = Just inst
#ifdef DPH
......@@ -686,9 +689,9 @@ pprIdInUnfolding in_scopes v
-- instance-ish things: should we try to figure out
-- *exactly* which extra instances have to be exported? (ToDo)
DictFunId c t _
DictFunId c t _ _
-> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t]
ConstMethodId c t o _
ConstMethodId c t o _ _
-> ppCat [ppPStr SLIT("_CONSTM_"), pp_class c, pp_class_op o, pp_type t]
-- specialisations and workers
......@@ -823,7 +826,7 @@ unfoldingUnfriendlyId (Id _ _ _ (WorkerId wrapper))
class_thing (Id _ _ _ (DefaultMethodId _ _ _)) = True
class_thing other = False
unfoldingUnfriendlyId (Id _ _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _)) _ _))
unfoldingUnfriendlyId (Id _ _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _ _)) _ _))
-- a SPEC of a DictFunId can end up w/ gratuitous
-- TyVar(Templates) in the i/face; only a problem
-- if -fshow-pragma-name-errs; but we can do without the pain.
......@@ -832,7 +835,7 @@ unfoldingUnfriendlyId (Id _ _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _)) _ _)
naughty_DictFunId dfun
--)
unfoldingUnfriendlyId d@(Id _ _ _ dfun@(DictFunId _ t _))
unfoldingUnfriendlyId d@(Id _ _ _ dfun@(DictFunId _ t _ _))
= --pprTrace "unfriendly2:" (ppCat [ppr PprDebug d, ppr PprDebug t]) (
naughty_DictFunId dfun -- similar deal...
--)
......@@ -842,8 +845,8 @@ unfoldingUnfriendlyId other_id = False -- is friendly in all other cases
naughty_DictFunId :: IdDetails -> Bool
-- True <=> has a TyVar(Template) in the "type" part of its "name"
naughty_DictFunId (DictFunId _ _ False) = False -- came from outside; must be OK
naughty_DictFunId (DictFunId _ ty _)
naughty_DictFunId (DictFunId _ _ False _) = False -- came from outside; must be OK
naughty_DictFunId (DictFunId _ ty _ _)
= not (isGroundTy ty)
\end{code}
......@@ -1112,7 +1115,7 @@ getIdNamePieces show_uniqs (Id u ty info details)
then [SLIT("defm"), op_name]
else [SLIT("defm"), c_mod, c_name, op_name] }}
DictFunId c ty _ ->
DictFunId c ty _ _ ->
case (getOrigName c) of { (c_mod, c_name) ->
let
c_bits = if fromPreludeCore c
......@@ -1124,7 +1127,7 @@ getIdNamePieces show_uniqs (Id u ty info details)
[SLIT("dfun")] ++ c_bits ++ ty_bits }
ConstMethodId c ty o _ ->
ConstMethodId c ty o _ _ ->
case (getOrigName c) of { (c_mod, c_name) ->
case (getTypeString ty) of { ty_bits ->
case (getClassOpString o) of { o_name ->
......@@ -1236,6 +1239,13 @@ getMentionedTyConsAndClassesFromId id
getIdKind i = kindFromType (getIdUniType i)
\end{code}
\begin{code}
getInstIdModule (Id _ _ _ (DictFunId _ _ _ mod)) = mod
getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ _ mod)) = mod
getInstIdModule other = panic "Id:getInstIdModule"
\end{code}
\begin{code}
{- NOT USED
getIdTauType :: Id -> TauType
......@@ -1260,11 +1270,11 @@ mkSuperDictSelId u c sc ty info = Id u ty info (SuperDictSelId c sc)
mkClassOpId u c op ty info = Id u ty info (ClassOpId c op)
mkDefaultMethodId u c op gen ty info = Id u ty info (DefaultMethodId c op gen)
mkDictFunId u c ity full_ty from_here info
= Id u full_ty info (DictFunId c ity from_here)
mkDictFunId u c ity full_ty from_here modname info
= Id u full_ty info (DictFunId c ity from_here modname)
mkConstMethodId u c op ity full_ty from_here info
= Id u full_ty info (ConstMethodId c ity op from_here)
mkConstMethodId u c op ity full_ty from_here modname info
= Id u full_ty info (ConstMethodId c ity op from_here modname)
mkWorkerId u unwrkr ty info = Id u ty info (WorkerId unwrkr)
......@@ -1313,7 +1323,7 @@ mkSysLocal str uniq ty loc
mkUserLocal str uniq ty loc
= Id uniq ty noIdInfo (LocalId (mkShortName str loc) (no_free_tvs ty))
-- for an SpecPragmaId being created by the compiler out of thin air...
-- for a SpecPragmaId being created by the compiler out of thin air...
mkSpecPragmaId :: FAST_STRING -> Unique -> UniType -> Maybe SpecInfo -> SrcLoc -> Id
mkSpecPragmaId str uniq ty specinfo loc
= Id uniq ty noIdInfo (SpecPragmaId (mkShortName str loc) specinfo (no_free_tvs ty))
......@@ -1397,6 +1407,11 @@ replaceIdInfo (Id u ty _ details) info = Id u ty info details
#ifdef DPH
replaceIdInfo (PodId dim ity id) info = PodId dim ity (replaceIdInfo id info)
#endif {- Data Parallel Haskell -}
selectIdInfoForSpecId :: Id -> IdInfo
selectIdInfoForSpecId unspec
= ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
noIdInfo `addInfo_UF` getIdUnfolding unspec
\end{code}
%************************************************************************
......@@ -1531,13 +1546,7 @@ mkTupleCon arity = data_con
tuplecon_info
= noIdInfo `addInfo_UF` unfolding
`addInfo` mkArityInfo arity
`addInfo` tuplecon_specenv
tuplecon_specenv
= if arity == 2 then
pcGenerateDataSpecs ty
else
nullSpecEnv
`addInfo` pcGenerateTupleSpecs arity ty
unfolding
= -- if arity == 0
......@@ -2081,8 +2090,8 @@ instance NamedThing Id where
get (SuperDictSelId c _) = getExportFlag c
get (ClassOpId c _) = getExportFlag c
get (DefaultMethodId c _ _) = getExportFlag c
get (DictFunId c ty from_here) = instance_export_flag c ty from_here
get (ConstMethodId c ty _ from_here) = instance_export_flag c ty from_here
get (DictFunId c ty from_here _) = instance_export_flag c ty from_here
get (ConstMethodId c ty _ from_here _) = instance_export_flag c ty from_here
get (SpecId unspec _ _) = getExportFlag unspec
get (WorkerId unwrkr) = getExportFlag unwrkr
get (InstId _) = NotExported
......@@ -2105,12 +2114,12 @@ instance NamedThing Id where
get (SuperDictSelId c _) = isLocallyDefined c
get (ClassOpId c _) = isLocallyDefined c
get (DefaultMethodId c _ _) = isLocallyDefined c
get (DictFunId c tyc from_here) = from_here
get (DictFunId c tyc from_here _) = from_here
-- For DictFunId and ConstMethodId things, you really have to
-- know whether it came from an imported instance or one
-- really here; no matter where the tycon and class came from.
get (ConstMethodId c tyc _ from_here) = from_here
get (ConstMethodId c tyc _ from_here _) = from_here
get (SpecId unspec _ _) = isLocallyDefined unspec
get (WorkerId unwrkr) = isLocallyDefined unwrkr
get (InstId _) = True
......@@ -2242,8 +2251,8 @@ instance NamedThing Id where
get (SuperDictSelId c _) = fromPreludeCore c
get (ClassOpId c _) = fromPreludeCore c
get (DefaultMethodId c _ _) = fromPreludeCore c
get (DictFunId c t _) = fromPreludeCore c && is_prelude_core_ty t
get (ConstMethodId c t _ _) = fromPreludeCore c && is_prelude_core_ty t
get (DictFunId c t _ _) = fromPreludeCore c && is_prelude_core_ty t
get (ConstMethodId c t _ _ _) = fromPreludeCore c && is_prelude_core_ty t
get (SpecId unspec _ _) = fromPreludeCore unspec
get (WorkerId unwrkr) = fromPreludeCore unwrkr
get (InstId _) = False
......
......@@ -64,7 +64,7 @@ type OutAtom = CoreAtom Id
type OutExpr = CoreExpr Id Id
type OutId = Id
data UnfoldingDetails = NoUnfoldingDetails | LiteralForm BasicLit | OtherLiteralForm [BasicLit] | ConstructorForm Id [UniType] [CoreAtom Id] | OtherConstructorForm [Id] | GeneralForm Bool FormSummary (CoreExpr (Id, BinderInfo) Id) UnfoldingGuidance | MagicForm _PackedString MagicUnfoldingFun | IWantToBeINLINEd UnfoldingGuidance
data UnfoldingGuidance = UnfoldNever | UnfoldAlways | EssentialUnfolding | UnfoldIfGoodArgs Int Int [Bool] Int
data UnfoldingGuidance = UnfoldNever | UnfoldAlways | EssentialUnfolding | UnfoldIfGoodArgs Int Int [Bool] Int | BadUnfolding
data SrcLoc
data Subst
type SimplifiableBinder = (Id, BinderInfo)
......@@ -94,7 +94,7 @@ getWorkerId :: StrictnessInfo -> Id
getWrapperArgTypeCategories :: UniType -> StrictnessInfo -> Labda [Char]
iWantToBeINLINEd :: UnfoldingGuidance -> UnfoldingDetails
indicatesWorker :: [Demand] -> Bool
lookupConstMethodId :: SpecEnv -> UniType -> Labda Id
lookupConstMethodId :: Id -> UniType -> Labda Id
lookupSpecEnv :: SpecEnv -> [UniType] -> Labda (Id, [UniType], Int)
lookupSpecId :: Id -> [Labda UniType] -> Id
mkArgUsageInfo :: [ArgUsage] -> ArgUsageInfo
......
......@@ -48,11 +48,8 @@ module IdInfo (
UnfoldingDetails(..), -- non-abstract! re-exported
UnfoldingGuidance(..), -- non-abstract; ditto
mkUnfolding,
--OLD: mkUnfolding_NoGuideGiven, -- a convenient interface; for imported things only
iWantToBeINLINEd, mkMagicUnfolding,
--UNUSED: haveUnfolding,
noInfo_UF, getInfo_UF, addInfo_UF, -- to avoid instance virus
--UNUSED: clearInfo_UF,
UpdateInfo,
mkUpdateInfo,
......@@ -96,8 +93,8 @@ import AbsPrel ( mkFunTy, nilDataCon{-HACK-}
import AbsUniType
import Bag ( emptyBag, Bag )
import CmdLineOpts ( GlobalSwitch(..) )
import Id ( getIdUniType, getDataConSig,
getInstantiatedDataConSig, getIdInfo,
import Id ( getIdUniType, getIdInfo,
getDataConSig, getInstantiatedDataConSig,
externallyVisibleId, isDataCon,
unfoldingUnfriendlyId, isWorkerId,
isWrapperId, DataCon(..)
......@@ -282,9 +279,14 @@ ppIdInfo sty for_this_id specs_please better_id_fn inline_env
ppInfo sty better_id_fn arity,
ppInfo sty better_id_fn update,
ppInfo sty better_id_fn deforest,
pp_strictness sty (Just for_this_id)
better_id_fn inline_env strictness,
pp_unfolding sty for_this_id inline_env unfold,
better_id_fn inline_env strictness,
if bottomIsGuaranteed strictness
then pp_NONE
else pp_unfolding sty for_this_id inline_env unfold,
if specs_please
then pp_specs sty (not (isDataCon for_this_id))
better_id_fn inline_env specialise
......@@ -456,11 +458,12 @@ mkSpecEnv = SpecEnv
nullSpecEnv = SpecEnv []
addOneToSpecEnv (SpecEnv xs) x = SpecEnv (x : xs)
lookupConstMethodId :: SpecEnv -> UniType -> Maybe Id
lookupConstMethodId :: Id -> UniType -> Maybe Id
-- slight variant on "lookupSpecEnv" below
lookupConstMethodId (SpecEnv spec_infos) spec_ty
= firstJust (map try spec_infos)
lookupConstMethodId sel_id spec_ty
= case (getInfo (getIdInfo sel_id)) of
SpecEnv spec_infos -> firstJust (map try spec_infos)
where
try (SpecInfo (Just ty:nothings) _ const_meth_id)
= ASSERT(all nothing_is_nothing nothings)
......@@ -469,14 +472,14 @@ lookupConstMethodId (SpecEnv spec_infos) spec_ty
_ -> Nothing
nothing_is_nothing Nothing = True -- debugging only
nothing_is_nothing _ = panic "nothing_is_nothing!"
nothing_is_nothing _ = panic "nothing_is_nothing!"
lookupSpecId :: Id -- *un*specialised Id
-> [Maybe UniType] -- types to which it is to be specialised
-> Id -- specialised Id
lookupSpecId unspec_id ty_maybes
= case (getInfo (getIdInfo unspec_id)) of { SpecEnv spec_infos ->
= case (getInfo (getIdInfo unspec_id)) of { SpecEnv spec_infos ->
case (firstJust (map try spec_infos)) of
Just id -> id
......@@ -715,7 +718,7 @@ getWorkerId :: StrictnessInfo -> Id
getWorkerId (StrictnessInfo _ (Just worker_id)) = worker_id
#ifdef DEBUG
getWorkerId junk = pprPanic "getWorkerId: Nothing" (ppInfo PprDebug (\x->x) junk)
getWorkerId junk = pprPanic "getWorkerId: " (ppInfo PprDebug (\x->x) junk)
#endif
\end{code}
......@@ -933,7 +936,7 @@ iWantToBeINLINEd :: UnfoldingGuidance -> UnfoldingDetails
mkMagicUnfolding :: FAST_STRING -> UnfoldingDetails
mkUnfolding guide expr
= GeneralForm False (mkFormSummary NoStrictnessInfo{-NB:lying-} expr)
= GeneralForm False (mkFormSummary NoStrictnessInfo expr)
(BSCC("OccurExpr") occurAnalyseGlobalExpr expr ESCC)
guide
\end{code}
......@@ -943,22 +946,24 @@ iWantToBeINLINEd guide = IWantToBeINLINEd guide
mkMagicUnfolding tag = MagicForm tag (mkMagicUnfoldingFun tag)
{- UNUSED:
haveUnfolding NoUnfoldingDetails = False
haveUnfolding (IWantToBeINLINEd _) = False -- don't have the unfolding *YET*
haveUnfolding _ = True
-}
\end{code}
\begin{code}
noInfo_UF = NoUnfoldingDetails
getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _) = unfolding
getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _)
= case unfolding of
NoUnfoldingDetails -> NoUnfoldingDetails
GeneralForm _ _ _ BadUnfolding -> NoUnfoldingDetails
unfold_ok -> unfold_ok
-- getInfo_UF ensures that any BadUnfoldings are never returned
-- We had to delay the test required in TcPragmas until now due
-- to strictness constraints in TcPragmas
addInfo_UF id_info@(IdInfo a b c d e f g h i j) NoUnfoldingDetails = id_info
addInfo_UF (IdInfo a b d e xxx f g h i j) uf = IdInfo a b d e uf f g h i j
addInfo_UF (IdInfo a b d e xxx f g h i j) uf = IdInfo a b d e uf f g h i j
--UNUSED:clearInfo_UF (IdInfo a b d e xxx f g h i j) = IdInfo a b d e noInfo_UF f g h i j
\end{code}
\begin{code}
......@@ -977,6 +982,8 @@ pp_unfolding sty for_this_id inline_env uf_details
pp (MagicForm tag _)
= ppCat [ppPStr SLIT("_MF_"), ppPStr tag]
pp (GeneralForm _ _ _ BadUnfolding) = pp_NONE
pp (GeneralForm _ _ template guide)
= let
untagged = unTagBinders template
......@@ -1104,8 +1111,8 @@ instance OptIdInfo ArgUsageInfo where
addInfo id_info NoArgUsageInfo = id_info
addInfo (IdInfo a b d e f g h _ i j) au_info = IdInfo a b d e f g h au_info i j
ppInfo sty better_id_fn NoArgUsageInfo = ifPprInterface sty pp_NONE
ppInfo sty better_id_fn (SomeArgUsageInfo []) = ifPprInterface sty pp_NONE
ppInfo sty better_id_fn NoArgUsageInfo = ifPprInterface sty pp_NONE
ppInfo sty better_id_fn (SomeArgUsageInfo []) = ifPprInterface sty pp_NONE
ppInfo sty better_id_fn (SomeArgUsageInfo aut)
= ppBeside (ppPStr SLIT("_L_ ")) (ppArgUsageType aut)
......
......@@ -62,6 +62,7 @@ intTyConKey :: Unique
integerDataConKey :: Unique
integerMinusOneIdKey :: Unique
integerPlusOneIdKey :: Unique
integerPlusTwoIdKey :: Unique
integerTyConKey :: Unique
integerZeroIdKey :: Unique
integralClassKey :: Unique
......
......@@ -152,7 +152,8 @@ module Unique (
trueDataConKey,
unpackCStringIdKey, unpackCString2IdKey, unpackCStringAppendIdKey,
packCStringIdKey,
integerZeroIdKey, integerPlusOneIdKey, integerMinusOneIdKey,
integerZeroIdKey, integerPlusOneIdKey,
integerPlusTwoIdKey, integerMinusOneIdKey,
voidPrimIdKey,
cCallableClassKey,
cReturnableClassKey,
......@@ -619,7 +620,7 @@ int2IntegerIdKey = mkPreludeMiscIdUnique 7
integerMinusOneIdKey = mkPreludeMiscIdUnique 8
integerPlusOneIdKey = mkPreludeMiscIdUnique 9
integerZeroIdKey = mkPreludeMiscIdUnique 10
--UNUSED:lexIdKey = mkPreludeMiscIdUnique 11
integerPlusTwoIdKey = mkPreludeMiscIdUnique 11
packCStringIdKey = mkPreludeMiscIdUnique 12
parIdKey = mkPreludeMiscIdUnique 13
parErrorIdKey = mkPreludeMiscIdUnique 14
......
......@@ -19,5 +19,5 @@ data AbstractC
data CompilationInfo
type TCE = UniqFM TyCon
data UniqFM a
genStaticConBits :: CompilationInfo -> [TyCon] -> FiniteMap TyCon [[Labda UniType]] -> AbstractC
genStaticConBits :: CompilationInfo -> [TyCon] -> FiniteMap TyCon [(Bool, [Labda UniType])] -> AbstractC
......@@ -20,8 +20,7 @@ import AbsCSyn
import CgMonad
import AbsUniType ( getTyConDataCons, kindFromType,
maybeIntLikeTyCon,
mkSpecTyCon, isLocalSpecTyCon,
maybeIntLikeTyCon, mkSpecTyCon,
TyVarTemplate, TyCon, Class,
TauType(..), UniType, ThetaType(..)
IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass)
......@@ -113,7 +112,7 @@ closures predeclared.
\begin{code}
genStaticConBits :: CompilationInfo -- global info about the compilation
-> [TyCon] -- tycons to generate
-> FiniteMap TyCon [[Maybe UniType]]
-> FiniteMap TyCon [(Bool, [Maybe UniType])]
-- tycon specialisation info
-> AbstractC -- output
......@@ -128,20 +127,22 @@ genStaticConBits comp_info gen_tycons tycon_specs
-- ToDo: for tycons and specialisations which are not
-- declared in this module we must ensure that the
-- C labels are local to this module i.e. static
-- since they may be duplicated in other modules
mkAbstractCs [ gen_for_tycon tc | tc <- gen_tycons ]
`mkAbsCStmts`
mkAbstractCs [ mkAbstractCs [ gen_for_spec_tycon tc spec
| spec <- specs ]
| (tc, specs) <- fmToList tycon_specs,
isLocalSpecTyCon (sw_chkr CompilingPrelude) tc
]
| (imported_spec, spec) <- specs,
-- no code generated if spec is imported
not imported_spec
]
| (tc, specs) <- fmToList tycon_specs ]
where
gen_for_tycon :: TyCon -> AbstractC
gen_for_tycon tycon
= mkAbstractCs (map (genConInfo comp_info tycon) data_cons)
`mkAbsCStmts` maybe_tycon_vtbl
`mkAbsCStmts`
maybe_tycon_vtbl
where
data_cons = getTyConDataCons tycon
tycon_upd_label = mkStdUpdVecTblLabel tycon
......@@ -151,13 +152,13 @@ genStaticConBits comp_info gen_tycons tycon_specs
UnvectoredReturn 1 -> CRetUnVector tycon_upd_label
(mk_upd_label tycon (head data_cons))
UnvectoredReturn _ -> AbsCNop
VectoredReturn _ -> CFlatRetVector tycon_upd_label
VectoredReturn _ -> CFlatRetVector tycon_upd_label
(map (mk_upd_label tycon) data_cons)