August 2002 - Hugs-Bugs

Your message to Hugs-Users awaits moderator approval
by hugs-users-admin＠haskell.org 05 Aug '02

05 Aug '02

Your mail to 'Hugs-Users' with the subject Hello,hugs-users,congratulations Is being held until the list moderator can review it for approval. The reason it is being held: Message body is too big: 128035 bytes but there's a limit of 40 KB Either the message will get posted to the list, or you will receive notification of the moderator's decision.

1 0

FFI for SPARC [was: FFI testers wanted]
by Sven Panne 03 Aug '02

03 Aug '02

Using cut-n-paste from GHC's sources (esp. Adjustor.c) quite generously, I've hacked together the missing FFI parts for SPARC. Attached is a torture test, too, which is again based on GHC stuff (ffi009.hs). Cheers, S. diff -r -u hugs98-ffi-09072002c.orig/src/builtin.c hugs98-ffi-09072002c/src/builtin.c --- hugs98-ffi-09072002c.orig/src/builtin.c Tue Jul 9 13:05:26 2002 +++ hugs98-ffi-09072002c/src/builtin.c Tue Jul 23 13:04:30 2002 @@ -2239,6 +2239,8 @@ HugsStablePtr stable; #if defined(__ppc__) char code[13*4]; +#elif defined(__sparc__) && defined(__GNUC__) + char code[44]; #else char code[16]; #endif @@ -2324,6 +2326,65 @@ } __asm__ volatile ("sync\n\tisync"); } + } +#elif defined(__sparc__) && defined(__GNUC__) + /* Mostly cut-n-pasted from GHC's Adjustor.c: + + <00>: 9C23A008 sub %sp, 8, %sp ! make room for %o4/%o5 in caller's frame + <04>: DA23A060 st %o5, [%sp + 96] ! shift registers by 2 positions + <08>: D823A05C st %o4, [%sp + 92] + <0C>: 9A10000B mov %o3, %o5 + <10>: 9810000A mov %o2, %o4 + <14>: 96100009 mov %o1, %o3 + <18>: 94100008 mov %o0, %o2 + <1C>: 13000000 sethi %hi(app), %o1 ! load up app (1 of 2) + <20>: 11000000 sethi %hi(s), %o0 ! load up s (1 of 2) + <24>: 81C26000 jmp %o1 + %lo(app) ! jump to app (load 2 of 2) + <28>: 90122000 or %o0, %lo(), %o0 ! load up s (2 of 2, delay slot) + + ccall'ing on SPARC is easy, because we are quite lucky to push a + multiple of 8 bytes (1 word stable pointer + 1 word dummy arg) in front + of the existing arguments (note that %sp must stay double-word aligned at + all times, see ABI spec at http://www.sparc.org/standards/psABI3rd.pdf) + To do this, we extend the *caller's* stack frame by 2 words and shift + the output registers used for argument passing (%o0 - %o5, we are a + *leaf* procedure because of the tail-jump) by 2 positions. This makes + room in %o0 and %o1 for the additinal arguments, namely the stable + pointer and a dummy (used for destination addr of jump on SPARC). This + shouldn't cause any problems for a C-like caller: alloca is implemented + similarly, and local variables should be accessed via %fp, not %sp. In + a nutshell: This should work! (Famous last words! :-) + */ + { + unsigned long *adj_code = (unsigned long *)pc; + adj_code[ 0] = 0x9C23A008UL; /* sub %sp, 8, %sp */ + adj_code[ 1] = 0xDA23A060UL; /* st %o5, [%sp + 96] */ + adj_code[ 2] = 0xD823A05CUL; /* st %o4, [%sp + 92] */ + adj_code[ 3] = 0x9A10000BUL; /* mov %o3, %o5 */ + adj_code[ 4] = 0x9810000AUL; /* mov %o2, %o4 */ + adj_code[ 5] = 0x96100009UL; /* mov %o1, %o3 */ + adj_code[ 6] = 0x94100008UL; /* mov %o0, %o2 */ + adj_code[ 7] = 0x13000000UL; /* sethi %hi(app), %o1 */ + adj_code[ 7] |= ((unsigned long)app) >> 10; + adj_code[ 8] = 0x11000000UL; /* sethi %hi(s), %o0 */ + adj_code[ 8] |= ((unsigned long)s) >> 10; + adj_code[ 9] = 0x81C26000UL; /* jmp %o1 + %lo(app) */ + adj_code[ 9] |= ((unsigned long)app) & 0x000003FFUL; + adj_code[10] = 0x90122000UL; /* or %o0, %lo(s), %o0 */ + adj_code[10] |= ((unsigned long)s) & 0x000003FFUL; + + /* flush cache */ + asm("flush %0" : : "r" (adj_code )); + asm("flush %0" : : "r" (adj_code + 2)); + asm("flush %0" : : "r" (adj_code + 4)); + asm("flush %0" : : "r" (adj_code + 6)); + asm("flush %0" : : "r" (adj_code + 10)); + + /* max. 5 instructions latency, and we need at >= 1 for returning */ + asm("nop"); + asm("nop"); + asm("nop"); + asm("nop"); } #else ERRMSG(0) "Foreign import wrapper is not supported on this architecture" diff -r -u hugs98-ffi-09072002c.orig/src/ffi.c hugs98-ffi-09072002c/src/ffi.c --- hugs98-ffi-09072002c.orig/src/ffi.c Sat Jul 6 12:52:00 2002 +++ hugs98-ffi-09072002c/src/ffi.c Tue Jul 23 11:54:05 2002 @@ -412,7 +412,13 @@ } fprintf(out,"("); if (extraArg) { +#ifdef __sparc__ + /* On SPARC we need an additional dummy argument due to stack alignment + restrictions, see the comment in mkThunk in builtin.c. */ + fprintf(out,"HugsStablePtr fun1, void* unusedArg"); +#else fprintf(out,"HugsStablePtr fun1"); +#endif if (nonNull(argTys)) { fprintf(out,", "); } import Foreign import Random -------------------------------------------------------------------------------- foreign import ccall "dynamic" callFun5I :: FunPtr (Int -> Int -> Int -> Int -> Int -> Int) -> (Int -> Int -> Int -> Int -> Int -> Int) foreign import ccall "wrapper" mkFun5I :: (Int -> Int -> Int -> Int -> Int -> Int) -> IO (FunPtr (Int -> Int -> Int -> Int -> Int -> Int)) manyArgs5I :: (Int -> Int -> Int -> Int -> Int -> Int) manyArgs5I a1 a2 a3 a4 a5 = (((a1 * 31 + a2) * 31 + a3) * 31 + a4) * 31 + a5 test5I :: IO () test5I = do a1 <- randomIO a2 <- randomIO a3 <- randomIO a4 <- randomIO a5 <- randomIO funAddr <- mkFun5I manyArgs5I print (callFun5I funAddr a1 a2 a3 a4 a5 == manyArgs5I a1 a2 a3 a4 a5) freeHaskellFunPtr funAddr -------------------------------------------------------------------------------- foreign import ccall "dynamic" callFun6D :: FunPtr (Double -> Double -> Double -> Double -> Double -> Double -> Double) -> (Double -> Double -> Double -> Double -> Double -> Double -> Double) foreign import ccall "wrapper" mkFun6D :: (Double -> Double -> Double -> Double -> Double -> Double -> Double) -> IO (FunPtr (Double -> Double -> Double -> Double -> Double -> Double -> Double)) manyArgs6D :: Double -> Double -> Double -> Double -> Double -> Double -> Double manyArgs6D a1 a2 a3 a4 a5 a6 = ((((a1 * 31 + a2) * 31 + a3) * 31 + a4) * 31 + a5) * 31 + a6 test6D :: IO () test6D = do a1 <- randomIO a2 <- randomIO a3 <- randomIO a4 <- randomIO a5 <- randomIO a6 <- randomIO funAddr <- mkFun6D manyArgs6D print (callFun6D funAddr a1 a2 a3 a4 a5 a6 == manyArgs6D a1 a2 a3 a4 a5 a6) freeHaskellFunPtr funAddr -------------------------------------------------------------------------------- foreign import ccall "dynamic" callFun11M :: FunPtr (Int -> Double -> Float -> Char -> Int -> Int -> Float -> Int -> Char -> Double -> Int -> Double) -> (Int -> Double -> Float -> Char -> Int -> Int -> Float -> Int -> Char -> Double -> Int -> Double) foreign import ccall "wrapper" mkFun11M :: (Int -> Double -> Float -> Char -> Int -> Int -> Float -> Int -> Char -> Double -> Int -> Double) -> IO (FunPtr (Int -> Double -> Float -> Char -> Int -> Int -> Float -> Int -> Char -> Double -> Int -> Double)) manyArgs11M :: Int -> Double -> Float -> Char -> Int -> Int -> Float -> Int -> Char -> Double -> Int -> Double manyArgs11M a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 = (((((((((fromIntegral a1 * 31 + a2) * 31 + realToFrac a3) * 31 + fromIntegral (fromEnum a4)) * 31 + fromIntegral a5) * 31 + fromIntegral a6) * 31 + realToFrac a7) * 31 + fromIntegral a8) * 31 + fromIntegral (fromEnum a9)) * 31 + a10) * 31 + fromIntegral a11 test11M :: IO () test11M = do a1 <- randomIO a2 <- randomIO a3 <- randomIO a4 <- randomIO a5 <- randomIO a6 <- randomIO a7 <- randomIO a8 <- randomIO a9 <- randomIO a10 <- randomIO a11 <- randomIO funAddr <- mkFun11M manyArgs11M print (callFun11M funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 == manyArgs11M a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) freeHaskellFunPtr funAddr -------------------------------------------------------------------------------- rep :: String -> IO () -> IO () rep msg tst = do putStrLn ("Testing " ++ msg ++ "...") sequence_ (replicate 10 tst) main :: IO () main = do setStdGen (mkStdGen 4711) rep "5 Int arguments" test5I rep "6 Double arguments" test6D rep "11 mixed arguments" test11M

