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.45 $
  14  * $Date: 2000/04/27 16:35:29 $
  15  * ------------------------------------------------------------------------*/
  16
  17 #define DEBUG_STORAGE               /* a moderate level of sanity checking */
  18 #define DEBUG_STORAGE_EXTRA         /* max paranoia in sanity checks       */
  19
  20 /* --------------------------------------------------------------------------
  21  * Typedefs for main data types:
  22  * Many of these type names are used to indicate the intended us of a data
  23  * item, rather than for type checking purposes.  Sadly (although sometimes,
  24  * fortunately), the C compiler cannot distinguish between the use of two
  25  * different names defined to be synonyms for the same types.
  26  * ------------------------------------------------------------------------*/
  27
  28 typedef Int          Text;                       /* text string            */
  29 typedef Unsigned     Syntax;                     /* syntax (assoc,preced)  */
  30 typedef Int          Cell;                       /* general cell value     */
  31 typedef Cell far     *Heap;                      /* storage of heap        */
  32 typedef Cell         Pair;                       /* pair cell              */
  33 typedef Int          StackPtr;                   /* stack pointer          */
  34 typedef Cell         Offset;                     /* offset/generic variable*/
  35 typedef Int          Module;                     /* module                 */
  36 typedef Cell         Tycon;                      /* type constructor       */
  37 typedef Cell         Type;                       /* type expression        */
  38 typedef Cell         Kind;                       /* kind expression        */
  39 typedef Cell         Kinds;                      /* list of kinds          */
  40 typedef Cell         Constr;                     /* constructor expression */
  41 typedef Cell         Name;                       /* named value            */
  42 typedef Cell         Class;                      /* type class             */
  43 typedef Cell         Inst;                       /* instance of type class */
  44 typedef Cell         Triple;                     /* triple of cell values  */
  45 typedef Cell         List;                       /* list of cells          */
  46 typedef Cell         Bignum;                     /* bignum integer         */
  47 typedef Cell         Float;                      /* floating pt literal    */
  48 #if TREX
  49 typedef Cell         Ext;                        /* extension label        */
  50 #endif
  51
  52 typedef Cell         ConId;
  53 typedef Cell         VarId;
  54 typedef Cell         QualId;
  55 typedef Cell         ConVarId;
  56
  57 /* --------------------------------------------------------------------------
  58  * Address ranges.
  59  *
  60  * -heapSize .. -1                                    cells in the heap
  61  * 0                                                  NIL
  62  *
  63  * TAG_NONPTR_MIN(100) .. TAG_NONPTR_MAX(116)         non pointer tags
  64  * TAG_PTR_MIN(200)    .. TAG_PTR_MAX(298)            pointer tags
  65  * TAG_SPEC_MIN(400)   .. TAG_SPEC_MAX(431)           special tags
  66  * OFF_MIN(1,000)      .. OFF_MAX(1,999)              offsets
  67  * CHARR_MIN(3,000)    .. CHARR_MAX(3,255)            chars
  68  *
  69  * SMALL_INT_MIN(100,000) .. SMALL_INT_MAX(499,999)   smallish ints
  70  *              (300,000 denotes 0)
  71  *
  72  * NAME_BASE_ADDR   (1,000,000 .. 1,899,999)          names
  73  * TYCON_BASE_ADDR  (2,000,000 .. 2,899,999)          tycons
  74  * CCLASS_BASE_ADDR (3,000,000 .. 3,899,999)          classes
  75  * INST_BASE_ADDR   (4,000,000 .. 4,899,999)          instances
  76  * MODULE_BASE_ADDR (5,000,000 .. 5,899,999)          modules
  77  * INVAR_BASE_ADDR  (6,000,000 .. 6,899,999)          invented var names
  78  * INDVAR_BASE_ADDR (7,000,000 .. 7,899,999)          invented dict var names
  79  * TEXT_BASE_ADDR   (8,000,000 .. 8M +TEXT_SIZE-1)    text
  80  * ------------------------------------------------------------------------*/
  81
  82 /* --------------------------------------------------------------------------
  83  * Text storage:
  84  * provides storage for the characters making up identifier and symbol
  85  * names, string literals, character constants etc...
  86  * ------------------------------------------------------------------------*/
  87
  88 extern  String       textToStr            ( Text );
  89 extern  Text         findText             ( String );
  90 extern  Text         inventText           ( Void );
  91 extern  Text         inventDictText       ( Void );
  92 extern  Bool         inventedText         ( Text );
  93 extern  Text         enZcodeThenFindText  ( String );
  94 extern  Text         unZcodeThenFindText  ( String );
  95
  96 /* Variants of textToStr and syntaxOf which work for idents, ops whether
  97  * qualified or unqualified.
  98  */
  99 extern  String       identToStr         ( Cell );
 100 extern  Text         fixLitText         ( Text );
 101 extern  Syntax       identSyntax        ( Cell );
 102 extern  Syntax       defaultSyntax      ( Text );
 103
 104 #define INVAR_BASE_ADDR  6000000
 105 #define INVAR_MAX_AVAIL  900000
 106 #define isInventedVar(c) (INVAR_BASE_ADDR<=(c) \
 107                           && (c)<INVAR_BASE_ADDR+INVAR_MAX_AVAIL)
 108
 109 #define INDVAR_BASE_ADDR 7000000
 110 #define INDVAR_MAX_AVAIL 900000
 111 #define isInventedDictVar(c) (INDVAR_BASE_ADDR<=(c) \
 112                               && (c)<INDVAR_BASE_ADDR+INDVAR_MAX_AVAIL)
 113
 114 #define TEXT_BASE_ADDR   8000000
 115 #define isText(c) (TEXT_BASE_ADDR<=(c) \
 116                   && (c)<TEXT_BASE_ADDR+TEXT_SIZE)
 117
 118 /* --------------------------------------------------------------------------
 119  * Specification of syntax (i.e. default written form of application)
 120  * ------------------------------------------------------------------------*/
 121
 122 #define MIN_PREC  0                    /* weakest binding operator         */
 123 #define MAX_PREC  9                    /* strongest binding operator       */
 124 #define FUN_PREC  (MAX_PREC+2)         /* binding of function symbols      */
 125 #define DEF_PREC  MAX_PREC
 126 #define APPLIC    0                    /* written applicatively            */
 127 #define LEFT_ASS  1                    /* left associative infix           */
 128 #define RIGHT_ASS 2                    /* right associative infix          */
 129 #define NON_ASS   3                    /* non associative infix            */
 130 #define DEF_ASS   LEFT_ASS
 131
 132 #define UMINUS_PREC  6                  /* Change these settings at your   */
 133 #define UMINUS_ASSOC LEFT_ASS           /* own risk; they may not work!    */
 134
 135 #define assocOf(x)      ((x)&NON_ASS)
 136 #define precOf(x)       ((x)>>2)
 137 #define mkSyntax(a,p)   ((a)|((p)<<2))
 138 #define DEF_OPSYNTAX    mkSyntax(DEF_ASS,DEF_PREC)
 139 #define NO_SYNTAX       (-1)
 140
 141 extern  Void   addSyntax  ( Int,Text,Syntax );
 142 extern  Syntax syntaxOf   ( Text );
 143
 144 /* --------------------------------------------------------------------------
 145  * Heap storage:
 146  * Provides a garbage collectable heap for storage of expressions etc.
 147  * ------------------------------------------------------------------------*/
 148
 149 #define heapAlloc(s) (Heap)(farCalloc(s,sizeof(Cell)))
 150 extern  Int          heapSize;
 151 extern  Heap         heapFst, heapSnd;
 152 extern  Heap         heapTopFst;
 153 extern  Heap         heapTopSnd;
 154 extern  Bool         consGC;            /* Set to FALSE to turn off gc from*/
 155                                         /* C stack; use with extreme care! */
 156 extern  Int          cellsRecovered;    /* cells recovered by last gc      */
 157
 158 #define fst(c)       heapTopFst[c]
 159 #define snd(c)       heapTopSnd[c]
 160
 161 extern  Pair         pair            ( Cell,Cell );
 162 extern  Void         garbageCollect  ( Void );
 163 extern  Void         mark            ( Cell );
 164
 165 #define isPair(c)    ((c)<0)
 166 #define isGenPair(c) ((c)<0 && -heapSize<=(c))
 167
 168 extern  Cell         whatIs    ( Cell );
 169
 170 /* --------------------------------------------------------------------------
 171  * Pairs in the heap fall into three categories.
 172  *
 173  * pair(TAG_NONPTR,y)
 174  *    used to denote that the second element of the pair is to be treated
 175  *    in some special way (eg is a integer or Text), and specifically is not
 176  *    a heap pointer
 177  *
 178  * pair(TAG_PTR,y)
 179  *    to indicate that the second element of the pair is a normal
 180  *    heap pointer, which should be followed at GC time
 181  *
 182  * pair(x,y)
 183  *    is a genuine pair, where both components are heap pointers.
 184  * ------------------------------------------------------------------------*/
 185
 186 #if !defined(SIZEOF_VOID_P) || !defined(SIZEOF_INT)
 187 #error SIZEOF_VOID_P or SIZEOF_INT is not defined
 188 #endif
 189
 190 #define isTagNonPtr(c) (TAG_NONPTR_MIN<=(c) && (c)<=TAG_NONPTR_MAX)
 191 #define isTagPtr(c)    (TAG_PTR_MIN<=(c) && (c)<=TAG_PTR_MAX)
 192 #define isTag(c)       (isTagNonPtr(c) || isTagPtr(c))
 193
 194 /* --------------------------------------------------------------------------
 195  * Tags for non-pointer cells.
 196  * ------------------------------------------------------------------------*/
 197
 198 #define TAG_NONPTR_MIN 100
 199 #define TAG_NONPTR_MAX 116
 200
 201 #define FREECELL     100          /* Free list cell:          snd :: Cell  */
 202 #define VARIDCELL    101          /* Identifier variable:     snd :: Text  */
 203 #define VAROPCELL    102          /* Operator variable:       snd :: Text  */
 204 #define DICTVAR      103          /* Dictionary variable:     snd :: Text  */
 205 #define CONIDCELL    104          /* Identifier constructor:  snd :: Text  */
 206 #define CONOPCELL    105          /* Operator constructor:    snd :: Text  */
 207 #define STRCELL      106          /* String literal:          snd :: Text  */
 208 #define INTCELL      107          /* Int literal:             snd :: Int   */
 209 #define ADDPAT       108          /* (_+k) pattern discr:     snd :: Int   */
 210 #define FLOATCELL    109          /* Floating Pt literal:     snd :: Text  */
 211 #define BIGCELL      110          /* Integer literal:         snd :: Text  */
 212 #define ADDRCELL     111          /* Address literal          snd :: Ptr   */
 213 #define MPTRCELL     112          /* C (malloc) Heap Pointer  snd :: Ptr   */
 214 #define CPTRCELL     113          /* Closure pointer          snd :: Ptr   */
 215
 216 #if IPARAM
 217 #define IPCELL       114          /* Imp Param Cell:          snd :: Text  */
 218 #define IPVAR        115          /* ?x:                      snd :: Text  */
 219 #endif
 220
 221 #if TREX
 222 #define EXTCOPY      116          /* Copy of an Ext:          snd :: Text  */
 223 #endif
 224
 225 #define qmodOf(c)       (textOf(fst(snd(c))))    /* c ::  QUALIDENT        */
 226 #define qtextOf(c)      (textOf(snd(snd(c))))    /* c ::  QUALIDENT        */
 227 #define mkVar(t)        ap(VARIDCELL,t)
 228 #define mkVarop(t)      ap(VAROPCELL,t)
 229 #define mkCon(t)        ap(CONIDCELL,t)
 230 #define mkConop(t)      ap(CONOPCELL,t)
 231 #define mkQVar(m,t)     ap(QUALIDENT,pair(mkCon(m),mkVar(t)))
 232 #define mkQCon(m,t)     ap(QUALIDENT,pair(mkCon(m),mkCon(t)))
 233 #define mkQVarOp(m,t)   ap(QUALIDENT,pair(mkCon(m),mkVarop(t)))
 234 #define mkQConOp(m,t)   ap(QUALIDENT,pair(mkCon(m),mkConop(t)))
 235 #define mkQualId(m,t)   ap(QUALIDENT,pair(m,t))
 236 #define intValOf(c)     (snd(c))
 237 #define inventVar()     mkVar(inventText())
 238 #define mkDictVar(t)    ap(DICTVAR,t)
 239 #define inventDictVar() mkDictVar(inventDictText())
 240 #define mkStr(t)        ap(STRCELL,t)
 241 #if IPARAM
 242 #define mkIParam(c)     ap(IPCELL,snd(c))
 243 #define isIP(p)         (whatIs(p) == IPCELL)
 244 #define ipMatch(pi, t)  (isIP(fun(pi)) && textOf(fun(pi)) == t)
 245 #define ipVar(pi)       textOf(fun(pi))
 246 #else
 247 #define isIP(p)         FALSE
 248 #endif
 249
 250 extern  Bool            isVar        ( Cell );
 251 extern  Bool            isCon        ( Cell );
 252 extern  Bool            isQVar       ( Cell );
 253 extern  Bool            isQCon       ( Cell );
 254 extern  Bool            isQualIdent  ( Cell );
 255 extern  Bool            eqQualIdent  ( QualId c1, QualId c2 );
 256 extern  Bool            isIdent      ( Cell );
 257 extern  String          stringNegate ( String );
 258 extern  Text            textOf       ( Cell );
 259
 260 #define isFloat(c)       (isPair(c) && fst(c)==FLOATCELL)
 261 #define stringToFloat(s) pair(FLOATCELL,findText(s))
 262 #define floatToString(f) textToStr(snd(f))
 263 #define floatOf(f)       atof(floatToString(f))
 264 #define mkFloat(f)       (f)  /* ToDo: is this right? */
 265 #define floatNegate(f)   stringToFloat(stringNegate(floatToString(f)))
 266
 267 #define stringToBignum(s) pair(BIGCELL,findText(s))
 268 #define bignumToString(b) textToStr(snd(b))
 269
 270 #define isMPtr(c)       (isPair(c) && fst(c)==MPTRCELL)
 271 extern  Cell            mkMPtr          ( Ptr );
 272 extern  Ptr             mptrOf          ( Cell );
 273 #define isCPtr(c)       (isPair(c) && fst(c)==CPTRCELL)
 274 extern  Cell            mkCPtr          ( Ptr );
 275 extern  Ptr             cptrOf          ( Cell );
 276 #define isAddr(c)       (isPair(c) && fst(c)==ADDRCELL)
 277 extern  Cell            mkAddr          ( Ptr );
 278 extern  Ptr             addrOf          ( Cell );
 279
 280 /* --------------------------------------------------------------------------
 281  * Tags for pointer cells.
 282  * ------------------------------------------------------------------------*/
 283
 284 #define TAG_PTR_MIN 200
 285 #define TAG_PTR_MAX 299
 286
 287 #define LETREC       200          /* LETREC     snd :: ([Decl],Exp)        */
 288 #define COND         201          /* COND       snd :: (Exp,Exp,Exp)       */
 289 #define LAMBDA       202          /* LAMBDA     snd :: Alt                 */
 290 #define FINLIST      203          /* FINLIST    snd :: [Exp]               */
 291 #define DOCOMP       204          /* DOCOMP     snd :: (Exp,[Qual])        */
 292 #define BANG         205          /* BANG       snd :: Type                */
 293 #define COMP         206          /* COMP       snd :: (Exp,[Qual])        */
 294 #define ASPAT        207          /* ASPAT      snd :: (Var,Exp)           */
 295 #define ESIGN        208          /* ESIGN      snd :: (Exp,Type)          */
 296 #define RSIGN        209          /* RSIGN      snd :: (Rhs,Type)          */
 297 #define CASE         210          /* CASE       snd :: (Exp,[Alt])         */
 298 #define NUMCASE      211          /* NUMCASE    snd :: (Exp,Disc,Rhs)      */
 299 #define FATBAR       212          /* FATBAR     snd :: (Exp,Exp)           */
 300 #define LAZYPAT      213          /* LAZYPAT    snd :: Exp                 */
 301 #define DERIVE       214          /* DERIVE     snd :: Cell                */
 302 #define BOOLQUAL     215          /* BOOLQUAL   snd :: Exp                 */
 303 #define QWHERE       216          /* QWHERE     snd :: [Decl]              */
 304 #define FROMQUAL     217          /* FROMQUAL   snd :: (Exp,Exp)           */
 305 #define DOQUAL       218          /* DOQUAL     snd :: Exp                 */
 306 #define MONADCOMP    219          /* MONADCOMP  snd :: ((m,m0),(Exp,[Qual])*/
 307 #define GUARDED      220          /* GUARDED    snd :: [guarded exprs]     */
 308 #define ARRAY        221          /* Array      snd :: (Bounds,[Values])   */
 309 #define MUTVAR       222          /* Mutvar     snd :: Cell                */
 310 #define HUGSOBJECT   223          /* HUGSOBJECT snd :: Cell                */
 311
 312 #if IPARAM
 313 #define WITHEXP      224          /* WITHEXP    snd :: [(Var,Exp)]         */
 314 #endif
 315
 316 #define POLYTYPE     225          /* POLYTYPE   snd :: (Kind,Type)         */
 317 #define QUAL         226          /* QUAL       snd :: ([Classes],Type)    */
 318 #define RANK2        227          /* RANK2      snd :: (Int,Type)          */
 319 #define EXIST        228          /* EXIST      snd :: (Int,Type)          */
 320 #define POLYREC      229          /* POLYREC    snd :: (Int,Type)          */
 321 #define BIGLAM       230          /* BIGLAM     snd :: (vars,patterns)     */
 322 #define CDICTS       231          /* CDICTS     snd :: ([Pred],Type)       */
 323
 324 #define LABC         232          /* LABC       snd :: (con,[(Vars,Type)]) */
 325 #define CONFLDS      233          /* CONFLDS    snd :: (con,[Field])       */
 326 #define UPDFLDS      234          /* UPDFLDS    snd :: (Exp,[con],[Field]) */
 327 #if TREX
 328 #define RECORD       235          /* RECORD     snd :: [Val]               */
 329 #define EXTCASE      236          /* EXTCASE    snd :: (Exp,Disc,Rhs)      */
 330 #define RECSEL       237          /* RECSEL     snd :: Ext                 */
 331 #endif
 332 #define IMPDEPS      238          /* IMPDEPS    snd :: [Binding]           */
 333
 334 #define QUALIDENT    239          /* Qualified identifier  snd :: (Id,Id)  */
 335 #define HIDDEN       240          /* hiding import list    snd :: [Entity] */
 336 #define MODULEENT    241          /* module in export list snd :: con      */
 337
 338 #define INFIX        242          /* INFIX      snd :: (see tidyInfix)     */
 339 #define ONLY         243          /* ONLY       snd :: Exp                 */
 340 #define NEG          244          /* NEG        snd :: Exp                 */
 341
 342 /* Used when parsing GHC interface files */
 343 #define DICTAP       245          /* DICTAP     snd :: (QClassId,[Type])   */
 344 #define UNBOXEDTUP   246          /* UNBOXEDTUP snd :: [Type]              */
 345
 346 #if SIZEOF_VOID_P != SIZEOF_INT
 347 #define PTRCELL      247          /* C Heap Pointer snd :: (Int,Int)       */
 348 #endif
 349
 350 /* STG syntax */
 351 #define STGVAR       248          /* STGVAR     snd :: (StgRhs,info)       */
 352 #define STGAPP       249          /* STGAPP     snd :: (StgVar,[Arg])      */
 353 #define STGPRIM      250          /* STGPRIM    snd :: (PrimOp,[Arg])      */
 354 #define STGCON       251          /* STGCON     snd :: (StgCon,[Arg])      */
 355 #define PRIMCASE     252          /* PRIMCASE   snd :: (Expr,[PrimAlt])    */
 356 #define DEEFALT      253          /* DEEFALT    snd :: (Var,Expr)          */
 357 #define CASEALT      254          /* CASEALT    snd :: (Con,[Var],Expr)    */
 358 #define PRIMALT      255          /* PRIMALT    snd :: ([Var],Expr)        */
 359
 360 /* Module groups */
 361 #define GRP_REC      256          /* GRP_REC    snd :: [CONID]             */
 362 #define GRP_NONREC   257          /* GRP_NONREC snd :: CONID               */
 363
 364
 365 /*
 366    Top-level interface entities
 367    type Line             = Int  -- a line number
 368    type ConVarId         = CONIDCELL | VARIDCELL
 369    type ExportListEntry  = ConVarId | (ConId, [ConVarId])
 370    type Associativity    = mkInt of LEFT_ASS | RIGHT_ASS | NON_ASS
 371    type Constr           = ((ConId, [((Type,VarId,Int))]))
 372                ((constr name, [((type, field name if any, strictness))]))
 373                strictness: 0 => none, 1 => !, 2 => !! (unpacked)
 374    All 2/3/4/5 tuples in the interface abstract syntax are done with
 375    z-tuples.
 376 */
 377
 378 #define I_INTERFACE  260  /* snd :: ((ConId, [I_IMPORT..I_VALUE]))
 379                                     interface name, list of iface entities */
 380
 381 #define I_IMPORT     261  /* snd :: ((ConId, [ConVarId]))
 382                                     module name, list of entities          */
 383
 384 #define I_INSTIMPORT 262  /* snd :: NIL    -- not used at present          */
 385
 386 #define I_EXPORT     263  /* snd :: ((ConId, [ExportListEntry]))
 387                                     this module name?, entities to export  */
 388
 389 #define I_FIXDECL    264  /* snd :: ((NIL|Int, Associativity, ConVarId))
 390                                     fixity, associativity, name            */
 391
 392 #define I_INSTANCE   265 /* snd :: ((Line,
 393                                      [((VarId,Kind))],
 394                                      Type, VarId, Inst))
 395                    lineno,
 396                    forall-y bit (eg __forall [a b] =>),
 397                    other bit, eg { C a1 } -> { C2 a2 } -> ... -> { Cn an },
 398                    name of dictionary builder,
 399                    (after startGHCInstance) the instance table location    */
 400
 401 #define I_TYPE       266 /* snd :: ((Line, ConId, [((VarId,Kind))], Type))
 402                             lineno, tycon, kinded tyvars, the type expr    */
 403
 404 #define I_DATA       267 /* snd :: ((Line, [((QConId,VarId))], ConId,
 405                                           [((VarId,Kind))], [Constr])
 406                             lineno, context, tycon, kinded tyvars, constrs
 407                            An empty constr list means exported abstractly. */
 408
 409 #define I_NEWTYPE    268 /* snd :: ((Line, [((QConId,VarId))], ConId,
 410                                     [((VarId,Kind))], ((ConId,Type)) ))
 411                              lineno, context, tycon, kinded tyvars, constr
 412                                     constr==NIL means exported abstractly. */
 413
 414 #define I_CLASS      269 /* snd :: ((Line, [((QConId,VarId))], ConId,
 415                                     [((VarId,Kind))], [((VarId,Type))]))
 416                             lineno, context, classname,
 417                                       kinded tyvars, method sigs           */
 418
 419 #define I_VALUE      270 /* snd :: ((Line, VarId, Type))                   */
 420
 421 /*
 422    Top-level module entities.
 423
 424    type Export = ?
 425 */
 426 #define M_MODULE     280 /* snd :: ((ConId, [Export],
 427                                      M_IMPORT_Q .. M_VALUE]))
 428                             module name, export spec, top level entities   */
 429
 430 #define M_IMPORT_Q   281 /* snd :: ((?,?)) */
 431 #define M_IMPORT_UNQ 282 /* snd :: ((?,?)) */
 432 #define M_TYCON      283 /* snd :: ((Line,?,?,?)) */
 433 #define M_CLASS      284 /* snd :: ((Line,?,?,?)) */
 434 #define M_INST       285 /* snd :: ((Line,?,?)) */
 435 #define M_DEFAULT    286 /* snd :: ((Line,?)) */
 436 #define M_FOREIGN_EX 289 /* snd :: ((Line,?,?,?,?)) */
 437 #define M_FOREIGN_IM 290 /* snd :: ((Line,?,?,?,?)) */
 438 #define M_VALUE      291 /* snd :: ? */
 439
 440
 441
 442
 443 /*
 444    Tagged tuples.
 445 */
 446 #define ZTUP2        295          /* snd :: (Cell,Cell)                    */
 447 #define ZTUP3        296          /* snd :: (Cell,(Cell,Cell))             */
 448 #define ZTUP4        297          /* snd :: (Cell,(Cell,(Cell,Cell)))      */
 449 #define ZTUP5        298       /* snd :: (Cell,(Cell,(Cell,(Cell,Cell))))  */
 450
 451 #define MDOCOMP      299          /* MDOCOMP     snd :: (Exp,[Qual])       */
 452
 453
 454 /* --------------------------------------------------------------------------
 455  * Special cell values.
 456  * ------------------------------------------------------------------------*/
 457
 458 #define TAG_SPEC_MIN 400
 459 #define TAG_SPEC_MAX 431
 460
 461 #define isSpec(c) (TAG_SPEC_MIN<=(c) && (c)<=TAG_SPEC_MAX)
 462
 463 #define NONE         400          /* Dummy stub                            */
 464 #define STAR         401          /* Representing the kind of types        */
 465 #if TREX
 466 #define ROW          402          /* Representing the kind of rows         */
 467 #endif
 468 #define WILDCARD     403          /* Wildcard pattern                      */
 469 #define SKOLEM       404          /* Skolem constant                       */
 470
 471 #define DOTDOT       405          /* ".." in import/export list            */
 472
 473 #define NAME         406          /* whatIs code for isName                */
 474 #define TYCON        407          /* whatIs code for isTycon               */
 475 #define CLASS        408          /* whatIs code for isClass               */
 476 #define MODULE       409          /* whatIs code for isModule              */
 477 #define INSTANCE     410          /* whatIs code for isInst                */
 478 #define TUPLE        411          /* whatIs code for tuple constructor     */
 479 #define OFFSET       412          /* whatis code for offset                */
 480 #define AP           413          /* whatIs code for application node      */
 481 #define CHARCELL     414          /* whatIs code for isChar                */
 482 #if TREX
 483 #define EXT          415          /* whatIs code for isExt                 */
 484 #endif
 485
 486 #define SIGDECL      416          /* Signature declaration                 */
 487 #define FIXDECL      417          /* Fixity declaration                    */
 488 #define FUNBIND      418          /* Function binding                      */
 489 #define PATBIND      419          /* Pattern binding                       */
 490
 491 #define DATATYPE     420          /* Datatype type constructor             */
 492 #define NEWTYPE      421          /* Newtype type constructor              */
 493 #define SYNONYM      422          /* Synonym type constructor              */
 494 #define RESTRICTSYN  423          /* Synonym with restricted scope         */
 495
 496 #define NODEPENDS    424          /* Stop calculation of deps in type check*/
 497 #define PREDEFINED   425          /* Predefined name, not yet filled       */
 498 #define TEXTCELL     426          /* whatIs code for isText                */
 499 #define INVAR        427          /* whatIs code for isInventedVar         */
 500 #define INDVAR       428          /* whatIs code for isInventedDictVar     */
 501
 502 #define FM_SOURCE    429          /* denotes source module (FileMode)      */
 503 #define FM_OBJECT    430          /* denotes object module                 */
 504 #define FM_EITHER    431          /* no restriction; either is allowed     */
 505
 506
 507 /* --------------------------------------------------------------------------
 508  * Tuple data/type constructors:
 509  * ------------------------------------------------------------------------*/
 510
 511 extern Text ghcTupleText    ( Tycon );
 512 extern Text ghcTupleText_n  ( Int );
 513
 514
 515
 516 #if TREX
 517 #error TREX not supported
 518 #define EXTMIN       301
 519 #define isExt(c)     (EXTMIN<=(c) && (c)<OFFMIN)
 520 #define extText(e)   tabExt[(e)-EXTMIN]
 521 #define extField(c)  arg(fun(c))
 522 #define extRow(c)    arg(c)
 523
 524 extern Text          DECTABLE(tabExt);
 525 extern Ext           mkExt ( Text );
 526 #else
 527 #define mkExt(t) NIL
 528 #endif
 529
 530 extern Module        findFakeModule ( Text t );
 531 extern Tycon         addTupleTycon ( Int n );
 532 extern Name          addWiredInBoxingTycon
 533                         ( String modNm, String typeNm, String constrNm,
 534                           Int rep, Kind kind );
 535 extern Tycon         addWiredInEnumTycon
 536                         ( String modNm, String typeNm,
 537                           List /*of Text*/ constrs );
 538
 539 /* --------------------------------------------------------------------------
 540  * Offsets: (generic types/stack offsets)
 541  * ------------------------------------------------------------------------*/
 542
 543 #define OFF_MIN 1000
 544 #define OFF_MAX 1999
 545
 546 #define isOffset(c)  (OFF_MIN<=(c) && (c)<=OFF_MAX)
 547 #define offsetOf(c)  ((c)-OFF_MIN)
 548 #define mkOffset(o)  (OFF_MIN+(o))
 549
 550
 551 /* --------------------------------------------------------------------------
 552  * Modules:
 553  * ------------------------------------------------------------------------*/
 554
 555 #define MODULE_BASE_ADDR     5000000
 556 #define MODULE_MAX_SIZE      900000
 557 #define MODULE_INIT_SIZE     4
 558
 559 #ifdef DEBUG_STORAGE
 560 extern struct strModule* generate_module_ref ( Cell );
 561 #define module(mod)  (*generate_module_ref(mod))
 562 #else
 563 #define module(mod)   tabModule[(mod)-MODULE_BASE_ADDR]
 564 #endif
 565
 566 #define mkModule(n)   (MODULE_BASE_ADDR+(n))
 567 #define isModule(c)   (MODULE_BASE_ADDR<=(c)                  \
 568                        && (c)<MODULE_BASE_ADDR+tabModuleSz    \
 569                        && tabModule[(c)-MODULE_BASE_ADDR].inUse)
 570
 571
 572 /* Import defns for the ObjectCode struct in Module. */
 573 #include "object.h"
 574
 575 /* Import a machine-dependent definition of Time, for module timestamps. */
 576 #include "machdep_time.h"
 577
 578 /* Under Haskell 1.3, the list of qualified imports is always a subset
 579  * of the list of unqualified imports.  For simplicity and flexibility,
 580  * we do not attempt to exploit this fact - when a module is imported
 581  * unqualified, it is added to both the qualified and unqualified
 582  * import lists.
 583  * Similarily, Haskell 1.3 does not allow a constructor to be imported
 584  * or exported without exporting the type it belongs to but the export
 585  * list is just a flat list of Texts (before static analysis) or
 586  * Tycons, Names and Classes (after static analysis).
 587  */
 588 struct strModule {
 589    Bool   inUse;
 590    Name   nextFree;
 591
 592    Text   text;        /* Name of this module                              */
 593
 594    List   tycons;      /* Lists of top level objects ...                   */
 595    List   names;       /* (local defns + imports)                          */
 596    List   classes;
 597    List   exports;     /* [ Entity | (Entity, NIL|DOTDOT) ]                */
 598
 599    List   qualImports; /* Qualified imports.                               */
 600
 601    List   codeList;    /* [ Name | StgTree ] before code generation,
 602                           [ Name | CPtr ] afterwards                       */
 603
 604    Bool   fake;        /* TRUE if module exists only via GHC primop        */
 605                        /* defn; usually FALSE                              */
 606
 607    Cell   tree;        /* Parse tree for mod or iface                      */
 608    Bool   completed;   /* Fully loaded or just parsed?                     */
 609    Time   lastStamp;   /* Time of last parse                               */
 610
 611    Cell   mode;        /* FM_SOURCE or FM_OBJECT                           */
 612    Text   srcExt;      /* if mode==FM_SOURCE ".lhs", ".hs", etc            */
 613    List   uses;        /* :: [CONID] -- names of mods imported by this one */
 614
 615    Text   objName;     /* Name of the primary object code file.            */
 616    Int    objSize;     /* Size of the primary object code file.            */
 617
 618    ObjectCode* object;        /* Primary object code for this module.      */
 619    ObjectCode* objectExtras;  /* And any extras it might need.             */
 620    List   objectExtraNames;   /* :: [Text] -- names of extras              */
 621 };
 622
 623 extern struct strModule* tabModule;
 624 extern Int               tabModuleSz;
 625
 626 extern Module currentModule;           /* Module currently being processed */
 627 extern List   moduleGraph;             /* :: [GRP_REC | GRP_NONREC]        */
 628 extern List   prelModules;             /* :: [CONID]                       */
 629 extern List   targetModules;           /* :: [CONID]                       */
 630 extern Bool   nukeModule_needs_major_gc; /* see comment in compiler.c      */
 631
 632 extern Bool         isValidModule   ( Module );
 633 extern Module       newModule       ( Text );
 634 extern Void         nukeModule      ( Module );
 635 extern Module       findModule      ( Text );
 636 extern Module       findModid       ( Cell );
 637 extern Void         setCurrModule   ( Module );
 638 extern void         addToCodeList   ( Module, Cell );
 639 extern void         setNameOrTupleClosure ( Cell c, Cell closure );
 640 extern Cell         getNameOrTupleClosure ( Cell c );
 641 extern void         setNameOrTupleClosureCPtr ( Cell c,
 642                                                 void* /* StgClosure* */ cptr );
 643
 644
 645 extern void         addOTabName     ( Module,char*,void* );
 646 extern void*        lookupOTabName  ( Module,char* );
 647 extern char*        nameFromOPtr    ( void* );
 648
 649 extern void         addSection      ( Module,void*,void*,OSectionKind );
 650 extern OSectionKind lookupSection   ( void* );
 651 extern void*    lookupOExtraTabName                ( char* sym );
 652 extern void*    lookupOTabNameAbsolutelyEverywhere ( char* sym );
 653
 654 #define isPrelude(m) (m==modulePrelude)
 655
 656 #define N_PRELUDE_SCRIPTS (combined ? 32 : 1)
 657
 658 /* --------------------------------------------------------------------------
 659  * Type constructor names:
 660  * ------------------------------------------------------------------------*/
 661
 662 #define TYCON_BASE_ADDR   2000000
 663 #define TYCON_MAX_SIZE    900000
 664 #define TYCON_INIT_SIZE   4
 665
 666 #ifdef DEBUG_STORAGE
 667 extern struct strTycon* generate_tycon_ref ( Cell );
 668 #define tycon(tc)    (*generate_tycon_ref(tc))
 669 #else
 670 #define tycon(tc)    tabTycon[(tc)-TYCON_BASE_ADDR]
 671 #endif
 672
 673 #define isTycon(c)   (TYCON_BASE_ADDR<=(c)                        \
 674                       && (c)<TYCON_BASE_ADDR+tabTyconSz           \
 675                       && tabTycon[(c)-TYCON_BASE_ADDR].inUse      \
 676                       && tabTycon[(c)-TYCON_BASE_ADDR].tuple==-1)
 677 #define isTuple(c)   (TYCON_BASE_ADDR<=(c)                        \
 678                       && (c)<TYCON_BASE_ADDR+tabTyconSz           \
 679                       && tabTycon[(c)-TYCON_BASE_ADDR].inUse      \
 680                       && tabTycon[(c)-TYCON_BASE_ADDR].tuple>=0)
 681 #define tupleOf(n)   (tycon(n).tuple)
 682
 683 extern Tycon mkTuple ( Int );
 684
 685
 686 struct strTycon {
 687     Bool   inUse;
 688     Name   nextFree;
 689     Text   text;
 690     Int    line;
 691     Module mod;                         /* module that defines it          */
 692     Int    tuple;                      /* tuple number, or -1 if not tuple */
 693     Int    arity;
 694     Kind   kind;                        /* kind (includes arity) of Tycon  */
 695     Cell   what;                        /* DATATYPE/SYNONYM/RESTRICTSYN... */
 696     Cell   defn;
 697     Name   conToTag;                    /* used in derived code            */
 698     Name   tagToCon;
 699     void*  itbl;                       /* For tuples, the info tbl pointer */
 700     Cell   closure;       /* Either StgTree, or (later) CPtr, which is the
 701                              address in the evaluator's heap.  Only Tuples
 702                              use the closure field; all other tycons which
 703                              require actual code have associated name table
 704                                                                  entries.  */
 705     Tycon  nextTyconHash;
 706 };
 707
 708 extern struct strTycon* tabTycon;
 709 extern Int              tabTyconSz;
 710
 711 extern Tycon newTycon      ( Text );
 712 extern Tycon findTycon     ( Text );
 713 extern Tycon addTycon      ( Tycon );
 714 extern Tycon findQualTycon ( Cell );
 715 extern Tycon addPrimTycon  ( Text,Kind,Int,Cell,Cell );
 716
 717 #define isSynonym(h)    (isTycon(h) && tycon(h).what==SYNONYM)
 718 #define isQualType(t)   (isPair(t) && fst(t)==QUAL)
 719 #define mkPolyType(n,t) pair(POLYTYPE,pair(n,t))
 720 #define isPolyType(t)   (isPair(t) && fst(t)==POLYTYPE)
 721 #define isPolyOrQualType(t) (isPair(t) && (fst(t)==POLYTYPE || fst(t)==QUAL))
 722 #define polySigOf(t)    fst(snd(t))
 723 #define monotypeOf(t)   snd(snd(t))
 724 #define bang(t)         ap(BANG,t)
 725
 726 extern Tycon findQualTyconWithoutConsultingExportList ( QualId q );
 727
 728 extern Int numQualifiers   ( Type );
 729
 730
 731 /* --------------------------------------------------------------------------
 732  * Globally defined name values:
 733  * ------------------------------------------------------------------------*/
 734
 735 #define NAME_BASE_ADDR    1000000
 736 #define NAME_MAX_SIZE     900000
 737 #define NAME_INIT_SIZE    4
 738
 739 #ifdef DEBUG_STORAGE
 740 extern struct strName* generate_name_ref ( Cell );
 741 #define name(nm)    (*generate_name_ref(nm))
 742 #else
 743 #define name(nm)    tabName[(nm)-NAME_BASE_ADDR]
 744 #endif
 745
 746 #define mkName(n)   (NAME_BASE_ADDR+(n))
 747 #define isName(c)   (NAME_BASE_ADDR<=(c)                   \
 748                      && (c)<NAME_BASE_ADDR+tabNameSz       \
 749                      && tabName[(c)-NAME_BASE_ADDR].inUse)
 750
 751 struct strName {
 752     Bool   inUse;
 753     Name   nextFree;
 754     Text   text;
 755     Int    line;
 756     Module mod;                         /* module that defines it          */
 757     Syntax syntax;
 758     Cell   parent;
 759     Int    arity;
 760     Int    number;
 761     Cell   type;
 762     Cell   defn;
 763     Bool   hasStrict;          /* does constructor have strict components? */
 764     Text   callconv;                          /* for foreign import/export */
 765     void*  primop;                                      /* really StgPrim* */
 766     void*  itbl;                 /* For constructors, the info tbl pointer */
 767     Cell   closure;       /* Either StgTree, or (later) Ptr, an AsmBCO/
 768                              AsmCAF/AsmCon thing, or CPtr, which is the
 769                              address in the evaluator's heap               */
 770     Name   nextNameHash;
 771 };
 772
 773 extern struct strName* tabName;
 774 extern Int             tabNameSz;
 775
 776 extern int numNames (  Void  );
 777
 778 /* The number field in a name is used to distinguish various kinds of name:
 779  *   mfunNo(i) = code for member function, offset i
 780  *               members that are sole elements of dict use mfunNo(0)
 781  *               members of dicts with more than one elem use mfunNo(n), n>=1
 782  *   EXECNAME  = code for executable name (bytecodes or primitive)
 783  *   SELNAME   = code for selector function
 784  *   DFUNNAME  = code for dictionary builder or selector
 785  *   cfunNo(i) = code for data constructor
 786  *               datatypes with only one constructor uses cfunNo(0)
 787  *               datatypes with multiple constructors use cfunNo(n), n>=1
 788  */
 789
 790 #define EXECNAME        0
 791 #define SELNAME         1
 792 #define DFUNNAME        2
 793 #define CFUNNAME        3
 794
 795 #define isSfun(n)       (name(n).number==SELNAME)
 796 #define isDfun(n)       (name(n).number==DFUNNAME)
 797
 798 #define isCfun(n)       (name(n).number>=CFUNNAME)
 799 #define cfunOf(n)       (name(n).number-CFUNNAME)
 800 #define cfunNo(i)       ((i)+CFUNNAME)
 801 #define hasCfun(cs)     (nonNull(cs) && isCfun(hd(cs)))
 802
 803 #define isMfun(n)       (name(n).number<0)
 804 #define mfunOf(n)       ((-1)-name(n).number)
 805 #define mfunNo(i)       ((-1)-(i))
 806
 807 extern Name   newName         ( Text,Cell );
 808 extern Name   findName        ( Text );
 809 extern Name   addName         ( Name );
 810 extern Name   findQualName    ( Cell );
 811 extern Name   addPrimCfun     ( Text,Int,Int,Cell );
 812 extern Name   addPrimCfunREP  ( Text,Int,Int,Int );
 813 extern Int    sfunPos         ( Name,Name );
 814 extern Name   jrsFindQualName ( Text,Text );
 815
 816 extern Name findQualNameWithoutConsultingExportList ( QualId q );
 817
 818 /* --------------------------------------------------------------------------
 819  * Type class values:
 820  * ------------------------------------------------------------------------*/
 821
 822 #define INST_BASE_ADDR     4000000
 823 #define INST_MAX_SIZE      900000
 824 #define INST_INIT_SIZE     4
 825
 826 #ifdef DEBUG_STORAGE
 827 extern struct strInst* generate_inst_ref ( Cell );
 828 #define inst(in)    (*generate_inst_ref(in))
 829 #else
 830 #define inst(in)    tabInst[(in)-INST_BASE_ADDR]
 831 #endif
 832
 833 #define mkInst(n)   (INST_BASE_ADDR+(n))
 834 #define instOf(c)   ((Int)((c)-INST_BASE_ADDR))
 835 #define isInst(c)   (INST_BASE_ADDR<=(c)                   \
 836                      && (c)<INST_BASE_ADDR+tabInstSz       \
 837                      && tabInst[(c)-INST_BASE_ADDR].inUse)
 838
 839 struct strInst {
 840     Bool   inUse;
 841     Name   nextFree;
 842     Class  c;                           /* class C                         */
 843     Int    line;
 844     Module mod;                         /* module that defines it          */
 845     Kinds  kinds;                       /* Kinds of variables in head      */
 846     Cell   head;                        /* :: Pred                         */
 847     List   specifics;                   /* :: [Pred]                       */
 848     Int    numSpecifics;                /* length(specifics)               */
 849     List   implements;
 850     Name   builder;                     /* Dictionary constructor function */
 851 };
 852
 853 extern struct strInst* tabInst;
 854 extern Int             tabInstSz;
 855
 856 /* a predicate (an element :: Pred) is an application of a Class to one or
 857  * more type expressions
 858  */
 859
 860 #define CCLASS_BASE_ADDR   3000000
 861 #define CCLASS_MAX_SIZE    900000
 862 #define CCLASS_INIT_SIZE   4
 863
 864 #ifdef DEBUG_STORAGE
 865 extern struct strClass* generate_cclass_ref ( Cell );
 866 #define cclass(cl)   (*generate_cclass_ref(cl))
 867 #else
 868 #define cclass(cl)   tabClass[(cl)-CCLASS_BASE_ADDR]
 869 #endif
 870
 871 #define mkClass(n)   (CCLASS_BASE_ADDR+(n))
 872 #define isClass(c)   (CCLASS_BASE_ADDR<=(c)                   \
 873                       && (c)<CCLASS_BASE_ADDR+tabClassSz      \
 874                       && tabClass[(c)-CCLASS_BASE_ADDR].inUse)
 875
 876 struct strClass {
 877     Bool   inUse;
 878     Name   nextFree;
 879     Text   text;                        /* Name of class                   */
 880     Int    line;                        /* Line where declaration begins   */
 881     Module mod;                         /* module that declares it         */
 882     Int    level;                       /* Level in class hierarchy        */
 883     Int    arity;                       /* Number of arguments             */
 884     Kinds  kinds;                       /* Kinds of constructors in class  */
 885     List   fds;                         /* Functional Dependencies         */
 886     List   xfds;                        /* Xpanded Functional Dependencies */
 887     Cell   head;                        /* Head of class                   */
 888     Name   dcon;                        /* Dictionary constructor function */
 889     List   supers;                      /* :: [Pred]                       */
 890     Int    numSupers;                   /* length(supers)                  */
 891     List   dsels;                       /* Superclass dictionary selectors */
 892     List   members;                     /* :: [Name]                       */
 893     Int    numMembers;                  /* length(members)                 */
 894     List   defaults;                    /* :: [Name]                       */
 895     List   instances;                   /* :: [Inst]                       */
 896 };
 897
 898 extern struct strClass* tabClass;
 899 extern Int              tabClassSz;
 900
 901 extern Class newClass      ( Text );
 902 extern Class findClass     ( Text );
 903 extern Class addClass      ( Class );
 904 extern Class findQualClass ( Cell );
 905 extern Inst  newInst       ( Void );
 906 extern Inst  findFirstInst ( Tycon );
 907 extern Inst  findNextInst  ( Tycon,Inst );
 908 extern List  getAllKnownTyconsAndClasses ( void );
 909 extern Class findQualClassWithoutConsultingExportList ( QualId q );
 910
 911 /* --------------------------------------------------------------------------
 912  * Character values:
 913  * ------------------------------------------------------------------------*/
 914
 915 /* I think this assumes that NUM_CHARS==256. */
 916 #define CHARR_MIN    3000
 917 #define CHARR_MAX    3255
 918 #define isChar(c)    (CHARR_MIN<=(c) && (c)<=CHARR_MAX)
 919 #define charOf(c)    ((Char)((c)-CHARR_MIN))
 920 #define mkChar(c)    (CHARR_MIN+(((Cell)(c)) & 0xFF))
 921 #define MAXCHARVAL   (NUM_CHARS-1)
 922
 923 /* --------------------------------------------------------------------------
 924  * Small Integer values:
 925  * ------------------------------------------------------------------------*/
 926
 927 #define SMALL_INT_MIN   100000
 928 #define SMALL_INT_MAX   499999
 929 #define SMALL_INT_ZERO  (1 + SMALL_INT_MIN/2 + SMALL_INT_MAX/2)
 930 #define isSmall(c)      (SMALL_INT_MIN<=(c) && (c)<=SMALL_INT_MAX)
 931 extern  Bool isInt      ( Cell );
 932 extern  Int  intOf      ( Cell );
 933 extern  Cell mkInt      ( Int );
 934
 935 /* --------------------------------------------------------------------------
 936  * Implementation of triples:
 937  * ------------------------------------------------------------------------*/
 938
 939 #define triple(x,y,z) pair(x,pair(y,z))
 940 #define fst3(c)      fst(c)
 941 #define snd3(c)      fst(snd(c))
 942 #define thd3(c)      snd(snd(c))
 943
 944 /* --------------------------------------------------------------------------
 945  * Implementation of lists:
 946  * ------------------------------------------------------------------------*/
 947
 948 #define NIL              0
 949 #define isNull(c)        ((c)==NIL)
 950 #define nonNull(c)       (c)
 951 #define cons(x,xs)       pair(x,xs)
 952 #define singleton(x)     cons(x,NIL)
 953 #define doubleton(x,y)   cons(x,cons(y,NIL))
 954 #define tripleton(x,y,z) cons(x,cons(y,cons(z,NIL)))
 955 #define hd(c)            fst(c)
 956 #define tl(c)            snd(c)
 957
 958 extern  Int          length       ( List );
 959 extern  List         appendOnto   ( List,List );    /* destructive     */
 960 extern  List         dupOnto      ( List,List );
 961 extern  List         dupList      ( List );
 962 extern  List         revOnto      ( List, List );   /* destructive     */
 963 #define rev(xs)      revOnto((xs),NIL)              /* destructive     */
 964 #define reverse(xs)  revOnto(dupList(xs),NIL)       /* non-destructive */
 965 extern  Cell         cellIsMember ( Cell,List );
 966 extern  Cell         cellAssoc    ( Cell,List );
 967 extern  Cell         cellRevAssoc ( Cell,List );
 968 extern  Bool         eqList       ( List,List );
 969 extern  Cell         varIsMember  ( Text,List );
 970 extern  Name         nameIsMember ( Text,List );
 971 extern  QualId       qualidIsMember ( QualId, List );
 972 extern  Cell         intIsMember  ( Int,List );
 973 extern  List         replicate    ( Int,Cell );
 974 extern  List         diffList     ( List,List );    /* destructive     */
 975 extern  List         deleteCell   ( List,Cell );    /* non-destructive */
 976 extern  List         take         ( Int,List );     /* destructive     */
 977 extern  List         splitAt      ( Int,List );     /* non-destructive */
 978 extern  Cell         nth          ( Int,List );
 979 extern  List         removeCell   ( Cell,List );    /* destructive     */
 980 extern  List         dupListOnto  ( List,List );    /* non-destructive */
 981 extern  List         nubList      ( List );         /* non-destructive */
 982
 983 /* The following macros provide `inline expansion' of some common ways of
 984  * traversing, using and modifying lists:
 985  *
 986  * N.B. We use the names _f, _a, _xs, Zs, in an attempt to avoid clashes
 987  *      with identifiers used elsewhere.
 988  */
 989
 990 #define mapBasic(_init,_step)           {List Zs=(_init);\
 991                                          for(;nonNull(Zs);Zs=tl(Zs))  \
 992                                          _step;}
 993 #define mapModify(_init,_step)          mapBasic(_init,hd(Zs)=_step)
 994
 995 #define mapProc(_f,_xs)                 mapBasic(_xs,_f(hd(Zs)))
 996 #define map1Proc(_f,_a,_xs)             mapBasic(_xs,_f(_a,hd(Zs)))
 997 #define map2Proc(_f,_a,_b,_xs)          mapBasic(_xs,_f(_a,_b,hd(Zs)))
 998 #define map3Proc(_f,_a,_b,_c,_xs)       mapBasic(_xs,_f(_a,_b,_c,hd(Zs)))
 999 #define map4Proc(_f,_a,_b,_c,_d,_xs)    mapBasic(_xs,_f(_a,_b,_c,_d,hd(Zs)))
