NCG support for f.e.d. stdcall -- Literal.MachLabels now optionally carry
the size (in bytes) of the stack frame it expects, if known. That just
so happens to match what stdcall labels need to be annotated with when
emitting them in the NCG..
-- string argument is the name of a symbol. This literal
-- refers to the *address* of the label.
| MachLabel FastString -- always an Addr#
-- string argument is the name of a symbol. This literal
-- refers to the *address* of the label.
| MachLabel FastString -- always an Addr#
+ (Maybe Int) -- the size (in bytes) of the arguments
+ -- the label expects. Only applicable with
+ -- 'stdcall' labels.
+ -- Just x => "@<x>" will be appended to label
+ -- name when emitting asm.
-- lit-lits only work for via-C compilation, hence they
-- are deprecated. The string is emitted verbatim into
-- lit-lits only work for via-C compilation, hence they
-- are deprecated. The string is emitted verbatim into
put_ bh (MachWord64 ag) = do putByte bh 6; put_ bh ag
put_ bh (MachFloat ah) = do putByte bh 7; put_ bh ah
put_ bh (MachDouble ai) = do putByte bh 8; put_ bh ai
put_ bh (MachWord64 ag) = do putByte bh 6; put_ bh ag
put_ bh (MachFloat ah) = do putByte bh 7; put_ bh ah
put_ bh (MachDouble ai) = do putByte bh 8; put_ bh ai
- put_ bh (MachLabel aj) = do putByte bh 9; put_ bh aj
+ put_ bh (MachLabel aj mb) = do putByte bh 9; put_ bh aj ; put_ bh mb
put_ bh (MachLitLit ak _) = do putByte bh 10; put_ bh ak
get bh = do
h <- getByte bh
put_ bh (MachLitLit ak _) = do putByte bh 10; put_ bh ak
get bh = do
h <- getByte bh
return (MachDouble ai)
9 -> do
aj <- get bh
return (MachDouble ai)
9 -> do
aj <- get bh
+ mb <- get bh
+ return (MachLabel aj mb)
10 -> do
ak <- get bh
return (MachLitLit ak (error "MachLitLit: no type"))
10 -> do
ak <- get bh
return (MachLitLit ak (error "MachLitLit: no type"))
literalType (MachWord64 _) = word64PrimTy
literalType (MachFloat _) = floatPrimTy
literalType (MachDouble _) = doublePrimTy
literalType (MachWord64 _) = word64PrimTy
literalType (MachFloat _) = floatPrimTy
literalType (MachDouble _) = doublePrimTy
-literalType (MachLabel _) = addrPrimTy
+literalType (MachLabel _ _) = addrPrimTy
literalType (MachLitLit _ ty) = ty
\end{code}
literalType (MachLitLit _ ty) = ty
\end{code}
literalPrimRep (MachWord64 _) = Word64Rep
literalPrimRep (MachFloat _) = FloatRep
literalPrimRep (MachDouble _) = DoubleRep
literalPrimRep (MachWord64 _) = Word64Rep
literalPrimRep (MachFloat _) = FloatRep
literalPrimRep (MachDouble _) = DoubleRep
-literalPrimRep (MachLabel _) = AddrRep
+literalPrimRep (MachLabel _ _) = AddrRep
literalPrimRep (MachLitLit _ ty) = typePrimRep ty
\end{code}
literalPrimRep (MachLitLit _ ty) = typePrimRep ty
\end{code}
cmpLit (MachWord64 a) (MachWord64 b) = a `compare` b
cmpLit (MachFloat a) (MachFloat b) = a `compare` b
cmpLit (MachDouble a) (MachDouble b) = a `compare` b
cmpLit (MachWord64 a) (MachWord64 b) = a `compare` b
cmpLit (MachFloat a) (MachFloat b) = a `compare` b
cmpLit (MachDouble a) (MachDouble b) = a `compare` b
-cmpLit (MachLabel a) (MachLabel b) = a `compare` b
+cmpLit (MachLabel a _) (MachLabel b _) = a `compare` b
cmpLit (MachLitLit a b) (MachLitLit c d) = (a `compare` c) `thenCmp` (b `tcCmpType` d)
cmpLit lit1 lit2 | litTag lit1 <# litTag lit2 = LT
| otherwise = GT
cmpLit (MachLitLit a b) (MachLitLit c d) = (a `compare` c) `thenCmp` (b `tcCmpType` d)
cmpLit lit1 lit2 | litTag lit1 <# litTag lit2 = LT
| otherwise = GT
litTag (MachWord64 _) = _ILIT(7)
litTag (MachFloat _) = _ILIT(8)
litTag (MachDouble _) = _ILIT(9)
litTag (MachWord64 _) = _ILIT(7)
litTag (MachFloat _) = _ILIT(8)
litTag (MachDouble _) = _ILIT(9)
-litTag (MachLabel _) = _ILIT(10)
-litTag (MachLitLit _ _) = _ILIT(11)
+litTag (MachLabel _ _) = _ILIT(10)
+litTag (MachLitLit _ _) = _ILIT(11)
MachAddr p | code_style -> ptext SLIT("(void*)") <> integer p
| otherwise -> ptext SLIT("__addr") <+> integer p
MachAddr p | code_style -> ptext SLIT("(void*)") <> integer p
| otherwise -> ptext SLIT("__addr") <+> integer p
- MachLabel l | code_style -> ptext SLIT("(&") <> ftext l <> char ')'
- | otherwise -> ptext SLIT("__label") <+> pprHsString l
+ MachLabel l mb
+ | code_style -> ptext SLIT("(&") <> ftext l <> char ')'
+ | otherwise -> ptext SLIT("__label") <+>
+ case mb of
+ Nothing -> pprHsString l
+ Just x -> doubleQuotes (text (unpackFS l ++ '@':show x))
MachLitLit s ty | code_style -> ftext s
| otherwise -> parens (hsep [ptext SLIT("__litlit"),
MachLitLit s ty | code_style -> ftext s
| otherwise -> parens (hsep [ptext SLIT("__litlit"),
hashLiteral (MachWord64 i) = hashInteger i
hashLiteral (MachFloat r) = hashRational r
hashLiteral (MachDouble r) = hashRational r
hashLiteral (MachWord64 i) = hashInteger i
hashLiteral (MachFloat r) = hashRational r
hashLiteral (MachDouble r) = hashRational r
-hashLiteral (MachLabel s) = hashFS s
+hashLiteral (MachLabel s _) = hashFS s
hashLiteral (MachLitLit s _) = hashFS s
hashRational :: Rational -> Int
hashLiteral (MachLitLit s _) = hashFS s
hashRational :: Rational -> Int
FCallId (CCall (CCallSpec (StaticTarget nm) _ _)) -> C.External (unpackFS nm) (make_ty (varType v))
FCallId _ -> error "MkExternalCore died: can't handle non-static-C foreign call"
_ -> C.Var (make_var_qid (Var.varName v))
FCallId (CCall (CCallSpec (StaticTarget nm) _ _)) -> C.External (unpackFS nm) (make_ty (varType v))
FCallId _ -> error "MkExternalCore died: can't handle non-static-C foreign call"
_ -> C.Var (make_var_qid (Var.varName v))
-make_exp (Lit (l@(MachLabel s))) = C.External (unpackFS s) (make_ty (literalType l))
+make_exp (Lit (l@(MachLabel s _))) = C.External (unpackFS s) (make_ty (literalType l))
make_exp (Lit l) = C.Lit (make_lit l)
make_exp (App e (Type t)) = C.Appt (make_exp e) (make_ty t)
make_exp (App e1 e2) = C.App (make_exp e1) (make_exp e2)
make_exp (Lit l) = C.Lit (make_lit l)
make_exp (App e (Type t)) = C.Appt (make_exp e) (make_ty t)
make_exp (App e1 e2) = C.App (make_exp e1) (make_exp e2)
import Module ( moduleString )
import Name ( getOccString, NamedThing(..) )
import OccName ( encodeFS )
import Module ( moduleString )
import Name ( getOccString, NamedThing(..) )
import OccName ( encodeFS )
-import Type ( repType, eqType )
+import Type ( repType, eqType, typePrimRep )
import TcType ( Type, mkFunTys, mkForAllTys, mkTyConApp,
mkFunTy, tcSplitTyConApp_maybe,
tcSplitForAllTys, tcSplitFunTys, tcTyConAppArgs,
import TcType ( Type, mkFunTys, mkForAllTys, mkTyConApp,
mkFunTy, tcSplitTyConApp_maybe,
tcSplitForAllTys, tcSplitFunTys, tcTyConAppArgs,
)
import CStrings ( CLabelString )
import TysWiredIn ( unitTy, stablePtrTyCon )
)
import CStrings ( CLabelString )
import TysWiredIn ( unitTy, stablePtrTyCon )
-import TysPrim ( addrPrimTy )
+import TysPrim ( addrPrimTy, mkStablePtrPrimTy, alphaTy )
+import PrimRep ( getPrimRepSizeInBytes )
import PrelNames ( hasKey, ioTyConKey, newStablePtrName, bindIOName )
import BasicTypes ( Activation( NeverActive ) )
import Outputable
import PrelNames ( hasKey, ioTyConKey, newStablePtrName, bindIOName )
import BasicTypes ( Activation( NeverActive ) )
import Outputable
combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f)
(ForeignExport id _ (CExport (CExportStatic ext_nm cconv)) depr loc)
= dsFExport id (idType id)
combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f)
(ForeignExport id _ (CExport (CExportStatic ext_nm cconv)) depr loc)
= dsFExport id (idType id)
- ext_nm cconv False `thenDs` \(h, c) ->
+ ext_nm cconv False `thenDs` \(h, c, _) ->
warnDepr depr loc `thenDs` \_ ->
returnDs (ForeignStubs (h $$ acc_h) (c $$ acc_c) acc_hdrs (id:acc_feb),
acc_f)
warnDepr depr loc `thenDs` \_ ->
returnDs (ForeignStubs (h $$ acc_h) (c $$ acc_c) acc_hdrs (id:acc_feb),
acc_f)
returnDs ([(setImpInline no_hdrs id, rhs)], empty, empty)
where
(resTy, foRhs) = resultWrapper (idType id)
returnDs ([(setImpInline no_hdrs id, rhs)], empty, empty)
where
(resTy, foRhs) = resultWrapper (idType id)
- rhs = foRhs (mkLit (MachLabel cid))
+ rhs = foRhs (mkLit (MachLabel cid Nothing))
dsCImport id (CFunction target) cconv safety no_hdrs
= dsFCall id (CCall (CCallSpec target cconv safety)) no_hdrs
dsCImport id CWrapper cconv _ _
dsCImport id (CFunction target) cconv safety no_hdrs
= dsFCall id (CCall (CCallSpec target cconv safety)) no_hdrs
dsCImport id CWrapper cconv _ _
-- the first argument's stable pointer
-> DsM ( SDoc -- contents of Module_stub.h
, SDoc -- contents of Module_stub.c
-- the first argument's stable pointer
-> DsM ( SDoc -- contents of Module_stub.h
, SDoc -- contents of Module_stub.c
+ , [Type] -- arguments expected by stub function.
)
dsFExport fn_id ty ext_name cconv isDyn
)
dsFExport fn_id ty ext_name cconv isDyn
)
`thenDs` \ (res_ty, -- t
is_IO_res_ty) -> -- Bool
)
`thenDs` \ (res_ty, -- t
is_IO_res_ty) -> -- Bool
- let
- (h_stub, c_stub)
- = mkFExportCBits ext_name
- (if isDyn then Nothing else Just fn_id)
- fe_arg_tys res_ty is_IO_res_ty cconv
- in
- returnDs (h_stub, c_stub)
+ returnDs $
+ mkFExportCBits ext_name
+ (if isDyn then Nothing else Just fn_id)
+ fe_arg_tys res_ty is_IO_res_ty cconv
\end{code}
@foreign export dynamic@ lets you dress up Haskell IO actions
\end{code}
@foreign export dynamic@ lets you dress up Haskell IO actions
-- hack: need to get at the name of the C stub we're about to generate.
fe_nm = mkFastString (moduleString mod_name ++ "_" ++ toCName fe_id)
in
-- hack: need to get at the name of the C stub we're about to generate.
fe_nm = mkFastString (moduleString mod_name ++ "_" ++ toCName fe_id)
in
- dsFExport id export_ty fe_nm cconv True `thenDs` \ (h_code, c_code) ->
+ dsFExport id export_ty fe_nm cconv True `thenDs` \ (h_code, c_code, stub_args) ->
newSysLocalDs arg_ty `thenDs` \ cback ->
dsLookupGlobalId newStablePtrName `thenDs` \ newStablePtrId ->
let
newSysLocalDs arg_ty `thenDs` \ cback ->
dsLookupGlobalId newStablePtrName `thenDs` \ newStablePtrId ->
let
-}
adj_args = [ mkIntLitInt (ccallConvToInt cconv)
, Var stbl_value
-}
adj_args = [ mkIntLitInt (ccallConvToInt cconv)
, Var stbl_value
- , mkLit (MachLabel fe_nm)
+ , mkLit (MachLabel fe_nm mb_sz_args)
]
-- name of external entry point providing these services.
-- (probably in the RTS.)
adjustor = FSLIT("createAdjustor")
]
-- name of external entry point providing these services.
-- (probably in the RTS.)
adjustor = FSLIT("createAdjustor")
+
+ mb_sz_args =
+ case cconv of
+ StdCallConv -> Just (sum (map (getPrimRepSizeInBytes . typePrimRep) stub_args))
+ _ -> Nothing
in
dsCCall adjustor adj_args PlayRisky False io_res_ty `thenDs` \ ccall_adj ->
-- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
in
dsCCall adjustor adj_args PlayRisky False io_res_ty `thenDs` \ ccall_adj ->
-- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
-> Type
-> Bool -- True <=> returns an IO type
-> CCallConv
-> Type
-> Bool -- True <=> returns an IO type
-> CCallConv
+ -> (SDoc, SDoc, [Type])
mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
- = (header_bits, c_bits)
+ = (header_bits, c_bits, all_arg_tys)
where
-- Create up types and names for the real args
arg_cnames, arg_ctys :: [SDoc]
where
-- Create up types and names for the real args
arg_cnames, arg_ctys :: [SDoc]
-- and also for auxiliary ones; the stable ptr in the dynamic case, and
-- a slot for the dummy return address in the dynamic + ccall case
-- and also for auxiliary ones; the stable ptr in the dynamic case, and
-- a slot for the dummy return address in the dynamic + ccall case
- Nothing -> [(text "the_stableptr", text "StgStablePtr")]
+ Nothing -> [((text "the_stableptr", text "StgStablePtr"), mkStablePtrPrimTy alphaTy)]
other -> []
++
case (maybe_target, cc) of
other -> []
++
case (maybe_target, cc) of
- (Nothing, CCallConv) -> [(text "original_return_addr", text "void*")]
+ (Nothing, CCallConv) -> [((text "original_return_addr", text "void*"), addrPrimTy)]
other -> []
all_cnames_and_ctys :: [(SDoc, SDoc)]
all_cnames_and_ctys
other -> []
all_cnames_and_ctys :: [(SDoc, SDoc)]
all_cnames_and_ctys
- = extra_cnames_and_ctys ++ zip arg_cnames arg_ctys
+ = map fst extra_cnames_and_tys ++ zip arg_cnames arg_ctys
+
+ all_arg_tys
+ = map snd extra_cnames_and_tys ++ arg_htys
-- stuff to do with the return type of the C function
res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes
-- stuff to do with the return type of the C function
res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes
= do st_I1 <- addToSS st_I0 (getName dcon)
return (sizeSS st_I0, (st_i0,st_l0,st_p0,st_I1))
= do st_I1 <- addToSS st_I0 (getName dcon)
return (sizeSS st_I0, (st_i0,st_l0,st_p0,st_I1))
- literal st (MachLabel fs) = litlabel st fs
- literal st (MachWord w) = int st (fromIntegral w)
- literal st (MachInt j) = int st (fromIntegral j)
- literal st (MachFloat r) = float st (fromRational r)
- literal st (MachDouble r) = double st (fromRational r)
- literal st (MachChar c) = int st c
- literal st (MachInt64 ii) = int64 st (fromIntegral ii)
- literal st (MachWord64 ii) = int64 st (fromIntegral ii)
- literal st other = pprPanic "ByteCodeLink.literal" (ppr other)
+ literal st (MachLabel fs _) = litlabel st fs
+ literal st (MachWord w) = int st (fromIntegral w)
+ literal st (MachInt j) = int st (fromIntegral j)
+ literal st (MachFloat r) = float st (fromRational r)
+ literal st (MachDouble r) = double st (fromRational r)
+ literal st (MachChar c) = int st c
+ literal st (MachInt64 ii) = int64 st (fromIntegral ii)
+ literal st (MachWord64 ii) = int64 st (fromIntegral ii)
+ literal st other = pprPanic "ByteCodeLink.literal" (ppr other)
push_alts WordRep = bci_PUSH_ALTS_N
push_alts WordRep = bci_PUSH_ALTS_N
pushAtom d p (AnnLit lit)
= case lit of
pushAtom d p (AnnLit lit)
= case lit of
- MachLabel fs -> code CodePtrRep
- MachWord w -> code WordRep
- MachInt i -> code IntRep
- MachFloat r -> code FloatRep
- MachDouble r -> code DoubleRep
- MachChar c -> code CharRep
- MachStr s -> pushStr s
+ MachLabel fs _ -> code CodePtrRep
+ MachWord w -> code WordRep
+ MachInt i -> code IntRep
+ MachFloat r -> code FloatRep
+ MachDouble r -> code DoubleRep
+ MachChar c -> code CharRep
+ MachStr s -> pushStr s
where
code rep
= let size_host_words = getPrimRepSize rep
where
code rep
= let size_host_words = getPrimRepSize rep
pushLit env (MachDouble f) = text "ldc.r8" <+> rational f
pushLit env (MachLitLit _ _) = trace "WARNING: Cannot compile MachLitLit to ILX in IlxGen.lhs" (text "// MachLitLit!!! Not valid in ILX!!")
pushLit env (MachAddr w) = text "ldc.i4" <+> integer w <+> text "conv.i"
pushLit env (MachDouble f) = text "ldc.r8" <+> rational f
pushLit env (MachLitLit _ _) = trace "WARNING: Cannot compile MachLitLit to ILX in IlxGen.lhs" (text "// MachLitLit!!! Not valid in ILX!!")
pushLit env (MachAddr w) = text "ldc.i4" <+> integer w <+> text "conv.i"
-pushLit env (MachLabel l) = trace "WARNING: Cannot compile MachLabel to ILX in IlxGen.lhs" (text "// MachLabel!!! Not valid in ILX!!")
+pushLit env (MachLabel l _) = trace "WARNING: Cannot compile MachLabel to ILX in IlxGen.lhs" (text "// MachLabel!!! Not valid in ILX!!")
pprIlxTopVar env v
| isExternalName n = (nameReference env n) <> pprId (nameModule n) <> text "::" <> singleQuotes (ppr (nameModule n) <> text "_" <> ppr (nameOccName n))
pprIlxTopVar env v
| isExternalName n = (nameReference env n) <> pprId (nameModule n) <> text "::" <> singleQuotes (ppr (nameModule n) <> text "_" <> ppr (nameOccName n))
CCallConv(..), playSafe, playThreadSafe )
import Outputable
import Util ( notNull )
CCallConv(..), playSafe, playThreadSafe )
import Outputable
import Util ( notNull )
import FastTypes
#include "NCG.h"
import FastTypes
#include "NCG.h"
MachInt i -> StInt i
MachWord w -> case word2IntLit core of MachInt iw -> StInt iw
MachLitLit s _ -> litLitErr
MachInt i -> StInt i
MachWord w -> case word2IntLit core of MachInt iw -> StInt iw
MachLitLit s _ -> litLitErr
- MachLabel l -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
+ -- dreadful, but rare.
+ MachLabel l (Just x) -> StCLbl (mkForeignLabel (mkFastString (unpackFS l ++ '@':show x)) False)
+ MachLabel l _ -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
MachFloat d -> StFloat d
MachDouble d -> StDouble d
_ -> panic "amodeToStix:core literal"
MachFloat d -> StFloat d
MachDouble d -> StDouble d
_ -> panic "amodeToStix:core literal"
-- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well
-- as ft -> IO Addr is accepted, too. The use of the latter two forms
-- is DEPRECATED, though.
-- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well
-- as ft -> IO Addr is accepted, too. The use of the latter two forms
-- is DEPRECATED, though.
- checkCg (if cconv == StdCallConv
- then checkC
- else checkCOrAsmOrInterp) `thenM_`
- -- the native code gen can't handle foreign import stdcall "wrapper",
- -- because it doesn't emit the '@n' suffix on the label of the
- -- C stub function. Infrastructure changes are required to make this
- -- happen; MachLabel will need to carry around information about
- -- the arity of the foreign call.
+ checkCg checkCOrAsmOrInterp `thenM_`
case arg_tys of
[arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys `thenM_`
checkForeignRes nonIOok isFFIExportResultTy res1_ty `thenM_`
case arg_tys of
[arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys `thenM_`
checkForeignRes nonIOok isFFIExportResultTy res1_ty `thenM_`