Commit 7e602b0a authored by simonpj's avatar simonpj

[project @ 1998-12-18 17:40:31 by simonpj]

Another big commit from Simon.  Actually, the last one
didn't all go into the main trunk; because of a CVS glitch it
ended up in the wrong branch.

So this commit includes:

* Scoped type variables
* Warnings for unused variables should work now (they didn't before)
* Simplifier improvements:
	- Much better treatment of strict arguments
	- Better treatment of bottoming Ids
	- No need for w/w split for fns that are merely strict
	- Fewer iterations needed, I hope
* Less gratuitous renaming in interface files and abs C
* OccName is a separate module, and is an abstract data type

I think the whole Prelude and Exts libraries compile correctly.
Something isn't quite right about typechecking existentials though.
parent 139f0fd3
cvs remove TcGRHSs.hi-boot TcGRHSs.hi-boot-5 TcGRHSs.lhs
cvs remove pbinding.ugn
cvs add grhsb.ugn gdexp.ugn
cvs add basicTypes/OccName.lhs
New in 4.02
* Scoped type variables
* Warnings for unused variables should work now (they didn't before)
* Simplifier improvements:
- Much better treatment of strict arguments
- Better treatment of bottoming Ids
- No need for w/w split for fns that are merely strict
- Fewer iterations needed, I hope
* Less gratuitous renaming in interface files and abs C
* OccName is a separate module, and is an abstract data type
-----------------------
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: AbsCSyn.lhs,v 1.18 1998/12/02 13:17:16 simonm Exp $
% $Id: AbsCSyn.lhs,v 1.19 1998/12/18 17:40:32 simonpj Exp $
%
\section[AbstractC]{Abstract C: the last stop before machine code}
......
......@@ -30,7 +30,7 @@ import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply,
import CmdLineOpts ( opt_ProduceC )
import Maybes ( maybeToBool )
import PrimOp ( PrimOp(..) )
import Util ( panic )
import Panic ( panic )
infixr 9 `thenFlt`
\end{code}
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CLabel.lhs,v 1.21 1998/12/02 13:17:19 simonm Exp $
% $Id: CLabel.lhs,v 1.22 1998/12/18 17:40:34 simonpj Exp $
%
\section[CLabel]{@CLabel@: Information to make C Labels}
......
This module deals with printing (a) C string literals and (b) C labels.
This module deals with printing C string literals
\begin{code}
module CStrings(
cSEP, pp_cSEP,
cSEP,
pp_cSEP,
identToC, modnameToC,
stringToC, charToC,
charToEasyHaskell
) where
#include "HsVersions.h"
import Char ( isAlphanum, ord, chr )
import Char ( ord, chr )
import Outputable
\end{code}
\begin{verbatim}
_ is the main separator
orig becomes
**** *******
_ Zu
' Zq (etc for ops ??)
<funny char> Z[hex-digit][hex-digit]
Prelude<x> ZP<x>
<std class> ZC<?>
<std tycon> ZT<?>
\end{verbatim}
\begin{code}
cSEP = SLIT("_") -- official C separator
pp_cSEP = char '_'
identToC :: FAST_STRING -> SDoc
modnameToC :: FAST_STRING -> FAST_STRING
stringToC :: String -> String
charToC, charToEasyHaskell :: Char -> String
......@@ -92,60 +73,5 @@ octify n
[chr (n + ord '0')]
else
octify (n `quot` 8) ++ [chr (n `rem` 8 + ord '0')]
identToC ps
= let
str = _UNPK_ ps
in
(<>)
(case str of
's':'t':'d':_ -> -- avoid "stdin", "stdout", and "stderr"...
char 'Z'
_ -> empty)
(if (all isAlphanum str) -- we gamble that this test will succeed...
then ptext ps
else hcat (map char_to_c str))
where
char_to_c 'Z' = ptext SLIT("ZZ")
char_to_c '&' = ptext SLIT("Za")
char_to_c '|' = ptext SLIT("Zb")
char_to_c ':' = ptext SLIT("Zc")
char_to_c '/' = ptext SLIT("Zd")
char_to_c '=' = ptext SLIT("Ze")
char_to_c '>' = ptext SLIT("Zg")
char_to_c '#' = ptext SLIT("Zh")
char_to_c '<' = ptext SLIT("Zl")
char_to_c '-' = ptext SLIT("Zm")
char_to_c '!' = ptext SLIT("Zn")
char_to_c '.' = ptext SLIT("_")
char_to_c '+' = ptext SLIT("Zp")
char_to_c '\'' = ptext SLIT("Zq")
char_to_c '*' = ptext SLIT("Zt")
char_to_c '_' = ptext SLIT("_")
char_to_c c = if isAlphanum c
then char c
else char 'Z' <> int (ord c)
\end{code}
For \tr{modnameToC}, we really only have to worry about \tr{'}s (quote
chars) in the name. Rare.
\begin{code}
modnameToC ps
= let
str = _UNPK_ ps
in
if not (any quote_here str) then
ps
else
_PK_ (concat (map char_to_c str))
where
quote_here '\'' = True
quote_here _ = False
char_to_c c
= if isAlphanum c then [c] else 'Z' : (show (ord c))
\end{code}
......@@ -59,7 +59,7 @@ module Costs( costs,
import AbsCSyn
import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
import Util ( trace )
import Panic ( trace )
-- --------------------------------------------------------------------------
data CostRes = Cost (Int, Int, Int, Int, Int)
......
......@@ -10,11 +10,9 @@
\begin{code}
module PprAbsC (
writeRealC,
dumpRealC
#ifdef DEBUG
, pprAmode -- otherwise, not exported
, pprMagicId
#endif
dumpRealC,
pprAmode,
pprMagicId
) where
#include "HsVersions.h"
......@@ -53,7 +51,7 @@ import UniqSet ( emptyUniqSet, elementOfUniqSet,
import StgSyn ( SRT(..) )
import BitSet ( intBS )
import Outputable
import Util ( nOfThem, panic, assertPanic )
import Util ( nOfThem )
import Addr ( Addr )
import ST
......@@ -320,7 +318,9 @@ pprAbsC stmt@(CCallTypedef op@(CCallOp op_str is_asm may_gc cconv) results args)
in ASSERT (length nvrs <= 1) nvrs
pprAbsC (CCodeBlock label abs_C) _
= ASSERT( maybeToBool(nonemptyAbsC abs_C) )
= if not (maybeToBool(nonemptyAbsC abs_C)) then
pprTrace "pprAbsC: curious empty code block for" (pprCLabel label) empty
else
case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
vcat [
hcat [text (if (externallyVisibleCLabel label)
......
......@@ -16,7 +16,6 @@ types that
module BasicTypes(
Version, Arity,
Unused, unused,
Module, moduleString, pprModule,
Fixity(..), FixityDirection(..), StrictnessMark(..),
NewOrData(..), IfaceFlavour(..), TopLevelFlag(..), RecFlag(..)
) where
......@@ -64,22 +63,6 @@ type Version = Int
\end{code}
%************************************************************************
%* *
\subsection[Module]{The name of a module}
%* *
%************************************************************************
\begin{code}
type Module = FAST_STRING
moduleString :: Module -> String
moduleString mod = _UNPK_ mod
pprModule :: Module -> SDoc
pprModule m = ptext m
\end{code}
%************************************************************************
%* *
\subsection[IfaceFlavour]{IfaceFlavour}
......
......@@ -51,7 +51,25 @@ data DataCon
dcName :: Name,
dcUnique :: Unique, -- Cached from Name
dcTag :: ConTag,
dcType :: Type, -- Type of the constructor (see notes below)
-- Running example:
--
-- data Eq a => T a = forall b. Ord b => MkT a [b]
dcType :: Type, -- Type of the constructor
-- forall ab . Ord b => a -> [b] -> MkT a
-- (this is *not* of the constructor Id:
-- see notes after this data type declaration)
-- The next six fields express the type of the constructor, in pieces
-- e.g.
--
-- dcTyVars = [a]
-- dcTheta = [Eq a]
-- dcExTyVars = [b]
-- dcExTheta = [Ord b]
-- dcArgTys = [a,List b]
-- dcTyCon = T
dcTyVars :: [TyVar], -- Type vars and context for the data type decl
dcTheta :: ThetaType,
......@@ -62,6 +80,7 @@ data DataCon
dcArgTys :: [Type], -- 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
......@@ -69,6 +88,11 @@ data DataCon
-- 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
-- mkT = /\ab. \deq dord p qs. Con MkT [a, b, dord, p, qs]
-- This unfolding is built in MkId.mkDataConId
dcId :: Id -- The corresponding Id
}
......
......@@ -78,9 +78,7 @@ isStrict (WwUnpack NewType _ ds) = isStrict (head ds)
isStrict (WwUnpack other _ _) = True
isStrict WwStrict = True
isStrict WwEnum = True
isStrict WwPrim = False -- NB: we treat only lifted types as strict.
-- Why is this important? Mostly it doesn't matter
-- but it saves a test for lifted-ness in SimplUtils.etaCoreExpr
isStrict WwPrim = True
isStrict _ = False
\end{code}
......@@ -97,7 +95,42 @@ isLazy _ = False -- (as they imply a worker)
%* *
%************************************************************************
\begin{code}
pprDemands demands bot = hcat (map pprDemand demands) <> pp_bot
where
pp_bot | bot = ptext SLIT("B")
| otherwise = empty
pprDemand (WwLazy False) = char 'L'
pprDemand (WwLazy True) = char 'A'
pprDemand WwStrict = char 'S'
pprDemand WwPrim = char 'P'
pprDemand WwEnum = char 'E'
pprDemand (WwUnpack nd wu args) = char ch <> parens (hcat (map pprDemand args))
where
ch = case nd of
DataType | wu -> 'U'
| otherwise -> 'u'
NewType | wu -> 'N'
| otherwise -> 'n'
instance Outputable Demand where
ppr (WwLazy False) = empty
ppr other_demand = ptext SLIT("__D") <+> pprDemand other_demand
instance Show Demand where
showsPrec p d = showsPrecSDoc p (ppr d)
\end{code}
\begin{code}
{- ------------------- OMITTED NOW -------------------------------
-- Reading demands is done in Lex.lhs
-- Also note that the (old) code here doesn't take proper
-- account of the 'B' suffix for bottoming functions
#ifdef REALLY_HASKELL_1_3
instance Read Demand where
......@@ -113,6 +146,8 @@ instance Text Demand where
showsPrec p d = showsPrecSDoc p (ppr d)
#endif
readDemands :: String ->
read_em acc ('L' : xs) = read_em (WwLazy False : acc) xs
read_em acc ('A' : xs) = read_em (WwLazy True : acc) xs
read_em acc ('S' : xs) = read_em (WwStrict : acc) xs
......@@ -128,25 +163,8 @@ read_em acc rest = [(reverse acc, rest)]
do_unpack new_or_data wrapper_unpacks acc xs
= case (read_em [] xs) of
[(stuff, rest)] -> read_em (WwUnpack new_or_data wrapper_unpacks stuff : acc) rest
_ -> pprPanic "Demand.do_unpack:" (ppr acc <+> text ("::"++xs))
pprDemands demands = hcat (map pprDemand demands)
pprDemand (WwLazy False) = char 'L'
pprDemand (WwLazy True) = char 'A'
pprDemand WwStrict = char 'S'
pprDemand WwPrim = char 'P'
pprDemand WwEnum = char 'E'
pprDemand (WwUnpack nd wu args) = char ch <> parens (pprDemands args)
where
ch = case nd of
DataType | wu -> 'U'
| otherwise -> 'u'
NewType | wu -> 'N'
| otherwise -> 'n'
_ -> pprPanic "Demand.do_unpack:" (ppr acc <+> dcolon <> text xs)
instance Outputable Demand where
ppr (WwLazy False) = empty
ppr other_demand = ptext SLIT("__D") <+> pprDemand other_demand
-------------------- END OF OMISSION ------------------------------ -}
\end{code}
......@@ -5,20 +5,19 @@
\begin{code}
module Id (
Id, DictId, GenId,
Id, DictId,
-- Simple construction
mkVanillaId, mkImportedId, mkSysLocal, mkUserLocal,
mkTemplateLocals, mkWildId, mkUserId,
-- Taking an Id apart
idName, idType, idUnique, idInfo,
idName, idType, idUnique, idInfo, idDetails,
idPrimRep, isId,
recordSelectorFieldLabel,
-- Modifying an Id
setIdName, setIdUnique, setIdType, setIdInfo,
setIdVisibility, mkIdVisible,
setIdName, setIdUnique, setIdType, setIdInfo, mkIdVisible,
-- Predicates
omitIfaceSigForId,
......@@ -34,7 +33,7 @@ module Id (
isRecordSelector,
isPrimitiveId_maybe, isDataConId_maybe,
isConstantId,
isBottomingId,
isBottomingId, idAppIsBottom,
-- IdInfo stuff
setIdUnfolding,
......@@ -59,25 +58,24 @@ module Id (
import {-# SOURCE #-} CoreUnfold ( Unfolding )
import Var ( Id, GenId, DictId, VarDetails(..),
import Var ( Id, DictId, VarDetails(..),
isId, mkId,
idName, idType, idUnique, idInfo, varDetails,
idName, idType, idUnique, idInfo, idDetails,
setIdName, setVarType, setIdUnique, setIdInfo, modifyIdInfo,
externallyVisibleId
)
import VarSet
import Type ( GenType, Type, tyVarsOfType, typePrimRep, addFreeTyVars )
import Type ( Type, tyVarsOfType, typePrimRep, addFreeTyVars )
import IdInfo
import Demand ( Demand )
import Name ( Name, OccName,
import Name ( Name, OccName, Module,
mkSysLocalName, mkLocalName,
isWiredInName, setNameVisibility, mkNameVisible
isWiredInName, mkNameVisible
)
import Const ( Con(..) )
import PrimRep ( PrimRep )
import PrimOp ( PrimOp )
import FieldLabel ( FieldLabel(..) )
import BasicTypes ( Module )
import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques )
import Outputable
......@@ -100,22 +98,22 @@ infixl 1 `setIdUnfolding`,
%************************************************************************
\begin{code}
mkVanillaId :: Name -> (GenType flexi) -> GenId flexi
mkVanillaId name ty = mkId name ty VanillaId noIdInfo
mkVanillaId :: Name -> Type -> Id
mkVanillaId name ty = mkId name (addFreeTyVars ty) VanillaId noIdInfo
mkImportedId :: Name -> Type -> IdInfo -> Id
mkImportedId name ty info = mkId name ty VanillaId info
mkImportedId name ty info = mkId name (addFreeTyVars ty) VanillaId info
mkUserId :: Name -> GenType flexi -> GenId flexi
mkUserId :: Name -> Type -> Id
mkUserId name ty = mkVanillaId name ty
-- SysLocal: for an Id being created by the compiler out of thin air...
-- UserLocal: an Id with a name the user might recognize...
mkUserLocal :: OccName -> Unique -> GenType flexi -> GenId flexi
mkSysLocal :: Unique -> GenType flexi -> GenId flexi
mkUserLocal :: OccName -> Unique -> Type -> Id
mkSysLocal :: FAST_STRING -> Unique -> Type -> Id
mkSysLocal uniq ty = mkVanillaId (mkSysLocalName uniq) ty
mkUserLocal occ uniq ty = mkVanillaId (mkLocalName uniq occ) ty
mkSysLocal fs uniq ty = mkVanillaId (mkSysLocalName uniq fs) ty
mkUserLocal occ uniq ty = mkVanillaId (mkLocalName uniq occ) ty
\end{code}
Make some local @Ids@ for a template @CoreExpr@. These have bogus
......@@ -125,11 +123,11 @@ instantiated before use.
\begin{code}
-- "Wild Id" typically used when you need a binder that you don't expect to use
mkWildId :: Type -> Id
mkWildId ty = mkSysLocal (mkBuiltinUnique 1) ty
mkWildId ty = mkSysLocal SLIT("wild") (mkBuiltinUnique 1) ty
-- "Template locals" typically used in unfoldings
mkTemplateLocals :: [Type] -> [Id]
mkTemplateLocals tys = zipWith mkSysLocal
mkTemplateLocals tys = zipWith (mkSysLocal SLIT("tpl"))
(getBuiltinUniques (length tys))
tys
\end{code}
......@@ -142,10 +140,10 @@ mkTemplateLocals tys = zipWith mkSysLocal
%************************************************************************
\begin{code}
idFreeTyVars :: (GenId flexi) -> (GenTyVarSet flexi)
idFreeTyVars :: Id -> TyVarSet
idFreeTyVars id = tyVarsOfType (idType id)
setIdType :: GenId flexi1 -> GenType flexi2 -> GenId flexi2
setIdType :: Id -> Type -> Id
-- Add free tyvar info to the type
setIdType id ty = setVarType id (addFreeTyVars ty)
......@@ -164,7 +162,7 @@ omitIfaceSigForId id
= True
| otherwise
= case varDetails id of
= case idDetails id of
RecordSelId _ -> True -- Includes dictionary selectors
ConstantId _ -> True
-- ConstantIds are implied by their type or class decl;
......@@ -175,13 +173,7 @@ omitIfaceSigForId id
other -> False -- Don't omit!
\end{code}
See notes with setNameVisibility (Name.lhs)
\begin{code}
setIdVisibility :: Maybe Module -> Unique -> Id -> Id
setIdVisibility maybe_mod u id
= setIdName id (setNameVisibility maybe_mod u (idName id))
mkIdVisible :: Module -> Unique -> Id -> Id
mkIdVisible mod u id
= setIdName id (mkNameVisible mod u (idName id))
......@@ -195,22 +187,22 @@ mkIdVisible mod u id
\begin{code}
recordSelectorFieldLabel :: Id -> FieldLabel
recordSelectorFieldLabel id = case varDetails id of
recordSelectorFieldLabel id = case idDetails id of
RecordSelId lbl -> lbl
isRecordSelector id = case varDetails id of
isRecordSelector id = case idDetails id of
RecordSelId lbl -> True
other -> False
isPrimitiveId_maybe id = case varDetails id of
isPrimitiveId_maybe id = case idDetails id of
ConstantId (PrimOp op) -> Just op
other -> Nothing
isDataConId_maybe id = case varDetails id of
isDataConId_maybe id = case idDetails id of
ConstantId (DataCon con) -> Just con
other -> Nothing
isConstantId id = case varDetails id of
isConstantId id = case idDetails id of
ConstantId _ -> True
other -> False
\end{code}
......@@ -225,61 +217,65 @@ isConstantId id = case varDetails id of
\begin{code}
---------------------------------
-- ARITY
getIdArity :: GenId flexi -> ArityInfo
getIdArity :: Id -> ArityInfo
getIdArity id = arityInfo (idInfo id)
setIdArity :: GenId flexi -> ArityInfo -> GenId flexi
setIdArity :: Id -> ArityInfo -> Id
setIdArity id arity = modifyIdInfo id (arity `setArityInfo`)
---------------------------------
-- STRICTNESS
getIdStrictness :: GenId flexi -> StrictnessInfo
getIdStrictness :: Id -> StrictnessInfo
getIdStrictness id = strictnessInfo (idInfo id)
setIdStrictness :: GenId flexi -> StrictnessInfo -> GenId flexi
setIdStrictness :: Id -> StrictnessInfo -> Id
setIdStrictness id strict_info = modifyIdInfo id (strict_info `setStrictnessInfo`)
isBottomingId :: GenId flexi -> Bool
isBottomingId id = bottomIsGuaranteed (strictnessInfo (idInfo id))
-- isBottomingId returns true if an application to n args would diverge
isBottomingId :: Id -> Bool
isBottomingId id = isBottomingStrictness (strictnessInfo (idInfo id))
idAppIsBottom :: Id -> Int -> Bool
idAppIsBottom id n = appIsBottom (strictnessInfo (idInfo id)) n
---------------------------------
-- UNFOLDING
getIdUnfolding :: GenId flexi -> Unfolding
getIdUnfolding :: Id -> Unfolding
getIdUnfolding id = unfoldingInfo (idInfo id)
setIdUnfolding :: GenId flexi -> Unfolding -> GenId flexi
setIdUnfolding :: Id -> Unfolding -> Id
setIdUnfolding id unfolding = modifyIdInfo id (unfolding `setUnfoldingInfo`)
---------------------------------
-- DEMAND
getIdDemandInfo :: GenId flexi -> Demand
getIdDemandInfo :: Id -> Demand
getIdDemandInfo id = demandInfo (idInfo id)
setIdDemandInfo :: GenId flexi -> Demand -> GenId flexi
setIdDemandInfo :: Id -> Demand -> Id
setIdDemandInfo id demand_info = modifyIdInfo id (demand_info `setDemandInfo`)
---------------------------------
-- UPDATE INFO
getIdUpdateInfo :: GenId flexi -> UpdateInfo
getIdUpdateInfo :: Id -> UpdateInfo
getIdUpdateInfo id = updateInfo (idInfo id)
setIdUpdateInfo :: GenId flexi -> UpdateInfo -> GenId flexi
setIdUpdateInfo :: Id -> UpdateInfo -> Id
setIdUpdateInfo id upd_info = modifyIdInfo id (upd_info `setUpdateInfo`)
---------------------------------
-- SPECIALISATION
getIdSpecialisation :: GenId flexi -> IdSpecEnv
getIdSpecialisation :: Id -> IdSpecEnv
getIdSpecialisation id = specInfo (idInfo id)
setIdSpecialisation :: GenId flexi -> IdSpecEnv -> GenId flexi
setIdSpecialisation :: Id -> IdSpecEnv -> Id
setIdSpecialisation id spec_info = modifyIdInfo id (spec_info `setSpecInfo`)
---------------------------------
-- CAF INFO
getIdCafInfo :: GenId flexi -> CafInfo
getIdCafInfo :: Id -> CafInfo
getIdCafInfo id = cafInfo (idInfo id)
setIdCafInfo :: GenId flexi -> CafInfo -> GenId flexi
setIdCafInfo :: Id -> CafInfo -> Id
setIdCafInfo id caf_info = modifyIdInfo id (caf_info `setCafInfo`)
\end{code}
......@@ -290,16 +286,16 @@ The inline pragma tells us to be very keen to inline this Id, but it's still
OK not to if optimisation is switched off.
\begin{code}
getInlinePragma :: GenId flexi -> InlinePragInfo
getInlinePragma :: Id -> InlinePragInfo
getInlinePragma id = inlinePragInfo (idInfo id)
setInlinePragma :: GenId flexi -> InlinePragInfo -> GenId flexi
setInlinePragma :: Id -> InlinePragInfo -> Id
setInlinePragma id prag = modifyIdInfo id (setInlinePragInfo prag)
modifyInlinePragma :: GenId flexi -> (InlinePragInfo -> InlinePragInfo) -> GenId flexi
modifyInlinePragma :: Id -> (InlinePragInfo -> InlinePragInfo) -> Id
modifyInlinePragma id fn = modifyIdInfo id (\info -> setInlinePragInfo (fn (inlinePragInfo info)) info)
idWantsToBeINLINEd :: GenId flexi -> Bool
idWantsToBeINLINEd :: Id -> Bool
idWantsToBeINLINEd id = case getInlinePragma id of
IWantToBeINLINEd -> True
IMustBeINLINEd -> True
......
......@@ -20,9 +20,10 @@ module IdInfo (
-- Strictness
StrictnessInfo(..), -- Non-abstract
workerExists, mkStrictnessInfo, mkBottomStrictnessInfo,
noStrictnessInfo, bottomIsGuaranteed, strictnessInfo,
workerExists, mkStrictnessInfo,
noStrictnessInfo, strictnessInfo,
ppStrictnessInfo, setStrictnessInfo,
isBottomingStrictness, appIsBottom,
-- Unfolding
unfoldingInfo, setUnfoldingInfo,
......@@ -302,52 +303,46 @@ it exists); i.e. its calling convention.
data StrictnessInfo
= NoStrictnessInfo
| BottomGuaranteed -- This Id guarantees never to return;
-- it is bottom regardless of its arguments.
-- Useful for "error" and other disguised
-- variants thereof.
| StrictnessInfo [Demand]
Bool -- True <=> the function diverges regardless of its arguments
-- Useful for "error" and other disguised variants thereof.
-- BUT NB: f = \x y. error "urk"
-- will have info SI [SS] True
-- but still (f) and (f 2) are not bot; only (f 3 2) is bot
Bool -- True <=> there is a worker. There might not be, even for a
-- strict function, because:
-- (a) the function might be small enough to inline,
-- so no need for w/w split
-- (b) the strictness info might be "SSS" or something, so no w/w split.
-- Worker's Id, if applicable, and a list of the constructors
-- mentioned by the wrapper. This is necessary so that the
-- renamer can slurp them in. Without this info, the renamer doesn't
-- know which data types to slurp in concretely. Remember, for
-- strict things we don't put the unfolding in the interface file, to save space.
-- This constructor list allows the renamer to behave much as if the
-- unfolding *was* in the interface file.
\end{code}
\begin{code}
mkStrictnessInfo :: [Demand] -> Bool -> StrictnessInfo
mkStrictnessInfo :: ([Demand], Bool) -> Bool -> StrictnessInfo
mkStrictnessInfo xs has_wrkr
| all isLazy xs = NoStrictnessInfo -- Uninteresting
| otherwise = StrictnessInfo xs has_wrkr
mkStrictnessInfo (xs, is_bot) has_wrkr
| all isLazy xs && not is_bot = NoStrictnessInfo -- Uninteresting
| otherwise = StrictnessInfo xs is_bot has_wrkr