ghc/interpreter/storage.h

   1
   2 /* --------------------------------------------------------------------------
   3  * Defines storage datatypes: Text, Name, Module, Tycon, Cell, List, Pair,
   4  * Triple, ...
   5  *
   6  * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
   7  * Haskell Group 1994-99, and is distributed as Open Source software
   8  * under the Artistic License; see the file "Artistic" that is included
   9  * in the distribution for details.
  10  *
  11  * $RCSfile: storage.h,v $
  12  * $Revision: 1.4 $
  13  * $Date: 1999/03/01 14:46:55 $
  14  * ------------------------------------------------------------------------*/
  15
  16 /* --------------------------------------------------------------------------
  17  * Typedefs for main data types:
  18  * Many of these type names are used to indicate the intended us of a data
  19  * item, rather than for type checking purposes.  Sadly (although sometimes,
  20  * fortunately), the C compiler cannot distinguish between the use of two
  21  * different names defined to be synonyms for the same types.
  22  * ------------------------------------------------------------------------*/
  23
  24 typedef Int          Text;                       /* text string            */
  25 typedef Unsigned     Syntax;                     /* syntax (assoc,preced)  */
  26 typedef Int          Cell;                       /* general cell value     */
  27 typedef Cell far     *Heap;                      /* storage of heap        */
  28 typedef Cell         Pair;                       /* pair cell              */
  29 typedef Int          StackPtr;                   /* stack pointer          */
  30 typedef Cell         Offset;                     /* offset/generic variable*/
  31 typedef Int          Script;                     /* script file number     */
  32 typedef Int          Module;                     /* module                 */
  33 typedef Cell         Tycon;                      /* type constructor       */
  34 typedef Cell         Type;                       /* type expression        */
  35 typedef Cell         Kind;                       /* kind expression        */
  36 typedef Cell         Kinds;                      /* list of kinds          */
  37 typedef Cell         Constr;                     /* constructor expression */
  38 typedef Cell         Name;                       /* named value            */
  39 typedef Cell         Class;                      /* type class             */
  40 typedef Cell         Inst;                       /* instance of type class */
  41 typedef Cell         Triple;                     /* triple of cell values  */
  42 typedef Cell         List;                       /* list of cells          */
  43 typedef Cell         Bignum;                     /* bignum integer         */
  44 typedef Cell         Float;                      /* floating pt literal    */
  45 #if TREX
  46 typedef Cell         Ext;                        /* extension label        */
  47 #endif
  48
  49 /* --------------------------------------------------------------------------
  50  * Text storage:
  51  * provides storage for the characters making up identifier and symbol
  52  * names, string literals, character constants etc...
  53  * ------------------------------------------------------------------------*/
  54
  55 extern  String       textToStr          Args((Text));
  56 extern  Text         findText           Args((String));
  57 extern  Text         inventText         Args((Void));
  58 extern  Text         inventDictText     Args((Void));
  59 extern  Bool         inventedText       Args((Text));
  60
  61 /* Variants of textToStr and syntaxOf which work for idents, ops whether
  62  * qualified or unqualified.
  63  */
  64 extern  String       identToStr         Args((Cell));
  65 extern  Syntax       identSyntax        Args((Cell));
  66 extern  Syntax       defaultSyntax      Args((Text));
  67
  68 /* --------------------------------------------------------------------------
  69  * Specification of syntax (i.e. default written form of application)
  70  * ------------------------------------------------------------------------*/
  71
  72 #define MIN_PREC  0                    /* weakest binding operator         */
  73 #define MAX_PREC  9                    /* strongest binding operator       */
  74 #define FUN_PREC  (MAX_PREC+2)         /* binding of function symbols      */
  75 #define DEF_PREC  MAX_PREC
  76 #define APPLIC    0                    /* written applicatively            */
  77 #define LEFT_ASS  1                    /* left associative infix           */
  78 #define RIGHT_ASS 2                    /* right associative infix          */
  79 #define NON_ASS   3                    /* non associative infix            */
  80 #define DEF_ASS   LEFT_ASS
  81
  82 #define UMINUS_PREC  6                  /* Change these settings at your   */
  83 #define UMINUS_ASSOC LEFT_ASS           /* own risk; they may not work!    */
  84
  85 #define assocOf(x)      ((x)&NON_ASS)
  86 #define precOf(x)       ((x)>>2)
  87 #define mkSyntax(a,p)   ((a)|((p)<<2))
  88 #define DEF_OPSYNTAX    mkSyntax(DEF_ASS,DEF_PREC)
  89 #define NO_SYNTAX       (-1)
  90
  91 extern  Void   addSyntax  Args((Int,Text,Syntax));
  92 extern  Syntax syntaxOf   Args((Text));
  93
  94 /* --------------------------------------------------------------------------
  95  * Heap storage:
  96  * Provides a garbage collectable heap for storage of expressions etc.
  97  * ------------------------------------------------------------------------*/
  98
  99 #define heapAlloc(s) (Heap)(farCalloc(s,sizeof(Cell)))
 100 #define heapBuilt()  (heapFst)
 101 extern  Int          heapSize;
 102 extern  Heap         heapFst, heapSnd;
 103 extern  Heap         heapTopFst;
 104 extern  Heap         heapTopSnd;
 105 extern  Bool         consGC;            /* Set to FALSE to turn off gc from*/
 106                                         /* C stack; use with extreme care! */
 107 extern Int   cellsRecovered;            /* cells recovered by last gc      */
 108
 109 #define fst(c)       heapTopFst[c]
 110 #define snd(c)       heapTopSnd[c]
 111 #if PROFILING
 112 extern   Heap        heapThd, heapTopThd;
 113 #define thd(c)       heapTopThd[c]
 114 extern   Name        producer;
 115 extern   Bool        profiling;
 116 extern   Int         profInterval;
 117 extern   Void        profilerLog     Args((String));
 118 #endif
 119
 120 extern  Pair         pair            Args((Cell,Cell));
 121 extern  Void         garbageCollect  Args((Void));
 122
 123 extern  Void         overwrite       Args((Pair,Pair));
 124 extern  Void         overwrite2      Args((Pair,Cell,Cell));
 125 extern  Cell         markExpr        Args((Cell));
 126 extern  Void         markWithoutMove Args((Cell));
 127
 128 #define mark(v)      v=markExpr(v)
 129
 130 #define isPair(c)    ((c)<0)
 131 #define isGenPair(c) ((c)<0 && -heapSize<=(c))
 132
 133 extern  Cell         whatIs    Args((Cell));
 134
 135 /* --------------------------------------------------------------------------
 136  * Box cell tags are used as the fst element of a pair to indicate that
 137  * the snd element of the pair is to be treated in some special way, other
 138  * than as a Cell.  Examples include holding integer values, variable name
 139  * and string text etc.
 140  * ------------------------------------------------------------------------*/
 141
 142 #define TAGMIN       1            /* Box and constructor cell tag values   */
 143 #define BCSTAG       20           /* Box=TAGMIN..BCSTAG-1                  */
 144 #define isTag(c)     (TAGMIN<=(c) && (c)<SPECMIN) /* Tag cell values       */
 145 #define isBoxTag(c)  (TAGMIN<=(c) && (c)<BCSTAG)  /* Box cell tag values   */
 146 #define isConTag(c)  (BCSTAG<=(c) && (c)<SPECMIN) /* Constr cell tag values*/
 147
 148 #define FREECELL     3            /* Free list cell:          snd :: Cell  */
 149 #define VARIDCELL    4            /* Identifier variable:     snd :: Text  */
 150 #define VAROPCELL    5            /* Operator variable:       snd :: Text  */
 151 #define DICTVAR      6            /* Dictionary variable:     snd :: Text  */
 152 #define CONIDCELL    7            /* Identifier constructor:  snd :: Text  */
 153 #define CONOPCELL    8            /* Operator constructor:    snd :: Text  */
 154 #define STRCELL      9            /* String literal:          snd :: Text  */
 155 #define INTCELL      10           /* Int literal:             snd :: Int   */
 156 #define ADDPAT       11           /* (_+k) pattern discr:     snd :: Int   */
 157 #define FLOATCELL    15           /* Floating Pt literal:     snd :: Text  */
 158 #define BIGCELL      16           /* Integer literal:         snd :: Text  */
 159 #if PTR_ON_HEAP
 160 #define PTRCELL      17           /* C Heap Pointer           snd :: Ptr   */
 161 #endif
 162 #if TREX
 163 #define EXTCOPY      18           /* Copy of an Ext:          snd :: Text  */
 164 #endif
 165
 166 #define textOf(c)       ((Text)(snd(c)))         /* c ::  (VAR|CON)(ID|OP) */
 167 #define qmodOf(c)       (textOf(fst(snd(c))))    /* c ::  QUALIDENT        */
 168 #define qtextOf(c)      (textOf(snd(snd(c))))    /* c ::  QUALIDENT        */
 169 #define mkVar(t)        ap(VARIDCELL,t)
 170 #define mkVarop(t)      ap(VAROPCELL,t)
 171 #define mkCon(t)        ap(CONIDCELL,t)
 172 #define mkConop(t)      ap(CONOPCELL,t)
 173 #define mkQVar(m,t)     ap(QUALIDENT,pair(mkCon(m),mkVar(t)))
 174 #define mkQCon(m,t)     ap(QUALIDENT,pair(mkCon(m),mkCon(t)))
 175 #define mkQVarOp(m,t)   ap(QUALIDENT,pair(mkCon(m),mkVarop(t)))
 176 #define mkQConOp(m,t)   ap(QUALIDENT,pair(mkCon(m),mkConop(t)))
 177 #define intValOf(c)     (snd(c))
 178 #define inventVar()     mkVar(inventText())
 179 #define mkDictVar(t)    ap(DICTVAR,t)
 180 #define inventDictVar() mkDictVar(inventDictText())
 181 #define mkStr(t)        ap(STRCELL,t)
 182 extern  Bool            isVar       Args((Cell));
 183 extern  Bool            isCon       Args((Cell));
 184 extern  Bool            isQVar      Args((Cell));
 185 extern  Bool            isQCon      Args((Cell));
 186 extern  Bool            isQualIdent Args((Cell));
 187 extern  Bool            isIdent     Args((Cell));
 188
 189 #if 0
 190 Originally ...
 191 #define isFloat(c)      (isPair(c) && fst(c)==FLOATCELL)
 192 extern  Cell            mkFloat         Args((FloatPro));
 193 extern  FloatPro        floatOf         Args((Cell));
 194 extern  String          floatToString   Args((FloatPro));
 195 extern  FloatPro        stringToFloat   Args((String));
 196 #else
 197 #define isFloat(c)       (isPair(c) && fst(c)==FLOATCELL)
 198 #define stringToFloat(s) pair(FLOATCELL,findText(s))
 199 #define floatToString(f) textToStr(snd(f))
 200 #define floatEq(f1,f2)   (snd(f1) == snd(f2))
 201 #define floatNegate(f)   stringToFloat(stringNegate(floatToString(f)))
 202 #define floatOf(f)       atof(floatToString(f))
 203 #endif
 204
 205
 206
 207
 208 #define isFloat(c)       (isPair(c) && fst(c)==FLOATCELL)
 209 #define stringToFloat(s) pair(FLOATCELL,findText(s))
 210 #define floatToString(f) textToStr(snd(f))
 211 #define floatEq(f1,f2)   (snd(f1) == snd(f2))
 212 #define floatNegate(f)   stringToFloat(stringNegate(floatToString(f)))
 213 #define floatOf(f)       atof(floatToString(f))
 214 #define mkFloat(f)       (f)  /* ToDo: is this right? */
 215
 216 #define bignumToString(b) textToStr(snd(b))
 217
 218
 219 #if PTR_ON_HEAP
 220 #define isPtr(c)        (isPair(c) && fst(c)==PTRCELL)
 221 extern  Cell            mkPtr           Args((Ptr));
 222 extern  Ptr             ptrOf           Args((Cell));
 223 #endif
 224
 225 /* --------------------------------------------------------------------------
 226  * Constructor cell tags are used as the fst element of a pair to indicate
 227  * a particular syntactic construct described by the snd element of the
 228  * pair.
 229  * Note that a cell c will not be treated as an application (AP/isAp) node
 230  * if its first element is a constructor cell tag, whereas a cell whose fst
 231  * element is a special cell will be treated as an application node.
 232  * ------------------------------------------------------------------------*/
 233
 234 #define LETREC       20           /* LETREC     snd :: ([Decl],Exp)        */
 235 #define COND         21           /* COND       snd :: (Exp,Exp,Exp)       */
 236 #define LAMBDA       22           /* LAMBDA     snd :: Alt                 */
 237 #define FINLIST      23           /* FINLIST    snd :: [Exp]               */
 238 #define DOCOMP       24           /* DOCOMP     snd :: (Exp,[Qual])        */
 239 #define BANG         25           /* BANG       snd :: Type                */
 240 #define COMP         26           /* COMP       snd :: (Exp,[Qual])        */
 241 #define ASPAT        27           /* ASPAT      snd :: (Var,Exp)           */
 242 #define ESIGN        28           /* ESIGN      snd :: (Exp,Type)          */
 243 #define RSIGN        29           /* RSIGN      snd :: (Rhs,Type)          */
 244 #define CASE         30           /* CASE       snd :: (Exp,[Alt])         */
 245 #define NUMCASE      31           /* NUMCASE    snd :: (Exp,Disc,Rhs)      */
 246 #define FATBAR       32           /* FATBAR     snd :: (Exp,Exp)           */
 247 #define LAZYPAT      33           /* LAZYPAT    snd :: Exp                 */
 248 #define DERIVE       35           /* DERIVE     snd :: Cell                */
 249 #if BREAK_FLOATS
 250 #define FLOATCELL    36           /* FLOATCELL  snd :: (Int,Int)           */
 251 #endif
 252
 253 #if BIGNUMS
 254 #define POSNUM       37           /* POSNUM     snd :: [Int]               */
 255 #define NEGNUM       38           /* NEGNUM     snd :: [Int]               */
 256 #endif
 257
 258 #define BOOLQUAL     39           /* BOOLQUAL   snd :: Exp                 */
 259 #define QWHERE       40           /* QWHERE     snd :: [Decl]              */
 260 #define FROMQUAL     41           /* FROMQUAL   snd :: (Exp,Exp)           */
 261 #define DOQUAL       42           /* DOQUAL     snd :: Exp                 */
 262 #define MONADCOMP    43           /* MONADCOMP  snd :: ((m,m0),(Exp,[Qual])*/
 263
 264 #define GUARDED      44           /* GUARDED    snd :: [guarded exprs]     */
 265
 266 #define ARRAY        45           /* Array      snd :: (Bounds,[Values])   */
 267 #define MUTVAR       46           /* Mutvar     snd :: Cell                */
 268 #if INTERNAL_PRIMS
 269 #define HUGSOBJECT   47           /* HUGSOBJECT snd :: Cell                */
 270 #endif
 271
 272 #define POLYTYPE     50           /* POLYTYPE   snd :: (Kind,Type)         */
 273 #define QUAL         51           /* QUAL       snd :: ([Classes],Type)    */
 274 #define RANK2        52           /* RANK2      snd :: (Int,Type)          */
 275 #define EXIST        53           /* EXIST      snd :: (Int,Type)          */
 276 #define POLYREC      54           /* POLYREC    snd :: (Int,Type)          */
 277 #define BIGLAM       55           /* BIGLAM     snd :: (vars,patterns)     */
 278 #define CDICTS       56           /* CDICTS     snd :: ([Pred],Type)       */
 279
 280 #define LABC         60           /* LABC       snd :: (con,[(Vars,Type)]) */
 281 #define CONFLDS      61           /* CONFLDS    snd :: (con,[Field])       */
 282 #define UPDFLDS      62           /* UPDFLDS    snd :: (Exp,[con],[Field]) */
 283 #if TREX
 284 #define RECORD       63           /* RECORD     snd :: [Val]               */
 285 #define EXTCASE      64           /* EXTCASE    snd :: (Exp,Disc,Rhs)      */
 286 #define RECSEL       65           /* RECSEL     snd :: Ext                 */
 287 #endif
 288 #define IMPDEPS      68           /* IMPDEPS    snd :: [Binding]           */
 289
 290 #define QUALIDENT    70           /* Qualified identifier  snd :: (Id,Id)  */
 291 #define HIDDEN       71           /* hiding import list    snd :: [Entity] */
 292 #define MODULEENT    72           /* module in export list snd :: con      */
 293
 294 #define INFIX        80           /* INFIX      snd :: (see tidyInfix)     */
 295 #define ONLY         81           /* ONLY       snd :: Exp                 */
 296 #define NEG          82           /* NEG        snd :: Exp                 */
 297
 298 #if SIZEOF_INTP != SIZEOF_INT
 299 #define PTRCELL      90           /* C Heap Pointer snd :: (Int,Int)       */
 300 #endif
 301
 302 #define STGVAR       92           /* STGVAR     snd :: (StgRhs,info)       */
 303 #define STGAPP       93           /* STGAPP     snd :: (StgVar,[Arg])      */
 304 #define STGPRIM      94           /* STGPRIM    snd :: (PrimOp,[Arg])      */
 305 #define STGCON       95           /* STGCON     snd :: (StgCon,[Arg])      */
 306 #define PRIMCASE     96           /* PRIMCASE   snd :: (Expr,[PrimAlt])    */
 307 /* Last constructor tag must be less than SPECMIN */
 308
 309 /* --------------------------------------------------------------------------
 310  * Special cell values:
 311  * ------------------------------------------------------------------------*/
 312
 313 #define SPECMIN      101
 314 #define isSpec(c)    (SPECMIN<=(c) && (c)<TUPMIN)/* Special cell values    */
 315
 316 #define NONE         101          /* Dummy stub                            */
 317 #define STAR         102          /* Representing the kind of types        */
 318 #if TREX
 319 #define ROW          103          /* Representing the kind of rows         */
 320 #endif
 321 #define WILDCARD     104          /* Wildcard pattern                      */
 322 #define SKOLEM       105          /* Skolem constant                       */
 323
 324 #define DOTDOT       106          /* ".." in import/export list            */
 325
 326 #if BIGNUMS
 327 #define ZERONUM      108          /* The zero bignum (see POSNUM, NEGNUM)  */
 328 #endif
 329
 330 #define NAME         110          /* whatIs code for isName                */
 331 #define TYCON        111          /* whatIs code for isTycon               */
 332 #define CLASS        112          /* whatIs code for isClass               */
 333 #define MODULE       113          /* whatIs code for isModule              */
 334 #define INSTANCE     114          /* whatIs code for isInst                */
 335 #define TUPLE        115          /* whatIs code for tuple constructor     */
 336 #define OFFSET       116          /* whatis code for offset                */
 337 #define AP           117          /* whatIs code for application node      */
 338 #define CHARCELL     118          /* whatIs code for isChar                */
 339 #if TREX
 340 #define EXT          119          /* whatIs code for isExt                 */
 341 #endif
 342
 343 #define SIGDECL      120          /* Signature declaration                 */
 344 #define FIXDECL      121          /* Fixity declaration                    */
 345 #define FUNBIND      122          /* Function binding                      */
 346 #define PATBIND      123          /* Pattern binding                       */
 347
 348 #define DATATYPE     130          /* Datatype type constructor             */
 349 #define NEWTYPE      131          /* Newtype type constructor              */
 350 #define SYNONYM      132          /* Synonym type constructor              */
 351 #define RESTRICTSYN  133          /* Synonym with restricted scope         */
 352
 353 #define NODEPENDS    135          /* Stop calculation of deps in type check*/
 354 #define PREDEFINED   136          /* Predefined name, not yet filled       */
 355
 356 /* --------------------------------------------------------------------------
 357  * Tuple data/type constructors:
 358  * ------------------------------------------------------------------------*/
 359
 360 #define TUPMIN       201
 361 #if TREX
 362 #define isTuple(c)   (TUPMIN<=(c) && (c)<EXTMIN)
 363 #else
 364 #define isTuple(c)   (TUPMIN<=(c) && (c)<OFFMIN)
 365 #endif
 366 #define mkTuple(n)   (TUPMIN+(n))
 367 #define tupleOf(n)   ((Int)((n)-TUPMIN))
 368
 369 #if TREX
 370 #define EXTMIN       (TUPMIN+NUM_TUPLES)
 371 #define isExt(c)     (EXTMIN<=(c) && (c)<OFFMIN)
 372 #define extText(e)   tabExt[(e)-EXTMIN]
 373 #define extField(c)  arg(fun(c))
 374 #define extRow(c)    arg(c)
 375
 376 extern Text          DECTABLE(tabExt);
 377 extern Ext           mkExt Args((Text));
 378 #else
 379 #define mkExt(t) NIL
 380 #endif
 381
 382 /* --------------------------------------------------------------------------
 383  * Offsets: (generic types/stack offsets)
 384  * ------------------------------------------------------------------------*/
 385
 386 #if TREX
 387 #define OFFMIN       (EXTMIN+NUM_EXT)
 388 #else
 389 #define OFFMIN       (TUPMIN+NUM_TUPLES)
 390 #endif
 391 #define isOffset(c)  (OFFMIN<=(c) && (c)<MODMIN)
 392 #define offsetOf(c)  ((c)-OFFMIN)
 393 #define mkOffset(o)  (OFFMIN+(o))
 394
 395 /* --------------------------------------------------------------------------
 396  * Modules:
 397  * ------------------------------------------------------------------------*/
 398
 399 #define MODMIN        (OFFMIN+NUM_OFFSETS)
 400
 401 #if IGNORE_MODULES
 402 #define setCurrModule(m) doNothing()
 403 #else /* !IGNORE_MODULES */
 404 #define isModule(c)   (MODMIN<=(c) && (c)<TYCMIN)
 405 #define mkModule(n)   (MODMIN+(n))
 406 #define module(n)     tabModule[(n)-MODMIN]
 407
 408 /* Under Haskell 1.3, the list of qualified imports is always a subset
 409  * of the list of unqualified imports.  For simplicity and flexibility,
 410  * we do not attempt to exploit this fact - when a module is imported
 411  * unqualified, it is added to both the qualified and unqualified
 412  * import lists.
 413  * Similarily, Haskell 1.3 does not allow a constructor to be imported
 414  * or exported without exporting the type it belongs to but the export
 415  * list is just a flat list of Texts (before static analysis) or
 416  * Tycons, Names and Classes (after static analysis).
 417  */
 418 struct Module {
 419     Text  text;
 420     /* Lists of top level objects (local defns + imports)                  */
 421     List  tycons;
 422     List  names;
 423     List  classes;
 424     List  exports; /* [ Entity | (Entity, NIL|DOTDOT) ] */
 425     /* List of qualified imports.  Used both during compilation and when
 426      * evaluating an expression in the context of the current module.
 427      */
 428     List  qualImports;
 429     ObjectFile objectFile; /* usually unused */
 430 };
 431
 432 extern Module currentModule;           /* Module currently being processed */
 433 extern struct Module DECTABLE(tabModule);
 434
 435 extern Bool   isValidModule Args((Module));
 436 extern Module newModule     Args((Text));
 437 extern Module findModule    Args((Text));
 438 extern Module findModid     Args((Cell));
 439 extern Void   setCurrModule Args((Module));
 440
 441 #define isPrelude(m) (m==modulePrelude)
 442 #endif /* !IGNORE_MODULES */
 443
 444 /* --------------------------------------------------------------------------
 445  * Type constructor names:
 446  * ------------------------------------------------------------------------*/
 447
 448 #define TYCMIN       (MODMIN+NUM_MODULE)
 449 #define isTycon(c)   (TYCMIN<=(c) && (c)<NAMEMIN)
 450 #define mkTycon(n)   (TCMIN+(n))
 451 #define tycon(n)     tabTycon[(n)-TYCMIN]
 452
 453 struct strTycon {
 454     Text  text;
 455     Int   line;
 456 #if !IGNORE_MODULES
 457     Module mod;                         /* module that defines it          */
 458 #endif
 459     Int   arity;
 460     Kind  kind;                         /* kind (includes arity) of Tycon  */
 461     Cell  what;                         /* DATATYPE/SYNONYM/RESTRICTSYN... */
 462     Cell  defn;
 463     Name  conToTag;                     /* used in derived code            */
 464     Name  tagToCon;
 465   //Tycon nextTyconHash;
 466 };
 467
 468 extern struct strTycon DECTABLE(tabTycon);
 469
 470 extern Tycon newTycon     Args((Text));
 471 extern Tycon findTycon    Args((Text));
 472 extern Tycon addTycon     Args((Tycon));
 473 extern Tycon findQualTycon Args((Cell));
 474 extern Tycon addPrimTycon Args((Text,Kind,Int,Cell,Cell));
 475
 476 #define isSynonym(h)    (isTycon(h) && tycon(h).what==SYNONYM)
 477 #define mkPolyType(n,t) pair(POLYTYPE,pair(n,t))
 478 #define isPolyType(t)   (isPair(t) && fst(t)==POLYTYPE)
 479 #define polySigOf(t)    fst(snd(t))
 480 #define monotypeOf(t)   snd(snd(t))
 481
 482 /* --------------------------------------------------------------------------
 483  * Globally defined name values:
 484  * ------------------------------------------------------------------------*/
 485
 486 #define NAMEMIN      (TYCMIN+NUM_TYCON)
 487 #define isName(c)    (NAMEMIN<=(c) && (c)<INSTMIN)
 488 #define mkName(n)    (NAMEMIN+(n))
 489 #define name(n)      tabName[(n)-NAMEMIN]
 490
 491 struct strName {
 492     Text   text;
 493     Int    line;
 494     Module mod;                         /* module that defines it          */
 495     Syntax syntax;
 496     Cell   parent;
 497     Int    arity;
 498     Int    number;
 499     Cell   type;
 500     Cell   defn;
 501     Cell   stgVar;        /* really StgVar   */
 502     const void*  primop;  /* really StgPrim* */
 503   //Name   nextNameHash;
 504 };
 505
 506 extern int numNames Args(( Void ));
 507
 508 extern struct strName DECTABLE(tabName);
 509
 510 /* The number field in a name is used to distinguish various kinds of name:
 511  *   mfunNo(i) = code for member function, offset i
 512  *               members that are sole elements of dict use mfunNo(0)
 513  *               members of dicts with more than one elem use mfunNo(n), n>=1
 514  *   EXECNAME  = code for executable name (bytecodes or primitive)
 515  *   SELNAME   = code for selector function
 516  *   DFUNNAME  = code for dictionary builder or selector
 517  *   cfunNo(i) = code for data constructor
 518  *               datatypes with only one constructor uses cfunNo(0)
 519  *               datatypes with multiple constructors use cfunNo(n), n>=1
 520  */
 521
 522 #define EXECNAME        0
 523 #define SELNAME         1
 524 #define DFUNNAME        2
 525 #define CFUNNAME        3
 526
 527 #define isSfun(n)       (name(n).number==SELNAME)
 528 #define isDfun(n)       (name(n).number==DFUNNAME)
 529
 530 #define isCfun(n)       (name(n).number>=CFUNNAME)
 531 #define cfunOf(n)       (name(n).number-CFUNNAME)
 532 #define cfunNo(i)       ((i)+CFUNNAME)
 533 #define hasCfun(cs)     (nonNull(cs) && isCfun(hd(cs)))
 534
 535 #define isMfun(n)       (name(n).number<0)
 536 #define mfunOf(n)       ((-1)-name(n).number)
 537 #define mfunNo(i)       ((-1)-(i))
 538
 539 extern Name   newName         Args((Text,Cell));
 540 extern Name   findName        Args((Text));
 541 extern Name   addName         Args((Name));
 542 extern Name   findQualName    Args((Cell));
 543 extern Name   addPrimCfun     Args((Text,Int,Int,Cell));
 544 extern Name   addPrimCfunREP  Args((Text,Int,Int,Int));
 545 extern Int    sfunPos         Args((Name,Name));
 546
 547 /* --------------------------------------------------------------------------
 548  * Type class values:
 549  * ------------------------------------------------------------------------*/
 550
 551 #define INSTMIN      (NAMEMIN+NUM_NAME) /* instances                       */
 552 #define isInst(c)    (INSTMIN<=(c) && (c)<CLASSMIN)
 553 #define mkInst(n)    (INSTMIN+(n))
 554 #define instOf(c)    ((Int)((c)-INSTMIN))
 555 #define inst(in)     tabInst[(in)-INSTMIN]
 556
 557 struct strInst {
 558     Class c;                            /* class C                         */
 559     Int   line;
 560     Module mod;                         /* module that defines it          */
 561     Kinds kinds;                        /* Kinds of variables in head      */
 562     Cell  head;                         /* :: Pred                         */
 563     List  specifics;                    /* :: [Pred]                       */
 564     Int   numSpecifics;                 /* length(specifics)               */
 565     List  implements;
 566     Name  builder;                      /* Dictionary constructor function */
 567 };
 568
 569 /* a predicate (an element :: Pred) is an application of a Class to one or
 570  * more type expressions
 571  */
 572
 573 #define CLASSMIN     (INSTMIN+NUM_INSTS)
 574 #define isClass(c)   (CLASSMIN<=(c) && (c)<CHARMIN)
 575 #define mkClass(n)   (CLASSMIN+(n))
 576 #define cclass(n)    tabClass[(n)-CLASSMIN]
 577
 578 struct strClass {
 579     Text   text;                        /* Name of class                   */
 580     Int    line;                        /* Line where declaration begins   */
 581 #if !IGNORE_MODULES
 582     Module mod;                         /* module that declares it         */
 583 #endif
 584     Int    level;                       /* Level in class hierarchy        */
 585     Int    arity;                       /* Number of arguments             */
 586     Kinds  kinds;                       /* Kinds of constructors in class  */
 587     Cell   head;                        /* Head of class                   */
 588     Name   dcon;                        /* Dictionary constructor function */
 589     List   supers;                      /* :: [Pred]                       */
 590     Int    numSupers;                   /* length(supers)                  */
 591     List   dsels;                       /* Superclass dictionary selectors */
 592     List   members;                     /* :: [Name]                       */
 593     Int    numMembers;                  /* length(members)                 */
 594     Name   dbuild;                      /* Default dictionary builder      */
 595     List   defaults;                    /* :: [Name]                       */
 596     List   instances;                   /* :: [Inst]                       */
 597 };
 598
 599 extern struct strClass    DECTABLE(tabClass);
 600 extern struct strInst far *tabInst;
 601
 602 extern Class newClass      Args((Text));
 603 extern Class classMax      Args((Void));
 604 extern Class findClass     Args((Text));
 605 extern Class addClass      Args((Class));
 606 extern Class findQualClass Args((Cell));
 607 extern Inst  newInst       Args((Void));
 608 extern Inst  findFirstInst Args((Tycon));
 609 extern Inst  findNextInst  Args((Tycon,Inst));
 610
 611 /* --------------------------------------------------------------------------
 612  * Character values:
 613  * ------------------------------------------------------------------------*/
 614
 615 #define CHARMIN      (CLASSMIN+NUM_CLASSES)
 616 #define MAXCHARVAL   (NUM_CHARS-1)
 617 #define isChar(c)    (CHARMIN<=(c) && (c)<INTMIN)
 618 #define charOf(c)    ((Char)(c-CHARMIN))
 619 #define mkChar(c)    ((Cell)(CHARMIN+((unsigned)((c)%NUM_CHARS))))
 620
 621 /* --------------------------------------------------------------------------
 622  * Small Integer values:
 623  * ------------------------------------------------------------------------*/
 624
 625 #define INTMIN       (CHARMIN+NUM_CHARS)
 626 #define INTMAX       (MAXPOSINT)
 627 #define isSmall(c)   (INTMIN<=(c))
 628 #define INTZERO      (INTMIN/2 + INTMAX/2)
 629 #define MINSMALLINT  (INTMIN - INTZERO)
 630 #define MAXSMALLINT  (INTMAX - INTZERO)
 631 #define mkDigit(c)   ((Cell)((c)+INTMIN))
 632 #define digitOf(c)   ((Int)((c)-INTMIN))
 633
 634 extern  Bool isInt    Args((Cell));
 635 extern  Int  intOf    Args((Cell));
 636 extern  Cell mkInt    Args((Int));
 637 #if BIGNUMS
 638 extern  Bool isBignum Args((Cell));
 639 #endif
 640
 641 /* --------------------------------------------------------------------------
 642  * Implementation of triples:
 643  * ------------------------------------------------------------------------*/
 644
 645 #define triple(x,y,z) pair(x,pair(y,z))
 646 #define fst3(c)      fst(c)
 647 #define snd3(c)      fst(snd(c))
 648 #define thd3(c)      snd(snd(c))
 649
 650 /* --------------------------------------------------------------------------
 651  * Implementation of lists:
 652  * ------------------------------------------------------------------------*/
 653
 654 #define NIL          0
 655 #define isNull(c)    ((c)==NIL)
 656 #define nonNull(c)   (c)
 657 #define cons(x,xs)   pair(x,xs)
 658 #define singleton(x)     cons(x,NIL)
 659 #define doubleton(x,y)   cons(x,cons(y,NIL))
 660 #define tripleton(x,y,z) cons(x,cons(y,cons(z,NIL)))
 661 #define hd(c)        fst(c)
 662 #define tl(c)        snd(c)
 663
 664 extern  Int          length       Args((List));
 665 extern  List         appendOnto   Args((List,List));    /* destructive     */
 666 extern  List         dupOnto      Args((List,List));
 667 extern  List         dupList      Args((List));
 668 extern  List         revOnto      Args((List, List));   /* destructive     */
 669 #define rev(xs)      revOnto((xs),NIL)                  /* destructive     */
 670 #define reverse(xs)  revOnto(dupList(xs),NIL)           /* non-destructive */
 671 extern  Cell         cellIsMember Args((Cell,List));
 672 extern  Cell         cellAssoc    Args((Cell,List));
 673 extern  Cell         cellRevAssoc Args((Cell,List));
 674 extern  Bool         eqList       Args((List,List));
 675 extern  Cell         varIsMember  Args((Text,List));
 676 extern  Name         nameIsMember Args((Text,List));
 677 extern  Cell         intIsMember  Args((Int,List));
 678 extern  List         replicate    Args((Int,Cell));
 679 extern  List         diffList     Args((List,List));    /* destructive     */
 680 extern  List         deleteCell   Args((List,Cell));    /* non-destructive */
 681 extern  List         take         Args((Int,List));     /* destructive     */
 682 extern  List         splitAt      Args((Int,List));     /* non-destructive */
 683 extern  Cell         nth          Args((Int,List));
 684 extern  List         removeCell   Args((Cell,List));    /* destructive     */
 685 extern  List         dupListOnto  Args((List,List));    /* non-destructive */
 686
 687 /* The following macros provide `inline expansion' of some common ways of
 688  * traversing, using and modifying lists:
 689  *
 690  * N.B. We use the names _f, _a, _xs, Zs, in an attempt to avoid clashes
 691  *      with identifiers used elsewhere.
 692  */
 693
 694 #define mapBasic(_init,_step)           {List Zs=(_init);\
 695                                          for(;nonNull(Zs);Zs=tl(Zs))  \
 696                                          _step;}
 697 #define mapModify(_init,_step)          mapBasic(_init,hd(Zs)=_step)
 698
 699 #define mapProc(_f,_xs)                 mapBasic(_xs,_f(hd(Zs)))
 700 #define map1Proc(_f,_a,_xs)             mapBasic(_xs,_f(_a,hd(Zs)))
 701 #define map2Proc(_f,_a,_b,_xs)          mapBasic(_xs,_f(_a,_b,hd(Zs)))
 702 #define map3Proc(_f,_a,_b,_c,_xs)       mapBasic(_xs,_f(_a,_b,_c,hd(Zs)))
 703 #define map4Proc(_f,_a,_b,_c,_d,_xs)    mapBasic(_xs,_f(_a,_b,_c,_d,hd(Zs)))
 704
 705 #define mapOver(_f,_xs)                 mapModify(_xs,_f(hd(Zs)))
 706 #define map1Over(_f,_a,_xs)             mapModify(_xs,_f(_a,hd(Zs)))
 707 #define map2Over(_f,_a,_b,_xs)          mapModify(_xs,_f(_a,_b,hd(Zs)))
 708 #define map3Over(_f,_a,_b,_c,_xs)       mapModify(_xs,_f(_a,_b,_c,hd(Zs)))
 709 #define map4Over(_f,_a,_b,_c,_d,_xs)    mapModify(_xs,_f(_a,_b,_c,_d,hd(Zs)))
 710
 711 /* This is just what you want for functions with accumulating parameters */
 712 #define mapAccum(_f,_acc,_xs)           mapBasic(_xs,_acc=_f(_acc,hd(Zs)))
 713 #define map1Accum(_f,_acc,_a,_xs)       mapBasic(_xs,_acc=_f(_acc,_a,hd(Zs)))
 714 #define map2Accum(_f,_acc,_a,_b,_xs)    mapBasic(_xs,_acc=_f(_acc,_a,_b,hd(Zs)))
 715 #define map3Accum(_f,_acc,_a,_b,_c,_xs) mapBasic(_xs,_acc=_f(_acc,_a,_b,_c,hd(Zs)))
 716
 717 /* --------------------------------------------------------------------------
 718  * Implementation of function application nodes:
 719  * ------------------------------------------------------------------------*/
 720
 721 #define ap(f,x)      pair(f,x)
 722 #define ap1(f,x)     ap(f,x)
 723 #define ap2(f,x,y)   ap(ap(f,x),y)
 724 #define ap3(f,x,y,z) ap(ap(ap(f,x),y),z)
 725 #define fun(c)       fst(c)
 726 #define arg(c)       snd(c)
 727 #define isAp(c)      (isPair(c) && !isTag(fst(c)))
 728 extern  Cell         getHead     Args((Cell));
 729 extern  List         getArgs     Args((Cell));
 730 extern  Int          argCount;
 731 extern  Cell         nthArg      Args((Int,Cell));
 732 extern  Int          numArgs     Args((Cell));
 733 extern  Cell         applyToArgs Args((Cell,List));
 734
 735 /* --------------------------------------------------------------------------
 736  * Stack implementation:
 737  *
 738  * NB: Use of macros makes order of evaluation hard to predict.
 739  *     For example, "push(1+pop());" doesn't increment TOS.
 740  * ------------------------------------------------------------------------*/
 741
 742 extern  Cell DECTABLE(cellStack);
 743 extern  StackPtr sp;
 744
 745 #define clearStack() sp=(-1)
 746 #define stackEmpty() (sp==(-1))
 747 #define stack(p)     cellStack[p]
 748 #define chkStack(n)  if (sp>=NUM_STACK-(n)) hugsStackOverflow()
 749 #define push(c)      \
 750   do {               \
 751     chkStack(1);     \
 752     onto(c);         \
 753   } while (0)
 754 #define onto(c)      stack(++sp)=(c)
 755 #define pop()        stack(sp--)
 756 #define drop()       sp--
 757 #define top()        stack(sp)
 758 #define pushed(n)    stack(sp-(n))
 759 #define topfun(f)    top()=ap((f),top())
 760 #define toparg(x)    top()=ap(top(),(x))
 761
 762 extern  Void hugsStackOverflow Args((Void));
 763
 764 /* --------------------------------------------------------------------------
 765  * Script file control:
 766  * The implementation of script file storage is hidden.
 767  * ------------------------------------------------------------------------*/
 768
 769 extern Script      startNewScript   Args((String));
 770 extern Bool        moduleThisScript Args((Module));
 771 extern Module      moduleOfScript   Args((Script));
 772 extern Bool        isPreludeScript  Args((Void));
 773 extern Module      lastModule       Args((Void));
 774 extern Script      scriptThisFile   Args((Text));
 775 extern Script      scriptThisName   Args((Name));
 776 extern Script      scriptThisTycon  Args((Tycon));
 777 extern Script      scriptThisInst   Args((Inst));
 778 extern Script      scriptThisClass  Args((Class));
 779 extern String      fileOfModule     Args((Module));
 780 extern Void        dropScriptsFrom  Args((Script));
 781
 782 /* --------------------------------------------------------------------------
 783  * I/O Handles:
 784  * ------------------------------------------------------------------------*/
 785
 786 #if IO_HANDLES
 787 #define HSTDIN          0       /* Numbers for standard handles            */
 788 #define HSTDOUT         1
 789 #define HSTDERR         2
 790
 791 struct strHandle {              /* Handle description and status flags     */
 792     Cell hcell;                 /* Heap representation of handle (or NIL)  */
 793     FILE *hfp;                  /* Corresponding file pointer              */
 794     Int  hmode;                 /* Current mode: see below                 */
 795 };
 796
 797 #define HCLOSED         0000    /* no I/O permitted                        */
 798 #define HSEMICLOSED     0001    /* semiclosed reads only                   */
 799 #define HREAD           0002    /* set to enable reads from handle         */
 800 #define HWRITE          0004    /* set to enable writes to handle          */
 801 #define HAPPEND         0010    /* opened in append mode                   */
 802
 803 extern Cell   openHandle Args((String,Int,Bool));
 804 extern struct strHandle  DECTABLE(handles);
 805 #endif
 806
 807 /* --------------------------------------------------------------------------
 808  * Malloc Pointers
 809  * ------------------------------------------------------------------------*/
 810
 811 #if GC_MALLOCPTRS
 812 struct strMallocPtr {           /* Malloc Ptr description                  */
 813     Cell mpcell;                /* Back pointer to MPCELL                  */
 814     Void *ptr;                  /* Pointer into C world                    */
 815     Int  refCount;              /* Reference count                         */
 816     Void (*cleanup) Args((Void *)); /* Code to free the C pointer          */
 817 };
 818
 819 extern struct strMallocPtr       mallocPtrs[];
 820 extern Cell   mkMallocPtr        Args((Void *, Void (*)(Void *)));
 821 extern Void   freeMallocPtr      Args((Cell));
 822 extern Void   incMallocPtrRefCnt Args((Int, Int));
 823
 824 #define mpOf(c)    snd(c)
 825 #define derefMP(c) (mallocPtrs[(Int)mpOf(c)].ptr)
 826 #endif /* GC_MALLOCPTRS */
 827
 828 /* --------------------------------------------------------------------------
 829  * Weak Pointers
 830  * ------------------------------------------------------------------------*/
 831
 832 #if GC_WEAKPTRS
 833 #define mkWeakPtr(c)    pair(WEAKCELL,pair(c,NIL))
 834 #define derefWeakPtr(c) fst(snd(c))
 835 #define nextWeakPtr(c) snd(snd(c))
 836
 837 extern List finalizers;
 838 extern List liveWeakPtrs;
 839
 840 #endif /* GC_WEAKPTRS */
 841
 842 /* --------------------------------------------------------------------------
 843  * Stable pointers
 844  * ------------------------------------------------------------------------*/
 845
 846 #if GC_STABLEPTRS
 847 extern  Int  mkStablePtr     Args((Cell));
 848 extern  Cell derefStablePtr  Args((Int));
 849 extern  Void freeStablePtr   Args((Int));
 850 #endif /* GC_STABLEPTRS */
 851
 852 /* --------------------------------------------------------------------------
 853  * Plugins
 854  * ------------------------------------------------------------------------*/
 855
 856 #if PLUGINS
 857 /* This is an exact copy of the declaration found in GreenCard.h */
 858
 859 typedef int     HugsStackPtr;
 860 typedef int     HugsStablePtr;
 861 typedef Pointer HugsForeign;
 862
 863 typedef struct {
 864
 865   /* evaluate next argument */
 866   int            (*getInt   )     Args(());
 867   unsigned int   (*getWord  )     Args(());
 868   void*          (*getAddr  )     Args(());
 869   float          (*getFloat )     Args(());
 870   double         (*getDouble)     Args(());
 871   char           (*getChar  )     Args(());
 872   HugsForeign    (*getForeign)    Args(());
 873   HugsStablePtr  (*getStablePtr)  Args(());
 874
 875   /* push part of result   */
 876   void           (*putInt   )     Args((int));
 877   void           (*putWord  )     Args((unsigned int));
 878   void           (*putAddr  )     Args((void*));
 879   void           (*putFloat )     Args((double));
 880   void           (*putDouble)     Args((double));
 881   void           (*putChar  )     Args((char));
 882   void           (*putForeign)    Args((HugsForeign, void (*)(HugsForeign)));
 883   void           (*putStablePtr)  Args((HugsStablePtr));
 884
 885   /* return n values in IO monad or Id monad */
 886   void           (*returnIO)      Args((HugsStackPtr, int));
 887   void           (*returnId)      Args((HugsStackPtr, int));
 888   int            (*runIO)         Args((int));
 889
 890   /* free a stable pointer */
 891   void           (*freeStablePtr) Args((HugsStablePtr));
 892
 893   /* register the prim table */
 894   void           (*registerPrims) Args((struct primInfo*));
 895
 896   /* garbage collect */
 897   void           (*garbageCollect) Args(());
 898
 899 } HugsAPI2;
 900
 901 extern  HugsAPI2* hugsAPI2     Args((Void));
 902 typedef Void (*InitModuleFun2) Args((HugsAPI2*));
 903
 904 typedef struct {
 905   Name  nameTrue, nameFalse;
 906   Name  nameNil,  nameCons;
 907   Name  nameJust, nameNothing;
 908   Name  nameLeft, nameRight;
 909   Name  nameUnit;
 910   Name  nameIORun;
 911
 912   Cell  (*makeInt)         Args((Int));
 913
 914   Cell  (*makeChar)        Args((Char));
 915   Char  (*CharOf)          Args((Cell));
 916
 917   Cell  (*makeFloat)       Args((FloatPro));
 918   Cell  (*makeTuple)       Args((Int));
 919   Pair  (*pair)            Args((Cell,Cell));
 920
 921   Cell  (*mkMallocPtr)     Args((Void *, Void (*)(Void *)));
 922   Void *(*derefMallocPtr)  Args((Cell));
 923
 924   Int   (*mkStablePtr)     Args((Cell));
 925   Cell  (*derefStablePtr)  Args((Int));
 926   Void  (*freeStablePtr)   Args((Int));
 927
 928   Void  (*eval)            Args((Cell));
 929   Cell  (*evalWithNoError) Args((Cell));
 930   Void  (*evalFails)       Args((StackPtr));
 931   Int   *whnfArgs;
 932   Cell  *whnfHead;
 933   Int   *whnfInt;
 934   Float *whnfFloat;
 935
 936   Void  (*garbageCollect)  Args(());
 937   Void  (*stackOverflow)   Args(());
 938   Void  (*internal)        Args((String)) HUGS_noreturn;
 939
 940   Void  (*registerPrims)   Args((struct primInfo*));
 941   Name  (*addPrimCfun)     Args((Text,Int,Int,Cell));
 942   Text  (*inventText)      Args(());
 943
 944   Cell *(*Fst)             Args((Cell));
 945   Cell *(*Snd)             Args((Cell));
 946
 947   Cell  *cellStack;
 948   StackPtr *sp;
 949 } HugsAPI1;
 950
 951 extern  HugsAPI1* hugsAPI1     Args((Void));
 952 typedef Void (*InitModuleFun1) Args((HugsAPI1*));
 953 #endif /* PLUGINS */
 954
 955
 956 /* --------------------------------------------------------------------------
 957  * Misc:
 958  * ------------------------------------------------------------------------*/
 959
 960 extern  Void   setLastExpr       Args((Cell));
 961 extern  Cell   getLastExpr       Args((Void));
 962 extern  List   addTyconsMatching Args((String,List));
 963 extern  List   addNamesMatching  Args((String,List));
 964
 965 /*-------------------------------------------------------------------------*/