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