From: sewardj Date: Fri, 15 Oct 1999 11:03:10 +0000 (+0000) Subject: [project @ 1999-10-15 11:02:06 by sewardj] X-Git-Tag: Approximately_9120_patches~5698 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=dfb12323d9fd0c8fb717b8e548592f20163b4ed0;p=ghc-hetmet.git [project @ 1999-10-15 11:02:06 by sewardj] Added basic support for foreign export dynamic. Many aspects of it are still broken: * Only supports x86-linux. * The range of allowable types is small: Char Int Float Double Addr and Word. * Adjustor thunks are never freed. * Returning Doubles or Floats doesn't work at all. I expect to fix some of these shortly. foreign import also needs redoing, so it can accept any number of arguments of any type. Also: * Fixed setRtsFlags in Evaluator.c to make it endian-independent. * Fixed raisePrim in Evaluator.c so things like division by zero, array index errors, etc, throw an exception instead of terminating StgHugs. raisePrim is renamed makeErrorCall. --- diff --git a/ghc/includes/Assembler.h b/ghc/includes/Assembler.h index b708712..d0c1998 100644 --- a/ghc/includes/Assembler.h +++ b/ghc/includes/Assembler.h @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- - * $Id: Assembler.h,v 1.7 1999/07/06 16:17:39 sewardj Exp $ + * $Id: Assembler.h,v 1.8 1999/10/15 11:02:06 sewardj Exp $ * * (c) The GHC Team 1994-1998. * @@ -89,9 +89,7 @@ typedef enum { ADDR_REP = 'A', FLOAT_REP = 'F', DOUBLE_REP = 'D', -#ifdef PROVIDE_STABLE STABLE_REP = 's', /* StablePtr a */ -#endif #ifdef PROVIDE_FOREIGN FOREIGN_REP = 'f', /* ForeignObj */ #endif diff --git a/ghc/interpreter/Makefile b/ghc/interpreter/Makefile index 60933d7..b82c13d 100644 --- a/ghc/interpreter/Makefile +++ b/ghc/interpreter/Makefile @@ -1,6 +1,6 @@ # ----------------------------------------------------------------------------- # -# $Id: Makefile,v 1.10 1999/07/06 15:24:35 sewardj Exp $ # +# $Id: Makefile,v 1.11 1999/10/15 11:02:09 sewardj Exp $ # # ----------------------------------------------------------------------------- # TOP = ../.. @@ -27,7 +27,7 @@ C_SRCS = link.c type.c static.c storage.c derive.c input.c compiler.c subst.c \ translate.c codegen.c lift.c free.c stgSubst.c optimise.c output.c \ hugs.c dynamic.c stg.c sainteger.c interface.c -SRC_CC_OPTS = -g -I$(GHC_DIR)/interpreter -I$(GHC_DIR)/includes -I$(GHC_DIR)/rts -D__HUGS__ -DCOMPILING_RTS -Wall -Wstrict-prototypes -DDEBUG -DDEBUG_EXTRA +SRC_CC_OPTS = -g -O -I$(GHC_DIR)/interpreter -I$(GHC_DIR)/includes -I$(GHC_DIR)/rts -D__HUGS__ -DCOMPILING_RTS -Wall -Wstrict-prototypes -Wno-unused -DDEBUG -DDEBUG_EXTRA -Winline GHC_LIBS_NEEDED = $(TOP)/ghc/rts/libHSrts.a @@ -39,7 +39,7 @@ hugs: $(C_OBJS) ../rts/Sanity.o ../rts/Assembler.o ../rts/Disassembler.o \ ../rts/StgCRun.o nHandle.so $(CC) -o $@ -rdynamic $(CC_OPTS) $^ $(GHC_LIBS_NEEDED) -lbfd -liberty -ldl -lm -nHandle.so: +nHandle.so: nHandle.c gcc -O -fPIC -shared -o nHandle.so nHandle.c $(TOP)/ghc/rts/libHSrts.a: diff --git a/ghc/interpreter/connect.h b/ghc/interpreter/connect.h index 41dc004..c2c782a 100644 --- a/ghc/interpreter/connect.h +++ b/ghc/interpreter/connect.h @@ -7,8 +7,8 @@ * in the distribution for details. * * $RCSfile: connect.h,v $ - * $Revision: 1.7 $ - * $Date: 1999/06/07 17:22:45 $ + * $Revision: 1.8 $ + * $Date: 1999/10/15 11:02:09 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -74,6 +74,7 @@ extern Name nameReturn, nameBind; /* for translating monad comps */ extern Name nameMFail; extern Name nameListMonad; /* builder function for List Monad */ extern Name namePrint; /* printing primitive */ +extern Name nameCreateAdjThunk; /* f-x-dyn: create adjustor thunk */ extern Text textPrelude; extern Text textNum; /* used to process default decls */ #if NPLUSK diff --git a/ghc/interpreter/free.c b/ghc/interpreter/free.c index d58635b..18966d9 100644 --- a/ghc/interpreter/free.c +++ b/ghc/interpreter/free.c @@ -7,8 +7,8 @@ * Hugs version 1.4, December 1997 * * $RCSfile: free.c,v $ - * $Revision: 1.4 $ - * $Date: 1999/04/27 10:06:52 $ + * $Revision: 1.5 $ + * $Date: 1999/10/15 11:02:09 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -116,7 +116,7 @@ static List freeVarsExpr( List acc, StgExpr e ) case NAME: return acc; /* Names are never free vars */ default: -printf("\n\n"); +printf("\n"); ppStgExpr(e); printf("\n"); internal("freeVarsExpr"); diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c index 8485df4..cf5a994 100644 --- a/ghc/interpreter/hugs.c +++ b/ghc/interpreter/hugs.c @@ -8,8 +8,8 @@ * in the distribution for details. * * $RCSfile: hugs.c,v $ - * $Revision: 1.10 $ - * $Date: 1999/10/11 12:22:58 $ + * $Revision: 1.11 $ + * $Date: 1999/10/15 11:02:10 $ * ------------------------------------------------------------------------*/ #include @@ -811,7 +811,8 @@ static Void local makeStackEntry ( ScriptInfo* ent, String iname ) ); if (!ok) { ERRMSG(0) - "Can't file source or object+interface for module \"%s\"", + /* "Can't file source or object+interface for module \"%s\"", */ + "Can't file source for module \"%s\"", iname EEND; } @@ -825,7 +826,6 @@ static Void local makeStackEntry ( ScriptInfo* ent, String iname ) ? (oAvail && iAvail && timeEarlier(sTime,oTime)) : TRUE; */ - fromObj = FALSE; /* ToDo: namesUpto overflow */ diff --git a/ghc/interpreter/input.c b/ghc/interpreter/input.c index afae01f..a979f25 100644 --- a/ghc/interpreter/input.c +++ b/ghc/interpreter/input.c @@ -8,8 +8,8 @@ * in the distribution for details. * * $RCSfile: input.c,v $ - * $Revision: 1.6 $ - * $Date: 1999/06/07 17:22:32 $ + * $Revision: 1.7 $ + * $Date: 1999/10/15 11:02:12 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -124,7 +124,8 @@ static Text textWildcard; static Text textModule, textImport, textInterface, textInstImport; static Text textHiding, textQualified, textAsMod; -static Text textExport, textUnsafe, text__All; +static Text textExport, textDynamic, textUUExport; +static Text textUnsafe, textUUAll; Text textNum; /* Num */ Text textPrelude; /* Prelude */ @@ -1470,12 +1471,14 @@ static Int local yylex() { /* Read next input token ... */ if (it==textInstImport) return INSTIMPORT; if (it==textImport) return IMPORT; if (it==textExport) return EXPORT; + if (it==textDynamic) return DYNAMIC; + if (it==textUUExport) return UUEXPORT; if (it==textHiding) return HIDING; if (it==textQualified) return QUALIFIED; if (it==textAsMod) return ASMOD; if (it==textWildcard) return '_'; if (it==textAll && !haskell98) return ALL; - if (it==text__All) return ALL; + if (it==textUUAll) return ALL; if (it==textRepeat && reading==KEYBOARD) return repeatLast(); @@ -1671,14 +1674,16 @@ Int what; { textModule = findText("module"); textInterface = findText("__interface"); textInstImport = findText("__instimport"); - textExport = findText("__export"); + textExport = findText("export"); + textDynamic = findText("dynamic"); + textUUExport = findText("__export"); textImport = findText("import"); textHiding = findText("hiding"); textQualified = findText("qualified"); textAsMod = findText("as"); textWildcard = findText("_"); textAll = findText("forall"); - text__All = findText("__forall"); + textUUAll = findText("__forall"); varMinus = mkVar(textMinus); varPlus = mkVar(textPlus); varBang = mkVar(textBang); diff --git a/ghc/interpreter/lib/Prelude.hs b/ghc/interpreter/lib/Prelude.hs index f1fe9a7..ebee5b4 100644 --- a/ghc/interpreter/lib/Prelude.hs +++ b/ghc/interpreter/lib/Prelude.hs @@ -60,7 +60,8 @@ module Prelude ( -- module Ratio, Ratio, Rational, (%), numerator, denominator, approxRational, -- Non-standard exports - IO(..), IOResult(..), Addr, + IO(..), IOResult(..), Addr, StablePtr, + makeStablePtr, freeStablePtr, deRefStablePtr, Bool(False, True), Maybe(Nothing, Just), @@ -111,8 +112,8 @@ module Prelude ( ,nh_free,nh_close,nh_errno,nh_flush,nh_read,primIntToChar ,unsafeInterleaveIO,nh_write,primCharToInt - -- ToDo: rm -- these are only for debugging - ,primPlusInt,primEqChar,primRunIO + -- debugging hacks + ,ST(..) ) where -- Standard value bindings {Prelude} ---------------------------------------- @@ -1383,7 +1384,7 @@ nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]] lexLitChar :: ReadS String lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s] where - lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)] + lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)] -- " lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)] lexEsc s@(d:_) | isDigit d = lexDigits s lexEsc s@(c:_) | isUpper c @@ -1548,6 +1549,13 @@ primPmFail = error "Pattern Match Failure" primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a primMkIO = ST +primCreateAdjThunk :: (a -> b) -> String -> IO Addr +primCreateAdjThunk fun typestr + = do sp <- makeStablePtr fun + p <- copy_String_to_cstring typestr -- is never freed + a <- primCreateAdjThunkARCH sp p + return a + -- The following primitives are only needed if (n+k) patterns are enabled: primPmNpk :: Integral a => Int -> a -> Maybe a primPmNpk n x = if n'<=x then Just (x-n') else Nothing @@ -1655,7 +1663,6 @@ writeFile fname contents then (ioError.IOError) ("writeFile: can't create file " ++ fname) else writetohandle fname h contents - appendFile :: FilePath -> String -> IO () appendFile fname contents = copy_String_to_cstring fname >>= \ptr -> @@ -1694,46 +1701,43 @@ instance Show Exception where data IOResult = IOResult deriving (Show) type FILE_STAR = Int -- FILE * -type Ptr = Int -- char * foreign import stdcall "nHandle.so" "nh_stdin" nh_stdin :: IO FILE_STAR foreign import stdcall "nHandle.so" "nh_stdout" nh_stdout :: IO FILE_STAR foreign import stdcall "nHandle.so" "nh_stderr" nh_stderr :: IO FILE_STAR foreign import stdcall "nHandle.so" "nh_write" nh_write :: FILE_STAR -> Int -> IO () foreign import stdcall "nHandle.so" "nh_read" nh_read :: FILE_STAR -> IO Int -foreign import stdcall "nHandle.so" "nh_open" nh_open :: Int -> Int -> IO FILE_STAR +foreign import stdcall "nHandle.so" "nh_open" nh_open :: Addr -> Int -> IO FILE_STAR foreign import stdcall "nHandle.so" "nh_flush" nh_flush :: FILE_STAR -> IO () foreign import stdcall "nHandle.so" "nh_close" nh_close :: FILE_STAR -> IO () foreign import stdcall "nHandle.so" "nh_errno" nh_errno :: IO Int -foreign import stdcall "nHandle.so" "nh_malloc" nh_malloc :: Int -> IO Ptr -foreign import stdcall "nHandle.so" "nh_free" nh_free :: Ptr -> IO () -foreign import stdcall "nHandle.so" "nh_store" nh_store :: Ptr -> Int -> IO () -foreign import stdcall "nHandle.so" "nh_load" nh_load :: Ptr -> IO Int +foreign import stdcall "nHandle.so" "nh_malloc" nh_malloc :: Int -> IO Addr +foreign import stdcall "nHandle.so" "nh_free" nh_free :: Addr -> IO () +foreign import stdcall "nHandle.so" "nh_store" nh_store :: Addr -> Int -> IO () +foreign import stdcall "nHandle.so" "nh_load" nh_load :: Addr -> IO Int foreign import stdcall "nHandle.so" "nh_argc" nh_argc :: IO Int foreign import stdcall "nHandle.so" "nh_argvb" nh_argvb :: Int -> Int -> IO Int -foreign import stdcall "nHandle.so" "nh_getenv" nh_getenv :: Ptr -> IO Ptr +foreign import stdcall "nHandle.so" "nh_getenv" nh_getenv :: Addr -> IO Addr -copy_String_to_cstring :: String -> IO Ptr +copy_String_to_cstring :: String -> IO Addr copy_String_to_cstring s = nh_malloc (1 + length s) >>= \ptr0 -> let loop ptr [] = nh_store ptr 0 >> return ptr0 - loop ptr (c:cs) = --trace ("Out `" ++ [c] ++ "'") ( - nh_store ptr (primCharToInt c) >> loop (ptr+1) cs - --) + loop ptr (c:cs) = nh_store ptr (primCharToInt c) >> loop (incAddr ptr) cs in - loop ptr0 s + if isNullAddr ptr0 + then error "copy_String_to_cstring: malloc failed" + else loop ptr0 s -copy_cstring_to_String :: Ptr -> IO String +copy_cstring_to_String :: Addr -> IO String copy_cstring_to_String ptr = nh_load ptr >>= \ci -> if ci == 0 then return [] - else copy_cstring_to_String (ptr+1) >>= \cs -> - --trace ("In " ++ show ci) ( + else copy_cstring_to_String (incAddr ptr) >>= \cs -> return ((primIntToChar ci) : cs) - --) readfromhandle :: FILE_STAR -> IO String readfromhandle h @@ -1772,7 +1776,7 @@ primGetEnv v = copy_String_to_cstring v >>= \ptr -> nh_getenv ptr >>= \ptr2 -> nh_free ptr >> - if ptr2 == 0 + if isNullAddr ptr2 then return [] else copy_cstring_to_String ptr2 >>= \result -> @@ -1799,12 +1803,12 @@ primRunST m = fst (unST m theWorld) unST (ST a) = a instance Functor (ST s) where - fmap f x = x >>= (return . f) + fmap f x = x >>= (return . f) instance Monad (ST s) where - m >> k = m >>= \ _ -> k - return x = ST $ \ s -> (x,s) - m >>= k = ST $ \s -> case unST m s of { (a,s') -> unST (k a) s' } + m >> k = ST (\s -> case unST m s of { (a,s') -> unST k s' }) + return x = ST (\s -> (x,s)) + m >>= k = ST (\s -> case unST m s of { (a,s') -> unST (k a) s' }) -- used when Hugs invokes top level function @@ -1812,7 +1816,7 @@ primRunIO :: IO () -> () primRunIO m = protect (fst (unST m realWorld)) where - realWorld = error "panic: Hugs entered the real world" + realWorld = error "primRunIO: entered the RealWorld" protect :: () -> () protect comp = primCatch comp (\e -> fst (unST (putStr (show e ++ "\n")) realWorld)) @@ -1829,12 +1833,14 @@ unsafeInterleaveIO = unsafeInterleaveST ------------------------------------------------------------------------------ --- Word, Addr, ForeignObj, Prim*Array ---------------------------------------- +-- Word, Addr, StablePtr, Prim*Array ----------------------------------------- ------------------------------------------------------------------------------ data Addr -nullAddr = primIntToAddr 0 +nullAddr = primIntToAddr 0 +incAddr a = primIntToAddr (1 + primAddrToInt a) +isNullAddr a = 0 == primAddrToInt a instance Eq Addr where (==) = primEqAddr @@ -1860,9 +1866,14 @@ instance Ord Word where (>) = primGtWord ---data ForeignObj ---makeForeignObj :: Addr -> IO ForeignObj ---makeForeignObj = primMakeForeignObj +data StablePtr a + +makeStablePtr :: a -> IO (StablePtr a) +makeStablePtr = primMakeStablePtr +deRefStablePtr :: StablePtr a -> IO a +deRefStablePtr = primDeRefStablePtr +freeStablePtr :: StablePtr a -> IO () +freeStablePtr = primFreeStablePtr data PrimArray a -- immutable arrays with Int indices @@ -1874,172 +1885,6 @@ data PrimMutableByteArray s ------------------------------------------------------------------------------- --- hooks to call libHS_cbits ------------------------------------------------- ------------------------------------------------------------------------------- -{- -type FILE_OBJ = ForeignObj -- as passed into functions -type CString = PrimByteArray -type How = Int -type Binary = Int -type OpenFlags = Int -type IOFileAddr = Addr -- as returned from functions -type FD = Int -type OpenStdFlags = Int -type Readable = Int -- really Bool -type Exclusive = Int -- really Bool -type RC = Int -- standard return code -type Bytes = PrimMutableByteArray RealWorld -type Flush = Int -- really Bool - -foreign import stdcall "libHS_cbits.so" "freeStdFileObject" - freeStdFileObject :: ForeignObj -> IO () - -foreign import stdcall "libHS_cbits.so" "freeFileObject" - freeFileObject :: ForeignObj -> IO () - -foreign import stdcall "libHS_cbits.so" "setBuf" - prim_setBuf :: FILE_OBJ -> Addr -> Int -> IO () - -foreign import stdcall "libHS_cbits.so" "getBufSize" - prim_getBufSize :: FILE_OBJ -> IO Int - -foreign import stdcall "libHS_cbits.so" "inputReady" - prim_inputReady :: FILE_OBJ -> Int -> IO RC - -foreign import stdcall "libHS_cbits.so" "fileGetc" - prim_fileGetc :: FILE_OBJ -> IO Int - -foreign import stdcall "libHS_cbits.so" "fileLookAhead" - prim_fileLookAhead :: FILE_OBJ -> IO Int - -foreign import stdcall "libHS_cbits.so" "readBlock" - prim_readBlock :: FILE_OBJ -> IO Int - -foreign import stdcall "libHS_cbits.so" "readLine" - prim_readLine :: FILE_OBJ -> IO Int - -foreign import stdcall "libHS_cbits.so" "readChar" - prim_readChar :: FILE_OBJ -> IO Int - -foreign import stdcall "libHS_cbits.so" "writeFileObject" - prim_writeFileObject :: FILE_OBJ -> Int -> IO RC - -foreign import stdcall "libHS_cbits.so" "filePutc" - prim_filePutc :: FILE_OBJ -> Char -> IO RC - -foreign import stdcall "libHS_cbits.so" "getBufStart" - prim_getBufStart :: FILE_OBJ -> Int -> IO Addr - -foreign import stdcall "libHS_cbits.so" "getWriteableBuf" - prim_getWriteableBuf :: FILE_OBJ -> IO Addr - -foreign import stdcall "libHS_cbits.so" "getBufWPtr" - prim_getBufWPtr :: FILE_OBJ -> IO Int - -foreign import stdcall "libHS_cbits.so" "setBufWPtr" - prim_setBufWPtr :: FILE_OBJ -> Int -> IO () - -foreign import stdcall "libHS_cbits.so" "closeFile" - prim_closeFile :: FILE_OBJ -> Flush -> IO RC - -foreign import stdcall "libHS_cbits.so" "fileEOF" - prim_fileEOF :: FILE_OBJ -> IO RC - -foreign import stdcall "libHS_cbits.so" "setBuffering" - prim_setBuffering :: FILE_OBJ -> Int -> IO RC - -foreign import stdcall "libHS_cbits.so" "flushFile" - prim_flushFile :: FILE_OBJ -> IO RC - -foreign import stdcall "libHS_cbits.so" "getBufferMode" - prim_getBufferMode :: FILE_OBJ -> IO RC - -foreign import stdcall "libHS_cbits.so" "seekFileP" - prim_seekFileP :: FILE_OBJ -> IO RC - -foreign import stdcall "libHS_cbits.so" "setTerminalEcho" - prim_setTerminalEcho :: FILE_OBJ -> Int -> IO RC - -foreign import stdcall "libHS_cbits.so" "getTerminalEcho" - prim_getTerminalEcho :: FILE_OBJ -> IO RC - -foreign import stdcall "libHS_cbits.so" "isTerminalDevice" - prim_isTerminalDevice :: FILE_OBJ -> IO RC - -foreign import stdcall "libHS_cbits.so" "setConnectedTo" - prim_setConnectedTo :: FILE_OBJ -> FILE_OBJ -> Int -> IO () - -foreign import stdcall "libHS_cbits.so" "ungetChar" - prim_ungetChar :: FILE_OBJ -> Char -> IO RC - -foreign import stdcall "libHS_cbits.so" "readChunk" - prim_readChunk :: FILE_OBJ -> Addr -> Int -> IO RC - -foreign import stdcall "libHS_cbits.so" "writeBuf" - prim_writeBuf :: FILE_OBJ -> Addr -> Int -> IO RC - -foreign import stdcall "libHS_cbits.so" "getFileFd" - prim_getFileFd :: FILE_OBJ -> IO FD - -foreign import stdcall "libHS_cbits.so" "fileSize_int64" - prim_fileSize_int64 :: FILE_OBJ -> Bytes -> IO RC - -foreign import stdcall "libHS_cbits.so" "getFilePosn" - prim_getFilePosn :: FILE_OBJ -> IO Int - -foreign import stdcall "libHS_cbits.so" "setFilePosn" - prim_setFilePosn :: FILE_OBJ -> Int -> IO Int - -foreign import stdcall "libHS_cbits.so" "getConnFileFd" - prim_getConnFileFd :: FILE_OBJ -> IO FD - -foreign import stdcall "libHS_cbits.so" "allocMemory__" - prim_allocMemory__ :: Int -> IO Addr - -foreign import stdcall "libHS_cbits.so" "getLock" - prim_getLock :: FD -> Exclusive -> IO RC - -foreign import stdcall "libHS_cbits.so" "openStdFile" - prim_openStdFile :: FD -> OpenStdFlags -> Readable -> IO IOFileAddr - -foreign import stdcall "libHS_cbits.so" "openFile" - prim_openFile :: CString -> How -> Binary -> OpenFlags -> IO IOFileAddr - -foreign import stdcall "libHS_cbits.so" "freeFileObject" - prim_freeFileObject :: FILE_OBJ -> IO () - -foreign import stdcall "libHS_cbits.so" "freeStdFileObject" - prim_freeStdFileObject :: FILE_OBJ -> IO () - -foreign import stdcall "libHS_cbits.so" "const_BUFSIZ" - const_BUFSIZ :: Int - -foreign import stdcall "libHS_cbits.so" "setConnNonBlockingIOFlag__" - prim_setConnNonBlockingIOFlag__ :: FILE_OBJ -> IO () - -foreign import stdcall "libHS_cbits.so" "clearConnNonBlockingIOFlag__" - prim_clearConnNonBlockingIOFlag__ :: FILE_OBJ -> IO () - -foreign import stdcall "libHS_cbits.so" "setNonBlockingIOFlag__" - prim_setNonBlockingIOFlag__ :: FILE_OBJ -> IO () - -foreign import stdcall "libHS_cbits.so" "clearNonBlockingIOFlag__" - prim_clearNonBlockingIOFlag__ :: FILE_OBJ -> IO () - -foreign import stdcall "libHS_cbits.so" "getErrStr__" - prim_getErrStr__ :: IO Addr - -foreign import stdcall "libHS_cbits.so" "getErrNo__" - prim_getErrNo__ :: IO Int - -foreign import stdcall "libHS_cbits.so" "getErrType__" - prim_getErrType__ :: IO Int - ---foreign import stdcall "libHS_cbits.so" "seekFile_int64" --- prim_seekFile_int64 :: FILE_OBJ -> Int -> Int64 -> IO RC --} - -- showFloat ------------------------------------------------------------------ showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS @@ -2194,12 +2039,6 @@ floatToDigits base x = in gen [] (r * bk) s (mUp * bk) (mDn * bk) in (map toInt (reverse rds), k) -{- --- Exponentiation with(out) a cache for the most common numbers. -expt :: Integer -> Int -> Integer -expt base n = base^n --} - -- Exponentiation with a cache for the most common numbers. minExpt = 0::Int diff --git a/ghc/interpreter/link.c b/ghc/interpreter/link.c index 6fc348c..f5bfdfd 100644 --- a/ghc/interpreter/link.c +++ b/ghc/interpreter/link.c @@ -7,8 +7,8 @@ * Hugs version 1.4, December 1997 * * $RCSfile: link.c,v $ - * $Revision: 1.7 $ - * $Date: 1999/04/27 10:06:54 $ + * $Revision: 1.8 $ + * $Date: 1999/10/15 11:02:15 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -35,9 +35,7 @@ Type typePrimMutableArray; Type typePrimMutableByteArray; Type typeFloat; Type typeDouble; -#ifdef PROVIDE_STABLE Type typeStable; -#endif #ifdef PROVIDE_WEAK Type typeWeak; #endif @@ -113,9 +111,11 @@ Name namePmLe; Name namePmSubtract; Name namePmFromInteger; Name nameMkIO; +Name nameRunST; Name nameUnpackString; Name nameError; Name nameInd; +Name nameCreateAdjThunk; Name nameAnd; Name nameConCmp; @@ -165,9 +165,7 @@ Name nameMkPrimByteArray; Name nameMkRef; Name nameMkPrimMutableArray; Name nameMkPrimMutableByteArray; -#ifdef PROVIDE_STABLE Name nameMkStable; /* StablePtr# a -> StablePtr a */ -#endif #ifdef PROVIDE_WEAK Name nameMkWeak; /* Weak# a -> Weak a */ #endif @@ -290,9 +288,7 @@ Void linkPreludeTC(void) { /* Hook to tycons and classes in */ typePrimMutableByteArray = linkTycon("PrimMutableByteArray"); typeFloat = linkTycon("Float"); typeDouble = linkTycon("Double"); -#ifdef PROVIDE_STABLE typeStable = linkTycon("StablePtr"); -#endif #ifdef PROVIDE_WEAK typeWeak = linkTycon("Weak"); #endif @@ -342,9 +338,7 @@ Void linkPreludeTC(void) { /* Hook to tycons and classes in */ nameMkA = addPrimCfunREP(findText("A#"),1,0,ADDR_REP); nameMkF = addPrimCfunREP(findText("F#"),1,0,FLOAT_REP); nameMkD = addPrimCfunREP(findText("D#"),1,0,DOUBLE_REP); -#ifdef PROVIDE_STABLE nameMkStable = addPrimCfunREP(findText("Stable#"),1,0,STABLE_REP); -#endif nameMkInteger = addPrimCfunREP(findText("Integer#"),1,0,0); #ifdef PROVIDE_FOREIGN nameMkForeign = addPrimCfunREP(findText("Foreign#"),1,0,0); @@ -477,6 +471,8 @@ Void linkPreludeNames(void) { /* Hook to names defined in Prelude */ implementPrim(n); } + nameRunST = linkName("primRunST"); + /* static(tidyInfix) */ nameNegate = linkName("negate"); /* user interface */ @@ -492,6 +488,7 @@ Void linkPreludeNames(void) { /* Hook to names defined in Prelude */ /* translator */ nameEqChar = linkName("primEqChar"); nameEqInt = linkName("primEqInt"); +nameCreateAdjThunk = linkName("primCreateAdjThunk"); #if !OVERLOADED_CONSTANTS nameEqInteger = linkName("primEqInteger"); #endif /* !OVERLOADED_CONSTANTS */ @@ -565,6 +562,9 @@ Int what; { pFun(nameError, "error"); pFun(nameUnpackString, "primUnpackString"); + // /* foreign export dynamic */ + //pFun(nameCreateAdjThunk, "primCreateAdjThunk"); + /* hooks for handwritten bytecode */ pFun(namePrimSeq, "primSeq"); pFun(namePrimCatch, "primCatch"); diff --git a/ghc/interpreter/link.h b/ghc/interpreter/link.h index b87a0e7..ce766b4 100644 --- a/ghc/interpreter/link.h +++ b/ghc/interpreter/link.h @@ -16,9 +16,7 @@ extern Name nameMkW; extern Name nameMkA; extern Name nameMkF; extern Name nameMkD; -#ifdef PROVIDE_STABLE extern Name nameMkStable; -#endif /* The following data constructors are used to make boxed but * unpointed values pointed and require no special treatment @@ -58,9 +56,7 @@ extern Type typePrimMutableArray; extern Type typePrimMutableByteArray; extern Type typeFloat; extern Type typeDouble; -#ifdef PROVIDE_STABLE extern Type typeStable; -#endif #ifdef PROVIDE_WEAK extern Type typeWeak; #endif @@ -106,6 +102,7 @@ extern Name namePmLe; extern Name namePmSubtract; extern Name namePmFromInteger; extern Name nameMkIO; +extern Name nameRunST; extern Name nameUnpackString; extern Name namePrimSeq; extern Name nameMap; diff --git a/ghc/interpreter/parser.y b/ghc/interpreter/parser.y index 4b860aa..9c73280 100644 --- a/ghc/interpreter/parser.y +++ b/ghc/interpreter/parser.y @@ -11,8 +11,8 @@ * in the distribution for details. * * $RCSfile: parser.y,v $ - * $Revision: 1.7 $ - * $Date: 1999/07/06 15:24:40 $ + * $Revision: 1.8 $ + * $Date: 1999/10/15 11:02:20 $ * ------------------------------------------------------------------------*/ %{ @@ -89,7 +89,8 @@ static Void local noTREX Args((String)); %token '!' IMPLIES '(' ',' ')' %token '[' ';' ']' '`' '.' %token TMODULE IMPORT HIDING QUALIFIED ASMOD -%token EXPORT INTERFACE REQUIRES UNSAFE INSTIMPORT +%token EXPORT UUEXPORT INTERFACE REQUIRES UNSAFE +%token INSTIMPORT DYNAMIC %% /*- Top level script/module structure -------------------------------------*/ @@ -139,7 +140,7 @@ ifDecl | INSTIMPORT CONID {$$=gc2(NIL);} - | EXPORT CONID ifEntities { addGHCExports($2,$3); + | UUEXPORT CONID ifEntities { addGHCExports($2,$3); $$=gc3(NIL);} | NUMLIT INFIXL optDigit varid_or_conid @@ -623,7 +624,7 @@ derivs : derivs ',' qconid {$$ = gc3(cons($3,$1));} topDecl : FOREIGN IMPORT callconv ext_loc ext_name unsafe_flag var COCO type {foreignImport($1,pair($4,$5),$7,$9); sp-=9;} - | FOREIGN EXPORT callconv ext_name qvarid COCO type + | FOREIGN EXPORT callconv DYNAMIC qvarid COCO type {foreignExport($1,$4,$5,$7); sp-=7;} ; diff --git a/ghc/interpreter/static.c b/ghc/interpreter/static.c index c6f9a7e..38e179d 100644 --- a/ghc/interpreter/static.c +++ b/ghc/interpreter/static.c @@ -8,8 +8,8 @@ * in the distribution for details. * * $RCSfile: static.c,v $ - * $Revision: 1.8 $ - * $Date: 1999/07/06 15:24:41 $ + * $Revision: 1.9 $ + * $Date: 1999/10/15 11:02:22 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -2789,7 +2789,6 @@ static Void local checkDefaultDefns() { /* check that default types are */ } -/*-- from STG --*/ /* -------------------------------------------------------------------------- * Foreign import declarations are Hugs' equivalent of GHC's ccall mechanism. * They are used to "import" C functions into a module. @@ -2869,61 +2868,6 @@ Name p; { - -#if 0 -/*-- from 98 --*/ -/* -------------------------------------------------------------------------- - * Primitive definitions are usually only included in the first script - * file read - the prelude. A primitive definition associates a variable - * name with a string (which identifies a built-in primitive) and a type. - * ------------------------------------------------------------------------*/ - -Void primDefn(line,prims,type) /* Handle primitive definitions */ -Cell line; -List prims; -Cell type; { - primDefns = cons(triple(line,prims,type),primDefns); -} - -static List local checkPrimDefn(pd) /* Check primitive definition */ -Triple pd; { - Int line = intOf(fst3(pd)); - List prims = snd3(pd); - Type type = thd3(pd); - emptySubstitution(); - type = checkSigType(line,"primitive definition",fst(hd(prims)),type); - for (; nonNull(prims); prims=tl(prims)) { - Cell p = hd(prims); - Bool same = isVar(p); - Text pt = textOf(same ? p : fst(p)); - String pr = textToStr(textOf(same ? p : snd(p))); - hd(prims) = addNewPrim(line,pt,pr,type); - } - return snd3(pd); -} - -static Name local addNewPrim(l,vn,s,t) /* make binding of variable vn to */ -Int l; /* primitive function referred */ -Text vn; /* to by s, with given type t */ -String s; -Cell t;{ - Name n = findName(vn); - - if (isNull(n)) { - n = newName(vn,NIL); - } else if (name(n).defn!=PREDEFINED) { - duplicateError(l,name(n).mod,vn,"primitive"); - } - - addPrim(l,n,s,t); - return n; -} -#endif - - - - - /* -------------------------------------------------------------------------- * Static analysis of patterns: * diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c index 7de66ab..2015905 100644 --- a/ghc/interpreter/storage.c +++ b/ghc/interpreter/storage.c @@ -8,8 +8,8 @@ * in the distribution for details. * * $RCSfile: storage.c,v $ - * $Revision: 1.8 $ - * $Date: 1999/07/06 15:24:43 $ + * $Revision: 1.9 $ + * $Date: 1999/10/15 11:02:26 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -503,6 +503,16 @@ Name nameFromStgVar ( StgVar v ) return NIL; } +void* getHugs_AsmObject_for ( char* s ) +{ + StgVar v; + Name n = findName(findText(s)); + if (isNull(n)) internal("getHugs_AsmObject_for(1)"); + v = name(n).stgVar; + if (!isStgVar(v) || !isPtr(stgVarInfo(v))) + internal("getHugs_AsmObject_for(2)"); + return ptrOf(stgVarInfo(v)); +} /* -------------------------------------------------------------------------- * Primitive functions: diff --git a/ghc/interpreter/translate.c b/ghc/interpreter/translate.c index 53647c2..8c11034 100644 --- a/ghc/interpreter/translate.c +++ b/ghc/interpreter/translate.c @@ -8,8 +8,8 @@ * Hugs version 1.4, December 1997 * * $RCSfile: translate.c,v $ - * $Revision: 1.7 $ - * $Date: 1999/04/27 10:07:08 $ + * $Revision: 1.8 $ + * $Date: 1999/10/15 11:02:35 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -534,11 +534,15 @@ List scs; { /* in incr order of strict comps. */ * Foreign function calls and primops * ------------------------------------------------------------------------*/ -static String charListToString( List cs ); -static Cell foreignResultTy( Type t ); -static Cell foreignArgTy( Type t ); -static Name repToBox Args(( char c )); -static StgRhs makeStgPrim Args(( Name,Bool,List,String,String )); +/* Outbound denotes data moving from Haskell world to elsewhere. + Inbound denotes data moving from elsewhere to Haskell world. +*/ +static String charListToString ( List cs ); +static Cell foreignTy ( Bool outBound, Type t ); +static Cell foreignOutboundTy ( Type t ); +static Cell foreignInboundTy ( Type t ); +static Name repToBox ( char c ); +static StgRhs makeStgPrim ( Name,Bool,List,String,String ); static String charListToString( List cs ) { @@ -553,11 +557,13 @@ static String charListToString( List cs ) return textToStr(findText(s)); } -static Cell foreignResultTy( Type t ) +static Cell foreignTy ( Bool outBound, Type t ) { if (t == typeChar) return mkChar(CHAR_REP); else if (t == typeInt) return mkChar(INT_REP); +#if 0 else if (t == typeInteger)return mkChar(INTEGER_REP); +#endif else if (t == typeWord) return mkChar(WORD_REP); else if (t == typeAddr) return mkChar(ADDR_REP); else if (t == typeFloat) return mkChar(FLOAT_REP); @@ -566,6 +572,7 @@ static Cell foreignResultTy( Type t ) else if (t == typeForeign)return mkChar(FOREIGN_REP); /* ToDo: argty only! */ #endif +#if 0 else if (t == typePrimByteArray) return mkChar(BARR_REP); /* ToDo: argty only! */ else if (whatIs(t) == AP) { @@ -573,16 +580,29 @@ static Cell foreignResultTy( Type t ) if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP); /* ToDo: argty only! */ } +#endif /* ToDo: decent line numbers! */ - ERRMSG(0) "Illegal foreign type" ETHEN - ERRTEXT " \"" ETHEN ERRTYPE(t); - ERRTEXT "\"" - EEND; + if (outBound) { + ERRMSG(0) "Illegal outbound (away from Haskell) type" ETHEN + ERRTEXT " \"" ETHEN ERRTYPE(t); + ERRTEXT "\"" + EEND; + } else { + ERRMSG(0) "Illegal inbound (towards Haskell) type" ETHEN + ERRTEXT " \"" ETHEN ERRTYPE(t); + ERRTEXT "\"" + EEND; + } +} + +static Cell foreignOutboundTy ( Type t ) +{ + return foreignTy ( TRUE, t ); } -static Cell foreignArgTy( Type t ) +static Cell foreignInboundTy ( Type t ) { - return foreignResultTy( t ); + return foreignTy ( FALSE, t ); } static Name repToBox( char c ) @@ -600,9 +620,7 @@ static Name repToBox( char c ) case REF_REP: return nameMkRef; case MUTARR_REP: return nameMkPrimMutableArray; case MUTBARR_REP: return nameMkPrimMutableByteArray; -#ifdef PROVIDE_STABLE case STABLE_REP: return nameMkStable; -#endif #ifdef PROVIDE_WEAK case WEAK_REP: return nameMkWeak; #endif @@ -765,7 +783,7 @@ String r_reps; { } } -Void implementPrim( n ) +Void implementPrim ( n ) Name n; { const AsmPrim* p = name(n).primop; StgRhs rhs = makeStgPrim(n,p->monad!=MONAD_Id,NIL,p->args,p->results); @@ -797,9 +815,9 @@ Name n; { * :: * Addr -> (Int -> Float -> IO (Char,Addr)) */ -Void implementForeignImport( Name n ) +Void implementForeignImport ( Name n ) { - Type t = name(n).type; + Type t = name(n).type; List argTys = NIL; List resultTys = NIL; CFunDescriptor* descriptor = 0; @@ -828,8 +846,8 @@ Void implementForeignImport( Name n ) } else { resultTys = singleton(resultTys); } - mapOver(foreignArgTy,argTys); /* allows foreignObj, byteArrays, etc */ - mapOver(foreignResultTy,resultTys); /* doesn't */ + mapOver(foreignOutboundTy,argTys); /* allows foreignObj, byteArrays, etc */ + mapOver(foreignInboundTy,resultTys); /* doesn't */ descriptor = mkDescriptor(charListToString(argTys), charListToString(resultTys)); name(n).primop = addState ? &ccall_IO : &ccall_Id; @@ -847,7 +865,7 @@ Void implementForeignImport( Name n ) textToStr(textOf(fst(extName))) EEND; } - //ppStg(v); + /* ppStg(v); */ name(n).defn = NIL; name(n).stgVar = v; name(n).stgSize = stgSize(stgVarBody(v)); @@ -856,9 +874,94 @@ Void implementForeignImport( Name n ) } } -Void implementForeignExport( Name n ) + +/* Generate code: + * + * \ fun s0 -> + let e1 = A# "...." + in primMkAdjThunk fun s0 e1 + + we require, and check that, + fun :: prim_arg* -> IO prim_result + */ +Void implementForeignExport ( Name n ) { - internal("implementForeignExport: not implemented"); + Type t = name(n).type; + List argTys = NIL; + List resultTys = NIL; + + if (getHead(t)==typeArrow && argCount==2) { + t = arg(fun(t)); + } else { + ERRMSG(0) "foreign export has illegal type" ETHEN + ERRTEXT " \"" ETHEN ERRTYPE(t); + ERRTEXT "\"" + EEND; + } + + while (getHead(t)==typeArrow && argCount==2) { + Type ta = fullExpand(arg(fun(t))); + Type tr = arg(t); + argTys = cons(ta,argTys); + t = tr; + } + argTys = rev(argTys); + if (getHead(t) == typeIO) { + resultTys = getArgs(t); + assert(length(resultTys) == 1); + resultTys = hd(resultTys); + } else { + ERRMSG(0) "foreign export doesn't return an IO type" ETHEN + ERRTEXT " \"" ETHEN ERRTYPE(t); + ERRTEXT "\"" + EEND; + } + resultTys = fullExpand(resultTys); + + mapOver(foreignInboundTy,argTys); + + { + List tdList; + Text tdText; + List args; + StgVar e1, e2, v; + StgExpr fun; + + tdList = cons(mkChar(':'),argTys); + if (resultTys != typeUnit) + tdList = cons(foreignOutboundTy(resultTys),tdList); + + tdText = findText(charListToString ( tdList )); + args = makeArgs(2); + e1 = mkStgVar( + mkStgCon(nameMkA,singleton(ap(STRCELL,tdText))), + NIL + ); + e2 = mkStgVar( + mkStgApp(nameUnpackString,singleton(e1)), + NIL + ); + + fun = mkStgLambda( + args, + mkStgLet( + doubleton(e1,e2), + mkStgApp( + nameCreateAdjThunk, + tripleton(hd(args),e2,hd(tl(args))) + ) + ) + ); + + v = mkStgVar(fun,NIL); + /* ppStg(v); */ + + name(n).defn = NIL; + name(n).stgVar = v; + name(n).stgSize = stgSize(stgVarBody(v)); + name(n).inlineMe = FALSE; + stgGlobals = cons(pair(n,v),stgGlobals); + } } // ToDo: figure out how to set inlineMe for these (non-Name) things diff --git a/ghc/interpreter/type.c b/ghc/interpreter/type.c index ff794f7..f5430d5 100644 --- a/ghc/interpreter/type.c +++ b/ghc/interpreter/type.c @@ -8,8 +8,8 @@ * in the distribution for details. * * $RCSfile: type.c,v $ - * $Revision: 1.7 $ - * $Date: 1999/06/07 17:22:31 $ + * $Revision: 1.8 $ + * $Date: 1999/10/15 11:02:40 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -2469,10 +2469,7 @@ Char k; { case REF_REP: return ap2(typeRef,mkStateVar(),mkAlphaVar()); case MUTARR_REP: return ap2(typePrimMutableArray,mkStateVar(),mkAlphaVar()); case MUTBARR_REP: return ap(typePrimMutableByteArray,mkStateVar()); -#ifdef PROVIDE_STABLE - case STABLE_REP: - return ap(typeStable,mkAlphaVar()); -#endif + case STABLE_REP: return ap(typeStable,mkAlphaVar()); #ifdef PROVIDE_WEAK case WEAK_REP: return ap(typeWeak,mkAlphaVar()); diff --git a/ghc/lib/hugs/Prelude.hs b/ghc/lib/hugs/Prelude.hs index f1fe9a7..ebee5b4 100644 --- a/ghc/lib/hugs/Prelude.hs +++ b/ghc/lib/hugs/Prelude.hs @@ -60,7 +60,8 @@ module Prelude ( -- module Ratio, Ratio, Rational, (%), numerator, denominator, approxRational, -- Non-standard exports - IO(..), IOResult(..), Addr, + IO(..), IOResult(..), Addr, StablePtr, + makeStablePtr, freeStablePtr, deRefStablePtr, Bool(False, True), Maybe(Nothing, Just), @@ -111,8 +112,8 @@ module Prelude ( ,nh_free,nh_close,nh_errno,nh_flush,nh_read,primIntToChar ,unsafeInterleaveIO,nh_write,primCharToInt - -- ToDo: rm -- these are only for debugging - ,primPlusInt,primEqChar,primRunIO + -- debugging hacks + ,ST(..) ) where -- Standard value bindings {Prelude} ---------------------------------------- @@ -1383,7 +1384,7 @@ nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]] lexLitChar :: ReadS String lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s] where - lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)] + lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)] -- " lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)] lexEsc s@(d:_) | isDigit d = lexDigits s lexEsc s@(c:_) | isUpper c @@ -1548,6 +1549,13 @@ primPmFail = error "Pattern Match Failure" primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a primMkIO = ST +primCreateAdjThunk :: (a -> b) -> String -> IO Addr +primCreateAdjThunk fun typestr + = do sp <- makeStablePtr fun + p <- copy_String_to_cstring typestr -- is never freed + a <- primCreateAdjThunkARCH sp p + return a + -- The following primitives are only needed if (n+k) patterns are enabled: primPmNpk :: Integral a => Int -> a -> Maybe a primPmNpk n x = if n'<=x then Just (x-n') else Nothing @@ -1655,7 +1663,6 @@ writeFile fname contents then (ioError.IOError) ("writeFile: can't create file " ++ fname) else writetohandle fname h contents - appendFile :: FilePath -> String -> IO () appendFile fname contents = copy_String_to_cstring fname >>= \ptr -> @@ -1694,46 +1701,43 @@ instance Show Exception where data IOResult = IOResult deriving (Show) type FILE_STAR = Int -- FILE * -type Ptr = Int -- char * foreign import stdcall "nHandle.so" "nh_stdin" nh_stdin :: IO FILE_STAR foreign import stdcall "nHandle.so" "nh_stdout" nh_stdout :: IO FILE_STAR foreign import stdcall "nHandle.so" "nh_stderr" nh_stderr :: IO FILE_STAR foreign import stdcall "nHandle.so" "nh_write" nh_write :: FILE_STAR -> Int -> IO () foreign import stdcall "nHandle.so" "nh_read" nh_read :: FILE_STAR -> IO Int -foreign import stdcall "nHandle.so" "nh_open" nh_open :: Int -> Int -> IO FILE_STAR +foreign import stdcall "nHandle.so" "nh_open" nh_open :: Addr -> Int -> IO FILE_STAR foreign import stdcall "nHandle.so" "nh_flush" nh_flush :: FILE_STAR -> IO () foreign import stdcall "nHandle.so" "nh_close" nh_close :: FILE_STAR -> IO () foreign import stdcall "nHandle.so" "nh_errno" nh_errno :: IO Int -foreign import stdcall "nHandle.so" "nh_malloc" nh_malloc :: Int -> IO Ptr -foreign import stdcall "nHandle.so" "nh_free" nh_free :: Ptr -> IO () -foreign import stdcall "nHandle.so" "nh_store" nh_store :: Ptr -> Int -> IO () -foreign import stdcall "nHandle.so" "nh_load" nh_load :: Ptr -> IO Int +foreign import stdcall "nHandle.so" "nh_malloc" nh_malloc :: Int -> IO Addr +foreign import stdcall "nHandle.so" "nh_free" nh_free :: Addr -> IO () +foreign import stdcall "nHandle.so" "nh_store" nh_store :: Addr -> Int -> IO () +foreign import stdcall "nHandle.so" "nh_load" nh_load :: Addr -> IO Int foreign import stdcall "nHandle.so" "nh_argc" nh_argc :: IO Int foreign import stdcall "nHandle.so" "nh_argvb" nh_argvb :: Int -> Int -> IO Int -foreign import stdcall "nHandle.so" "nh_getenv" nh_getenv :: Ptr -> IO Ptr +foreign import stdcall "nHandle.so" "nh_getenv" nh_getenv :: Addr -> IO Addr -copy_String_to_cstring :: String -> IO Ptr +copy_String_to_cstring :: String -> IO Addr copy_String_to_cstring s = nh_malloc (1 + length s) >>= \ptr0 -> let loop ptr [] = nh_store ptr 0 >> return ptr0 - loop ptr (c:cs) = --trace ("Out `" ++ [c] ++ "'") ( - nh_store ptr (primCharToInt c) >> loop (ptr+1) cs - --) + loop ptr (c:cs) = nh_store ptr (primCharToInt c) >> loop (incAddr ptr) cs in - loop ptr0 s + if isNullAddr ptr0 + then error "copy_String_to_cstring: malloc failed" + else loop ptr0 s -copy_cstring_to_String :: Ptr -> IO String +copy_cstring_to_String :: Addr -> IO String copy_cstring_to_String ptr = nh_load ptr >>= \ci -> if ci == 0 then return [] - else copy_cstring_to_String (ptr+1) >>= \cs -> - --trace ("In " ++ show ci) ( + else copy_cstring_to_String (incAddr ptr) >>= \cs -> return ((primIntToChar ci) : cs) - --) readfromhandle :: FILE_STAR -> IO String readfromhandle h @@ -1772,7 +1776,7 @@ primGetEnv v = copy_String_to_cstring v >>= \ptr -> nh_getenv ptr >>= \ptr2 -> nh_free ptr >> - if ptr2 == 0 + if isNullAddr ptr2 then return [] else copy_cstring_to_String ptr2 >>= \result -> @@ -1799,12 +1803,12 @@ primRunST m = fst (unST m theWorld) unST (ST a) = a instance Functor (ST s) where - fmap f x = x >>= (return . f) + fmap f x = x >>= (return . f) instance Monad (ST s) where - m >> k = m >>= \ _ -> k - return x = ST $ \ s -> (x,s) - m >>= k = ST $ \s -> case unST m s of { (a,s') -> unST (k a) s' } + m >> k = ST (\s -> case unST m s of { (a,s') -> unST k s' }) + return x = ST (\s -> (x,s)) + m >>= k = ST (\s -> case unST m s of { (a,s') -> unST (k a) s' }) -- used when Hugs invokes top level function @@ -1812,7 +1816,7 @@ primRunIO :: IO () -> () primRunIO m = protect (fst (unST m realWorld)) where - realWorld = error "panic: Hugs entered the real world" + realWorld = error "primRunIO: entered the RealWorld" protect :: () -> () protect comp = primCatch comp (\e -> fst (unST (putStr (show e ++ "\n")) realWorld)) @@ -1829,12 +1833,14 @@ unsafeInterleaveIO = unsafeInterleaveST ------------------------------------------------------------------------------ --- Word, Addr, ForeignObj, Prim*Array ---------------------------------------- +-- Word, Addr, StablePtr, Prim*Array ----------------------------------------- ------------------------------------------------------------------------------ data Addr -nullAddr = primIntToAddr 0 +nullAddr = primIntToAddr 0 +incAddr a = primIntToAddr (1 + primAddrToInt a) +isNullAddr a = 0 == primAddrToInt a instance Eq Addr where (==) = primEqAddr @@ -1860,9 +1866,14 @@ instance Ord Word where (>) = primGtWord ---data ForeignObj ---makeForeignObj :: Addr -> IO ForeignObj ---makeForeignObj = primMakeForeignObj +data StablePtr a + +makeStablePtr :: a -> IO (StablePtr a) +makeStablePtr = primMakeStablePtr +deRefStablePtr :: StablePtr a -> IO a +deRefStablePtr = primDeRefStablePtr +freeStablePtr :: StablePtr a -> IO () +freeStablePtr = primFreeStablePtr data PrimArray a -- immutable arrays with Int indices @@ -1874,172 +1885,6 @@ data PrimMutableByteArray s ------------------------------------------------------------------------------- --- hooks to call libHS_cbits ------------------------------------------------- ------------------------------------------------------------------------------- -{- -type FILE_OBJ = ForeignObj -- as passed into functions -type CString = PrimByteArray -type How = Int -type Binary = Int -type OpenFlags = Int -type IOFileAddr = Addr -- as returned from functions -type FD = Int -type OpenStdFlags = Int -type Readable = Int -- really Bool -type Exclusive = Int -- really Bool -type RC = Int -- standard return code -type Bytes = PrimMutableByteArray RealWorld -type Flush = Int -- really Bool - -foreign import stdcall "libHS_cbits.so" "freeStdFileObject" - freeStdFileObject :: ForeignObj -> IO () - -foreign import stdcall "libHS_cbits.so" "freeFileObject" - freeFileObject :: ForeignObj -> IO () - -foreign import stdcall "libHS_cbits.so" "setBuf" - prim_setBuf :: FILE_OBJ -> Addr -> Int -> IO () - -foreign import stdcall "libHS_cbits.so" "getBufSize" - prim_getBufSize :: FILE_OBJ -> IO Int - -foreign import stdcall "libHS_cbits.so" "inputReady" - prim_inputReady :: FILE_OBJ -> Int -> IO RC - -foreign import stdcall "libHS_cbits.so" "fileGetc" - prim_fileGetc :: FILE_OBJ -> IO Int - -foreign import stdcall "libHS_cbits.so" "fileLookAhead" - prim_fileLookAhead :: FILE_OBJ -> IO Int - -foreign import stdcall "libHS_cbits.so" "readBlock" - prim_readBlock :: FILE_OBJ -> IO Int - -foreign import stdcall "libHS_cbits.so" "readLine" - prim_readLine :: FILE_OBJ -> IO Int - -foreign import stdcall "libHS_cbits.so" "readChar" - prim_readChar :: FILE_OBJ -> IO Int - -foreign import stdcall "libHS_cbits.so" "writeFileObject" - prim_writeFileObject :: FILE_OBJ -> Int -> IO RC - -foreign import stdcall "libHS_cbits.so" "filePutc" - prim_filePutc :: FILE_OBJ -> Char -> IO RC - -foreign import stdcall "libHS_cbits.so" "getBufStart" - prim_getBufStart :: FILE_OBJ -> Int -> IO Addr - -foreign import stdcall "libHS_cbits.so" "getWriteableBuf" - prim_getWriteableBuf :: FILE_OBJ -> IO Addr - -foreign import stdcall "libHS_cbits.so" "getBufWPtr" - prim_getBufWPtr :: FILE_OBJ -> IO Int - -foreign import stdcall "libHS_cbits.so" "setBufWPtr" - prim_setBufWPtr :: FILE_OBJ -> Int -> IO () - -foreign import stdcall "libHS_cbits.so" "closeFile" - prim_closeFile :: FILE_OBJ -> Flush -> IO RC - -foreign import stdcall "libHS_cbits.so" "fileEOF" - prim_fileEOF :: FILE_OBJ -> IO RC - -foreign import stdcall "libHS_cbits.so" "setBuffering" - prim_setBuffering :: FILE_OBJ -> Int -> IO RC - -foreign import stdcall "libHS_cbits.so" "flushFile" - prim_flushFile :: FILE_OBJ -> IO RC - -foreign import stdcall "libHS_cbits.so" "getBufferMode" - prim_getBufferMode :: FILE_OBJ -> IO RC - -foreign import stdcall "libHS_cbits.so" "seekFileP" - prim_seekFileP :: FILE_OBJ -> IO RC - -foreign import stdcall "libHS_cbits.so" "setTerminalEcho" - prim_setTerminalEcho :: FILE_OBJ -> Int -> IO RC - -foreign import stdcall "libHS_cbits.so" "getTerminalEcho" - prim_getTerminalEcho :: FILE_OBJ -> IO RC - -foreign import stdcall "libHS_cbits.so" "isTerminalDevice" - prim_isTerminalDevice :: FILE_OBJ -> IO RC - -foreign import stdcall "libHS_cbits.so" "setConnectedTo" - prim_setConnectedTo :: FILE_OBJ -> FILE_OBJ -> Int -> IO () - -foreign import stdcall "libHS_cbits.so" "ungetChar" - prim_ungetChar :: FILE_OBJ -> Char -> IO RC - -foreign import stdcall "libHS_cbits.so" "readChunk" - prim_readChunk :: FILE_OBJ -> Addr -> Int -> IO RC - -foreign import stdcall "libHS_cbits.so" "writeBuf" - prim_writeBuf :: FILE_OBJ -> Addr -> Int -> IO RC - -foreign import stdcall "libHS_cbits.so" "getFileFd" - prim_getFileFd :: FILE_OBJ -> IO FD - -foreign import stdcall "libHS_cbits.so" "fileSize_int64" - prim_fileSize_int64 :: FILE_OBJ -> Bytes -> IO RC - -foreign import stdcall "libHS_cbits.so" "getFilePosn" - prim_getFilePosn :: FILE_OBJ -> IO Int - -foreign import stdcall "libHS_cbits.so" "setFilePosn" - prim_setFilePosn :: FILE_OBJ -> Int -> IO Int - -foreign import stdcall "libHS_cbits.so" "getConnFileFd" - prim_getConnFileFd :: FILE_OBJ -> IO FD - -foreign import stdcall "libHS_cbits.so" "allocMemory__" - prim_allocMemory__ :: Int -> IO Addr - -foreign import stdcall "libHS_cbits.so" "getLock" - prim_getLock :: FD -> Exclusive -> IO RC - -foreign import stdcall "libHS_cbits.so" "openStdFile" - prim_openStdFile :: FD -> OpenStdFlags -> Readable -> IO IOFileAddr - -foreign import stdcall "libHS_cbits.so" "openFile" - prim_openFile :: CString -> How -> Binary -> OpenFlags -> IO IOFileAddr - -foreign import stdcall "libHS_cbits.so" "freeFileObject" - prim_freeFileObject :: FILE_OBJ -> IO () - -foreign import stdcall "libHS_cbits.so" "freeStdFileObject" - prim_freeStdFileObject :: FILE_OBJ -> IO () - -foreign import stdcall "libHS_cbits.so" "const_BUFSIZ" - const_BUFSIZ :: Int - -foreign import stdcall "libHS_cbits.so" "setConnNonBlockingIOFlag__" - prim_setConnNonBlockingIOFlag__ :: FILE_OBJ -> IO () - -foreign import stdcall "libHS_cbits.so" "clearConnNonBlockingIOFlag__" - prim_clearConnNonBlockingIOFlag__ :: FILE_OBJ -> IO () - -foreign import stdcall "libHS_cbits.so" "setNonBlockingIOFlag__" - prim_setNonBlockingIOFlag__ :: FILE_OBJ -> IO () - -foreign import stdcall "libHS_cbits.so" "clearNonBlockingIOFlag__" - prim_clearNonBlockingIOFlag__ :: FILE_OBJ -> IO () - -foreign import stdcall "libHS_cbits.so" "getErrStr__" - prim_getErrStr__ :: IO Addr - -foreign import stdcall "libHS_cbits.so" "getErrNo__" - prim_getErrNo__ :: IO Int - -foreign import stdcall "libHS_cbits.so" "getErrType__" - prim_getErrType__ :: IO Int - ---foreign import stdcall "libHS_cbits.so" "seekFile_int64" --- prim_seekFile_int64 :: FILE_OBJ -> Int -> Int64 -> IO RC --} - -- showFloat ------------------------------------------------------------------ showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS @@ -2194,12 +2039,6 @@ floatToDigits base x = in gen [] (r * bk) s (mUp * bk) (mDn * bk) in (map toInt (reverse rds), k) -{- --- Exponentiation with(out) a cache for the most common numbers. -expt :: Integer -> Int -> Integer -expt base n = base^n --} - -- Exponentiation with a cache for the most common numbers. minExpt = 0::Int diff --git a/ghc/rts/Assembler.c b/ghc/rts/Assembler.c index 738b891..b4decda 100644 --- a/ghc/rts/Assembler.c +++ b/ghc/rts/Assembler.c @@ -5,8 +5,8 @@ * Copyright (c) 1994-1998. * * $RCSfile: Assembler.c,v $ - * $Revision: 1.9 $ - * $Date: 1999/07/06 16:40:22 $ + * $Revision: 1.10 $ + * $Date: 1999/10/15 11:02:58 $ * * This module provides functions to construct BCOs and other closures * required by the bytecode compiler. @@ -464,9 +464,7 @@ static StgWord repSizeW( AsmRep rep ) case ADDR_REP: return sizeofW(StgWord) + sizeofW(StgAddr); case FLOAT_REP: return sizeofW(StgWord) + sizeofW(StgFloat); case DOUBLE_REP: return sizeofW(StgWord) + sizeofW(StgDouble); -#ifdef PROVIDE_STABLE case STABLE_REP: return sizeofW(StgWord) + sizeofW(StgWord); -#endif case INTEGER_REP: #ifdef PROVIDE_WEAK @@ -635,6 +633,14 @@ static void emit_i_VAR_DOUBLE ( AsmBCO bco, int arg1 ) emiti_16(bco,i_VAR_DOUBLE_big,arg1); } +static void emit_i_VAR_STABLE ( AsmBCO bco, int arg1 ) +{ + ASSERT(arg1 >= 0); + if (arg1 < 256) + emiti_8 (bco,i_VAR_STABLE, arg1); else + emiti_16(bco,i_VAR_STABLE_big,arg1); +} + static void emit_i_VAR ( AsmBCO bco, int arg1 ) { ASSERT(arg1 >= 0); @@ -796,11 +802,9 @@ void asmVar ( AsmBCO bco, AsmVar v, AsmRep rep ) case DOUBLE_REP: emit_i_VAR_DOUBLE(bco,offset); break; -#ifdef PROVIDE_STABLE case STABLE_REP: emit_i_VAR_STABLE(bco,offset); break; -#endif case INTEGER_REP: #ifdef PROVIDE_WEAK @@ -884,12 +888,10 @@ AsmVar asmBox( AsmBCO bco, AsmRep rep ) emiti_(bco,i_PACK_DOUBLE); grabHpNonUpd(bco,Dzh_sizeW); break; -#ifdef PROVIDE_STABLE case STABLE_REP: emiti_(bco,i_PACK_STABLE); grabHpNonUpd(bco,Stablezh_sizeW); break; -#endif default: barf("asmBox %d",rep); @@ -925,11 +927,9 @@ AsmVar asmUnbox( AsmBCO bco, AsmRep rep ) case DOUBLE_REP: emiti_(bco,i_UNPACK_DOUBLE); break; -#ifdef PROVIDE_STABLE case STABLE_REP: emiti_(bco,i_UNPACK_STABLE); break; -#endif default: barf("asmUnbox %d",rep); } @@ -1171,9 +1171,11 @@ const AsmPrim asmPrimOps[] = { , { "primIndexAddrOffAddr", "AI", "A", MONAD_Id, i_PRIMOP1, i_indexAddrOffAddr } , { "primIndexFloatOffAddr", "AI", "F", MONAD_Id, i_PRIMOP1, i_indexFloatOffAddr } , { "primIndexDoubleOffAddr", "AI", "D", MONAD_Id, i_PRIMOP1, i_indexDoubleOffAddr } -#ifdef PROVIDE_STABLE , { "primIndexStableOffAddr", "AI", "s", MONAD_Id, i_PRIMOP1, i_indexStableOffAddr } -#endif + + /* Stable# operations */ + , { "primIntToStablePtr", "I", "s", MONAD_Id, i_PRIMOP1, i_intToStable } + , { "primStablePtrToInt", "s", "I", MONAD_Id, i_PRIMOP1, i_stableToInt } /* These ops really ought to be in the IO monad */ , { "primReadCharOffAddr", "AI", "C", MONAD_ST, i_PRIMOP1, i_readCharOffAddr } @@ -1182,9 +1184,7 @@ const AsmPrim asmPrimOps[] = { , { "primReadAddrOffAddr", "AI", "A", MONAD_ST, i_PRIMOP1, i_readAddrOffAddr } , { "primReadFloatOffAddr", "AI", "F", MONAD_ST, i_PRIMOP1, i_readFloatOffAddr } , { "primReadDoubleOffAddr", "AI", "D", MONAD_ST, i_PRIMOP1, i_readDoubleOffAddr } -#ifdef PROVIDE_STABLE , { "primReadStableOffAddr", "AI", "s", MONAD_ST, i_PRIMOP1, i_readStableOffAddr } -#endif /* These ops really ought to be in the IO monad */ , { "primWriteCharOffAddr", "AIC", "", MONAD_ST, i_PRIMOP1, i_writeCharOffAddr } @@ -1193,9 +1193,7 @@ const AsmPrim asmPrimOps[] = { , { "primWriteAddrOffAddr", "AIA", "", MONAD_ST, i_PRIMOP1, i_writeAddrOffAddr } , { "primWriteFloatOffAddr", "AIF", "", MONAD_ST, i_PRIMOP1, i_writeFloatOffAddr } , { "primWriteDoubleOffAddr", "AID", "", MONAD_ST, i_PRIMOP1, i_writeDoubleOffAddr } -#ifdef PROVIDE_STABLE , { "primWriteStableOffAddr", "AIs", "", MONAD_ST, i_PRIMOP1, i_writeStableOffAddr } -#endif /* Integer operations */ , { "primCompareInteger", "ZZ", "I", MONAD_Id, i_PRIMOP1, i_compareInteger } @@ -1343,12 +1341,13 @@ const AsmPrim asmPrimOps[] = { , { "primReadDoubleArray", "mI", "D", MONAD_ST, i_PRIMOP2, i_readDoubleArray } , { "primIndexDoubleArray", "xI", "D", MONAD_Id, i_PRIMOP2, i_indexDoubleArray } -#ifdef PROVIDE_STABLE +#if 0 +#ifdef PROVIDE_STABLE , { "primWriteStableArray", "mIs", "", MONAD_ST, i_PRIMOP2, i_writeStableArray } , { "primReadStableArray", "mI", "s", MONAD_ST, i_PRIMOP2, i_readStableArray } , { "primIndexStableArray", "xI", "s", MONAD_Id, i_PRIMOP2, i_indexStableArray } #endif - +#endif /* {new,write,read,index}ForeignObjArray not provided */ @@ -1361,12 +1360,14 @@ const AsmPrim asmPrimOps[] = { , { "primMakeWeak", "bac", "w", MONAD_IO, i_PRIMOP2, i_makeWeak } , { "primDeRefWeak", "w", "Ia", MONAD_IO, i_PRIMOP2, i_deRefWeak } #endif -#ifdef PROVIDE_STABLE /* StablePtr# operations */ , { "primMakeStablePtr", "a", "s", MONAD_IO, i_PRIMOP2, i_makeStablePtr } , { "primDeRefStablePtr", "s", "a", MONAD_IO, i_PRIMOP2, i_deRefStablePtr } , { "primFreeStablePtr", "s", "", MONAD_IO, i_PRIMOP2, i_freeStablePtr } -#endif + + /* foreign export dynamic support */ + , { "primCreateAdjThunkARCH", "sA", "A", MONAD_IO, i_PRIMOP2, i_createAdjThunkARCH } + #ifdef PROVIDE_PTREQUALITY , { "primReallyUnsafePtrEquality", "aa", "B",MONAD_Id, i_PRIMOP2, i_reallyUnsafePtrEquality } #endif diff --git a/ghc/rts/Bytecodes.h b/ghc/rts/Bytecodes.h index d93f86e..f277d59 100644 --- a/ghc/rts/Bytecodes.h +++ b/ghc/rts/Bytecodes.h @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- - * $Id: Bytecodes.h,v 1.6 1999/04/27 10:07:20 sewardj Exp $ + * $Id: Bytecodes.h,v 1.7 1999/10/15 11:02:59 sewardj Exp $ * * (c) The GHC Team, 1998-1999 * @@ -87,6 +87,7 @@ Ins(i_PACK_DOUBLE), \ Ins(i_UNPACK_DOUBLE), \ Ins(i_VAR_STABLE), \ + Ins(i_VAR_STABLE_big), \ Ins(i_PACK_STABLE), \ Ins(i_UNPACK_STABLE), \ Ins(i_PRIMOP1), \ @@ -180,6 +181,10 @@ typedef enum , i_intToAddr , i_addrToInt + /* Stable# operations */ + , i_intToStable + , i_stableToInt + /* Stateless Addr operations */ , i_indexCharOffAddr , i_indexIntOffAddr @@ -187,9 +192,7 @@ typedef enum , i_indexAddrOffAddr , i_indexFloatOffAddr , i_indexDoubleOffAddr -#ifdef PROVIDE_STABLE , i_indexStableOffAddr -#endif , i_readCharOffAddr , i_readIntOffAddr @@ -197,9 +200,7 @@ typedef enum , i_readAddrOffAddr , i_readFloatOffAddr , i_readDoubleOffAddr -#ifdef PROVIDE_STABLE , i_readStableOffAddr -#endif , i_writeCharOffAddr , i_writeIntOffAddr @@ -207,9 +208,7 @@ typedef enum , i_writeAddrOffAddr , i_writeFloatOffAddr , i_writeDoubleOffAddr -#ifdef PROVIDE_STABLE , i_writeStableOffAddr -#endif /* Integer operations */ , i_compareInteger @@ -370,11 +369,13 @@ typedef enum , i_readDoubleArray , i_indexDoubleArray +#if 0 #ifdef PROVIDE_STABLE , i_writeStableArray , i_readStableArray , i_indexStableArray #endif +#endif /* {write,read,index}ForeignObjArray not provided */ @@ -403,12 +404,13 @@ typedef enum , i_makeWeak , i_deRefWeak #endif -#ifdef PROVIDE_STABLE /* StablePtr# operations */ , i_makeStablePtr , i_deRefStablePtr , i_freeStablePtr -#endif + + /* foreign export dynamic support */ + , i_createAdjThunkARCH #ifdef PROVIDE_CONCURRENT /* Concurrency operations */ diff --git a/ghc/rts/Disassembler.c b/ghc/rts/Disassembler.c index 0cfc6b7..e3590ae 100644 --- a/ghc/rts/Disassembler.c +++ b/ghc/rts/Disassembler.c @@ -5,8 +5,8 @@ * Copyright (c) 1994-1998. * * $RCSfile: Disassembler.c,v $ - * $Revision: 1.7 $ - * $Date: 1999/07/06 16:40:24 $ + * $Revision: 1.8 $ + * $Date: 1999/10/15 11:03:01 $ * ---------------------------------------------------------------------------*/ #include "Rts.h" @@ -336,14 +336,12 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) case i_UNPACK_DOUBLE: return disNone(bco,pc,"UNPACK_DOUBLE"); -#ifdef PROVIDE_STABLE case i_VAR_STABLE: return disInt(bco,pc,"VAR_STABLE"); case i_PACK_STABLE: return disNone(bco,pc,"PACK_STABLE"); case i_UNPACK_STABLE: return disNone(bco,pc,"UNPACK_STABLE"); -#endif case i_PRIMOP1: { diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c index f7c8147..172ccb5 100644 --- a/ghc/rts/Evaluator.c +++ b/ghc/rts/Evaluator.c @@ -5,8 +5,8 @@ * Copyright (c) 1994-1998. * * $RCSfile: Evaluator.c,v $ - * $Revision: 1.17 $ - * $Date: 1999/07/06 16:40:24 $ + * $Revision: 1.18 $ + * $Date: 1999/10/15 11:03:01 $ * ---------------------------------------------------------------------------*/ #include "Rts.h" @@ -19,18 +19,15 @@ #include "Storage.h" #include "SchedAPI.h" /* for createGenThread */ #include "Schedule.h" /* for context_switch */ - #include "Bytecodes.h" #include "Assembler.h" /* for CFun stuff */ #include "ForeignCall.h" -#include "StablePriv.h" #include "PrimOps.h" /* for __{encode,decode}{Float,Double} */ #include "Evaluator.h" #ifdef DEBUG #include "Printer.h" #include "Disassembler.h" - #include "Sanity.h" #include "StgRun.h" #endif @@ -48,7 +45,6 @@ #error Non-standalone integer not yet supported #endif - /* An incredibly useful abbreviation. * Interestingly, there are some uses of END_TSO_QUEUE_closure that * can't use it because they use the closure at type StgClosure* or @@ -70,6 +66,12 @@ #define USE_GCC_LABELS 0 #endif +/* Make it possible for the evaluator to get hold of bytecode + for a given function by name. Useful but a hack. Sigh. + */ +extern void* getHugs_AsmObject_for ( char* s ); + + /* -------------------------------------------------------------------------- * Crude profiling stuff (mainly to assess effect of optimiser) * ------------------------------------------------------------------------*/ @@ -233,13 +235,24 @@ void cp_show ( void ) * Hugs Hooks - a bit of a hack * ------------------------------------------------------------------------*/ -/* A total hack -- this code has an endian dependancy and only works - on little-endian archs. -*/ void setRtsFlags( int x ); void setRtsFlags( int x ) { - *(int*)(&(RtsFlags.DebugFlags)) = x; + unsigned int w = 0x12345678; + unsigned char* pw = (unsigned char *)&w; + if (*pw == 0x78) { + /* little endian */ + *(int*)(&(RtsFlags.DebugFlags)) = x; + } else { + /* big endian */ + unsigned int w1 = x; + unsigned int w2 = 0; + w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8; + w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8; + w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8; + w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8; + *(int*)(&(RtsFlags.DebugFlags)) = (int)w2; + } } /* -------------------------------------------------------------------------- @@ -247,7 +260,7 @@ void setRtsFlags( int x ) * * ToDo: figure out why these are being used and crush them! * ------------------------------------------------------------------------*/ - +#if 0 void OnExitHook (void) { } @@ -270,7 +283,7 @@ void defaultsHook (void) { /* do nothing */ } - +#endif /* -------------------------------------------------------------------------- * Entering-objects and bytecode interpreter part of evaluator @@ -300,7 +313,7 @@ void defaultsHook (void) /* Forward decls ... */ static void* enterBCO_primop1 ( int ); -static void* enterBCO_primop2 ( int , int* /*StgThreadReturnCode* */ ); +static void* enterBCO_primop2 ( int , int* /*StgThreadReturnCode* */, StgBCO** ); static inline void PopUpdateFrame ( StgClosure* obj ); static inline void PopCatchFrame ( void ); static inline void PopSeqFrame ( void ); @@ -310,6 +323,8 @@ static inline void PushTaggedInteger ( mpz_ptr ); static inline StgPtr grabHpUpd( nat size ); static inline StgPtr grabHpNonUpd( nat size ); static StgClosure* raiseAnError ( StgClosure* errObj ); +static StgAddr createAdjThunkARCH ( StgStablePtr stableptr, + StgAddr typestr ); static int enterCountI = 0; @@ -337,7 +352,11 @@ void SloppifyIntegerEnd ( StgPtr ); #define LLL { xSp = Sp; xSu = Su; xSpLim = SpLim; } #endif -#define RETURN(vvv) { StgThreadReturnCode retVal=(vvv); SSS; return retVal; } +#define RETURN(vvv) { \ + StgThreadReturnCode retVal=(vvv); SSS; \ + /* SaveThreadState() is done by the scheduler. */ \ + return retVal; \ + } /* Macros to operate directly on the pulled-out machine state. @@ -385,6 +404,12 @@ void SloppifyIntegerEnd ( StgPtr ); #define xPopTaggedAddr() ((xSp++,xSp+=sizeofW(StgAddr), \ (StgAddr)(*(xSp-sizeofW(StgAddr))))) +#define xPushTaggedStable(xxx) { xSp -= sizeofW(StgStablePtr); \ + *xSp = (StgWord)(xxx); xPushTag(STABLE_TAG); } +#define xTaggedStackStable(iii) ((StgStablePtr)(*(xSp+1+(iii)))) +#define xPopTaggedStable() ((xSp++,xSp+=sizeofW(StgStablePtr), \ + (StgStablePtr)(*(xSp-sizeofW(StgStablePtr))))) + #define xPushTaggedChar(xxx) { xSp -= sizeofW(StgChar); \ *xSp = (StgWord)(xxx); xPushTag(CHAR_TAG); } #define xTaggedStackChar(iii) ((StgChar)(*(xSp+1+(iii)))) @@ -437,10 +462,15 @@ StgThreadReturnCode enter( StgClosure* obj0 ) register StgPtr xSpLim; /* local state -- stack lim pointer */ register StgClosure* obj; /* object currently under evaluation */ char eCount; /* enter counter, for context switching */ + StgBCO** bco_SAVED; #ifdef DEBUG /* use the t values to check that Su/Sp/SpLim do not change unexpectedly */ - StgPtr tSp = Sp; StgUpdateFrame* tSu = Su; StgPtr tSpLim = SpLim; + StgPtr tSp; StgUpdateFrame* tSu; StgPtr tSpLim; +#endif + /* LoadThreadState() is done by the scheduler. */ +#ifdef DEBUG + tSp = Sp; tSu = Su; tSpLim = SpLim; #endif obj = obj0; @@ -515,6 +545,8 @@ StgThreadReturnCode enter( StgClosure* obj0 ) register StgBCO* bco = (StgBCO*)obj; StgWord wantToGC; + bco_SAVED = bco; + /* Don't need to SSS ... LLL around doYouWantToGC */ wantToGC = doYouWantToGC(); if (wantToGC) { @@ -975,7 +1007,7 @@ StgThreadReturnCode enter( StgClosure* obj0 ) } Case(i_UNPACK_ADDR): { - StgClosure* con = stgCast(StgClosure*,xStackPtr(0)); + StgClosure* con = (StgClosure*)xStackPtr(0); /* ASSERT(isAddrLike(con)); */ xPushTaggedAddr(payloadPtr(con,0)); Continue; @@ -1085,38 +1117,30 @@ StgThreadReturnCode enter( StgClosure* obj0 ) } Case(i_VAR_STABLE): { - fprintf(stderr, "unimp: i_VAR_STABLE\n" ); exit(0); - /*fix side effects here ...*/ - /* - xPushTaggedStablePtr(xTaggedStackStable(BCO_INSTR_8)); - */ + StgStablePtr s = xTaggedStackStable(BCO_INSTR_8); + xPushTaggedStable(s); Continue; } Case(i_PACK_STABLE): { - //StgClosure* o; - fprintf(stderr, "unimp: i_PACK_STABLE\n" ); exit(0); - /* + StgClosure* o; SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL; SET_HDR(o,&StablePtr_con_info,??); - payloadWord(o,0) = xPopTaggedStablePtr(); + payloadWord(o,0) = xPopTaggedStable(); IF_DEBUG(evaluator, fprintf(stderr,"\tBuilt "); + SSS; printObj(stgCast(StgClosure*,o)); + LLL; ); xPushPtr(stgCast(StgPtr,o)); - */ Continue; } Case(i_UNPACK_STABLE): { - //StgClosure* con; - fprintf(stderr, "unimp: i_UNPACK_STABLE\n" ); exit(0); - /* - con = stgCast(StgClosure*,xStackPtr(0)); - ASSERT(isStableLike(con)); - xPushTaggedStablePtr(payloadWord(con,0)); - */ + StgClosure* con = (StgClosure*)xStackPtr(0); + /* ASSERT(isStableLike(con)); */ + xPushTaggedStable(payloadWord(con,0)); Continue; } Case(i_PRIMOP1): @@ -1130,11 +1154,19 @@ StgThreadReturnCode enter( StgClosure* obj0 ) } Case(i_PRIMOP2): { - int i, trc; - void* p; - trc = 12345678; /* Hope that no StgThreadReturnCode has this value */ - i = BCO_INSTR_8; - SSS; p = enterBCO_primop2 ( i, &trc ); LLL; + /* Remember to save */ + int i, trc, pc_saved; + void* p; + StgBCO* bco_tmp; + trc = 12345678; /* Assume != any StgThreadReturnCode */ + i = BCO_INSTR_8; + pc_saved = PC; + bco_tmp = bco; + SSS; + p = enterBCO_primop2 ( i, &trc, &bco_tmp ); + LLL; + bco = bco_tmp; + bciPtr = &(bcoInstr(bco,pc_saved)); if (p) { if (trc == 12345678) { /* we want to enter p */ @@ -1315,13 +1347,16 @@ StgThreadReturnCode enter( StgClosure* obj0 ) } obj = ap->fun; #ifdef EAGER_BLACKHOLING +#warn LAZY_BLACKHOLING is default for StgHugs +#error Dont know if EAGER_BLACKHOLING works in StgHugs { - /* superfluous - but makes debugging easier */ - StgBlackHole* bh = stgCast(StgBlackHole*,ap); - SET_INFO(bh,&BLACKHOLE_info); - bh->blocking_queue = EndTSOQueue; - IF_DEBUG(gccafs,fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh)); - /*printObj(bh); */ + /* superfluous - but makes debugging easier */ + StgBlackHole* bh = stgCast(StgBlackHole*,ap); + SET_INFO(bh,&BLACKHOLE_info); + bh->blocking_queue = EndTSOQueue; + IF_DEBUG(gccafs, + fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh)); + /* printObj(bh); */ } #endif /* EAGER_BLACKHOLING */ goto enterLoop; @@ -1376,9 +1411,10 @@ StgThreadReturnCode enter( StgClosure* obj0 ) ASSERT(xSp==(P_)xSu); IF_DEBUG(evaluator, SSS; + fprintf(stderr, "hit a STOP_FRAME\n"); printObj(obj); - /*fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);*/ - /*printStack(xSp,CurrentTSO->stack+CurrentTSO->stack_size,xSu);*/ + fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu); + printStack(xSp,CurrentTSO->stack+CurrentTSO->stack_size,xSu); LLL; ); SSS; PopStopFrame(obj); LLL; @@ -1400,7 +1436,7 @@ StgThreadReturnCode enter( StgClosure* obj0 ) case RET_VEC_SMALL: case RET_BIG: case RET_VEC_BIG: - barf("todo: RET_[VEC_]{BIG,SMALL}"); + // barf("todo: RET_[VEC_]{BIG,SMALL}"); default: belch("entered CONSTR with invalid continuation on stack"); IF_DEBUG(evaluator, @@ -1453,6 +1489,9 @@ StgThreadReturnCode enter( StgClosure* obj0 ) #undef xPushTaggedAddr #undef xTaggedStackAddr #undef xPopTaggedAddr +#undef xPushTaggedStable +#undef xTaggedStackStable +#undef xPopTaggedStable #undef xPushTaggedChar #undef xTaggedStackChar #undef xPopTaggedChar @@ -1471,7 +1510,7 @@ StgThreadReturnCode enter( StgClosure* obj0 ) static inline void PushTag ( StackTag t ) { *(--Sp) = t; } -static inline void PushPtr ( StgPtr x ) + inline void PushPtr ( StgPtr x ) { *(--stgCast(StgPtr*,Sp)) = x; } static inline void PushCPtr ( StgClosure* x ) { *(--stgCast(StgClosure**,Sp)) = x; } @@ -1485,7 +1524,7 @@ static inline void checkTag ( StackTag t1, StackTag t2 ) { ASSERT(t1 == t2);} static inline void PopTag ( StackTag t ) { checkTag(t,*(Sp++)); } -static inline StgPtr PopPtr ( void ) + inline StgPtr PopPtr ( void ) { return *stgCast(StgPtr*,Sp)++; } static inline StgClosure* PopCPtr ( void ) { return *stgCast(StgClosure**,Sp)++; } @@ -1510,7 +1549,7 @@ static inline void PushTaggedRealWorld( void ) { Sp -= sizeofW(StgInt); *Sp = x; PushTag(INT_TAG); } static inline void PushTaggedWord ( StgWord x ) { Sp -= sizeofW(StgWord); *Sp = x; PushTag(WORD_TAG); } -static inline void PushTaggedAddr ( StgAddr x ) + inline void PushTaggedAddr ( StgAddr x ) { Sp -= sizeofW(StgAddr); *Sp = (W_)x; PushTag(ADDR_TAG); } static inline void PushTaggedChar ( StgChar x ) { Sp -= sizeofW(StgChar); *Sp = stgCast(StgWord,x); PushTag(CHAR_TAG); } @@ -1533,16 +1572,16 @@ static inline void PopTaggedRealWorld ( void ) static inline StgWord PopTaggedWord ( void ) { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, Sp); Sp += sizeofW(StgWord); return r;} -static inline StgAddr PopTaggedAddr ( void ) + inline StgAddr PopTaggedAddr ( void ) { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, Sp); Sp += sizeofW(StgAddr); return r;} -static inline StgChar PopTaggedChar ( void ) + inline StgChar PopTaggedChar ( void ) { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *Sp); Sp += sizeofW(StgChar); return r;} -static inline StgFloat PopTaggedFloat ( void ) + inline StgFloat PopTaggedFloat ( void ) { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(Sp); Sp += sizeofW(StgFloat); return r;} -static inline StgDouble PopTaggedDouble ( void ) + inline StgDouble PopTaggedDouble ( void ) { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(Sp); Sp += sizeofW(StgDouble); return r;} static inline StgStablePtr PopTaggedStablePtr ( void ) @@ -1616,6 +1655,8 @@ static inline void PopUpdateFrame( StgClosure* obj ) fprintf(stderr,"Sp = %p\tSu = %p\n\n", Sp, Su); ); #ifdef EAGER_BLACKHOLING +#warn LAZY_BLACKHOLING is default for StgHugs +#error Dont know if EAGER_BLACKHOLING works in StgHugs ASSERT(get_itbl(Su->updatee)->type == BLACKHOLE || get_itbl(Su->updatee)->type == SE_BLACKHOLE || get_itbl(Su->updatee)->type == CAF_BLACKHOLE @@ -1713,32 +1754,29 @@ static inline StgClosure* raiseAnError( StgClosure* errObj ) } } -static StgClosure* raisePrim(char* msg) + +static StgClosure* makeErrorCall ( const char* msg ) { - /* ToDo: figure out some way to turn the msg into a Haskell Exception - * Hack: we don't know how to build an Exception but we do know how - * to build a (recursive!) error object. - * The result isn't pretty but it's (slightly) better than nothing. - */ - nat size = sizeof(StgClosure) + 1; - StgClosure* errObj = stgCast(StgClosure*,grabHpNonUpd(size)); - SET_INFO(errObj,&raise_info); - errObj->payload[0] = errObj; -fprintf(stderr, "\n\n\nRAISE PRIM %s\n", msg); -#if 0 - belch(msg); -#else - /* At the moment, I prefer to put it on stdout to make things as - * close to Hugs' old behaviour as possible. - */ - fprintf(stdout, "Program error: %s", msg); - fflush(stdout); -#endif - return raiseAnError(stgCast(StgClosure*,errObj)); + /* Note! the msg string should be allocated in a + place which will not get freed -- preferably + read-only data of the program. That's because + the thunk we build here may linger indefinitely. + (thinks: probably not so, but anyway ...) + */ + HaskellObj error + = asmClosureOfObject(getHugs_AsmObject_for("error")); + HaskellObj unpack + = asmClosureOfObject(getHugs_AsmObject_for("primUnpackString")); + HaskellObj thunk + = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) ); + thunk + = rts_apply ( error, thunk ); + return + (StgClosure*) thunk; } -#define raiseIndex(where) raisePrim("Array index out of range in " where) -#define raiseDiv0(where) raisePrim("Division by 0 in " where) +#define raiseIndex(where) makeErrorCall("Array index out of range in " where) +#define raiseDiv0(where) makeErrorCall("Division by zero in " where) /* -------------------------------------------------------------------------- * Evaluator @@ -1822,6 +1860,12 @@ fprintf(stderr, "\n\n\nRAISE PRIM %s\n", msg); PushTaggedWord(e); \ } +#define OP_I_s(e) \ +{ \ + StgInt x = PopTaggedInt(); \ + PushTaggedStablePtr(e); \ +} + #define OP__F(e) \ { \ PushTaggedFloat(e); \ @@ -1864,6 +1908,12 @@ fprintf(stderr, "\n\n\nRAISE PRIM %s\n", msg); PushTaggedInt(e); \ } +#define OP_s_I(e) \ +{ \ + StgStablePtr x = PopTaggedStablePtr(); \ + PushTaggedInt(e); \ +} + #define OP_W_W(e) \ { \ StgWord x = PopTaggedWord(); \ @@ -1927,7 +1977,7 @@ fprintf(stderr, "\n\n\nRAISE PRIM %s\n", msg); int y = PopTaggedInt(); \ StgStablePtr r; \ s; \ - PushTaggedStablePtr(r); \ + PushTaggedStablePtr(r); \ } #define OP_AIC_(s) \ { \ @@ -2236,8 +2286,7 @@ static void* enterBCO_primop1 ( int primop1code ) return (raiseDiv0("quotInt")); } /* ToDo: protect against minInt / -1 errors - * (repeat for all other division primops) - */ + * (repeat for all other division primops) */ PushTaggedInt(x/y); } break; @@ -2334,6 +2383,9 @@ static void* enterBCO_primop1 ( int primop1code ) case i_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */ case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */ + case i_intToStable: OP_I_s(x); break; + case i_stableToInt: OP_s_I(x); break; + case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break; case i_readCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break; case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrzh(x,y,z)); break; @@ -2354,11 +2406,9 @@ static void* enterBCO_primop1 ( int primop1code ) case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break; case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z)); break; -#ifdef PROVIDE_STABLE case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break; case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break; case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break; -#endif #ifdef STANDALONE_INTEGER case i_compareInteger: @@ -2448,11 +2498,6 @@ static void* enterBCO_primop1 ( int primop1code ) { StgFloat x = PopTaggedFloat(); StgFloat y = PopTaggedFloat(); -#if 0 - if (y == 0) { - return (raiseDiv0("divideFloat")); - } -#endif PushTaggedFloat(x/y); } break; @@ -2519,11 +2564,6 @@ static void* enterBCO_primop1 ( int primop1code ) { StgDouble x = PopTaggedDouble(); StgDouble y = PopTaggedDouble(); -#if 0 - if (y == 0) { - return (raiseDiv0("divideDouble")); - } -#endif PushTaggedDouble(x/y); } break; @@ -2593,7 +2633,8 @@ static void* enterBCO_primop1 ( int primop1code ) set *return2 to it and return a non-NULL value. */ static void* enterBCO_primop2 ( int primop2code, - int* /*StgThreadReturnCode* */ return2 ) + int* /*StgThreadReturnCode* */ return2, + StgBCO** bco ) { switch (primop2code) { case i_raise: /* raise#{err} */ @@ -2713,8 +2754,8 @@ static void* enterBCO_primop2 ( int primop2code, } /* Most of these generate alignment warnings on Sparcs and similar architectures. - * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS. - */ + * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS. + */ case i_indexCharArray: OP_mI_ty(Char,"indexCharArray", indexCharArrayzh(r,x,i)); break; case i_readCharArray: @@ -2750,6 +2791,7 @@ static void* enterBCO_primop2 ( int primop2code, case i_writeDoubleArray: OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break; +#if 0 #ifdef PROVIDE_STABLE case i_indexStableArray: OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break; @@ -2758,7 +2800,7 @@ static void* enterBCO_primop2 ( int primop2code, case i_writeStableArray: OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break; #endif - +#endif @@ -2812,54 +2854,45 @@ static void* enterBCO_primop2 ( int primop2code, PushCPtr(w->value); /* last result */ PushTaggedInt(1); /* first result */ } else { - PushPtr(stgCast(StgPtr,w)); /* ToDo: error thunk would be better */ + PushPtr(stgCast(StgPtr,w)); + /* ToDo: error thunk would be better */ PushTaggedInt(0); } break; } #endif /* PROVIDE_WEAK */ -#ifdef PROVIDE_STABLE - /* StablePtr# operations */ - case i_makeStablePtr: - case i_deRefStablePtr: - case i_freeStablePtr: - { fprintf(stderr,"Evaluator.c:stablePtrOp unimp\n" ); - exit(1); }; -#if 0 - ToDo: reinstate case i_makeStablePtr: { - StgStablePtr stable_ptr; - if (stable_ptr_free == NULL) { - enlargeStablePtrTable(); - } - - stable_ptr = stable_ptr_free - stable_ptr_table; - stable_ptr_free = (P_*)*stable_ptr_free; - stable_ptr_table[stable_ptr] = PopPtr(); - - PushTaggedStablePtr(stable_ptr); + StgPtr p = PopPtr(); + StgStablePtr sp = getStablePtr ( p ); + PushTaggedStablePtr(sp); break; } case i_deRefStablePtr: { - StgStablePtr stable_ptr = PopTaggedStablePtr(); - PushPtr(stable_ptr_table[stable_ptr]); + StgPtr p; + StgStablePtr sp = PopTaggedStablePtr(); + p = deRefStablePtr(sp); + PushPtr(p); break; } - case i_freeStablePtr: { - StgStablePtr stable_ptr = PopTaggedStablePtr(); - stable_ptr_table[stable_ptr] = (P_)stable_ptr_free; - stable_ptr_free = stable_ptr_table + stable_ptr; + StgStablePtr sp = PopTaggedStablePtr(); + freeStablePtr(sp); break; } -#endif /* 0 */ + case i_createAdjThunkARCH: + { + StgStablePtr stableptr = PopTaggedStablePtr(); + StgAddr typestr = PopTaggedAddr(); + StgAddr adj_thunk = createAdjThunkARCH(stableptr,typestr); + PushTaggedAddr(adj_thunk); + break; + } -#endif /* PROVIDE_STABLE */ #ifdef PROVIDE_CONCURRENT case i_fork: { @@ -3012,8 +3045,8 @@ off the stack. case i_ccall_IO: { CFunDescriptor* descriptor = PopTaggedAddr(); - StgAddr funPtr = PopTaggedAddr(); - ccall(descriptor,funPtr); + void (*funPtr)(void) = PopTaggedAddr(); + ccall(descriptor,funPtr,bco); break; } default: @@ -3060,11 +3093,9 @@ nat marshall(char arg_ty, void* arg) case ADDR_REP: PushTaggedAddr(*((void**)arg)); return ARG_SIZE(ADDR_TAG); -#ifdef PROVIDE_STABLE case STABLE_REP: PushTaggedStablePtr(*((StgStablePtr*)arg)); return ARG_SIZE(STABLE_TAG); -#endif #ifdef PROVIDE_FOREIGN case FOREIGN_REP: /* Not allowed in this direction - you have to @@ -3114,11 +3145,9 @@ nat unmarshall(char res_ty, void* res) case ADDR_REP: *((void**)res) = PopTaggedAddr(); return ARG_SIZE(ADDR_TAG); -#ifdef PROVIDE_STABLE case STABLE_REP: *((StgStablePtr*)res) = PopTaggedStablePtr(); return ARG_SIZE(STABLE_TAG); -#endif #ifdef PROVIDE_FOREIGN case FOREIGN_REP: { @@ -3167,11 +3196,9 @@ nat argSize( const char* ks ) case ADDR_REP: sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG); break; -#ifdef PROVIDE_STABLE case STABLE_REP: sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG); break; -#endif #ifdef PROVIDE_FOREIGN case FOREIGN_REP: #endif @@ -3371,4 +3398,156 @@ void B__decodeFloat (B* man, I_* exp, StgFloat flt) +/* ----------------------------------------------------------------------------- + * Support for foreign export dynamic. + * ---------------------------------------------------------------------------*/ + +static +int unpackArgsAndCallHaskell_x86 ( StgStablePtr stableptr, + char* tydesc, char* args) +{ + HaskellObj node; + HaskellObj nodeOut; + SchedulerStatus sstat; + + char* resp = tydesc; + char* argp = tydesc; + + /* + fprintf ( stderr, + "unpackArgsAndCallHaskell_x86: args=0x%x tydesc=%s stableptr=0x%x\n", + (unsigned int)args, tydesc, stableptr ); + */ + + node = deRefStablePtr(stableptr); + + if (*argp != ':') argp++; + ASSERT( *argp == ':' ); + argp++; + while (*argp) { + switch (*argp) { + case CHAR_REP: + node = rts_apply ( node, rts_mkChar ( *(char*)args ) ); + /* fprintf(stderr, "char `%c' ", *(char*)args ); */ + args += 4; + break; + case INT_REP: + node = rts_apply ( node, rts_mkInt ( *(int*)args ) ); + /* fprintf(stderr, "int %d ", *(int*)args ); */ + args += 4; + break; + case FLOAT_REP: + node = rts_apply ( node, rts_mkFloat ( *(float*)args ) ); + /* fprintf(stderr, "float %f ", *(float*)args ); */ + args += 4; + break; + case DOUBLE_REP: + node = rts_apply ( node, rts_mkDouble ( *(double*)args ) ); + /* fprintf(stderr, "double %f ", *(double*)args ); */ + args += 8; + break; + case WORD_REP: + case ADDR_REP: + default: + internal( + "unpackArgsAndCallHaskell_x86: unexpected arg type rep"); + } + argp++; + } + fprintf ( stderr, "\n" ); + node = rts_apply ( + asmClosureOfObject(getHugs_AsmObject_for("primRunST")), + node ); + + sstat = rts_eval ( node, &nodeOut ); + if (sstat != Success) + internal ("unpackArgsAndCallHaskell_x86: evalIO failed"); + + switch (*resp) { + case ':': return 0; + case CHAR_REP: return rts_getChar(nodeOut); + case INT_REP: return rts_getInt(nodeOut); + //case FLOAT_REP: return rts_getFloat(nodeOut); + //case DOUBLE_REP: return rts_getDouble(nodeOut); + case WORD_REP: + case ADDR_REP: + default: + internal( + "unpackArgsAndCallHaskell_x86: unexpected res type rep"); + } +} + +static +StgAddr createAdjThunk_x86 ( StgStablePtr stableptr, + StgAddr typestr ) +{ + unsigned char* codeblock; + unsigned char* cp; + unsigned int ts = (unsigned int)typestr; + unsigned int sp = (unsigned int)stableptr; + unsigned int ch = (unsigned int)&unpackArgsAndCallHaskell_x86; + + /* fprintf ( stderr, "createAdjThunk_x86: %s 0x%x\n", (char*)typestr, sp ); */ + codeblock = malloc ( 1 + 0x22 ); + if (!codeblock) { + fprintf ( stderr, + "createAdjThunk_x86 (foreign export dynamic):\n" + "\tfatal: can't alloc mem\n" ); + exit(1); + } + cp = codeblock; + /* Generate the following: + 9 0000 53 pushl %ebx + 10 0001 51 pushl %ecx + 11 0002 56 pushl %esi + 12 0003 57 pushl %edi + 13 0004 55 pushl %ebp + 14 0005 89E0 movl %esp,%eax # sp -> eax + 15 0007 83C018 addl $24,%eax # move eax back over 5 saved regs + retaddr + 16 000a 50 pushl %eax # push arg-block addr + 17 000b 6844332211 pushl $0x11223344 # push addr of type descr string + 18 0010 6877665544 pushl $0x44556677 # push stableptr to closure + 19 0015 E8BBAA9988 call 0x8899aabb # SEE COMMENT BELOW + 20 001a 83C40C addl $12,%esp # pop 3 args + 21 001d 5D popl %ebp + 22 001e 5F popl %edi + 23 001f 5E popl %esi + 24 0020 59 popl %ecx + 25 0021 5B popl %ebx + 26 0022 C3 ret + */ + *cp++ = 0x53; + *cp++ = 0x51; + *cp++ = 0x56; + *cp++ = 0x57; + *cp++ = 0x55; + *cp++ = 0x89; *cp++ = 0xE0; + *cp++ = 0x83; *cp++ = 0xC0; *cp++ = 0x18; + *cp++ = 0x50; + *cp++ = 0x68; *cp++=ts;ts>>=8; *cp++=ts;ts>>=8; *cp++=ts;ts>>=8; *cp++=ts; + *cp++ = 0x68; *cp++=sp;sp>>=8; *cp++=sp;sp>>=8; *cp++=sp;sp>>=8; *cp++=sp; + + /* call address needs to be: displacement relative to next insn */ + ch = ch - ( ((unsigned int)cp) + 5); + *cp++ = 0xE8; *cp++=ch;ch>>=8; *cp++=ch;ch>>=8; *cp++=ch;ch>>=8; *cp++=ch; + + *cp++ = 0x83; *cp++ = 0xC4; *cp++ = 0x0C; + *cp++ = 0x5D; + *cp++ = 0x5F; + *cp++ = 0x5E; + *cp++ = 0x59; + *cp++ = 0x5B; + *cp++ = 0xC3; + + return codeblock; +} + + +static +StgAddr createAdjThunkARCH ( StgStablePtr stableptr, + StgAddr typestr ) +{ + return createAdjThunk_x86 ( stableptr, typestr ); +} + #endif /* INTERPRETER */ diff --git a/ghc/rts/ForeignCall.c b/ghc/rts/ForeignCall.c index 2f0509e..e8d0c97 100644 --- a/ghc/rts/ForeignCall.c +++ b/ghc/rts/ForeignCall.c @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- - * $Id: ForeignCall.c,v 1.4 1999/03/01 14:47:06 sewardj Exp $ + * $Id: ForeignCall.c,v 1.5 1999/10/15 11:03:06 sewardj Exp $ * * (c) The GHC Team 1994-1999. * @@ -120,12 +120,24 @@ void ccall( CFunDescriptor* d, void (*fun)(void) ) #if 1 /* HACK alert (red alert) */ extern StgInt PopTaggedInt ( void ) ; -extern void PushTaggedInt ( StgInt ); -extern StgPtr PopPtr ( void ); +extern StgDouble PopTaggedDouble ( void ) ; +extern StgFloat PopTaggedFloat ( void ) ; +extern StgChar PopTaggedChar ( void ) ; +extern StgAddr PopTaggedAddr ( void ) ; + +extern void PushTaggedInt ( StgInt ); +extern void PushTaggedAddr ( StgAddr ); +extern void PushPtr ( StgPtr ); +extern StgPtr PopPtr ( void ); + int seqNr = 0; #define IF(sss) if (strcmp(sss,cdesc)==0) -void ccall( CFunDescriptor* d, void (*fun)(void) ) +#define STS PushPtr((StgPtr)(*bco));SaveThreadState() +#define LTS LoadThreadState();*bco=(StgBCO*)PopPtr(); +#define LTS_RET LoadThreadState();*bco=(StgBCO*)PopPtr(); return +#define RET return +void ccall( CFunDescriptor* d, void (*fun)(void), StgBCO** bco ) { int i; char cdesc[100]; @@ -141,20 +153,56 @@ void ccall( CFunDescriptor* d, void (*fun)(void) ) //fprintf(stderr, "ccall: %d cdesc = `%s'\n", seqNr++, cdesc); - IF(":") { ((void(*)(void))(fun))(); return; }; - IF(":I") { int a1=PopTaggedInt(); ((void(*)(int))(fun))(a1); return;}; - IF("I:") { int r= ((int(*)(void))(fun))(); PushTaggedInt(r); return;}; + IF(":") { STS; ((void(*)(void))(fun))(); LTS_RET; }; + + IF(":I") { int a1=PopTaggedInt(); + STS; ((void(*)(int))(fun))(a1); LTS_RET; }; + IF(":A") { void* a1=PopTaggedAddr(); + STS; ((void(*)(void*))(fun))(a1); LTS_RET; }; + + IF("I:") { int r; + STS; r= ((int(*)(void))(fun))(); LTS; + PushTaggedInt(r); RET ;}; + IF(":II") { int a1=PopTaggedInt(); int a2=PopTaggedInt(); - ((void(*)(int,int))(fun))(a1,a2); return; }; - IF("I:I") { int a1=PopTaggedInt(); - int r=((int(*)(int))(fun))(a1); PushTaggedInt(r); return; }; - IF("I:II") { int a1=PopTaggedInt(); int a2=PopTaggedInt(); - int r=((int(*)(int,int))(fun))(a1,a2); PushTaggedInt(r); return; }; - IF("I:III") { int a1=PopTaggedInt(); int a2=PopTaggedInt(); int a3=PopTaggedInt(); - int r=((int(*)(int,int,int))(fun))(a1,a2,a3); PushTaggedInt(r); return; }; + STS; ((void(*)(int,int))(fun))(a1,a2); LTS_RET; }; + IF(":AI") { void* a1=PopTaggedAddr(); int a2=PopTaggedInt(); + STS; ((void(*)(void*,int))(fun))(a1,a2); LTS_RET; }; + + IF("I:I") { int a1=PopTaggedInt(); int r; + STS; r=((int(*)(int))(fun))(a1); LTS; + PushTaggedInt(r); RET; }; + IF("A:I") { int a1=PopTaggedInt(); void* r; + STS; r=((void*(*)(int))(fun))(a1); LTS; + PushTaggedAddr(r); RET; }; + IF("A:A") { void* a1=PopTaggedAddr(); void* r; + STS; r=((void*(*)(void*))(fun))(a1); LTS; + PushTaggedAddr(r); RET; }; + + IF("I:II") { int a1=PopTaggedInt(); int a2=PopTaggedInt(); int r; + STS; r=((int(*)(int,int))(fun))(a1,a2); LTS; + PushTaggedInt(r); RET; }; + IF("I:AI") { void* a1=PopTaggedAddr(); int a2=PopTaggedInt(); int r; + STS; r=((int(*)(void*,int))(fun))(a1,a2); LTS; + PushTaggedInt(r); RET; }; + IF("A:AI") { void* a1=PopTaggedAddr(); int a2=PopTaggedInt(); void* r; + STS; r=((void*(*)(void*,int))(fun))(a1,a2); LTS; + PushTaggedAddr(r); RET; }; + + IF("I:III") { int a1=PopTaggedInt(); int a2=PopTaggedInt(); + int a3=PopTaggedInt(); int r; + STS; r=((int(*)(int,int,int))(fun))(a1,a2,a3); LTS; + PushTaggedInt(r); RET; }; + + IF(":AIDCF") { void* a1 = PopTaggedAddr(); + int a2 = PopTaggedInt(); + double a3 = PopTaggedDouble(); + char a4 = PopTaggedChar(); + float a5 = PopTaggedFloat(); + STS; + ((void(*)(void*,int,double,char,float))(fun))(a1,a2,a3,a4,a5); + LTS_RET; }; - //IF("I:AI") { void* a1=(void*)PopPtr(); int a2=PopTaggedInt(); - // int r=((int(*)(void*,int))(fun))(a1,a2); PushTaggedInt(r); return; }; fprintf(stderr,"panic: ccall cdesc `%s' not implemented\n", cdesc ); exit(1); @@ -164,7 +212,13 @@ fprintf(stderr, "ccall: arg_tys %s arg_size %d result_tys %s result_size %d\n", d->arg_tys, d->arg_size, d->result_tys, d->result_size ); } + #undef IF +#undef STS +#undef LTS +#undef LTS_RET +#undef RET + #endif diff --git a/ghc/rts/ForeignCall.h b/ghc/rts/ForeignCall.h index 8718ca0..a36c0ca 100644 --- a/ghc/rts/ForeignCall.h +++ b/ghc/rts/ForeignCall.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: ForeignCall.h,v 1.3 1999/02/05 16:02:41 simonm Exp $ + * $Id: ForeignCall.h,v 1.4 1999/10/15 11:03:10 sewardj Exp $ * * (c) The GHC Team, 1998-1999 * @@ -9,7 +9,7 @@ typedef int StablePtr; -extern void ccall ( CFunDescriptor* descriptor, void (*fun)(void) ); +extern void ccall ( CFunDescriptor* descriptor, void (*fun)(void), StgBCO** bco ); extern void hcall ( HFunDescriptor* descriptor, StablePtr fun, void* as, void* rs ); diff --git a/ghc/rts/RtsAPI.c b/ghc/rts/RtsAPI.c index 9e0c507..79c33a8 100644 --- a/ghc/rts/RtsAPI.c +++ b/ghc/rts/RtsAPI.c @@ -1,5 +1,5 @@ /* ---------------------------------------------------------------------------- - * $Id: RtsAPI.c,v 1.8 1999/07/06 09:42:38 sof Exp $ + * $Id: RtsAPI.c,v 1.9 1999/10/15 11:03:10 sewardj Exp $ * * (c) The GHC Team, 1998-1999 * @@ -189,6 +189,7 @@ rts_mkString (char *s) { return rts_apply((StgClosure *)&unpackCString_closure, rts_mkAddr(s)); } +#endif /* COMPILER */ HaskellObj rts_apply (HaskellObj f, HaskellObj arg) @@ -200,7 +201,6 @@ rts_apply (HaskellObj f, HaskellObj arg) ap->payload[0] = (P_)arg; return (StgClosure *)ap; } -#endif /* COMPILER */ /* ---------------------------------------------------------------------------- Deconstructing Haskell objects