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

Adding and removing files

5 files changed, 1031 insertions, 0 deletions

diff --git a/ghc/compiler/basicTypes/Demand.lhs b/ghc/compiler/basicTypes/Demand.lhs
new file mode 100644
index 0000000000..21c22d4606
--- /dev/null
+++ b/ghc/compiler/basicTypes/Demand.lhs
@@ -0,0 +1,124 @@
+%
+% (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}
+
+
+
diff --git a/ghc/compiler/main/Constants.lhs b/ghc/compiler/main/Constants.lhs
new file mode 100644
index 0000000000..aaafe10d2b
--- /dev/null
+++ b/ghc/compiler/main/Constants.lhs
@@ -0,0 +1,186 @@
+%
+% (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}
diff --git a/ghc/compiler/prelude/StdIdInfo.lhs b/ghc/compiler/prelude/StdIdInfo.lhs
new file mode 100644
index 0000000000..a13fa83b56
--- /dev/null
+++ b/ghc/compiler/prelude/StdIdInfo.lhs
@@ -0,0 +1,282 @@
+%
+% (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}
diff --git a/ghc/compiler/reader/Lex.lhs b/ghc/compiler/reader/Lex.lhs
new file mode 100644
index 0000000000..a353f79eca
--- /dev/null
+++ b/ghc/compiler/reader/Lex.lhs
@@ -0,0 +1,372 @@
+%
+% (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
+
+isLexCon cs = isLexConId  cs || isLexConSym cs
+isLexVar cs = isLexVarId  cs || isLexVarSym cs
+
+isLexId  cs = isLexConId  cs || isLexVarId  cs
+isLexSym cs = isLexConSym cs || isLexVarSym cs
+
+-------------
+
+isLexConId cs
+  | _NULL_ cs	     = False
+  | cs == SLIT("[]") = True
+  | c  == '('	     = True	-- (), (,), (,,), ...
+  | otherwise	     = isUpper c || isUpperISO c
+  where					
+    c = _HEAD_ cs
+
+isLexVarId cs
+  | _NULL_ cs	 = False
+  | otherwise    = isLower c || isLowerISO c
+  where
+    c = _HEAD_ cs
+
+isLexConSym cs
+  | _NULL_ cs	= False
+  | otherwise	= c  == ':'
+	       || cs == SLIT("->")
+  where
+    c = _HEAD_ cs
+
+isLexVarSym cs
+  | _NULL_ cs = False
+  | otherwise = isSymbolASCII c
+	     || isSymbolISO c
+  where
+    c = _HEAD_ cs
+
+-------------
+isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
+isSymbolISO   c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
+isUpperISO    c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
+isLowerISO    c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Tuple strings -- ugh!}
+%*									*
+%************************************************************************
+
+\begin{code}
+mkTupNameStr 0 = SLIT("()")
+mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???"
+mkTupNameStr 2 = _PK_ "(,)"   -- not strictly necessary
+mkTupNameStr 3 = _PK_ "(,,)"  -- ditto
+mkTupNameStr 4 = _PK_ "(,,,)" -- ditto
+mkTupNameStr n = _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")
+\end{code}
+
+
+
+%************************************************************************
+%*									*
+\subsection{Data types}
+%*									*
+%************************************************************************
+
+\begin{code}
+data IfaceToken
+  = ITinterface		-- keywords
+  | ITusages
+  | ITversions
+  | ITexports
+  | ITinstance_modules
+  | ITinstances
+  | ITfixities
+  | ITdeclarations
+  | ITpragmas
+  | ITdata
+  | ITtype
+  | ITnewtype
+  | ITderiving
+  | ITclass
+  | ITwhere
+  | ITinstance
+  | ITinfixl
+  | ITinfixr
+  | ITinfix
+  | ITforall
+  | ITbang		-- magic symbols
+  | ITvbar
+  | ITdcolon
+  | ITcomma
+  | ITdarrow
+  | ITdotdot
+  | ITequal
+  | ITocurly
+  | ITdccurly
+  | ITdocurly
+  | ITobrack
+  | IToparen
+  | ITrarrow
+  | ITccurly
+  | ITcbrack
+  | ITcparen
+  | ITsemi
+  | ITinteger Integer	-- numbers and names
+  | ITvarid   FAST_STRING
+  | ITconid   FAST_STRING
+  | ITvarsym  FAST_STRING
+  | ITconsym  FAST_STRING
+  | ITqvarid  (FAST_STRING,FAST_STRING)
+  | ITqconid  (FAST_STRING,FAST_STRING)
+  | ITqvarsym (FAST_STRING,FAST_STRING)
+  | ITqconsym (FAST_STRING,FAST_STRING)
+
+	-- Stuff for reading unfoldings
+  | ITarity | ITstrict | ITunfold
+  | ITdemand [Demand] | ITbottom
+  | ITlam | ITbiglam | ITcase | ITlet | ITletrec | ITin | ITof
+  | ITcoerce_in | ITcoerce_out
+  | ITchar Char | ITstring FAST_STRING
+  deriving Text -- debugging
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{The lexical analyser}
+%*									*
+%************************************************************************
+
+\begin{code}
+lexIface :: String -> [IfaceToken]
+
+lexIface input
+  = _scc_ "Lexer"
+    case input of
+      []    -> []
+
+      -- whitespace and comments
+      ' '	: cs -> lexIface cs
+      '\t'	: cs -> lexIface cs
+      '\n'	: cs -> lexIface cs
+      '-' : '-' : cs -> lex_comment cs
+
+-- Leave out nested comments for now; danger of finding { and - juxtaposed by mistake?
+--    '{' : '-' : cs -> lex_nested_comment 1{-one seen-} cs
+
+      '(' : '.' : '.' : ')' : cs -> ITdotdot	: lexIface cs
+      '{'		    : cs -> ITocurly	: lexIface cs
+      '}'		    : cs -> ITccurly	: lexIface cs
+      '(' : ',' 	    : cs -> lex_tuple Nothing cs 
+      '(' : ')' 	    : cs -> ITconid SLIT("()")	: lexIface cs
+      '(' 		    : cs -> IToparen	: lexIface cs
+      ')'		    : cs -> ITcparen	: lexIface cs
+      '[' : ']'		    : cs -> ITconid SLIT("[]")	: lexIface cs
+      '['		    : cs -> ITobrack	: lexIface cs
+      ']'		    : cs -> ITcbrack	: lexIface cs
+      ','		    : cs -> ITcomma	: lexIface cs
+      ':' : ':'		    : cs -> ITdcolon    : lexIface cs
+      ';'		    : cs -> ITsemi	: lexIface cs
+      '\"'		    : cs -> case read input of
+					((str, rest) : _) -> ITstring (_PK_ (str::String)) : lexIface rest
+      '\''		    : cs -> case read input of
+					((ch, rest) : _) -> ITchar ch : lexIface rest
+
+      '_' : 'S' : '_'	    : cs -> ITstrict	: lex_demand cs
+      '_' 		    : cs -> lex_keyword cs
+
+      c : cs | isDigit c 	 -> lex_num  input
+	     | otherwise	 -> lex_id input
+	     
+      other -> error ("lexing:"++other)
+  where
+    lex_comment str
+      = case (span ((/=) '\n') str) of { (junk, rest) ->
+	lexIface rest }
+
+    ------------------
+    lex_demand (c:cs) | isSpace c = lex_demand cs
+		      | otherwise = case readList (c:cs) of
+					((demand,rest) : _) -> ITdemand demand : lexIface rest
+    -----------
+    lex_num str
+      = case (span isDigit str) of { (num, rest) ->
+	ITinteger (read num) : lexIface rest }
+
+    ------------
+    lex_keyword str
+      = case (span is_kwd_mod_char str)    of { (kw, rest) ->
+	case (lookupFM ifaceKeywordsFM kw) of
+	  Nothing -> panic ("lex_keyword:"++str)
+	  Just xx -> xx : lexIface rest
+	}
+
+    is_kwd_mod_char '_' = True
+    is_kwd_mod_char c   = isAlphanum c
+
+    -----------
+    lex_tuple module_dot orig_cs = go 2 orig_cs
+		 where
+		   go n (',':cs) = go (n+1) cs
+		   go n (')':cs) = end_lex_id module_dot (ITconid (mkTupNameStr n)) cs
+		   go n other    = panic ("lex_tuple" ++ orig_cs)
+
+	-- NB: ':' isn't valid inside an identifier, only at the start.
+	-- otherwise we get confused by a::t!
+    is_id_char c = isAlphanum c || c `elem` "_'!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic
+
+    lex_id cs = go [] cs
+	where
+	  go xs (f  :cs) | is_kwd_mod_char f = go (f : xs) cs
+	  go xs ('.':cs) | not (null xs)     = lex_id2 (Just (_PK_ (reverse xs))) [] cs
+	  go xs cs			     = lex_id2 Nothing		   	  xs cs
+
+	-- Dealt with the Module.part
+    lex_id2 module_dot [] ('[': ']': cs) = end_lex_id module_dot (ITconid SLIT("[]")) cs
+    lex_id2 module_dot [] ('(': ')': cs) = end_lex_id module_dot (ITconid SLIT("()")) cs
+    lex_id2 module_dot [] ('(': ',': cs) = lex_tuple module_dot cs
+    lex_id2 module_dot [] (':' : cs)     = lex_id3 module_dot [':'] cs
+    lex_id2 module_dot xs cs 		 = lex_id3 module_dot xs cs
+
+	-- Dealt with [], (), : special cases
+    lex_id3 module_dot xs (f:cs) | is_id_char f = lex_id3 module_dot (f : xs) cs
+
+    lex_id3 Nothing xs rest = case lookupFM haskellKeywordsFM rxs of
+				       Just kwd_token -> kwd_token	    : lexIface rest
+				       other 	      -> (mk_var_token rxs) : lexIface rest
+			    where
+			       rxs = reverse xs
+
+    lex_id3 (Just m) xs rest = end_lex_id (Just m) (mk_var_token (reverse xs)) rest
+
+    mk_var_token xs@(f:_) | isUpper f || isUpperISO f = ITconid n
+		    	  | f == ':'		  = ITconsym n
+		      	  | isAlpha f		  = ITvarid n
+		    	  | otherwise		  = ITvarsym n 
+		where
+		      n = _PK_ xs
+			    
+    end_lex_id (Just m) (ITconid n)  cs = ITqconid (m,n) : lexIface cs
+    end_lex_id (Just m) (ITvarid n)  cs = ITqvarid (m,n) : lexIface cs
+    end_lex_id (Just m) (ITconsym n) cs = ITqconsym (m,n): lexIface cs
+    end_lex_id (Just m) (ITvarsym n) cs = ITqvarsym (m,n): lexIface cs
+    end_lex_id (Just m) ITbang	     cs = ITqvarsym (m,SLIT("!")) : lexIface cs
+    end_lex_id (Just m) token	     cs = panic ("end_lex_id:" ++ show token)
+    end_lex_id Nothing  token	     cs = token : lexIface cs
+
+    ------------
+    ifaceKeywordsFM :: FiniteMap String IfaceToken
+    ifaceKeywordsFM = listToFM [
+	("interface_",	 	ITinterface)
+       ,("usages_",		ITusages)
+       ,("versions_",		ITversions)
+       ,("exports_",		ITexports)
+       ,("instance_modules_",	ITinstance_modules)
+       ,("instances_",		ITinstances)
+       ,("fixities_",		ITfixities)
+       ,("declarations_",	ITdeclarations)
+       ,("pragmas_",		ITpragmas)
+       ,("forall_",		ITforall)
+       ,("U_",			ITunfold)
+       ,("A_",			ITarity)
+       ,("coerce_in_",		ITcoerce_in)
+       ,("coerce_out_",		ITcoerce_out)
+       ,("A_",			ITarity)
+       ,("A_",			ITarity)
+       ,("!_",			ITbottom)
+
+       ]
+
+    haskellKeywordsFM = listToFM [
+        ("data",		ITdata)
+       ,("type",		ITtype)
+       ,("newtype",		ITnewtype)
+       ,("class",		ITclass)
+       ,("where",		ITwhere)
+       ,("instance",		ITinstance)
+       ,("infixl",		ITinfixl)
+       ,("infixr",		ITinfixr)
+       ,("infix",		ITinfix)
+       ,("case",		ITcase)
+       ,("of",			ITof)
+       ,("in",			ITin)
+       ,("let",			ITlet)
+       ,("letrec",		ITletrec)
+       ,("deriving",		ITderiving)
+
+       ,("->",			ITrarrow)
+       ,("\\",			ITlam)
+       ,("/\\",			ITbiglam)
+       ,("|",			ITvbar)
+       ,("!",			ITbang)
+       ,("=>",			ITdarrow)
+       ,("=",			ITequal)
+       ]
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Other utility functions
+%*									*
+%************************************************************************
+
+\begin{code}
+type IfM a = MaybeErr a Error
+
+returnIf   :: a -> IfM a
+thenIf	   :: IfM a -> (a -> IfM b) -> IfM b
+happyError :: Int -> [IfaceToken] -> IfM a
+
+returnIf a = Succeeded a
+
+thenIf (Succeeded a) k = k a
+thenIf (Failed  err) _ = Failed err
+
+happyError ln toks = Failed (ifaceParseErr ln toks)
+
+-----------------------------------------------------------------
+
+ifaceParseErr ln toks sty
+  = ppCat [ppPStr SLIT("Interface-file parse error: line"), ppInt ln, ppStr "toks=", ppStr (show (take 10 toks))]
+\end{code}
diff --git a/ghc/compiler/utils/SpecLoop.lhi b/ghc/compiler/utils/SpecLoop.lhi
new file mode 100644
index 0000000000..74e3f2cb7b
--- /dev/null
+++ b/ghc/compiler/utils/SpecLoop.lhi
@@ -0,0 +1,67 @@
+This loop-breaking module is used solely to braek the loops caused by
+SPECIALIZE pragmas.
+
+\begin{code}
+interface SpecLoop where
+
+import RdrHsSyn		( RdrName )
+import Name		( Name, OrigName, OccName )
+import TyVar		( GenTyVar )
+import TyCon		( TyCon )
+import Class		( GenClass, GenClassOp )
+import Id		( GenId )
+import Unique		( Unique )
+import UniqFM		( Uniquable(..) )
+import MachRegs		( Reg )
+import CLabel		( CLabel )
+
+data RdrName 
+data GenClass a b
+data GenClassOp a
+data GenId a		-- NB: fails the optimisation criterion
+data GenTyVar a		-- NB: fails the optimisation criterion
+data Name
+data OrigName
+data OccName
+data TyCon
+data Unique
+data Reg
+data CLabel
+
+
+class Uniquable a where
+	uniqueOf :: a -> Unique
+
+-- SPECIALIZing in FiniteMap
+instance Eq Reg
+instance Eq CLabel
+instance Eq OccName
+instance Eq RdrName
+instance Eq OrigName
+instance Eq (GenId a)
+instance Eq TyCon
+instance Eq (GenClass a b)
+instance Eq Unique
+instance Eq Name
+
+instance Ord Reg
+instance Ord CLabel
+instance Ord OccName
+instance Ord RdrName
+instance Ord OrigName
+instance Ord (GenId a)
+instance Ord TyCon
+instance Ord (GenClass a b)
+instance Ord Unique
+instance Ord Name
+
+-- SPECIALIZing in UniqFM, UniqSet
+instance Uniquable OrigName
+instance Uniquable (GenId a)
+instance Uniquable TyCon
+instance Uniquable (GenClass a b)
+instance Uniquable Unique
+instance Uniquable Name
+
+-- SPECIALIZing in Name
+\end{code}