* Defines storage datatypes: Text, Name, Module, Tycon, Cell, List, Pair,
* Triple, ...
*
- * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
- * Haskell Group 1994-99, and is distributed as Open Source software
- * under the Artistic License; see the file "Artistic" that is included
- * in the distribution for details.
+ * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
+ * Yale Haskell Group, and the Oregon Graduate Institute of Science and
+ * Technology, 1994-1999, All rights reserved. It is distributed as
+ * free software under the license in the file "License", which is
+ * included in the distribution.
*
* $RCSfile: storage.h,v $
- * $Revision: 1.5 $
- * $Date: 1999/03/09 14:51:14 $
+ * $Revision: 1.42 $
+ * $Date: 2000/04/07 16:25:20 $
* ------------------------------------------------------------------------*/
+#define DEBUG_STORAGE /* a moderate level of sanity checking */
+#define DEBUG_STORAGE_EXTRA /* max paranoia in sanity checks */
+
/* --------------------------------------------------------------------------
* Typedefs for main data types:
* Many of these type names are used to indicate the intended us of a data
typedef Cell Pair; /* pair cell */
typedef Int StackPtr; /* stack pointer */
typedef Cell Offset; /* offset/generic variable*/
-typedef Int Script; /* script file number */
typedef Int Module; /* module */
typedef Cell Tycon; /* type constructor */
typedef Cell Type; /* type expression */
typedef Cell Ext; /* extension label */
#endif
+typedef Cell ConId;
+typedef Cell VarId;
+typedef Cell QualId;
+typedef Cell ConVarId;
+
+/* --------------------------------------------------------------------------
+ * Address ranges.
+ *
+ * -heapSize .. -1 cells in the heap
+ * 0 NIL
+ *
+ * TAG_NONPTR_MIN(100) .. TAG_NONPTR_MAX(115) non pointer tags
+ * TAG_PTR_MIN(200) .. TAG_PTR_MAX(298) pointer tags
+ * TAG_SPEC_MIN(400) .. TAG_SPEC_MAX(431) special tags
+ * OFF_MIN(1,000) .. OFF_MAX(1,999) offsets
+ * CHARR_MIN(3,000) .. CHARR_MAX(3,255) chars
+ *
+ * SMALL_INT_MIN(100,000) .. SMALL_INT_MAX(499,999) smallish ints
+ * (300,000 denotes 0)
+ *
+ * NAME_BASE_ADDR (1,000,000 .. 1,899,999) names
+ * TYCON_BASE_ADDR (2,000,000 .. 2,899,999) tycons
+ * CCLASS_BASE_ADDR (3,000,000 .. 3,899,999) classes
+ * INST_BASE_ADDR (4,000,000 .. 4,899,999) instances
+ * MODULE_BASE_ADDR (5,000,000 .. 5,899,999) modules
+ * INVAR_BASE_ADDR (6,000,000 .. 6,899,999) invented var names
+ * INDVAR_BASE_ADDR (7,000,000 .. 7,899,999) invented dict var names
+ * TEXT_BASE_ADDR (8,000,000 .. 8M +TEXT_SIZE-1) text
+ * ------------------------------------------------------------------------*/
+
/* --------------------------------------------------------------------------
* Text storage:
* provides storage for the characters making up identifier and symbol
* names, string literals, character constants etc...
* ------------------------------------------------------------------------*/
-extern String textToStr Args((Text));
-extern Text findText Args((String));
-extern Text inventText Args((Void));
-extern Text inventDictText Args((Void));
-extern Bool inventedText Args((Text));
+extern String textToStr ( Text );
+extern Text findText ( String );
+extern Text inventText ( Void );
+extern Text inventDictText ( Void );
+extern Bool inventedText ( Text );
+extern Text enZcodeThenFindText ( String );
+extern Text unZcodeThenFindText ( String );
/* Variants of textToStr and syntaxOf which work for idents, ops whether
* qualified or unqualified.
*/
-extern String identToStr Args((Cell));
-extern Syntax identSyntax Args((Cell));
-extern Syntax defaultSyntax Args((Text));
+extern String identToStr ( Cell );
+extern Text fixLitText ( Text );
+extern Syntax identSyntax ( Cell );
+extern Syntax defaultSyntax ( Text );
+
+#define INVAR_BASE_ADDR 6000000
+#define INVAR_MAX_AVAIL 900000
+#define isInventedVar(c) (INVAR_BASE_ADDR<=(c) \
+ && (c)<INVAR_BASE_ADDR+INVAR_MAX_AVAIL)
+
+#define INDVAR_BASE_ADDR 7000000
+#define INDVAR_MAX_AVAIL 900000
+#define isInventedDictVar(c) (INDVAR_BASE_ADDR<=(c) \
+ && (c)<INDVAR_BASE_ADDR+INDVAR_MAX_AVAIL)
+
+#define TEXT_BASE_ADDR 8000000
+#define isText(c) (TEXT_BASE_ADDR<=(c) \
+ && (c)<TEXT_BASE_ADDR+TEXT_SIZE)
/* --------------------------------------------------------------------------
* Specification of syntax (i.e. default written form of application)
#define DEF_OPSYNTAX mkSyntax(DEF_ASS,DEF_PREC)
#define NO_SYNTAX (-1)
-extern Void addSyntax Args((Int,Text,Syntax));
-extern Syntax syntaxOf Args((Text));
+extern Void addSyntax ( Int,Text,Syntax );
+extern Syntax syntaxOf ( Text );
/* --------------------------------------------------------------------------
* Heap storage:
* ------------------------------------------------------------------------*/
#define heapAlloc(s) (Heap)(farCalloc(s,sizeof(Cell)))
-#define heapBuilt() (heapFst)
extern Int heapSize;
extern Heap heapFst, heapSnd;
extern Heap heapTopFst;
extern Heap heapTopSnd;
extern Bool consGC; /* Set to FALSE to turn off gc from*/
/* C stack; use with extreme care! */
-extern Int cellsRecovered; /* cells recovered by last gc */
+extern Int cellsRecovered; /* cells recovered by last gc */
#define fst(c) heapTopFst[c]
#define snd(c) heapTopSnd[c]
-#if PROFILING
-extern Heap heapThd, heapTopThd;
-#define thd(c) heapTopThd[c]
-extern Name producer;
-extern Bool profiling;
-extern Int profInterval;
-extern Void profilerLog Args((String));
-#endif
-
-extern Pair pair Args((Cell,Cell));
-extern Void garbageCollect Args((Void));
-extern Void overwrite Args((Pair,Pair));
-extern Void overwrite2 Args((Pair,Cell,Cell));
-extern Cell markExpr Args((Cell));
-extern Void markWithoutMove Args((Cell));
-
-#define mark(v) v=markExpr(v)
+extern Pair pair ( Cell,Cell );
+extern Void garbageCollect ( Void );
+extern Void mark ( Cell );
#define isPair(c) ((c)<0)
#define isGenPair(c) ((c)<0 && -heapSize<=(c))
-extern Cell whatIs Args((Cell));
+extern Cell whatIs ( Cell );
/* --------------------------------------------------------------------------
- * Box cell tags are used as the fst element of a pair to indicate that
- * the snd element of the pair is to be treated in some special way, other
- * than as a Cell. Examples include holding integer values, variable name
- * and string text etc.
+ * Pairs in the heap fall into three categories.
+ *
+ * pair(TAG_NONPTR,y)
+ * used to denote that the second element of the pair is to be treated
+ * in some special way (eg is a integer or Text), and specifically is not
+ * a heap pointer
+ *
+ * pair(TAG_PTR,y)
+ * to indicate that the second element of the pair is a normal
+ * heap pointer, which should be followed at GC time
+ *
+ * pair(x,y)
+ * is a genuine pair, where both components are heap pointers.
* ------------------------------------------------------------------------*/
-#define TAGMIN 1 /* Box and constructor cell tag values */
-#define BCSTAG 20 /* Box=TAGMIN..BCSTAG-1 */
-#define isTag(c) (TAGMIN<=(c) && (c)<SPECMIN) /* Tag cell values */
-#define isBoxTag(c) (TAGMIN<=(c) && (c)<BCSTAG) /* Box cell tag values */
-#define isConTag(c) (BCSTAG<=(c) && (c)<SPECMIN) /* Constr cell tag values*/
-
-#define FREECELL 3 /* Free list cell: snd :: Cell */
-#define VARIDCELL 4 /* Identifier variable: snd :: Text */
-#define VAROPCELL 5 /* Operator variable: snd :: Text */
-#define DICTVAR 6 /* Dictionary variable: snd :: Text */
-#define CONIDCELL 7 /* Identifier constructor: snd :: Text */
-#define CONOPCELL 8 /* Operator constructor: snd :: Text */
-#define STRCELL 9 /* String literal: snd :: Text */
-#define INTCELL 10 /* Int literal: snd :: Int */
-#define ADDPAT 11 /* (_+k) pattern discr: snd :: Int */
-#define FLOATCELL 15 /* Floating Pt literal: snd :: Text */
-#define BIGCELL 16 /* Integer literal: snd :: Text */
-#if PTR_ON_HEAP
-#define PTRCELL 17 /* C Heap Pointer snd :: Ptr */
+#if !defined(SIZEOF_VOID_P) || !defined(SIZEOF_INT)
+#error SIZEOF_VOID_P or SIZEOF_INT is not defined
#endif
+
+#define isTagNonPtr(c) (TAG_NONPTR_MIN<=(c) && (c)<=TAG_NONPTR_MAX)
+#define isTagPtr(c) (TAG_PTR_MIN<=(c) && (c)<=TAG_PTR_MAX)
+#define isTag(c) (isTagNonPtr(c) || isTagPtr(c))
+
+/* --------------------------------------------------------------------------
+ * Tags for non-pointer cells.
+ * ------------------------------------------------------------------------*/
+
+#define TAG_NONPTR_MIN 100
+#define TAG_NONPTR_MAX 115
+
+#define FREECELL 100 /* Free list cell: snd :: Cell */
+#define VARIDCELL 101 /* Identifier variable: snd :: Text */
+#define VAROPCELL 102 /* Operator variable: snd :: Text */
+#define DICTVAR 103 /* Dictionary variable: snd :: Text */
+#define CONIDCELL 104 /* Identifier constructor: snd :: Text */
+#define CONOPCELL 105 /* Operator constructor: snd :: Text */
+#define STRCELL 106 /* String literal: snd :: Text */
+#define INTCELL 107 /* Int literal: snd :: Int */
+#define ADDPAT 108 /* (_+k) pattern discr: snd :: Int */
+#define FLOATCELL 109 /* Floating Pt literal: snd :: Text */
+#define BIGCELL 110 /* Integer literal: snd :: Text */
+#define PTRCELL 111 /* C Heap Pointer snd :: Ptr */
+#define CPTRCELL 112 /* Native code pointer snd :: Ptr */
+
+#if IPARAM
+#define IPCELL 113 /* Imp Param Cell: snd :: Text */
+#define IPVAR 114 /* ?x: snd :: Text */
+#endif
+
#if TREX
-#define EXTCOPY 18 /* Copy of an Ext: snd :: Text */
+#define EXTCOPY 115 /* Copy of an Ext: snd :: Text */
#endif
-#define textOf(c) ((Text)(snd(c))) /* c :: (VAR|CON)(ID|OP) */
#define qmodOf(c) (textOf(fst(snd(c)))) /* c :: QUALIDENT */
#define qtextOf(c) (textOf(snd(snd(c)))) /* c :: QUALIDENT */
#define mkVar(t) ap(VARIDCELL,t)
#define mkQCon(m,t) ap(QUALIDENT,pair(mkCon(m),mkCon(t)))
#define mkQVarOp(m,t) ap(QUALIDENT,pair(mkCon(m),mkVarop(t)))
#define mkQConOp(m,t) ap(QUALIDENT,pair(mkCon(m),mkConop(t)))
+#define mkQualId(m,t) ap(QUALIDENT,pair(m,t))
#define intValOf(c) (snd(c))
#define inventVar() mkVar(inventText())
#define mkDictVar(t) ap(DICTVAR,t)
#define inventDictVar() mkDictVar(inventDictText())
#define mkStr(t) ap(STRCELL,t)
-extern Bool isVar Args((Cell));
-extern Bool isCon Args((Cell));
-extern Bool isQVar Args((Cell));
-extern Bool isQCon Args((Cell));
-extern Bool isQualIdent Args((Cell));
-extern Bool isIdent Args((Cell));
+#if IPARAM
+#define mkIParam(c) ap(IPCELL,snd(c))
+#define isIP(p) (whatIs(p) == IPCELL)
+#define ipMatch(pi, t) (isIP(fun(pi)) && textOf(fun(pi)) == t)
+#define ipVar(pi) textOf(fun(pi))
+#else
+#define isIP(p) FALSE
+#endif
-extern String stringNegate Args((String));
+extern Bool isVar ( Cell );
+extern Bool isCon ( Cell );
+extern Bool isQVar ( Cell );
+extern Bool isQCon ( Cell );
+extern Bool isQualIdent ( Cell );
+extern Bool eqQualIdent ( QualId c1, QualId c2 );
+extern Bool isIdent ( Cell );
+extern String stringNegate ( String );
+extern Text textOf ( Cell );
#define isFloat(c) (isPair(c) && fst(c)==FLOATCELL)
#define stringToFloat(s) pair(FLOATCELL,findText(s))
#define mkFloat(f) (f) /* ToDo: is this right? */
#define floatNegate(f) stringToFloat(stringNegate(floatToString(f)))
+#define stringToBignum(s) pair(BIGCELL,findText(s))
#define bignumToString(b) textToStr(snd(b))
-
-#if PTR_ON_HEAP
#define isPtr(c) (isPair(c) && fst(c)==PTRCELL)
-extern Cell mkPtr Args((Ptr));
-extern Ptr ptrOf Args((Cell));
-#endif
+extern Cell mkPtr ( Ptr );
+extern Ptr ptrOf ( Cell );
+#define isCPtr(c) (isPair(c) && fst(c)==CPTRCELL)
+extern Cell mkCPtr ( Ptr );
+extern Ptr cptrOf ( Cell );
/* --------------------------------------------------------------------------
- * Constructor cell tags are used as the fst element of a pair to indicate
- * a particular syntactic construct described by the snd element of the
- * pair.
- * Note that a cell c will not be treated as an application (AP/isAp) node
- * if its first element is a constructor cell tag, whereas a cell whose fst
- * element is a special cell will be treated as an application node.
+ * Tags for pointer cells.
* ------------------------------------------------------------------------*/
-#define LETREC 20 /* LETREC snd :: ([Decl],Exp) */
-#define COND 21 /* COND snd :: (Exp,Exp,Exp) */
-#define LAMBDA 22 /* LAMBDA snd :: Alt */
-#define FINLIST 23 /* FINLIST snd :: [Exp] */
-#define DOCOMP 24 /* DOCOMP snd :: (Exp,[Qual]) */
-#define BANG 25 /* BANG snd :: Type */
-#define COMP 26 /* COMP snd :: (Exp,[Qual]) */
-#define ASPAT 27 /* ASPAT snd :: (Var,Exp) */
-#define ESIGN 28 /* ESIGN snd :: (Exp,Type) */
-#define RSIGN 29 /* RSIGN snd :: (Rhs,Type) */
-#define CASE 30 /* CASE snd :: (Exp,[Alt]) */
-#define NUMCASE 31 /* NUMCASE snd :: (Exp,Disc,Rhs) */
-#define FATBAR 32 /* FATBAR snd :: (Exp,Exp) */
-#define LAZYPAT 33 /* LAZYPAT snd :: Exp */
-#define DERIVE 35 /* DERIVE snd :: Cell */
-#if BREAK_FLOATS
-#define FLOATCELL 36 /* FLOATCELL snd :: (Int,Int) */
+#define TAG_PTR_MIN 200
+#define TAG_PTR_MAX 298
+
+#define LETREC 200 /* LETREC snd :: ([Decl],Exp) */
+#define COND 201 /* COND snd :: (Exp,Exp,Exp) */
+#define LAMBDA 202 /* LAMBDA snd :: Alt */
+#define FINLIST 203 /* FINLIST snd :: [Exp] */
+#define DOCOMP 204 /* DOCOMP snd :: (Exp,[Qual]) */
+#define BANG 205 /* BANG snd :: Type */
+#define COMP 206 /* COMP snd :: (Exp,[Qual]) */
+#define ASPAT 207 /* ASPAT snd :: (Var,Exp) */
+#define ESIGN 208 /* ESIGN snd :: (Exp,Type) */
+#define RSIGN 209 /* RSIGN snd :: (Rhs,Type) */
+#define CASE 210 /* CASE snd :: (Exp,[Alt]) */
+#define NUMCASE 211 /* NUMCASE snd :: (Exp,Disc,Rhs) */
+#define FATBAR 212 /* FATBAR snd :: (Exp,Exp) */
+#define LAZYPAT 213 /* LAZYPAT snd :: Exp */
+#define DERIVE 214 /* DERIVE snd :: Cell */
+#define BOOLQUAL 215 /* BOOLQUAL snd :: Exp */
+#define QWHERE 216 /* QWHERE snd :: [Decl] */
+#define FROMQUAL 217 /* FROMQUAL snd :: (Exp,Exp) */
+#define DOQUAL 218 /* DOQUAL snd :: Exp */
+#define MONADCOMP 219 /* MONADCOMP snd :: ((m,m0),(Exp,[Qual])*/
+#define GUARDED 220 /* GUARDED snd :: [guarded exprs] */
+#define ARRAY 221 /* Array snd :: (Bounds,[Values]) */
+#define MUTVAR 222 /* Mutvar snd :: Cell */
+#define HUGSOBJECT 223 /* HUGSOBJECT snd :: Cell */
+
+#if IPARAM
+#define WITHEXP 224 /* WITHEXP snd :: [(Var,Exp)] */
#endif
-#if BIGNUMS
-#define POSNUM 37 /* POSNUM snd :: [Int] */
-#define NEGNUM 38 /* NEGNUM snd :: [Int] */
+#define POLYTYPE 225 /* POLYTYPE snd :: (Kind,Type) */
+#define QUAL 226 /* QUAL snd :: ([Classes],Type) */
+#define RANK2 227 /* RANK2 snd :: (Int,Type) */
+#define EXIST 228 /* EXIST snd :: (Int,Type) */
+#define POLYREC 229 /* POLYREC snd :: (Int,Type) */
+#define BIGLAM 230 /* BIGLAM snd :: (vars,patterns) */
+#define CDICTS 231 /* CDICTS snd :: ([Pred],Type) */
+
+#define LABC 232 /* LABC snd :: (con,[(Vars,Type)]) */
+#define CONFLDS 233 /* CONFLDS snd :: (con,[Field]) */
+#define UPDFLDS 234 /* UPDFLDS snd :: (Exp,[con],[Field]) */
+#if TREX
+#define RECORD 235 /* RECORD snd :: [Val] */
+#define EXTCASE 236 /* EXTCASE snd :: (Exp,Disc,Rhs) */
+#define RECSEL 237 /* RECSEL snd :: Ext */
#endif
+#define IMPDEPS 238 /* IMPDEPS snd :: [Binding] */
-#define BOOLQUAL 39 /* BOOLQUAL snd :: Exp */
-#define QWHERE 40 /* QWHERE snd :: [Decl] */
-#define FROMQUAL 41 /* FROMQUAL snd :: (Exp,Exp) */
-#define DOQUAL 42 /* DOQUAL snd :: Exp */
-#define MONADCOMP 43 /* MONADCOMP snd :: ((m,m0),(Exp,[Qual])*/
+#define QUALIDENT 239 /* Qualified identifier snd :: (Id,Id) */
+#define HIDDEN 240 /* hiding import list snd :: [Entity] */
+#define MODULEENT 241 /* module in export list snd :: con */
-#define GUARDED 44 /* GUARDED snd :: [guarded exprs] */
+#define INFIX 242 /* INFIX snd :: (see tidyInfix) */
+#define ONLY 243 /* ONLY snd :: Exp */
+#define NEG 244 /* NEG snd :: Exp */
-#define ARRAY 45 /* Array snd :: (Bounds,[Values]) */
-#define MUTVAR 46 /* Mutvar snd :: Cell */
-#if INTERNAL_PRIMS
-#define HUGSOBJECT 47 /* HUGSOBJECT snd :: Cell */
-#endif
+/* Used when parsing GHC interface files */
+#define DICTAP 245 /* DICTAP snd :: (QClassId,[Type]) */
+#define UNBOXEDTUP 246 /* UNBOXEDTUP snd :: [Type] */
-#define POLYTYPE 50 /* POLYTYPE snd :: (Kind,Type) */
-#define QUAL 51 /* QUAL snd :: ([Classes],Type) */
-#define RANK2 52 /* RANK2 snd :: (Int,Type) */
-#define EXIST 53 /* EXIST snd :: (Int,Type) */
-#define POLYREC 54 /* POLYREC snd :: (Int,Type) */
-#define BIGLAM 55 /* BIGLAM snd :: (vars,patterns) */
-#define CDICTS 56 /* CDICTS snd :: ([Pred],Type) */
-
-#define LABC 60 /* LABC snd :: (con,[(Vars,Type)]) */
-#define CONFLDS 61 /* CONFLDS snd :: (con,[Field]) */
-#define UPDFLDS 62 /* UPDFLDS snd :: (Exp,[con],[Field]) */
-#if TREX
-#define RECORD 63 /* RECORD snd :: [Val] */
-#define EXTCASE 64 /* EXTCASE snd :: (Exp,Disc,Rhs) */
-#define RECSEL 65 /* RECSEL snd :: Ext */
+#if SIZEOF_VOID_P != SIZEOF_INT
+#define PTRCELL 247 /* C Heap Pointer snd :: (Int,Int) */
#endif
-#define IMPDEPS 68 /* IMPDEPS snd :: [Binding] */
-
-#define QUALIDENT 70 /* Qualified identifier snd :: (Id,Id) */
-#define HIDDEN 71 /* hiding import list snd :: [Entity] */
-#define MODULEENT 72 /* module in export list snd :: con */
-#define INFIX 80 /* INFIX snd :: (see tidyInfix) */
-#define ONLY 81 /* ONLY snd :: Exp */
-#define NEG 82 /* NEG snd :: Exp */
+/* STG syntax */
+#define STGVAR 248 /* STGVAR snd :: (StgRhs,info) */
+#define STGAPP 249 /* STGAPP snd :: (StgVar,[Arg]) */
+#define STGPRIM 250 /* STGPRIM snd :: (PrimOp,[Arg]) */
+#define STGCON 251 /* STGCON snd :: (StgCon,[Arg]) */
+#define PRIMCASE 252 /* PRIMCASE snd :: (Expr,[PrimAlt]) */
+#define DEEFALT 253 /* DEEFALT snd :: (Var,Expr) */
+#define CASEALT 254 /* CASEALT snd :: (Con,[Var],Expr) */
+#define PRIMALT 255 /* PRIMALT snd :: ([Var],Expr) */
+
+/* Module groups */
+#define GRP_REC 256 /* GRP_REC snd :: [CONID] */
+#define GRP_NONREC 257 /* GRP_NONREC snd :: CONID */
+
+
+/*
+ Top-level interface entities
+ type Line = Int -- a line number
+ type ConVarId = CONIDCELL | VARIDCELL
+ type ExportListEntry = ConVarId | (ConId, [ConVarId])
+ type Associativity = mkInt of LEFT_ASS | RIGHT_ASS | NON_ASS
+ type Constr = ((ConId, [((Type,VarId,Int))]))
+ ((constr name, [((type, field name if any, strictness))]))
+ strictness: 0 => none, 1 => !, 2 => !! (unpacked)
+ All 2/3/4/5 tuples in the interface abstract syntax are done with
+ z-tuples.
+*/
+
+#define I_INTERFACE 260 /* snd :: ((ConId, [I_IMPORT..I_VALUE]))
+ interface name, list of iface entities */
+
+#define I_IMPORT 261 /* snd :: ((ConId, [ConVarId]))
+ module name, list of entities */
+
+#define I_INSTIMPORT 262 /* snd :: NIL -- not used at present */
+
+#define I_EXPORT 263 /* snd :: ((ConId, [ExportListEntry]))
+ this module name?, entities to export */
+
+#define I_FIXDECL 264 /* snd :: ((NIL|Int, Associativity, ConVarId))
+ fixity, associativity, name */
+
+#define I_INSTANCE 265 /* snd :: ((Line,
+ [((VarId,Kind))],
+ Type, VarId, Inst))
+ lineno,
+ forall-y bit (eg __forall [a b] =>),
+ other bit, eg { C a1 } -> { C2 a2 } -> ... -> { Cn an },
+ name of dictionary builder,
+ (after startGHCInstance) the instance table location */
+
+#define I_TYPE 266 /* snd :: ((Line, ConId, [((VarId,Kind))], Type))
+ lineno, tycon, kinded tyvars, the type expr */
+
+#define I_DATA 267 /* snd :: ((Line, [((QConId,VarId))], ConId,
+ [((VarId,Kind))], [Constr])
+ lineno, context, tycon, kinded tyvars, constrs
+ An empty constr list means exported abstractly. */
+
+#define I_NEWTYPE 268 /* snd :: ((Line, [((QConId,VarId))], ConId,
+ [((VarId,Kind))], ((ConId,Type)) ))
+ lineno, context, tycon, kinded tyvars, constr
+ constr==NIL means exported abstractly. */
+
+#define I_CLASS 269 /* snd :: ((Line, [((QConId,VarId))], ConId,
+ [((VarId,Kind))], [((VarId,Type))]))
+ lineno, context, classname,
+ kinded tyvars, method sigs */
+
+#define I_VALUE 270 /* snd :: ((Line, VarId, Type)) */
+
+/*
+ Top-level module entities.
+
+ type Export = ?
+*/
+#define M_MODULE 280 /* snd :: ((ConId, [Export],
+ M_IMPORT_Q .. M_VALUE]))
+ module name, export spec, top level entities */
+
+#define M_IMPORT_Q 281 /* snd :: ((?,?)) */
+#define M_IMPORT_UNQ 282 /* snd :: ((?,?)) */
+#define M_TYCON 283 /* snd :: ((Line,?,?,?)) */
+#define M_CLASS 284 /* snd :: ((Line,?,?,?)) */
+#define M_INST 285 /* snd :: ((Line,?,?)) */
+#define M_DEFAULT 286 /* snd :: ((Line,?)) */
+#define M_FOREIGN_EX 289 /* snd :: ((Line,?,?,?,?)) */
+#define M_FOREIGN_IM 290 /* snd :: ((Line,?,?,?,?)) */
+#define M_VALUE 291 /* snd :: ? */
+
+
+
+
+/*
+ Tagged tuples.
+*/
+#define ZTUP2 295 /* snd :: (Cell,Cell) */
+#define ZTUP3 296 /* snd :: (Cell,(Cell,Cell)) */
+#define ZTUP4 297 /* snd :: (Cell,(Cell,(Cell,Cell))) */
+#define ZTUP5 298 /* snd :: (Cell,(Cell,(Cell,(Cell,Cell)))) */
-#if SIZEOF_INTP != SIZEOF_INT
-#define PTRCELL 90 /* C Heap Pointer snd :: (Int,Int) */
-#endif
-#define STGVAR 92 /* STGVAR snd :: (StgRhs,info) */
-#define STGAPP 93 /* STGAPP snd :: (StgVar,[Arg]) */
-#define STGPRIM 94 /* STGPRIM snd :: (PrimOp,[Arg]) */
-#define STGCON 95 /* STGCON snd :: (StgCon,[Arg]) */
-#define PRIMCASE 96 /* PRIMCASE snd :: (Expr,[PrimAlt]) */
-/* Last constructor tag must be less than SPECMIN */
/* --------------------------------------------------------------------------
- * Special cell values:
+ * Special cell values.
* ------------------------------------------------------------------------*/
-#define SPECMIN 101
-#define isSpec(c) (SPECMIN<=(c) && (c)<TUPMIN)/* Special cell values */
+#define TAG_SPEC_MIN 400
+#define TAG_SPEC_MAX 431
-#define NONE 101 /* Dummy stub */
-#define STAR 102 /* Representing the kind of types */
-#if TREX
-#define ROW 103 /* Representing the kind of rows */
-#endif
-#define WILDCARD 104 /* Wildcard pattern */
-#define SKOLEM 105 /* Skolem constant */
+#define isSpec(c) (TAG_SPEC_MIN<=(c) && (c)<=TAG_SPEC_MAX)
-#define DOTDOT 106 /* ".." in import/export list */
-
-#if BIGNUMS
-#define ZERONUM 108 /* The zero bignum (see POSNUM, NEGNUM) */
+#define NONE 400 /* Dummy stub */
+#define STAR 401 /* Representing the kind of types */
+#if TREX
+#define ROW 402 /* Representing the kind of rows */
#endif
-
-#define NAME 110 /* whatIs code for isName */
-#define TYCON 111 /* whatIs code for isTycon */
-#define CLASS 112 /* whatIs code for isClass */
-#define MODULE 113 /* whatIs code for isModule */
-#define INSTANCE 114 /* whatIs code for isInst */
-#define TUPLE 115 /* whatIs code for tuple constructor */
-#define OFFSET 116 /* whatis code for offset */
-#define AP 117 /* whatIs code for application node */
-#define CHARCELL 118 /* whatIs code for isChar */
+#define WILDCARD 403 /* Wildcard pattern */
+#define SKOLEM 404 /* Skolem constant */
+
+#define DOTDOT 405 /* ".." in import/export list */
+
+#define NAME 406 /* whatIs code for isName */
+#define TYCON 407 /* whatIs code for isTycon */
+#define CLASS 408 /* whatIs code for isClass */
+#define MODULE 409 /* whatIs code for isModule */
+#define INSTANCE 410 /* whatIs code for isInst */
+#define TUPLE 411 /* whatIs code for tuple constructor */
+#define OFFSET 412 /* whatis code for offset */
+#define AP 413 /* whatIs code for application node */
+#define CHARCELL 414 /* whatIs code for isChar */
#if TREX
-#define EXT 119 /* whatIs code for isExt */
+#define EXT 415 /* whatIs code for isExt */
#endif
-#define SIGDECL 120 /* Signature declaration */
-#define FIXDECL 121 /* Fixity declaration */
-#define FUNBIND 122 /* Function binding */
-#define PATBIND 123 /* Pattern binding */
+#define SIGDECL 416 /* Signature declaration */
+#define FIXDECL 417 /* Fixity declaration */
+#define FUNBIND 418 /* Function binding */
+#define PATBIND 419 /* Pattern binding */
+
+#define DATATYPE 420 /* Datatype type constructor */
+#define NEWTYPE 421 /* Newtype type constructor */
+#define SYNONYM 422 /* Synonym type constructor */
+#define RESTRICTSYN 423 /* Synonym with restricted scope */
-#define DATATYPE 130 /* Datatype type constructor */
-#define NEWTYPE 131 /* Newtype type constructor */
-#define SYNONYM 132 /* Synonym type constructor */
-#define RESTRICTSYN 133 /* Synonym with restricted scope */
+#define NODEPENDS 424 /* Stop calculation of deps in type check*/
+#define PREDEFINED 425 /* Predefined name, not yet filled */
+#define TEXTCELL 426 /* whatIs code for isText */
+#define INVAR 427 /* whatIs code for isInventedVar */
+#define INDVAR 428 /* whatIs code for isInventedDictVar */
+
+#define FM_SOURCE 429 /* denotes source module (FileMode) */
+#define FM_OBJECT 430 /* denotes object module */
+#define FM_EITHER 431 /* no restriction; either is allowed */
-#define NODEPENDS 135 /* Stop calculation of deps in type check*/
-#define PREDEFINED 136 /* Predefined name, not yet filled */
/* --------------------------------------------------------------------------
* Tuple data/type constructors:
* ------------------------------------------------------------------------*/
-#define TUPMIN 201
-#if TREX
-#define isTuple(c) (TUPMIN<=(c) && (c)<EXTMIN)
-#else
-#define isTuple(c) (TUPMIN<=(c) && (c)<OFFMIN)
-#endif
-#define mkTuple(n) (TUPMIN+(n))
-#define tupleOf(n) ((Int)((n)-TUPMIN))
+extern Text ghcTupleText ( Tycon );
+extern Text ghcTupleText_n ( Int );
+
+
#if TREX
-#define EXTMIN (TUPMIN+NUM_TUPLES)
+#error TREX not supported
+#define EXTMIN 301
#define isExt(c) (EXTMIN<=(c) && (c)<OFFMIN)
#define extText(e) tabExt[(e)-EXTMIN]
#define extField(c) arg(fun(c))
#define extRow(c) arg(c)
extern Text DECTABLE(tabExt);
-extern Ext mkExt Args((Text));
+extern Ext mkExt ( Text );
#else
#define mkExt(t) NIL
#endif
+extern Module findFakeModule ( Text t );
+extern Tycon addTupleTycon ( Int n );
+extern Name addWiredInBoxingTycon
+ ( String modNm, String typeNm, String constrNm,
+ Int rep, Kind kind );
+extern Tycon addWiredInEnumTycon
+ ( String modNm, String typeNm,
+ List /*of Text*/ constrs );
+
/* --------------------------------------------------------------------------
* Offsets: (generic types/stack offsets)
* ------------------------------------------------------------------------*/
-#if TREX
-#define OFFMIN (EXTMIN+NUM_EXT)
-#else
-#define OFFMIN (TUPMIN+NUM_TUPLES)
-#endif
-#define isOffset(c) (OFFMIN<=(c) && (c)<MODMIN)
-#define offsetOf(c) ((c)-OFFMIN)
-#define mkOffset(o) (OFFMIN+(o))
+#define OFF_MIN 1000
+#define OFF_MAX 1999
+
+#define isOffset(c) (OFF_MIN<=(c) && (c)<=OFF_MAX)
+#define offsetOf(c) ((c)-OFF_MIN)
+#define mkOffset(o) (OFF_MIN+(o))
+
/* --------------------------------------------------------------------------
* Modules:
* ------------------------------------------------------------------------*/
-#define MODMIN (OFFMIN+NUM_OFFSETS)
+#define MODULE_BASE_ADDR 5000000
+#define MODULE_MAX_SIZE 900000
+#define MODULE_INIT_SIZE 4
+
+#ifdef DEBUG_STORAGE
+extern struct strModule* generate_module_ref ( Cell );
+#define module(mod) (*generate_module_ref(mod))
+#else
+#define module(mod) tabModule[(mod)-MODULE_BASE_ADDR]
+#endif
-#if IGNORE_MODULES
-#define setCurrModule(m) doNothing()
-#else /* !IGNORE_MODULES */
-#define isModule(c) (MODMIN<=(c) && (c)<TYCMIN)
-#define mkModule(n) (MODMIN+(n))
-#define module(n) tabModule[(n)-MODMIN]
+#define mkModule(n) (MODULE_BASE_ADDR+(n))
+#define isModule(c) (MODULE_BASE_ADDR<=(c) \
+ && (c)<MODULE_BASE_ADDR+tabModuleSz \
+ && tabModule[(c)-MODULE_BASE_ADDR].inUse)
+
+
+/* Import defns for the ObjectCode struct in Module. */
+#include "object.h"
+
+/* Import a machine-dependent definition of Time, for module timestamps. */
+#include "machdep_time.h"
/* Under Haskell 1.3, the list of qualified imports is always a subset
* of the list of unqualified imports. For simplicity and flexibility,
* list is just a flat list of Texts (before static analysis) or
* Tycons, Names and Classes (after static analysis).
*/
-struct Module {
- Text text;
- /* Lists of top level objects (local defns + imports) */
- List tycons;
- List names;
- List classes;
- List exports; /* [ Entity | (Entity, NIL|DOTDOT) ] */
- /* List of qualified imports. Used both during compilation and when
- * evaluating an expression in the context of the current module.
- */
- List qualImports;
- ObjectFile objectFile; /* usually unused */
+struct strModule {
+ Bool inUse;
+ Name nextFree;
+
+ Text text; /* Name of this module */
+
+ List tycons; /* Lists of top level objects ... */
+ List names; /* (local defns + imports) */
+ List classes;
+ List exports; /* [ Entity | (Entity, NIL|DOTDOT) ] */
+
+ List qualImports; /* Qualified imports. */
+
+ Bool fake; /* TRUE if module exists only via GHC primop */
+ /* defn; usually FALSE */
+
+ Cell tree; /* Parse tree for mod or iface */
+ Bool completed; /* Fully loaded or just parsed? */
+ Time lastStamp; /* Time of last parse */
+
+ Cell mode; /* FM_SOURCE or FM_OBJECT */
+ Text srcExt; /* if mode==FM_SOURCE ".lhs", ".hs", etc */
+ List uses; /* :: [CONID] -- names of mods imported by this one */
+
+ Text objName; /* Name of the primary object code file. */
+ Int objSize; /* Size of the primary object code file. */
+
+ ObjectCode* object; /* Primary object code for this module. */
+ ObjectCode* objectExtras; /* And any extras it might need. */
+ List objectExtraNames; /* :: [Text] -- names of extras */
};
+extern struct strModule* tabModule;
+extern Int tabModuleSz;
+
extern Module currentModule; /* Module currently being processed */
-extern struct Module DECTABLE(tabModule);
+extern List moduleGraph; /* :: [GRP_REC | GRP_NONREC] */
+extern List prelModules; /* :: [CONID] */
+extern List targetModules; /* :: [CONID] */
+
-extern Bool isValidModule Args((Module));
-extern Module newModule Args((Text));
-extern Module findModule Args((Text));
-extern Module findModid Args((Cell));
-extern Void setCurrModule Args((Module));
+extern Bool isValidModule ( Module );
+extern Module newModule ( Text );
+extern Void nukeModule ( Module );
+extern Module findModule ( Text );
+extern Module findModid ( Cell );
+extern Void setCurrModule ( Module );
+
+extern void addOTabName ( Module,char*,void* );
+extern void* lookupOTabName ( Module,char* );
+extern char* nameFromOPtr ( void* );
+
+extern void addSection ( Module,void*,void*,OSectionKind );
+extern OSectionKind lookupSection ( void* );
+extern void* lookupOExtraTabName ( char* sym );
+extern void* lookupOTabNameAbsolutelyEverywhere ( char* sym );
#define isPrelude(m) (m==modulePrelude)
-#endif /* !IGNORE_MODULES */
+
+#define N_PRELUDE_SCRIPTS (combined ? 32 : 1)
/* --------------------------------------------------------------------------
* Type constructor names:
* ------------------------------------------------------------------------*/
-#define TYCMIN (MODMIN+NUM_MODULE)
-#define isTycon(c) (TYCMIN<=(c) && (c)<NAMEMIN)
-#define mkTycon(n) (TCMIN+(n))
-#define tycon(n) tabTycon[(n)-TYCMIN]
+#define TYCON_BASE_ADDR 2000000
+#define TYCON_MAX_SIZE 900000
+#define TYCON_INIT_SIZE 4
+
+#ifdef DEBUG_STORAGE
+extern struct strTycon* generate_tycon_ref ( Cell );
+#define tycon(tc) (*generate_tycon_ref(tc))
+#else
+#define tycon(tc) tabTycon[(tc)-TYCON_BASE_ADDR]
+#endif
+
+#define isTycon(c) (TYCON_BASE_ADDR<=(c) \
+ && (c)<TYCON_BASE_ADDR+tabTyconSz \
+ && tabTycon[(c)-TYCON_BASE_ADDR].inUse \
+ && tabTycon[(c)-TYCON_BASE_ADDR].tuple==-1)
+#define isTuple(c) (TYCON_BASE_ADDR<=(c) \
+ && (c)<TYCON_BASE_ADDR+tabTyconSz \
+ && tabTycon[(c)-TYCON_BASE_ADDR].inUse \
+ && tabTycon[(c)-TYCON_BASE_ADDR].tuple>=0)
+#define tupleOf(n) (tycon(n).tuple)
+
+extern Tycon mkTuple ( Int );
+
struct strTycon {
- Text text;
- Int line;
-#if !IGNORE_MODULES
+ Bool inUse;
+ Name nextFree;
+ Text text;
+ Int line;
Module mod; /* module that defines it */
-#endif
- Int arity;
- Kind kind; /* kind (includes arity) of Tycon */
- Cell what; /* DATATYPE/SYNONYM/RESTRICTSYN... */
- Cell defn;
- Name conToTag; /* used in derived code */
- Name tagToCon;
- Tycon nextTyconHash;
+ Int tuple; /* tuple number, or -1 if not tuple */
+ Int arity;
+ Kind kind; /* kind (includes arity) of Tycon */
+ Cell what; /* DATATYPE/SYNONYM/RESTRICTSYN... */
+ Cell defn;
+ Name conToTag; /* used in derived code */
+ Name tagToCon;
+ void* itbl; /* For tuples, the info tbl pointer */
+ Tycon nextTyconHash;
};
-extern struct strTycon DECTABLE(tabTycon);
+extern struct strTycon* tabTycon;
+extern Int tabTyconSz;
-extern Tycon newTycon Args((Text));
-extern Tycon findTycon Args((Text));
-extern Tycon addTycon Args((Tycon));
-extern Tycon findQualTycon Args((Cell));
-extern Tycon addPrimTycon Args((Text,Kind,Int,Cell,Cell));
+extern Tycon newTycon ( Text );
+extern Tycon findTycon ( Text );
+extern Tycon addTycon ( Tycon );
+extern Tycon findQualTycon ( Cell );
+extern Tycon addPrimTycon ( Text,Kind,Int,Cell,Cell );
#define isSynonym(h) (isTycon(h) && tycon(h).what==SYNONYM)
+#define isQualType(t) (isPair(t) && fst(t)==QUAL)
#define mkPolyType(n,t) pair(POLYTYPE,pair(n,t))
#define isPolyType(t) (isPair(t) && fst(t)==POLYTYPE)
+#define isPolyOrQualType(t) (isPair(t) && (fst(t)==POLYTYPE || fst(t)==QUAL))
#define polySigOf(t) fst(snd(t))
#define monotypeOf(t) snd(snd(t))
+#define bang(t) ap(BANG,t)
+
+extern Tycon findQualTyconWithoutConsultingExportList ( QualId q );
+
+extern Int numQualifiers ( Type );
+
/* --------------------------------------------------------------------------
* Globally defined name values:
* ------------------------------------------------------------------------*/
-#define NAMEMIN (TYCMIN+NUM_TYCON)
-#define isName(c) (NAMEMIN<=(c) && (c)<INSTMIN)
-#define mkName(n) (NAMEMIN+(n))
-#define name(n) tabName[(n)-NAMEMIN]
+#define NAME_BASE_ADDR 1000000
+#define NAME_MAX_SIZE 900000
+#define NAME_INIT_SIZE 4
+
+#ifdef DEBUG_STORAGE
+extern struct strName* generate_name_ref ( Cell );
+#define name(nm) (*generate_name_ref(nm))
+#else
+#define name(nm) tabName[(nm)-NAME_BASE_ADDR]
+#endif
+
+#define mkName(n) (NAME_BASE_ADDR+(n))
+#define isName(c) (NAME_BASE_ADDR<=(c) \
+ && (c)<NAME_BASE_ADDR+tabNameSz \
+ && tabName[(c)-NAME_BASE_ADDR].inUse)
struct strName {
+ Bool inUse;
+ Name nextFree;
Text text;
Int line;
Module mod; /* module that defines it */
Int number;
Cell type;
Cell defn;
- Cell stgVar; /* really StgVar */
- const void* primop; /* really StgPrim* */
+ Bool hasStrict; /* does constructor have strict components? */
+ Cell stgVar; /* really StgVar */
+ Text callconv; /* for foreign import/export */
+ void* primop; /* really StgPrim* */
+ void* itbl; /* For constructors, the info tbl pointer */
Name nextNameHash;
};
-extern int numNames Args(( Void ));
+extern struct strName* tabName;
+extern Int tabNameSz;
-extern struct strName DECTABLE(tabName);
+extern int numNames ( Void );
/* The number field in a name is used to distinguish various kinds of name:
* mfunNo(i) = code for member function, offset i
#define mfunOf(n) ((-1)-name(n).number)
#define mfunNo(i) ((-1)-(i))
-extern Name newName Args((Text,Cell));
-extern Name findName Args((Text));
-extern Name addName Args((Name));
-extern Name findQualName Args((Cell));
-extern Name addPrimCfun Args((Text,Int,Int,Cell));
-extern Name addPrimCfunREP Args((Text,Int,Int,Int));
-extern Int sfunPos Args((Name,Name));
+extern Name newName ( Text,Cell );
+extern Name findName ( Text );
+extern Name addName ( Name );
+extern Name findQualName ( Cell );
+extern Name addPrimCfun ( Text,Int,Int,Cell );
+extern Name addPrimCfunREP ( Text,Int,Int,Int );
+extern Int sfunPos ( Name,Name );
+extern Name nameFromStgVar ( Cell );
+extern Name jrsFindQualName ( Text,Text );
+
+extern Name findQualNameWithoutConsultingExportList ( QualId q );
/* --------------------------------------------------------------------------
* Type class values:
* ------------------------------------------------------------------------*/
-#define INSTMIN (NAMEMIN+NUM_NAME) /* instances */
-#define isInst(c) (INSTMIN<=(c) && (c)<CLASSMIN)
-#define mkInst(n) (INSTMIN+(n))
-#define instOf(c) ((Int)((c)-INSTMIN))
-#define inst(in) tabInst[(in)-INSTMIN]
+#define INST_BASE_ADDR 4000000
+#define INST_MAX_SIZE 900000
+#define INST_INIT_SIZE 4
+
+#ifdef DEBUG_STORAGE
+extern struct strInst* generate_inst_ref ( Cell );
+#define inst(in) (*generate_inst_ref(in))
+#else
+#define inst(in) tabInst[(in)-INST_BASE_ADDR]
+#endif
+
+#define mkInst(n) (INST_BASE_ADDR+(n))
+#define instOf(c) ((Int)((c)-INST_BASE_ADDR))
+#define isInst(c) (INST_BASE_ADDR<=(c) \
+ && (c)<INST_BASE_ADDR+tabInstSz \
+ && tabInst[(c)-INST_BASE_ADDR].inUse)
struct strInst {
- Class c; /* class C */
- Int line;
- //Module mod; /* module that defines it */
- Kinds kinds; /* Kinds of variables in head */
- Cell head; /* :: Pred */
- List specifics; /* :: [Pred] */
- Int numSpecifics; /* length(specifics) */
- List implements;
- Name builder; /* Dictionary constructor function */
+ Bool inUse;
+ Name nextFree;
+ Class c; /* class C */
+ Int line;
+ Module mod; /* module that defines it */
+ Kinds kinds; /* Kinds of variables in head */
+ Cell head; /* :: Pred */
+ List specifics; /* :: [Pred] */
+ Int numSpecifics; /* length(specifics) */
+ List implements;
+ Name builder; /* Dictionary constructor function */
};
+extern struct strInst* tabInst;
+extern Int tabInstSz;
+
/* a predicate (an element :: Pred) is an application of a Class to one or
* more type expressions
*/
-#define CLASSMIN (INSTMIN+NUM_INSTS)
-#define isClass(c) (CLASSMIN<=(c) && (c)<CHARMIN)
-#define mkClass(n) (CLASSMIN+(n))
-#define cclass(n) tabClass[(n)-CLASSMIN]
+#define CCLASS_BASE_ADDR 3000000
+#define CCLASS_MAX_SIZE 900000
+#define CCLASS_INIT_SIZE 4
+
+#ifdef DEBUG_STORAGE
+extern struct strClass* generate_cclass_ref ( Cell );
+#define cclass(cl) (*generate_cclass_ref(cl))
+#else
+#define cclass(cl) tabClass[(cl)-CCLASS_BASE_ADDR]
+#endif
+
+#define mkClass(n) (CCLASS_BASE_ADDR+(n))
+#define isClass(c) (CCLASS_BASE_ADDR<=(c) \
+ && (c)<CCLASS_BASE_ADDR+tabClassSz \
+ && tabClass[(c)-CCLASS_BASE_ADDR].inUse)
struct strClass {
+ Bool inUse;
+ Name nextFree;
Text text; /* Name of class */
Int line; /* Line where declaration begins */
-#if !IGNORE_MODULES
Module mod; /* module that declares it */
-#endif
Int level; /* Level in class hierarchy */
Int arity; /* Number of arguments */
Kinds kinds; /* Kinds of constructors in class */
+ List fds; /* Functional Dependencies */
+ List xfds; /* Xpanded Functional Dependencies */
Cell head; /* Head of class */
Name dcon; /* Dictionary constructor function */
List supers; /* :: [Pred] */
List dsels; /* Superclass dictionary selectors */
List members; /* :: [Name] */
Int numMembers; /* length(members) */
- Name dbuild; /* Default dictionary builder */
List defaults; /* :: [Name] */
List instances; /* :: [Inst] */
};
-extern struct strClass DECTABLE(tabClass);
-extern struct strInst far *tabInst;
+extern struct strClass* tabClass;
+extern Int tabClassSz;
-extern Class newClass Args((Text));
-extern Class classMax Args((Void));
-extern Class findClass Args((Text));
-extern Class addClass Args((Class));
-extern Class findQualClass Args((Cell));
-extern Inst newInst Args((Void));
-extern Inst findFirstInst Args((Tycon));
-extern Inst findNextInst Args((Tycon,Inst));
+extern Class newClass ( Text );
+extern Class findClass ( Text );
+extern Class addClass ( Class );
+extern Class findQualClass ( Cell );
+extern Inst newInst ( Void );
+extern Inst findFirstInst ( Tycon );
+extern Inst findNextInst ( Tycon,Inst );
+extern List getAllKnownTyconsAndClasses ( void );
+extern Class findQualClassWithoutConsultingExportList ( QualId q );
/* --------------------------------------------------------------------------
* Character values:
* ------------------------------------------------------------------------*/
-#define CHARMIN (CLASSMIN+NUM_CLASSES)
+/* I think this assumes that NUM_CHARS==256. */
+#define CHARR_MIN 3000
+#define CHARR_MAX 3255
+#define isChar(c) (CHARR_MIN<=(c) && (c)<=CHARR_MAX)
+#define charOf(c) ((Char)((c)-CHARR_MIN))
+#define mkChar(c) (CHARR_MIN+(((Cell)(c)) & 0xFF))
#define MAXCHARVAL (NUM_CHARS-1)
-#define isChar(c) (CHARMIN<=(c) && (c)<INTMIN)
-#define charOf(c) ((Char)(c-CHARMIN))
-#define mkChar(c) ((Cell)(CHARMIN+((unsigned)((c)%NUM_CHARS))))
/* --------------------------------------------------------------------------
* Small Integer values:
* ------------------------------------------------------------------------*/
-#define INTMIN (CHARMIN+NUM_CHARS)
-#define INTMAX (MAXPOSINT)
-#define isSmall(c) (INTMIN<=(c))
-#define INTZERO (INTMIN/2 + INTMAX/2)
-#define MINSMALLINT (INTMIN - INTZERO)
-#define MAXSMALLINT (INTMAX - INTZERO)
-#define mkDigit(c) ((Cell)((c)+INTMIN))
-#define digitOf(c) ((Int)((c)-INTMIN))
-
-extern Bool isInt Args((Cell));
-extern Int intOf Args((Cell));
-extern Cell mkInt Args((Int));
-#if BIGNUMS
-extern Bool isBignum Args((Cell));
-#endif
+#define SMALL_INT_MIN 100000
+#define SMALL_INT_MAX 499999
+#define SMALL_INT_ZERO (1 + SMALL_INT_MIN/2 + SMALL_INT_MAX/2)
+#define isSmall(c) (SMALL_INT_MIN<=(c) && (c)<=SMALL_INT_MAX)
+extern Bool isInt ( Cell );
+extern Int intOf ( Cell );
+extern Cell mkInt ( Int );
/* --------------------------------------------------------------------------
* Implementation of triples:
* Implementation of lists:
* ------------------------------------------------------------------------*/
-#define NIL 0
-#define isNull(c) ((c)==NIL)
-#define nonNull(c) (c)
-#define cons(x,xs) pair(x,xs)
+#define NIL 0
+#define isNull(c) ((c)==NIL)
+#define nonNull(c) (c)
+#define cons(x,xs) pair(x,xs)
#define singleton(x) cons(x,NIL)
#define doubleton(x,y) cons(x,cons(y,NIL))
#define tripleton(x,y,z) cons(x,cons(y,cons(z,NIL)))
-#define hd(c) fst(c)
-#define tl(c) snd(c)
-
-extern Int length Args((List));
-extern List appendOnto Args((List,List)); /* destructive */
-extern List dupOnto Args((List,List));
-extern List dupList Args((List));
-extern List revOnto Args((List, List)); /* destructive */
-#define rev(xs) revOnto((xs),NIL) /* destructive */
-#define reverse(xs) revOnto(dupList(xs),NIL) /* non-destructive */
-extern Cell cellIsMember Args((Cell,List));
-extern Cell cellAssoc Args((Cell,List));
-extern Cell cellRevAssoc Args((Cell,List));
-extern Bool eqList Args((List,List));
-extern Cell varIsMember Args((Text,List));
-extern Name nameIsMember Args((Text,List));
-extern Cell intIsMember Args((Int,List));
-extern List replicate Args((Int,Cell));
-extern List diffList Args((List,List)); /* destructive */
-extern List deleteCell Args((List,Cell)); /* non-destructive */
-extern List take Args((Int,List)); /* destructive */
-extern List splitAt Args((Int,List)); /* non-destructive */
-extern Cell nth Args((Int,List));
-extern List removeCell Args((Cell,List)); /* destructive */
-extern List dupListOnto Args((List,List)); /* non-destructive */
+#define hd(c) fst(c)
+#define tl(c) snd(c)
+
+extern Int length ( List );
+extern List appendOnto ( List,List ); /* destructive */
+extern List dupOnto ( List,List );
+extern List dupList ( List );
+extern List revOnto ( List, List ); /* destructive */
+#define rev(xs) revOnto((xs),NIL) /* destructive */
+#define reverse(xs) revOnto(dupList(xs),NIL) /* non-destructive */
+extern Cell cellIsMember ( Cell,List );
+extern Cell cellAssoc ( Cell,List );
+extern Cell cellRevAssoc ( Cell,List );
+extern Bool eqList ( List,List );
+extern Cell varIsMember ( Text,List );
+extern Name nameIsMember ( Text,List );
+extern QualId qualidIsMember ( QualId, List );
+extern Cell intIsMember ( Int,List );
+extern List replicate ( Int,Cell );
+extern List diffList ( List,List ); /* destructive */
+extern List deleteCell ( List,Cell ); /* non-destructive */
+extern List take ( Int,List ); /* destructive */
+extern List splitAt ( Int,List ); /* non-destructive */
+extern Cell nth ( Int,List );
+extern List removeCell ( Cell,List ); /* destructive */
+extern List dupListOnto ( List,List ); /* non-destructive */
+extern List nubList ( List ); /* non-destructive */
/* The following macros provide `inline expansion' of some common ways of
* traversing, using and modifying lists:
#define map2Accum(_f,_acc,_a,_b,_xs) mapBasic(_xs,_acc=_f(_acc,_a,_b,hd(Zs)))
#define map3Accum(_f,_acc,_a,_b,_c,_xs) mapBasic(_xs,_acc=_f(_acc,_a,_b,_c,hd(Zs)))
+
+/* --------------------------------------------------------------------------
+ * Strongly-typed lists (z-lists) and tuples (experimental)
+ * ------------------------------------------------------------------------*/
+
+typedef Cell ZPair;
+typedef Cell ZTriple;
+typedef Cell Z4Ble;
+typedef Cell Z5Ble;
+
+#define isZPair(c) (whatIs((c))==ZTUP2)
+
+extern Cell zpair ( Cell x1, Cell x2 );
+extern Cell zfst ( Cell zpair );
+extern Cell zsnd ( Cell zpair );
+
+extern Cell ztriple ( Cell x1, Cell x2, Cell x3 );
+extern Cell zfst3 ( Cell zpair );
+extern Cell zsnd3 ( Cell zpair );
+extern Cell zthd3 ( Cell zpair );
+
+extern Cell z4ble ( Cell x1, Cell x2, Cell x3, Cell x4 );
+extern Cell zsel14 ( Cell zpair );
+extern Cell zsel24 ( Cell zpair );
+extern Cell zsel34 ( Cell zpair );
+extern Cell zsel44 ( Cell zpair );
+
+extern Cell z5ble ( Cell x1, Cell x2, Cell x3, Cell x4, Cell x5 );
+extern Cell zsel15 ( Cell zpair );
+extern Cell zsel25 ( Cell zpair );
+extern Cell zsel35 ( Cell zpair );
+extern Cell zsel45 ( Cell zpair );
+extern Cell zsel55 ( Cell zpair );
+
+extern Cell unap ( int tag, Cell c );
+
+
/* --------------------------------------------------------------------------
* Implementation of function application nodes:
* ------------------------------------------------------------------------*/
#define fun(c) fst(c)
#define arg(c) snd(c)
#define isAp(c) (isPair(c) && !isTag(fst(c)))
-extern Cell getHead Args((Cell));
-extern List getArgs Args((Cell));
+
+extern Cell getHead ( Cell );
+extern List getArgs ( Cell );
+extern Cell nthArg ( Int,Cell );
+extern Int numArgs ( Cell );
+extern Cell applyToArgs ( Cell,List );
extern Int argCount;
-extern Cell nthArg Args((Int,Cell));
-extern Int numArgs Args((Cell));
-extern Cell applyToArgs Args((Cell,List));
/* --------------------------------------------------------------------------
* Stack implementation:
* For example, "push(1+pop());" doesn't increment TOS.
* ------------------------------------------------------------------------*/
-extern Cell DECTABLE(cellStack);
+extern Cell cellStack[];
extern StackPtr sp;
#define clearStack() sp=(-1)
#define stackEmpty() (sp==(-1))
#define stack(p) cellStack[p]
#define chkStack(n) if (sp>=NUM_STACK-(n)) hugsStackOverflow()
-#define push(c) \
- do { \
- chkStack(1); \
- onto(c); \
- } while (0)
-#define onto(c) stack(++sp)=(c)
+#define push(c) do { chkStack(1); onto(c); } while (0)
+#define onto(c) stack(++sp)=(c);
#define pop() stack(sp--)
#define drop() sp--
#define top() stack(sp)
#define pushed(n) stack(sp-(n))
#define topfun(f) top()=ap((f),top())
#define toparg(x) top()=ap(top(),(x))
+#define getsp() sp
-extern Void hugsStackOverflow Args((Void));
-
-/* --------------------------------------------------------------------------
- * Script file control:
- * The implementation of script file storage is hidden.
- * ------------------------------------------------------------------------*/
-
-extern Script startNewScript Args((String));
-extern Bool moduleThisScript Args((Module));
-extern Module moduleOfScript Args((Script));
-extern Bool isPreludeScript Args((Void));
-extern Module lastModule Args((Void));
-extern Script scriptThisFile Args((Text));
-extern Script scriptThisName Args((Name));
-extern Script scriptThisTycon Args((Tycon));
-extern Script scriptThisInst Args((Inst));
-extern Script scriptThisClass Args((Class));
-extern String fileOfModule Args((Module));
-extern Void dropScriptsFrom Args((Script));
-
-/* --------------------------------------------------------------------------
- * I/O Handles:
- * ------------------------------------------------------------------------*/
-
-#if IO_HANDLES
-#define HSTDIN 0 /* Numbers for standard handles */
-#define HSTDOUT 1
-#define HSTDERR 2
-
-struct strHandle { /* Handle description and status flags */
- Cell hcell; /* Heap representation of handle (or NIL) */
- FILE *hfp; /* Corresponding file pointer */
- Int hmode; /* Current mode: see below */
-};
+extern Void hugsStackOverflow ( Void );
-#define HCLOSED 0000 /* no I/O permitted */
-#define HSEMICLOSED 0001 /* semiclosed reads only */
-#define HREAD 0002 /* set to enable reads from handle */
-#define HWRITE 0004 /* set to enable writes to handle */
-#define HAPPEND 0010 /* opened in append mode */
-
-extern Cell openHandle Args((String,Int,Bool));
-extern struct strHandle DECTABLE(handles);
+#if SYMANTEC_C
+#include <Memory.h>
+#define STACK_HEADROOM 16384
+#define STACK_CHECK if (StackSpace() <= STACK_HEADROOM) \
+ internal("Macintosh function parameter stack overflow.");
+#else
+#define STACK_CHECK
#endif
/* --------------------------------------------------------------------------
- * Malloc Pointers
- * ------------------------------------------------------------------------*/
-
-#if GC_MALLOCPTRS
-struct strMallocPtr { /* Malloc Ptr description */
- Cell mpcell; /* Back pointer to MPCELL */
- Void *ptr; /* Pointer into C world */
- Int refCount; /* Reference count */
- Void (*cleanup) Args((Void *)); /* Code to free the C pointer */
-};
-
-extern struct strMallocPtr mallocPtrs[];
-extern Cell mkMallocPtr Args((Void *, Void (*)(Void *)));
-extern Void freeMallocPtr Args((Cell));
-extern Void incMallocPtrRefCnt Args((Int, Int));
-
-#define mpOf(c) snd(c)
-#define derefMP(c) (mallocPtrs[(Int)mpOf(c)].ptr)
-#endif /* GC_MALLOCPTRS */
-
-/* --------------------------------------------------------------------------
- * Weak Pointers
- * ------------------------------------------------------------------------*/
-
-#if GC_WEAKPTRS
-#define mkWeakPtr(c) pair(WEAKCELL,pair(c,NIL))
-#define derefWeakPtr(c) fst(snd(c))
-#define nextWeakPtr(c) snd(snd(c))
-
-extern List finalizers;
-extern List liveWeakPtrs;
-
-#endif /* GC_WEAKPTRS */
-
-/* --------------------------------------------------------------------------
- * Stable pointers
- * ------------------------------------------------------------------------*/
-
-#if GC_STABLEPTRS
-extern Int mkStablePtr Args((Cell));
-extern Cell derefStablePtr Args((Int));
-extern Void freeStablePtr Args((Int));
-#endif /* GC_STABLEPTRS */
-
-/* --------------------------------------------------------------------------
- * Plugins
- * ------------------------------------------------------------------------*/
-
-#if PLUGINS
-/* This is an exact copy of the declaration found in GreenCard.h */
-
-typedef int HugsStackPtr;
-typedef int HugsStablePtr;
-typedef Pointer HugsForeign;
-
-typedef struct {
-
- /* evaluate next argument */
- int (*getInt ) Args(());
- unsigned int (*getWord ) Args(());
- void* (*getAddr ) Args(());
- float (*getFloat ) Args(());
- double (*getDouble) Args(());
- char (*getChar ) Args(());
- HugsForeign (*getForeign) Args(());
- HugsStablePtr (*getStablePtr) Args(());
-
- /* push part of result */
- void (*putInt ) Args((int));
- void (*putWord ) Args((unsigned int));
- void (*putAddr ) Args((void*));
- void (*putFloat ) Args((double));
- void (*putDouble) Args((double));
- void (*putChar ) Args((char));
- void (*putForeign) Args((HugsForeign, void (*)(HugsForeign)));
- void (*putStablePtr) Args((HugsStablePtr));
-
- /* return n values in IO monad or Id monad */
- void (*returnIO) Args((HugsStackPtr, int));
- void (*returnId) Args((HugsStackPtr, int));
- int (*runIO) Args((int));
-
- /* free a stable pointer */
- void (*freeStablePtr) Args((HugsStablePtr));
-
- /* register the prim table */
- void (*registerPrims) Args((struct primInfo*));
-
- /* garbage collect */
- void (*garbageCollect) Args(());
-
-} HugsAPI2;
-
-extern HugsAPI2* hugsAPI2 Args((Void));
-typedef Void (*InitModuleFun2) Args((HugsAPI2*));
-
-typedef struct {
- Name nameTrue, nameFalse;
- Name nameNil, nameCons;
- Name nameJust, nameNothing;
- Name nameLeft, nameRight;
- Name nameUnit;
- Name nameIORun;
-
- Cell (*makeInt) Args((Int));
-
- Cell (*makeChar) Args((Char));
- Char (*CharOf) Args((Cell));
-
- Cell (*makeFloat) Args((FloatPro));
- Cell (*makeTuple) Args((Int));
- Pair (*pair) Args((Cell,Cell));
-
- Cell (*mkMallocPtr) Args((Void *, Void (*)(Void *)));
- Void *(*derefMallocPtr) Args((Cell));
-
- Int (*mkStablePtr) Args((Cell));
- Cell (*derefStablePtr) Args((Int));
- Void (*freeStablePtr) Args((Int));
-
- Void (*eval) Args((Cell));
- Cell (*evalWithNoError) Args((Cell));
- Void (*evalFails) Args((StackPtr));
- Int *whnfArgs;
- Cell *whnfHead;
- Int *whnfInt;
- Float *whnfFloat;
-
- Void (*garbageCollect) Args(());
- Void (*stackOverflow) Args(());
- Void (*internal) Args((String)) HUGS_noreturn;
-
- Void (*registerPrims) Args((struct primInfo*));
- Name (*addPrimCfun) Args((Text,Int,Int,Cell));
- Text (*inventText) Args(());
-
- Cell *(*Fst) Args((Cell));
- Cell *(*Snd) Args((Cell));
-
- Cell *cellStack;
- StackPtr *sp;
-} HugsAPI1;
-
-extern HugsAPI1* hugsAPI1 Args((Void));
-typedef Void (*InitModuleFun1) Args((HugsAPI1*));
-#endif /* PLUGINS */
-
-
-/* --------------------------------------------------------------------------
* Misc:
* ------------------------------------------------------------------------*/
-extern Void setLastExpr Args((Cell));
-extern Cell getLastExpr Args((Void));
-extern List addTyconsMatching Args((String,List));
-extern List addNamesMatching Args((String,List));
+extern Void setLastExpr ( Cell );
+extern Cell getLastExpr ( Void );
+extern List addTyconsMatching ( String,List );
+extern List addNamesMatching ( String,List );
+
+extern Tycon findTyconInAnyModule ( Text t );
+extern Class findClassInAnyModule ( Text t );
+extern Name findNameInAnyModule ( Text t );
+
+extern Void print ( Cell, Int );
+extern void dumpTycon ( Int t );
+extern void dumpName ( Int n );
+extern void dumpClass ( Int c );
+extern void dumpInst ( Int i );
+extern void locateSymbolByName ( Text t );
/*-------------------------------------------------------------------------*/