From e120f85a5df3f5f3e0c6ffb8d5bad1b7a6d24ab9 Mon Sep 17 00:00:00 2001 From: sewardj Date: Thu, 2 Mar 2000 10:10:34 +0000 Subject: [PATCH] [project @ 2000-03-02 10:10:33 by sewardj] Changes needed to support foreign export (dynamic) in combined mode. --- ghc/interpreter/interface.c | 7 +++++-- ghc/interpreter/lib/Prelude.hs | 5 +++++ ghc/interpreter/storage.h | 6 +++--- ghc/interpreter/translate.c | 17 +++++++---------- ghc/lib/hugs/Prelude.hs | 5 +++++ ghc/lib/std/PrelHugs.lhs | 38 ++++++++++++++++++++++++++++++++++++-- ghc/rts/ForeignCall.c | 28 ++++++++++++++++------------ 7 files changed, 77 insertions(+), 29 deletions(-) diff --git a/ghc/interpreter/interface.c b/ghc/interpreter/interface.c index da604fc..d0e753c 100644 --- a/ghc/interpreter/interface.c +++ b/ghc/interpreter/interface.c @@ -7,8 +7,8 @@ * Hugs version 1.4, December 1997 * * $RCSfile: interface.c,v $ - * $Revision: 1.32 $ - * $Date: 2000/02/24 12:34:18 $ + * $Revision: 1.33 $ + * $Date: 2000/03/02 10:10:33 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -2519,6 +2519,9 @@ Type type; { Sym(prog_argv) \ Sym(prog_argc) \ Sym(resetNonBlockingFd) \ + Sym(getStablePtr) \ + Sym(stable_ptr_table) \ + Sym(createAdjThunk) \ \ /* needed by libHS_cbits */ \ SymX(malloc) \ diff --git a/ghc/interpreter/lib/Prelude.hs b/ghc/interpreter/lib/Prelude.hs index 9fcb210..09d1a03 100644 --- a/ghc/interpreter/lib/Prelude.hs +++ b/ghc/interpreter/lib/Prelude.hs @@ -1560,6 +1560,11 @@ hugsprimPmFail :: a hugsprimPmFail = error "Pattern Match Failure" -- used in desugaring Foreign functions +-- Note: hugsprimMkIO is used as a wrapper to translate a Hugs-created +-- bit of code of type RealWorld -> (a,RealWorld) into a proper IO value. +-- What follows is the version for standalone mode. ghc/lib/std/PrelHugs.lhs +-- contains a version used in combined mode. That version takes care of +-- switching between the GHC and Hugs IO representations, which are different. hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a hugsprimMkIO = ST diff --git a/ghc/interpreter/storage.h b/ghc/interpreter/storage.h index 932f553..167fece 100644 --- a/ghc/interpreter/storage.h +++ b/ghc/interpreter/storage.h @@ -10,8 +10,8 @@ * included in the distribution. * * $RCSfile: storage.h,v $ - * $Revision: 1.29 $ - * $Date: 2000/02/25 10:53:54 $ + * $Revision: 1.30 $ + * $Date: 2000/03/02 10:10:33 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -547,7 +547,7 @@ extern void* lookupOExtraTabName ( char* sym ); #define isPrelude(m) (m==modulePrelude) -#define N_PRELUDE_SCRIPTS (combined ? 30 : 1) +#define N_PRELUDE_SCRIPTS (combined ? 32 : 1) /* -------------------------------------------------------------------------- * Type constructor names: diff --git a/ghc/interpreter/translate.c b/ghc/interpreter/translate.c index ead65fc..d22ebd1 100644 --- a/ghc/interpreter/translate.c +++ b/ghc/interpreter/translate.c @@ -10,8 +10,8 @@ * included in the distribution. * * $RCSfile: translate.c,v $ - * $Revision: 1.24 $ - * $Date: 1999/12/10 15:59:56 $ + * $Revision: 1.25 $ + * $Date: 2000/03/02 10:10:33 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -899,17 +899,15 @@ Void implementForeignImport ( Name n ) descriptor->arg_tys++; descriptor->num_args--; } - - } /* Generate code: * - * \ fun s0 -> + * \ fun -> let e1 = A# "...." e3 = C# 'c' -- (ccall), or 's' (stdcall) - in primMkAdjThunk fun e1 e3 s0 + in primMkAdjThunk fun e1 e3 we require, and check that, fun :: prim_arg* -> IO prim_result @@ -942,7 +940,7 @@ Void implementForeignExport ( Name n ) assert(length(resultTys) == 1); resultTys = hd(resultTys); } else { - ERRMSG(name(n).line) "foreign export doesn't return an IO type" ETHEN + ERRMSG(name(n).line) "function to be exported doesn't return an IO type: " ETHEN ERRTEXT " \"" ETHEN ERRTYPE(t); ERRTEXT "\"" EEND; @@ -966,7 +964,6 @@ Void implementForeignExport ( Name n ) else internal ( "implementForeignExport: unknown calling convention"); - { List tdList; Text tdText; @@ -979,7 +976,7 @@ Void implementForeignExport ( Name n ) tdList = cons(foreignOutboundTy(resultTys),tdList); tdText = findText(charListToString ( tdList )); - args = makeArgs(2); + args = makeArgs(1); e1 = mkStgVar( mkStgCon(nameMkA,singleton(ap(STRCELL,tdText))), NIL @@ -998,7 +995,7 @@ Void implementForeignExport ( Name n ) tripleton(e1,e2,e3), mkStgApp( nameCreateAdjThunk, - cons(hd(args),cons(e2,cons(e3,cons(hd(tl(args)),NIL)))) + cons(hd(args),cons(e2,cons(e3,NIL))) ) ) ); diff --git a/ghc/lib/hugs/Prelude.hs b/ghc/lib/hugs/Prelude.hs index 9fcb210..09d1a03 100644 --- a/ghc/lib/hugs/Prelude.hs +++ b/ghc/lib/hugs/Prelude.hs @@ -1560,6 +1560,11 @@ hugsprimPmFail :: a hugsprimPmFail = error "Pattern Match Failure" -- used in desugaring Foreign functions +-- Note: hugsprimMkIO is used as a wrapper to translate a Hugs-created +-- bit of code of type RealWorld -> (a,RealWorld) into a proper IO value. +-- What follows is the version for standalone mode. ghc/lib/std/PrelHugs.lhs +-- contains a version used in combined mode. That version takes care of +-- switching between the GHC and Hugs IO representations, which are different. hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a hugsprimMkIO = ST diff --git a/ghc/lib/std/PrelHugs.lhs b/ghc/lib/std/PrelHugs.lhs index 6138c53..805f7b7 100644 --- a/ghc/lib/std/PrelHugs.lhs +++ b/ghc/lib/std/PrelHugs.lhs @@ -38,9 +38,11 @@ import PrelShow(show,shows,showString,showChar,Show,ShowS) import PrelRead(Read,ReadS,lex,reads) import PrelFloat(Double) import PrelReal(Fractional,fromRational,toRational) -import PrelAddr(Addr) +import PrelAddr(Addr(..),nullAddr) +import PrelStable(StablePtr,makeStablePtr) import PrelErr(error) import PrelPack(unpackCString) +import List(length) -- Stuff needed by Hugs for desugaring. Do not mess with these! -- They need to correspond exactly to versions written in @@ -73,10 +75,42 @@ connectWorlds hrealworld +-- StgAddr createAdjThunk ( StgStablePtr stableptr, +-- StgAddr typestr, +-- StgChar callconv ) +foreign import "createAdjThunk" hugsCreateAdjThunk + :: StablePtr (a -> b) -> Addr{-mallocville String-} -> Char -> IO Addr +foreign import "malloc" malloc + :: Int -> IO Addr hugsprimCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr hugsprimCreateAdjThunk fun typestr callconv - = error "hugsprimCreateAdjThunk in combined mode: unimplemented" + = do sp <- makeStablePtr fun + p <- copy_String_to_cstring typestr -- is never freed + a <- hugsCreateAdjThunk sp p callconv + return a + where + copy_String_to_cstring :: String -> IO Addr + copy_String_to_cstring s + = malloc (1 + length s) >>= \ptr0 -> + let loop off [] = writeCharOffAddr ptr0 off (chr 0) + >> return ptr0 + loop off (c:cs) = writeCharOffAddr ptr0 off c + >> loop (off+1) cs + in + if isNullAddr ptr0 + then error "copy_String_to_cstring: malloc failed" + else loop 0 s + + isNullAddr a = a == nullAddr + + writeCharOffAddr :: Addr -> Int -> Char -> IO () + writeCharOffAddr (A# buf#) (I# n#) (C# c#) + = IO ( \ s# -> + case (writeCharOffAddr# buf# n# c# s#) of + s2# -> (# s2#, () #) ) + + fromDouble :: Fractional a => Double -> a fromDouble n = fromRational (toRational n) diff --git a/ghc/rts/ForeignCall.c b/ghc/rts/ForeignCall.c index 17eb97a..66d3758 100644 --- a/ghc/rts/ForeignCall.c +++ b/ghc/rts/ForeignCall.c @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- - * $Id: ForeignCall.c,v 1.11 1999/11/08 15:30:37 sewardj Exp $ + * $Id: ForeignCall.c,v 1.12 2000/03/02 10:10:34 sewardj Exp $ * * (c) The GHC Team 1994-1999. * @@ -386,7 +386,7 @@ int ccall ( CFunDescriptor* d, for a given function by name. Useful but a hack. Sigh. */ extern void* getHugs_AsmObject_for ( char* s ); - +extern int /*Bool*/ combined; /* ----------------------------------------------------------------* * The implementation for x86_ccall and x86_stdcall. @@ -464,12 +464,16 @@ unpackArgsAndCallHaskell_x86_nocallconv_wrk ( StgStablePtr stableptr, } argp++; } - - node = rts_apply ( - asmClosureOfObject(getHugs_AsmObject_for("primRunST")), - node ); - - sstat = rts_eval ( node, &nodeOut ); +fprintf(stderr,"before rts_evalIO\n"); + if (combined) { + sstat = rts_evalIO ( node, &nodeOut ); + } else { + node = rts_apply ( + asmClosureOfObject(getHugs_AsmObject_for("primRunST")), + node ); + sstat = rts_eval ( node, &nodeOut ); + } +fprintf(stderr, "after rts_evalIO\n"); if (sstat != Success) barf ("unpackArgsAndCallHaskell_x86_nocallconv: eval failed"); @@ -519,10 +523,10 @@ unpackArgsAndCallHaskell_x86_nocallconv_INTISH ( StgStablePtr stableptr, char* tydesc, char* args ) { - HaskellObj nodeOut - = unpackArgsAndCallHaskell_x86_nocallconv_wrk ( - stableptr, tydesc, args - ); + HaskellObj nodeOut; + nodeOut = unpackArgsAndCallHaskell_x86_nocallconv_wrk ( + stableptr, tydesc, args + ); /* A complete hack. We know that all these returns will be put into %eax (and %edx, if it is a 64-bit return), and the adjustor thunk will then itself return to the original -- 1.7.10.4