Commit bb521c6b authored by simonpj's avatar simonpj
Browse files

[project @ 1996-12-19 18:35:23 by simonpj]

Adding and removing files
parent c3e7e772
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[Demand]{@Demand@: the amount of demand on a value}
\begin{code}
#include "HsVersions.h"
module Demand where
import PprStyle ( PprStyle )
import Outputable
import Pretty ( SYN_IE(Pretty), PrettyRep, ppStr )
import Util ( panic )
\end{code}
%************************************************************************
%* *
\subsection{The @Demand@ data type}
%* *
%************************************************************************
\begin{code}
data Demand
= WwLazy -- Argument is lazy as far as we know
MaybeAbsent -- (does not imply worker's existence [etc]).
-- If MaybeAbsent == True, then it is
-- *definitely* lazy. (NB: Absence implies
-- a worker...)
| WwStrict -- Argument is strict but that's all we know
-- (does not imply worker's existence or any
-- calling-convention magic)
| WwUnpack -- Argument is strict & a single-constructor
[Demand] -- type; its constituent parts (whose StrictInfos
-- are in the list) should be passed
-- as arguments to the worker.
| WwPrim -- Argument is of primitive type, therefore
-- strict; doesn't imply existence of a worker;
-- argument should be passed as is to worker.
| WwEnum -- Argument is strict & an enumeration type;
-- an Int# representing the tag (start counting
-- at zero) should be passed to the worker.
deriving (Eq, Ord)
-- we need Eq/Ord to cross-chk update infos in interfaces
type MaybeAbsent = Bool -- True <=> not even used
-- versions that don't worry about Absence:
wwLazy = WwLazy False
wwStrict = WwStrict
wwUnpack xs = WwUnpack xs
wwPrim = WwPrim
wwEnum = WwEnum
\end{code}
%************************************************************************
%* *
\subsection{Functions over @Demand@}
%* *
%************************************************************************
\begin{code}
isStrict :: Demand -> Bool
isStrict WwStrict = True
isStrict (WwUnpack _) = True
isStrict WwPrim = True
isStrict WwEnum = True
isStrict _ = False
\end{code}
%************************************************************************
%* *
\subsection{Instances}
%* *
%************************************************************************
\begin{code}
#ifdef REALLY_HASKELL_1_3
instance Read Demand where
#else
instance Text Demand where
#endif
readList str = read_em [{-acc-}] str
where
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
read_em acc ('P' : xs) = read_em (WwPrim : acc) xs
read_em acc ('E' : xs) = read_em (WwEnum : acc) xs
read_em acc (')' : xs) = [(reverse acc, xs)]
read_em acc ( 'U' : '(' : xs)
= case (read_em [] xs) of
[(stuff, rest)] -> read_em (WwUnpack stuff : acc) rest
_ -> panic ("Text.Demand:"++str++"::"++xs)
read_em acc rest = [(reverse acc, rest)]
#ifdef REALLY_HASKELL_1_3
instance Show Demand where
#endif
showList wrap_args rest = foldr show1 rest wrap_args
where
show1 (WwLazy False) rest = 'L' : rest
show1 (WwLazy True) rest = 'A' : rest
show1 WwStrict rest = 'S' : rest
show1 WwPrim rest = 'P' : rest
show1 WwEnum rest = 'E' : rest
show1 (WwUnpack args) rest = "U(" ++ showList args (')' : rest)
instance Outputable Demand where
ppr sty si = ppStr (showList [si] "")
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
%
\section[Constants]{Info about this compilation}
!!!!! THIS CODE MUST AGREE WITH SMinterface.h !!!!!!
*** This SHOULD BE the only module that is CPP'd with "stgdefs.h" stuff.
\begin{code}
#include "HsVersions.h"
module Constants (
uNFOLDING_USE_THRESHOLD,
uNFOLDING_CREATION_THRESHOLD,
-- uNFOLDING_OVERRIDE_THRESHOLD,
iNTERFACE_UNFOLD_THRESHOLD,
lIBERATE_CASE_THRESHOLD,
uNFOLDING_CHEAP_OP_COST,
uNFOLDING_DEAR_OP_COST,
uNFOLDING_NOREP_LIT_COST,
uNFOLDING_CON_DISCOUNT_WEIGHT,
mAX_SPEC_ALL_PTRS,
mAX_SPEC_ALL_NONPTRS,
mAX_SPEC_MIXED_FIELDS,
mAX_SPEC_SELECTEE_SIZE,
tARGET_MIN_INT, tARGET_MAX_INT,
mIN_UPD_SIZE,
mIN_SIZE_NonUpdHeapObject,
mIN_SIZE_NonUpdStaticHeapObject,
mAX_FAMILY_SIZE_FOR_VEC_RETURNS,
sTD_UF_SIZE, cON_UF_SIZE,
sCC_STD_UF_SIZE, sCC_CON_UF_SIZE,
uF_RET,
uF_SUB,
uF_SUA,
uF_UPDATEE,
uF_COST_CENTRE,
mAX_Vanilla_REG,
mAX_Float_REG,
mAX_Double_REG,
mIN_BIG_TUPLE_SIZE,
mIN_MP_INT_SIZE,
mP_STRUCT_SIZE,
oTHER_TAG, iND_TAG, -- semi-tagging stuff
lIVENESS_R1,
lIVENESS_R2,
lIVENESS_R3,
lIVENESS_R4,
lIVENESS_R5,
lIVENESS_R6,
lIVENESS_R7,
lIVENESS_R8,
mAX_INTLIKE, mIN_INTLIKE,
spARelToInt,
spBRelToInt
) where
-- This magical #include brings in all the everybody-knows-these magic
-- constants unfortunately, we need to be *explicit* about which one
-- we want; if we just hope a -I... will get the right one, we could
-- be in trouble.
#include "../../includes/GhcConstants.h"
CHK_Ubiq() -- debugging consistency check
import Util
\end{code}
All pretty arbitrary:
\begin{code}
uNFOLDING_USE_THRESHOLD = ( 3 :: Int)
uNFOLDING_CREATION_THRESHOLD = (30 :: Int)
iNTERFACE_UNFOLD_THRESHOLD = (30 :: Int)
lIBERATE_CASE_THRESHOLD = (10 :: Int)
-- uNFOLDING_OVERRIDE_THRESHOLD = ( 8 :: Int)
uNFOLDING_CHEAP_OP_COST = ( 1 :: Int)
uNFOLDING_DEAR_OP_COST = ( 4 :: Int)
uNFOLDING_NOREP_LIT_COST = ( 4 :: Int)
uNFOLDING_CON_DISCOUNT_WEIGHT = ( 1 :: Int)
\end{code}
\begin{code}
mAX_SPEC_ALL_PTRS = (MAX_SPEC_ALL_PTRS :: Int)
mAX_SPEC_ALL_NONPTRS = (MAX_SPEC_ALL_NONPTRS :: Int)
mAX_SPEC_MIXED_FIELDS = (MAX_SPEC_OTHER_SIZE :: Int)
mAX_SPEC_SELECTEE_SIZE = (MAX_SPEC_SELECTEE_SIZE :: Int)
-- closure sizes: these do NOT include the header
mIN_UPD_SIZE = (MIN_UPD_SIZE::Int)
mIN_SIZE_NonUpdHeapObject = (MIN_NONUPD_SIZE::Int)
mIN_SIZE_NonUpdStaticHeapObject = (0::Int)
\end{code}
A completely random number:
\begin{code}
mIN_BIG_TUPLE_SIZE = (16::Int)
\end{code}
Sizes of gmp objects:
\begin{code}
mIN_MP_INT_SIZE = (MIN_MP_INT_SIZE :: Int)
mP_STRUCT_SIZE = (MP_STRUCT_SIZE :: Int)
\end{code}
\begin{code}
tARGET_MIN_INT, tARGET_MAX_INT :: Integer
tARGET_MIN_INT = -536870912
tARGET_MAX_INT = 536870912
\end{code}
Constants for semi-tagging; the tags associated with the data
constructors will start at 0 and go up.
\begin{code}
oTHER_TAG = (INFO_OTHER_TAG :: Integer) -- (-1) unevaluated, probably
iND_TAG = (INFO_IND_TAG :: Integer) -- (-2) NOT USED, REALLY
\end{code}
Stuff for liveness masks:
\begin{code}
lIVENESS_R1 = (LIVENESS_R1 :: Int)
lIVENESS_R2 = (LIVENESS_R2 :: Int)
lIVENESS_R3 = (LIVENESS_R3 :: Int)
lIVENESS_R4 = (LIVENESS_R4 :: Int)
lIVENESS_R5 = (LIVENESS_R5 :: Int)
lIVENESS_R6 = (LIVENESS_R6 :: Int)
lIVENESS_R7 = (LIVENESS_R7 :: Int)
lIVENESS_R8 = (LIVENESS_R8 :: Int)
\end{code}
\begin{code}
mIN_INTLIKE, mAX_INTLIKE :: Integer -- Only used to compare with (MachInt Integer)
mIN_INTLIKE = MIN_INTLIKE
mAX_INTLIKE = MAX_INTLIKE
\end{code}
\begin{code}
-- THESE ARE DIRECTION SENSITIVE!
spARelToInt :: Int{-VirtualSpAOffset-} -> Int{-VirtualSpAOffset-} -> Int
spBRelToInt :: Int{-VirtualSpBOffset-} -> Int{-VirtualSpBOffset-} -> Int
spARelToInt spA off = spA - off -- equiv to: AREL(spA - off)
spBRelToInt spB off = off - spB -- equiv to: BREL(spB - off)
\end{code}
A section of code-generator-related MAGIC CONSTANTS.
\begin{code}
mAX_FAMILY_SIZE_FOR_VEC_RETURNS = (MAX_VECTORED_RTN::Int) -- pretty arbitrary
-- If you change this, you may need to change runtimes/standard/Update.lhc
-- The update frame sizes
sTD_UF_SIZE = (NOSCC_STD_UF_SIZE::Int)
cON_UF_SIZE = (NOSCC_CON_UF_SIZE::Int)
-- Same again, with profiling
sCC_STD_UF_SIZE = (SCC_STD_UF_SIZE::Int)
sCC_CON_UF_SIZE = (SCC_CON_UF_SIZE::Int)
-- Offsets in an update frame. They don't change with profiling!
uF_RET = (UF_RET::Int)
uF_SUB = (UF_SUB::Int)
uF_SUA = (UF_SUA::Int)
uF_UPDATEE = (UF_UPDATEE::Int)
uF_COST_CENTRE = (UF_COST_CENTRE::Int)
\end{code}
\begin{code}
mAX_Vanilla_REG = (MAX_VANILLA_REG :: Int)
mAX_Float_REG = (MAX_FLOAT_REG :: Int)
mAX_Double_REG = (MAX_DOUBLE_REG :: Int)
\end{code}
%
% (c) The AQUA Project, Glasgow University, 1994-1996
%
\section[StdIdInfo]{Standard unfoldings}
This module contains definitions for the IdInfo for things that
have a standard form, namely:
* data constructors
* record selectors
* method and superclass selectors
* primitive operations
\begin{code}
#include "HsVersions.h"
module StdIdInfo (
addStandardIdInfo
) where
IMP_Ubiq()
import Type
import CoreSyn
import Literal
import CoreUnfold ( mkUnfolding )
import TysWiredIn ( tupleCon )
import Id ( GenId, mkTemplateLocals, idType,
dataConStrictMarks, dataConFieldLabels, dataConArgTys,
recordSelectorFieldLabel, dataConSig,
StrictnessMark(..),
isDataCon, isMethodSelId_maybe, isSuperDictSelId_maybe,
isRecordSelector, isPrimitiveId_maybe,
addIdUnfolding, addIdArity
)
import IdInfo ( ArityInfo, exactArity )
import Class ( GenClass, GenClassOp, classSig, classOpLocalType )
import TyCon ( isNewTyCon )
import FieldLabel ( FieldLabel )
import PrelVals ( pAT_ERROR_ID )
import Maybes
import PprStyle ( PprStyle(..) )
import Pretty
import Util ( assertPanic, pprTrace,
assoc
)
\end{code}
%************************************************************************
%* *
\subsection{Data constructors}
%* *
%************************************************************************
We're going to build a constructor that looks like:
data (Data a, C b) => T a b = T1 !a !Int b
T1 = /\ a b ->
\d1::Data a, d2::C b ->
\p q r -> case p of { p ->
case q of { q ->
Con T1 [a,b] [p,q,r]}}
Notice that
* d2 is thrown away --- a context in a data decl is used to make sure
one *could* construct dictionaries at the site the constructor
is used, but the dictionary isn't actually used.
* We have to check that we can construct Data dictionaries for
the types a and Int. Once we've done that we can throw d1 away too.
* We use (case p of ...) to evaluate p, rather than "seq" because
all that matters is that the arguments are evaluated. "seq" is
very careful to preserve evaluation order, which we don't need
to be here.
\begin{code}
addStandardIdInfo :: Id -> Id
addStandardIdInfo con_id
| isDataCon con_id
= con_id `addIdUnfolding` unfolding
`addIdArity` exactArity (length locals)
where
unfolding = mkUnfolding True {- Always inline constructors -} con_rhs
(tyvars,theta,arg_tys,tycon) = dataConSig con_id
dict_tys = [mkDictTy clas ty | (clas,ty) <- theta]
n_dicts = length dict_tys
result_ty = applyTyCon tycon (mkTyVarTys tyvars)
locals = mkTemplateLocals (dict_tys ++ arg_tys)
data_args = drop n_dicts locals
(data_arg1:_) = data_args -- Used for newtype only
strict_marks = dataConStrictMarks con_id
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)
Coerce (CoerceIn con_id) result_ty (Var data_arg1)
| otherwise
= Con con_id (map TyArg (mkTyVarTys tyvars) ++ map VarArg data_args)
con_rhs = mkTyLam tyvars $
mkValLam locals $
foldr mk_case con_app strict_args
mk_case arg body | isUnboxedType (idType arg)
= body -- "!" on unboxed arg does nothing
| otherwise
= Case (Var arg) (AlgAlts [] (BindDefault arg body))
-- This case shadows "arg" but that's fine
\end{code}
%************************************************************************
%* *
\subsection{Record selectors}
%* *
%************************************************************************
We're going to build a record selector that looks like this:
data T a b c = T1 { ..., op :: a, ...}
| T2 { ..., op :: a, ...}
| T3
sel = /\ a b c -> \ d -> case d of
T1 ... x ... -> x
T2 ... x ... -> x
other -> error "..."
\begin{code}
addStandardIdInfo sel_id
| isRecordSelector sel_id
= ASSERT( null theta )
sel_id `addIdUnfolding` unfolding
`addIdArity` exactArity 1
-- ToDo: consider adding further IdInfo
where
unfolding = mkUnfolding False {- Don't inline every selector -} sel_rhs
(tyvars, theta, tau) = splitSigmaTy (idType sel_id)
field_lbl = recordSelectorFieldLabel sel_id
(data_ty,rhs_ty) = expectJust "StdIdInfoRec" (getFunTy_maybe tau)
-- tau is of form (T a b c -> field-type)
(tycon, _, data_cons) = getAppDataTyCon data_ty
tyvar_tys = mkTyVarTys tyvars
[data_id] = mkTemplateLocals [data_ty]
sel_rhs = mkTyLam tyvars $
mkValLam [data_id] $
Case (Var data_id) (AlgAlts (catMaybes (map mk_maybe_alt data_cons))
(BindDefault data_id error_expr))
mk_maybe_alt data_con
= case maybe_the_arg_id of
Nothing -> Nothing
Just the_arg_id -> Just (data_con, arg_ids, Var the_arg_id)
where
arg_ids = mkTemplateLocals (dataConArgTys data_con tyvar_tys)
-- The first one will shadow data_id, but who cares
field_lbls = dataConFieldLabels data_con
maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_lbl
error_expr = mkApp (Var pAT_ERROR_ID) [] [rhs_ty] [LitArg msg_lit]
full_msg = ppShow 80 (ppSep [ppStr "No match in record selector", ppr PprForUser sel_id])
msg_lit = NoRepStr (_PK_ full_msg)
\end{code}
%************************************************************************
%* *
\subsection{Super selectors}
%* *
%************************************************************************
\begin{code}
addStandardIdInfo sel_id
| maybeToBool maybe_sc_sel_id
= sel_id `addIdUnfolding` unfolding
-- The always-inline thing means we don't need any other IdInfo
where
maybe_sc_sel_id = isSuperDictSelId_maybe sel_id
Just (cls, the_sc) = maybe_sc_sel_id
unfolding = mkUnfolding True {- Always inline selectors -} rhs
rhs = mk_dict_selector [tyvar] dict_id arg_ids the_arg_id
(tyvar, scs, ops) = classSig cls
tyvar_ty = mkTyVarTy tyvar
[dict_id] = mkTemplateLocals [mkDictTy cls tyvar_ty]
arg_ids = mkTemplateLocals ([mkDictTy sc tyvar_ty | sc <- scs] ++
map classOpLocalType ops)
the_arg_id = assoc "StdIdInfoSC" (scs `zip` arg_ids) the_sc
addStandardIdInfo sel_id
| maybeToBool maybe_meth_sel_id
= sel_id `addIdUnfolding` unfolding
-- The always-inline thing means we don't need any other IdInfo
where
maybe_meth_sel_id = isMethodSelId_maybe sel_id
Just (cls, the_op) = maybe_meth_sel_id
unfolding = mkUnfolding True {- Always inline selectors -} rhs
rhs = mk_dict_selector [tyvar] dict_id arg_ids the_arg_id
(tyvar, scs, ops) = classSig cls
n_scs = length scs
tyvar_ty = mkTyVarTy tyvar
[dict_id] = mkTemplateLocals [mkDictTy cls tyvar_ty]
arg_ids = mkTemplateLocals ([mkDictTy sc tyvar_ty | sc <- scs] ++
map classOpLocalType ops)
the_arg_id = assoc "StdIdInfoMeth" (ops `zip` (drop n_scs arg_ids)) the_op
\end{code}
%************************************************************************
%* *
\subsection{Primitive operations
%* *
%************************************************************************
\begin{code}
addStandardIdInfo prim_id
| maybeToBool maybe_prim_id
= prim_id `addIdUnfolding` unfolding
where
maybe_prim_id = isPrimitiveId_maybe prim_id
Just prim_op = maybe_prim_id
unfolding = mkUnfolding True {- Always inline PrimOps -} rhs
(tyvars, tau) = splitForAllTy (idType prim_id)
(arg_tys, _) = splitFunTy tau
args = mkTemplateLocals arg_tys
rhs = mkLam tyvars args $
Prim prim_op
([TyArg (mkTyVarTy tv) | tv <- tyvars] ++
[VarArg v | v <- args])
\end{code}
%************************************************************************
%* *
\subsection{Catch-all}
%* *
%************************************************************************
\begin{code}
addStandardIdInfo id
= pprTrace "addStandardIdInfo missing:" (ppr PprDebug id) id
\end{code}
%************************************************************************
%* *
\subsection{Dictionary selector help function
%* *
%************************************************************************
Selecting a field for a dictionary. If there is just one field, then
there's nothing to do.
\begin{code}
mk_dict_selector tyvars dict_id [arg_id] the_arg_id
= mkLam tyvars [dict_id] (Var dict_id)
mk_dict_selector tyvars dict_id arg_ids the_arg_id
= mkLam tyvars [dict_id] $
Case (Var dict_id) (AlgAlts [(tup_con, arg_ids, Var the_arg_id)] NoDefault)
where
tup_con = tupleCon (length arg_ids)
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[Lexical analysis]{Lexical analysis}
\begin{code}
#include "HsVersions.h"
module Lex (
isLexCon, isLexVar, isLexId, isLexSym,
isLexConId, isLexConSym, isLexVarId, isLexVarSym,
mkTupNameStr,
-- Monad for parser
IfaceToken(..), lexIface, SYN_IE(IfM), thenIf, returnIf, happyError
) where
IMPORT_1_3(Char(isDigit, isAlpha, isAlphanum, isUpper))
import Demand ( Demand {- instance Read -} )
import FiniteMap ( FiniteMap, listToFM, lookupFM )
import Maybes ( Maybe(..), MaybeErr(..) )
import Pretty
import CharSeq ( CSeq )
import ErrUtils ( Error(..) )
import Outputable ( Outputable(..) )
import PprStyle ( PprStyle(..) )
import Util ( nOfThem, panic )
\end{code}
%************************************************************************
%* *
\subsection{Lexical categories}
%* *
%************************************************************************
These functions test strings to see if they fit the lexical categories
defined in the Haskell report. Normally applied as in e.g. @isCon
(getLocalName foo)@.
\begin{code}
isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym,
isLexVarId, isLexVarSym :: FAST_STRING -> Bool