From 6642714ec59883c1edd31e9e5b485e99f0edd952 Mon Sep 17 00:00:00 2001 From: sewardj Date: Tue, 26 Oct 1999 17:27:54 +0000 Subject: [PATCH] [project @ 1999-10-26 17:27:25 by sewardj] Add foreign import/export implementations for x86 stdcall convention. Make parser notice calling conventions on f-i and f-x declarations, check they are supported on the platform Hugs is compiled on. Pass them all the way through the code generator to the interpreter. Allow f-i/f-x decls to omit the calling convention, in which case ccall is used. Remove calling convention from all such decls in the Prelude so it will work on any platform. --- ghc/includes/Assembler.h | 8 +- ghc/interpreter/connect.h | 11 ++- ghc/interpreter/dynamic.c | 39 +++++++- ghc/interpreter/dynamic.h | 7 +- ghc/interpreter/input.c | 11 ++- ghc/interpreter/lib/Prelude.hs | 43 ++++----- ghc/interpreter/parser.y | 14 +-- ghc/interpreter/static.c | 30 +++--- ghc/interpreter/storage.c | 5 +- ghc/interpreter/storage.h | 5 +- ghc/interpreter/translate.c | 67 ++++++++++---- ghc/lib/hugs/Prelude.hs | 43 ++++----- ghc/rts/Assembler.c | 18 ++-- ghc/rts/Bytecodes.h | 10 +- ghc/rts/Disassembler.c | 16 ++-- ghc/rts/Evaluator.c | 18 ++-- ghc/rts/ForeignCall.c | 196 ++++++++++++++++++++++++++++------------ ghc/rts/ForeignCall.h | 8 +- ghc/rts/universal_call_c.S | 127 ++++++++++++++++++++------ 19 files changed, 474 insertions(+), 202 deletions(-) diff --git a/ghc/includes/Assembler.h b/ghc/includes/Assembler.h index 36669ca..2cc9dd1 100644 --- a/ghc/includes/Assembler.h +++ b/ghc/includes/Assembler.h @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- - * $Id: Assembler.h,v 1.9 1999/10/19 11:41:35 sewardj Exp $ + * $Id: Assembler.h,v 1.10 1999/10/26 17:27:35 sewardj Exp $ * * (c) The GHC Team 1994-1998. * @@ -243,8 +243,10 @@ extern void asmEndMkPAP ( AsmBCO bco, AsmVar v, AsmSp start ); * C-call and H-call * ------------------------------------------------------------------------*/ -extern const AsmPrim ccall_Id; -extern const AsmPrim ccall_IO; +extern const AsmPrim ccall_ccall_Id; +extern const AsmPrim ccall_ccall_IO; +extern const AsmPrim ccall_stdcall_Id; +extern const AsmPrim ccall_stdcall_IO; typedef struct { unsigned int num_args; diff --git a/ghc/interpreter/connect.h b/ghc/interpreter/connect.h index 0864ba8..426d84c 100644 --- a/ghc/interpreter/connect.h +++ b/ghc/interpreter/connect.h @@ -8,8 +8,8 @@ * included in the distribution. * * $RCSfile: connect.h,v $ - * $Revision: 1.12 $ - * $Date: 1999/10/20 02:15:59 $ + * $Revision: 1.13 $ + * $Date: 1999/10/26 17:27:41 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -78,6 +78,9 @@ 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 */ +extern Text textCcall; /* used to process foreign import */ +extern Text textStdcall; /* ... and foreign export */ + #if NPLUSK extern Text textPlus; /* Used to recognise n+k patterns */ #endif @@ -474,10 +477,10 @@ extern Type typeException; extern Type typeIO; extern Type typeST; -extern Void foreignImport Args((Cell,Pair,Cell,Cell)); +extern Void foreignImport Args((Cell,Text,Pair,Cell,Cell)); extern List foreignImports; /* foreign import declarations */ extern Void implementForeignImport Args((Name)); -extern Void foreignExport Args((Cell,Cell,Cell,Cell)); +extern Void foreignExport Args((Cell,Text,Cell,Cell,Cell)); extern List foreignExports; /* foreign export declarations */ extern Void implementForeignExport Args((Name)); diff --git a/ghc/interpreter/dynamic.c b/ghc/interpreter/dynamic.c index 23d939e..2144706 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.9 $ - * $Date: 1999/10/22 10:00:19 $ + * $Revision: 1.10 $ + * $Date: 1999/10/26 17:27:39 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -52,6 +52,16 @@ String symbol; { return GetProcAddress(instance,symbol); } +Bool stdcallAllowed ( void ) +{ + return TRUE; +} + + + + + + #elif HAVE_DLFCN_H /* eg LINUX, SOLARIS, ULTRIX */ #include @@ -91,6 +101,16 @@ String symbol; { EEND; } +Bool stdcallAllowed ( void ) +{ + return FALSE; +} + + + + + + #elif HAVE_DL_H /* eg HPUX */ #include @@ -107,6 +127,16 @@ String symbol; { return (0 == shl_findsym(&instance,symbol,TYPE_PROCEDURE,&r)) ? r : 0; } +Bool stdcallAllowed ( void ) +{ + return FALSE; +} + + + + + + #else /* Dynamic loading not available */ void* getDLLSymbol(dll,symbol) /* load dll and lookup symbol */ @@ -120,5 +150,10 @@ String symbol; { #endif } +Bool stdcallAllowed ( void ) +{ + return FALSE; +} + #endif /* Dynamic loading not available */ diff --git a/ghc/interpreter/dynamic.h b/ghc/interpreter/dynamic.h index 85e1736..61612a0 100644 --- a/ghc/interpreter/dynamic.h +++ b/ghc/interpreter/dynamic.h @@ -1,5 +1,6 @@ -void* getDLLSymbol Args((String,String)); -void* lookupSymbol Args((ObjectFile file, String symbol)); -ObjectFile loadLibrary Args((String fn)); +extern void* getDLLSymbol Args((String,String)); +extern void* lookupSymbol Args((ObjectFile file, String symbol)); +extern ObjectFile loadLibrary Args((String fn)); +extern Bool stdcallAllowed Args((void)); diff --git a/ghc/interpreter/input.c b/ghc/interpreter/input.c index 071ceb2..922e98b 100644 --- a/ghc/interpreter/input.c +++ b/ghc/interpreter/input.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: input.c,v $ - * $Revision: 1.9 $ - * $Date: 1999/10/15 23:52:00 $ + * $Revision: 1.10 $ + * $Date: 1999/10/26 17:27:39 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -136,6 +136,9 @@ static Text textHiding, textQualified, textAsMod; static Text textExport, textDynamic, textUUExport; static Text textUnsafe, textUUAll; +Text textCcall; /* ccall */ +Text textStdcall; /* stdcall */ + Text textNum; /* Num */ Text textPrelude; /* Prelude */ Text textPlus; /* (+) */ @@ -1493,6 +1496,8 @@ static Int local yylex() { /* Read next input token ... */ if (it==textImport) return IMPORT; if (it==textExport) return EXPORT; if (it==textDynamic) return DYNAMIC; + if (it==textCcall) return CCALL; + if (it==textStdcall) return STDCALL; if (it==textUUExport) return UUEXPORT; if (it==textHiding) return HIDING; if (it==textQualified) return QUALIFIED; @@ -1709,6 +1714,8 @@ Int what; { textInstImport = findText("__instimport"); textExport = findText("export"); textDynamic = findText("dynamic"); + textCcall = findText("ccall"); + textStdcall = findText("stdcall"); textUUExport = findText("__export"); textImport = findText("import"); textHiding = findText("hiding"); diff --git a/ghc/interpreter/lib/Prelude.hs b/ghc/interpreter/lib/Prelude.hs index 21b9aa9..dd5f825 100644 --- a/ghc/interpreter/lib/Prelude.hs +++ b/ghc/interpreter/lib/Prelude.hs @@ -114,6 +114,7 @@ module Prelude ( -- debugging hacks --,ST(..) + ,primIntToAddr ) where -- Standard value bindings {Prelude} ---------------------------------------- @@ -1549,11 +1550,11 @@ primPmFail = error "Pattern Match Failure" primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a primMkIO = ST -primCreateAdjThunk :: (a -> b) -> String -> IO Addr -primCreateAdjThunk fun typestr +primCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr +primCreateAdjThunk fun typestr callconv = do sp <- makeStablePtr fun p <- copy_String_to_cstring typestr -- is never freed - a <- primCreateAdjThunkARCH sp p + a <- primCreateAdjThunkARCH sp p callconv return a -- The following primitives are only needed if (n+k) patterns are enabled: @@ -1702,24 +1703,24 @@ data IOResult = IOResult deriving (Show) type FILE_STAR = Int -- FILE * -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 :: 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 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 :: Addr -> IO Addr +foreign import "nHandle.so" "nh_stdin" nh_stdin :: IO FILE_STAR +foreign import "nHandle.so" "nh_stdout" nh_stdout :: IO FILE_STAR +foreign import "nHandle.so" "nh_stderr" nh_stderr :: IO FILE_STAR +foreign import "nHandle.so" "nh_write" nh_write :: FILE_STAR -> Int -> IO () +foreign import "nHandle.so" "nh_read" nh_read :: FILE_STAR -> IO Int +foreign import "nHandle.so" "nh_open" nh_open :: Addr -> Int -> IO FILE_STAR +foreign import "nHandle.so" "nh_flush" nh_flush :: FILE_STAR -> IO () +foreign import "nHandle.so" "nh_close" nh_close :: FILE_STAR -> IO () +foreign import "nHandle.so" "nh_errno" nh_errno :: IO Int + +foreign import "nHandle.so" "nh_malloc" nh_malloc :: Int -> IO Addr +foreign import "nHandle.so" "nh_free" nh_free :: Addr -> IO () +foreign import "nHandle.so" "nh_store" nh_store :: Addr -> Int -> IO () +foreign import "nHandle.so" "nh_load" nh_load :: Addr -> IO Int + +foreign import "nHandle.so" "nh_argc" nh_argc :: IO Int +foreign import "nHandle.so" "nh_argvb" nh_argvb :: Int -> Int -> IO Int +foreign import "nHandle.so" "nh_getenv" nh_getenv :: Addr -> IO Addr copy_String_to_cstring :: String -> IO Addr copy_String_to_cstring s diff --git a/ghc/interpreter/parser.y b/ghc/interpreter/parser.y index 0d787cf..a836cd6 100644 --- a/ghc/interpreter/parser.y +++ b/ghc/interpreter/parser.y @@ -12,8 +12,8 @@ * included in the distribution. * * $RCSfile: parser.y,v $ - * $Revision: 1.11 $ - * $Date: 1999/10/20 02:16:02 $ + * $Revision: 1.12 $ + * $Date: 1999/10/26 17:27:37 $ * ------------------------------------------------------------------------*/ %{ @@ -97,7 +97,7 @@ static Void local noIP Args((String)); %token '[' ';' ']' '`' '.' %token TMODULE IMPORT HIDING QUALIFIED ASMOD %token EXPORT UUEXPORT INTERFACE REQUIRES UNSAFE -%token INSTIMPORT DYNAMIC +%token INSTIMPORT DYNAMIC CCALL STDCALL %% /*- Top level script/module structure -------------------------------------*/ @@ -631,12 +631,14 @@ derivs : derivs ',' qconid {$$ = gc3(cons($3,$1));} /*- Processing definitions of primitives ----------------------------------*/ topDecl : FOREIGN IMPORT callconv ext_loc ext_name unsafe_flag var COCO type - {foreignImport($1,pair($4,$5),$7,$9); sp-=9;} + {foreignImport($1,$3,pair($4,$5),$7,$9); sp-=9;} | FOREIGN EXPORT callconv DYNAMIC qvarid COCO type - {foreignExport($1,$4,$5,$7); sp-=7;} + {foreignExport($1,$3,$4,$5,$7); sp-=7;} ; -callconv : var {$$ = gc1(NIL); /* ignored */ } +callconv : CCALL {$$ = gc1(textCcall);} + | STDCALL {$$ = gc1(textStdcall);} + | /* empty */ {$$ = gc0(NIL);} ; ext_loc : STRINGLIT {$$ = $1;} ; diff --git a/ghc/interpreter/static.c b/ghc/interpreter/static.c index f2a949e..7a61668 100644 --- a/ghc/interpreter/static.c +++ b/ghc/interpreter/static.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: static.c,v $ - * $Revision: 1.12 $ - * $Date: 1999/10/19 12:05:27 $ + * $Revision: 1.13 $ + * $Date: 1999/10/26 17:27:45 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -3138,8 +3138,10 @@ static Void local checkDefaultDefns() { /* check that default types are */ * what "foreign export static" would mean in an interactive setting. * ------------------------------------------------------------------------*/ -Void foreignImport(line,extName,intName,type) /* Handle foreign imports */ +Void foreignImport(line,callconv,extName,intName,type) + /* Handle foreign imports */ Cell line; +Text callconv; Pair extName; Cell intName; Cell type; { @@ -3153,10 +3155,11 @@ Cell type; { ERRMSG(l) "Redeclaration of foreign \"%s\"", textToStr(t) EEND; } - name(n).line = l; - name(n).defn = extName; - name(n).type = type; - foreignImports = cons(n,foreignImports); + name(n).line = l; + name(n).defn = extName; + name(n).type = type; + name(n).callconv = callconv; + foreignImports = cons(n,foreignImports); } static Void local checkForeignImport(p) /* Check foreign import */ @@ -3173,8 +3176,10 @@ Name p; { implementForeignImport(p); } -Void foreignExport(line,extName,intName,type)/* Handle foreign exports */ +Void foreignExport(line,callconv,extName,intName,type) + /* Handle foreign exports */ Cell line; +Text callconv; Cell extName; Cell intName; Cell type; { @@ -3188,10 +3193,11 @@ Cell type; { ERRMSG(l) "Redeclaration of foreign \"%s\"", textToStr(t) EEND; } - name(n).line = l; - name(n).defn = NIL; /* nothing to say */ - name(n).type = type; - foreignExports = cons(n,foreignExports); + name(n).line = l; + name(n).defn = NIL; /* nothing to say */ + name(n).type = type; + name(n).callconv = callconv; + foreignExports = cons(n,foreignExports); } static Void local checkForeignExport(p) /* Check foreign export */ diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c index e08b3e7..72e9a19 100644 --- a/ghc/interpreter/storage.c +++ b/ghc/interpreter/storage.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: storage.c,v $ - * $Revision: 1.13 $ - * $Date: 1999/10/20 02:16:05 $ + * $Revision: 1.14 $ + * $Date: 1999/10/26 17:27:43 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -438,6 +438,7 @@ Cell parent; { name(nameHw).inlineMe = FALSE; name(nameHw).simplified = FALSE; name(nameHw).isDBuilder = FALSE; + name(nameHw).callconv = NIL; name(nameHw).type = NIL; name(nameHw).primop = 0; name(nameHw).mod = currentModule; diff --git a/ghc/interpreter/storage.h b/ghc/interpreter/storage.h index da74ecb..342e983 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.10 $ - * $Date: 1999/10/16 02:17:25 $ + * $Revision: 1.11 $ + * $Date: 1999/10/26 17:27:42 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -555,6 +555,7 @@ struct strName { Bool inlineMe; /* self-evident */ Bool simplified; /* TRUE => already simplified */ Bool isDBuilder; /* TRUE => is a dictionary builder */ + Text callconv; /* for foreign import/export */ const void* primop; /* really StgPrim* */ Name nextNameHash; }; diff --git a/ghc/interpreter/translate.c b/ghc/interpreter/translate.c index 72dd432..2c2717e 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.10 $ - * $Date: 1999/10/19 11:01:24 $ + * $Revision: 1.11 $ + * $Date: 1999/10/26 17:27:36 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -529,7 +529,7 @@ List scs; { /* in incr order of strict comps. */ name(c).inlineMe = TRUE; name(c).stgSize = stgSize(stgVarBody(name(c).stgVar)); stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals); - //printStg(stderr, name(c).stgVar); fprintf(stderr,"\n\n"); + /* printStg(stderr, name(c).stgVar); fprintf(stderr,"\n\n"); */ } /* -------------------------------------------------------------------------- @@ -570,6 +570,7 @@ static Cell foreignTy ( Bool outBound, Type t ) else if (t == typeAddr) return mkChar(ADDR_REP); else if (t == typeFloat) return mkChar(FLOAT_REP); else if (t == typeDouble) return mkChar(DOUBLE_REP); + else if (t == typeStable) return mkChar(STABLE_REP); #ifdef PROVIDE_FOREIGN else if (t == typeForeign)return mkChar(FOREIGN_REP); /* ToDo: argty only! */ @@ -705,7 +706,6 @@ static StgRhs unboxVars( String reps, List b_args, List u_args, StgExpr e ) if (nonNull(b_args)) { StgVar b_arg = hd(b_args); /* boxed arg */ StgVar u_arg = hd(u_args); /* unboxed arg */ - //StgRep k = mkStgRep(*reps); Name box = repToBox(*reps); e = unboxVars(reps+1,tl(b_args),tl(u_args),e); if (isNull(box)) { @@ -853,11 +853,25 @@ Void implementForeignImport ( Name n ) descriptor = mkDescriptor(charListToString(argTys), charListToString(resultTys)); if (!descriptor) { - ERRMSG(0) "Can't allocate memory for call descriptor" + ERRMSG(name(n).line) "Can't allocate memory for call descriptor" EEND; } - name(n).primop = addState ? &ccall_IO : &ccall_Id; + /* ccall is the default convention, if it wasn't specified */ + if (isNull(name(n).callconv) + || name(n).callconv == textCcall) { + name(n).primop = addState ? &ccall_ccall_IO : &ccall_ccall_Id; + } + else if (name(n).callconv == textStdcall) { + if (!stdcallAllowed()) { + ERRMSG(name(n).line) "stdcall is not supported on this platform" + EEND; + } + name(n).primop = addState ? &ccall_stdcall_IO : &ccall_stdcall_Id; + } + else + internal ( "implementForeignImport: unknown calling convention"); + { Pair extName = name(n).defn; void* funPtr = getDLLSymbol(textToStr(textOf(fst(extName))), @@ -867,7 +881,7 @@ Void implementForeignImport ( Name n ) descriptor->result_tys); StgVar v = mkStgVar(rhs,NIL); if (funPtr == 0) { - ERRMSG(0) "Could not find foreign function \"%s\" in \"%s\"", + ERRMSG(name(n).line) "Could not find foreign function \"%s\" in \"%s\"", textToStr(textOf(snd(extName))), textToStr(textOf(fst(extName))) EEND; @@ -886,7 +900,8 @@ Void implementForeignImport ( Name n ) * * \ fun s0 -> let e1 = A# "...." - in primMkAdjThunk fun s0 e1 + e3 = C# 'c' -- (ccall), or 's' (stdcall) + in primMkAdjThunk fun e1 e3 s0 we require, and check that, fun :: prim_arg* -> IO prim_result @@ -896,11 +911,12 @@ Void implementForeignExport ( Name n ) Type t = name(n).type; List argTys = NIL; List resultTys = NIL; + Char cc_char; if (getHead(t)==typeArrow && argCount==2) { t = arg(fun(t)); } else { - ERRMSG(0) "foreign export has illegal type" ETHEN + ERRMSG(name(n).line) "foreign export has illegal type" ETHEN ERRTEXT " \"" ETHEN ERRTYPE(t); ERRTEXT "\"" EEND; @@ -918,7 +934,7 @@ Void implementForeignExport ( Name n ) assert(length(resultTys) == 1); resultTys = hd(resultTys); } else { - ERRMSG(0) "foreign export doesn't return an IO type" ETHEN + ERRMSG(name(n).line) "foreign export doesn't return an IO type" ETHEN ERRTEXT " \"" ETHEN ERRTYPE(t); ERRTEXT "\"" EEND; @@ -927,11 +943,27 @@ Void implementForeignExport ( Name n ) mapOver(foreignInboundTy,argTys); + /* ccall is the default convention, if it wasn't specified */ + if (isNull(name(n).callconv) + || name(n).callconv == textCcall) { + cc_char = 'c'; + } + else if (name(n).callconv == textStdcall) { + if (!stdcallAllowed()) { + ERRMSG(name(n).line) "stdcall is not supported on this platform" + EEND; + } + cc_char = 's'; + } + else + internal ( "implementForeignExport: unknown calling convention"); + + { List tdList; Text tdText; List args; - StgVar e1, e2, v; + StgVar e1, e2, e3, v; StgExpr fun; tdList = cons(mkChar(':'),argTys); @@ -944,24 +976,27 @@ Void implementForeignExport ( Name n ) mkStgCon(nameMkA,singleton(ap(STRCELL,tdText))), NIL ); - e2 = mkStgVar( + e2 = mkStgVar( mkStgApp(nameUnpackString,singleton(e1)), NIL ); - + e3 = mkStgVar( + mkStgCon(nameMkC,singleton(mkChar(cc_char))), + NIL + ); fun = mkStgLambda( args, mkStgLet( - doubleton(e1,e2), + tripleton(e1,e2,e3), mkStgApp( nameCreateAdjThunk, - tripleton(hd(args),e2,hd(tl(args))) + cons(hd(args),cons(e2,cons(e3,cons(hd(tl(args)),NIL)))) ) ) ); v = mkStgVar(fun,NIL); - /* ppStg(v); */ + ppStg(v); name(n).defn = NIL; name(n).stgVar = v; diff --git a/ghc/lib/hugs/Prelude.hs b/ghc/lib/hugs/Prelude.hs index 21b9aa9..dd5f825 100644 --- a/ghc/lib/hugs/Prelude.hs +++ b/ghc/lib/hugs/Prelude.hs @@ -114,6 +114,7 @@ module Prelude ( -- debugging hacks --,ST(..) + ,primIntToAddr ) where -- Standard value bindings {Prelude} ---------------------------------------- @@ -1549,11 +1550,11 @@ primPmFail = error "Pattern Match Failure" primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a primMkIO = ST -primCreateAdjThunk :: (a -> b) -> String -> IO Addr -primCreateAdjThunk fun typestr +primCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr +primCreateAdjThunk fun typestr callconv = do sp <- makeStablePtr fun p <- copy_String_to_cstring typestr -- is never freed - a <- primCreateAdjThunkARCH sp p + a <- primCreateAdjThunkARCH sp p callconv return a -- The following primitives are only needed if (n+k) patterns are enabled: @@ -1702,24 +1703,24 @@ data IOResult = IOResult deriving (Show) type FILE_STAR = Int -- FILE * -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 :: 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 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 :: Addr -> IO Addr +foreign import "nHandle.so" "nh_stdin" nh_stdin :: IO FILE_STAR +foreign import "nHandle.so" "nh_stdout" nh_stdout :: IO FILE_STAR +foreign import "nHandle.so" "nh_stderr" nh_stderr :: IO FILE_STAR +foreign import "nHandle.so" "nh_write" nh_write :: FILE_STAR -> Int -> IO () +foreign import "nHandle.so" "nh_read" nh_read :: FILE_STAR -> IO Int +foreign import "nHandle.so" "nh_open" nh_open :: Addr -> Int -> IO FILE_STAR +foreign import "nHandle.so" "nh_flush" nh_flush :: FILE_STAR -> IO () +foreign import "nHandle.so" "nh_close" nh_close :: FILE_STAR -> IO () +foreign import "nHandle.so" "nh_errno" nh_errno :: IO Int + +foreign import "nHandle.so" "nh_malloc" nh_malloc :: Int -> IO Addr +foreign import "nHandle.so" "nh_free" nh_free :: Addr -> IO () +foreign import "nHandle.so" "nh_store" nh_store :: Addr -> Int -> IO () +foreign import "nHandle.so" "nh_load" nh_load :: Addr -> IO Int + +foreign import "nHandle.so" "nh_argc" nh_argc :: IO Int +foreign import "nHandle.so" "nh_argvb" nh_argvb :: Int -> Int -> IO Int +foreign import "nHandle.so" "nh_getenv" nh_getenv :: Addr -> IO Addr copy_String_to_cstring :: String -> IO Addr copy_String_to_cstring s diff --git a/ghc/rts/Assembler.c b/ghc/rts/Assembler.c index b4decda..acef38c 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.10 $ - * $Date: 1999/10/15 11:02:58 $ + * $Revision: 1.11 $ + * $Date: 1999/10/26 17:27:28 $ * * This module provides functions to construct BCOs and other closures * required by the bytecode compiler. @@ -1366,7 +1366,7 @@ const AsmPrim asmPrimOps[] = { , { "primFreeStablePtr", "s", "", MONAD_IO, i_PRIMOP2, i_freeStablePtr } /* foreign export dynamic support */ - , { "primCreateAdjThunkARCH", "sA", "A", MONAD_IO, i_PRIMOP2, i_createAdjThunkARCH } + , { "primCreateAdjThunkARCH", "sAC","A", MONAD_IO, i_PRIMOP2, i_createAdjThunkARCH } #ifdef PROVIDE_PTREQUALITY , { "primReallyUnsafePtrEquality", "aa", "B",MONAD_Id, i_PRIMOP2, i_reallyUnsafePtrEquality } @@ -1389,11 +1389,17 @@ const AsmPrim asmPrimOps[] = { /* Ccall is polyadic - so it's excluded from this table */ - , { 0,0,0,0 } + , { 0,0,0,0,0,0 } }; -const AsmPrim ccall_Id = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_Id }; -const AsmPrim ccall_IO = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_IO }; +const AsmPrim ccall_ccall_Id + = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_ccall_Id }; +const AsmPrim ccall_ccall_IO + = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_ccall_IO }; +const AsmPrim ccall_stdcall_Id + = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_stdcall_Id }; +const AsmPrim ccall_stdcall_IO + = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_stdcall_IO }; const AsmPrim* asmFindPrim( char* s ) diff --git a/ghc/rts/Bytecodes.h b/ghc/rts/Bytecodes.h index f277d59..c52d51c 100644 --- a/ghc/rts/Bytecodes.h +++ b/ghc/rts/Bytecodes.h @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- - * $Id: Bytecodes.h,v 1.7 1999/10/15 11:02:59 sewardj Exp $ + * $Id: Bytecodes.h,v 1.8 1999/10/26 17:27:30 sewardj Exp $ * * (c) The GHC Team, 1998-1999 * @@ -426,14 +426,16 @@ typedef enum #endif /* CCall! */ - , i_ccall_Id - , i_ccall_IO + , i_ccall_ccall_Id + , i_ccall_ccall_IO + , i_ccall_stdcall_Id + , i_ccall_stdcall_IO /* If you add a new primop to this table, check you don't * overflow the 256 limit. That is MAX_Primop2 <= 255. * Current value (30/10/98) = 0x42 */ - , MAX_Primop2 = i_ccall_IO + , MAX_Primop2 = i_ccall_stdcall_IO } Primop2; typedef unsigned int InstrPtr; /* offset of instruction within BCO */ diff --git a/ghc/rts/Disassembler.c b/ghc/rts/Disassembler.c index e3590ae..cbf36ac 100644 --- a/ghc/rts/Disassembler.c +++ b/ghc/rts/Disassembler.c @@ -5,8 +5,8 @@ * Copyright (c) 1994-1998. * * $RCSfile: Disassembler.c,v $ - * $Revision: 1.8 $ - * $Date: 1999/10/15 11:03:01 $ + * $Revision: 1.9 $ + * $Date: 1999/10/26 17:27:31 $ * ---------------------------------------------------------------------------*/ #include "Rts.h" @@ -369,10 +369,14 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) switch (op) { case i_INTERNAL_ERROR2: return disNone(bco,pc,"INTERNAL_ERROR2"); - case i_ccall_Id: - return disNone(bco,pc,"ccall_Id"); - case i_ccall_IO: - return disNone(bco,pc,"ccall_IO"); + case i_ccall_ccall_Id: + return disNone(bco,pc,"ccall_ccall_Id"); + case i_ccall_ccall_IO: + return disNone(bco,pc,"ccall_ccall_IO"); + case i_ccall_stdcall_Id: + return disNone(bco,pc,"ccall_stdcall_Id"); + case i_ccall_stdcall_IO: + return disNone(bco,pc,"ccall_stdcall_IO"); case i_raise: return disNone(bco,pc,"primRaise"); default: diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c index a898471..6dd91fa 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.21 $ - * $Date: 1999/10/22 15:58:22 $ + * $Revision: 1.22 $ + * $Date: 1999/10/26 17:27:25 $ * ---------------------------------------------------------------------------*/ #include "Rts.h" @@ -2883,7 +2883,8 @@ static void* enterBCO_primop2 ( int primop2code, { StgStablePtr stableptr = PopTaggedStablePtr(); StgAddr typestr = PopTaggedAddr(); - StgAddr adj_thunk = createAdjThunk(stableptr,typestr); + StgChar callconv = PopTaggedChar(); + StgAddr adj_thunk = createAdjThunk(stableptr,typestr,callconv); PushTaggedAddr(adj_thunk); break; } @@ -3036,13 +3037,18 @@ off the stack. ASSERT(0); break; #endif /* PROVIDE_CONCURRENT */ - case i_ccall_Id: - case i_ccall_IO: + case i_ccall_ccall_Id: + case i_ccall_ccall_IO: + case i_ccall_stdcall_Id: + case i_ccall_stdcall_IO: { int r; CFunDescriptor* descriptor = PopTaggedAddr(); void (*funPtr)(void) = PopTaggedAddr(); - r = ccall(descriptor,funPtr,bco); + char cc = (primop2code == i_ccall_stdcall_Id || + primop2code == i_ccall_stdcall_IO) + ? 's' : 'c'; + r = ccall(descriptor,funPtr,bco,cc); if (r == 0) break; if (r == 1) return makeErrorCall( diff --git a/ghc/rts/ForeignCall.c b/ghc/rts/ForeignCall.c index 5b1e64f..5bf75ad 100644 --- a/ghc/rts/ForeignCall.c +++ b/ghc/rts/ForeignCall.c @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- - * $Id: ForeignCall.c,v 1.9 1999/10/22 15:58:21 sewardj Exp $ + * $Id: ForeignCall.c,v 1.10 1999/10/26 17:27:30 sewardj Exp $ * * (c) The GHC Team 1994-1999. * @@ -153,16 +153,19 @@ CFunDescriptor* mkDescriptor( char* as, char* rs ) * External refs for the assembly routines. * ----------------------------------------------------------------*/ -extern void universal_call_c_x86_ccall ( int, void*, char*, void* ); -static void universal_call_c_generic ( int, void*, char*, void* ); - +#if i386_TARGET_ARCH +extern void universal_call_c_x86_stdcall ( int, void*, char*, void* ); +extern void universal_call_c_x86_ccall ( int, void*, char*, void* ); +#else +static void universal_call_c_generic ( int, void*, char*, void* ); +#endif /* ----------------------------------------------------------------* * This is a generic version of universal call that * only works for specific argument patterns. * * It allows ports to work on the Hugs Prelude immediately, - * even if univeral_call_c_arch_callingconvention is not available. + * even if universal_call_c_arch_callingconvention is not available. * ----------------------------------------------------------------*/ static void universal_call_c_generic @@ -221,7 +224,11 @@ static void universal_call_c_generic * This code attempts to be architecture neutral (viz, generic). * ----------------------------------------------------------------*/ -int ccall ( CFunDescriptor* d, void (*fun)(void), StgBCO** bco ) +int ccall ( CFunDescriptor* d, + void (*fun)(void), + StgBCO** bco, + char cc + ) { double arg_vec [31]; char argd_vec[31]; @@ -306,9 +313,14 @@ int ccall ( CFunDescriptor* d, void (*fun)(void), StgBCO** bco ) PushPtr((StgPtr)(*bco)); SaveThreadState(); -#if 1 - universal_call_c_x86_ccall ( - d->num_args, (void*)arg_vec, argd_vec, fun ); +#if i386_TARGET_ARCH + if (cc == 'c') + universal_call_c_x86_ccall ( + d->num_args, (void*)arg_vec, argd_vec, fun ); + else if (cc == 's') + universal_call_c_x86_stdcall ( + d->num_args, (void*)arg_vec, argd_vec, fun ); + else barf ( "ccall(i386): unknown calling convention" ); #else universal_call_c_generic ( d->num_args, (void*)arg_vec, argd_vec, fun ); @@ -367,13 +379,13 @@ extern void* getHugs_AsmObject_for ( char* s ); /* ----------------------------------------------------------------* - * The implementation for x86_ccall. + * The implementation for x86_ccall and x86_stdcall. * ----------------------------------------------------------------*/ static HaskellObj -unpackArgsAndCallHaskell_x86_ccall_wrk ( StgStablePtr stableptr, - char* tydesc, char* args) +unpackArgsAndCallHaskell_x86_nocallconv_wrk ( StgStablePtr stableptr, + char* tydesc, char* args) { /* Copy args out of the C stack frame in an architecture dependent fashion, under the direction of the type description @@ -437,7 +449,8 @@ unpackArgsAndCallHaskell_x86_ccall_wrk ( StgStablePtr stableptr, break; default: barf( - "unpackArgsAndCallHaskell_x86_ccall: unexpected arg type rep"); + "unpackArgsAndCallHaskell_x86_nocallconv: " + "unexpected arg type rep"); } argp++; } @@ -448,7 +461,7 @@ unpackArgsAndCallHaskell_x86_ccall_wrk ( StgStablePtr stableptr, sstat = rts_eval ( node, &nodeOut ); if (sstat != Success) - barf ("unpackArgsAndCallHaskell_x86_ccall: eval failed"); + barf ("unpackArgsAndCallHaskell_x86_nocallconv: eval failed"); return nodeOut; } @@ -456,11 +469,14 @@ unpackArgsAndCallHaskell_x86_ccall_wrk ( StgStablePtr stableptr, static double -unpackArgsAndCallHaskell_x86_ccall_DOUBLE ( StgStablePtr stableptr, - char* tydesc, char* args) +unpackArgsAndCallHaskell_x86_nocallconv_DOUBLE ( + StgStablePtr stableptr, char* tydesc, char* args + ) { HaskellObj nodeOut - = unpackArgsAndCallHaskell_x86_ccall_wrk ( stableptr, tydesc, args ); + = unpackArgsAndCallHaskell_x86_nocallconv_wrk ( + stableptr, tydesc, args + ); /* Return a double. This return will go into %st(0), which is unmodified by the adjustor thunk. */ @@ -471,11 +487,14 @@ unpackArgsAndCallHaskell_x86_ccall_DOUBLE ( StgStablePtr stableptr, static float -unpackArgsAndCallHaskell_x86_ccall_FLOAT ( StgStablePtr stableptr, - char* tydesc, char* args) +unpackArgsAndCallHaskell_x86_nocallconv_FLOAT ( + StgStablePtr stableptr, char* tydesc, char* args + ) { HaskellObj nodeOut - = unpackArgsAndCallHaskell_x86_ccall_wrk ( stableptr, tydesc, args ); + = unpackArgsAndCallHaskell_x86_nocallconv_wrk ( + stableptr, tydesc, args + ); /* Probably could be merged with the double case, since %st(0) is still the return register. */ @@ -486,11 +505,14 @@ unpackArgsAndCallHaskell_x86_ccall_FLOAT ( StgStablePtr stableptr, static unsigned long -unpackArgsAndCallHaskell_x86_ccall_INTISH ( StgStablePtr stableptr, - char* tydesc, char* args) +unpackArgsAndCallHaskell_x86_nocallconv_INTISH ( + StgStablePtr stableptr, char* tydesc, char* args + ) { HaskellObj nodeOut - = unpackArgsAndCallHaskell_x86_ccall_wrk ( stableptr, tydesc, args ); + = 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 @@ -506,56 +528,108 @@ unpackArgsAndCallHaskell_x86_ccall_INTISH ( StgStablePtr stableptr, case STABLE_REP: return (unsigned long)rts_getStablePtr(nodeOut); default: barf( - "unpackArgsAndCallHaskell_x86_ccall: unexpected res type rep"); + "unpackArgsAndCallHaskell_x86_nocallconv: " + "unexpected res type rep"); } } +/* This is a bit subtle, since it can deal with both stdcall + and ccall. There are two call transitions to consider: + + 1. The call to "here". If it's a ccall, we can return + using 'ret 0' and let the caller remove the args. + If stdcall, we have to return with 'ret N', where + N is the size of the args passed. N has to be + determined by inspecting the type descriptor string + typestr. + + 2. The call to unpackArgsAndCallHaskell_x86_anycallconv_*. + Whether these are done with stdcall or ccall depends on + the conventions applied by the compiler that translated + those procedures. Fortunately, we can sidestep what it + did by saving esp (in ebx), pushing the three args, + calling unpack..., and restoring esp from ebx. This + trick assumes that ebx is a callee-saves register, so + its value will be preserved across the unpack... call. +*/ static -StgAddr createAdjThunk_x86_ccall ( StgStablePtr stableptr, - StgAddr typestr ) +StgAddr createAdjThunk_x86 ( StgStablePtr stableptr, + StgAddr typestr, + char callconv ) { unsigned char* codeblock; unsigned char* cp; - unsigned int ts = (unsigned int)typestr; - unsigned int sp = (unsigned int)stableptr; - unsigned int ch; + unsigned int ch; + unsigned int nwords; + + unsigned char* argp = (unsigned char*)typestr; + unsigned int ts = (unsigned int)typestr; + unsigned int sp = (unsigned int)stableptr; if (((char*)typestr)[0] == DOUBLE_REP) - ch = (unsigned int)&unpackArgsAndCallHaskell_x86_ccall_DOUBLE; + ch = (unsigned int) + &unpackArgsAndCallHaskell_x86_nocallconv_DOUBLE; else if (((char*)typestr)[0] == FLOAT_REP) - ch = (unsigned int)&unpackArgsAndCallHaskell_x86_ccall_FLOAT; + ch = (unsigned int) + &unpackArgsAndCallHaskell_x86_nocallconv_FLOAT; else - ch = (unsigned int)&unpackArgsAndCallHaskell_x86_ccall_INTISH; - - codeblock = malloc ( 1 + 0x22 ); - if (!codeblock) { - fprintf ( stderr, - "createAdjThunk_x86_ccall (foreign export dynamic):\n" - "\tfatal: can't alloc mem\n" ); - exit(1); + ch = (unsigned int) + &unpackArgsAndCallHaskell_x86_nocallconv_INTISH; + + codeblock = malloc ( 0x26 ); + if (!codeblock) + barf ( "createAdjThunk_x86: can't malloc memory\n"); + + if (callconv == 's') { + nwords = 0; + if (*argp != ':') argp++; + ASSERT( *argp == ':' ); + argp++; + while (*argp) { + switch (*argp) { + case CHAR_REP: case INT_REP: case WORD_REP: + case ADDR_REP: case STABLE_REP: case FLOAT_REP: + nwords += 4; break; + case DOUBLE_REP: + nwords += 8; break; + default: + barf("createAdjThunk_x86: unexpected type descriptor"); + } + argp++; + } + } else + if (callconv == 'c') { + nwords = 0; + } else { + barf ( "createAdjThunk_x86: unknown calling convention\n"); } + cp = codeblock; - /* Generate the following: - 0000 53 pushl %ebx + /* + 0000 53 pushl %ebx # save caller's registers 0001 51 pushl %ecx 0002 56 pushl %esi 0003 57 pushl %edi 0004 55 pushl %ebp 0005 89E0 movl %esp,%eax # sp -> eax 0007 83C018 addl $24,%eax # move eax back over 5 saved regs + retaddr - 000a 50 pushl %eax # push arg-block addr - 000b 6844332211 pushl $0x11223344 # push addr of type descr string - 0010 6877665544 pushl $0x44556677 # push stableptr to closure - 0015 E8BBAA9988 call 0x8899aabb # SEE COMMENT BELOW - 001a 83C40C addl $12,%esp # pop 3 args - 001d 5D popl %ebp - 001e 5F popl %edi - 001f 5E popl %esi - 0020 59 popl %ecx - 0021 5B popl %ebx - 0022 C3 ret - */ + 000a 89E3 movl %esp,%ebx # remember sp before pushing args + 000c 50 pushl %eax # push arg-block addr + 000d 6844332211 pushl $0x11223344 # push addr of type descr string + 0012 6877665544 pushl $0x44556677 # push stableptr to closure + 0017 E8BBAA9988 call 0x8899aabb # SEE COMMENT BELOW + # return value is in %eax, or %eax:%edx, + # or %st(0), so don't trash these regs + # between here and 'ret' + 001c 89DC movl %ebx,%esp # restore sp from remembered value + 001e 5D popl %ebp # restore caller's registers + 001f 5F popl %edi + 0020 5E popl %esi + 0021 59 popl %ecx + 0022 5B popl %ebx + 0023 C27766 ret $0x6677 # return, clearing args if stdcall + */ *cp++ = 0x53; *cp++ = 0x51; *cp++ = 0x56; @@ -563,6 +637,7 @@ StgAddr createAdjThunk_x86_ccall ( StgStablePtr stableptr, *cp++ = 0x55; *cp++ = 0x89; *cp++ = 0xE0; *cp++ = 0x83; *cp++ = 0xC0; *cp++ = 0x18; + *cp++ = 0x89; *cp++ = 0xE3; *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; @@ -571,13 +646,13 @@ StgAddr createAdjThunk_x86_ccall ( StgStablePtr stableptr, 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++ = 0x89; *cp++ = 0xDC; *cp++ = 0x5D; *cp++ = 0x5F; *cp++ = 0x5E; *cp++ = 0x59; *cp++ = 0x5B; - *cp++ = 0xC3; + *cp++ = 0xC2; *cp++=nwords;nwords>>=8; *cp++=nwords; return codeblock; } @@ -589,9 +664,16 @@ StgAddr createAdjThunk_x86_ccall ( StgStablePtr stableptr, * ----------------------------------------------------------------*/ StgAddr createAdjThunk ( StgStablePtr stableptr, - StgAddr typestr ) + StgAddr typestr, + StgChar callconv ) { - return createAdjThunk_x86_ccall ( stableptr, typestr ); + return +#if i386_TARGET_ARCH + createAdjThunk_x86 ( stableptr, typestr, callconv ); +#else + 0; + #warn foreign export not implemented on this architecture +#endif } diff --git a/ghc/rts/ForeignCall.h b/ghc/rts/ForeignCall.h index f4df3fc..5bff124 100644 --- a/ghc/rts/ForeignCall.h +++ b/ghc/rts/ForeignCall.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: ForeignCall.h,v 1.6 1999/10/22 15:58:21 sewardj Exp $ + * $Id: ForeignCall.h,v 1.7 1999/10/26 17:27:30 sewardj Exp $ * * (c) The GHC Team, 1998-1999 * @@ -11,8 +11,10 @@ typedef int StablePtr; extern int ccall ( CFunDescriptor* descriptor, void (*fun)(void), - StgBCO** bco + StgBCO** bco, + char callconv ); extern StgAddr createAdjThunk ( StgStablePtr stableptr, - StgAddr typestr ); + StgAddr typestr, + StgChar callconv ); diff --git a/ghc/rts/universal_call_c.S b/ghc/rts/universal_call_c.S index 3f03ff3..e34af9f 100644 --- a/ghc/rts/universal_call_c.S +++ b/ghc/rts/universal_call_c.S @@ -5,8 +5,8 @@ * Copyright (c) 1994-1999. * * $RCSfile: universal_call_c.S,v $ - * $Revision: 1.3 $ - * $Date: 1999/10/22 15:58:26 $ + * $Revision: 1.4 $ + * $Date: 1999/10/26 17:27:31 $ * ------------------------------------------------------------------------*/ #include "config.h" @@ -66,6 +66,7 @@ #endif #if i386_TARGET_ARCH + .globl universal_call_c_x86_ccall universal_call_c_x86_ccall: pushl %ebp @@ -77,61 +78,135 @@ universal_call_c_x86_ccall: movl 16(%ebp),%edi movl 8(%ebp),%ebx testl %ebx,%ebx - jle docall + jle cdocall -looptop: +clooptop: cmpb $105,(%ebx,%edi) # 'i' - jne .L6 + jne .Lc6 pushl (%esi,%ebx,8) - jmp looptest -.L6: + jmp clooptest +.Lc6: cmpb $73,(%ebx,%edi) # 'I' - jne .L8 + jne .Lc8 pushl 4(%esi,%ebx,8) pushl (%esi,%ebx,8) - jmp looptest -.L8: + jmp clooptest +.Lc8: cmpb $102,(%ebx,%edi) # 'f' - jne .L10 + jne .Lc10 movl (%esi,%ebx,8),%eax pushl %eax - jmp looptest -.L10: + jmp clooptest +.Lc10: cmpb $70,(%ebx,%edi) # 'F' - jne looptest + jne clooptest movl 4(%esi,%ebx,8),%eax movl (%esi,%ebx,8),%edx pushl %eax pushl %edx -looptest: +clooptest: decl %ebx testl %ebx,%ebx - jg looptop + jg clooptop -docall: +cdocall: call *20(%ebp) cmpb $102,(%edi) # 'f' - je float32 + je cfloat32 cmpb $70,(%edi) # 'F' - je float64 -iorI: + je cfloat64 +ciorI: movl %eax,0(%esi) movl %edx,4(%esi) - jmp bye -float32: + jmp cbye +cfloat32: fstps 0(%esi) - jmp bye -float64: + jmp cbye +cfloat64: fstpl 0(%esi) - jmp bye -bye: + jmp cbye +cbye: leal -12(%ebp),%esp popl %ebx popl %esi popl %edi leave ret + + + +# Almost identical to the above piece of code +# see comments near end for differences + +.globl universal_call_c_x86_stdcall +universal_call_c_x86_stdcall: + pushl %ebp + movl %esp,%ebp + pushl %edi + pushl %esi + pushl %ebx + movl 12(%ebp),%esi + movl 16(%ebp),%edi + movl 8(%ebp),%ebx + testl %ebx,%ebx + jle sdocall + +slooptop: + cmpb $105,(%ebx,%edi) # 'i' + jne .Ls6 + pushl (%esi,%ebx,8) + jmp slooptest +.Ls6: + cmpb $73,(%ebx,%edi) # 'I' + jne .Ls8 + pushl 4(%esi,%ebx,8) + pushl (%esi,%ebx,8) + jmp slooptest +.Ls8: + cmpb $102,(%ebx,%edi) # 'f' + jne .Ls10 + movl (%esi,%ebx,8),%eax + pushl %eax + jmp slooptest +.Ls10: + cmpb $70,(%ebx,%edi) # 'F' + jne slooptest + movl 4(%esi,%ebx,8),%eax + movl (%esi,%ebx,8),%edx + pushl %eax + pushl %edx +slooptest: + decl %ebx + testl %ebx,%ebx + jg slooptop + +sdocall: + call *20(%ebp) + + cmpb $102,(%edi) # 'f' + je sfloat32 + cmpb $70,(%edi) # 'F' + je sfloat64 +siorI: + movl %eax,0(%esi) + movl %edx,4(%esi) + jmp sbye +sfloat32: + fstps 0(%esi) + jmp sbye +sfloat64: + fstpl 0(%esi) + jmp sbye +sbye: + ## don_t clear the args -- the callee does it + ## leal -12(%ebp),%esp + popl %ebx + popl %esi + popl %edi + leave + ret $16 # but we have to clear our own! + #endif /* i386_TARGET_ARCH */ #endif /* INTERPRETER */ \ No newline at end of file -- 1.7.10.4