2 1

preprocessor & file not found
by Ross Paterson 01 Aug '02

01 Aug '02

If I ask Hugs to read a non-existent file, e.g. "hugs Foo", I get Reading file "/usr/local/share/hugs/lib/Prelude.hs": Reading file "Foo": ERROR "Foo" - Unable to open file "Foo" Prelude> But if I say "hugs -Fcat Foo", I get Reading file "/usr/local/share/hugs/lib/Prelude.hs": Reading file "Foo": Parsingcat: Foo: No such file or directory Hugs session for: /usr/local/share/hugs/lib/Prelude.hs Foo Type :? for help Main> This is because findPathname() returns the original name if it couldn't find a file, relying on fileInput() to fail in that situation, but popen() always succeeds. The preprocessor is executed with the name as argument and fails in its own way, and Hugs doesn't know it failed. (It thinks it read an empty module, hence Main.) This patch is one way of fixing that. Index: src/input.c =================================================================== RCS file: /home/cvs/root/hugs98/src/input.c,v retrieving revision 1.47 diff -u -r1.47 input.c --- src/input.c 2002/07/19 22:13:48 1.47 +++ src/input.c 2002/08/01 13:20:02 @@ -407,8 +407,9 @@ static Bool local fileInput(nm,len) /* prepare to input characters from*/ String nm; /* named file (specified length is */ Long len; { /* used to set target for reading) */ + inputStream = fopen(nm,FOPEN_MODE); #if SUPPORT_PREPROCESSOR - if (preprocessor) { + if (preprocessor && inputStream) { Int reallen = strlen(preprocessor) + 1 + strlen(nm) + 1; char *cmd = malloc(reallen+1); if (cmd == NULL) { @@ -423,13 +424,10 @@ } else { cmd[reallen] = '\0'; } + fclose(inputStream); inputStream = popen(cmd,"r"); free(cmd); - } else { - inputStream = fopen(nm,FOPEN_MODE); } -#else - inputStream = fopen(nm,FOPEN_MODE); #endif if (inputStream) { reading = SCRIPTFILE;

1 0