/* -------------------------------------------------------------------------- * Defines storage datatypes: Text, Name, Module, Tycon, Cell, List, Pair, * Triple, ... * * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the * Yale Haskell Group, and the OGI School of Science & Engineering at OHSU, * 1994-2003, All rights reserved. It is distributed as free software under * the license in the file "License", which is included in the distribution. * * ------------------------------------------------------------------------*/ #ifndef __STORAGE_H__ #define __STORAGE_H__ /* -------------------------------------------------------------------------- * Typedefs for main data types: * Many of these type names are used to indicate the intended us of a data * item, rather than for type checking purposes. Sadly (although sometimes, * fortunately), the C compiler cannot distinguish between the use of two * different names defined to be synonyms for the same types. * ------------------------------------------------------------------------*/ typedef Int Text; /* text string */ typedef Unsigned Syntax; /* syntax (assoc,preced) */ typedef Int Addr; /* address of code */ typedef Int Cell; /* general cell value */ typedef Cell far *Heap; /* storage of heap */ typedef Cell Pair; /* pair cell */ typedef Int StackPtr; /* stack pointer */ typedef Cell Offset; /* offset/generic variable*/ typedef Int Script; /* script file number */ typedef Int Module; /* module */ typedef Cell Tycon; /* type constructor */ typedef Cell Type; /* type expression */ typedef Cell Kind; /* kind expression */ typedef Cell Kinds; /* list of kinds */ typedef Cell Constr; /* constructor expression */ typedef Cell Name; /* named value */ typedef Void (*Prim) Args((StackPtr)); /* primitive function */ typedef Cell Class; /* type class */ typedef Cell Inst; /* instance of type class */ typedef Cell Triple; /* triple of cell values */ typedef Cell List; /* list of cells */ #if BIGNUMS typedef Cell Bignum; /* bignum integer */ #endif typedef FloatImpType Float; /* implementation of Float*/ typedef DoubleImpType Double; /* implementation of Double*/ #if TREX typedef Cell Ext; /* extension label */ #endif #if OBSERVATIONS typedef Int Observe; /* observation */ typedef Int Breakpt; /* Breakpoint */ #endif #ifdef DOTNET extern Void primInvoker Args((StackPtr,Name)); #endif /* -------------------------------------------------------------------------- * Text storage: * provides storage for the characters making up identifier and symbol * names, string literals, character constants etc... * ------------------------------------------------------------------------*/ extern String textToStr Args((Text)); extern Text findText Args((String)); extern Text inventText Args((Void)); extern Text inventDictText Args((Void)); extern Bool inventedText Args((Text)); extern String identToStr Args((Cell)); extern Text fixLitText Args((Text)); extern Text concatText Args((String,String)); extern Text subText Args((String,Int)); /* -------------------------------------------------------------------------- * Specification of syntax (i.e. default written form of application) * ------------------------------------------------------------------------*/ #define MIN_PREC 0 /* weakest binding operator */ #define MAX_PREC 9 /* strongest binding operator */ #define FUN_PREC (MAX_PREC+2) /* binding of function symbols */ #define DEF_PREC MAX_PREC #define APPLIC 0 /* written applicatively */ #define LEFT_ASS 1 /* left associative infix */ #define RIGHT_ASS 2 /* right associative infix */ #define NON_ASS 3 /* non associative infix */ #define DEF_ASS LEFT_ASS #define UMINUS_PREC 6 /* Change these settings at your */ #define UMINUS_ASSOC LEFT_ASS /* own risk; they may not work! */ #define assocOf(x) ((x)&NON_ASS) #define precOf(x) ((x)>>2) #define mkSyntax(a,p) ((a)|((p)<<2)) #define DEF_OPSYNTAX mkSyntax(DEF_ASS,DEF_PREC) #define NO_SYNTAX ((Syntax)(-1)) #define FFI_NOSAFETY 0 #define FFI_SAFE 1 #define FFI_UNSAFE 2 #define FFI_THREADSAFE 4 /* Note: cconv flags are combined with the above safety flags, * so need to be disjoint. */ #define FFI_CCONV_UNKNOWN 0 #define FFI_CCONV_CCALL 8 #define FFI_CCONV_STDCALL 16 #define FFI_CCONV_DOTNET 32 #define FFI_TYPE_UNIT 0 #define FFI_TYPE_CHAR 1 #define FFI_TYPE_INT 2 #define FFI_TYPE_INT8 3 #define FFI_TYPE_INT16 4 #define FFI_TYPE_INT32 5 #define FFI_TYPE_INT64 6 #define FFI_TYPE_WORD8 7 #define FFI_TYPE_WORD16 8 #define FFI_TYPE_WORD32 9 #define FFI_TYPE_WORD64 10 #define FFI_TYPE_FLOAT 11 #define FFI_TYPE_DOUBLE 12 #define FFI_TYPE_BOOL 13 #define FFI_TYPE_ADDR 14 #define FFI_TYPE_PTR 15 #define FFI_TYPE_FUNPTR 16 #define FFI_TYPE_FOREIGN 17 #define FFI_TYPE_STABLE 18 #ifdef DOTNET #define FFI_TYPE_OBJECT 19 #define FFI_TYPE_STRING 20 #endif #ifdef DOTNET #define FFI_DOTNET_STATIC 1 #define FFI_DOTNET_FIELD 2 #define FFI_DOTNET_CTOR 4 #define FFI_DOTNET_METHOD 8 #endif /* -------------------------------------------------------------------------- * Primitive functions: * ------------------------------------------------------------------------*/ struct primitive { /* entry in table of primitives */ String ref; /* primitive reference string */ Int arity; /* primitive function arity */ Prim imp; /* primitive implementation */ }; /* Modules that define new primitive functions must register a control * function (defining INSTALL, RESET, etc code) and a (null-terminated) * table of primitive functions. * * They are stored as a linked list - so there's no wired in limits. * Control functions are called in the order they are registered * after all other control functions have been called. * (At the moment) there's no way of unregistering a module. */ struct primInfo { Void (*controlFun) Args((Int)); struct primitive *primFuns; struct primInfo *nextPrimInfo; }; extern Void registerPrims Args((struct primInfo*)); extern Void controlFuns Args((Int)); /* Call all control functions in */ /* prim list. */ extern struct primInfoDef* setPrimInfoDll Args((void*)); /* -------------------------------------------------------------------------- * Program code storage: for holding compiled function defns etc... * ------------------------------------------------------------------------*/ extern Addr getMem Args((Int)); extern Void nextInstr Args((Addr)); /* -------------------------------------------------------------------------- * Heap storage: * Provides a garbage collectable heap for storage of expressions etc. * ------------------------------------------------------------------------*/ #define heapAlloc(s) (Heap)(farCalloc(s,sizeof(Cell))) #define heapBuilt() (heapFst) extern Int heapSize; extern Heap heapFst, heapSnd; #ifdef GLOBALfst register Heap heapTopFst GLOBALfst; #else extern Heap heapTopFst; #endif #ifdef GLOBALsnd register Heap heapTopSnd GLOBALsnd; #else extern Heap heapTopSnd; #endif extern Bool consGC; /* Set to FALSE to turn off gc from*/ /* C stack; use with extreme care! */ extern Int cellsRecovered; /* cells recovered by last gc */ #define fst(c) heapTopFst[c] #define snd(c) heapTopSnd[c] #if PROFILING extern Heap heapThd, heapTopThd; #define thd(c) heapTopThd[c] extern Name producer; extern Bool profiling; extern Int profInterval; extern Void profilerLog Args((String)); #endif extern Pair pair Args((Cell,Cell)); extern Void garbageCollect Args((Void)); extern Void overwrite Args((Pair,Pair)); extern Cell markExpr Args((Cell)); extern Void markWithoutMove Args((Cell)); #define mark(v) v=markExpr(v) #define isPair(c) ((c)<0) #define isGenPair(c) ((c)<0 && -heapSize<=(c)) #if FAST_WHATIS #define whatIs(c) (isPair(c)? (isTag(fst(c)) ? fst(c) : AP ) : whatCode[c]) extern unsigned char whatCode[]; #else extern Cell whatIs Args((Cell)); #endif /* -------------------------------------------------------------------------- * Box cell tags are used as the fst element of a pair to indicate that * the snd element of the pair is to be treated in some special way, other * than as a Cell. Examples include holding integer values, variable name * and string text etc. * ------------------------------------------------------------------------*/ #define TAGMIN 1 /* Box and constructor cell tag values */ #define BCSTAG 30 /* Box=TAGMIN..BCSTAG-1 */ #define isTag(c) (TAGMIN<=(c) && (c)data))[idx]) extern DynTable* allocDynTable Args((unsigned long,unsigned long,unsigned long,const char*)); extern void freeDynTable Args((DynTable*)); extern void growDynTable Args((DynTable*)); /* -------------------------------------------------------------------------- * Constructor cell tags are used as the fst element of a pair to indicate * a particular syntactic construct described by the snd element of the * pair. * Note that a cell c will not be treated as an application (AP/isAp) node * if its first element is a constructor cell tag, whereas a cell whose fst * element is a special cell will be treated as an application node. * ------------------------------------------------------------------------*/ #define LETREC 30 /* LETREC snd :: ([Decl],Exp) */ #define COND 31 /* COND snd :: (Exp,Exp,Exp) */ #define LAMBDA 32 /* LAMBDA snd :: Alt */ #define FINLIST 33 /* FINLIST snd :: [Exp] */ #define DOCOMP 34 /* DOCOMP snd :: (Exp,[Qual]) */ #if MUDO #define MDOCOMP 44 /* MDOCOMP snd :: (Exp,[Qual]) */ #endif #define BANG 35 /* BANG snd :: Type */ #define COMP 36 /* COMP snd :: (Exp,[Qual]) */ #define ASPAT 37 /* ASPAT snd :: (Var,Exp) */ #define ESIGN 38 /* ESIGN snd :: (Exp,Type) */ #define RSIGN 39 /* RSIGN snd :: (Rhs,Type) */ #define CASE 40 /* CASE snd :: (Exp,[Alt]) */ #define NUMCASE 41 /* NUMCASE snd :: (Exp,Disc,Rhs) */ #define FATBAR 42 /* FATBAR snd :: (Exp,Exp) */ #define LAZYPAT 43 /* LAZYPAT snd :: Exp */ #define DERIVE 45 /* DERIVE snd :: Cell */ #if BREAK_FLOATS #define FLOATCELL 46 /* FLOATCELL snd :: (Int,Int) */ #endif #if BIGNUMS #define POSNUM 47 /* POSNUM snd :: [Int] */ #define NEGNUM 48 /* NEGNUM snd :: [Int] */ #endif #define BOOLQUAL 49 /* BOOLQUAL snd :: Exp */ #define QWHERE 50 /* QWHERE snd :: [Decl] */ #define FROMQUAL 51 /* FROMQUAL snd :: (Exp,Exp) */ #define DOQUAL 52 /* DOQUAL snd :: Exp */ #define MONADCOMP 53 /* MONADCOMP snd :: ((m,m0),(Exp,[Qual])*/ #define GUARDED 54 /* GUARDED snd :: [guarded exprs] */ #define ARRAY 55 /* Array snd :: (Bounds,[Values]) */ #define MUTVAR 56 /* Mutvar snd :: Cell */ #define HUGSOBJECT 57 /* HUGSOBJECT snd :: Cell */ #if STABLE_NAMES #define STABLENAME 58 /* Stable Nm snd :: Cell */ #endif #if IPARAM #define WITHEXP 59 /* WITH snd :: [(Var,Exp)] */ #endif #define POLYTYPE 60 /* POLYTYPE snd :: (Kind,Type) */ #define QUAL 61 /* QUAL snd :: ([Classes],Type) */ #define RANK2 62 /* RANK2 snd :: (Int,Type) */ #define EXIST 63 /* EXIST snd :: (Int,Type) */ #define POLYREC 64 /* POLYREC snd :: (Int,Type) */ #define BIGLAM 65 /* BIGLAM snd :: (vars,patterns) */ #define CDICTS 66 /* CDICTS snd :: ([Pred],Type) */ #define LABC 70 /* LABC snd :: (con,[(Vars,Type)]) */ #define CONFLDS 71 /* CONFLDS snd :: (con,[Field]) */ #define UPDFLDS 72 /* UPDFLDS snd :: (Exp,[con],[Field]) */ #if TREX #define RECORD 73 /* RECORD snd :: [Val] */ #define EXTCASE 74 /* EXTCASE snd :: (Exp,Disc,Rhs) */ #define RECSEL 75 /* RECSEL snd :: Ext */ #endif #define IMPDEPS 78 /* IMPDEPS snd :: [Binding] */ #define QUALIDENT 80 /* Qualified identifier snd :: (Id,Id) */ #define HIDDEN 81 /* hiding import list snd :: [Entity] */ #define MODULEENT 82 /* module in export list snd :: con */ #if OBSERVATIONS #define OBSERVEHEAD 83 /* obs. list; snd ::(first,last) */ #define OBSERVE 84 /* observe marker; snd :: (Cell,observe) */ #define OBSERVESTK 85 /* observe marker on stack */ #endif #define INFIX 90 /* INFIX snd :: (see tidyInfix) */ #define ONLY 91 /* ONLY snd :: Exp */ #define NEG 92 /* NEG snd :: Exp */ #if ZIP_COMP #define ZCOMP 93 /* ZCOMP snd :: (Exp,[[Qual]]) */ #endif #define DOUBLECELL 97 /* DOUBLECELL snd :: (Int,Int) */ #define I64CELL 98 /* Int/Word64 snd :: (Int,Int) */ #if SIZEOF_INTP != SIZEOF_INT #define PTRCELL 99 /* C Heap Pointer snd :: (Int,Int) */ #endif /* Last constructor tag must be less than SPECMIN */ /* -------------------------------------------------------------------------- * Special cell values: * ------------------------------------------------------------------------*/ #if FAST_WHATIS1 #define SPECMIN 129 /* must be out of TAG_MASK range */ #define NONE 129 /* Dummy stub */ #define STAR 130 /* Representing the kind of types */ #if TREX #define ROW 131 /* Representing the kind of rows */ #endif #define WILDCARD 132 /* Wildcard pattern */ #define SKOLEM 133 /* Skolem constant */ #define DOTDOT 134 /* ".." in import/export list */ #if BIGNUMS #define ZERONUM 136 /* The zero bignum (see POSNUM, NEGNUM) */ #endif #define NAME 138 /* whatIs code for isName */ #define TYCON 139 /* whatIs code for isTycon */ #define CLASS 140 /* whatIs code for isClass */ #define MODULE 141 /* whatIs code for isModule */ #define INSTANCE 142 /* whatIs code for isInst */ #define TUPLE 143 /* whatIs code for tuple constructor */ #define OFFSET 144 /* whatis code for offset */ #define AP 145 /* whatIs code for application node */ #if TREX #define EXT 147 /* whatIs code for isExt */ #endif #define SIGDECL 148 /* Signature declaration */ #define FIXDECL 149 /* Fixity declaration */ #define FUNBIND 150 /* Function binding */ #define PATBIND 151 /* Pattern binding */ #define DATATYPE 158 /* Datatype type constructor */ #define NEWTYPE 159 /* Newtype type constructor */ #define SYNONYM 160 /* Synonym type constructor */ #define RESTRICTSYN 161 /* Synonym with restricted scope */ #define NODEPENDS 163 /* Stop calculation of deps in type check*/ #define PREDEFINED 164 /* Predefined name, not yet filled */ #else /* !FAST_WHATIS1 */ #define SPECMIN 101 #define isSpec(c) (SPECMIN<=(c) && (c)=1 * EXECNAME = code for executable name (bytecodes or primitive) * SELNAME = code for selector function * DFUNNAME = code for dictionary builder or selector * cfunNo(i) = code for data constructor * datatypes with only one constructor uses cfunNo(0) * datatypes with multiple constructors use cfunNo(n), n>=1 */ #define EXECNAME 0 #define SELNAME 1 #define DFUNNAME 2 #define CFUNNAME 3 #define isSfun(n) (name(n).number==SELNAME) #define isDfun(n) (name(n).number==DFUNNAME) #define isCfun(n) (name(n).number>=CFUNNAME) #define cfunOf(n) (name(n).number-CFUNNAME) #define cfunNo(i) ((i)+CFUNNAME) #define hasCfun(cs) (nonNull(cs) && isCfun(hd(cs))) #define isMfun(n) (name(n).number<0) #define mfunOf(n) ((-1)-name(n).number) #define mfunNo(i) ((-1)-(i)) extern Name newName Args((Text,Cell)); extern Name findName Args((Text)); extern Name addName Args((Name)); extern Void removeName Args((Name)); extern Name findQualName Args((Cell)); extern List findQualNames Args((Cell)); extern Name findQualFun Args((Text,Text)); extern Void addPrim Args((Int,Name,String,Module,Type)); extern Name addPrimCfun Args((Text,Int,Int,Cell)); extern Int sfunPos Args((Name,Name)); extern Bool setOldDLLFlag Args((Bool)); /* -------------------------------------------------------------------------- * Type class values: * ------------------------------------------------------------------------*/ #define INSTMIN (NAMEMIN+NUM_NAME) /* instances */ #define isInst(c) (INSTMIN<=(c) && (c)(c))) extern Bool isChar Args((Cell)); extern Int charOf Args((Cell)); extern Cell mkChar Args((Int)); #else /* !UNICODE_CHARS */ #define isChar(c) (CHARMIN<=(c) && (c)=NUM_STACK-(n)) hugsStackOverflow() #define push(c) \ do { \ chkStack(1); \ onto(c); \ } while (0) #define onto(c) stack(++sp)=(c) #define pop() stack(sp--) #define drop() sp-- #define top() stack(sp) #define pushed(n) stack(sp-(n)) #define topfun(f) top()=ap((f),top()) #define toparg(x) top()=ap(top(),(x)) extern Void hugsStackOverflow Args((Void)) HUGS_noreturn; #if __MWERKS__ && macintosh #include #define STACK_HEADROOM 16384 #define STACK_CHECK if (StackSpace() <= STACK_HEADROOM) \ internal("Macintosh function parameter stack overflow."); #else #define STACK_CHECK #endif /* -------------------------------------------------------------------------- * Script file control: * The implementation of script file storage is hidden. * ------------------------------------------------------------------------*/ extern Script startNewScript Args((String)); extern Bool moduleThisScript Args((Module)); extern Module moduleOfScript Args((Script)); extern Bool isPreludeScript Args((Void)); extern Module lastModule Args((Void)); extern Script scriptThisFile Args((Text)); extern Script scriptThisName Args((Name)); extern Script scriptThisTycon Args((Tycon)); extern Script scriptThisInst Args((Inst)); extern Script scriptThisClass Args((Class)); extern String fileOfModule Args((Module)); extern Void dropAScript Args((Script)); extern Void dropScriptsFrom Args((Script)); extern Void setScriptPrims Args((void*)); /* -------------------------------------------------------------------------- * I/O Handles: * ------------------------------------------------------------------------*/ #if IO_HANDLES #define HSTDIN 0 /* Numbers for standard handles */ #define HSTDOUT 1 #define HSTDERR 2 #define IS_STANDARD_HANDLE(h) ((h) <= 2) struct strHandle { /* Handle description and status flags */ Cell hcell; /* Heap representation of handle (or NIL) */ FILE *hfp; /* Corresponding file pointer */ Int hmode; /* Current mode: see below */ Int hbufMode; /* Buffering mode. */ Int hbufSize; /* < 0 => not yet known. */ Int hRWState; /* State of a READWRITE handle (see below) */ #if CHAR_ENCODING Bool hBinaryMode; /* TRUE => Handle opened in binary mode */ Char hLookAhead; /* Char read by hLookAhead (or <0 if none) */ /* This is only used in text mode. */ #endif }; #define HCLOSED 0000 /* no I/O permitted */ #define HSEMICLOSED 0001 /* semiclosed reads only */ #define HREAD 0002 /* set to enable reads from handle */ #define HWRITE 0004 /* set to enable writes to handle */ #define HAPPEND 0010 /* opened in append mode */ #define HREADWRITE 0020 /* set to enable both reading and writing */ #define HUNKNOWN_BUFFERING (-1) /* the buffering mode of a handle is lazily determined. */ #define HANDLE_NOTBUFFERED 1 #define HANDLE_LINEBUFFERED 2 #define HANDLE_BLOCKBUFFERED 3 #define RW_NEUTRAL 0 /* r/w stream was just opened/at EOF/seeked */ #define RW_READING 1 /* last operation on r/w stream was reading */ #define RW_WRITING 2 /* last operation on r/w stream was writing */ #define NO_HANDLE (-1) #if !WANT_FIXED_SIZE_TABLES extern unsigned long num_handles; extern DynTable* dynTabHandles; extern struct strHandle* handles; #else extern struct strHandle DECTABLE(handles); #endif #endif /* -------------------------------------------------------------------------- * Malloc Pointers * ------------------------------------------------------------------------*/ #if GC_MALLOCPTRS struct strMallocPtr { /* Malloc Ptr description */ Cell mpcell; /* Back pointer to MPCELL */ Void *ptr; /* Pointer into C world */ Int refCount; /* Reference count */ Cell finalizers; /* List of finalizer functions */ /* or (finalizer, envptr) pairs */ }; typedef Void (*CFinalizer) Args((Pointer)); typedef Void (*CFinalizerEnv) Args((Pointer, Pointer)); extern struct strMallocPtr mallocPtrs[]; extern Cell newMallocPtr Args((Void *)); extern Cell mkMallocPtr Args((Void *, CFinalizer)); extern Void freeMallocPtr Args((Cell)); extern Void incMallocPtrRefCnt Args((Int, Int)); extern Int mallocPtr_hw; #define mpOf(c) snd(c) #define derefMP(c) (mallocPtrs[(Int)mpOf(c)].ptr) #endif /* GC_MALLOCPTRS */ #if GC_WEAKPTRS /* -------------------------------------------------------------------------- * Weak Pointers * ------------------------------------------------------------------------*/ #define mkWeakPtr(c) pair(WEAKCELL,pair(c,NIL)) #define derefWeakPtr(c) fst(snd(c)) #define nextWeakPtr(c) snd(snd(c)) extern List finalizers; extern List liveWeakPtrs; #endif /* GC_WEAKPTRS */ /* -------------------------------------------------------------------------- * Foreign Function Interface * ------------------------------------------------------------------------*/ #include "HsFFI.h" extern Int part1Int64 Args((HsInt64)); extern Int part2Int64 Args((HsInt64)); extern HsInt64 int64FromParts Args((Int,Int)); /* -------------------------------------------------------------------------- * Stable pointers * ------------------------------------------------------------------------*/ #if GC_STABLEPTRS extern Int mkStablePtr Args((Cell)); extern Cell derefStablePtr Args((Int)); extern Void freeStablePtr Args((Int)); #endif /* -------------------------------------------------------------------------- * Misc: * ------------------------------------------------------------------------*/ extern Void setLastExpr Args((Cell)); extern Cell getLastExpr Args((Void)); extern List addTyconsMatching Args((String,List)); extern List addNamesMatching Args((String,List)); /*-------------------------------------------------------------------------*/ #if FAST_WHATIS1 /* whatIs1 is faster than whatIs, but it will return NIL if fst(c) is NIL * Used with care in the right places it gains us speed. */ #define isTag1(c) (((c) & TAG_MASK) == 0) /* doesn't exclude NIL */ #define whatIs1(c) (isPair(c)? (isTag1(fst(c))? fst(c) : AP ) : whatCode[c]) #define isAp1(c) (isPair(c) && !isTag1(fst(c))) #endif extern Module moduleHw; /* next unused Module */ #endif /* __STORAGE_H__ */