X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Fmachdep.c;h=c8db3991fc37a941a1be3a3978b844a4aa64073f;hb=9957de2fa9fc8b2aea8bffb11f0791db86eb06f5;hp=cc691126d7d2f48f68b7b5f1e0fa1c7748ea3579;hpb=333e9b497dd063a37af367abd937d2f6454ae84c;p=ghc-hetmet.git diff --git a/ghc/interpreter/machdep.c b/ghc/interpreter/machdep.c index cc69112..c8db399 100644 --- a/ghc/interpreter/machdep.c +++ b/ghc/interpreter/machdep.c @@ -13,8 +13,8 @@ * included in the distribution. * * $RCSfile: machdep.c,v $ - * $Revision: 1.10 $ - * $Date: 1999/11/17 16:57:41 $ + * $Revision: 1.28 $ + * $Date: 2000/04/10 09:40:03 $ * ------------------------------------------------------------------------*/ #ifdef HAVE_SIGNAL_H @@ -45,7 +45,7 @@ #ifdef HAVE_DOS_H # include #endif -#if defined HAVE_CONIO_H && ! HUGS_FOR_WINDOWS +#if defined HAVE_CONIO_H # include #endif #ifdef HAVE_IO_H @@ -58,16 +58,6 @@ # include #endif -#if HUGS_FOR_WINDOWS -#include -#include - -extern HCURSOR HandCursor; /* Forward references to cursors */ -extern HCURSOR GarbageCursor; -extern HCURSOR SaveCursor; -static void local DrawStatusLine Args((HWND)); -#endif - #if DOS #include extern unsigned _stklen = 8000; /* Allocate an 8k stack segment */ @@ -105,48 +95,13 @@ int allow_break_count = 0; #endif /* -------------------------------------------------------------------------- - * Prototypes for registry reading - * ------------------------------------------------------------------------*/ - -#if USE_REGISTRY - -/* where have we hidden things in the registry? */ -#if HSCRIPT -#define HScriptRoot ("SOFTWARE\\Haskell\\HaskellScript\\") -#endif - -#define HugsRoot ("SOFTWARE\\Haskell\\Hugs\\" HUGS_VERSION "\\") -#define ProjectRoot ("SOFTWARE\\Haskell\\Projects\\") - -static Bool local createKey Args((HKEY, String, PHKEY, REGSAM)); -static Bool local queryValue Args((HKEY, String, String, LPDWORD, LPBYTE, DWORD)); -static Bool local setValue Args((HKEY, String, String, DWORD, LPBYTE, DWORD)); -static String local readRegString Args((HKEY, String, String, String)); -static Int local readRegInt Args((String,Int)); -static Bool local writeRegString Args((String,String)); -static Bool local writeRegInt Args((String,Int)); - -static String local readRegChildStrings Args((HKEY, String, String, Char, String)); -#endif /* USE_REGISTRY */ - -/* -------------------------------------------------------------------------- * Find information about a file: * ------------------------------------------------------------------------*/ -#if RISCOS -typedef struct { unsigned hi, lo; } Time; -#define timeChanged(now,thn) (now.hi!=thn.hi || now.lo!=thn.lo) -#define timeSet(var,tm) var.hi = tm.hi; var.lo = tm.lo -error timeEarlier not defined -#else -typedef time_t Time; -#define timeChanged(now,thn) (now!=thn) -#define timeSet(var,tm) var = tm -#define timeEarlier(earlier,now) (earlier < now) -#endif +#include "machdep_time.h" -static Bool local readable Args((String)); -static Void local getFileInfo Args((String, Time *, Long *)); +static Bool local readable ( String ); +static Void local getFileInfo ( String, Time *, Long * ); static Void local getFileInfo(f,tm,sz) /* find time stamp and size of file*/ String f; @@ -221,7 +176,7 @@ String f; { return (0 == access(f,4)); #elif defined HAVE_SYS_STAT_H || defined HAVE_STAT_H struct stat scbuf; - //fprintf(stderr, "readable: %s\n", f ); + /* fprintf(stderr, "readable: %s\n", f ); */ return ( !stat(f,&scbuf) && (scbuf.st_mode & S_IREAD) /* readable */ && (scbuf.st_mode & S_IFREG) /* regular file */ @@ -241,33 +196,35 @@ String f; { * Search for script files on the HUGS path: * ------------------------------------------------------------------------*/ -static String local hugsdir Args((Void)); +static String local hugsdir ( Void ); #if HSCRIPT -static String local hscriptDir Args((Void)); +static String local hscriptDir ( Void ); #endif -//static String local RealPath Args((String)); -static int local pathCmp Args((String, String)); -static String local normPath Args((String)); -static Void local searchChr Args((Int)); -static Void local searchStr Args((String)); -static Bool local tryEndings Args((String)); - -#if DOS_FILENAMES +static int local pathCmp ( String, String ); +static String local normPath ( String ); +static Void local searchChr ( Int ); +static Void local searchStr ( String ); +static Bool local tryEndings ( String ); + +#if (DOS_FILENAMES || __CYGWIN32__) # define SLASH '\\' # define isSLASH(c) ((c)=='\\' || (c)=='/') # define PATHSEP ';' +# define PATHSEP_STR ";" # define DLL_ENDING ".dll" #elif MAC_FILENAMES # define SLASH ':' # define isSLASH(c) ((c)==SLASH) # define PATHSEP ';' +# define PATHSEP_STR ";" /* Mac PEF (Preferred Executable Format) file */ # define DLL_ENDING ".pef" #else # define SLASH '/' # define isSLASH(c) ((c)==SLASH) # define PATHSEP ':' -# define DLL_ENDING ".o" +# define PATHSEP_STR ":" +# define DLL_ENDING ".u_o" #endif static String local hugsdir() { /* directory containing lib/Prelude.hs */ @@ -380,9 +337,9 @@ String s; { /* a pathname in some appropriate manner. */ } #if HSCRIPT -static String endings[] = { "", ".hi", ".hs", ".lhs", ".hsx", ".hash", 0 }; +static String endings[] = { "", ".u_hi", ".hs", ".lhs", ".hsx", ".hash", 0 }; #else -static String endings[] = { "", ".hi", ".hs", ".lhs", 0 }; +static String endings[] = { "", ".u_hi", ".hs", ".lhs", 0 }; #endif static char searchBuf[FILENAME_MAX+1]; static Int searchPos; @@ -518,14 +475,6 @@ String along; /* Return NULL if file does not exist */ String nm; { /* AC, 1/21/99: modified to search hugsPath first, then projectPath */ String s = findMPathname(along,nm,hugsPath); -#if USE_REGISTRY -#if 0 - ToDo: - if (s==NULL) { - s = findMPathname(along,nm,projectPath); - } -#endif /* 0 */ -#endif /* USE_REGISTRY */ return s ? s : normPath(searchBuf); } @@ -604,40 +553,46 @@ String path; { * New path handling stuff for the Combined System (tm) * ------------------------------------------------------------------------*/ -#define N_DEFAULT_LIBDIR 1000 -char defaultLibDir[N_DEFAULT_LIBDIR]; +char installDir[N_INSTALLDIR]; -/* Assumes that getcwd()++argv[0] is the absolute path to the - executable. Basically wrong. +/* Sets installDir to $STGHUGSDIR, and ensures there is a trailing + slash at the end. */ -void setDefaultLibDir ( String argv_0 ) +void setInstallDir ( String argv_0 ) { - int i; - if (argv_0[0] != SLASH) { - if (!getcwd(defaultLibDir,N_DEFAULT_LIBDIR-strlen(argv_0)-10)) { - ERRMSG(0) "Can't get current working directory" - EEND; - } - i = strlen(defaultLibDir); - defaultLibDir[i++] = SLASH; - } else { - i = 0; + int i; + char* r = getenv("STGHUGSDIR"); + if (!r) { + fprintf(stderr, + "%s: installation error: environment variable STGHUGSDIR is not set.\n", + argv_0 ); + fprintf(stderr, + "%s: pls set it to be the directory where STGHugs98 is installed.\n\n", + argv_0 ); + exit(2); + } - strcpy(&defaultLibDir[i],argv_0); - i += strlen(argv_0); - while (defaultLibDir[i] != SLASH) i--; - i++; - strcpy(&defaultLibDir[i], "lib"); - /* fprintf ( stderr, "default lib dir = %s\n", defaultLibDir ); */ + + if (strlen(r) > N_INSTALLDIR-30 ) { + fprintf(stderr, + "%s: environment variable STGHUGSDIR is suspiciously long; pls remedy\n\n", + argv_0 ); + exit(2); + } + + strcpy ( installDir, r ); + i = strlen(installDir); + if (installDir[i-1] != SLASH) installDir[i++] = SLASH; + installDir[i] = 0; } + Bool findFilesForModule ( String modName, String* path, String* sExt, - Bool* sAvail, Time* sTime, Long* sSize, - Bool* iAvail, Time* iTime, Long* iSize, - Bool* oAvail, Time* oTime, Long* oSize + Bool* sAvail, Time* sTime, Long* sSize, + Bool* oiAvail, Time* oiTime, Long* oSize, Long* iSize ) { /* Let the module name given be M. @@ -649,26 +604,45 @@ Bool findFilesForModule ( use P to fill in the path names. Otherwise, move on to the next path entry. If all path entries are exhausted, return False. + + If in standalone, only look for (and succeed for) source modules. + Caller free()s path. sExt is statically allocated. + srcExt is only set if a valid source file is found. */ Int nPath; Bool literate; String peStart, peEnd; - String augdPath; /* .:defaultLibDir:hugsPath */ + String augdPath; /* .:hugsPath:installDir/GhcPrel:installDir/lib */ + Time oTime, iTime; + Bool oAvail, iAvail; *path = *sExt = NULL; - *sAvail = *iAvail = *oAvail = FALSE; - *sSize = *iSize = *oSize = 0; + *sAvail = *oiAvail = oAvail = iAvail = FALSE; + *sSize = *oSize = *iSize = 0; - augdPath = malloc(4+strlen(defaultLibDir)+strlen(hugsPath)); + augdPath = malloc( 2*(10+3+strlen(installDir)) + +strlen(hugsPath) +10/*paranoia*/); if (!augdPath) internal("moduleNameToFileNames: malloc failed(2)"); - augdPath[0] = '.'; - augdPath[1] = PATHSEP; - augdPath[2] = 0; - strcat ( augdPath, defaultLibDir ); - augdPath[2+strlen(defaultLibDir)] = PATHSEP; - augdPath[3+strlen(defaultLibDir)] = 0; - strcat(augdPath,hugsPath); + + augdPath[0] = 0; + strcat(augdPath, "."); + strcat(augdPath, PATHSEP_STR); + + strcat(augdPath, hugsPath); + strcat(augdPath, PATHSEP_STR); + + if (combined) { + strcat(augdPath, installDir); + strcat(augdPath, "GhcPrel"); + strcat(augdPath, PATHSEP_STR); + } + + strcat(augdPath, installDir); + strcat(augdPath, "lib"); + strcat(augdPath, PATHSEP_STR); + + /* fprintf ( stderr, "augdpath = `%s'\n", augdPath ); */ peEnd = augdPath-1; while (1) { @@ -699,20 +673,25 @@ Bool findFilesForModule ( nPath += strlen(modName); /* searchBuf now holds 'P/M'. Try out the various endings. */ - *path = *sExt = NULL; - *sAvail = *iAvail = *oAvail = FALSE; - *sSize = *iSize = *oSize = 0; - - strcpy(searchBuf+nPath, DLL_ENDING); - if (readable(searchBuf)) { - *oAvail = TRUE; - getFileInfo(searchBuf, oTime, oSize); - } + *path = *sExt = NULL; + *sAvail = *oiAvail = oAvail = iAvail = FALSE; + *sSize = *oSize = *iSize = 0; - strcpy(searchBuf+nPath, ".hi"); - if (readable(searchBuf)) { - *iAvail = TRUE; - getFileInfo(searchBuf, iTime, iSize); + if (combined) { + strcpy(searchBuf+nPath, DLL_ENDING); + if (readable(searchBuf)) { + oAvail = TRUE; + getFileInfo(searchBuf, &oTime, oSize); + } + strcpy(searchBuf+nPath, HI_ENDING); + if (readable(searchBuf)) { + iAvail = TRUE; + getFileInfo(searchBuf, &iTime, iSize); + } + if (oAvail && iAvail) { + *oiAvail = TRUE; + *oiTime = whicheverIsLater ( oTime, iTime ); + } } strcpy(searchBuf+nPath, ".hs"); @@ -732,7 +711,7 @@ Bool findFilesForModule ( } /* Success? */ - if (*sAvail || (*oAvail && *iAvail)) { + if (*sAvail || *oiAvail) { nPath -= strlen(modName); *path = malloc(nPath+1); if (!(*path)) @@ -748,12 +727,49 @@ Bool findFilesForModule ( } +/* If the primaryObjectName is (eg) + /foo/bar/PrelSwamp.o + and the extraFileName is (eg) + swampy_cbits + and DLL_ENDING is set to .o + return + /foo/bar/swampy_cbits.o + and set *extraFileSize to its size, or -1 if not avail +*/ +String getExtraObjectInfo ( String primaryObjectName, + String extraFileName, + Int* extraFileSize ) +{ + Time xTime; + Long xSize; + String xtra; + + Int i = strlen(primaryObjectName)-1; + while (i >= 0 && primaryObjectName[i] != SLASH) i--; + if (i == -1) return extraFileName; + i++; + xtra = malloc ( i+3+strlen(extraFileName)+strlen(DLL_ENDING) ); + if (!xtra) internal("deriveExtraObjectName: malloc failed"); + strncpy ( xtra, primaryObjectName, i ); + xtra[i] = 0; + strcat ( xtra, extraFileName ); + strcat ( xtra, DLL_ENDING ); + + *extraFileSize = -1; + if (readable(xtra)) { + getFileInfo ( xtra, &xTime, &xSize ); + *extraFileSize = xSize; + } + return xtra; +} + + /* -------------------------------------------------------------------------- * Substitute old value of path into empty entries in new path * eg substPath("a:b:c::d:e","x:y:z") = "a:b:c:x:y:z:d:e" * ------------------------------------------------------------------------*/ -static String local substPath Args((String,String)); +static String local substPath ( String,String ); static String local substPath(new,sub) /* substitute sub path into new path*/ String new; @@ -791,9 +807,6 @@ String sub; { Bool gcMessages = FALSE; /* TRUE => print GC messages */ Void gcStarted() { /* Notify garbage collector start */ -#if HUGS_FOR_WINDOWS - SaveCursor = SetCursor(GarbageCursor); -#endif if (gcMessages) { Printf("{{Gc"); FlushStdout(); @@ -813,9 +826,6 @@ Int recovered; { Printf("%d}}",recovered); FlushStdout(); } -#if HUGS_FOR_WINDOWS - SetCursor(SaveCursor); -#endif } Cell *CStackBase; /* Retain start of C control stack */ @@ -882,7 +892,7 @@ void gcCStack() { Void gcCStack() { /* Garbage collect elements off */ Cell stackTop = NIL; /* C stack */ Cell *ptr = &stackTop; -#if SIZEOF_INTP == 2 +#if SIZEOF_VOID_P == 2 if (((long)(ptr) - (long)(CStackBase))&1) fatal("gcCStack"); #elif STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */ @@ -893,7 +903,7 @@ Void gcCStack() { /* Garbage collect elements off */ fatal("gcCStack"); #endif -#define Blargh markWithoutMove(*ptr); +#define Blargh mark(*ptr); #if 0 markWithoutMove((*ptr)/sizeof(Cell)); \ markWithoutMove(( (void*)(*ptr)-(void*)heapTopFst)/sizeof(Cell)); \ @@ -912,7 +922,7 @@ Void gcCStack() { /* Garbage collect elements off */ GuessDirection; #endif -#if SIZEOF_INTP==4 && STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */ +#if SIZEOF_VOID_P==4 && STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */ ptr = (Cell *)((long)(&stackTop) + 2); StackGrowsDown; #endif @@ -1068,7 +1078,7 @@ Int readTerminalChar() { /* read character from terminal */ if (terminalEchoReqd) { return getchar(); } else { -#if IS_WIN32 && !HUGS_FOR_WINDOWS && !__BORLANDC__ +#if IS_WIN32 && !__BORLANDC__ /* When reading a character from the console/terminal, we want * to operate in 'raw' mode (to use old UNIX tty parlance) and have * it return when a character is available and _not_ wait until @@ -1133,66 +1143,10 @@ Int readTerminalChar() { /* read character from terminal */ * Interrupt handling: * ------------------------------------------------------------------------*/ -Bool broken = FALSE; -static Bool breakReqd = FALSE; -static sigProto(ignoreBreak); -static Void local installHandlers Args((Void)); - -Bool breakOn(reqd) /* set break trapping on if reqd, */ -Bool reqd; { /* or off otherwise, returning old */ - Bool old = breakReqd; - - breakReqd = reqd; - if (reqd) { - if (broken) { /* repond to break signal received */ - broken = FALSE; /* whilst break trap disabled */ - sigRaise(breakHandler); - /* not reached */ - } -#if HANDLERS_CANT_LONGJMP - ctrlbrk(ignoreBreak); -#else - ctrlbrk(breakHandler); -#endif - } else { - ctrlbrk(ignoreBreak); - } - return old; -} - -static sigHandler(ignoreBreak) { /* record but don't respond to break*/ - ctrlbrk(ignoreBreak); /* reinstall signal handler */ - /* redundant on BSD systems but essential */ - /* on POSIX and other systems */ - broken = TRUE; - interruptStgRts(); - sigResume; -} - -#if !DONT_PANIC -static sigProto(panic); -static sigHandler(panic) { /* exit in a panic, on receipt of */ - everybody(EXIT); /* an unexpected signal */ - fprintf(stderr,"\nUnexpected signal\n"); - exit(1); - sigResume;/*NOTREACHED*/ -} -#endif /* !DONT_PANIC */ - -#if IS_WIN32 -BOOL WINAPI consoleHandler(DWORD dwCtrlType) { - switch (dwCtrlType) { /* Allows Hugs to be terminated */ - case CTRL_CLOSE_EVENT : /* from the window's close menu. */ - ExitProcess(0); - } - return FALSE; -} -#endif - -static Void local installHandlers() { /* Install handlers for all fatal */ +static Void installHandlers ( void ) { /* Install handlers for all fatal */ /* signals except SIGINT and SIGBREAK*/ #if IS_WIN32 - SetConsoleCtrlHandler(consoleHandler,TRUE); + /* SetConsoleCtrlHandler(consoleHandler,TRUE); */ #endif #if !DONT_PANIC && !DOS # ifdef SIGABRT @@ -1381,124 +1335,6 @@ int snprintf(char* buffer, int count, const char* fmt, ...) { #endif /* HAVE_SNPRINTF */ /* -------------------------------------------------------------------------- - * Read/write values from/to the registry - * - * All reads are from either HUGS_CURRENT_USER\\hugs_ROOT\\key or - * HUGS_LOCAL_MACHINE\\hugs_ROOT\\key. (Machine entry is only used if - * user entry doesn't exist). - * - * All writes are to HUGS_CURRENT_USER\\HugsRoot\\key - * ------------------------------------------------------------------------*/ - -#if USE_REGISTRY - -#define HugsRoot ("SOFTWARE\\Haskell\\Hugs\\" HUGS_VERSION "\\") - -static Bool local createKey Args((HKEY, PHKEY, REGSAM)); -static Bool local queryValue Args((HKEY, String, LPDWORD, LPBYTE, DWORD)); -static Bool local setValue Args((HKEY, String, DWORD, LPBYTE, DWORD)); - -static Bool local createKey(hKey, phRootKey, samDesired) -HKEY hKey; -PHKEY phRootKey; -REGSAM samDesired; { - DWORD dwDisp; - return RegCreateKeyEx(hKey, HugsRoot, - 0, "", REG_OPTION_NON_VOLATILE, - samDesired, NULL, phRootKey, &dwDisp) - == ERROR_SUCCESS; -} - -static Bool local queryValue(hKey, regPath, var, type, buf, bufSize) -HKEY hKey; -String regPath; -String var; -LPDWORD type; -LPBYTE buf; -DWORD bufSize; { - HKEY hRootKey; - - if (!createKey(hKey, regPath, &hRootKey, KEY_READ)) { - return FALSE; - } else { - LONG res = RegQueryValueEx(hRootKey, var, NULL, type, buf, &bufSize); - RegCloseKey(hRootKey); - return (res == ERROR_SUCCESS); - } -} - -static Bool local setValue(hKey, regPath, var, type, buf, bufSize) -HKEY hKey; -String regPath; -String var; -DWORD type; -LPBYTE buf; -DWORD bufSize; { - HKEY hRootKey; - - if (!createKey(hKey, regPath, &hRootKey, KEY_WRITE)) { - return FALSE; - } else { - LONG res = RegSetValueEx(hRootKey, var, 0, type, buf, bufSize); - RegCloseKey(hRootKey); - return (res == ERROR_SUCCESS); - } -} - -static String local readRegString(key,regPath,var,def) /* read String from registry */ -HKEY key; -String regPath; -String var; -String def; { - static char buf[300]; - DWORD type; - if (queryValue(key, regPath,var, &type, buf, sizeof(buf)) - && type == REG_SZ) { - return (String)buf; - } else { - return def; - } -} - -static Int local readRegInt(var, def) /* read Int from registry */ -String var; -Int def; { - DWORD buf; - DWORD type; - - if (queryValue(HKEY_CURRENT_USER, HugsRoot, var, &type, - (LPBYTE)&buf, sizeof(buf)) - && type == REG_DWORD) { - return (Int)buf; - } else if (queryValue(HKEY_LOCAL_MACHINE, HugsRoot, var, &type, - (LPBYTE)&buf, sizeof(buf)) - && type == REG_DWORD) { - return (Int)buf; - } else { - return def; - } -} - -static Bool local writeRegString(var,val) /* write String to registry */ -String var; -String val; { - if (NULL == val) { - val = ""; - } - return setValue(HKEY_CURRENT_USER, HugsRoot, var, - REG_SZ, (LPBYTE)val, lstrlen(val)+1); -} - -static Bool local writeRegInt(var,val) /* write String to registry */ -String var; -Int val; { - return setValue(HKEY_CURRENT_USER, HugsRoot, var, - REG_DWORD, (LPBYTE)&val, sizeof(val)); -} - -#endif /* USE_REGISTRY */ - -/* -------------------------------------------------------------------------- * Things to do with the argv/argc and the env * ------------------------------------------------------------------------*/ @@ -1520,17 +1356,12 @@ Void machdep(what) /* Handle machine specific */ Int what; { /* initialisation etc.. */ switch (what) { case MARK : break; - case INSTALL : installHandlers(); + case POSTPREL: break; + case PREPREL : installHandlers(); break; case RESET : case BREAK : case EXIT : normalTerminal(); -#if HUGS_FOR_WINDOWS - if (what==EXIT) - DestroyWindow(hWndMain); - else - SetCursor(LoadCursor(NULL,IDC_ARROW)); -#endif break; } }