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.
/* -----------------------------------------------------------------------------
- * $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.
*
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
# ----------------------------------------------------------------------------- #
-# $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 = ../..
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
../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:
* 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 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
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
* 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"
case NAME:
return acc; /* Names are never free vars */
default:
-printf("\n\n");
+printf("\n");
ppStgExpr(e);
printf("\n");
internal("freeVarsExpr");
* 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 <setjmp.h>
);
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;
}
? (oAvail && iAvail && timeEarlier(sTime,oTime))
: TRUE;
*/
-
fromObj = FALSE;
/* ToDo: namesUpto overflow */
* 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"
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 */
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();
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);
-- 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),
,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} ----------------------------------------
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
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
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 ->
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
= 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 ->
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
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))
------------------------------------------------------------------------------
--- 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
(>) = 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
-------------------------------------------------------------------------------
--- 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
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
* 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"
Type typePrimMutableByteArray;
Type typeFloat;
Type typeDouble;
-#ifdef PROVIDE_STABLE
Type typeStable;
-#endif
#ifdef PROVIDE_WEAK
Type typeWeak;
#endif
Name namePmSubtract;
Name namePmFromInteger;
Name nameMkIO;
+Name nameRunST;
Name nameUnpackString;
Name nameError;
Name nameInd;
+Name nameCreateAdjThunk;
Name nameAnd;
Name nameConCmp;
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
typePrimMutableByteArray = linkTycon("PrimMutableByteArray");
typeFloat = linkTycon("Float");
typeDouble = linkTycon("Double");
-#ifdef PROVIDE_STABLE
typeStable = linkTycon("StablePtr");
-#endif
#ifdef PROVIDE_WEAK
typeWeak = linkTycon("Weak");
#endif
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);
implementPrim(n);
}
+ nameRunST = linkName("primRunST");
+
/* static(tidyInfix) */
nameNegate = linkName("negate");
/* user interface */
/* translator */
nameEqChar = linkName("primEqChar");
nameEqInt = linkName("primEqInt");
+nameCreateAdjThunk = linkName("primCreateAdjThunk");
#if !OVERLOADED_CONSTANTS
nameEqInteger = linkName("primEqInteger");
#endif /* !OVERLOADED_CONSTANTS */
pFun(nameError, "error");
pFun(nameUnpackString, "primUnpackString");
+ // /* foreign export dynamic */
+ //pFun(nameCreateAdjThunk, "primCreateAdjThunk");
+
/* hooks for handwritten bytecode */
pFun(namePrimSeq, "primSeq");
pFun(namePrimCatch, "primCatch");
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
extern Type typePrimMutableByteArray;
extern Type typeFloat;
extern Type typeDouble;
-#ifdef PROVIDE_STABLE
extern Type typeStable;
-#endif
#ifdef PROVIDE_WEAK
extern Type typeWeak;
#endif
extern Name namePmSubtract;
extern Name namePmFromInteger;
extern Name nameMkIO;
+extern Name nameRunST;
extern Name nameUnpackString;
extern Name namePrimSeq;
extern Name nameMap;
* 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 $
* ------------------------------------------------------------------------*/
%{
%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 -------------------------------------*/
| INSTIMPORT CONID {$$=gc2(NIL);}
- | EXPORT CONID ifEntities { addGHCExports($2,$3);
+ | UUEXPORT CONID ifEntities { addGHCExports($2,$3);
$$=gc3(NIL);}
| NUMLIT INFIXL optDigit varid_or_conid
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;}
;
* 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"
}
-/*-- from STG --*/
/* --------------------------------------------------------------------------
* Foreign import declarations are Hugs' equivalent of GHC's ccall mechanism.
* They are used to "import" C functions into a module.
-
-#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:
*
* 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"
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:
* 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"
* 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 )
{
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);
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) {
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 )
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
}
}
-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);
* ::
* 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;
} 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;
textToStr(textOf(fst(extName)))
EEND;
}
- //ppStg(v);
+ /* ppStg(v); */
name(n).defn = NIL;
name(n).stgVar = v;
name(n).stgSize = stgSize(stgVarBody(v));
}
}
-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
* 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"
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());
-- 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),
,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} ----------------------------------------
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
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
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 ->
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
= 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 ->
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
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))
------------------------------------------------------------------------------
--- 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
(>) = 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
-------------------------------------------------------------------------------
--- 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
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
* 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.
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
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);
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
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);
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);
}
, { "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 }
, { "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 }
, { "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 }
, { "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 */
, { "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
/* -----------------------------------------------------------------------------
- * $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
*
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), \
, i_intToAddr
, i_addrToInt
+ /* Stable# operations */
+ , i_intToStable
+ , i_stableToInt
+
/* Stateless Addr operations */
, i_indexCharOffAddr
, i_indexIntOffAddr
, i_indexAddrOffAddr
, i_indexFloatOffAddr
, i_indexDoubleOffAddr
-#ifdef PROVIDE_STABLE
, i_indexStableOffAddr
-#endif
, i_readCharOffAddr
, i_readIntOffAddr
, i_readAddrOffAddr
, i_readFloatOffAddr
, i_readDoubleOffAddr
-#ifdef PROVIDE_STABLE
, i_readStableOffAddr
-#endif
, i_writeCharOffAddr
, i_writeIntOffAddr
, i_writeAddrOffAddr
, i_writeFloatOffAddr
, i_writeDoubleOffAddr
-#ifdef PROVIDE_STABLE
, i_writeStableOffAddr
-#endif
/* Integer operations */
, i_compareInteger
, i_readDoubleArray
, i_indexDoubleArray
+#if 0
#ifdef PROVIDE_STABLE
, i_writeStableArray
, i_readStableArray
, i_indexStableArray
#endif
+#endif
/* {write,read,index}ForeignObjArray not provided */
, 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 */
* 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"
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:
{
* 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"
#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
#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
#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)
* ------------------------------------------------------------------------*/
* 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;
+ }
}
/* --------------------------------------------------------------------------
*
* ToDo: figure out why these are being used and crush them!
* ------------------------------------------------------------------------*/
-
+#if 0
void OnExitHook (void)
{
}
{
/* do nothing */
}
-
+#endif
/* --------------------------------------------------------------------------
* Entering-objects and bytecode interpreter part of evaluator
/* 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 );
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;
#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.
#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))))
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;
register StgBCO* bco = (StgBCO*)obj;
StgWord wantToGC;
+ bco_SAVED = bco;
+
/* Don't need to SSS ... LLL around doYouWantToGC */
wantToGC = doYouWantToGC();
if (wantToGC) {
}
Case(i_UNPACK_ADDR):
{
- StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
+ StgClosure* con = (StgClosure*)xStackPtr(0);
/* ASSERT(isAddrLike(con)); */
xPushTaggedAddr(payloadPtr(con,0));
Continue;
}
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):
}
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 */
}
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;
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;
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,
#undef xPushTaggedAddr
#undef xTaggedStackAddr
#undef xPopTaggedAddr
+#undef xPushTaggedStable
+#undef xTaggedStackStable
+#undef xPopTaggedStable
#undef xPushTaggedChar
#undef xTaggedStackChar
#undef xPopTaggedChar
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; }
{ 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)++; }
{ 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); }
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 )
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
}
}
-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
PushTaggedWord(e); \
}
+#define OP_I_s(e) \
+{ \
+ StgInt x = PopTaggedInt(); \
+ PushTaggedStablePtr(e); \
+}
+
#define OP__F(e) \
{ \
PushTaggedFloat(e); \
PushTaggedInt(e); \
}
+#define OP_s_I(e) \
+{ \
+ StgStablePtr x = PopTaggedStablePtr(); \
+ PushTaggedInt(e); \
+}
+
#define OP_W_W(e) \
{ \
StgWord x = PopTaggedWord(); \
int y = PopTaggedInt(); \
StgStablePtr r; \
s; \
- PushTaggedStablePtr(r); \
+ PushTaggedStablePtr(r); \
}
#define OP_AIC_(s) \
{ \
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;
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;
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:
{
StgFloat x = PopTaggedFloat();
StgFloat y = PopTaggedFloat();
-#if 0
- if (y == 0) {
- return (raiseDiv0("divideFloat"));
- }
-#endif
PushTaggedFloat(x/y);
}
break;
{
StgDouble x = PopTaggedDouble();
StgDouble y = PopTaggedDouble();
-#if 0
- if (y == 0) {
- return (raiseDiv0("divideDouble"));
- }
-#endif
PushTaggedDouble(x/y);
}
break;
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} */
}
/* 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:
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;
case i_writeStableArray:
OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break;
#endif
-
+#endif
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:
{
case i_ccall_IO:
{
CFunDescriptor* descriptor = PopTaggedAddr();
- StgAddr funPtr = PopTaggedAddr();
- ccall(descriptor,funPtr);
+ void (*funPtr)(void) = PopTaggedAddr();
+ ccall(descriptor,funPtr,bco);
break;
}
default:
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
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:
{
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
+/* -----------------------------------------------------------------------------
+ * 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 */
/* -----------------------------------------------------------------------------
- * $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.
*
#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];
//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);
"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
/* -----------------------------------------------------------------------------
- * $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
*
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 );
/* ----------------------------------------------------------------------------
- * $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
*
{
return rts_apply((StgClosure *)&unpackCString_closure, rts_mkAddr(s));
}
+#endif /* COMPILER */
HaskellObj
rts_apply (HaskellObj f, HaskellObj arg)
ap->payload[0] = (P_)arg;
return (StgClosure *)ap;
}
-#endif /* COMPILER */
/* ----------------------------------------------------------------------------
Deconstructing Haskell objects
projects / ghc-hetmet.git / commitdiff