ghc/interpreter/storage.h

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