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.30 $
  13  * $Date: 2000/03/15 23:27:16 $
  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  Void   parseScript      ( 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      ( Cell );
 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       ( Void );
 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 HUGS_FOR_WINDOWS
 572 #  define ctrlbrk(bh)
 573 #  define allowBreak()  kbhit()
 574 #else /* !HUGS_FOR_WINDOWS */
 575 # if HAVE_SIGPROCMASK
 576 #  include <signal.h>
 577 #  define ctrlbrk(bh)   { sigset_t mask; \
 578                           signal(SIGINT,bh); \
 579                           sigemptyset(&mask); \
 580                           sigaddset(&mask, SIGINT); \
 581                           sigprocmask(SIG_UNBLOCK, &mask, NULL); \
 582                         }
 583 # else
 584 #  define ctrlbrk(bh)   signal(SIGINT,bh)
 585 # endif
 586 #if SYMANTEC_C
 587 extern int time_release;
 588 extern int allow_break_count;
 589 # define allowBreak()   if (time_release !=0 && \
 590                             (++allow_break_count % time_release) == 0) \
 591                             ProcessEvent();
 592 #else
 593 # define allowBreak()  if (broken) { broken=FALSE; sigRaise(breakHandler); }
 594 #endif
 595 #endif /* !HUGS_FOR_WINDOWS */
 596
 597
 598 /*---------------------------------------------------------------------------
 599  * Environment variables and the registry
 600  *-------------------------------------------------------------------------*/
 601
 602 /* On Win32 we can use the registry to supplement info in environment
 603  * variables.
 604  */
 605 /* AJG: Commented out for now for development */
 606 /* #define USE_REGISTRY (HAVE_WINDOWS_H && !__MSDOS__) */
 607
 608 #ifdef USE_REGISTRY
 609 Bool    writeRegString          ( String var, String val );
 610 String  readRegString           ( String var, String def );
 611 Int     readRegInt              ( String var, Int def );
 612 Bool    writeRegInt             ( String var, Int val );
 613 #endif
 614
 615 #define N_INSTALLDIR 200
 616 extern char installDir[N_INSTALLDIR];
 617
 618
 619 /*---------------------------------------------------------------------------
 620  * File operations:
 621  *-------------------------------------------------------------------------*/
 622
 623 #if HAVE_UNISTD_H
 624 # include <sys/types.h>
 625 # include <unistd.h>
 626 #elif !HUGS_FOR_WINDOWS
 627 extern int      chdir           ( const char* );
 628 #endif
 629
 630 #if HAVE_STDLIB_H
 631 # include <stdlib.h>
 632 #else
 633 extern int      system          ( const char * );
 634 extern double   atof            ( const char * );
 635 extern void     exit            ( int );
 636 #endif
 637
 638 #ifndef FILENAME_MAX       /* should already be defined in an ANSI compiler*/
 639 #define FILENAME_MAX 256
 640 #else
 641 #if     FILENAME_MAX < 256
 642 #undef  FILENAME_MAX
 643 #define FILENAME_MAX 256
 644 #endif
 645 #endif
 646
 647 /* Hack, hack: if you have dos.h, you probably have a DOS filesystem */
 648 #define DOS_FILENAMES              HAVE_DOS_H
 649 /* ToDo: can we replace this with a feature test? */
 650 #define MAC_FILENAMES              SYMANTEC_C
 651
 652 #define CASE_INSENSITIVE_FILENAMES (DOS_FILENAMES | RISCOS)
 653
 654 #if CASE_INSENSITIVE_FILENAMES
 655 # if HAVE_STRCASECMP
 656 #  define filenamecmp(s1,s2) strcasecmp(s1,s2)
 657 # elif HAVE__STRICMP
 658 #  define filenamecmp(s1,s2) _stricmp(s1,s2)
 659 # elif HAVE_STRICMP
 660 #  define filenamecmp(s1,s2) stricmp(s1,s2)
 661 # elif HAVE_STRCMPI
 662 #  define filenamecmp(s1,s2) strcmpi(s1,s2)
 663 # endif
 664 #else
 665 # define filenamecmp(s1,s2) strcmp(s1,s2)
 666 #endif
 667
 668
 669 /*---------------------------------------------------------------------------
 670  * Pipe-related operations:
 671  *
 672  * On Windows, many standard Unix names acquire a leading underscore.
 673  * Irritating, but easy to work around.
 674  *-------------------------------------------------------------------------*/
 675
 676 #if !defined(HAVE_POPEN) && defined(HAVE__POPEN)
 677 #define popen(x,y) _popen(x,y)
 678 #endif
 679 #if !defined(HAVE_PCLOSE) && defined(HAVE__PCLOSE)
 680 #define pclose(x) _pclose(x)
 681 #endif
 682
 683
 684 /*---------------------------------------------------------------------------
 685  * Bit manipulation:
 686  *-------------------------------------------------------------------------*/
 687
 688 #define bitArraySize(n)    ((n)/bitsPerWord + 1)
 689 #define placeInSet(n)      ((-(n)-1)>>wordShift)
 690 #define maskInSet(n)       (1<<((-(n)-1)&wordMask))
 691
 692
 693 /*---------------------------------------------------------------------------
 694  * Function prototypes for code in machdep.c
 695  *-------------------------------------------------------------------------*/
 696
 697 extern  String findMPathname    ( String,String,String );
 698 extern  String findPathname     ( String,String );
 699 extern  Int    shellEsc         ( String );
 700 extern  Int    getTerminalWidth ( Void );
 701 extern  Void   normalTerminal   ( Void );
 702 extern  Void   noechoTerminal   ( Void );
 703 extern  Int    readTerminalChar ( Void );
 704 extern  Void   gcStarted        ( Void );
 705 extern  Void   gcScanning       ( Void );
 706 extern  Void   gcRecovered      ( Int );
 707 extern  Void   gcCStack         ( Void );
 708
 709
 710 /*---------------------------------------------------------------------------
 711  * To do with reading interface and object files
 712  *-------------------------------------------------------------------------*/
 713
 714 extern Cell   parseInterface        ( String,Long );
 715 extern ZPair  readInterface         ( String,Long );
 716 extern Bool   processInterfaces     ( Void );
 717 extern Void   getFileSize           ( String, Long * );
 718 extern Void   ifLinkConstrItbl      ( Name n );
 719 extern Void   hi_o_namesFromSrcName ( String,String*,String* oName );
 720 extern void*  lookupObjName         ( char* );
 721
 722 extern String getExtraObjectInfo    ( String primaryObjectName,
 723                                       String extraFileName,
 724                                       Int*   extraFileSize );
 725
 726 extern List /* of ZTriple(I_INTERFACE,
 727                           Text--name of obj file,
 728                           Int--size of obj file) */
 729              ifaces_outstanding;
 730
 731
 732 /* --------------------------------------------------------------------------
 733  * Interpreter command structure
 734  * ------------------------------------------------------------------------*/
 735
 736 typedef Int Command;
 737
 738 struct cmd {
 739     String cmdString;
 740     Command cmdCode;
 741 };
 742
 743 extern Command readCommand      ( struct cmd *, Char, Char );
 744
 745 #define EDIT    0
 746 #define FIND    1
 747 #define LOAD    2
 748 #define ALSO    3
 749 #define PROJECT 4
 750 #define RELOAD  5
 751 #define EVAL    6
 752 #define TYPEOF  7
 753 #define HELP    8
 754 #define NAMES   9
 755 #define BADCMD  10
 756 #define SET     11
 757 #define QUIT    12
 758 #define SYSTEM  13
 759 #define CHGDIR  14
 760 #define INFO    15
 761 #define COLLECT 16
 762 #define SETMODULE 17
 763 #define DUMP    18
 764 #define STATS   19
 765 #define BROWSE  20
 766 #define XPLAIN  21
 767 #define PNTVER  22
 768 #define NOCMD   23
 769
 770
 771 /* --------------------------------------------------------------------------
 772  * STG Syntax:
 773  *
 774  *   Rhs     -> STGCON   (Con, [Atom])
 775  *            | STGAPP   (Var, [Atom])     -- delayed application
 776  *            | Expr
 777  *
 778  *   Expr    -> LETREC   ([Var],Expr)      -- Vars contain their bound value
 779  *            | LAMBDA   ([Var],Expr)      -- all vars bound to NIL
 780  *            | CASE     (Expr,[Alt])      -- algebraic case
 781  *            | PRIMCASE (Expr,[PrimAlt])  -- primitive case
 782  *            | STGPRIM  (Prim,[Atom])
 783  *            | STGAPP   (Var, [Atom])     -- tail call
 784  *            | Var                        -- Abbreviation for STGAPP(Var,[])
 785  *
 786  *   Atom    -> Var
 787  *            | CHAR                       -- unboxed
 788  *            | INT                        -- unboxed
 789  *            | BIGNUM                     -- unboxed
 790  *            | FLOAT                      -- unboxed
 791  *            | ADDR                       -- unboxed
 792  *            | STRING                     -- boxed
 793  *
 794  *   Var     -> STGVAR   (Rhs,StgRep,info) -- let, case or lambda bound
 795  *            | Name                       -- let-bound (effectively)
 796  *                                         -- always unboxed (PTR_REP)
 797  *
 798  *   Alt     -> DEEFALT (Var,Expr)         -- var bound to NIL
 799  *            | CASEALT (Con,[Var],Expr)   -- vars bound to NIL;
 800  *                                         -- Con is Name or TUPLE
 801  *   PrimAlt -> PRIMALT ([Var],Expr)       -- vars bound to NIL or int
 802  *
 803  * We use pointer equality to distinguish variables.
 804  * The info field of a Var is used as follows in various phases:
 805  *
 806  * Translation:      unused (set to NIL on output)
 807  * Freevar analysis: list of free vars after
 808  * Lambda lifting:   freevar list or UNIT on input, discarded after
 809  * Code generation:  unused
 810  * Optimisation:     number of uses (sort-of) of let-bound variable
 811  * ------------------------------------------------------------------------*/
 812
 813 typedef Cell   StgRhs;
 814 typedef Cell   StgExpr;
 815 typedef Cell   StgAtom;
 816 typedef Cell   StgVar;       /* Could be a Name or an STGVAR */
 817 typedef Cell   StgCaseAlt;
 818 typedef Cell   StgPrimAlt;
 819 typedef Cell   StgDiscr;
 820 typedef Cell   StgRep;  /* PTR_REP | .. DOUBLE_REP */
 821
 822 #define mkStgLet(binds,body)       ap(LETREC,pair(binds,body))
 823 #define stgLetBinds(e)             fst(snd(e))
 824 #define stgLetBody(e)              snd(snd(e))
 825
 826 #define mkStgPrimVar(rhs,rep,info) ap(STGVAR,triple(rhs,rep,info))
 827 #define stgVarBody(e)              fst3(snd(e))
 828 #define stgVarRep(e)               snd3(snd(e))
 829 #define stgVarInfo(e)              thd3(snd(e))
 830
 831 #define mkStgCase(scrut,alts)      ap(CASE,pair(scrut,alts))
 832 #define stgCaseScrut(e)            fst(snd(e))
 833 #define stgCaseAlts(e)             snd(snd(e))
 834
 835 #define mkStgCaseAlt(con,vs,e)     ap(CASEALT,triple(con,vs,e))
 836 #define stgCaseAltCon(alt)         fst3(snd(alt))
 837 #define stgCaseAltVars(alt)        snd3(snd(alt))
 838 #define stgCaseAltBody(alt)        thd3(snd(alt))
 839
 840 #define mkStgDefault(v,e)          ap(DEEFALT,pair(v,e))
 841 #define stgDefaultVar(alt)         fst(snd(alt))
 842 #define stgDefaultBody(alt)        snd(snd(alt))
 843 #define isDefaultAlt(alt)          (fst(alt)==DEEFALT)
 844
 845 #define mkStgPrimCase(scrut,alts)  ap(PRIMCASE,pair(scrut,alts))
 846 #define stgPrimCaseScrut(e)        fst(snd(e))
 847 #define stgPrimCaseAlts(e)         snd(snd(e))
 848
 849 #define mkStgPrimAlt(vs,body)      ap(PRIMALT,pair(vs,body))
 850 #define stgPrimAltVars(alt)        fst(snd(alt))
 851 #define stgPrimAltBody(alt)        snd(snd(alt))
 852
 853 #define mkStgApp(fun,args)         ap(STGAPP,pair(fun,args))
 854 #define stgAppFun(e)               fst(snd(e))
 855 #define stgAppArgs(e)              snd(snd(e))
 856
 857 #define mkStgPrim(op,args)         ap(STGPRIM,pair(op,args))
 858 #define stgPrimOp(e)               fst(snd(e))
 859 #define stgPrimArgs(e)             snd(snd(e))
 860
 861 #define mkStgCon(con,args)         ap(STGCON,pair(con,args))
 862 #define stgConCon(e)               fst(snd(e))
 863 #define stgConArgs(e)              snd(snd(e))
 864
 865 #define mkStgLambda(args,body)     ap(LAMBDA,pair(args,body))
 866 #define stgLambdaArgs(e)           fst(snd(e))
 867 #define stgLambdaBody(e)           snd(snd(e))
 868
 869
 870 /* --------------------------------------------------------------------------
 871  * Utility functions for manipulating STG syntax trees.
 872  * ------------------------------------------------------------------------*/
 873
 874 extern int     stgConTag        ( StgDiscr d );
 875 extern void*   stgConInfo       ( StgDiscr d );
 876 extern int     stgDiscrTag      ( StgDiscr d );
 877
 878 extern List    makeArgs         ( Int );
 879 extern StgExpr makeStgLambda    ( List args,  StgExpr body );
 880 extern StgExpr makeStgApp       ( StgVar fun, List args );
 881 extern StgExpr makeStgLet       ( List binds, StgExpr body );
 882 extern StgExpr makeStgIf        ( StgExpr cond, StgExpr e1, StgExpr e2 );
 883 extern Bool    isStgVar         ( StgRhs rhs );
 884 extern Bool    isAtomic         ( StgRhs rhs );
 885 extern StgVar  mkStgVar         ( StgRhs rhs, Cell info );
 886
 887 #define mkStgRep(c) mkChar(c)
 888
 889
 890 /* --------------------------------------------------------------------------
 891  * STG/backendish functions
 892  * ------------------------------------------------------------------------*/
 893
 894 extern  Void  stgDefn                ( Name n, Int arity, Cell e );
 895
 896 extern  Void  implementForeignImport ( Name );
 897 extern  Void  implementForeignExport ( Name );
 898 extern  Void  implementCfun          ( Name, List );
 899 extern  Void  implementConToTag      ( Tycon );
 900 extern  Void  implementTagToCon      ( Tycon );
 901 extern  Void  implementPrim          ( Name );
 902 extern  Void  implementTuple         ( Int );
 903 #if TREX
 904 extern  Name  implementRecShw        ( Text );
 905 extern  Name  implementRecEq         ( Text );
 906 #endif
 907
 908 /* Association list storing globals assigned to dictionaries, tuples, etc */
 909 extern List stgGlobals;
 910
 911 extern List    liftBinds        ( List binds );
 912 extern StgExpr substExpr        ( List sub, StgExpr e );
 913 extern List    freeVarsBind     ( List, StgVar );
 914
 915
 916 extern Void    cgBinds          ( StgRhs );
 917 extern void*   closureOfVar     ( StgVar );
 918 extern char*   lookupHugsName   ( void* );
 919
 920
 921 /* --------------------------------------------------------------------------
 922  * Definitions for substitution data structure and operations.
 923  * ------------------------------------------------------------------------*/
 924
 925 typedef struct {                        /* Each type variable contains:    */
 926     Type bound;                         /* A type skeleton (unbound==NIL)  */
 927     Int  offs;                          /* Offset for skeleton             */
 928     Kind kind;                          /* kind annotation                 */
 929 } Tyvar;
 930
 931 #if     FIXED_SUBST                     /* storage for type variables      */
 932 extern  Tyvar           tyvars[];
 933 #else
 934 extern  Tyvar           *tyvars;        /* storage for type variables      */
 935 #endif
 936 extern  Int             typeOff;        /* offset of result type           */
 937 extern  Type            typeIs;         /* skeleton of result type         */
 938 extern  Int             typeFree;       /* freedom in instantiated type    */
 939 extern  List            predsAre;       /* list of predicates in type      */
 940 extern  List            genericVars;    /* list of generic vars            */
 941 extern  List            btyvars;        /* explicitly scoped type vars     */
 942
 943 #define tyvar(n)        (tyvars+(n))    /* nth type variable               */
 944 #define tyvNum(t)       ((t)-tyvars)    /* and the corresp. inverse funct. */
 945 #define isBound(t)      (((t)->bound) && ((t)->bound!=SKOLEM))
 946 #define aVar            mkOffset(0)     /* Simple skeletons for type vars  */
 947 #define bVar            mkOffset(1)
 948 #define enterBtyvs()    btyvars = cons(NIL,btyvars)
 949 #define leaveBtyvs()    btyvars = tl(btyvars)
 950
 951 #define deRef(tyv,t,o)  while ((tyv=getTypeVar(t,o)) && isBound(tyv)) { \
 952                             t = tyv->bound;                             \
 953                             o = tyv->offs;                              \
 954                         }
 955
 956                                         /* offs values when isNull(bound): */
 957 #define FIXED_TYVAR     0               /* fixed in current assumption     */
 958 #define UNUSED_GENERIC  1               /* not fixed, not yet encountered  */
 959 #define GENERIC         2               /* GENERIC+n==nth generic var found*/
 960
 961 extern  char            *unifyFails;    /* Unification error message       */
 962
 963 extern Void  emptySubstitution  ( Void );
 964 extern Int   newTyvars          ( Int );
 965 #define      newKindvars(n)     newTyvars(n)
 966 extern Int   newKindedVars      ( Kind );
 967 extern Kind  simpleKind         ( Int );
 968 extern Void  instantiate        ( Type );
 969
 970 extern Pair  findBtyvs          ( Text );
 971 extern Void  markBtyvs          ( Void );
 972 extern Type  localizeBtyvs      ( Type );
 973
 974 extern Tyvar *getTypeVar        ( Type,Int );
 975 extern Void  tyvarType          ( Int );
 976 extern Void  bindTv             ( Int,Type,Int );
 977 extern Cell  getDerefHead       ( Type,Int );
 978 extern Void  expandSyn          ( Tycon, Int, Type *, Int * );
 979
 980 extern Void  clearMarks         ( Void );
 981 extern Void  markAllVars        ( Void );
 982 extern Void  resetGenerics      ( Void );
 983 extern Void  markTyvar          ( Int );
 984 extern Void  markType           ( Type,Int );
 985 extern Void  markPred           ( Cell );
 986
 987 extern Type  copyTyvar          ( Int );
 988 extern Type  copyType           ( Type,Int );
 989 extern Cell  copyPred           ( Cell,Int );
 990 extern Type  dropRank2          ( Type,Int,Int );
 991 extern Type  dropRank1          ( Type,Int,Int );
 992 extern Void  liftRank2Args      ( List,Int,Int );
 993 extern Type  liftRank2          ( Type,Int,Int );
 994 extern Type  liftRank1          ( Type,Int,Int );
 995 #ifdef DEBUG_TYPES
 996 extern Type  debugTyvar         ( Int );
 997 extern Type  debugType          ( Type,Int );
 998 #endif
 999 extern Kind  copyKindvar        ( Int );
