+/* ----------------------------------------------------------------------
+ * Part the second: CALLING IN -- foreign export {dynamic}
+ * --------------------------------------------------------------------*/
+
+/* Make it possible for the evaluator to get hold of bytecode
+ for a given function by name. Useful but a hack. Sigh.
+ */
+extern void* getHugs_AsmObject_for ( char* s );
+
+
+/* ----------------------------------------------------------------*
+ * The implementation for x86_ccall and x86_stdcall.
+ * ----------------------------------------------------------------*/
+
+static
+HaskellObj
+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
+ string tydesc. Dereference the stable pointer, giving the
+ Haskell function to call. Build an application of this to
+ the arguments, and finally wrap primRunST round the whole
+ thing, since we know it returns an IO type. Then evaluate
+ the whole, which leaves nodeOut as the evaluated 'a', where
+ the type of the function called is .... -> IO a.
+
+ We can't immediately unpack the results and return, since
+ int results need to return in a different register (%eax and
+ possibly %edx) from float things (%st(0)). So return nodeOut
+ to the relevant wrapper function, which knows enough about
+ the return type to do the Right Thing.
+
+ There's no getting round it: this is most heinous hack.
+ */
+
+ HaskellObj node;
+ HaskellObj nodeOut;
+ SchedulerStatus sstat;
+
+ char* resp = tydesc;
+ char* argp = tydesc;
+
+ node = (HaskellObj)deRefStablePtr(stableptr);
+
+ if (*argp != ':') argp++;
+ ASSERT( *argp == ':' );
+ argp++;
+ while (*argp) {
+ switch (*argp) {
+ case CHAR_REP:
+ node = rts_apply ( node, rts_mkChar ( *(char*)args ) );
+ args += 4;
+ break;
+ case INT_REP:
+ node = rts_apply ( node, rts_mkInt ( *(int*)args ) );
+ args += 4;
+ break;
+ case WORD_REP:
+ node = rts_apply ( node, rts_mkWord ( *(unsigned int*)args ) );
+ args += 4;
+ break;
+ case ADDR_REP:
+ node = rts_apply ( node, rts_mkAddr ( *(void**)args ) );
+ args += 4;
+ break;
+ case STABLE_REP:
+ node = rts_apply ( node, rts_mkStablePtr ( *(int*)args ) );
+ args += 4;
+ break;
+ case FLOAT_REP:
+ node = rts_apply ( node, rts_mkFloat ( *(float*)args ) );
+ args += 4;
+ break;
+ case DOUBLE_REP:
+ node = rts_apply ( node, rts_mkDouble ( *(double*)args ) );
+ args += 8;
+ break;
+ default:
+ barf(
+ "unpackArgsAndCallHaskell_x86_nocallconv: "
+ "unexpected arg type rep");
+ }
+ argp++;
+ }
+
+ node = rts_apply (
+ asmClosureOfObject(getHugs_AsmObject_for("primRunST")),
+ node );
+
+ sstat = rts_eval ( node, &nodeOut );
+ if (sstat != Success)
+ barf ("unpackArgsAndCallHaskell_x86_nocallconv: eval failed");
+
+ return nodeOut;
+}
+
+
+static
+double
+unpackArgsAndCallHaskell_x86_nocallconv_DOUBLE (
+ StgStablePtr stableptr, char* tydesc, char* args
+ )
+{
+ HaskellObj nodeOut
+ = unpackArgsAndCallHaskell_x86_nocallconv_wrk (
+ stableptr, tydesc, args
+ );
+ /* Return a double. This return will go into %st(0), which
+ is unmodified by the adjustor thunk.
+ */
+ ASSERT(tydesc[0] == DOUBLE_REP);
+ return rts_getDouble(nodeOut);
+}
+
+
+static
+float
+unpackArgsAndCallHaskell_x86_nocallconv_FLOAT (
+ StgStablePtr stableptr, char* tydesc, char* args
+ )
+{
+ HaskellObj nodeOut
+ = unpackArgsAndCallHaskell_x86_nocallconv_wrk (
+ stableptr, tydesc, args
+ );
+ /* Probably could be merged with the double case, since %st(0) is
+ still the return register.
+ */
+ ASSERT(tydesc[0] == FLOAT_REP);
+ return rts_getFloat(nodeOut);
+}
+
+
+static
+unsigned long
+unpackArgsAndCallHaskell_x86_nocallconv_INTISH (
+ StgStablePtr stableptr, char* tydesc, char* args
+ )
+{
+ HaskellObj 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
+ (C-world) caller without modifying %eax or %edx, so the
+ original caller will be a Happy Bunny.
+ */
+ switch (*tydesc) {
+ case ':': return 0;
+ case CHAR_REP: return (unsigned long)rts_getChar(nodeOut);
+ case INT_REP: return (unsigned long)rts_getInt(nodeOut);
+ case WORD_REP: return (unsigned long)rts_getWord(nodeOut);
+ case ADDR_REP: return (unsigned long)rts_getAddr(nodeOut);
+ case STABLE_REP: return (unsigned long)rts_getStablePtr(nodeOut);
+ default:
+ barf(
+ "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 ( StgStablePtr stableptr,
+ StgAddr typestr,
+ char callconv )
+{
+ unsigned char* codeblock;
+ unsigned char* cp;
+ 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_nocallconv_DOUBLE;
+ else if (((char*)typestr)[0] == FLOAT_REP)
+ ch = (unsigned int)
+ &unpackArgsAndCallHaskell_x86_nocallconv_FLOAT;
+ else
+ 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;
+ /*
+ 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 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;
+ *cp++ = 0x57;
+ *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;
+
+ /* call address needs to be: displacement relative to next insn */
+ ch = ch - ( ((unsigned int)cp) + 5);
+ *cp++ = 0xE8; *cp++=ch;ch>>=8; *cp++=ch;ch>>=8; *cp++=ch;ch>>=8; *cp++=ch;
+
+ *cp++ = 0x89; *cp++ = 0xDC;
+ *cp++ = 0x5D;
+ *cp++ = 0x5F;
+ *cp++ = 0x5E;
+ *cp++ = 0x59;
+ *cp++ = 0x5B;
+ *cp++ = 0xC2; *cp++=nwords;nwords>>=8; *cp++=nwords;
+
+ return codeblock;
+}
+
+
+/* ----------------------------------------------------------------*
+ * The only function involved in foreign-export that needs to be
+ * visible outside this file.
+ * ----------------------------------------------------------------*/
+
+StgAddr createAdjThunk ( StgStablePtr stableptr,
+ StgAddr typestr,
+ StgChar callconv )
+{
+ return
+#if i386_TARGET_ARCH
+ createAdjThunk_x86 ( stableptr, typestr, callconv );
+#else
+ 0;
+ #warn foreign export not implemented on this architecture
+#endif