ghc/interpreter/connect.h

   1
   2 /* --------------------------------------------------------------------------
   3  * Connections between components of the Hugs system
   4  *
   5  * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
   6  * Yale Haskell Group, and the Oregon Graduate Institute of Science and
   7  * Technology, 1994-1999, All rights reserved.  It is distributed as
   8  * free software under the license in the file "License", which is
   9  * included in the distribution.
  10  *
  11  * $RCSfile: connect.h,v $
  12  * $Revision: 1.32 $
  13  * $Date: 2000/03/22 18:14:22 $
  14  * ------------------------------------------------------------------------*/
  15
  16 /* --------------------------------------------------------------------------
  17  * Connections to Prelude entities:
  18  * Texts, Names, Instances, Classes, Types, Kinds and Modules
  19  * ------------------------------------------------------------------------*/
  20
  21 extern Text  textPrelude;
  22 extern Text  textNum;                   /* used to process default decls   */
  23 extern Text  textCcall;                 /* used to process foreign import  */
  24 extern Text  textStdcall;               /*         ... and foreign export  */
  25 extern Text  textPlus;                  /* Used to recognise n+k patterns  */
  26
  27
  28 extern Name  nameFalse, nameTrue;
  29 extern Name  nameNil,   nameCons;
  30 extern Name  nameJust,  nameNothing;
  31 extern Name  nameLeft,  nameRight;
  32 extern Name  nameUnit;
  33 extern Name  nameLT,      nameEQ;
  34 extern Name  nameGT;
  35 extern Name  nameFst,     nameSnd;      /* standard combinators            */
  36 extern Name  nameId,      nameOtherwise;
  37 extern Name  nameNegate,  nameFlip;     /* primitives reqd for parsing     */
  38 extern Name  nameFrom,    nameFromThen;
  39 extern Name  nameFromTo,  nameFromThenTo;
  40 extern Name  nameFatbar,  nameFail;     /* primitives reqd for translation */
  41 extern Name  nameIf,      nameSel;
  42 extern Name  nameCompAux;
  43 extern Name  namePmInt,   namePmFlt;    /* primitives for pattern matching */
  44 extern Name  namePmInteger;
  45 extern Name  namePmNpk,   namePmSub;    /* primitives for (n+k) patterns   */
  46 extern Name  nameError;                 /* For runtime error messages      */
  47 extern Name  nameUndefined;             /* A generic undefined value       */
  48 extern Name  nameBlackHole;             /* For GC-detected black hole      */
  49 extern Name  nameInd;                   /* For dict indirection            */
  50 extern Name  nameAnd,     nameOr;       /* For optimisation of && and ||   */
  51 extern Name  nameFromInt, nameFromDouble;/*coercion of numerics            */
  52 extern Name  nameFromInteger;
  53 extern Name  nameEq,      nameCompare;  /* names used for deriving         */
  54 extern Name  nameMinBnd,  nameMaxBnd;
  55 extern Name  nameIndex,   nameInRange;
  56 extern Name  nameRange;
  57 extern Name  nameLe,      nameGt;
  58 extern Name  nameShowsPrec, nameReadsPrec;
  59 extern Name  nameMult,    namePlus;
  60 extern Name  nameComp,    nameApp;      /* composition and append          */
  61 extern Name  nameShowField;             /* display single field            */
  62 extern Name  nameShowParen;             /* wrap with parens                */
  63 extern Name  nameReadField;             /* read single field               */
  64 extern Name  nameReadParen;             /* unwrap from parens              */
  65 extern Name  nameLex;                   /* lexer                           */
  66 extern Name  nameRangeSize;             /* calculate size of index range   */
  67 extern Name  nameReturn,  nameBind;     /* for translating monad comps     */
  68 extern Name  nameMFail;
  69 extern Name  nameListMonad;             /* builder function for List Monad */
  70 extern Name  namePrint;                 /* printing primitive              */
  71 extern Name  nameCreateAdjThunk;        /* f-x-dyn: create adjustor thunk  */
  72 extern Name  nameShow;
  73 extern Name  namePutStr;
  74 extern Name  nameRunIO_toplevel;
  75
  76 /* The following data constructors are used to make boxed but
  77  * unpointed values pointed and require no special treatment
  78  * by the code generator. */
  79 extern Name nameMkInteger;
  80 extern Name nameMkPrimArray;
  81 extern Name nameMkPrimByteArray;
  82 extern Name nameMkRef;
  83 extern Name nameMkPrimMutableArray;
  84 extern Name nameMkPrimMutableByteArray;
  85 extern Name nameMkThreadId;
  86 extern Name nameMkPrimMVar;
  87 #ifdef PROVIDE_FOREIGN
  88 extern Name nameMkForeign;
  89 #endif
  90 #ifdef PROVIDE_WEAK
  91 extern Name nameMkWeak;
  92 #endif
  93
  94 /* The following data constructors are used to box unboxed
  95  * arguments and are treated differently by the code generator.
  96  * That is, they have primop `elem` {INT_REP,FLOAT_REP,...}. */
  97 #define boxingConRep(con) ((AsmRep)(name(con).primop))
  98 #define isBoxingCon(con) (isName(con) && boxingConRep(con) != 0)
  99 extern Name nameMkC;
 100 extern Name nameMkI;
 101 extern Name nameMkW;
 102 extern Name nameMkA;
 103 extern Name nameMkF;
 104 extern Name nameMkD;
 105 extern Name nameMkStable;
 106
 107 /* used while desugaring */
 108 extern Name nameId;
 109 extern Name nameOtherwise;
 110 extern Name nameUndefined;              /* generic undefined value         */
 111
 112 /* used in pattern match */
 113 extern Name namePmSub;
 114 extern Name nameSel;
 115
 116 /* used in translation */
 117 extern Name nameEq;
 118 extern Name namePMFail;
 119 extern Name nameEqChar;
 120 extern Name nameEqInteger;
 121 extern Name namePmInt;
 122 extern Name namePmInteger;
 123 extern Name namePmDouble;
 124 extern Name namePmLe;
 125 extern Name namePmSubtract;
 126 extern Name namePmFromInteger;
 127 extern Name nameMkIO;
 128 extern Name nameUnpackString;
 129 extern Name namePrimSeq;
 130 extern Name nameMap;
 131 extern Name nameMinus;
 132
 133 /* assertion and exceptions */
 134 extern Name nameAssert;
 135 extern Name nameAssertError;
 136 extern Name nameTangleMessage;
 137 extern Name nameIrrefutPatError;
 138 extern Name nameNoMethodBindingError;
 139 extern Name nameNonExhaustiveGuardsError;
 140 extern Name namePatError;
 141 extern Name nameRecSelError;
 142 extern Name nameRecConError;
 143 extern Name nameRecUpdError;
 144
 145
 146 extern Class classMonad;                /* Monads                          */
 147 extern Class classEq;                   /* `standard' classes              */
 148 extern Class classOrd;
 149 extern Class classShow;
 150 extern Class classRead;
 151 extern Class classIx;
 152 extern Class classEnum;
 153 extern Class classBounded;
 154 extern Class classReal;                 /* `numeric' classes               */
 155 extern Class classIntegral;
 156 extern Class classRealFrac;
 157 extern Class classRealFloat;
 158 extern Class classFractional;
 159 extern Class classFloating;
 160 extern Class classNum;
 161
 162
 163 extern Type typeProgIO;                 /* For the IO monad, IO a          */
 164 extern Type typeArrow;                  /* Builtin type constructors       */
 165 extern Type typeList;
 166 extern Type typeUnit;
 167 extern Type typeInt64;
 168 extern Type typeWord;
 169 extern Type typeFloat;
 170 extern Type typePrimArray;
 171 extern Type typePrimByteArray;
 172 extern Type typeRef;
 173 extern Type typePrimMutableArray;
 174 extern Type typePrimMutableByteArray;
 175 extern Type typeStable;
 176 extern Type typeWeak;
 177 extern Type typeIO;
 178 extern Type typeForeign;
 179 extern Type typeMVar;
 180 extern Type typeThreadId;
 181 extern Type typeException;
 182 extern Type typeIO;
 183 extern Type typeST;
 184 extern Type typeOrdering;
 185 extern List  stdDefaults;               /* List of standard default types  */
 186
 187 /* For every primitive type provided by the runtime system,
 188  * we construct a Haskell type using a declaration of the form:
 189  *
 190  *   data Int  -- no constructors given
 191  */
 192 extern Type typeChar;
 193 extern Type typeInt;
 194 extern Type typeInteger;
 195 extern Type typeWord;
 196 extern Type typeAddr;
 197 extern Type typePrimArray;
 198 extern Type typePrimByteArray;
 199 extern Type typeRef;
 200 extern Type typePrimMutableArray;
 201 extern Type typePrimMutableByteArray;
 202 extern Type typeFloat;
 203 extern Type typeDouble;
 204 extern Type typeStable;
 205 extern Type typeThreadId;
 206 extern Type typeMVar;
 207 #ifdef PROVIDE_WEAK
 208 extern Type typeWeak;
 209 #endif
 210 #ifdef PROVIDE_FOREIGN
 211 extern Type typeForeign;
 212 #endif
 213
 214 /* And a smaller number of types defined in plain Haskell */
 215 extern Type typeList;
 216 extern Type typeUnit;
 217 extern Type typeString;
 218 extern Type typeBool;
 219 extern Type typeST;
 220 extern Type typeIO;
 221 extern Type typeException;
 222
 223
 224 extern Module modulePrelude;
 225
 226
 227 extern Kind   starToStar;                /* Type -> Type                    */
 228
 229
 230 #if TREX
 231 extern Name  nameRecExt;                /* Extend a record                 */
 232 extern Name  nameRecBrk;                /* Break a record                  */
 233 extern Name  nameAddEv;                 /* Addition of evidence values     */
 234 extern Name  nameRecSel;                /* Select a record                 */
 235 extern Name  nameRecShw;                /* Show a record                   */
 236 extern Name  nameShowRecRow;            /* Used to output rows             */
 237 extern Name  nameRecEq;                 /* Compare records                 */
 238 extern Name  nameEqRecRow;              /* Used to compare rows            */
 239 extern Name  nameInsFld;                /* Field insertion routine         */
 240 extern Name  nameNoRec;                 /* The empty record                */
 241 extern Type  typeNoRow;                 /* The empty row                   */
 242 extern Type  typeRec;                   /* Record formation                */
 243 extern Kind  extKind;                   /* Kind of extension, *->row->row  */
 244 #endif
 245
 246
 247 /* --------------------------------------------------------------------------
 248  * Constructions from the above names, types, etc.
 249  * ------------------------------------------------------------------------*/
 250
 251
 252 extern Type  arrow;                     /* mkOffset(0) -> mkOffset(1)      */
 253 extern Type  listof;                    /* [ mkOffset(0) ]                 */
 254 extern Cell  predNum;                   /* Num (mkOffset(0))               */
 255 extern Cell  predFractional;            /* Fractional (mkOffset(0))        */
 256 extern Cell  predIntegral;              /* Integral (mkOffset(0))          */
 257 extern Cell  predMonad;                 /* Monad (mkOffset(0))             */
 258
 259 extern Type  arrow;                     /* mkOffset(0) -> mkOffset(1)      */
 260 extern Type  boundPair;                 /* (mkOffset(0),mkOffset(0))       */
 261 extern Type  listof;                    /* [ mkOffset(0) ]                 */
 262 extern Type  typeVarToVar;              /* mkOffset(0) -> mkOffset(0)      */
 263
 264 extern Cell  predNum;                   /* Num (mkOffset(0))               */
 265 extern Cell  predFractional;            /* Fractional (mkOffset(0))        */
 266 extern Cell  predIntegral;              /* Integral (mkOffset(0))          */
 267 extern Kind  starToStar;                /* Type -> Type                    */
 268 extern Cell  predMonad;                 /* Monad (mkOffset(0))             */
 269
 270 #define fn(from,to)  ap(ap(typeArrow,from),to)  /* make type: from -> to   */
 271
 272 #define aVar            mkOffset(0)     /* Simple skeleton for type var    */
 273 extern Type boundPair;                  /* (mkOffset(0),mkOffset(0))       */
 274
 275 #define consChar(c) ap(nameCons,mkChar(c))
 276
 277 /* --------------------------------------------------------------------------
 278  * Umm ....
 279  * ------------------------------------------------------------------------*/
 280
 281 extern Bool   haskell98;                /* TRUE => Haskell 98 compatibility*/
 282 extern Bool   combined;                 /* TRUE => combined operation      */
 283 extern Bool   debugSC;                  /* TRUE => print SC to screen  */
 284 extern Bool   kindExpert;               /* TRUE => display kind errors in  */
 285                                         /*         full detail             */
 286 extern Bool   allowOverlap;             /* TRUE => allow overlapping insts */
 287
 288 extern String repeatStr;                /* Repeat last command string      */
 289 extern String hugsEdit;                 /* String for editor command       */
 290 extern String hugsPath;                 /* String for file search path     */
 291 extern String projectPath;              /* String for project search path  */
 292
 293 extern Cell*  CStackBase;               /* pointer to base of C stack      */
 294
 295 extern List   tyconDefns;               /* list of type constructor defns  */
 296 extern List   typeInDefns;              /* list of synonym restrictions    */
 297 extern List   valDefns;                 /* list of value definitions       */
 298 extern List   classDefns;               /* list of class definitions       */
 299 extern List   instDefns;                /* list of instance definitions    */
 300 extern List   selDefns;                 /* list of selector lists          */
 301 extern List   genDefns;                 /* list of generated defns         */
 302 extern List   primDefns;                /* list of primitive definitions   */
 303 extern List   unqualImports;            /* unqualified import list         */
 304 extern List   defaultDefns;             /* default definitions (if any)    */
 305 extern Int    defaultLine;              /* line in which default defs occur*/
 306 extern List   evalDefaults;             /* defaults for evaluator          */
 307 extern Cell   inputExpr;                /* evaluator input expression      */
 308 extern Cell   inputContext;             /* evaluator input expression      */
 309
 310 extern Cell   whnfHead;                 /* head of term in whnf            */
 311 extern Int    whnfInt;                  /* integer value of term in whnf   */
 312 extern Float  whnfFloat;                /* float value of term in whnf     */
 313 extern Long   numCells;                 /* number of cells allocated       */
 314 extern Int    numGcs;                   /* number of garbage collections   */
 315 extern Bool   broken;                   /* indicates interrupt received    */
 316 extern Bool   preludeLoaded;            /* TRUE => prelude has been loaded */
 317 extern Bool   flagAssert;               /* TRUE => assert False <e> causes
 318                                                    an assertion failure    */
 319
 320 extern Bool   gcMessages;               /* TRUE => print GC messages       */
 321 extern Bool   literateScripts;          /* TRUE => default lit scripts     */
 322 extern Bool   literateErrors;           /* TRUE => report errs in lit scrs */
 323 extern Bool   showInstRes;              /*TRUE => show instance resolution */
 324
 325 extern Int    cutoff;                   /* Constraint Cutoff depth         */
 326
 327 extern List   diVars;                   /* deriving: cache of names        */
 328 extern Int    diNum;                    /* also for deriving               */
 329 extern List   cfunSfuns;                /* List of (Cfun,[SelectorVar])    */
 330
 331 #if USE_PREPROCESSOR
 332 extern String preprocessor;             /* preprocessor command            */
 333 #endif
 334
 335
 336 /* --------------------------------------------------------------------------
 337  * Function prototypes etc...
 338  * ------------------------------------------------------------------------*/
 339
 340
 341
 342 #define RESET    1            /* reset subsystem                           */
 343 #define MARK     2            /* mark parts of graph in use by subsystem   */
 344 #define PREPREL  3            /* do startup actions before Prelude loading */
 345 #define POSTPREL 4            /* do startup actions after Prelude loading  */
 346 #define EXIT     5            /* Take action immediately before exit()     */
 347 #define BREAK    6            /* Take action after program break           */
 348 #define GCDONE   7            /* Restore subsystem invariants after GC     */
 349
 350 /* PREPREL was formerly called INSTALL.  POSTPREL doesn't have an analogy
 351    in the old Hugs.
 352 */
 353 extern  Void   everybody        ( Int );
 354 extern  Void   linkControl      ( Int );
 355 extern  Void   deriveControl    ( Int );
 356 extern  Void   translateControl ( Int );
 357 extern  Void   codegen          ( Int );
 358 extern  Void   machdep          ( Int );
 359 extern  Void   liftControl      ( Int );
 360 extern  Void   substitution     ( Int );
 361 extern  Void   typeChecker      ( Int );
 362 extern  Void   interface        ( Int );
 363 extern  Void   storage          ( Int );
 364
 365
 366
 367 typedef long   Target;
 368 extern  Void   setGoal          ( String, Target );
 369 extern  Void   soFar            ( Target );
 370 extern  Void   done             ( Void );
 371 extern  String fromEnv          ( String,String );
 372 extern  Bool   chase            ( List );
 373
 374 extern  Void   input            ( Int );
 375 extern  Void   consoleInput     ( String );
 376 extern  Void   projInput        ( String );
 377 extern  Void   stringInput      ( String );
 378 extern  Cell   parseModule      ( String,Long );
 379 extern  Void   parseExp         ( Void );
 380 #if EXPLAIN_INSTANCE_RESOLUTION
 381 extern  Void   parseContext     ( Void );
 382 #endif
 383 extern  String readFilename     ( Void );
 384 extern  String readLine         ( Void );
 385 extern  Syntax defaultSyntax    ( Text );
 386 extern  Syntax syntaxOf         ( Name );
 387 extern  String unlexChar        ( Char,Char );
 388 extern  Void   printString      ( String );
 389
 390
 391 extern  Void   staticAnalysis   ( Int );
 392 extern  Void   startModule      ( Module );
 393 extern  Void   setExportList    ( List );
 394 extern  Void   setExports       ( List );
 395 extern  Void   addQualImport    ( Text,Text );
 396 extern  Void   addUnqualImport  ( Text,List );
 397
 398 extern  Void   tyconDefn        ( Int,Cell,Cell,Cell );
 399 extern  Void   setTypeIns       ( List );
 400 extern  Void   clearTypeIns     ( Void );
 401 extern  Type   fullExpand       ( Type );
 402 extern  Bool   isAmbiguous      ( Type );
 403 extern  Void   ambigError       ( Int,String,Cell,Type );
 404 extern  Void   classDefn        ( Int,Cell,List,List );
 405 extern  Void   instDefn         ( Int,Cell,Cell );
 406 extern  Void   addTupInst       ( Class,Int );
 407 extern  Name   newDSel          ( Class,Int );
 408 #if TREX
 409 extern  Inst   addRecShowInst   ( Class,Ext );
 410 extern  Inst   addRecEqInst     ( Class,Ext );
 411 #endif
 412 extern  List   offsetTyvarsIn   ( Type,List );
 413
 414
 415 extern  List   typeVarsIn       ( Cell,List,List,List );
 416 extern  List   oclose           ( List,List );
 417 extern  List   zonkTyvarsIn     ( Type,List );
 418 extern  Type   zonkTyvar        ( Int );
 419 extern  Type   zonkType         ( Type,Int );
 420 extern  Void   primDefn         ( Cell,List,Cell );
 421 extern  Void   defaultDefn      ( Int,List );
 422 extern  Void   checkExp         ( Void );
 423 extern  Type   conToTagType     ( Tycon );
 424 extern  Type   tagToConType     ( Tycon );
 425 extern  Int    visitClass       ( Class );
 426
 427 #if EXPLAIN_INSTANCE_RESOLUTION
 428 extern  Void   checkContext     ( Void );
 429 #endif
 430 extern  Void   checkDefns       ( Module );
 431 extern  Bool   h98Pred          ( Bool,Cell );
 432 extern  Cell   h98Context       ( Bool,List );
 433 extern  Void   h98CheckCtxt     ( Int,String,Bool,List,Inst );
 434 extern  Void   h98CheckType     ( Int,String,Cell,Type );
 435 extern  Void   h98DoesntSupport ( Int,String );
 436
 437 extern Int     userArity        ( Name );
 438 extern List    deriveEq         ( Tycon );
 439 extern List    deriveOrd        ( Tycon );
 440 extern List    deriveEnum       ( Tycon );
 441 extern List    deriveIx         ( Tycon );
 442 extern List    deriveShow       ( Tycon );
 443 extern List    deriveRead       ( Cell );
 444 extern List    deriveBounded    ( Tycon );
 445 extern List    checkPrimDefn    ( Triple );
 446
 447 extern  Void  foreignImport     ( Cell,Text,Pair,Cell,Cell );
 448 extern  Void  foreignExport     ( Cell,Text,Cell,Cell,Cell );
 449
 450 extern  Void  implementForeignImport ( Name );
 451 extern  Void  implementForeignExport ( Name );
 452
 453 extern  List  foreignExports;            /* foreign export declarations     */
 454 extern  List  foreignImports;            /* foreign import declarations     */
 455
 456 extern  Type   primType         ( Int /*AsmMonad*/ monad,
 457                                   String a_kinds, String r_kinds );
 458
 459 extern  Type   typeCheckExp     ( Bool );
 460 extern  Void   typeCheckDefns   ( Void );
 461 extern  Cell   provePred        ( Kinds,List,Cell );
 462 extern  List   simpleContext    ( List,Int );
 463 extern  Cell   rhsExpr          ( Cell );
 464 extern  Int    rhsLine          ( Cell );
 465 extern  Bool   isProgType       ( List,Type );
 466 extern  Cell   superEvid        ( Cell,Class,Class );
 467 extern  Void   linkPreludeTC    ( Void );
 468 extern  Void   linkPreludeCM    ( Void );
 469 extern  Void   linkPrimNames    ( Void );
 470
 471 extern  Void   compiler         ( Int );
 472 extern  Void   compileDefns     ( Void );
 473 extern  Void   compileExp       ( Void );
 474 extern  Bool   failFree         ( Cell );
 475 extern  Int    discrArity       ( Cell );
 476
 477 extern  Addr   codeGen          ( Name,Int,Cell );
 478 extern  Void   evalExp          ( Void );
 479 extern  Int    shellEsc         ( String );
 480 extern  Int    getTerminalWidth ( Void );
 481 extern  Void   normalTerminal   ( Void );
 482 extern  Void   noechoTerminal   ( Void );
 483 extern  Int    readTerminalChar ( Void );
 484 extern  Void   gcStarted        ( Void );
 485 extern  Void   gcScanning       ( Void );
 486 extern  Void   gcRecovered      ( Int );
 487 extern  Void   gcCStack         ( Void );
 488 extern  Void   needPrims        ( Int );
 489 extern  List   calcFunDepsPreds ( List );
 490 extern  Inst   findInstFor      ( Cell,Int );
 491 #if MULTI_INST
 492 extern  List   findInstsFor     ( Cell,Int );
 493 #endif
 494
 495
 496 /*---------------------------------------------------------------------------
 497  * Debugging printers, and output-ery
 498  *-------------------------------------------------------------------------*/
 499
 500 extern Void ppScripts           ( Void );
 501 extern Void ppModules           ( Void );
 502
 503 extern Void printStg            ( FILE *fp, Cell /*StgVar*/ b);
 504
 505 extern Void ppStg               ( Cell /*StgVar*/ v );
 506 extern Void ppStgExpr           ( Cell /*StgExpr*/ e );
 507 extern Void ppStgRhs            ( Cell /*StgRhs*/ rhs );
 508 extern Void ppStgAlts           ( List alts );
 509 extern Void ppStgPrimAlts       ( List alts );
 510 extern Void ppStgVars           ( List vs );
 511
 512 extern Void putChr              ( Int );
 513 extern Void putStr              ( String );
 514 extern Void putInt              ( Int );
 515 extern Void putPtr              ( Ptr );
 516
 517 extern Void unlexCharConst      ( Cell );
 518 extern Void unlexStrConst       ( Text );
 519 extern Void unlexVar            ( Text );
 520 extern Void unlexVarStr         ( String );
 521
 522 extern FILE *outputStream;             /* current output stream            */
 523 extern Int  outColumn;                 /* current output column number     */
 524
 525
 526
 527 /*---------------------------------------------------------------------------
 528  * Crude profiling (probably doesn't work)
 529  *-------------------------------------------------------------------------*/
 530
 531 #ifdef CRUDE_PROFILING
 532 extern void cp_init             ( void );
 533 extern void cp_enter            ( Cell /*StgVar*/ );
 534 extern void cp_bill_words       ( int );
 535 extern void cp_bill_insns       ( int );
 536 extern void cp_show             ( void );
 537 #endif
 538
 539
 540 /*---------------------------------------------------------------------------
 541  * For dynamic.c and general object-related stuff
 542  *-------------------------------------------------------------------------*/
 543
 544 extern void*     getDLLSymbol   ( Int,String,String );
 545 extern Bool      stdcallAllowed ( void );
 546
 547 #if LEADING_UNDERSCORE
 548 #define MAYBE_LEADING_UNDERSCORE(sss)     _##sss
 549 #define MAYBE_LEADING_UNDERSCORE_STR(sss) "_" sss
 550 #else
 551 #define MAYBE_LEADING_UNDERSCORE(sss)     sss
 552 #define MAYBE_LEADING_UNDERSCORE_STR(sss) sss
 553 #endif
 554
 555
 556 /*---------------------------------------------------------------------------
 557  * Interrupting execution (signals, allowBreak):
 558  *-------------------------------------------------------------------------*/
 559
 560 extern Bool breakOn             ( Bool );
 561 extern Bool broken;                     /* indicates interrupt received    */
 562
 563 #ifndef SIGBREAK /* Sigh, not defined in cygwin32 beta release 16 */
 564 # define SIGBREAK 21
 565 #endif
 566
 567 /* allowBreak: call to allow user to interrupt computation
 568  * ctrlbrk:    set control break handler
 569  */
 570
 571 #if HAVE_SIGPROCMASK
 572 #include <signal.h>
 573 #define ctrlbrk(bh)     { sigset_t mask; \
 574                           signal(SIGINT,bh); \
 575                           sigemptyset(&mask); \
 576                           sigaddset(&mask, SIGINT); \
 577                           sigprocmask(SIG_UNBLOCK, &mask, NULL); \
 578                         }
 579 #else
 580 #  define ctrlbrk(bh)   signal(SIGINT,bh)
 581 #endif
 582
 583 #if SYMANTEC_C
 584 extern int time_release;
 585 extern int allow_break_count;
 586 # define allowBreak()   if (time_release !=0 && \
 587                             (++allow_break_count % time_release) == 0) \
 588                             ProcessEvent();
 589 #else
 590 # define allowBreak()  if (broken) { broken=FALSE; sigRaise(breakHandler); }
 591 #endif
 592
 593
 594 /*---------------------------------------------------------------------------
 595  * Environment variables and the registry
 596  *-------------------------------------------------------------------------*/
 597
 598 /* On Win32 we can use the registry to supplement info in environment
 599  * variables.
 600  */
 601 /* AJG: Commented out for now for development */
 602 /* #define USE_REGISTRY (HAVE_WINDOWS_H && !__MSDOS__) */
 603
 604 #ifdef USE_REGISTRY
 605 Bool    writeRegString          ( String var, String val );
 606 String  readRegString           ( String var, String def );
 607 Int     readRegInt              ( String var, Int def );
 608 Bool    writeRegInt             ( String var, Int val );
 609 #endif
 610
 611 #define N_INSTALLDIR 200
 612 extern char installDir[N_INSTALLDIR];
 613
 614
 615 /*---------------------------------------------------------------------------
 616  * File operations:
 617  *-------------------------------------------------------------------------*/
 618
 619 #if HAVE_UNISTD_H
 620 # include <sys/types.h>
 621 # include <unistd.h>
 622 #endif
 623
 624 extern int      chdir           ( const char* );
 625
 626 #if HAVE_STDLIB_H
 627 # include <stdlib.h>
 628 #else
 629 extern int      system          ( const char * );
 630 extern double   atof            ( const char * );
 631 extern void     exit            ( int );
 632 #endif
 633
 634 #ifndef FILENAME_MAX       /* should already be defined in an ANSI compiler*/
 635 #define FILENAME_MAX 256
 636 #else
 637 #if     FILENAME_MAX < 256
 638 #undef  FILENAME_MAX
 639 #define FILENAME_MAX 256
 640 #endif
 641 #endif
 642
 643 /* Hack, hack: if you have dos.h, you probably have a DOS filesystem */
 644 #define DOS_FILENAMES              HAVE_DOS_H
 645 /* ToDo: can we replace this with a feature test? */
 646 #define MAC_FILENAMES              SYMANTEC_C
 647
 648 #define CASE_INSENSITIVE_FILENAMES (DOS_FILENAMES | RISCOS)
 649
 650 #if CASE_INSENSITIVE_FILENAMES
 651 # if HAVE_STRCASECMP
 652 #  define filenamecmp(s1,s2) strcasecmp(s1,s2)
 653 # elif HAVE__STRICMP
 654 #  define filenamecmp(s1,s2) _stricmp(s1,s2)
 655 # elif HAVE_STRICMP
 656 #  define filenamecmp(s1,s2) stricmp(s1,s2)
 657 # elif HAVE_STRCMPI
 658 #  define filenamecmp(s1,s2) strcmpi(s1,s2)
 659 # endif
 660 #else
 661 # define filenamecmp(s1,s2) strcmp(s1,s2)
 662 #endif
 663
 664
 665 /*---------------------------------------------------------------------------
 666  * Pipe-related operations:
 667  *
 668  * On Windows, many standard Unix names acquire a leading underscore.
 669  * Irritating, but easy to work around.
 670  *-------------------------------------------------------------------------*/
 671
 672 #if !defined(HAVE_POPEN) && defined(HAVE__POPEN)
 673 #define popen(x,y) _popen(x,y)
 674 #endif
 675 #if !defined(HAVE_PCLOSE) && defined(HAVE__PCLOSE)
 676 #define pclose(x) _pclose(x)
 677 #endif
 678
 679
 680 /*---------------------------------------------------------------------------
 681  * Bit manipulation:
 682  *-------------------------------------------------------------------------*/
 683
 684 #define bitArraySize(n)    ((n)/bitsPerWord + 1)
 685 #define placeInSet(n)      ((-(n)-1)>>wordShift)
 686 #define maskInSet(n)       (1<<((-(n)-1)&wordMask))
 687
 688
 689 /*---------------------------------------------------------------------------
 690  * Function prototypes for code in machdep.c
 691  *-------------------------------------------------------------------------*/
 692
 693 extern  String findMPathname    ( String,String,String );
 694 extern  String findPathname     ( String,String );
 695 extern  Int    shellEsc         ( String );
 696 extern  Int    getTerminalWidth ( Void );
 697 extern  Void   normalTerminal   ( Void );
 698 extern  Void   noechoTerminal   ( Void );
 699 extern  Int    readTerminalChar ( Void );
 700 extern  Void   gcStarted        ( Void );
 701 extern  Void   gcScanning       ( Void );
 702 extern  Void   gcRecovered      ( Int );
 703 extern  Void   gcCStack         ( Void );
 704
 705
 706 /*---------------------------------------------------------------------------
 707  * To do with reading interface and object files
 708  *-------------------------------------------------------------------------*/
 709
 710 extern Cell   parseInterface        ( String,Long );
 711 extern List   getInterfaceImports   ( Cell );
 712 extern void   processInterfaces     ( List );
 713 extern Void   getFileSize           ( String, Long * );
 714 extern Void   ifLinkConstrItbl      ( Name n );
 715 extern Void   hi_o_namesFromSrcName ( String,String*,String* oName );
 716 extern void*  lookupObjName         ( char* );
 717
 718 extern String getExtraObjectInfo    ( String primaryObjectName,
 719                                       String extraFileName,
 720                                       Int*   extraFileSize );
 721
 722 extern List /* of ZTriple(I_INTERFACE,
 723                           Text--name of obj file,
 724                           Int--size of obj file) */
 725              ifaces_outstanding;
 726
 727
 728 /* --------------------------------------------------------------------------
 729  * Interpreter command structure
 730  * ------------------------------------------------------------------------*/
 731
 732 typedef Int Command;
 733
 734 struct cmd {
 735     String cmdString;
 736     Command cmdCode;
 737 };
 738
 739 extern Command readCommand      ( struct cmd *, Char, Char );
 740
 741 #define EDIT    0
 742 #define FIND    1
 743 #define LOAD    2
 744 #define ALSO    3
 745 #define PROJECT 4
 746 #define RELOAD  5
 747 #define EVAL    6
 748 #define TYPEOF  7
 749 #define HELP    8
 750 #define NAMES   9
 751 #define BADCMD  10
 752 #define SET     11
 753 #define QUIT    12
 754 #define SYSTEM  13
 755 #define CHGDIR  14
 756 #define INFO    15
 757 #define COLLECT 16
 758 #define SETMODULE 17
 759 #define DUMP    18
 760 #define STATS   19
 761 #define BROWSE  20
 762 #define XPLAIN  21
 763 #define PNTVER  22
 764 #define NOCMD   23
 765
 766
 767 /* --------------------------------------------------------------------------
 768  * STG Syntax:
 769  *
 770  *   Rhs     -> STGCON   (Con, [Atom])
 771  *            | STGAPP   (Var, [Atom])     -- delayed application
 772  *            | Expr
 773  *
 774  *   Expr    -> LETREC   ([Var],Expr)      -- Vars contain their bound value
 775  *            | LAMBDA   ([Var],Expr)      -- all vars bound to NIL
 776  *            | CASE     (Expr,[Alt])      -- algebraic case
 777  *            | PRIMCASE (Expr,[PrimAlt])  -- primitive case
 778  *            | STGPRIM  (Prim,[Atom])
 779  *            | STGAPP   (Var, [Atom])     -- tail call
 780  *            | Var                        -- Abbreviation for STGAPP(Var,[])
 781  *
 782  *   Atom    -> Var
 783  *            | CHAR                       -- unboxed
 784  *            | INT                        -- unboxed
 785  *            | BIGNUM                     -- unboxed
 786  *            | FLOAT                      -- unboxed
 787  *            | ADDR                       -- unboxed
 788  *            | STRING                     -- boxed
 789  *
 790  *   Var     -> STGVAR   (Rhs,StgRep,info) -- let, case or lambda bound
 791  *            | Name                       -- let-bound (effectively)
 792  *                                         -- always unboxed (PTR_REP)
 793  *
 794  *   Alt     -> DEEFALT (Var,Expr)         -- var bound to NIL
 795  *            | CASEALT (Con,[Var],Expr)   -- vars bound to NIL;
 796  *                                         -- Con is Name or TUPLE
 797  *   PrimAlt -> PRIMALT ([Var],Expr)       -- vars bound to NIL or int
 798  *
 799  * We use pointer equality to distinguish variables.
 800  * The info field of a Var is used as follows in various phases:
 801  *
 802  * Translation:      unused (set to NIL on output)
 803  * Freevar analysis: list of free vars after
 804  * Lambda lifting:   freevar list or UNIT on input, discarded after
 805  * Code generation:  unused
 806  * Optimisation:     number of uses (sort-of) of let-bound variable
 807  * ------------------------------------------------------------------------*/
 808
 809 typedef Cell   StgRhs;
 810 typedef Cell   StgExpr;
 811 typedef Cell   StgAtom;
 812 typedef Cell   StgVar;       /* Could be a Name or an STGVAR */
 813 typedef Cell   StgCaseAlt;
 814 typedef Cell   StgPrimAlt;
 815 typedef Cell   StgDiscr;
 816 typedef Cell   StgRep;  /* PTR_REP | .. DOUBLE_REP */
 817
 818 #define mkStgLet(binds,body)       ap(LETREC,pair(binds,body))
 819 #define stgLetBinds(e)             fst(snd(e))
 820 #define stgLetBody(e)              snd(snd(e))
 821
 822 #define mkStgPrimVar(rhs,rep,info) ap(STGVAR,triple(rhs,rep,info))
 823 #define stgVarBody(e)              fst3(snd(e))
 824 #define stgVarRep(e)               snd3(snd(e))
 825 #define stgVarInfo(e)              thd3(snd(e))
 826
 827 #define mkStgCase(scrut,alts)      ap(CASE,pair(scrut,alts))
 828 #define stgCaseScrut(e)            fst(snd(e))
 829 #define stgCaseAlts(e)             snd(snd(e))
 830
 831 #define mkStgCaseAlt(con,vs,e)     ap(CASEALT,triple(con,vs,e))
 832 #define stgCaseAltCon(alt)         fst3(snd(alt))
 833 #define stgCaseAltVars(alt)        snd3(snd(alt))
 834 #define stgCaseAltBody(alt)        thd3(snd(alt))
 835
 836 #define mkStgDefault(v,e)          ap(DEEFALT,pair(v,e))
 837 #define stgDefaultVar(alt)         fst(snd(alt))
 838 #define stgDefaultBody(alt)        snd(snd(alt))
 839 #define isDefaultAlt(alt)          (fst(alt)==DEEFALT)
 840
 841 #define mkStgPrimCase(scrut,alts)  ap(PRIMCASE,pair(scrut,alts))
 842 #define stgPrimCaseScrut(e)        fst(snd(e))
 843 #define stgPrimCaseAlts(e)         snd(snd(e))
 844
 845 #define mkStgPrimAlt(vs,body)      ap(PRIMALT,pair(vs,body))
 846 #define stgPrimAltVars(alt)        fst(snd(alt))
 847 #define stgPrimAltBody(alt)        snd(snd(alt))
 848
 849 #define mkStgApp(fun,args)         ap(STGAPP,pair(fun,args))
 850 #define stgAppFun(e)               fst(snd(e))
 851 #define stgAppArgs(e)              snd(snd(e))
 852
 853 #define mkStgPrim(op,args)         ap(STGPRIM,pair(op,args))
 854 #define stgPrimOp(e)               fst(snd(e))
 855 #define stgPrimArgs(e)             snd(snd(e))
 856
 857 #define mkStgCon(con,args)         ap(STGCON,pair(con,args))
 858 #define stgConCon(e)               fst(snd(e))
 859 #define stgConArgs(e)              snd(snd(e))
 860
 861 #define mkStgLambda(args,body)     ap(LAMBDA,pair(args,body))
 862 #define stgLambdaArgs(e)           fst(snd(e))
 863 #define stgLambdaBody(e)           snd(snd(e))
 864
 865
 866 /* --------------------------------------------------------------------------
 867  * Utility functions for manipulating STG syntax trees.
 868  * ------------------------------------------------------------------------*/
 869
 870 extern int     stgConTag        ( StgDiscr d );
 871 extern void*   stgConInfo       ( StgDiscr d );
 872 extern int     stgDiscrTag      ( StgDiscr d );
 873
 874 extern List    makeArgs         ( Int );
 875 extern StgExpr makeStgLambda    ( List args,  StgExpr body );
 876 extern StgExpr makeStgApp       ( StgVar fun, List args );
 877 extern StgExpr makeStgLet       ( List binds, StgExpr body );
 878 extern StgExpr makeStgIf        ( StgExpr cond, StgExpr e1, StgExpr e2 );
 879 extern Bool    isStgVar         ( StgRhs rhs );
 880 extern Bool    isAtomic         ( StgRhs rhs );
 881 extern StgVar  mkStgVar         ( StgRhs rhs, Cell info );
 882
 883 #define mkStgRep(c) mkChar(c)
 884
 885
 886 /* --------------------------------------------------------------------------
 887  * STG/backendish functions
 888  * ------------------------------------------------------------------------*/
 889
 890 extern  Void  stgDefn                ( Name n, Int arity, Cell e );
 891
 892 extern  Void  implementForeignImport ( Name );
 893 extern  Void  implementForeignExport ( Name );
 894 extern  Void  implementCfun          ( Name, List );
 895 extern  Void  implementConToTag      ( Tycon );
 896 extern  Void  implementTagToCon      ( Tycon );
 897 extern  Void  implementPrim          ( Name );
 898 extern  Void  implementTuple         ( Int );
 899 #if TREX
 900 extern  Name  implementRecShw        ( Text );
 901 extern  Name  implementRecEq         ( Text );
 902 #endif
 903
 904 /* Association list storing globals assigned to dictionaries, tuples, etc */
 905 extern List stgGlobals;
 906
 907 extern List    liftBinds        ( List binds );
 908 extern StgExpr substExpr        ( List sub, StgExpr e );
 909 extern List    freeVarsBind     ( List, StgVar );
 910
 911
 912 extern Void    cgBinds          ( StgRhs );
 913 extern void*   closureOfVar     ( StgVar );
 914 extern char*   lookupHugsName   ( void* );
 915
 916
 917 /* --------------------------------------------------------------------------
 918  * Definitions for substitution data structure and operations.
 919  * ------------------------------------------------------------------------*/
 920
 921 typedef struct {                        /* Each type variable contains:    */
 922     Type bound;                         /* A type skeleton (unbound==NIL)  */
 923     Int  offs;                          /* Offset for skeleton             */
 924     Kind kind;                          /* kind annotation                 */
 925 } Tyvar;
 926
 927 extern  Tyvar           *tyvars;        /* storage for type variables      */
 928 extern  Int             typeOff;        /* offset of result type           */
 929 extern  Type            typeIs;         /* skeleton of result type         */
 930 extern  Int             typeFree;       /* freedom in instantiated type    */
 931 extern  List            predsAre;       /* list of predicates in type      */
 932 extern  List            genericVars;    /* list of generic vars            */
 933 extern  List            btyvars;        /* explicitly scoped type vars     */
 934
 935 #define tyvar(n)        (tyvars+(n))    /* nth type variable               */
 936 #define tyvNum(t)       ((t)-tyvars)    /* and the corresp. inverse funct. */
 937 #define isBound(t)      (((t)->bound) && ((t)->bound!=SKOLEM))
 938 #define aVar            mkOffset(0)     /* Simple skeletons for type vars  */
 939 #define bVar            mkOffset(1)
 940 #define enterBtyvs()    btyvars = cons(NIL,btyvars)
 941 #define leaveBtyvs()    btyvars = tl(btyvars)
 942
 943 #define deRef(tyv,t,o)  while ((tyv=getTypeVar(t,o)) && isBound(tyv)) { \
 944                             t = tyv->bound;                             \
 945                             o = tyv->offs;                              \
 946                         }
 947
 948                                         /* offs values when isNull(bound): */
 949 #define FIXED_TYVAR     0               /* fixed in current assumption     */
 950 #define UNUSED_GENERIC  1               /* not fixed, not yet encountered  */
 951 #define GENERIC         2               /* GENERIC+n==nth generic var found*/
 952
 953 extern  char            *unifyFails;    /* Unification error message       */
 954
 955 extern Void  emptySubstitution  ( Void );
 956 extern Int   newTyvars          ( Int );
 957 #define      newKindvars(n)     newTyvars(n)
 958 extern Int   newKindedVars      ( Kind );
 959 extern Kind  simpleKind         ( Int );
 960 extern Void  instantiate        ( Type );
 961
 962 extern Pair  findBtyvs          ( Text );
 963 extern Void  markBtyvs          ( Void );
 964 extern Type  localizeBtyvs      ( Type );
 965
 966 extern Tyvar *getTypeVar        ( Type,Int );
 967 extern Void  tyvarType          ( Int );
 968 extern Void  bindTv             ( Int,Type,Int );
 969 extern Cell  getDerefHead       ( Type,Int );
 970 extern Void  expandSyn          ( Tycon, Int, Type *, Int * );
 971
 972 extern Void  clearMarks         ( Void );
 973 extern Void  markAllVars        ( Void );
 974 extern Void  resetGenerics      ( Void );
 975 extern Void  markTyvar          ( Int );
 976 extern Void  markType           ( Type,Int );
 977 extern Void  markPred           ( Cell );
 978
 979 extern Type  copyTyvar          ( Int );
 980 extern Type  copyType           ( Type,Int );
 981 extern Cell  copyPred           ( Cell,Int );
 982 extern Type  dropRank2          ( Type,Int,Int );
 983 extern Type  dropRank1          ( Type,Int,Int );
 984 extern Void  liftRank2Args      ( List,Int,Int );
 985 extern Type  liftRank2          ( Type,Int,Int );
 986 extern Type  liftRank1          ( Type,Int,Int );
 987 #ifdef DEBUG_TYPES
 988 extern Type  debugTyvar         ( Int );
 989 extern Type  debugType          ( Type,Int );
 990 #endif
 991 extern Kind  copyKindvar        ( Int );
 992 extern Kind  copyKind           ( Kind,Int );
 993
 994 extern Bool  eqKind             ( Kind,Kind );
 995 extern Kind  getKind            ( Cell,Int );
 996
 997 extern List  genvarTyvar        ( Int,List );
 998 extern List  genvarType         ( Type,Int,List );
 999
1000 extern Bool  doesntOccurIn      ( Tyvar*,Type,Int );
1001 extern Bool  unify              ( Type,Int,Type,Int );
1002 extern Bool  kunify             ( Kind,Int,Kind,Int );
1003
1004 extern Void  typeTuple          ( Cell );
1005 extern Void  varKind            ( Int );
1006
1007 extern Bool  samePred           ( Cell,Int,Cell,Int );
1008 extern Bool  matchPred          ( Cell,Int,Cell,Int );
1009 extern Bool  unifyPred          ( Cell,Int,Cell,Int );
1010 extern Inst  findInstFor        ( Cell,Int );
1011
1012 extern Void  improve            ( Int,List,List );
1013 extern Void  improve1           ( Int,List,Cell,Int );
1014
1015 extern Bool  sameSchemes        ( Type,Type );
1016 extern Bool  sameType           ( Type,Int,Type,Int );
1017 extern Bool  matchType          ( Type,Int,Type,Int );
1018 extern Bool  typeMatches        ( Type,Type );
1019
1020 #ifdef DEBUG
1021 extern Void  checkBytecodeCount  ( Void );
1022 #endif
1023 /*-------------------------------------------------------------------------*/