1000 extern Kind  copyKind           ( Kind,Int );
1001
1002 extern Bool  eqKind             ( Kind,Kind );
1003 extern Kind  getKind            ( Cell,Int );
1004
1005 extern List  genvarTyvar        ( Int,List );
1006 extern List  genvarType         ( Type,Int,List );
1007
1008 extern Bool  doesntOccurIn      ( Tyvar*,Type,Int );
1009 extern Bool  unify              ( Type,Int,Type,Int );
1010 extern Bool  kunify             ( Kind,Int,Kind,Int );
1011
1012 extern Void  typeTuple          ( Cell );
1013 extern Void  varKind            ( Int );
1014
1015 extern Bool  samePred           ( Cell,Int,Cell,Int );
1016 extern Bool  matchPred          ( Cell,Int,Cell,Int );
1017 extern Bool  unifyPred          ( Cell,Int,Cell,Int );
1018 extern Inst  findInstFor        ( Cell,Int );
1019
1020 extern Void  improve            ( Int,List,List );
1021 extern Void  improve1           ( Int,List,Cell,Int );
1022
1023 extern Bool  sameSchemes        ( Type,Type );
1024 extern Bool  sameType           ( Type,Int,Type,Int );
1025 extern Bool  matchType          ( Type,Int,Type,Int );
1026 extern Bool  typeMatches        ( Type,Type );
1027
1028 /*-------------------------------------------------------------------------*/