[project @ 1999-10-29 13:41:23 by sewardj]

Make foreign import and thus the Prelude work on cygwin.

diff --git a/ghc/interpreter/Makefile b/ghc/interpreter/Makefile
index 5fe682a..5760fde 100644 (file)
--- a/ghc/interpreter/Makefile
+++ b/ghc/interpreter/Makefile
@@ -1,6 +1,6 @@
 
 # ----------------------------------------------------------------------------- #
-# $Id: Makefile,v 1.12 1999/10/29 11:41:04 sewardj Exp $                        #
+# $Id: Makefile,v 1.13 1999/10/29 13:41:23 sewardj Exp $                        #
 # ----------------------------------------------------------------------------- #
 
 TOP = ../..
@@ -15,8 +15,10 @@ RTS_DIR = $(TOP)/ghc/rts
 
 ifeq "$(TARGETPLATFORM)" "i386-unknown-cygwin32"
 DYN_EXT=.dll
+MNO_CYGWIN=
 else
 DYN_EXT=.so
+MNO_CYGWIN=
 endif
 
 YACC = bison -y
@@ -33,7 +35,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 -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
+SRC_CC_OPTS = $(MNO_CYGWIN) -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
 
@@ -48,8 +50,9 @@ hugs: $(C_OBJS) ../rts/Sanity.o ../rts/Assembler.o ../rts/Disassembler.o \
 
 nHandle.$(DYN_EXT): nHandle.c
 ifeq "$(TARGETPLATFORM)" "i386-unknown-cygwin32"
-       gcc -O -Wall -o nHandle.o -c nHandle.c
-       dllwrap -o nHandle.dll nHandle.o
+       gcc -mno-cygwin -O -Wall -o nHandle.o -c nHandle.c
+       dllwrap -mno-cygwin --target=i386-mingw32 -o nHandle.dll \
+                -def nHandle.def nHandle.o
 else
        gcc -O -Wall -shared -fPIC -o nHandle.so nHandle.c
 endif

diff --git a/ghc/interpreter/dynamic.c b/ghc/interpreter/dynamic.c
index 002bf33..46ad6e4 100644 (file)
--- a/ghc/interpreter/dynamic.c
+++ b/ghc/interpreter/dynamic.c
@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: dynamic.c,v $
- * $Revision: 1.11 $
- * $Date: 1999/10/28 14:32:06 $
+ * $Revision: 1.12 $
+ * $Date: 1999/10/29 13:41:23 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -22,19 +22,29 @@
 
 #include <windows.h>
 
-void* getDLLSymbol(line,dll0,symbol)  /* load dll and lookup symbol */
+void* getDLLSymbol(line,dll0,symbol0) /* load dll and lookup symbol */
 Int    line;
 String dll0;
