2 /* --------------------------------------------------------------------------
3 * Defines storage datatypes: Text, Name, Module, Tycon, Cell, List, Pair,
6 * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
7 * Yale Haskell Group, and the Oregon Graduate Institute of Science and
8 * Technology, 1994-1999, All rights reserved. It is distributed as
9 * free software under the license in the file "License", which is
10 * included in the distribution.
12 * $RCSfile: storage.h,v $
14 * $Date: 1999/12/10 15:59:54 $
15 * ------------------------------------------------------------------------*/
17 /* --------------------------------------------------------------------------
18 * Typedefs for main data types:
19 * Many of these type names are used to indicate the intended us of a data
20 * item, rather than for type checking purposes. Sadly (although sometimes,
21 * fortunately), the C compiler cannot distinguish between the use of two
22 * different names defined to be synonyms for the same types.
23 * ------------------------------------------------------------------------*/
25 typedef Int Text; /* text string */
26 typedef Unsigned Syntax; /* syntax (assoc,preced) */
27 typedef Int Cell; /* general cell value */
28 typedef Cell far *Heap; /* storage of heap */
29 typedef Cell Pair; /* pair cell */
30 typedef Int StackPtr; /* stack pointer */
31 typedef Cell Offset; /* offset/generic variable*/
32 typedef Int Script; /* script file number */
33 typedef Int Module; /* module */
34 typedef Cell Tycon; /* type constructor */
35 typedef Cell Type; /* type expression */
36 typedef Cell Kind; /* kind expression */
37 typedef Cell Kinds; /* list of kinds */
38 typedef Cell Constr; /* constructor expression */
39 typedef Cell Name; /* named value */
40 typedef Cell Class; /* type class */
41 typedef Cell Inst; /* instance of type class */
42 typedef Cell Triple; /* triple of cell values */
43 typedef Cell List; /* list of cells */
44 typedef Cell Bignum; /* bignum integer */
45 typedef Cell Float; /* floating pt literal */
47 typedef Cell Ext; /* extension label */
53 /* --------------------------------------------------------------------------
55 * provides storage for the characters making up identifier and symbol
56 * names, string literals, character constants etc...
57 * ------------------------------------------------------------------------*/
59 extern String textToStr Args((Text));
60 extern Text findText Args((String));
61 extern Text inventText Args((Void));
62 extern Text inventDictText Args((Void));
63 extern Bool inventedText Args((Text));
64 extern Text enZcodeThenFindText Args((String));
65 extern Text unZcodeThenFindText Args((String));
67 /* Variants of textToStr and syntaxOf which work for idents, ops whether
68 * qualified or unqualified.
70 extern String identToStr Args((Cell));
71 extern Text fixLitText Args((Text));
72 extern Syntax identSyntax Args((Cell));
73 extern Syntax defaultSyntax Args((Text));
75 /* --------------------------------------------------------------------------
76 * Specification of syntax (i.e. default written form of application)
77 * ------------------------------------------------------------------------*/
79 #define MIN_PREC 0 /* weakest binding operator */
80 #define MAX_PREC 9 /* strongest binding operator */
81 #define FUN_PREC (MAX_PREC+2) /* binding of function symbols */
82 #define DEF_PREC MAX_PREC
83 #define APPLIC 0 /* written applicatively */
84 #define LEFT_ASS 1 /* left associative infix */
85 #define RIGHT_ASS 2 /* right associative infix */
86 #define NON_ASS 3 /* non associative infix */
87 #define DEF_ASS LEFT_ASS
89 #define UMINUS_PREC 6 /* Change these settings at your */
90 #define UMINUS_ASSOC LEFT_ASS /* own risk; they may not work! */
92 #define assocOf(x) ((x)&NON_ASS)
93 #define precOf(x) ((x)>>2)
94 #define mkSyntax(a,p) ((a)|((p)<<2))
95 #define DEF_OPSYNTAX mkSyntax(DEF_ASS,DEF_PREC)
96 #define NO_SYNTAX (-1)
98 extern Void addSyntax Args((Int,Text,Syntax));
99 extern Syntax syntaxOf Args((Text));
101 /* --------------------------------------------------------------------------
103 * Provides a garbage collectable heap for storage of expressions etc.
104 * ------------------------------------------------------------------------*/
106 #define heapAlloc(s) (Heap)(farCalloc(s,sizeof(Cell)))
107 #define heapBuilt() (heapFst)
109 extern Heap heapFst, heapSnd;
110 extern Heap heapTopFst;
111 extern Heap heapTopSnd;
112 extern Bool consGC; /* Set to FALSE to turn off gc from*/
113 /* C stack; use with extreme care! */
114 extern Int cellsRecovered; /* cells recovered by last gc */
116 #define fst(c) heapTopFst[c]
117 #define snd(c) heapTopSnd[c]
119 extern Pair pair Args((Cell,Cell));
120 extern Void garbageCollect Args((Void));
122 extern Void overwrite Args((Pair,Pair));
123 extern Void overwrite2 Args((Pair,Cell,Cell));
124 extern Cell markExpr Args((Cell));
125 extern Void markWithoutMove Args((Cell));
127 #define mark(v) v=markExpr(v)
129 #define isPair(c) ((c)<0)
130 #define isGenPair(c) ((c)<0 && -heapSize<=(c))
132 extern Cell whatIs Args((Cell));
134 /* --------------------------------------------------------------------------
135 * Box cell tags are used as the fst element of a pair to indicate that
136 * the snd element of the pair is to be treated in some special way, other
137 * than as a Cell. Examples include holding integer values, variable name
138 * and string text etc.
139 * ------------------------------------------------------------------------*/
141 #define TAGMIN 1 /* Box and constructor cell tag values */
142 #define BCSTAG 30 /* Box=TAGMIN..BCSTAG-1 */
143 #define isTag(c) (TAGMIN<=(c) && (c)<SPECMIN) /* Tag cell values */
144 #define isBoxTag(c) (TAGMIN<=(c) && (c)<BCSTAG) /* Box cell tag values */
145 #define isConTag(c) (BCSTAG<=(c) && (c)<SPECMIN) /* Constr cell tag values*/
147 #define FREECELL 3 /* Free list cell: snd :: Cell */
148 #define VARIDCELL 4 /* Identifier variable: snd :: Text */
149 #define VAROPCELL 5 /* Operator variable: snd :: Text */
150 #define DICTVAR 6 /* Dictionary variable: snd :: Text */
151 #define CONIDCELL 7 /* Identifier constructor: snd :: Text */
152 #define CONOPCELL 8 /* Operator constructor: snd :: Text */
153 #define STRCELL 9 /* String literal: snd :: Text */
154 #define INTCELL 10 /* Int literal: snd :: Int */
155 #define ADDPAT 11 /* (_+k) pattern discr: snd :: Int */
156 #define FLOATCELL 15 /* Floating Pt literal: snd :: Text */
157 #define BIGCELL 16 /* Integer literal: snd :: Text */
159 #define PTRCELL 17 /* C Heap Pointer snd :: Ptr */
161 #define IPCELL 19 /* Imp Param Cell: snd :: Text */
162 #define IPVAR 20 /* ?x: snd :: Text */
164 #define CPTRCELL 21 /* Native code pointer snd :: Ptr */
167 #define EXTCOPY 22 /* Copy of an Ext: snd :: Text */
170 #define qmodOf(c) (textOf(fst(snd(c)))) /* c :: QUALIDENT */
171 #define qtextOf(c) (textOf(snd(snd(c)))) /* c :: QUALIDENT */
172 #define mkVar(t) ap(VARIDCELL,t)
173 #define mkVarop(t) ap(VAROPCELL,t)
174 #define mkCon(t) ap(CONIDCELL,t)
175 #define mkConop(t) ap(CONOPCELL,t)
176 #define mkQVar(m,t) ap(QUALIDENT,pair(mkCon(m),mkVar(t)))
177 #define mkQCon(m,t) ap(QUALIDENT,pair(mkCon(m),mkCon(t)))
178 #define mkQVarOp(m,t) ap(QUALIDENT,pair(mkCon(m),mkVarop(t)))
179 #define mkQConOp(m,t) ap(QUALIDENT,pair(mkCon(m),mkConop(t)))
180 #define intValOf(c) (snd(c))
181 #define inventVar() mkVar(inventText())
182 #define mkDictVar(t) ap(DICTVAR,t)
183 #define inventDictVar() mkDictVar(inventDictText())
184 #define mkStr(t) ap(STRCELL,t)
186 #define mkIParam(c) ap(IPCELL,snd(c))
187 #define isIP(p) (whatIs(p) == IPCELL)
188 #define ipMatch(pi, t) (isIP(fun(pi)) && textOf(fun(pi)) == t)
189 #define ipVar(pi) textOf(fun(pi))
191 #define isIP(p) FALSE
194 extern Bool isVar Args((Cell));
195 extern Bool isCon Args((Cell));
196 extern Bool isQVar Args((Cell));
197 extern Bool isQCon Args((Cell));
198 extern Bool isQualIdent Args((Cell));
199 extern Bool isIdent Args((Cell));
200 extern String stringNegate Args((String));
201 extern Text textOf Args((Cell));
203 #define isFloat(c) (isPair(c) && fst(c)==FLOATCELL)
204 #define stringToFloat(s) pair(FLOATCELL,findText(s))
205 #define floatToString(f) textToStr(snd(f))
206 #define floatOf(f) atof(floatToString(f))
207 #define mkFloat(f) (f) /* ToDo: is this right? */
208 #define floatNegate(f) stringToFloat(stringNegate(floatToString(f)))
210 #define stringToBignum(s) pair(BIGCELL,findText(s))
211 #define bignumToString(b) textToStr(snd(b))
214 #define isPtr(c) (isPair(c) && fst(c)==PTRCELL)
215 extern Cell mkPtr Args((Ptr));
216 extern Ptr ptrOf Args((Cell));
217 #define isCPtr(c) (isPair(c) && fst(c)==CPTRCELL)
218 extern Cell mkCPtr Args((Ptr));
219 extern Ptr cptrOf Args((Cell));
222 /* --------------------------------------------------------------------------
223 * Constructor cell tags are used as the fst element of a pair to indicate
224 * a particular syntactic construct described by the snd element of the
226 * Note that a cell c will not be treated as an application (AP/isAp) node
227 * if its first element is a constructor cell tag, whereas a cell whose fst
228 * element is a special cell will be treated as an application node.
229 * ------------------------------------------------------------------------*/
231 #define LETREC 30 /* LETREC snd :: ([Decl],Exp) */
232 #define COND 31 /* COND snd :: (Exp,Exp,Exp) */
233 #define LAMBDA 32 /* LAMBDA snd :: Alt */
234 #define FINLIST 33 /* FINLIST snd :: [Exp] */
235 #define DOCOMP 34 /* DOCOMP snd :: (Exp,[Qual]) */
236 #define BANG 35 /* BANG snd :: Type */
237 #define COMP 36 /* COMP snd :: (Exp,[Qual]) */
238 #define ASPAT 37 /* ASPAT snd :: (Var,Exp) */
239 #define ESIGN 38 /* ESIGN snd :: (Exp,Type) */
240 #define RSIGN 39 /* RSIGN snd :: (Rhs,Type) */
241 #define CASE 40 /* CASE snd :: (Exp,[Alt]) */
242 #define NUMCASE 41 /* NUMCASE snd :: (Exp,Disc,Rhs) */
243 #define FATBAR 42 /* FATBAR snd :: (Exp,Exp) */
244 #define LAZYPAT 43 /* LAZYPAT snd :: Exp */
245 #define DERIVE 45 /* DERIVE snd :: Cell */
247 #define FLOATCELL 46 /* FLOATCELL snd :: (Int,Int) */
250 #define BOOLQUAL 49 /* BOOLQUAL snd :: Exp */
251 #define QWHERE 50 /* QWHERE snd :: [Decl] */
252 #define FROMQUAL 51 /* FROMQUAL snd :: (Exp,Exp) */
253 #define DOQUAL 52 /* DOQUAL snd :: Exp */
254 #define MONADCOMP 53 /* MONADCOMP snd :: ((m,m0),(Exp,[Qual])*/
256 #define GUARDED 54 /* GUARDED snd :: [guarded exprs] */
258 #define ARRAY 55 /* Array snd :: (Bounds,[Values]) */
259 #define MUTVAR 56 /* Mutvar snd :: Cell */
261 #define HUGSOBJECT 57 /* HUGSOBJECT snd :: Cell */
265 #define WITHEXP 58 /* WITHEXP snd :: [(Var,Exp)] */
269 #define POLYTYPE 60 /* POLYTYPE snd :: (Kind,Type) */
270 #define QUAL 61 /* QUAL snd :: ([Classes],Type) */
271 #define RANK2 62 /* RANK2 snd :: (Int,Type) */
272 #define EXIST 63 /* EXIST snd :: (Int,Type) */
273 #define POLYREC 64 /* POLYREC snd :: (Int,Type) */
274 #define BIGLAM 65 /* BIGLAM snd :: (vars,patterns) */
275 #define CDICTS 66 /* CDICTS snd :: ([Pred],Type) */
277 #define LABC 67 /* LABC snd :: (con,[(Vars,Type)]) */
278 #define CONFLDS 68 /* CONFLDS snd :: (con,[Field]) */
279 #define UPDFLDS 69 /* UPDFLDS snd :: (Exp,[con],[Field]) */
281 #define RECORD 70 /* RECORD snd :: [Val] */
282 #define EXTCASE 71 /* EXTCASE snd :: (Exp,Disc,Rhs) */
283 #define RECSEL 72 /* RECSEL snd :: Ext */
285 #define IMPDEPS 73 /* IMPDEPS snd :: [Binding] */
287 #define QUALIDENT 74 /* Qualified identifier snd :: (Id,Id) */
288 #define HIDDEN 75 /* hiding import list snd :: [Entity] */
289 #define MODULEENT 76 /* module in export list snd :: con */
291 #define INFIX 77 /* INFIX snd :: (see tidyInfix) */
292 #define ONLY 78 /* ONLY snd :: Exp */
293 #define NEG 79 /* NEG snd :: Exp */
295 /* Used when parsing GHC interface files */
296 #define DICTAP 80 /* DICTAP snd :: (QClassId,[Type]) */
297 #define UNBOXEDTUP 81 /* UNBOXEDTUP snd :: [Type] */
299 #if SIZEOF_INTP != SIZEOF_INT
300 #define PTRCELL 82 /* C Heap Pointer snd :: (Int,Int) */
304 #define STGVAR 92 /* STGVAR snd :: (StgRhs,info) */
305 #define STGAPP 93 /* STGAPP snd :: (StgVar,[Arg]) */
306 #define STGPRIM 94 /* STGPRIM snd :: (PrimOp,[Arg]) */
307 #define STGCON 95 /* STGCON snd :: (StgCon,[Arg]) */
308 #define PRIMCASE 96 /* PRIMCASE snd :: (Expr,[PrimAlt]) */
309 #define DEEFALT 97 /* DEEFALT snd :: (Var,Expr) */
310 #define CASEALT 98 /* CASEALT snd :: (Con,[Var],Expr) */
311 #define PRIMALT 99 /* PRIMALT snd :: ([Var],Expr) */
315 Top-level interface entities
316 type Line = Int -- a line number
317 type ConVarId = CONIDCELL | VARIDCELL
319 type ExportListEntry = ConVarId | (ConId, <ConVarId>)
320 type Associativity = mkInt of LEFT_ASS | RIGHT_ASS | NON_ASS
321 type Constr = (ConId, <(Type,VarId,Int)>)
322 (constr name, list of (type, field name if any, strictness))
323 strictness: 0 => none, 1 => !, 2 => !! (unpacked)
324 All 2/3/4/5 tuples in the interface abstract syntax are done with
328 #define I_INTERFACE 109 /* snd :: (ConId, <I_IMPORT..I_VALUE>)
329 interface name, list of iface entities */
331 #define I_IMPORT 110 /* snd :: (ConId, <ConVarId>)
332 module name, list of entities */
334 #define I_INSTIMPORT 111 /* snd :: NIL -- not used at present */
336 #define I_EXPORT 112 /* snd :: (ConId, <ExportListEntry>
337 this module name?, entities to export */
339 #define I_FIXDECL 113 /* snd :: (NIL|Int, Associativity, ConVarId)
340 fixity, associativity, name */
342 #define I_INSTANCE 114 /* snd :: (Line, <(QConId,VarId)>, Type, VarId)
344 forall-y bit (eg __forall [a b] {M.C1 a, M.C2 b} =>),
345 other bit, eg { C a1 } -> { C2 a2 } -> ... -> { Cn an },
346 name of dictionary builder */
348 #define I_TYPE 115 /* snd :: (Line, ConId, <(VarId,Kind)>, Type)
349 lineno, tycon, kinded tyvars, the type expr */
351 #define I_DATA 116 /* snd :: (Line, <(QConId,VarId)>, ConId,
352 <(VarId,Kind)>, <Constr>)
353 lineno, context, tycon, kinded tyvars, constrs */
355 #define I_NEWTYPE 117 /* snd :: (Line, <(QConId,VarId)>, ConId,
356 <(VarId,Kind)>, (ConId,Type))
357 lineno, context, tycon, kinded tyvars, constr */
359 #define I_CLASS 118 /* snd :: (Line, <(QConId,VarId)>, ConId,
360 <(VarId,Kind)>, <(VarId,Type)>)
361 lineno, context, classname,
362 kinded tyvars, method sigs */
364 #define I_VALUE 119 /* snd :: (Line, VarId, Type) */
370 #define ZCONS 190 /* snd :: (Cell,Cell) */
374 #define ZTUP2 192 /* snd :: (Cell,Cell) */
375 #define ZTUP3 193 /* snd :: (Cell,(Cell,Cell)) */
376 #define ZTUP4 194 /* snd :: (Cell,(Cell,(Cell,Cell))) */
377 #define ZTUP5 195 /* snd :: (Cell,(Cell,(Cell,(Cell,Cell)))) */
379 /* Last constructor tag must be less than SPECMIN */
381 /* --------------------------------------------------------------------------
382 * Special cell values:
383 * ------------------------------------------------------------------------*/
388 #define isSpec(c) (SPECMIN<=(c) && (c)<EXTMIN)/* Special cell values */
390 #define isSpec(c) (SPECMIN<=(c) && (c)<OFFMIN)
393 #define NONE 201 /* Dummy stub */
394 #define STAR 202 /* Representing the kind of types */
396 #define ROW 203 /* Representing the kind of rows */
398 #define WILDCARD 204 /* Wildcard pattern */
399 #define SKOLEM 205 /* Skolem constant */
401 #define DOTDOT 206 /* ".." in import/export list */
403 #define NAME 210 /* whatIs code for isName */
404 #define TYCON 211 /* whatIs code for isTycon */
405 #define CLASS 212 /* whatIs code for isClass */
406 #define MODULE 213 /* whatIs code for isModule */
407 #define INSTANCE 214 /* whatIs code for isInst */
408 #define TUPLE 215 /* whatIs code for tuple constructor */
409 #define OFFSET 216 /* whatis code for offset */
410 #define AP 217 /* whatIs code for application node */
411 #define CHARCELL 218 /* whatIs code for isChar */
413 #define EXT 219 /* whatIs code for isExt */
416 #define SIGDECL 220 /* Signature declaration */
417 #define FIXDECL 221 /* Fixity declaration */
418 #define FUNBIND 222 /* Function binding */
419 #define PATBIND 223 /* Pattern binding */
421 #define DATATYPE 230 /* Datatype type constructor */
422 #define NEWTYPE 231 /* Newtype type constructor */
423 #define SYNONYM 232 /* Synonym type constructor */
424 #define RESTRICTSYN 233 /* Synonym with restricted scope */
426 #define NODEPENDS 235 /* Stop calculation of deps in type check*/
427 #define PREDEFINED 236 /* Predefined name, not yet filled */
429 /* --------------------------------------------------------------------------
430 * Tuple data/type constructors:
431 * ------------------------------------------------------------------------*/
433 extern Text ghcTupleText Args((Tycon));
434 extern Text ghcTupleText_n Args((Int));
440 #define isExt(c) (EXTMIN<=(c) && (c)<OFFMIN)
441 #define extText(e) tabExt[(e)-EXTMIN]
442 #define extField(c) arg(fun(c))
443 #define extRow(c) arg(c)
445 extern Text DECTABLE(tabExt);
446 extern Ext mkExt Args((Text));
451 /* --------------------------------------------------------------------------
452 * Offsets: (generic types/stack offsets)
453 * ------------------------------------------------------------------------*/
456 #define OFFMIN (EXTMIN+NUM_EXT)
460 #define isOffset(c) (OFFMIN<=(c) && (c)<MODMIN)
461 #define offsetOf(c) ((c)-OFFMIN)
462 #define mkOffset(o) (OFFMIN+(o))
464 /* --------------------------------------------------------------------------
466 * ------------------------------------------------------------------------*/
468 /* An entry in a very crude object symbol table */
469 typedef struct { char* nm; void* ad; }
472 /* Indication of section kinds for loaded objects. Needed by
473 the GC for deciding whether or not a pointer on the stack
476 typedef enum { HUGS_DL_SECTION_CODE_OR_RODATA,
477 HUGS_DL_SECTION_RWDATA,
478 HUGS_DL_SECTION_OTHER }
481 typedef struct { void* start; void* end; DLSect sect; }
484 /* --------------------------------------------------------------------------
486 * ------------------------------------------------------------------------*/
488 #define MODMIN (OFFMIN+NUM_OFFSETS)
490 #define isModule(c) (MODMIN<=(c) && (c)<TYCMIN)
491 #define mkModule(n) (MODMIN+(n))
492 #define module(n) tabModule[(n)-MODMIN]
494 /* Under Haskell 1.3, the list of qualified imports is always a subset
495 * of the list of unqualified imports. For simplicity and flexibility,
496 * we do not attempt to exploit this fact - when a module is imported
497 * unqualified, it is added to both the qualified and unqualified
499 * Similarily, Haskell 1.3 does not allow a constructor to be imported
500 * or exported without exporting the type it belongs to but the export
501 * list is just a flat list of Texts (before static analysis) or
502 * Tycons, Names and Classes (after static analysis).
506 /* Lists of top level objects (local defns + imports) */
510 List exports; /* [ Entity | (Entity, NIL|DOTDOT) ] */
511 /* List of qualified imports. Used both during compilation and when
512 * evaluating an expression in the context of the current module.
516 /* ptr to malloc'd lump of memory holding the obj file */
519 /* ptr to object symbol table; lives in mallocville.
520 Dynamically expands. */
525 /* The section-kind entries for this object module. Dynamically expands. */
531 extern Module currentModule; /* Module currently being processed */
532 extern struct Module DECTABLE(tabModule);
534 extern Bool isValidModule Args((Module));
535 extern Module newModule Args((Text));
536 extern Module findModule Args((Text));
537 extern Module findModid Args((Cell));
538 extern Void setCurrModule Args((Module));
540 extern void addOTabName Args((Module,char*,void*));
541 extern void* lookupOTabName Args((Module,char*));
542 extern char* nameFromOPtr Args((void*));
544 extern void addDLSect Args((Module,void*,void*,DLSect));
545 extern DLSect lookupDLSect Args((void*));
548 #define isPrelude(m) (m==modulePrelude)
550 /* --------------------------------------------------------------------------
551 * Type constructor names:
552 * ------------------------------------------------------------------------*/
554 #define TYCMIN (MODMIN+NUM_MODULE)
555 #define isTycon(c) (TYCMIN<=(c) && (c)<NAMEMIN && tabTycon[(c)-TYCMIN].tuple==-1)
556 #define tycon(n) tabTycon[(n)-TYCMIN]
558 #define isTuple(c) (TYCMIN<=(c) && (c)<NAMEMIN && tabTycon[(c)-TYCMIN].tuple>=0)
559 #define tupleOf(n) (tabTycon[(n)-TYCMIN].tuple)
560 extern Tycon mkTuple ( Int );
561 extern Void allocTupleTycon ( Int );
567 Module mod; /* module that defines it */
568 Int tuple; /* tuple number, or -1 if not tuple */
570 Kind kind; /* kind (includes arity) of Tycon */
571 Cell what; /* DATATYPE/SYNONYM/RESTRICTSYN... */
573 Name conToTag; /* used in derived code */
575 void* itbl; /* For tuples, the info tbl pointer */
579 extern struct strTycon DECTABLE(tabTycon);
581 extern Tycon newTycon Args((Text));
582 extern Tycon findTycon Args((Text));
583 extern Tycon addTycon Args((Tycon));
584 extern Tycon findQualTycon Args((Cell));
585 extern Tycon addPrimTycon Args((Text,Kind,Int,Cell,Cell));
587 #define isSynonym(h) (isTycon(h) && tycon(h).what==SYNONYM)
588 #define isQualType(t) (isPair(t) && fst(t)==QUAL)
589 #define mkPolyType(n,t) pair(POLYTYPE,pair(n,t))
590 #define isPolyType(t) (isPair(t) && fst(t)==POLYTYPE)
591 #define isPolyOrQualType(t) (isPair(t) && (fst(t)==POLYTYPE || fst(t)==QUAL))
592 #define polySigOf(t) fst(snd(t))
593 #define monotypeOf(t) snd(snd(t))
595 #define bang(t) ap(BANG,t)
597 /* --------------------------------------------------------------------------
598 * Globally defined name values:
599 * ------------------------------------------------------------------------*/
601 #define NAMEMIN (TYCMIN+NUM_TYCON)
602 #define isName(c) (NAMEMIN<=(c) && (c)<INSTMIN)
603 #define mkName(n) (NAMEMIN+(n))
604 #define name(n) tabName[(n)-NAMEMIN]
609 Module mod; /* module that defines it */
616 Cell stgVar; /* really StgVar */
617 Text callconv; /* for foreign import/export */
618 void* primop; /* really StgPrim* */
619 void* itbl; /* For constructors, the info tbl pointer */
623 extern int numNames Args(( Void ));
625 extern struct strName DECTABLE(tabName);
627 /* The number field in a name is used to distinguish various kinds of name:
628 * mfunNo(i) = code for member function, offset i
629 * members that are sole elements of dict use mfunNo(0)
630 * members of dicts with more than one elem use mfunNo(n), n>=1
631 * EXECNAME = code for executable name (bytecodes or primitive)
632 * SELNAME = code for selector function
633 * DFUNNAME = code for dictionary builder or selector
634 * cfunNo(i) = code for data constructor
635 * datatypes with only one constructor uses cfunNo(0)
636 * datatypes with multiple constructors use cfunNo(n), n>=1
644 #define isSfun(n) (name(n).number==SELNAME)
645 #define isDfun(n) (name(n).number==DFUNNAME)
647 #define isCfun(n) (name(n).number>=CFUNNAME)
648 #define cfunOf(n) (name(n).number-CFUNNAME)
649 #define cfunNo(i) ((i)+CFUNNAME)
650 #define hasCfun(cs) (nonNull(cs) && isCfun(hd(cs)))
652 #define isMfun(n) (name(n).number<0)
653 #define mfunOf(n) ((-1)-name(n).number)
654 #define mfunNo(i) ((-1)-(i))
656 extern Name newName Args((Text,Cell));
657 extern Name findName Args((Text));
658 extern Name addName Args((Name));
659 extern Name findQualName Args((Cell));
660 extern Name addPrimCfun Args((Text,Int,Int,Cell));
661 extern Name addPrimCfunREP Args((Text,Int,Int,Int));
662 extern Int sfunPos Args((Name,Name));
663 extern Name nameFromStgVar Args((Cell));
664 extern Name jrsFindQualName Args((Text,Text));
666 /* --------------------------------------------------------------------------
668 * ------------------------------------------------------------------------*/
670 #define INSTMIN (NAMEMIN+NUM_NAME) /* instances */
671 #define isInst(c) (INSTMIN<=(c) && (c)<CLASSMIN)
672 #define mkInst(n) (INSTMIN+(n))
673 #define instOf(c) ((Int)((c)-INSTMIN))
674 #define inst(in) tabInst[(in)-INSTMIN]
677 Class c; /* class C */
679 Module mod; /* module that defines it */
680 Kinds kinds; /* Kinds of variables in head */
681 Cell head; /* :: Pred */
682 List specifics; /* :: [Pred] */
683 Int numSpecifics; /* length(specifics) */
685 Name builder; /* Dictionary constructor function */
688 /* a predicate (an element :: Pred) is an application of a Class to one or
689 * more type expressions
692 #define CLASSMIN (INSTMIN+NUM_INSTS)
693 #define isClass(c) (CLASSMIN<=(c) && (c)<CHARMIN)
694 #define mkClass(n) (CLASSMIN+(n))
695 #define cclass(n) tabClass[(n)-CLASSMIN]
698 Text text; /* Name of class */
699 Int line; /* Line where declaration begins */
700 Module mod; /* module that declares it */
701 Int level; /* Level in class hierarchy */
702 Int arity; /* Number of arguments */
703 Kinds kinds; /* Kinds of constructors in class */
704 List fds; /* Functional Dependencies */
705 List xfds; /* Xpanded Functional Dependencies */
706 Cell head; /* Head of class */
707 Name dcon; /* Dictionary constructor function */
708 List supers; /* :: [Pred] */
709 Int numSupers; /* length(supers) */
710 List dsels; /* Superclass dictionary selectors */
711 List members; /* :: [Name] */
712 Int numMembers; /* length(members) */
713 List defaults; /* :: [Name] */
714 List instances; /* :: [Inst] */
717 extern struct strClass DECTABLE(tabClass);
718 extern struct strInst far *tabInst;
720 extern Class newClass Args((Text));
721 extern Class classMax Args((Void));
722 extern Class findClass Args((Text));
723 extern Class addClass Args((Class));
724 extern Class findQualClass Args((Cell));
725 extern Inst newInst Args((Void));
726 extern Inst findFirstInst Args((Tycon));
727 extern Inst findNextInst Args((Tycon,Inst));
728 extern Inst findSimpleInstance ( ConId klass, ConId dataty );
730 /* --------------------------------------------------------------------------
732 * ------------------------------------------------------------------------*/
734 #define CHARMIN (CLASSMIN+NUM_CLASSES)
735 #define MAXCHARVAL (NUM_CHARS-1)
736 #define isChar(c) (CHARMIN<=(c) && (c)<INTMIN)
737 #define charOf(c) ((Char)(c-CHARMIN))
738 #define mkChar(c) ((Cell)(CHARMIN+(((unsigned)(c))%NUM_CHARS)))
740 /* --------------------------------------------------------------------------
741 * Small Integer values:
742 * ------------------------------------------------------------------------*/
744 #define INTMIN (CHARMIN+NUM_CHARS)
745 #define INTMAX (MAXPOSINT)
746 #define isSmall(c) (INTMIN<=(c))
747 #define INTZERO (INTMIN/2 + INTMAX/2)
748 #define MINSMALLINT (INTMIN - INTZERO)
749 #define MAXSMALLINT (INTMAX - INTZERO)
750 #define mkDigit(c) ((Cell)((c)+INTMIN))
751 #define digitOf(c) ((Int)((c)-INTMIN))
753 extern Bool isInt Args((Cell));
754 extern Int intOf Args((Cell));
755 extern Cell mkInt Args((Int));
757 /* --------------------------------------------------------------------------
758 * Implementation of triples:
759 * ------------------------------------------------------------------------*/
761 #define triple(x,y,z) pair(x,pair(y,z))
762 #define fst3(c) fst(c)
763 #define snd3(c) fst(snd(c))
764 #define thd3(c) snd(snd(c))
766 /* --------------------------------------------------------------------------
767 * Implementation of lists:
768 * ------------------------------------------------------------------------*/
771 #define isNull(c) ((c)==NIL)
772 #define nonNull(c) (c)
773 #define cons(x,xs) pair(x,xs)
774 #define singleton(x) cons(x,NIL)
775 #define doubleton(x,y) cons(x,cons(y,NIL))
776 #define tripleton(x,y,z) cons(x,cons(y,cons(z,NIL)))
780 extern Int length Args((List));
781 extern List appendOnto Args((List,List)); /* destructive */
782 extern List dupOnto Args((List,List));
783 extern List dupList Args((List));
784 extern List revOnto Args((List, List)); /* destructive */
785 #define rev(xs) revOnto((xs),NIL) /* destructive */
786 #define reverse(xs) revOnto(dupList(xs),NIL) /* non-destructive */
787 extern Cell cellIsMember Args((Cell,List));
788 extern Cell cellAssoc Args((Cell,List));
789 extern Cell cellRevAssoc Args((Cell,List));
790 extern Bool eqList Args((List,List));
791 extern Cell varIsMember Args((Text,List));
792 extern Name nameIsMember Args((Text,List));
793 extern Cell intIsMember Args((Int,List));
794 extern List replicate Args((Int,Cell));
795 extern List diffList Args((List,List)); /* destructive */
796 extern List deleteCell Args((List,Cell)); /* non-destructive */
797 extern List take Args((Int,List)); /* destructive */
798 extern List splitAt Args((Int,List)); /* non-destructive */
799 extern Cell nth Args((Int,List));
800 extern List removeCell Args((Cell,List)); /* destructive */
801 extern List dupListOnto Args((List,List)); /* non-destructive */
802 extern List nubList Args((List)); /* non-destructive */
804 /* The following macros provide `inline expansion' of some common ways of
805 * traversing, using and modifying lists:
807 * N.B. We use the names _f, _a, _xs, Zs, in an attempt to avoid clashes
808 * with identifiers used elsewhere.
811 #define mapBasic(_init,_step) {List Zs=(_init);\
812 for(;nonNull(Zs);Zs=tl(Zs)) \
814 #define mapModify(_init,_step) mapBasic(_init,hd(Zs)=_step)
816 #define mapProc(_f,_xs) mapBasic(_xs,_f(hd(Zs)))
817 #define map1Proc(_f,_a,_xs) mapBasic(_xs,_f(_a,hd(Zs)))
818 #define map2Proc(_f,_a,_b,_xs) mapBasic(_xs,_f(_a,_b,hd(Zs)))
819 #define map3Proc(_f,_a,_b,_c,_xs) mapBasic(_xs,_f(_a,_b,_c,hd(Zs)))
820 #define map4Proc(_f,_a,_b,_c,_d,_xs) mapBasic(_xs,_f(_a,_b,_c,_d,hd(Zs)))
822 #define mapOver(_f,_xs) mapModify(_xs,_f(hd(Zs)))
823 #define map1Over(_f,_a,_xs) mapModify(_xs,_f(_a,hd(Zs)))
824 #define map2Over(_f,_a,_b,_xs) mapModify(_xs,_f(_a,_b,hd(Zs)))
825 #define map3Over(_f,_a,_b,_c,_xs) mapModify(_xs,_f(_a,_b,_c,hd(Zs)))
826 #define map4Over(_f,_a,_b,_c,_d,_xs) mapModify(_xs,_f(_a,_b,_c,_d,hd(Zs)))
828 /* This is just what you want for functions with accumulating parameters */
829 #define mapAccum(_f,_acc,_xs) mapBasic(_xs,_acc=_f(_acc,hd(Zs)))
830 #define map1Accum(_f,_acc,_a,_xs) mapBasic(_xs,_acc=_f(_acc,_a,hd(Zs)))
831 #define map2Accum(_f,_acc,_a,_b,_xs) mapBasic(_xs,_acc=_f(_acc,_a,_b,hd(Zs)))
832 #define map3Accum(_f,_acc,_a,_b,_c,_xs) mapBasic(_xs,_acc=_f(_acc,_a,_b,_c,hd(Zs)))
835 /* --------------------------------------------------------------------------
836 * Strongly-typed lists (z-lists) and tuples (experimental)
837 * ------------------------------------------------------------------------*/
840 typedef Cell ZTriple;
846 extern Cell zcons ( Cell x, Cell xs );
847 extern Cell zhd ( Cell xs );
848 extern Cell ztl ( Cell xs );
849 extern Cell zsingleton ( Cell x );
850 extern Cell zdoubleton ( Cell x, Cell y );
851 extern Int zlength ( ZList xs );
852 extern ZList zreverse ( ZList xs );
855 extern Cell zpair ( Cell x1, Cell x2 );
856 extern Cell zfst ( Cell zpair );
857 extern Cell zsnd ( Cell zpair );
859 extern Cell ztriple ( Cell x1, Cell x2, Cell x3 );
860 extern Cell zfst3 ( Cell zpair );
861 extern Cell zsnd3 ( Cell zpair );
862 extern Cell zthd3 ( Cell zpair );
864 extern Cell z4ble ( Cell x1, Cell x2, Cell x3, Cell x4 );
865 extern Cell zsel14 ( Cell zpair );
866 extern Cell zsel24 ( Cell zpair );
867 extern Cell zsel34 ( Cell zpair );
868 extern Cell zsel44 ( Cell zpair );
870 extern Cell z5ble ( Cell x1, Cell x2, Cell x3, Cell x4, Cell x5 );
871 extern Cell zsel15 ( Cell zpair );
872 extern Cell zsel25 ( Cell zpair );
873 extern Cell zsel35 ( Cell zpair );
874 extern Cell zsel45 ( Cell zpair );
875 extern Cell zsel55 ( Cell zpair );
877 extern Cell unap ( int tag, Cell c );
878 #define isZPair(c) (whatIs((c))==ZTUP2)
880 /* --------------------------------------------------------------------------
881 * Implementation of function application nodes:
882 * ------------------------------------------------------------------------*/
884 #define ap(f,x) pair(f,x)
885 #define ap1(f,x) ap(f,x)
886 #define ap2(f,x,y) ap(ap(f,x),y)
887 #define ap3(f,x,y,z) ap(ap(ap(f,x),y),z)
888 #define fun(c) fst(c)
889 #define arg(c) snd(c)
890 #define isAp(c) (isPair(c) && !isTag(fst(c)))
891 extern Cell getHead Args((Cell));
892 extern List getArgs Args((Cell));
894 extern Cell nthArg Args((Int,Cell));
895 extern Int numArgs Args((Cell));
896 extern Cell applyToArgs Args((Cell,List));
898 /* --------------------------------------------------------------------------
899 * Stack implementation:
901 * NB: Use of macros makes order of evaluation hard to predict.
902 * For example, "push(1+pop());" doesn't increment TOS.
903 * ------------------------------------------------------------------------*/
905 extern Cell DECTABLE(cellStack);
908 #define clearStack() sp=(-1)
909 #define stackEmpty() (sp==(-1))
910 #define stack(p) cellStack[p]
911 #define chkStack(n) if (sp>=NUM_STACK-(n)) hugsStackOverflow()
917 #define onto(c) stack(++sp)=(c);
918 #define pop() stack(sp--)
920 #define top() stack(sp)
921 #define pushed(n) stack(sp-(n))
922 #define topfun(f) top()=ap((f),top())
923 #define toparg(x) top()=ap(top(),(x))
925 extern Void hugsStackOverflow Args((Void));
929 #define STACK_HEADROOM 16384
930 #define STACK_CHECK if (StackSpace() <= STACK_HEADROOM) \
931 internal("Macintosh function parameter stack overflow.");
936 /* --------------------------------------------------------------------------
937 * Script file control:
938 * The implementation of script file storage is hidden.
939 * ------------------------------------------------------------------------*/
941 extern Script startNewScript Args((String));
942 extern Bool moduleThisScript Args((Module));
943 extern Module moduleOfScript Args((Script));
944 extern Bool isPreludeScript Args((Void));
945 extern Module lastModule Args((Void));
946 extern Script scriptThisFile Args((Text));
947 extern Script scriptThisName Args((Name));
948 extern Script scriptThisTycon Args((Tycon));
949 extern Script scriptThisInst Args((Inst));
950 extern Script scriptThisClass Args((Class));
951 extern String fileOfModule Args((Module));
952 extern Void dropScriptsFrom Args((Script));
955 /* --------------------------------------------------------------------------
957 * ------------------------------------------------------------------------*/
960 /* This is an exact copy of the declaration found in GreenCard.h */
962 typedef int HugsStackPtr;
963 typedef int HugsStablePtr;
964 typedef Pointer HugsForeign;
968 /* evaluate next argument */
969 int (*getInt ) Args(());
970 unsigned int (*getWord ) Args(());
971 void* (*getAddr ) Args(());
972 float (*getFloat ) Args(());
973 double (*getDouble) Args(());
974 char (*getChar ) Args(());
975 HugsForeign (*getForeign) Args(());
976 HugsStablePtr (*getStablePtr) Args(());
978 /* push part of result */
979 void (*putInt ) Args((int));
980 void (*putWord ) Args((unsigned int));
981 void (*putAddr ) Args((void*));
982 void (*putFloat ) Args((double));
983 void (*putDouble) Args((double));
984 void (*putChar ) Args((char));
985 void (*putForeign) Args((HugsForeign, void (*)(HugsForeign)));
986 void (*putStablePtr) Args((HugsStablePtr));
988 /* return n values in IO monad or Id monad */
989 void (*returnIO) Args((HugsStackPtr, int));
990 void (*returnId) Args((HugsStackPtr, int));
991 int (*runIO) Args((int));
993 /* free a stable pointer */
994 void (*freeStablePtr) Args((HugsStablePtr));
996 /* register the prim table */
997 void (*registerPrims) Args((struct primInfo*));
999 /* garbage collect */
1000 void (*garbageCollect) Args(());
1004 extern HugsAPI2* hugsAPI2 Args((Void));
1005 typedef Void (*InitModuleFun2) Args((HugsAPI2*));
1008 Name nameTrue, nameFalse;
1009 Name nameNil, nameCons;
1010 Name nameJust, nameNothing;
1011 Name nameLeft, nameRight;
1015 Cell (*makeInt) Args((Int));
1017 Cell (*makeChar) Args((Char));
1018 Char (*CharOf) Args((Cell));
1020 Cell (*makeFloat) Args((FloatPro));
1021 Cell (*makeTuple) Args((Int));
1022 Pair (*pair) Args((Cell,Cell));
1024 Cell (*mkMallocPtr) Args((Void *, Void (*)(Void *)));
1025 Void *(*derefMallocPtr) Args((Cell));
1027 Int (*mkStablePtr) Args((Cell));
1028 Cell (*derefStablePtr) Args((Int));
1029 Void (*freeStablePtr) Args((Int));
1031 Void (*eval) Args((Cell));
1032 Cell (*evalWithNoError) Args((Cell));
1033 Void (*evalFails) Args((StackPtr));
1039 Void (*garbageCollect) Args(());
1040 Void (*stackOverflow) Args(());
1041 Void (*internal) Args((String)) HUGS_noreturn;
1043 Void (*registerPrims) Args((struct primInfo*));
1044 Name (*addPrimCfun) Args((Text,Int,Int,Cell));
1045 Text (*inventText) Args(());
1047 Cell *(*Fst) Args((Cell));
1048 Cell *(*Snd) Args((Cell));
1054 extern HugsAPI1* hugsAPI1 Args((Void));
1055 typedef Void (*InitModuleFun1) Args((HugsAPI1*));
1056 #endif /* PLUGINS */
1059 /* --------------------------------------------------------------------------
1061 * ------------------------------------------------------------------------*/
1063 extern Void setLastExpr Args((Cell));
1064 extern Cell getLastExpr Args((Void));
1065 extern List addTyconsMatching Args((String,List));
1066 extern List addNamesMatching Args((String,List));
1068 /*-------------------------------------------------------------------------*/