Commit 0632467a authored by sewardj's avatar sewardj

[project @ 2001-08-07 09:16:15 by sewardj]

This buffer is for notes you don't want to save, and for Lisp evaluation.
If you want to create a file, visit that file with C-x C-f,
then enter the text in that file's own buffer.

Interpreter FFI improvements:

* Support f-i dynamic.
* Correctly handle fns which don't return anything.
* Support x86 stdcall call-conv.

Clean-up of FFI-related code in ByteCodeGen.lhs.
parent 2b8f3628
......@@ -10,6 +10,7 @@ module ByteCodeFFI ( taggedSizeW, untaggedSizeW, mkMarshalCode ) where
import Outputable
import PrimRep ( PrimRep(..), getPrimRepSize, isFollowableRep )
import ForeignCall ( CCallConv(..) )
import Bits ( Bits(..), shiftR )
import Word ( Word8, Word32 )
import Addr ( Addr(..), writeWord8OffAddr )
......@@ -62,6 +63,9 @@ sendBytesToMallocville bytes
\begin{code}
-- For sparc_TARGET_ARCH, i386_TARGET_ARCH, etc.
#include "nativeGen/NCG.h"
{-
Make a piece of code which expects to see the Haskell stack
looking like this. It is given a pointer to the lowest word in
......@@ -72,18 +76,29 @@ the stack -- presumably the tag of the placeholder.
<arg_1>
Addr# address_of_C_fn
<placeholder-for-result#> (must be an unboxed type)
We cope with both ccall and stdcall for the C fn. However, this code
itself expects only to be called using the ccall convention -- that is,
we don't clear our own (single) arg off the C stack.
-}
mkMarshalCode :: (Int, PrimRep) -> Int -> [(Int, PrimRep)]
mkMarshalCode :: CCallConv
-> (Int, PrimRep) -> Int -> [(Int, PrimRep)]
-> Addr
mkMarshalCode (r_offW, r_rep) addr_offW arg_offs_n_reps
= let bytes = mkMarshalCode_wrk (r_offW, r_rep)
mkMarshalCode cconv (r_offW, r_rep) addr_offW arg_offs_n_reps
= let bytes = mkMarshalCode_wrk cconv (r_offW, r_rep)
addr_offW arg_offs_n_reps
in unsafePerformIO (sendBytesToMallocville bytes)
mkMarshalCode_wrk :: (Int, PrimRep) -> Int -> [(Int, PrimRep)]
mkMarshalCode_wrk :: CCallConv
-> (Int, PrimRep) -> Int -> [(Int, PrimRep)]
-> [Word8]
mkMarshalCode_wrk (r_offW, r_rep) addr_offW arg_offs_n_reps
#if i386_TARGET_ARCH
mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps
= let -- Don't change this without first consulting Intel Corp :-)
bytes_per_word = 4
......@@ -218,7 +233,9 @@ mkMarshalCode_wrk (r_offW, r_rep) addr_offW arg_offs_n_reps
addl $4*number_of_args_pushed, %esp (ccall only)
movl 28+4(%esp), %esi
-}
++ add_lit_esp (bytes_per_word * length offsets_to_pushW)
++ (if cconv /= StdCallConv
then add_lit_esp (bytes_per_word * length offsets_to_pushW)
else [])
++ movl_offespmem_esi 32
{- Depending on what the return type is, get the result
......@@ -239,6 +256,7 @@ mkMarshalCode_wrk (r_offW, r_rep) addr_offW arg_offs_n_reps
AddrRep -> movl_eax_offesimem 4
DoubleRep -> fstl_offesimem 4
FloatRep -> fsts_offesimem 4
VoidRep -> []
other -> pprPanic "ByteCodeFFI.mkMarshalCode_wrk(x86)" (ppr r_rep)
{- Restore all the pushed regs and go home.
......@@ -256,5 +274,8 @@ mkMarshalCode_wrk (r_offW, r_rep) addr_offW arg_offs_n_reps
++ restore_regs
++ ret
)
#endif /* i386_TARGET_ARCH */
\end{code}
......@@ -24,7 +24,8 @@ import CoreSyn
import PprCore ( pprCoreExpr )
import Literal ( Literal(..), literalPrimRep )
import PrimRep ( PrimRep(..) )
import PrimOp ( PrimOp(..) )
import PrimOp ( PrimOp(..) )
import CStrings ( CLabelString )
import CoreFVs ( freeVars )
import Type ( typePrimRep, splitTyConApp_maybe, isTyVarTy, splitForAllTys )
import DataCon ( dataConTag, fIRST_TAG, dataConTyCon,
......@@ -365,12 +366,22 @@ schemeE d s p (fvs_case, AnnCase (fvs_scrut, scrut) bndr
as
case .... of a -> ...
Use a as the name of the binder too.
Also case .... of (# a #) -> ...
to
case .... of a -> ...
-}
schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)])
| isUnboxedTupleCon dc && VoidRep == typePrimRep (idType bind1)
= trace "automagic mashing of case alts (# VoidRep, a #)" (
= --trace "automagic mashing of case alts (# VoidRep, a #)" (
schemeE d s p (fvs, AnnCase scrut bind2 [(DEFAULT, [bind2], rhs)])
)
--)
schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)])
| isUnboxedTupleCon dc
= --trace "automagic mashing of case alts (# a #)" (
schemeE d s p (fvs, AnnCase scrut bind1 [(DEFAULT, [bind1], rhs)])
--)
schemeE d s p (fvs, AnnCase scrut bndr alts)
= let
......@@ -467,7 +478,8 @@ schemeE d s p other
--
-- 2. (Another nasty hack). Spot (# a::VoidRep, b #) and treat
-- it simply as b -- since the representations are identical
-- (the VoidRep takes up zero stack space).
-- (the VoidRep takes up zero stack space). Also, spot
-- (# b #) and treat it as b.
--
-- 3. Application of a non-nullary constructor, by defn saturated.
-- Split the args into ptrs and non-ptrs, and push the nonptrs,
......@@ -508,11 +520,14 @@ schemeT d s p app
| let isVoidRepAtom (_, AnnVar v) = VoidRep == typePrimRep (idType v)
isVoidRepAtom (_, AnnNote n e) = isVoidRepAtom e
in is_con_call && isUnboxedTupleCon con
&& length args_r_to_l == 2
&& isVoidRepAtom (last (args_r_to_l))
= trace ("schemeT: unboxed pair with Void first component") (
&& ( (length args_r_to_l == 2 && isVoidRepAtom (last (args_r_to_l)))
|| (length args_r_to_l == 1)
)
= --trace (if length args_r_to_l == 1
-- then "schemeT: unboxed singleton"
-- else "schemeT: unboxed pair with Void first component") (
schemeT d s p (head args_r_to_l)
)
--)
-- Cases 3 and 4
| otherwise
......@@ -575,91 +590,8 @@ schemeT d s p app
do_pushery d []
-- CCALL !
| Just (CCall (CCallSpec (StaticTarget target)
cconv safety)) <- isFCallId_maybe fn
= let -- Get the arg and result reps.
(a_reps, r_rep) = getCCallPrimReps (idType fn)
tys_str = showSDoc (ppr (a_reps, r_rep))
{-
Because the Haskell stack grows down, the a_reps refer to
lowest to highest addresses in that order. The args for the call
are on the stack. Now push an unboxed, tagged Addr# indicating
the C function to call. Then push a dummy placeholder for the
result. Finally, emit a CCALL insn with an offset pointing to the
Addr# just pushed, and a literal field holding the mallocville
address of the piece of marshalling code we generate.
So, just prior to the CCALL insn, the stack looks like this
(growing down, as usual):
<arg_n>
...
<arg_1>
Addr# address_of_C_fn
<placeholder-for-result#> (must be an unboxed type)
The interpreter then calls the marshall code mentioned
in the CCALL insn, passing it (& <placeholder-for-result#>),
that is, the addr of the topmost word in the stack.
When this returns, the placeholder will have been
filled in. The placeholder is slid down to the sequel
depth, and we RETURN.
This arrangement makes it simple to do f-i-dynamic since the Addr#
value is the first arg anyway. It also has the virtue that the
stack is GC-understandable at all times.
The marshalling code is generated specifically for this
call site, and so knows exactly the (Haskell) stack
offsets of the args, fn address and placeholder. It
copies the args to the C stack, calls the stacked addr,
and parks the result back in the placeholder. The interpreter
calls it as a normal C call, assuming it has a signature
void marshall_code ( StgWord* ptr_to_top_of_stack )
-}
-- resolve static address
target_addr
= let unpacked = _UNPK_ target
in case unsafePerformIO (lookupSymbol unpacked) of
Just aa -> case aa of Ptr a# -> A# a#
Nothing -> panic ("interpreted ccall: can't resolve: "
++ unpacked)
-- push the Addr#
addr_usizeW = untaggedSizeW AddrRep
addr_tsizeW = taggedSizeW AddrRep
push_Addr = toOL [PUSH_UBX (Right target_addr) addr_usizeW,
PUSH_TAG addr_usizeW]
d_after_Addr = d + addr_tsizeW
-- push the return placeholder
r_lit = mkDummyLiteral r_rep
r_usizeW = untaggedSizeW r_rep
r_tsizeW = 1{-tag-} + r_usizeW
push_r = toOL [PUSH_UBX (Left r_lit) r_usizeW,
PUSH_TAG r_usizeW]
d_after_r = d_after_Addr + r_tsizeW
-- do the call
do_call = unitOL (CCALL addr_of_marshaller)
-- slide and return
wrapup = mkSLIDE r_tsizeW
(d_after_r - r_tsizeW - s)
`snocOL` RETURN r_rep
-- generate the marshalling code we're going to call
r_offW = 0
addr_offW = r_tsizeW
arg1_offW = r_tsizeW + addr_tsizeW
args_offW = map (arg1_offW +)
(init (scanl (+) 0 (map taggedSizeW a_reps)))
addr_of_marshaller
= mkMarshalCode (r_offW, r_rep) addr_offW
(zip args_offW a_reps)
in
--trace (show (arg1_offW, args_offW , (map taggedSizeW a_reps) )) (
target_addr
`seq`
(push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup)
--)
| Just (CCall ccall_spec) <- isFCallId_maybe fn
= generateCCall d s fn ccall_spec
| otherwise
= case maybe_dcon of
......@@ -672,12 +604,130 @@ schemeT d s p app
(d - s - narg_words)
`snocOL` ENTER
mkSLIDE n d
= if d == 0 then nilOL else unitOL (SLIDE n d)
bind x f
= f x
{- Given that the args for a CCall have been pushed onto the Haskell
stack, generate the marshalling (machine) code for the ccall, and
create bytecodes to call that and then return in the right way.
-}
generateCCall :: Int -> Sequel -- stack and sequel depths
-> Id -- of target, for type info
-> CCallSpec -- where to call
-> BCInstrList
generateCCall d s fn ccall_spec@(CCallSpec target cconv safety)
= let -- Get the arg and result reps.
(a_reps_RAW, maybe_r_rep) = getCCallPrimReps (idType fn)
(returns_void, r_rep)
= case maybe_r_rep of
Nothing -> (True, VoidRep)
Just rr -> (False, rr)
{-
Because the Haskell stack grows down, the a_reps refer to
lowest to highest addresses in that order. The args for the call
are on the stack. Now push an unboxed, tagged Addr# indicating
the C function to call. Then push a dummy placeholder for the
result. Finally, emit a CCALL insn with an offset pointing to the
Addr# just pushed, and a literal field holding the mallocville
address of the piece of marshalling code we generate.
So, just prior to the CCALL insn, the stack looks like this
(growing down, as usual):
<arg_n>
...
<arg_1>
Addr# address_of_C_fn
<placeholder-for-result#> (must be an unboxed type)
The interpreter then calls the marshall code mentioned
in the CCALL insn, passing it (& <placeholder-for-result#>),
that is, the addr of the topmost word in the stack.
When this returns, the placeholder will have been
filled in. The placeholder is slid down to the sequel
depth, and we RETURN.
This arrangement makes it simple to do f-i-dynamic since the Addr#
value is the first arg anyway. It also has the virtue that the
stack is GC-understandable at all times.
The marshalling code is generated specifically for this
call site, and so knows exactly the (Haskell) stack
offsets of the args, fn address and placeholder. It
copies the args to the C stack, calls the stacked addr,
and parks the result back in the placeholder. The interpreter
calls it as a normal C call, assuming it has a signature
void marshall_code ( StgWord* ptr_to_top_of_stack )
-}
-- resolve static address
(is_static, static_target_addr)
= case target of
DynamicTarget
-> (False, panic "ByteCodeGen.generateCCall(dyn)")
StaticTarget target
-> let unpacked = _UNPK_ target
in case unsafePerformIO (lookupSymbol unpacked) of
Just aa -> case aa of Ptr a# -> (True, A# a#)
Nothing -> invalid
CasmTarget _
-> invalid
where
invalid = pprPanic ("ByteCodeGen.generateCCall: unfindable "
++ "symbol or otherwise invalid target")
(ppr ccall_spec)
-- Get the arg reps, zapping the leading Addr# in the dynamic case
a_reps | is_static = a_reps_RAW
| otherwise = if null a_reps_RAW
then panic "ByteCodeGen.generateCCall: dyn with no args"
else tail a_reps_RAW
-- push the Addr#
addr_usizeW = untaggedSizeW AddrRep
addr_tsizeW = taggedSizeW AddrRep
(push_Addr, d_after_Addr)
| is_static
= (toOL [PUSH_UBX (Right static_target_addr) addr_usizeW,
PUSH_TAG addr_usizeW],
d + addr_tsizeW)
| otherwise -- is already on the stack
= (nilOL, d)
-- Push the return placeholder. For a call returning nothing,
-- this is a VoidRep (tag).
r_usizeW = untaggedSizeW r_rep
r_tsizeW = taggedSizeW r_rep
d_after_r = d_after_Addr + r_tsizeW
r_lit = mkDummyLiteral r_rep
push_r = (if returns_void
then nilOL
else unitOL (PUSH_UBX (Left r_lit) r_usizeW))
`appOL`
unitOL (PUSH_TAG r_usizeW)
-- do the call
do_call = unitOL (CCALL addr_of_marshaller)
-- slide and return
wrapup = mkSLIDE r_tsizeW (d_after_r - r_tsizeW - s)
`snocOL` RETURN r_rep
-- generate the marshalling code we're going to call
r_offW = 0
addr_offW = r_tsizeW
arg1_offW = r_tsizeW + addr_tsizeW
args_offW = map (arg1_offW +)
(init (scanl (+) 0 (map taggedSizeW a_reps)))
addr_of_marshaller
= mkMarshalCode cconv
(r_offW, r_rep) addr_offW
(zip args_offW a_reps)
in
--trace (show (arg1_offW, args_offW , (map taggedSizeW a_reps) )) (
push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
--)
-- Make a dummy literal, to be used as a placeholder for FFI return
-- values on the stack.
mkDummyLiteral :: PrimRep -> Literal
mkDummyLiteral pr
= case pr of
......@@ -692,31 +742,44 @@ mkDummyLiteral pr
-- PrelGHC.Int# -> PrelGHC.State# PrelGHC.RealWorld
-- -> (# PrelGHC.State# PrelGHC.RealWorld, PrelGHC.Int# #)
--
-- to [IntRep] -> IntRep
-- to [IntRep] -> Just IntRep
-- and check that the last arg is VoidRep'd and that an unboxed pair is
-- returned wherein the first arg is VoidRep'd.
--
-- Alternatively, for call-targets returning nothing, convert
--
-- PrelGHC.Int# -> PrelGHC.State# PrelGHC.RealWorld
-- -> (# PrelGHC.State# PrelGHC.RealWorld, PrelGHC.Int# #)
--
-- to [IntRep] -> Nothing
getCCallPrimReps :: Type -> ([PrimRep], PrimRep)
getCCallPrimReps :: Type -> ([PrimRep], Maybe PrimRep)
getCCallPrimReps fn_ty
= let (a_tys, r_ty) = splitRepFunTys fn_ty
a_reps = map typePrimRep a_tys
a_reps_to_go = init a_reps
maybe_r_rep_to_go
= if length r_reps == 1 then Nothing else Just (r_reps !! 1)
(r_tycon, r_reps)
= case splitTyConApp_maybe (repType r_ty) of
(Just (tyc, tys)) -> (tyc, map typePrimRep tys)
Nothing -> blargh
ok = length a_reps >= 1 && VoidRep == last a_reps
&& length r_reps == 2 && VoidRep == head r_reps
&& ( (length r_reps == 2 && VoidRep == head r_reps)
|| r_reps == [VoidRep] )
&& isUnboxedTupleTyCon r_tycon
&& PtrRep /= r_rep_to_go -- if it was, it would be impossible
-- to create a valid return value
-- placeholder on the stack
a_reps_to_go = init a_reps
r_rep_to_go = r_reps !! 1
&& case maybe_r_rep_to_go of
Nothing -> True
Just r_rep -> r_rep /= PtrRep
-- if it was, it would be impossible
-- to create a valid return value
-- placeholder on the stack
blargh = pprPanic "getCCallPrimReps: can't handle:"
(pprType fn_ty)
in
--trace (showSDoc (ppr (a_reps, r_reps))) (
if ok then (a_reps_to_go, r_rep_to_go) else blargh
if ok then (a_reps_to_go, maybe_r_rep_to_go) else blargh
--)
atomRep (AnnVar v) = typePrimRep (idType v)
......@@ -1105,6 +1168,10 @@ unboxedTupleException
"\tto foreign import/export decls in source. Workaround:\n" ++
"\tcompile this module to a .o file, then restart session."))
mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d)
bind x f = f x
\end{code}
%************************************************************************
......
......@@ -113,7 +113,7 @@ tcCheckFIType sig_ty arg_tys res_ty (CDynImport _)
tcCheckFIType sig_ty arg_tys res_ty (CImport (CCallSpec target _ safety))
| isDynamicTarget target -- Foreign import dynamic
= checkCg checkCOrAsm `thenNF_Tc_`
= checkCg checkCOrAsmOrInterp `thenNF_Tc_`
case arg_tys of -- The first arg must be Addr
[] -> check False (illegalForeignTyErr empty sig_ty)
(arg1_ty:arg_tys) -> getDOptsTc `thenNF_Tc` \ dflags ->
......@@ -237,12 +237,20 @@ checkC other = Just (text "requires C code generation (-fvia-C)")
checkCOrAsm HscC = Nothing
checkCOrAsm HscAsm = Nothing
checkCOrAsm other = Just (text "via-C or native code generation (-fvia-C)")
checkCOrAsm other
= Just (text "requires via-C or native code generation (-fvia-C)")
checkCOrAsmOrInterp HscC = Nothing
checkCOrAsmOrInterp HscAsm = Nothing
checkCOrAsmOrInterp HscInterpreted = Nothing
checkCOrAsmOrInterp other
= Just (text "requires interpreted, C or native code generation")
checkCOrAsmOrDotNet HscC = Nothing
checkCOrAsmOrDotNet HscAsm = Nothing
checkCOrAsmOrDotNet HscILX = Nothing
checkCOrAsmOrDotNet other = Just (text "requires C, native or .NET ILX code generation")
checkCOrAsmOrDotNet other
= Just (text "requires C, native or .NET ILX code generation")
checkCOrAsmOrDotNetOrInterp HscC = Nothing
checkCOrAsmOrDotNetOrInterp HscAsm = Nothing
......@@ -266,7 +274,8 @@ check True _ = returnTc ()
check _ the_err = addErrTc the_err
illegalForeignTyErr arg_or_res ty
= hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in foreign declaration:")])
= hang (hsep [ptext SLIT("Unacceptable"), arg_or_res,
ptext SLIT("type in foreign declaration:")])
4 (hsep [ppr ty])
-- Used for 'arg_or_res' argument to illegalForeignTyErr
......@@ -274,9 +283,10 @@ argument = text "argument"
result = text "result"
badCName :: CLabelString -> Message
badCName target = sep [quotes (ppr target) <+> ptext SLIT("is not a valid C identifier")]
badCName target
= sep [quotes (ppr target) <+> ptext SLIT("is not a valid C identifier")]
foreignDeclCtxt fo
= hang (ptext SLIT("When checking declaration:"))
4 (ppr fo)
4 (ppr fo)
\end{code}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment