[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.

13 files changed, 228 insertions, 331 deletions

diff --git a/ghc/interpreter/Makefile b/ghc/interpreter/Makefile
index 60933d74ea..b82c13de7b 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 41dc004919..c2c782aee5 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 d58635bb18..18966d96d0 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 8485df4c83..cf5a99498a 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 <setjmp.h>
@@ -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 afae01fd1f..a979f25adc 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 f1fe9a742b..ebee5b4e2f 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 6fc348c39b..f5bfdfd3de 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 b87a0e7b25..ce766b434b 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 4b860aaf81..9c73280891 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 c6f9a7ebbc..38e179da88 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 7de66abd5a..2015905d98 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 53647c21f5..8c11034a8f 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 ff794f7349..f5430d5a43 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());