1000
1001 #define mapOver(_f,_xs)                 mapModify(_xs,_f(hd(Zs)))
1002 #define map1Over(_f,_a,_xs)             mapModify(_xs,_f(_a,hd(Zs)))
1003 #define map2Over(_f,_a,_b,_xs)          mapModify(_xs,_f(_a,_b,hd(Zs)))
1004 #define map3Over(_f,_a,_b,_c,_xs)       mapModify(_xs,_f(_a,_b,_c,hd(Zs)))
1005 #define map4Over(_f,_a,_b,_c,_d,_xs)    mapModify(_xs,_f(_a,_b,_c,_d,hd(Zs)))
1006
1007 /* This is just what you want for functions with accumulating parameters */
1008 #define mapAccum(_f,_acc,_xs)           mapBasic(_xs,_acc=_f(_acc,hd(Zs)))
1009 #define map1Accum(_f,_acc,_a,_xs)       mapBasic(_xs,_acc=_f(_acc,_a,hd(Zs)))
1010 #define map2Accum(_f,_acc,_a,_b,_xs)    mapBasic(_xs,_acc=_f(_acc,_a,_b,hd(Zs)))
1011 #define map3Accum(_f,_acc,_a,_b,_c,_xs) mapBasic(_xs,_acc=_f(_acc,_a,_b,_c,hd(Zs)))
1012
1013
1014 /* --------------------------------------------------------------------------
1015  * Strongly-typed lists (z-lists) and tuples (experimental)
1016  * ------------------------------------------------------------------------*/
1017
1018 typedef Cell ZPair;
1019 typedef Cell ZTriple;
1020 typedef Cell Z4Ble;
1021 typedef Cell Z5Ble;
1022
1023 #define isZPair(c) (whatIs((c))==ZTUP2)
1024
1025 extern Cell zpair    ( Cell x1, Cell x2 );
1026 extern Cell zfst     ( Cell zpair );
1027 extern Cell zsnd     ( Cell zpair );
1028
1029 extern Cell ztriple  ( Cell x1, Cell x2, Cell x3 );
1030 extern Cell zfst3    ( Cell zpair );
1031 extern Cell zsnd3    ( Cell zpair );
1032 extern Cell zthd3    ( Cell zpair );
1033
1034 extern Cell z4ble    ( Cell x1, Cell x2, Cell x3, Cell x4 );
1035 extern Cell zsel14   ( Cell zpair );
1036 extern Cell zsel24   ( Cell zpair );
1037 extern Cell zsel34   ( Cell zpair );
1038 extern Cell zsel44   ( Cell zpair );
1039
1040 extern Cell z5ble    ( Cell x1, Cell x2, Cell x3, Cell x4, Cell x5 );
1041 extern Cell zsel15   ( Cell zpair );
1042 extern Cell zsel25   ( Cell zpair );
1043 extern Cell zsel35   ( Cell zpair );
1044 extern Cell zsel45   ( Cell zpair );
1045 extern Cell zsel55   ( Cell zpair );
1046
1047 extern Cell unap     ( int tag, Cell c );
1048
1049
1050 /* --------------------------------------------------------------------------
1051  * Implementation of function application nodes:
1052  * ------------------------------------------------------------------------*/
1053
1054 #define ap(f,x)      pair(f,x)
1055 #define ap1(f,x)     ap(f,x)
1056 #define ap2(f,x,y)   ap(ap(f,x),y)
1057 #define ap3(f,x,y,z) ap(ap(ap(f,x),y),z)
1058 #define fun(c)       fst(c)
1059 #define arg(c)       snd(c)
1060 #define isAp(c)      (isPair(c) && !isTag(fst(c)))
1061
1062 extern  Cell         getHead     ( Cell );
1063 extern  List         getArgs     ( Cell );
1064 extern  Cell         nthArg      ( Int,Cell );
1065 extern  Int          numArgs     ( Cell );
1066 extern  Cell         applyToArgs ( Cell,List );
1067 extern  Int          argCount;
1068
1069 /* --------------------------------------------------------------------------
1070  * Stack implementation:
1071  *
1072  * NB: Use of macros makes order of evaluation hard to predict.
1073  *     For example, "push(1+pop());" doesn't increment TOS.
1074  * ------------------------------------------------------------------------*/
1075
1076 extern  Cell cellStack[];
1077 extern  StackPtr sp;
1078
1079 #define clearStack() sp=(-1)
1080 #define stackEmpty() (sp==(-1))
1081 #define stack(p)     cellStack[p]
1082 #define chkStack(n)  if (sp>=NUM_STACK-(n)) hugsStackOverflow()
1083 #define push(c)      do { chkStack(1); onto(c); } while (0)
1084 #define onto(c)      stack(++sp)=(c);
1085 #define pop()        stack(sp--)
1086 #define drop()       sp--
1087 #define top()        stack(sp)
1088 #define pushed(n)    stack(sp-(n))
1089 #define topfun(f)    top()=ap((f),top())
1090 #define toparg(x)    top()=ap(top(),(x))
1091 #define getsp()      sp
1092
1093 extern  Void hugsStackOverflow ( Void );
1094
1095 #if SYMANTEC_C
1096 #include <Memory.h>
1097 #define STACK_HEADROOM 16384
1098 #define STACK_CHECK if (StackSpace() <= STACK_HEADROOM) \
1099                       internal("Macintosh function parameter stack overflow.");
1100 #else
1101 #define STACK_CHECK
1102 #endif
1103
1104 /* --------------------------------------------------------------------------
1105  * Misc:
1106  * ------------------------------------------------------------------------*/
1107
1108 extern  Void   setLastExpr          ( Cell );
1109 extern  Cell   getLastExpr          ( Void );
1110 extern  List   addTyconsMatching    ( String,List );
1111 extern  List   addNamesMatching     ( String,List );
1112
1113 extern  Tycon  findTyconInAnyModule ( Text t );
1114 extern  Class  findClassInAnyModule ( Text t );
1115 extern  Name   findNameInAnyModule  ( Text t );
1116
1117 extern  Void   print                ( Cell, Int );
1118 extern  void   dumpTycon            ( Int t );
1119 extern  void   dumpName             ( Int n );
1120 extern  void   dumpClass            ( Int c );
1121 extern  void   dumpInst             ( Int i );
1122 extern  void   locateSymbolByName   ( Text t );
1123
1124 /*-------------------------------------------------------------------------*/