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