Bug-fix patch to be applied to hugs98-Mar2005 src/char.c (rev. 1.14) fix a bug noticed by Ian Lynagh: encountering EOF in the middle of a character sequence should trigger an encoding error. src/iomonad.c (rev. 1.95) Fix bug reported by Ian Lynagh: output primitives other than hPutChar were ignoring binary mode (and getChar was too). fptools/libraries/Cabal/Distribution/Simple/Utils.hs (rev. 1.29) In sdist, avoid dropping 2 characters in the middle of the name (bug reported by Iavor Diatchki) fptools/libraries/Cabal/Distribution/Simple.hs (rev. 1.65) sdist shouldn't be reading the buildinfo file. fptools/libraries/Cabal/Distribution/Simple/SrcDist.hs (rev. 1.16) Improve sdist a bit: copy files named in main-is, license-file and c-sources. Also supply a default Setup.hs if none is present. src/char.c (revs. 1.15, 1.16) fix a bug reported in getDirectoryContents by Ian Lynagh: handle bad byte sequences in strings properly. src/builtin.c (rev. 1.84) Index: src/char.c =================================================================== RCS file: /home/cvs/root/hugs98/src/char.c,v retrieving revision 1.13 retrieving revision 1.14 diff -u -r1.13 -r1.14 --- src/char.c 15 Mar 2005 13:43:53 -0000 1.13 +++ src/char.c 16 Mar 2005 11:32:40 -0000 1.14 @@ -433,7 +433,7 @@ for (;;) { int c = fgetc(f); if (c == EOF) - return EOF; + return n == 0 ? EOF : BAD_CHAR; buf[n++] = c; if (mbtowc(&wc, buf, n) >= 0) return wc; Index: src/iomonad.c =================================================================== RCS file: /home/cvs/root/hugs98/src/iomonad.c,v retrieving revision 1.94 retrieving revision 1.95 diff -u -r1.94 -r1.95 --- src/iomonad.c 1 Feb 2005 10:17:19 -0000 1.94 +++ src/iomonad.c 17 Mar 2005 12:12:09 -0000 1.95 @@ -14,8 +14,8 @@ * the license in the file "License", which is included in the distribution. * * $RCSfile: iomonad.c,v $ - * $Revision: 1.94 $ - * $Date: 2005/02/01 10:17:19 $ + * $Revision: 1.95 $ + * $Date: 2005/03/17 12:12:09 $ * ------------------------------------------------------------------------*/ Name nameIORun; /* run IO code */ @@ -38,6 +38,7 @@ static Cell local openHandle Args((StackPtr,Cell *,Int,Bool,String)); static Cell local openFdHandle Args((StackPtr,Int,Int,Bool,String)); static Char local hGetChar Args((Int,String)); +static Void local hPutChar Args((Char,Int,String)); static Void local setRWState Args((Int,Int)); static Void local checkOpen Args((Int,String)); static Void local checkReadable Args((Int,String)); @@ -544,6 +545,18 @@ return c; } +static Void local hPutChar(Char c, Int h, String fname) { + Int retval; +#if CHAR_ENCODING + retval = handles[h].hBinaryMode ? fputc(c, handles[h].hfp) : + FPutChar(c, handles[h].hfp); +#else + retval = FPutChar(c, handles[h].hfp); +#endif + if (retval == EOF) + throwErrno(fname, TRUE, h, NULL); +} + /* If the stream is read-write, set the state, otherwise do nothing */ static Void local setRWState(Int h, Int newState) { if (handles[h].hmode&HREADWRITE) { @@ -820,22 +833,13 @@ * ------------------------------------------------------------------------*/ primFun(primGetChar) { /* Get character from stdin */ - Int c; checkOpen(HSTDIN, "getChar"); - c = FGetChar(stdin); - if (c==EOF) { - IOFail(mkIOError(&handles[HSTDIN].hcell, - nameEOFErr, - "Prelude.getChar", - "end of file", - NULL)); - } - IOReturn(mkChar(c)); + IOReturn(mkChar(hGetChar(HSTDIN, "Prelude.getChar"))); } primFun(primPutChar) { /* print character on stdout */ eval(pop()); - FPutChar(charOf(whnfHead), stdout); + hPutChar(charOf(whnfHead), HSTDOUT, "Prelude.putChar"); fflush(stdout); IOReturn(nameUnit); } @@ -846,7 +850,7 @@ while (whnfHead==nameCons) { eval(top()); checkChar(); - FPutChar(charOf(whnfHead), stdout); + hPutChar(charOf(whnfHead), HSTDOUT, "Prelude.putStr"); #if FLUSHEVERY fflush(stdout); #endif @@ -894,23 +898,12 @@ primFun(primHPutChar) { /* print character on handle */ Char c = 0; Int h; - Int retval; HandleArg(h,2+IOArity); CharArg(c,1+IOArity); checkWritable(h, "IO.hPutChar"); setRWState(h, RW_WRITING); -#if CHAR_ENCODING - if (handles[h].hBinaryMode) - retval = fputc(c, handles[h].hfp); - else - retval = FPutChar(c, handles[h].hfp); -#else - retval = FPutChar(c, handles[h].hfp); -#endif - - if ( retval == EOF ) - throwErrno("IO.hPutChar", TRUE, h, NULL); + hPutChar(c, h, "IO.hPutChar"); IOReturn(nameUnit); } @@ -926,7 +919,7 @@ eval(pop()); while (whnfHead==nameCons) { eval(pop()); - FPutChar(charOf(whnfHead),handles[h].hfp); + hPutChar(charOf(whnfHead),h,"IO.hPutStr"); #if FLUSHEVERY if ( h <= 2 ) { /* Only flush the standard handles */ fflush(handles[h].hfp); @@ -1013,7 +1006,7 @@ } primFun(primOpenBinaryFile) { /* open handle to a binary file */ - fopenPrim(root,TRUE,"IOExtensions.openBinaryFile"); + fopenPrim(root,TRUE,"System.IO.openBinaryFile"); } primFun(primStdin) { /* Standard input handle */ @@ -1447,7 +1440,7 @@ } primFun(primReadBinaryFile) { /* read file as lazy string */ - Cell hnd = openHandle(root,&IOArg(1),HREAD,TRUE,"IOExtensions.readBinaryFile"); + Cell hnd = openHandle(root,&IOArg(1),HREAD,TRUE,"System.IO.readBinaryFile"); handles[intValOf(hnd)].hmode = HSEMICLOSED; IOReturn(ap(nameHreader,hnd)); } @@ -1565,6 +1558,8 @@ String s = evalName(IOArg(2)); /* Eval and check filename */ FILE* wfp; String stmode; + Char c; + Int retval; if (!s) { IOFail(mkIOError(NULL, @@ -1589,7 +1584,14 @@ while (whnfHead==nameCons) { eval(top()); checkChar(); - FPutChar(charOf(whnfHead),wfp); + c = charOf(whnfHead); +#if CHAR_ENCODING + retval = binary ? fputc(c, wfp) : FPutChar(c, wfp); +#else + retval = FPutChar(c, wfp); +#endif + if (retval == EOF) + throwErrno(loc, TRUE, NO_HANDLE, NULL); drop(); eval(pop()); } Index: src/builtin.c =================================================================== RCS file: /home/cvs/root/hugs98/src/builtin.c,v retrieving revision 1.83 retrieving revision 1.84 diff -u -r1.83 -r1.84 --- src/builtin.c 14 Mar 2005 23:45:21 -0000 1.83 +++ src/builtin.c 27 Mar 2005 15:20:26 -0000 1.84 @@ -82,6 +82,12 @@ # include #endif +#if defined(openbsd_HOST_OS) +/* Needed for mallocBytesRWX() */ +#include +#include +#endif + #endif /* IO_MONAD */ #include "builtin.h" @@ -1951,6 +1957,7 @@ static void* mkThunk Args((void (*)(void), HugsStablePtr)); static void freeThunkAux Args((struct thunk_data*)); static void freeAllThunks Args((void)); +static void initAdjustor Args((void)); static struct thunk_data* foreignThunks = 0; @@ -1972,15 +1979,48 @@ for the C stack fixup code that we need to perform when returning in some static piece of memory and arrange to return to it before tail jumping from the adjustor thunk. - - For this to work we make the assumption that bytes in .data - are considered executable. */ -static unsigned char obscure_ccall_ret_code [] = - { 0x83, 0xc4, 0x04 /* addl $0x4, %esp */ - , 0xc3 /* ret */ - }; +static unsigned char *obscure_ccall_ret_code; /* set by initAdjustor() */ + +/* Heavily arch-specific, I'm afraid.. */ + +/* + * Allocate len bytes which are readable, writable, and executable. + * + * ToDo: If this turns out to be a performance bottleneck, one could + * e.g. cache the last VirtualProtect/mprotect-ed region and do + * nothing in case of a cache hit. + */ +static void* local mallocBytesRWX(int len) { + void *addr = (void *)malloc(len); +#if defined(openbsd_HOST_OS) + /* malloced memory isn't executable by default on OpenBSD */ + uintptr_t pageSize = sysconf(_SC_PAGESIZE); + uintptr_t mask = ~(pageSize - 1); + uintptr_t startOfFirstPage = ((uintptr_t)addr ) & mask; + uintptr_t startOfLastPage = ((uintptr_t)addr + len - 1) & mask; + uintptr_t size = startOfLastPage - startOfFirstPage + pageSize; + if (mprotect((void*)startOfFirstPage, + (size_t)size, PROT_EXEC | PROT_READ | PROT_WRITE) != 0) { + ERRMSG(0) "mallocBytesRWX: failed to protect 0x%p\n", addr + EEND; + } +#endif + return addr; +} + +#endif /* i386 || X86 */ + +/* Perform initialisation of adjustor thunk layer (if needed). */ +static void local initAdjustor() { +#if defined(__i386__) || defined(_X86_) + obscure_ccall_ret_code = (unsigned char *)mallocBytesRWX(4); + obscure_ccall_ret_code[0x00] = (unsigned char)0x83; /* addl $0x4, %esp */ + obscure_ccall_ret_code[0x01] = (unsigned char)0xc4; + obscure_ccall_ret_code[0x02] = (unsigned char)0x04; + obscure_ccall_ret_code[0x03] = (unsigned char)0xc3; /* ret */ #endif +} static void* mkThunk(void (*app)(void), HugsStablePtr s) { struct thunk_data* thunk @@ -2356,6 +2396,8 @@ Int what; { switch (what) { case INSTALL : + initAdjustor(); + registerPrims(&builtinPrims); registerPrims(&printerPrims); #if HASKELL_ARRAYS Index: fptools/libraries/Cabal/Distribution/Simple/Utils.hs =================================================================== RCS file: /home/cvs/root/fptools/libraries/Cabal/Distribution/Simple/Utils.hs,v retrieving revision 1.28 retrieving revision 1.29 diff -u -r1.28 -r1.29 --- fptools/libraries/Cabal/Distribution/Simple/Utils.hs 13 Feb 2005 02:42:58 -0000 1.28 +++ fptools/libraries/Cabal/Distribution/Simple/Utils.hs 17 Mar 2005 13:24:49 -0000 1.29 @@ -205,7 +205,7 @@ sourceLocs' <- mapM moduleToFPErr sources let sourceLocs = concat sourceLocs' let sourceLocsNoPref -- get rid of the prefix, for target location. - = if null pref then sourceLocs + = if null pref || pref == currentDir then sourceLocs else map (drop ((length pref) +1)) sourceLocs mapM (createDirectoryIfMissing True) $ nub [fst (splitFileName (targetDir `joinFileName` x)) Index: fptools/libraries/Cabal/Distribution/Simple.hs =================================================================== RCS file: /home/cvs/root/fptools/libraries/Cabal/Distribution/Simple.hs,v retrieving revision 1.64 retrieving revision 1.65 diff -u -r1.64 -r1.65 --- fptools/libraries/Cabal/Distribution/Simple.hs 4 Mar 2005 16:26:19 -0000 1.64 +++ fptools/libraries/Cabal/Distribution/Simple.hs 17 Mar 2005 16:09:13 -0000 1.65 @@ -84,7 +84,6 @@ defaultPackageDesc, defaultHookedPackageDesc, moduleToFilePath) -- Base -import System.Cmd (rawSystem) import System.Environment(getArgs) import System.Exit(ExitCode(..)) import System.Directory(removeFile, doesFileExist) @@ -406,7 +405,8 @@ -- -- * on non-Windows systems, 'postConf' runs @.\/configure@, if present. -- --- * all pre-hooks except 'preConf' read additional build information from +-- * the pre-hooks 'preBuild', 'preClean', 'preCopy', 'preInst', +-- 'preReg' and 'preUnreg' read additional build information from -- /package/@.buildinfo@, if present. -- -- Thus @configure@ can use local system information to generate @@ -423,7 +423,6 @@ preClean = readHook id, preCopy = readHook snd, preInst = readHook snd, - preSDist = readHook id, preReg = readHook thd3, preUnreg = readHook thd3 } Index: fptools/libraries/Cabal/Distribution/Simple/SrcDist.hs =================================================================== RCS file: /home/cvs/root/fptools/libraries/Cabal/Distribution/Simple/SrcDist.hs,v retrieving revision 1.15 retrieving revision 1.16 diff -u -r1.15 -r1.16 --- fptools/libraries/Cabal/Distribution/Simple/SrcDist.hs 12 Feb 2005 18:04:24 -0000 1.15 +++ fptools/libraries/Cabal/Distribution/Simple/SrcDist.hs 17 Mar 2005 16:09:56 -0000 1.16 @@ -53,13 +53,15 @@ (PackageDescription(..), BuildInfo(..), Executable(..), Library(..), setupMessage, libModules) import Distribution.Package (showPackageId) -import Distribution.Simple.Utils(smartCopySources, die, findPackageDesc) +import Distribution.Simple.Utils + (smartCopySources, die, findPackageDesc, copyFileVerbose) import Distribution.PreProcess (PPSuffixHandler, ppSuffixes, removePreprocessed) import Control.Monad(when) import System.Cmd (system) -import Distribution.Compat.Directory (doesDirectoryExist, getCurrentDirectory, copyFile) -import Distribution.Compat.FilePath (joinFileName) +import Distribution.Compat.Directory (doesFileExist, doesDirectoryExist, + getCurrentDirectory, createDirectoryIfMissing) +import Distribution.Compat.FilePath (joinFileName, splitFileName) #ifdef DEBUG import HUnit (Test) @@ -82,14 +84,26 @@ maybe (return ()) (\l -> prepareDir verbose targetDir pps (libModules pkg_descr) (libBuildInfo l)) (library pkg_descr) -- move the executables into place - sequence_ [prepareDir verbose targetDir pps [] exeBi | (Executable _ _ exeBi) <- executables pkg_descr] + flip mapM_ (executables pkg_descr) $ \ (Executable _ mainPath exeBi) -> do + prepareDir verbose targetDir pps [] exeBi + copyFileTo verbose targetDir (hsSourceDir exeBi `joinFileName` mainPath) + when (not (null (licenseFile pkg_descr))) $ + copyFileTo verbose targetDir (licenseFile pkg_descr) -- setup isn't listed in the description file. - smartCopySources verbose "" targetDir ["Setup"] ["lhs", "hs"] + hsExists <- doesFileExist "Setup.hs" + lhsExists <- doesFileExist "Setup.lhs" + if hsExists then copyFileTo verbose targetDir "Setup.hs" + else if lhsExists then copyFileTo verbose targetDir "Setup.lhs" + else writeFile (targetDir `joinFileName` "Setup.hs") $ unlines [ + "import Distribution.Simple", + "main = defaultMainWithHooks defaultUserHooks"] + -- the description file itself descFile <- getCurrentDirectory >>= findPackageDesc - copyFile descFile (joinFileName targetDir descFile) - system $ "tar --directory=" ++ tmpDir ++ " -zcf " ++ - (targetPref `joinFileName` (tarBallName pkg_descr)) - ++ " " ++ (nameVersion pkg_descr) + copyFileTo verbose targetDir descFile + + system $ "(cd " ++ tmpDir + ++ ";tar cf - " ++ (nameVersion pkg_descr) ++ ") | gzip -9 >" + ++ (targetPref `joinFileName` (tarBallName pkg_descr)) system $ "rm -rf " ++ tmpDir putStrLn "Source tarball created." @@ -100,11 +114,18 @@ -> [String] -- ^Exposed modules -> BuildInfo -> IO () -prepareDir verbose inPref pps mods BuildInfo{hsSourceDir=srcDir, otherModules=mods'} +prepareDir verbose inPref pps mods BuildInfo{hsSourceDir=srcDir, otherModules=mods', cSources=cfiles} = do let pref = inPref `joinFileName` srcDir let suff = ppSuffixes pps ++ ["hs", "lhs"] smartCopySources verbose srcDir pref (mods++mods') suff removePreprocessed pref mods suff + mapM_ (copyFileTo verbose inPref) cfiles + +copyFileTo :: Int -> FilePath -> FilePath -> IO () +copyFileTo verbose dir file = do + let targetFile = dir `joinFileName` file + createDirectoryIfMissing True (fst (splitFileName targetFile)) + copyFileVerbose verbose file targetFile ------------------------------------------------------------