From: sewardj Date: Fri, 29 Oct 1999 13:41:29 +0000 (+0000) Subject: [project @ 1999-10-29 13:41:23 by sewardj] X-Git-Tag: Approximately_9120_patches~5645 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=ba16192e5f34fe569a6df20ffc9a515f6b7de11a;p=ghc-hetmet.git [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 --- 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 --- 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 -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 --- 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 @@ -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 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 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 --- 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 --- 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 --- 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 --- 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: {