-String symbol; {
+String symbol0; {
     void*      sym;
     char       dll[1000];
+    char       symbol[100];
     ObjectFile instance;
+
     if (strlen(dll0) > 996) {
-       ERRMSG(line) "Excessively long library name:\n%s\n",dll
+       ERRMSG(line) "Excessively long library name:\n%s\n",dll0
        EEND;
     }
     strcpy(dll,dll0);
     strcat(dll, ".dll");
+
+    if (strlen(symbol0) > 96) {
+       ERRMSG(line) "Excessively long symbol name:\n%s\n",symbol0
+       EEND;
+    }
+    strcpy(&(symbol[1]),symbol0); 
+    symbol[0] = '_';
+
     instance = LoadLibrary(dll);
     if (NULL == instance) {
         /* GetLastError allegedly provides more detail - in practice,
@@ -43,7 +53,8 @@ String symbol; {
         ERRMSG(line) "Can't open library \"%s\"", dll
         EEND;
     }
-    return GetProcAddress(instance,symbol);
+    sym = GetProcAddress(instance,symbol0);
+    return sym;
 }
 
 Bool stdcallAllowed ( void )
@@ -69,7 +80,7 @@ String symbol; {
     char       dll[1000];
     ObjectFile instance;
     if (strlen(dll0) > 996) {
-       ERRMSG(line) "Excessively long library name:\n%s\n",dll
+       ERRMSG(line) "Excessively long library name:\n%s\n",dll0
        EEND;
     }
     strcpy(dll,dll0);
@@ -114,7 +125,7 @@ String symbol; {
     ObjectFile instance = shl_load(dll,BIND_IMMEDIATE,0L);
     void* r;
     if (NULL == instance) {
-        ERRMSG(line) "Error while importing DLL \"%s\"", dll
+        ERRMSG(line) "Error while importing DLL \"%s\"", dll0
         EEND;
     }
     return (0 == shl_findsym(&instance,symbol,TYPE_PROCEDURE,&r)) ? r : 0;

diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c
index 7060e35..f670969 100644 (file)
--- a/ghc/interpreter/hugs.c
+++ b/ghc/interpreter/hugs.c
@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: hugs.c,v $
- * $Revision: 1.15 $
- * $Date: 1999/10/20 02:15:59 $
+ * $Revision: 1.16 $
+ * $Date: 1999/10/29 13:41:24 $
  * ------------------------------------------------------------------------*/
 
 #include <setjmp.h>
@@ -300,8 +300,8 @@ String argv[]; {
    startupHaskell (argc,argv);
    argc = prog_argc; argv = prog_argv;
 
-    namesUpto = numScripts = 0;
-    addStackEntry("Prelude");
+   namesUpto = numScripts = 0;
+   addStackEntry("Prelude");
 
    for (i=1; i<argc; ++i) {            /* process command line arguments  */
         if (strcmp(argv[i], "--")==0) break;

diff --git a/ghc/interpreter/lib/Prelude.hs b/ghc/interpreter/lib/Prelude.hs
index 3c80d2b..68a8314 100644 (file)
--- a/ghc/interpreter/lib/Prelude.hs
+++ b/ghc/interpreter/lib/Prelude.hs
@@ -114,7 +114,9 @@ module Prelude (
 
     -- debugging hacks
     --,ST(..)
-    ,primIntToAddr
+    --,primIntToAddr
+    --,primGetArgc
+    --,primGetArgv
   ) where
 
 -- Standard value bindings {Prelude} ----------------------------------------
@@ -1718,8 +1720,8 @@ foreign import "nHandle" "nh_free"   nh_free   :: Addr -> IO ()
 foreign import "nHandle" "nh_store"  nh_store  :: Addr -> Int -> IO ()
 foreign import "nHandle" "nh_load"   nh_load   :: Addr -> IO Int
 
-foreign import "nHandle" "nh_argc"   nh_argc   :: IO Int
-foreign import "nHandle" "nh_argvb"  nh_argvb  :: Int -> Int -> IO Int
+--foreign import "nHandle" "nh_argc"   nh_argc   :: IO Int
+--foreign import "nHandle" "nh_argvb"  nh_argvb  :: Int -> Int -> IO Int
 foreign import "nHandle" "nh_getenv" nh_getenv :: Addr -> IO Addr
 
 copy_String_to_cstring :: String -> IO Addr
@@ -1761,16 +1763,13 @@ writetohandle fname h (c:cs)
 
 primGetRawArgs :: IO [String]
 primGetRawArgs
-   = nh_argc >>= \argc ->
-     accumulate (map (get_one_arg 0) [0 .. argc-1])
+   = primGetArgc >>= \argc ->
+     accumulate (map get_one_arg [0 .. argc-1])
      where
-        get_one_arg :: Int -> Int -> IO String
-        get_one_arg offset argno
-           = nh_argvb argno offset >>= \cb ->
-             if   cb == 0 
-             then return [] 
-             else get_one_arg (offset+1) argno >>= \s -> 
-                  return ((primIntToChar cb):s)
+        get_one_arg :: Int -> IO String
+        get_one_arg argno
+           = primGetArgv argno >>= \a ->
+             copy_cstring_to_String a
 
 primGetEnv :: String -> IO String
 primGetEnv v

diff --git a/ghc/interpreter/nHandle.def b/ghc/interpreter/nHandle.def
new file mode 100644 (file)
index 0000000..ec198d7
--- /dev/null
+++ b/ghc/interpreter/nHandle.def
@@ -0,0 +1,15 @@
+EXPORTS
+nh_stdin
+nh_stdout
+nh_stderr
+nh_write
+nh_read
+nh_open
+nh_flush
+nh_close
+nh_errno
+nh_malloc
+nh_free
+nh_store
+nh_load
+nh_getenv

diff --git a/ghc/lib/hugs/Prelude.hs b/ghc/lib/hugs/Prelude.hs
index 3c80d2b..68a8314 100644 (file)
--- a/ghc/lib/hugs/Prelude.hs
+++ b/ghc/lib/hugs/Prelude.hs
@@ -114,7 +114,9 @@ module Prelude (
 
     -- debugging hacks
     --,ST(..)
-    ,primIntToAddr
+    --,primIntToAddr
+    --,primGetArgc
+    --,primGetArgv
   ) where
 
 -- Standard value bindings {Prelude} ----------------------------------------
@@ -1718,8 +1720,8 @@ foreign import "nHandle" "nh_free"   nh_free   :: Addr -> IO ()
 foreign import "nHandle" "nh_store"  nh_store  :: Addr -> Int -> IO ()
 foreign import "nHandle" "nh_load"   nh_load   :: Addr -> IO Int
 
-foreign import "nHandle" "nh_argc"   nh_argc   :: IO Int
-foreign import "nHandle" "nh_argvb"  nh_argvb  :: Int -> Int -> IO Int
+--foreign import "nHandle" "nh_argc"   nh_argc   :: IO Int
+--foreign import "nHandle" "nh_argvb"  nh_argvb  :: Int -> Int -> IO Int
 foreign import "nHandle" "nh_getenv" nh_getenv :: Addr -> IO Addr
 
 copy_String_to_cstring :: String -> IO Addr
@@ -1761,16 +1763,13 @@ writetohandle fname h (c:cs)
 
 primGetRawArgs :: IO [String]
 primGetRawArgs
-   = nh_argc >>= \argc ->
-     accumulate (map (get_one_arg 0) [0 .. argc-1])
+   = primGetArgc >>= \argc ->
+     accumulate (map get_one_arg [0 .. argc-1])
      where
-        get_one_arg :: Int -> Int -> IO String
-        get_one_arg offset argno
-           = nh_argvb argno offset >>= \cb ->
-             if   cb == 0 
-             then return [] 
-             else get_one_arg (offset+1) argno >>= \s -> 
-                  return ((primIntToChar cb):s)
+        get_one_arg :: Int -> IO String
+        get_one_arg argno
+           = primGetArgv argno >>= \a ->
+             copy_cstring_to_String a
 
 primGetEnv :: String -> IO String
 primGetEnv v

diff --git a/ghc/rts/Assembler.c b/ghc/rts/Assembler.c
index acef38c..6c53983 100644 (file)
--- a/ghc/rts/Assembler.c
+++ b/ghc/rts/Assembler.c
@@ -5,8 +5,8 @@
  * Copyright (c) 1994-1998.
  *
  * $RCSfile: Assembler.c,v $
- * $Revision: 1.11 $
- * $Date: 1999/10/26 17:27:28 $
+ * $Revision: 1.12 $
+ * $Date: 1999/10/29 13:41:27 $
  *
  * This module provides functions to construct BCOs and other closures
  * required by the bytecode compiler.
@@ -1368,6 +1368,10 @@ const AsmPrim asmPrimOps[] = {
     /* foreign export dynamic support */
     , { "primCreateAdjThunkARCH",    "sAC","A",  MONAD_IO, i_PRIMOP2, i_createAdjThunkARCH }
 
+    /* misc handy hacks */
+    , { "primGetArgc",               "",   "I",  MONAD_IO, i_PRIMOP2, i_getArgc }
+    , { "primGetArgv",               "I",  "A",  MONAD_IO, i_PRIMOP2, i_getArgv }
+
 #ifdef PROVIDE_PTREQUALITY
     , { "primReallyUnsafePtrEquality", "aa", "B",MONAD_Id, i_PRIMOP2, i_reallyUnsafePtrEquality }
 #endif

diff --git a/ghc/rts/Bytecodes.h b/ghc/rts/Bytecodes.h
index c52d51c..f2f4a7e 100644 (file)
--- a/ghc/rts/Bytecodes.h
+++ b/ghc/rts/Bytecodes.h
@@ -1,6 +1,6 @@
 
 /* -----------------------------------------------------------------------------
- * $Id: Bytecodes.h,v 1.8 1999/10/26 17:27:30 sewardj Exp $
+ * $Id: Bytecodes.h,v 1.9 1999/10/29 13:41:29 sewardj Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -412,6 +412,10 @@ typedef enum
     /* foreign export dynamic support */
     , i_createAdjThunkARCH
 
+    /* misc handy hacks */
+    , i_getArgc
+    , i_getArgv
+
 #ifdef PROVIDE_CONCURRENT
     /* Concurrency operations */
     , i_fork

diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c
index 6dd91fa..2c04e55 100644 (file)
--- a/ghc/rts/Evaluator.c
+++ b/ghc/rts/Evaluator.c
@@ -5,8 +5,8 @@
  * Copyright (c) 1994-1998.
  *
  * $RCSfile: Evaluator.c,v $
- * $Revision: 1.22 $
- * $Date: 1999/10/26 17:27:25 $
+ * $Revision: 1.23 $
+ * $Date: 1999/10/29 13:41:29 $
  * ---------------------------------------------------------------------------*/
 
 #include "Rts.h"
@@ -2889,6 +2889,20 @@ static void* enterBCO_primop2 ( int primop2code,
                 break;
             }     
 
+        case i_getArgc:
+            {
+                StgInt n = prog_argc;
+                PushTaggedInt(n);
+                break;
+            }
+        case i_getArgv:
+            {
+                StgInt  n = PopTaggedInt();
+                StgAddr a = (StgAddr)prog_argv[n];
+                PushTaggedAddr(a);
+                break;
+            }
+
 #ifdef PROVIDE_CONCURRENT
         case i_fork:
             {