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 TcGRHSs.hi-boot TcGRHSs.hi-boot-5 TcGRHSs.lhs
cvs remove pbinding.ugn cvs remove pbinding.ugn
cvs add grhsb.ugn gdexp.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 % (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} \section[AbstractC]{Abstract C: the last stop before machine code}
......
...@@ -30,7 +30,7 @@ import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply, ...@@ -30,7 +30,7 @@ import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply,
import CmdLineOpts ( opt_ProduceC ) import CmdLineOpts ( opt_ProduceC )
import Maybes ( maybeToBool ) import Maybes ( maybeToBool )
import PrimOp ( PrimOp(..) ) import PrimOp ( PrimOp(..) )
import Util ( panic ) import Panic ( panic )
infixr 9 `thenFlt` infixr 9 `thenFlt`
\end{code} \end{code}
......
% %
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % (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} \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} \begin{code}
module CStrings( module CStrings(
cSEP, pp_cSEP,
cSEP,
pp_cSEP,
identToC, modnameToC,
stringToC, charToC, stringToC, charToC,
charToEasyHaskell charToEasyHaskell
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
import Char ( isAlphanum, ord, chr ) import Char ( ord, chr )
import Outputable import Outputable
\end{code} \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} \begin{code}
cSEP = SLIT("_") -- official C separator cSEP = SLIT("_") -- official C separator
pp_cSEP = char '_' pp_cSEP = char '_'
identToC :: FAST_STRING -> SDoc
modnameToC :: FAST_STRING -> FAST_STRING
stringToC :: String -> String stringToC :: String -> String
charToC, charToEasyHaskell :: Char -> String charToC, charToEasyHaskell :: Char -> String
...@@ -92,60 +73,5 @@ octify n ...@@ -92,60 +73,5 @@ octify n
[chr (n + ord '0')] [chr (n + ord '0')]
else else
octify (n `quot` 8) ++ [chr (n `rem` 8 + ord '0')] 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} \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, ...@@ -59,7 +59,7 @@ module Costs( costs,
import AbsCSyn import AbsCSyn
import PrimOp ( primOpNeedsWrapper, PrimOp(..) ) import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
import Util ( trace ) import Panic ( trace )
-- -------------------------------------------------------------------------- -- --------------------------------------------------------------------------
data CostRes = Cost (Int, Int, Int, Int, Int) data CostRes = Cost (Int, Int, Int, Int, Int)
......
...@@ -10,11 +10,9 @@ ...@@ -10,11 +10,9 @@
\begin{code} \begin{code}
module PprAbsC ( module PprAbsC (
writeRealC, writeRealC,
dumpRealC dumpRealC,
#ifdef DEBUG pprAmode,
, pprAmode -- otherwise, not exported pprMagicId
, pprMagicId
#endif
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -53,7 +51,7 @@ import UniqSet ( emptyUniqSet, elementOfUniqSet, ...@@ -53,7 +51,7 @@ import UniqSet ( emptyUniqSet, elementOfUniqSet,
import StgSyn ( SRT(..) ) import StgSyn ( SRT(..) )
import BitSet ( intBS ) import BitSet ( intBS )
import Outputable import Outputable
import Util ( nOfThem, panic, assertPanic ) import Util ( nOfThem )
import Addr ( Addr ) import Addr ( Addr )
import ST import ST
...@@ -320,7 +318,9 @@ pprAbsC stmt@(CCallTypedef op@(CCallOp op_str is_asm may_gc cconv) results args) ...@@ -320,7 +318,9 @@ pprAbsC stmt@(CCallTypedef op@(CCallOp op_str is_asm may_gc cconv) results args)
in ASSERT (length nvrs <= 1) nvrs in ASSERT (length nvrs <= 1) nvrs
pprAbsC (CCodeBlock label abs_C) _ 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) -> case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
vcat [ vcat [
hcat [text (if (externallyVisibleCLabel label) hcat [text (if (externallyVisibleCLabel label)
......
...@@ -16,7 +16,6 @@ types that ...@@ -16,7 +16,6 @@ types that
module BasicTypes( module BasicTypes(
Version, Arity, Version, Arity,
Unused, unused, Unused, unused,
Module, moduleString, pprModule,
Fixity(..), FixityDirection(..), StrictnessMark(..), Fixity(..), FixityDirection(..), StrictnessMark(..),
NewOrData(..), IfaceFlavour(..), TopLevelFlag(..), RecFlag(..) NewOrData(..), IfaceFlavour(..), TopLevelFlag(..), RecFlag(..)
) where ) where
...@@ -64,22 +63,6 @@ type Version = Int ...@@ -64,22 +63,6 @@ type Version = Int
\end{code} \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} \subsection[IfaceFlavour]{IfaceFlavour}
......
...@@ -51,7 +51,25 @@ data DataCon ...@@ -51,7 +51,25 @@ data DataCon
dcName :: Name, dcName :: Name,
dcUnique :: Unique, -- Cached from Name dcUnique :: Unique, -- Cached from Name
dcTag :: ConTag, 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 dcTyVars :: [TyVar], -- Type vars and context for the data type decl
dcTheta :: ThetaType, dcTheta :: ThetaType,
...@@ -62,6 +80,7 @@ data DataCon ...@@ -62,6 +80,7 @@ data DataCon
dcArgTys :: [Type], -- Argument types dcArgTys :: [Type], -- Argument types
dcTyCon :: TyCon, -- Result tycon 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; dcStricts :: [StrictnessMark], -- Strict args, in the same order as the argument types;
-- length = dataConNumFields dataCon -- length = dataConNumFields dataCon
...@@ -69,6 +88,11 @@ data DataCon ...@@ -69,6 +88,11 @@ data DataCon
-- same order as the argument types; -- same order as the argument types;
-- length = 0 (if not a record) or dataConSourceArity. -- 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 dcId :: Id -- The corresponding Id
} }
......
...@@ -78,9 +78,7 @@ isStrict (WwUnpack NewType _ ds) = isStrict (head ds) ...@@ -78,9 +78,7 @@ isStrict (WwUnpack NewType _ ds) = isStrict (head ds)
isStrict (WwUnpack other _ _) = True isStrict (WwUnpack other _ _) = True
isStrict WwStrict = True isStrict WwStrict = True
isStrict WwEnum = True isStrict WwEnum = True
isStrict WwPrim = False -- NB: we treat only lifted types as strict. isStrict WwPrim = True
-- Why is this important? Mostly it doesn't matter
-- but it saves a test for lifted-ness in SimplUtils.etaCoreExpr
isStrict _ = False isStrict _ = False
\end{code} \end{code}
...@@ -97,7 +95,42 @@ isLazy _ = False -- (as they imply a worker) ...@@ -97,7 +95,42 @@ isLazy _ = False -- (as they imply a worker)
%* * %* *
%************************************************************************ %************************************************************************
\begin{code} \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 #ifdef REALLY_HASKELL_1_3
instance Read Demand where instance Read Demand where
...@@ -113,6 +146,8 @@ instance Text Demand where ...@@ -113,6 +146,8 @@ instance Text Demand where
showsPrec p d = showsPrecSDoc p (ppr d) showsPrec p d = showsPrecSDoc p (ppr d)
#endif #endif
readDemands :: String ->
read_em acc ('L' : xs) = read_em (WwLazy False : acc) xs 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 ('A' : xs) = read_em (WwLazy True : acc) xs
read_em acc ('S' : xs) = read_em (WwStrict : acc) xs read_em acc ('S' : xs) = read_em (WwStrict : acc) xs
...@@ -128,25 +163,8 @@ read_em acc rest = [(reverse acc, rest)] ...@@ -128,25 +163,8 @@ read_em acc rest = [(reverse acc, rest)]
do_unpack new_or_data wrapper_unpacks acc xs do_unpack new_or_data wrapper_unpacks acc xs
= case (read_em [] xs) of = case (read_em [] xs) of
[(stuff, rest)] -> read_em (WwUnpack new_or_data wrapper_unpacks stuff : acc) rest [(stuff, rest)] -> read_em (WwUnpack new_or_data wrapper_unpacks stuff : acc) rest
_ -> pprPanic "Demand.do_unpack:" (ppr acc <+> text ("::"++xs)) _ -> pprPanic "Demand.do_unpack:" (ppr acc <+> dcolon <> 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'
instance Outputable Demand where -------------------- END OF OMISSION ------------------------------ -}
ppr (WwLazy False) = empty
ppr other_demand = ptext SLIT("__D") <+> pprDemand other_demand
\end{code} \end{code}
...@@ -5,20 +5,19 @@ ...@@ -5,20 +5,19 @@
\begin{code} \begin{code}
module Id ( module Id (
Id, DictId, GenId, Id, DictId,
-- Simple construction -- Simple construction
mkVanillaId, mkImportedId, mkSysLocal, mkUserLocal, mkVanillaId, mkImportedId, mkSysLocal, mkUserLocal,
mkTemplateLocals, mkWildId, mkUserId, mkTemplateLocals, mkWildId, mkUserId,
-- Taking an Id apart -- Taking an Id apart
idName, idType, idUnique, idInfo, idName, idType, idUnique, idInfo, idDetails,
idPrimRep, isId, idPrimRep, isId,
recordSelectorFieldLabel, recordSelectorFieldLabel,
-- Modifying an Id -- Modifying an Id
setIdName, setIdUnique, setIdType, setIdInfo, setIdName, setIdUnique, setIdType, setIdInfo, mkIdVisible,
setIdVisibility, mkIdVisible,
-- Predicates -- Predicates
omitIfaceSigForId, omitIfaceSigForId,
...@@ -34,7 +33,7 @@ module Id ( ...@@ -34,7 +33,7 @@ module Id (
isRecordSelector, isRecordSelector,
isPrimitiveId_maybe, isDataConId_maybe, isPrimitiveId_maybe, isDataConId_maybe,
isConstantId, isConstantId,
isBottomingId, isBottomingId, idAppIsBottom,
-- IdInfo stuff -- IdInfo stuff
setIdUnfolding, setIdUnfolding,
...@@ -59,25 +58,24 @@ module Id ( ...@@ -59,25 +58,24 @@ module Id (
import {-# SOURCE #-} CoreUnfold ( Unfolding ) import {-# SOURCE #-} CoreUnfold ( Unfolding )
import Var ( Id, GenId, DictId, VarDetails(..), import Var ( Id, DictId, VarDetails(..),
isId, mkId, isId, mkId,
idName, idType, idUnique, idInfo, varDetails, idName, idType, idUnique, idInfo, idDetails,
setIdName, setVarType, setIdUnique, setIdInfo, modifyIdInfo, setIdName, setVarType, setIdUnique, setIdInfo, modifyIdInfo,
externallyVisibleId externallyVisibleId
) )
import VarSet import VarSet
import Type ( GenType, Type, tyVarsOfType, typePrimRep, addFreeTyVars ) import Type ( Type, tyVarsOfType, typePrimRep, addFreeTyVars )
import IdInfo import IdInfo
import Demand ( Demand ) import Demand ( Demand )
import Name ( Name, OccName, import Name ( Name, OccName, Module,
mkSysLocalName, mkLocalName, mkSysLocalName, mkLocalName,
isWiredInName, setNameVisibility, mkNameVisible isWiredInName, mkNameVisible
) )
import Const ( Con(..) ) import Const ( Con(..) )
import PrimRep ( PrimRep ) import PrimRep ( PrimRep )
import PrimOp ( PrimOp ) import PrimOp ( PrimOp )
import FieldLabel ( FieldLabel(..) ) import FieldLabel ( FieldLabel(..) )
import BasicTypes ( Module )
import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques ) import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques )
import Outputable import Outputable
...@@ -100,22 +98,22 @@ infixl 1 `setIdUnfolding`, ...@@ -100,22 +98,22 @@ infixl 1 `setIdUnfolding`,
%************************************************************************ %************************************************************************
\begin{code} \begin{code}
mkVanillaId :: Name -> (GenType flexi) -> GenId flexi mkVanillaId :: Name -> Type -> Id
mkVanillaId name ty = mkId name ty VanillaId noIdInfo