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}
......@@ -25,6 +25,7 @@ import PprCore ( pprCoreExpr )
import Literal ( Literal(..), literalPrimRep )
import PrimRep ( PrimRep(..) )
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") (
schemeT d s p (head args_r_to_l)
&& ( (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,11 +590,38 @@ schemeT d s p app
do_pushery d []
-- CCALL !
| Just (CCall (CCallSpec (StaticTarget target)
cconv safety)) <- isFCallId_maybe fn
| Just (CCall ccall_spec) <- isFCallId_maybe fn
= generateCCall d s fn ccall_spec
| otherwise
= case maybe_dcon of
Just con -> PACK con narg_words `consOL` (
mkSLIDE 1 (d - narg_words - s) `snocOL` ENTER)
Nothing
-> let (push, arg_words) = pushAtom True d p (AnnVar fn)
in push
`appOL` mkSLIDE (narg_words+arg_words)
(d - s - narg_words)
`snocOL` ENTER
{- 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, r_rep) = getCCallPrimReps (idType fn)
tys_str = showSDoc (ppr (a_reps, r_rep))
(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
......@@ -616,33 +658,56 @@ schemeT d s p app
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
(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# -> A# a#
Nothing -> panic ("interpreted ccall: can't resolve: "
++ unpacked)
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 = 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
(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 = 1{-tag-} + r_usizeW
push_r = toOL [PUSH_UBX (Left r_lit) r_usizeW,
PUSH_TAG r_usizeW]
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)
wrapup = mkSLIDE r_tsizeW (d_after_r - r_tsizeW - s)
`snocOL` RETURN r_rep
-- generate the marshalling code we're going to call
......@@ -652,32 +717,17 @@ schemeT d s p app
args_offW = map (arg1_offW +)
(init (scanl (+) 0 (map taggedSizeW a_reps)))
addr_of_marshaller
= mkMarshalCode (r_offW, r_rep) addr_offW
= mkMarshalCode cconv
(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)
push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
--)
| otherwise
= case maybe_dcon of
Just con -> PACK con narg_words `consOL` (
mkSLIDE 1 (d - narg_words - s) `snocOL` ENTER)
Nothing
-> let (push, arg_words) = pushAtom True d p (AnnVar fn)
in push
`appOL` mkSLIDE (narg_words+arg_words)
(d - s - narg_words)
`snocOL` ENTER
mkSLIDE n d
= if d == 0 then nilOL else unitOL (SLIDE n d)
bind x f
= f x
-- 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
&& 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
a_reps_to_go = init a_reps
r_rep_to_go = r_reps !! 1
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,7 +283,8 @@ 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:"))
......
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