%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: AbsCSyn.lhs,v 1.35 2000/10/12 15:17:07 sewardj Exp $
+% $Id: AbsCSyn.lhs,v 1.36 2001/05/22 13:43:14 simonpj Exp $
%
\section[AbstractC]{Abstract C: the last stop before machine code}
mAX_Double_REG, spRelToInt )
import CostCentre ( CostCentre, CostCentreStack )
import Literal ( mkMachInt, Literal(..) )
+import ForeignCall ( CCallSpec )
import PrimRep ( PrimRep(..) )
-import PrimOp ( PrimOp, CCall )
import Unique ( Unique )
-import StgSyn ( SRT(..) )
+import StgSyn ( StgOp, SRT(..) )
import TyCon ( TyCon )
import BitSet -- for liveness masks
import FastTypes
| COpStmt
[CAddrMode] -- Results
- PrimOp
+ StgOp
[CAddrMode] -- Arguments
[MagicId] -- Potentially volatile/live registers
-- (to save/restore around the call/op)
compiling 'foreign import dynamic's)
-}
| CCallTypedef Bool {- True => use "typedef"; False => use "extern"-}
- CCall [CAddrMode] [CAddrMode]
+ CCallSpec Unique [CAddrMode] [CAddrMode]
-- *** the next three [or so...] are DATA (those above are CODE) ***
import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply,
UniqSupply )
import CmdLineOpts ( opt_EmitCExternDecls )
-import PrimOp ( PrimOp(..), CCall(..), isDynamicTarget )
+import ForeignCall ( ForeignCall(..), CCallSpec(..), isDynamicTarget )
+import StgSyn ( StgOp(..) )
import Panic ( panic )
import FastTypes
= flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) ->
returnFlt ( (tag, alt_heres), alt_tops )
-flatAbsC stmt@(COpStmt results (CCallOp ccall@(CCall target is_asm _ _)) args vol_regs)
- | isCandidate
- = returnFlt (stmt, tdef)
- | otherwise
- = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _ is_asm)) uniq) args _)
+ | is_dynamic -- Emit a typedef if its a dynamic call
+ || (opt_EmitCExternDecls && not is_asm) -- or we want extern decls
+ = returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args)
where
- isCandidate = is_dynamic || opt_EmitCExternDecls && not is_asm
- is_dynamic = isDynamicTarget target
-
- tdef = CCallTypedef is_dynamic ccall results args
+ is_dynamic = isDynamicTarget target
flatAbsC stmt@(CSimultaneous abs_c)
= flatAbsC abs_c `thenFlt` \ (stmts_here, tops) ->
| otherwise = returnFlt (stmt, AbsCNop)
-- Some statements need no flattening at all:
-flatAbsC stmt@(CMacroStmt macro amodes) = returnFlt (stmt, AbsCNop)
-flatAbsC stmt@(CCallProfCCMacro str amodes) = returnFlt (stmt, AbsCNop)
-flatAbsC stmt@(CAssign dest source) = returnFlt (stmt, AbsCNop)
-flatAbsC stmt@(CJump target) = returnFlt (stmt, AbsCNop)
-flatAbsC stmt@(CFallThrough target) = returnFlt (stmt, AbsCNop)
-flatAbsC stmt@(CReturn target return_info) = returnFlt (stmt, AbsCNop)
-flatAbsC stmt@(CInitHdr a b cc) = returnFlt (stmt, AbsCNop)
-flatAbsC stmt@(COpStmt results op args vol_regs)= returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(CMacroStmt macro amodes) = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(CCallProfCCMacro str amodes) = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(CAssign dest source) = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(CJump target) = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(CFallThrough target) = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(CReturn target return_info) = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(CInitHdr a b cc) = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(COpStmt results op args vol_regs) = returnFlt (stmt, AbsCNop)
-- Some statements only make sense at the top level, so we always float
-- them. This probably isn't necessary.
= or [dest1 `conflictsWith` src2 | src2 <- srcs2]
(COpStmt dests1 _ _ _) `should_follow` (COpStmt _ _ srcs2 _)
= or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
-
--- (COpStmt _ _ _ _ _) `should_follow` (CCallProfCtrMacro _ _) = False
--- (CCallProfCtrMacro _ _) `should_follow` (COpStmt _ _ _ _ _) = False
-
-
\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[Calling conventions]{External calling conventions}
-
-\begin{code}
-module CallConv
- (
- CallConv
- , pprCallConv
- , callConvToInt
-
- , stdCallConv
- , cCallConv
- , defaultCallConv
- , callConvAttribute
- ) where
-
-#include "HsVersions.h"
-
-import Outputable
-import PrimRep ( PrimRep, getPrimRepSizeInBytes )
-\end{code}
-
-\begin{code}
-type CallConv = Int
-
-pprCallConv :: CallConv -> SDoc
-pprCallConv 0 = ptext SLIT("__stdcall")
-pprCallConv _ = ptext SLIT("_ccall")
-
-stdCallConv :: CallConv
-stdCallConv = 0
-
-cCallConv :: CallConv
-cCallConv = 1
-
-defaultCallConv :: CallConv
-defaultCallConv = cCallConv
-
-callConvToInt :: CallConv -> Int
-callConvToInt x = x
-\end{code}
-
-Generate the gcc attribute corresponding to the given
-calling convention (used by PprAbsC):
-
-ToDo: The stdcall calling convention is x86 (win32) specific,
-so perhaps we should emit a warning if it's being used on other
-platforms.
-
-\begin{code}
-callConvAttribute :: CallConv -> String
-callConvAttribute cc
- | cc == stdCallConv = "__stdcall"
- | cc == cCallConv = ""
- | otherwise = panic ("callConvAttribute: cannot handle" ++ showSDoc (pprCallConv cc))
-
-\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: Costs.lhs,v 1.28 2001/01/15 16:55:24 sewardj Exp $
+% $Id: Costs.lhs,v 1.29 2001/05/22 13:43:14 simonpj Exp $
%
% Only needed in a GranSim setup -- HWL
% ---------------------------------------------------------------------------
#include "HsVersions.h"
import AbsCSyn
+import StgSyn ( StgOp(..) )
import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
import Panic ( trace )
mapOp :: (Int -> Int) -> CostRes -> CostRes
mapOp g ( Cost (i, b, l, s, f) ) = Cost (g i, g b, g l, g s, g f)
-foldrOp :: (Int -> a -> a) -> a -> CostRes -> a
-foldrOp o x ( Cost (i1, b1, l1, s1, f1) ) =
- i1 `o` ( b1 `o` ( l1 `o` ( s1 `o` ( f1 `o` x))))
-
binOp :: (Int -> Int -> Int) -> CostRes -> CostRes -> CostRes
binOp o ( Cost (i1, b1, l1, s1, f1) ) ( Cost (i2, b2, l2, s2, f2) ) =
( Cost (i1 `o` i2, b1 `o` b2, l1 `o` l2, s1 `o` s2, f1 `o` f2) )
For costing the args of this macro
see PprAbsC.lhs where args are inserted -}
- COpStmt modes_res primOp modes_args _ ->
+ COpStmt modes_res op modes_args _ ->
{-
let
n = length modes_res
-}
foldl (+) nullCosts [addrModeCosts mode Lhs | mode <- modes_res] +
foldl (+) nullCosts [addrModeCosts mode Rhs | mode <- modes_args] +
- primOpCosts primOp +
- if primOpNeedsWrapper primOp then SAVE_COSTS + RESTORE_COSTS
- else nullCosts
+ opCosts op
CSimultaneous absC -> costs absC
-- *** the next three [or so...] are DATA (those above are CODE) ***
-- as they are data rather than code they all have nullCosts -- HWL
- CCallTypedef _ _ _ _ -> nullCosts
+ CCallTypedef _ _ _ _ _ -> nullCosts
CStaticClosure _ _ _ _ -> nullCosts
_ -> trace ("Costs.costs") nullCosts
+
-- ---------------------------------------------------------------------------
addrModeCosts :: CAddrMode -> Side -> CostRes
rem_costs = Cost (30,15,0,0,0) -- due to spy counts
div_costs = Cost (30,15,0,0,0) -- due to spy counts
-primOpCosts :: PrimOp -> CostRes
--- Special cases
-primOpCosts (CCallOp _) = SAVE_COSTS + RESTORE_COSTS
- -- don't guess costs of ccall proper
- -- for exact costing use a GRAN_EXEC
- -- in the C code
+-- ---------------------------------------------------------------------------
+
+opCosts :: StgOp -> CostRes
--- Usually 3 mov instructions are needed to get args and res in right place.
+opCosts (StgFCallOp _ _) = SAVE_COSTS + RESTORE_COSTS
+ -- Don't guess costs of ccall proper
+ -- for exact costing use a GRAN_EXEC in the C code
+opCosts (StgPrimOp primop)
+ = primOpCosts primop +
+ if primOpNeedsWrapper primop then SAVE_COSTS + RESTORE_COSTS
+ else nullCosts
+
+primOpCosts :: PrimOp -> CostRes
+
+-- Usually 3 mov instructions are needed to get args and res in right place.
primOpCosts IntMulOp = Cost (3, 1, 0, 0, 0) + umul_costs
primOpCosts IntQuotOp = Cost (3, 1, 0, 0, 0) + div_costs
primOpCosts IntRemOp = Cost (3, 1, 0, 0, 0) + rem_costs
| primOp `elem` gmpOps = Cost (30, 5, 10, 10, 0) :: CostRes -- GUESS; check it
| otherwise = Cost (1, 0, 0, 0, 0)
--- ---------------------------------------------------------------------------
-{- HWL: currently unused
-
-costsByKind :: PrimRep -> Side -> CostRes
-
--- The following PrimKinds say that the data is already in a reg
-
-costsByKind CharRep _ = nullCosts
-costsByKind IntRep _ = nullCosts
-costsByKind WordRep _ = nullCosts
-costsByKind AddrRep _ = nullCosts
-costsByKind FloatRep _ = nullCosts
-costsByKind DoubleRep _ = nullCosts
--}
--- ---------------------------------------------------------------------------
\end{code}
)
import Constants ( mIN_UPD_SIZE )
-import CallConv ( callConvAttribute )
+import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe, ccallConvAttribute )
import CLabel ( externallyVisibleCLabel,
needsCDecl, pprCLabel,
mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel,
import Name ( NamedThing(..) )
import DataCon ( dataConWrapId )
import Maybes ( maybeToBool, catMaybes )
-import PrimOp ( primOpNeedsWrapper, pprCCallOp,
- PrimOp(..), CCall(..), CCallTarget(..), isDynamicTarget )
+import PrimOp ( primOpNeedsWrapper )
+import ForeignCall ( ForeignCall(..), isDynamicTarget )
import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize )
import SMRep ( pprSMRep )
import Unique ( pprUnique, Unique{-instance NamedThing-} )
import UniqSet ( emptyUniqSet, elementOfUniqSet,
addOneToUniqSet, UniqSet
)
-import StgSyn ( SRT(..) )
+import StgSyn ( SRT(..), StgOp(..) )
import BitSet ( intBS )
import Outputable
import GlaExts
-- Costs for addressing header of switch and cond. branching -- HWL
switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0))
-pprAbsC stmt@(COpStmt results (CCallOp ccall) args vol_regs) _
- = pprCCall ccall args results vol_regs
+pprAbsC stmt@(COpStmt results (StgFCallOp fcall uniq) args vol_regs) _
+ = pprFCall fcall uniq args results vol_regs
-pprAbsC stmt@(COpStmt results op args vol_regs) _
+pprAbsC stmt@(COpStmt results (StgPrimOp op) args vol_regs) _
= let
non_void_args = grab_non_void_amodes args
non_void_results = grab_non_void_amodes results
pprAbsC (CCallProfCCMacro op as) _
= hcat [ptext op, lparen,
hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
-pprAbsC stmt@(CCallTypedef is_tdef (CCall op_str is_asm may_gc cconv) results args) _
+pprAbsC stmt@(CCallTypedef is_tdef (CCallSpec op_str cconv _ _) uniq results args) _
= hsep [ ptext (if is_tdef then SLIT("typedef") else SLIT("extern"))
, ccall_res_ty
, fun_nm
-}
fun_nm
- | is_tdef = parens (text (callConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
- | otherwise = text (callConvAttribute cconv) <+> ccall_fun_ty
+ | is_tdef = parens (text (ccallConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
+ | otherwise = text (ccallConvAttribute cconv) <+> ccall_fun_ty
ccall_fun_ty =
case op_str of
- DynamicTarget u -> ptext SLIT("_ccall_fun_ty") <> ppr u
- StaticTarget x -> pprCLabelString x
+ DynamicTarget -> ptext SLIT("_ccall_fun_ty") <> ppr uniq
+ StaticTarget x -> pprCLabelString x
ccall_res_ty =
case non_void_results of
that the runtime check that PerformGC is being used sensibly will work.
\begin{code}
-pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs
+pprFCall call@(CCall (CCallSpec op_str cconv safety is_asm)) uniq args results vol_regs
= vcat [
char '{',
declare_local_vars, -- local var for *result*
where
(pp_saves, pp_restores) = ppr_vol_regs vol_regs
(pp_save_context, pp_restore_context)
- | may_gc = ( text "{ I_ id; SUSPEND_THREAD(id);"
- , text "RESUME_THREAD(id);}"
- )
+ | playSafe safety = ( text "{ I_ id; SUSPEND_THREAD(id);"
+ , text "RESUME_THREAD(id);}"
+ )
| otherwise = ( pp_basic_saves $$ pp_saves,
pp_basic_restores $$ pp_restores)
non_void_args =
let nvas = init args
- in ASSERT2 ( all non_void nvas, pprCCallOp call <+> hsep (map pprAmode args) )
+ in ASSERT2 ( all non_void nvas, ppr call <+> hsep (map pprAmode args) )
nvas
-- the last argument will be the "I/O world" token (a VoidRep)
-- all others should be non-void
-- Remainder only used for ccall
fun_name = case op_str of
- DynamicTarget u -> parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr u) <> text "%0")
+ DynamicTarget -> parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr uniq) <> text "%0")
StaticTarget st -> pprCLabelString st
ccall_str = showSDoc
| otherwise = ccall_args
ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
-
\end{code}
If the argument is a heap object, we need to reach inside and pull out
info_lbl = infoTableLabelFromCI cl_info
ppr_decls_AbsC (COpStmt results _ args _) = ppr_decls_Amodes (results ++ args)
-ppr_decls_AbsC (CSimultaneous abc) = ppr_decls_AbsC abc
+ppr_decls_AbsC (CSimultaneous abc) = ppr_decls_AbsC abc
ppr_decls_AbsC (CCheck _ amodes code) =
ppr_decls_Amodes amodes `thenTE` \p1 ->
isSpecPragmaId, isExportedId, isLocalId, isGlobalId,
isRecordSelector,
isPrimOpId, isPrimOpId_maybe,
+ isFCallId, isFCallId_maybe,
isDataConId, isDataConId_maybe,
isDataConWrapId, isDataConWrapId_maybe,
isBottomingId,
PrimOpId op -> Just op
other -> Nothing
+isFCallId id = case globalIdDetails id of
+ FCallId call -> True
+ other -> False
+
+isFCallId_maybe id = case globalIdDetails id of
+ FCallId call -> Just call
+ other -> Nothing
+
isDataConId id = case globalIdDetails id of
DataConId _ -> True
other -> False
hasNoBinding id = case globalIdDetails id of
DataConId _ -> True
PrimOpId _ -> True
+ FCallId _ -> True
other -> False
isImplicitId :: Id -> Bool
isImplicitId id
= case globalIdDetails id of
RecordSelId _ -> True -- Includes dictionary selectors
+ FCallId _ -> True
PrimOpId _ -> True
DataConId _ -> True
DataConWrapId _ -> True
Arity
)
import DataCon ( DataCon )
+import ForeignCall ( ForeignCall )
import FieldLabel ( FieldLabel )
import Type ( usOnce, usMany )
import Demand -- Lots of stuff
-- Id back to the data con]
| PrimOpId PrimOp -- The Id for a primitive operator
+ | FCallId ForeignCall -- The Id for a foreign call
| NotGlobalId -- Used as a convenient extra return value from globalIdDetails
ppr (DataConId _) = ptext SLIT("[DataCon]")
ppr (DataConWrapId _) = ptext SLIT("[DataConWrapper]")
ppr (PrimOpId _) = ptext SLIT("[PrimOp]")
+ ppr (FCallId _) = ptext SLIT("[ForeignCall]")
ppr (RecordSelId _) = ptext SLIT("[RecSel]")
\end{code}
mkDataConId, mkDataConWrapId,
mkRecordSelId, rebuildConArgs,
- mkPrimOpId, mkCCallOpId,
+ mkPrimOpId, mkFCallId,
-- And some particular Ids; see below for why they are wired in
wiredInIds,
import Class ( Class, classTyCon, classTyVars, classSelIds )
import Var ( Id, TyVar )
import VarSet ( isEmptyVarSet )
-import Name ( mkWiredInName, mkCCallName, Name )
+import Name ( mkWiredInName, mkFCallName, Name )
import OccName ( mkVarOcc )
-import PrimOp ( PrimOp(DataToTagOp, CCallOp),
- primOpSig, mkPrimOpIdName,
- CCall, pprCCallOp
- )
+import PrimOp ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName )
+import ForeignCall ( ForeignCall )
import Demand ( wwStrict, wwPrim, mkStrictnessInfo,
StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
import DataCon ( DataCon,
-- details of the ccall, type and all. This means that the interface
-- file reader can reconstruct a suitable Id
-mkCCallOpId :: Unique -> CCall -> Type -> Id
-mkCCallOpId uniq ccall ty
+mkFCallId :: Unique -> ForeignCall -> Type -> Id
+mkFCallId uniq fcall ty
= ASSERT( isEmptyVarSet (tyVarsOfType ty) )
-- A CCallOpId should have no free type variables;
-- when doing substitutions won't substitute over it
- mkGlobalId (PrimOpId prim_op) name ty info
+ mkGlobalId (FCallId fcall) name ty info
where
- occ_str = showSDocIface (braces (pprCCallOp ccall <+> ppr ty))
+ occ_str = showSDocIface (braces (ppr fcall <+> ppr ty))
-- The "occurrence name" of a ccall is the full info about the
-- ccall; it is encoded, but may have embedded spaces etc!
- name = mkCCallName uniq occ_str
- prim_op = CCallOp ccall
+ name = mkFCallName uniq occ_str
info = noCafNoTyGenIdInfo
`setCgArity` arity
-- The Name type
Name, -- Abstract
- mkLocalName, mkSysLocalName, mkCCallName,
+ mkLocalName, mkSysLocalName, mkFCallName,
mkIPName,
mkGlobalName, mkKnownKeyGlobal, mkWiredInName,
mkSysLocalName uniq fs = Name { n_uniq = uniq, n_sort = System,
n_occ = mkVarOcc fs, n_loc = noSrcLoc }
-mkCCallName :: Unique -> EncodedString -> Name
+mkFCallName :: Unique -> EncodedString -> Name
-- The encoded string completely describes the ccall
-mkCCallName uniq str = Name { n_uniq = uniq, n_sort = Local,
- n_occ = mkCCallOcc str, n_loc = noSrcLoc }
+mkFCallName uniq str = Name { n_uniq = uniq, n_sort = Local,
+ n_occ = mkFCallOcc str, n_loc = noSrcLoc }
mkIPName :: Unique -> OccName -> Name
mkIPName uniq occ
OccName, -- Abstract, instance of Outputable
pprOccName,
- mkOccFS, mkSysOcc, mkSysOccFS, mkCCallOcc, mkVarOcc, mkKindOccFS,
+ mkOccFS, mkSysOcc, mkSysOccFS, mkFCallOcc, mkVarOcc, mkKindOccFS,
mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc,
mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc,
mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc,
mkSysOccFS occ_sp fs = ASSERT2( alreadyEncodedFS fs, ppr fs )
OccName occ_sp fs
-mkCCallOcc :: EncodedString -> OccName
+mkFCallOcc :: EncodedString -> OccName
-- This version of mkSysOcc doesn't check that the string is already encoded,
-- because it will be something like "{__ccall f dyn Int# -> Int#}"
-- This encodes a lot into something that then parses like an Id.
-- But then alreadyEncoded complains about the braces!
-mkCCallOcc str = OccName varName (_PK_ str)
+mkFCallOcc str = OccName varName (_PK_ str)
-- Kind constructors get a special function. Uniquely, they are not encoded,
-- so that they have names like '*'. This means that *even in interface files*
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.51 2000/12/06 13:19:49 simonmar Exp $
+% $Id: CgCase.lhs,v 1.52 2001/05/22 13:43:15 simonpj Exp $
%
%********************************************************
%* *
import TyCon ( isEnumerationTyCon, isUnboxedTupleTyCon, tyConPrimRep )
import Unique ( Unique, Uniquable(..), newTagUnique )
import Maybes ( maybeToBool )
-import Util
+import Util ( only )
import Outputable
\end{code}
doesn't clash with anything else.
\begin{code}
-cgCase (StgPrimApp op args _)
+cgCase (StgOpApp op args _)
live_in_whole_case live_in_alts bndr srt (StgAlgAlts (Just tycon) alts deflt)
| isEnumerationTyCon tycon
= getArgAmodes args `thenFC` \ arg_amodes ->
- let tag_amode = case op of
- TagToEnumOp -> only arg_amodes
- _ -> CTemp (newTagUnique (getUnique bndr) 'C') IntRep
-
- closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep) tag_amode PtrRep) PtrRep
- in
-
case op of {
- TagToEnumOp -> nopC; -- no code!
+ StgPrimOp TagToEnumOp -- No code!
+ -> returnFC (only arg_amodes) ;
+
+ _ -> -- Perform the operation
+ let
+ tag_amode = CTemp (newTagUnique (getUnique bndr) 'C') IntRep
+ in
+ getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
+ absC (COpStmt [tag_amode] op arg_amodes vol_regs) `thenC`
+ -- NB: no liveness arg
+ returnFC tag_amode
+ } `thenFC` \ tag_amode ->
- _ -> -- Perform the operation
- getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
-
- absC (COpStmt [tag_amode] op
- arg_amodes -- note: no liveness arg
- vol_regs)
- } `thenC`
+ let
+ closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep)
+ tag_amode PtrRep)
+ PtrRep
+ in
- -- bind the default binder if necessary
+ -- Bind the default binder if necessary
-- The deadness info is set by StgVarInfo
(if (isDeadBinder bndr)
then nopC
Special case #2: inline PrimOps.
\begin{code}
-cgCase (StgPrimApp op args _)
+cgCase (StgOpApp op@(StgPrimOp primop) args _)
live_in_whole_case live_in_alts bndr srt alts
- | not (primOpOutOfLine op)
+ | not (primOpOutOfLine primop)
=
-- Get amodes for the arguments and results
getArgAmodes args `thenFC` \ arg_amodes ->
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.42 2001/03/13 12:50:30 simonmar Exp $
+% $Id: CgExpr.lhs,v 1.43 2001/05/22 13:43:15 simonpj Exp $
%
%********************************************************
%* *
call, so we treat it as an inline primop.
\begin{code}
-cgExpr (StgPrimApp op@(CCallOp ccall) args res_ty)
+cgExpr (StgOpApp op@(StgFCallOp _ _) args res_ty)
= primRetUnboxedTuple op args res_ty
-- tagToEnum# is special: we need to pull the constructor out of the table,
-- and perform an appropriate return.
-cgExpr (StgPrimApp TagToEnumOp [arg] res_ty)
+cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty)
= ASSERT(isEnumerationTyCon tycon)
getArgAmode arg `thenFC` \amode ->
-- save the tag in a temporary in case amode overlaps
tycon = tyConAppTyCon res_ty
-cgExpr x@(StgPrimApp op args res_ty)
- | primOpOutOfLine op = tailCallPrimOp op args
+cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty)
+ | primOpOutOfLine primop
+ = tailCallPrimOp primop args
+
| otherwise
- = ASSERT(op /= SeqOp) -- can't handle SeqOp
+ = ASSERT(primop /= SeqOp) -- can't handle SeqOp
getArgAmodes args `thenFC` \ arg_amodes ->
- case (getPrimOpResultInfo op) of
+ case (getPrimOpResultInfo primop) of
ReturnsPrim kind ->
let result_amode = CReg (dataReturnConvPrim kind) in
\begin{code}
-primRetUnboxedTuple :: PrimOp -> [StgArg] -> Type -> Code
+primRetUnboxedTuple :: StgOp -> [StgArg] -> Type -> Code
primRetUnboxedTuple op args res_ty
= getArgAmodes args `thenFC` \ arg_amodes ->
{-
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: ClosureInfo.lhs,v 1.46 2001/03/13 12:50:30 simonmar Exp $
+% $Id: ClosureInfo.lhs,v 1.47 2001/05/22 13:43:15 simonpj Exp $
%
\section[ClosureInfo]{Data structures which describe closures}
isNullaryDataCon, dataConName
)
import TyCon ( isBoxedTupleTyCon )
-import IdInfo ( ArityInfo(..) )
import Name ( Name, nameUnique, getOccName )
import OccName ( occNameUserString )
import PprType ( getTyDescription )
other -> False
\end{code}
-\begin{code}
-isLetNoEscape :: ClosureInfo -> Bool
-
-isLetNoEscape (MkClosureInfo _ (LFLetNoEscape _) _) = True
-isLetNoEscape _ = False
-\end{code}
-
Label generation.
\begin{code}
\begin{code}
-rulesSomeFreeVars :: InterestingVarFun -> CoreRules -> VarSet
-rulesSomeFreeVars interesting (Rules rules _)
- = foldr (unionVarSet . ruleSomeFreeVars interesting) emptyVarSet rules
-
ruleRhsFreeVars :: CoreRule -> VarSet
ruleRhsFreeVars (BuiltinRule _) = noFVs
ruleRhsFreeVars (Rule str tpl_vars tpl_args rhs)
addErrL :: Message -> LintM a
addErrL msg loc scope errs warns = (Nothing, addErr errs msg loc, warns)
-addWarnL :: Message -> LintM a
-addWarnL msg loc scope errs warns = (Nothing, errs, addErr warns msg loc)
-
addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg
-- errors or warnings, actually... they're the same type.
addErr errs_so_far msg locs
isUnLiftedType, isUnboxedTupleType, repType,
uaUTy, usOnce, usMany, seqType )
import Demand ( Demand, isStrict, wwLazy, StrictnessInfo(..) )
-import PrimOp ( PrimOp(..), setCCallUnique )
-import Var ( Var, Id, setVarUnique, globalIdDetails, setGlobalIdDetails )
+import PrimOp ( PrimOp(..) )
+import Var ( Var, Id, setVarUnique )
import VarSet
import VarEnv
import Id ( mkSysLocal, idType, idStrictness, idDemandInfo, idArity,
- setIdType, isPrimOpId_maybe, isLocalId, modifyIdInfo,
+ setIdType, isPrimOpId_maybe, isFCallId, isLocalId,
hasNoBinding
)
-import IdInfo ( GlobalIdDetails(..) )
import HscTypes ( ModDetails(..) )
import UniqSupply
import Maybes
fiddleCCall :: Id -> UniqSM Id
fiddleCCall id
- = case globalIdDetails id of
- PrimOpId (CCallOp ccall) ->
- -- Make a guaranteed unique name for a dynamic ccall.
- getUniqueUs `thenUs` \ uniq ->
- returnUs (setGlobalIdDetails id
- (PrimOpId (CCallOp (setCCallUnique ccall uniq))))
- other -> returnUs id
+ | isFCallId id = getUniqueUs `thenUs` \ uniq ->
+ returnUs (id `setVarUnique` uniq)
+ | otherwise = returnUs id
------------------------------------------------------------------------------
-- Generating new binders
import CoreUtils ( exprIsValue, exprIsCheap, exprIsTrivial )
import Id ( Id, idType, isId,
idSpecialisation, idInlinePragma, idUnfolding,
- isPrimOpId_maybe, globalIdDetails
+ isFCallId_maybe, globalIdDetails
)
import VarSet
import Literal ( isLitLitLit, litSize )
-import PrimOp ( PrimOp(..), primOpIsDupable, primOpOutOfLine, ccallIsCasm )
+import PrimOp ( primOpIsDupable, primOpOutOfLine )
+import ForeignCall ( ForeignCall(..), ccallIsCasm )
import IdInfo ( InlinePragInfo(..), OccInfo(..), GlobalIdDetails(..),
isNeverInlinePrag
)
= case globalIdDetails fun of
DataConId dc -> conSizeN (valArgCount args)
+ FCallId fc -> sizeN opt_UF_DearOp
PrimOpId op -> primOpSize op (valArgCount args)
-- foldr addSize (primOpSize op) (map arg_discount args)
-- At one time I tried giving an arg-discount if a primop
sizeZero = SizeIs (_ILIT 0) emptyBag (_ILIT 0)
sizeOne = SizeIs (_ILIT 1) emptyBag (_ILIT 0)
-sizeTwo = SizeIs (_ILIT 2) emptyBag (_ILIT 0)
sizeN n = SizeIs (iUnbox n) emptyBag (_ILIT 0)
conSizeN n = SizeIs (_ILIT 1) emptyBag (iUnbox n +# _ILIT 1)
-- Treat constructors as size 1; we are keen to expose them
okToUnfoldInHiFile e = opt_UnfoldCasms || go e
where
-- Race over an expression looking for CCalls..
- go (Var v) = case isPrimOpId_maybe v of
- Just op -> okToUnfoldPrimOp op
- Nothing -> True
+ go (Var v) = case isFCallId_maybe v of
+ Just fcall -> okToExposeFCall fcall
+ Nothing -> True
go (Lit lit) = not (isLitLitLit lit)
go (App fun arg) = go fun && go arg
go (Lam _ body) = go body
go (Type _) = True
-- ok to unfold a PrimOp as long as it's not a _casm_
- okToUnfoldPrimOp (CCallOp ccall) = not (ccallIsCasm ccall)
- okToUnfoldPrimOp _ = True
+ okToExposeFCall (CCall cc) = not (ccallIsCasm cc)
+ okToExposeFCall other = True
\end{code}
import Name ( hashName )
import Literal ( hashLiteral, literalType, litIsDupable )
import DataCon ( DataCon, dataConRepArity )
-import PrimOp ( primOpOkForSpeculation, primOpIsCheap,
- primOpIsDupable )
+import PrimOp ( primOpOkForSpeculation, primOpIsCheap )
import Id ( Id, idType, globalIdDetails, idStrictness, idLBVarInfo,
mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,
- isDataConId_maybe, isPrimOpId_maybe, mkSysLocal, hasNoBinding
+ isDataConId_maybe, mkSysLocal, hasNoBinding
)
import IdInfo ( LBVarInfo(..),
GlobalIdDetails(..),
import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
import CostCentre ( CostCentre )
import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply )
-import Maybes ( maybeToBool )
import Outputable
import TysPrim ( alphaTy ) -- Debugging only
\end{code}
import IdInfo ( IdInfo, megaSeqIdInfo,
arityInfo, ppArityInfo,
specInfo, cprInfo, ppCprInfo,
- strictnessInfo, ppStrictnessInfo, cgInfo, pprCgInfo,
+ strictnessInfo, ppStrictnessInfo, cgInfo,
cprInfo, ppCprInfo,
workerInfo, ppWorkerInfo,
tyGenInfo, ppTyGenInfo
a = arityInfo info
g = tyGenInfo info
s = strictnessInfo info
- c = cgInfo info
+-- c = cgInfo info
m = cprInfo info
p = specInfo info
\end{code}
\begin{code}
module DsCCall
( dsCCall
- , mkCCall
+ , mkFCall
, unboxArg
, boxResult
, resultWrapper
import CoreUtils ( exprType, mkCoerce )
import Id ( Id, mkWildId, idType )
-import MkId ( mkCCallOpId, realWorldPrimId, mkPrimOpId )
+import MkId ( mkFCallId, realWorldPrimId, mkPrimOpId )
import Maybes ( maybeToBool )
-import PrimOp ( CCall(..), CCallTarget(..) )
+import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety, CCallConv(..) )
import DataCon ( splitProductType_maybe, dataConSourceArity, dataConWrapId )
-import CallConv
+import ForeignCall ( ForeignCall, CCallTarget(..) )
import Type ( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys,
splitTyConApp_maybe, tyVarsOfType, mkForAllTys,
isNewType, repType, isUnLiftedType, mkFunTy, mkTyConApp,
\begin{code}
dsCCall :: CLabelString -- C routine to invoke
-> [CoreExpr] -- Arguments (desugared)
- -> Bool -- True <=> might cause Haskell GC
+ -> Safety -- Safety of the call
-> Bool -- True <=> really a "_casm_"
-> Type -- Type of the result: IO t
-> DsM CoreExpr
boxResult [] result_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
getUniqueDs `thenDs` \ uniq ->
let
- the_ccall = CCall (StaticTarget lbl) is_asm may_gc cCallConv
- the_prim_app = mkCCall uniq the_ccall unboxed_args ccall_result_ty
+ the_fcall = CCall (CCallSpec (StaticTarget lbl) CCallConv may_gc is_asm)
+ the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
in
returnDs (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
-mkCCall :: Unique -> CCall
+mkFCall :: Unique -> ForeignCall
-> [CoreExpr] -- Args
-> Type -- Result type
-> CoreExpr
-- Here we build a ccall thus
-- (ccallid::(forall a b. StablePtr (a -> b) -> Addr -> Char -> IO Addr))
-- a b s x c
-mkCCall uniq the_ccall val_args res_ty
- = mkApps (mkVarApps (Var the_ccall_id) tyvars) val_args
+mkFCall uniq the_fcall val_args res_ty
+ = mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
where
arg_tys = map exprType val_args
body_ty = (mkFunTys arg_tys res_ty)
tyvars = varSetElems (tyVarsOfType body_ty)
ty = mkForAllTys tyvars body_ty
- the_ccall_id = mkCCallOpId uniq the_ccall ty
+ the_fcall_id = mkFCallId uniq the_fcall ty
\end{code}
\begin{code}
import CoreSyn
-import DsCCall ( dsCCall, mkCCall, boxResult, unboxArg, resultWrapper )
+import DsCCall ( dsCCall, mkFCall, boxResult, unboxArg, resultWrapper )
import DsMonad
import HsSyn ( ExtName(..), ForeignDecl(..), isDynamicExtName, ForKind(..) )
import HsDecls ( extNameStatic )
-import CallConv
import TcHsSyn ( TypecheckedForeignDecl )
import CoreUtils ( exprType, mkInlineMe )
import Id ( Id, idType, idName, mkVanillaGlobal, mkSysLocal,
Type, mkFunTys, mkForAllTys, mkTyConApp,
mkFunTy, splitAppTy, applyTy, funResultTy
)
-import PrimOp ( CCall(..), CCallTarget(..), dynamicTarget )
+import ForeignCall ( ForeignCall(..), CCallSpec(..),
+ Safety(..), playSafe,
+ CCallTarget(..), dynamicTarget,
+ CCallConv(..), ccallConvToInt
+ )
import TysWiredIn ( unitTy, addrTy, stablePtrTyCon )
import TysPrim ( addrPrimTy )
import PrelNames ( hasKey, ioTyConKey, deRefStablePtrName, newStablePtrName,
FoLabel -> True
_ -> False
- (FoImport uns) = imp_exp
-
+ FoImport uns = imp_exp
\end{code}
Desugaring foreign imports is just the matter of creating a binding
\begin{code}
dsFImport :: Id
-> Type -- Type of foreign import.
- -> Bool -- True <=> cannot re-enter the Haskell RTS
+ -> Safety -- Whether can re-enter the Haskell RTS, do GC etc
-> ExtName
- -> CallConv
+ -> CCallConv
-> DsM [Binding]
-dsFImport fn_id ty unsafe ext_name cconv
+dsFImport fn_id ty safety ext_name cconv
= let
(tvs, fun_ty) = splitForAllTys ty
(arg_tys, io_res_ty) = splitFunTys fun_ty
let
work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars
- -- these are the ids we pass to boxResult, which are used to decide
+ -- These are the ids we pass to boxResult, which are used to decide
-- whether to touch# an argument after the call (used to keep
-- ForeignObj#s live across a 'safe' foreign import).
- maybe_arg_ids | unsafe = []
- | otherwise = work_arg_ids
+ maybe_arg_ids | playSafe safety = work_arg_ids
+ | otherwise = []
in
boxResult maybe_arg_ids io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
-- Build the worker
worker_ty = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
- the_ccall = CCall lbl False (not unsafe) cconv
- the_ccall_app = mkCCall ccall_uniq the_ccall val_args ccall_result_ty
+ the_ccall = CCall (CCallSpec lbl cconv safety False)
+ the_ccall_app = mkFCall ccall_uniq the_ccall val_args ccall_result_ty
work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app)
work_id = mkSysLocal SLIT("$wccall") work_uniq worker_ty
-> Type -- Type of foreign export.
-> Module
-> ExtName
- -> CallConv
+ -> CCallConv
-> Bool -- True => invoke IO action that's hanging off
-- the first argument's stable pointer
-> DsM ( Id -- The foreign-exported Id
-> Type -- Type of foreign export.
-> Module
-> ExtName
- -> CallConv
+ -> CCallConv
-> DsM (Id, [Binding], SDoc, SDoc)
dsFExportDynamic i ty mod_name ext_name cconv =
newSysLocalDs ty `thenDs` \ fe_id ->
to be entered using an external calling convention
(stdcall, ccall).
-}
- adj_args = [ mkIntLitInt (callConvToInt cconv)
+ adj_args = [ mkIntLitInt (ccallConvToInt cconv)
, Var stbl_value
, mkLit (MachLabel (_PK_ fe_nm))
]
-- (probably in the RTS.)
adjustor = SLIT("createAdjustor")
in
- dsCCall adjustor adj_args False False io_res_ty `thenDs` \ ccall_adj ->
+ 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
let ccall_adj_ty = exprType ccall_adj
ccall_io_adj = mkLams [stbl_value] $
Note (Coerce io_res_ty ccall_adj_ty)
ccall_adj
- in
- let io_app = mkLams tvs $
+ io_app = mkLams tvs $
mkLams [cback] $
stbl_app ccall_io_adj res_ty
fed = (i `setInlinePragma` neverInlinePrag, io_app)
where
(tvs,sans_foralls) = splitForAllTys ty
([arg_ty], io_res_ty) = splitFunTys sans_foralls
-
Just (ioTyCon, [res_ty]) = splitTyConApp_maybe io_res_ty
-
export_ty = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty
- ioAddrTy :: Type -- IO Addr
- ioAddrTy = mkTyConApp ioTyCon [addrTy]
-
toCName :: Id -> String
toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
\end{code}
-> Id
-> [Type]
-> Type
- -> CallConv
+ -> CCallConv
-> Bool
-> (SDoc, SDoc)
fexportEntry mod_nm c_nm helper args res_ty cc isDyn = (header_bits, c_bits)
cResType | res_ty_is_unit = text "void"
| otherwise = showStgType res_ty
- pprCconv
- | cc == cCallConv = empty
- | otherwise = pprCallConv cc
+ pprCconv = case cc of
+ CCallConv -> empty
+ StdCallConv -> ppr cc
declareResult = text "HaskellObj ret;"
needed by the Adjustor.c code to get the stack cleanup right.
-}
(proto_args, real_args)
- | cc == cCallConv && isDyn = ( text "a0" : text "a_" : mkCArgNames 1 (tail args)
- , head args : addrTy : tail args)
- | otherwise = (mkCArgNames 0 args, args)
+ = case cc of
+ CCallConv | isDyn -> ( text "a0" : text "a_" : mkCArgNames 1 (tail args)
+ , head args : addrTy : tail args)
+ other -> (mkCArgNames 0 args, args)
mkCArgNames :: Int -> [a] -> [SDoc]
mkCArgNames n as = zipWith (\ _ n -> text ('a':show n)) as [n..]
import UniqSupply ( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
UniqSM, UniqSupply )
import Unique ( Unique )
-import Util ( zipWithEqual )
import Name ( Name )
import CmdLineOpts ( DynFlags )
import Outputable
import Name ( Name, getName )
-import Id ( Id, idType, isDataConId_maybe, isPrimOpId_maybe,
+import Id ( Id, idType, isDataConId_maybe, isPrimOpId_maybe, isFCallId,
idPrimRep, mkSysLocal, idName )
import OrdList ( OrdList, consOL, snocOL, appOL, unitOL,
nilOL, toOL, concatOL, fromOL )
import Class ( Class, classTyCon )
import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem )
import Var ( isTyVar )
-import VarSet ( VarSet, varSetElems, unitVarSet, unionVarSet )
+import VarSet ( VarSet, varSetElems )
import PrimRep ( getPrimRepSize, isFollowableRep )
import CmdLineOpts ( DynFlags, DynFlag(..) )
import ErrUtils ( showPass, dumpIfSet_dyn )
case app of
(_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)
-> case isPrimOpId_maybe v of
- Nothing -> Nothing
- Just primop | primop == TagToEnumOp
- -> Just (snd arg, extract_constr_Names t)
- | otherwise
- -> Nothing
+ Just TagToEnumOp -> Just (snd arg, extract_constr_Names t)
+ other -> Nothing
other -> Nothing
-- Extract the args (R->L) and fn
= ASSERT(tagged)
(unitOL (PUSH_TAG 0), 1)
+ | isFCallId v
+ = pprPanic "pushAtom: byte code generator can't handle CCalls" (ppr v)
+
| Just primop <- isPrimOpId_maybe v
- = case primop of
- CCallOp _ -> panic "pushAtom: byte code generator can't handle CCalls"
- other -> (unitOL (PUSH_G (Right primop)), 1)
+ = (unitOL (PUSH_G (Right primop)), 1)
| otherwise
- = let str = "\npushAtom " ++ showSDocDebug (ppr v)
+ = let {-
+ str = "\npushAtom " ++ showSDocDebug (ppr v)
++ " :: " ++ showSDocDebug (pprType (idType v))
++ ", depth = " ++ show d
++ ", tagged = " ++ show tagged ++ ", env =\n" ++
++ " --> words: " ++ show (snd result) ++ "\n" ++
showSDoc (nest 4 (vcat (map ppr (fromOL (fst result)))))
++ "\nendPushAtom " ++ showSDocDebug (ppr v)
- where
- cmp_snd x y = compare (snd x) (snd y)
- str' = if str == str then str else str
+ -}
result
= case lookupBCEnv_maybe p v of
sz_u = untaggedIdSizeW v
nwords = if tagged then sz_t else sz_u
in
- --trace str'
result
pushAtom True d p (AnnLit lit)
)
-- others:
-import Id ( idArity, idType, isDataConId_maybe, isPrimOpId_maybe )
+import Id ( idArity, idType, isDataConId_maybe, isFCallId_maybe )
import Var ( varType, isId )
import IdInfo ( InlinePragInfo, pprInlinePragInfo, ppStrictnessInfo )
import Name ( Name, NamedThing(..), getName, toRdrName )
import OccName ( isTvOcc )
import CoreSyn
import CostCentre ( pprCostCentreCore )
-import PrimOp ( PrimOp(CCallOp) )
import Demand ( StrictnessInfo )
import Literal ( Literal, maybeLitLit )
-import PrimOp ( CCall, pprCCallOp )
+import ForeignCall ( ForeignCall )
import DataCon ( dataConTyCon, dataConSourceArity )
import TyCon ( isTupleTyCon, tupleTyConBoxity )
import Type ( Kind )
| UfNote (UfNote name) (UfExpr name)
| UfLit Literal
| UfLitLit FAST_STRING (HsType name)
- | UfCCall CCall (HsType name)
+ | UfFCall ForeignCall (HsType name)
data UfNote name = UfSCC CostCentre
| UfCoerce (HsType name)
mkUfApps = foldl (\f a -> UfApp f (toUfExpr a))
---------------------
-toUfVar v = case isPrimOpId_maybe v of
- -- Ccalls has special syntax
- Just (CCallOp cc) -> UfCCall cc (toHsType (idType v))
- other -> UfVar (getName v)
+toUfVar v = case isFCallId_maybe v of
+ -- Foreign calls have special syntax
+ Just fcall -> UfFCall fcall (toHsType (idType v))
+ other -> UfVar (getName v)
\end{code}
pprUfExpr add_par (UfVar v) = ppr v
pprUfExpr add_par (UfLit l) = ppr l
pprUfExpr add_par (UfLitLit l ty) = add_par (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
-pprUfExpr add_par (UfCCall cc ty) = braces (pprCCallOp cc <+> ppr ty)
+pprUfExpr add_par (UfFCall cc ty) = braces (ppr cc <+> ppr ty)
pprUfExpr add_par (UfType ty) = char '@' <+> pprParendHsType ty
pprUfExpr add_par e@(UfLam _ _) = add_par (char '\\' <+> hsep (map ppr bndrs)
eq_ufExpr env (UfVar v1) (UfVar v2) = eq_ufVar env v1 v2
eq_ufExpr env (UfLit l1) (UfLit l2) = l1 == l2
eq_ufExpr env (UfLitLit l1 ty1) (UfLitLit l2 ty2) = l1==l2 && eq_hsType env ty1 ty2
-eq_ufExpr env (UfCCall c1 ty1) (UfCCall c2 ty2) = c1==c2 && eq_hsType env ty1 ty2
+eq_ufExpr env (UfFCall c1 ty1) (UfFCall c2 ty2) = c1==c2 && eq_hsType env ty1 ty2
eq_ufExpr env (UfType ty1) (UfType ty2) = eq_hsType env ty1 ty2
eq_ufExpr env (UfTuple n1 as1) (UfTuple n2 as2) = n1==n2 && eqListBy (eq_ufExpr env) as1 as2
eq_ufExpr env (UfLam b1 body1) (UfLam b2 body2) = eq_ufBinder env b1 b2 (\env -> eq_ufExpr env body1 body2)
import CoreSyn ( CoreRule(..) )
import BasicTypes ( NewOrData(..) )
import Demand ( StrictnessMark(..) )
-import CallConv ( CallConv, pprCallConv )
+import ForeignCall ( CCallConv )
-- others:
+import ForeignCall ( Safety )
import Name ( NamedThing )
import FunDeps ( pprFundeps )
import Class ( FunDep, DefMeth(..) )
ForKind
(HsType name)
ExtName
- CallConv
+ CCallConv
SrcLoc
instance (Outputable name)
=> Outputable (ForeignDecl name) where
ppr (ForeignDecl nm imp_exp ty ext_name cconv src_loc)
- = ptext SLIT("foreign") <+> ppr_imp_exp <+> pprCallConv cconv <+>
+ = ptext SLIT("foreign") <+> ppr_imp_exp <+> ppr cconv <+>
ppr ext_name <+> ppr_unsafe <+> ppr nm <+> dcolon <+> ppr ty
where
(ppr_imp_exp, ppr_unsafe) =
case imp_exp of
FoLabel -> (ptext SLIT("label"), empty)
FoExport -> (ptext SLIT("export"), empty)
- FoImport us
- | us -> (ptext SLIT("import"), ptext SLIT("unsafe"))
- | otherwise -> (ptext SLIT("import"), empty)
+ FoImport us -> (ptext SLIT("import"), ppr us)
data ForKind
= FoLabel
| FoExport
- | FoImport Bool -- True => unsafe call.
+ | FoImport Safety
data ExtName
= Dynamic
import HsImpExp ( isOperator )
-- others:
+import ForeignCall ( Safety )
import Name ( Name )
import Outputable
import PprType ( pprParendType )
| HsCCall CLabelString -- call into the C world; string is
[HsExpr id pat] -- the C function; exprs are the
-- arguments to pass.
- Bool -- True <=> might cause Haskell
+ Safety -- True <=> might cause Haskell
-- garbage-collection (must generate
-- more paranoid code)
Bool -- True <=> it's really a "casm"
import DataCon ( isUnboxedTupleCon, dataConTyCon, dataConRepType, dataConRepArgTys )
import Literal ( Literal(..) )
import PrelNames -- Lots of keys
-import PrimOp ( PrimOp(..), CCallTarget(..),CCall(..) )
+import PrimOp ( PrimOp(..) )
+import ForeignCall ( ForeignCall(..), CCall(..), CCallTarget(..) )
import TysWiredIn ( mkTupleTy, tupleCon )
import PrimRep ( PrimRep(..) )
import Name ( nameModule, nameOccName, isGlobalName, isLocalName, NamedThing(getName) )
import UniqFM
import BasicTypes ( Boxity(..) )
import CStrings ( CLabelString, pprCLabelString )
-import CallConv ( CallConv )
+import CCallConv ( CCallConv )
import Outputable
import Char ( ord )
import List ( partition, elem, insertBy,any )
importsExpr env (StgLit _) = importsNone
importsExpr env (StgApp f args) = importsVar env f.importsStgArgs env args
importsExpr env (StgConApp con args) = importsDataCon env con.importsStgArgs env args
-importsExpr env (StgPrimApp (CCallOp (CCall (StaticTarget c) _ _ cc)) args rty)
+importsExpr env (StgOpApp (StgFCallOp (CCall (CCallSpec (StaticTarget c) cc _ _)) _) args rty)
= addCCallInfo (c,cc, map stgArgType tm_args, rty) . importsStgArgs env args
where
(ty_args,tm_args) = splitTyArgs1 args
-importsExpr env (StgPrimApp _ args res_ty) = importsType env res_ty. importsStgArgs env args
+importsExpr env (StgOpApp _ args res_ty) = importsType env res_ty. importsStgArgs env args
importsExpr env (StgSCC _ expr) = importsExpr env expr
importsPrelude | inPrelude = addModuleImpInfo (mkModuleName "PrelGHC")
| otherwise = addPackageImpInfo preludePackage
-type StaticCCallInfo = (CLabelString,CallConv,[Type],Type)
+type StaticCCallInfo = (CLabelString,CCallConv,[Type],Type)
type ImportsInfo = (UniqSet PackageName, UniqSet ModuleName, UniqSet TyCon, UniqFM StaticCCallInfo)
-- (Packages, Modules, Datatypes, Imported CCalls)
= ilxExprLocals (ilxPlaceStgCaseScrut env) scrut ++
(if isDeadBinder bndr then [] else [(LocalId bndr,Nothing)]) ++
ilxAltsLocals env alts
-ilxExprLocals env (StgPrimApp (CCallOp (CCall (StaticTarget _)_ _ _)) args _)
+ilxExprLocals env (StgOpApp (StgFCallOp (CCall (CCallSpec (StaticTarget _) _ _ _)) _) args _)
= concat (ilxMapPlaceArgs 0 ilxCCallArgLocals env args)
ilxExprLocals _ _ = []
= vcat (ilxMapPlaceArgs 0 (ilxArgClosures) env args) -- get strings
ilxExprClosures env (StgConApp _ args)
= vcat (ilxMapPlaceArgs 0 (ilxArgClosures) env args) -- get strings
-ilxExprClosures env (StgPrimApp _ args _)
+ilxExprClosures env (StgOpApp _ args _)
= vcat (ilxMapPlaceArgs 0 (ilxArgClosures) env args) -- get strings
ilxExprClosures env (StgLet bind body)
= ilxBindClosures env bind $$ ilxExprClosures (extendIlxEnvWithBinds env (ilxPairs1 bind)) body
= text " /* ilxExpr:StgConApp */ " <+> ilxConApp env data_con args $$ ilxSequel sequel
-- ilxExpr eenv (StgPrimApp primop args _) sequel
-ilxExpr (IlxEEnv env _) (StgPrimApp primop args ret_ty) sequel
- = ilxPrimApp env primop args ret_ty $$ ilxSequel sequel
+ilxExpr (IlxEEnv env _) (StgOpApp (StgFCallOp fcall) args ret_ty) sequel
+ = ilxFCall env fcall args ret_ty $$ ilxSequel sequel
+
+ilxExpr (IlxEEnv env _) (StgOpApp (StgPrimOp primop) args ret_ty) sequel
+ = ilxPrimOpTable primop args env $$ ilxSequel sequel
--BEGIN TEMPORARY
-- The following are versions of a peephole optimizations for "let t = \[] t2[fvs] in t"
]
-- StgCase: Special case 2 to avoid spurious branch.
-ilxExpr eenv@(IlxEEnv env live) (StgCase (StgPrimApp primop args ret_ty) live_in_case _live_in_alts bndr _ alts) sequel
+ilxExpr eenv@(IlxEEnv env live) (StgCase (StgOpApp (StgPrimOp primop) args ret_ty) live_in_case _live_in_alts bndr _ alts) sequel
= vcat [ilxWipe env (uniqSetToList (live `minusUniqSet` live_in_case)),
- ilxPrimApp (ilxPlaceStgCaseScrut env) primop args ret_ty,
+ ilxPrimOpTable primop args (ilxPlaceStgCaseScrut env),
--ilxWipe env (uniqSetToList (live_in_case `minusUniqSet` _live_in_alts)),
--ilxAlts (IlxEEnv env _live_in_alts) bndr alts sequel
ilxAlts (IlxEEnv env live_in_case) bndr alts sequel
\begin{code}
-ilxPrimApp env (CCallOp ccall) args ret_ty = ilxCCall env ccall args ret_ty
ilxPrimApp env op args ret_ty = ilxPrimOpTable op args env
WaitReadOp -> warn_op "WaitReadOp" (simp_op (ilxOp "/* WaitReadOp skipped... */ pop"))
WaitWriteOp -> warn_op "WaitWriteOp" (simp_op (ilxOp " /* WaitWriteOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw"))
- CCallOp _ -> panic "CCallOp should already be done..."
ParAtForNowOp -> warn_op "ParAtForNowOp" (simp_op (ilxOp " /* ParAtForNowOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw"))
ParAtRelOp -> warn_op "ParAtRelOp" (simp_op (ilxOp " /* ParAtRelOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw"))
ParAtAbsOp -> warn_op "ParAtAbsOp" (simp_op (ilxOp " /* ParAtAbsOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw"))
%************************************************************************
\begin{code}
-
-- Call the P/Invoke stub wrapper generated in the import section.
-- We eliminate voids in and around an IL C Call.
-- We also do some type-directed translation for pinning Haskell-managed blobs
-- of data as we throw them across the boundary.
-ilxCCall env (CCall (StaticTarget c) casm gc cconv) args ret_ty =
- ilxComment (text "C call <+> pprCLabelString c") <+>
+ilxFCall env (CCall (CCallSpec (StaticTarget c) cconv gc casm)) args ret_ty
+ = ilxComment (text "C call <+> pprCLabelString c") <+>
vcat [vcat (ilxMapPlaceArgs 0 pushCArg env args),
text "call" <+> retdoc <+> pprCLabelString c <+> pprTypeArgs ilxTypeR env ty_args
<+> pprCValArgTys ilxTypeL env (map deepIlxRepType (filter (not. isVoidIlxRepType) (map stgArgType tm_args))) ]
where
- retdoc =
- if isVoidIlxRepType ret_ty then text "void"
- else ilxTypeR env (deepIlxRepType ret_ty)
+ retdoc | isVoidIlxRepType ret_ty = text "void"
+ | otherwis = ilxTypeR env (deepIlxRepType ret_ty)
(ty_args,tm_args) = splitTyArgs1 args
import Type ( Type )
import Id ( Id, idName, setGlobalIdDetails )
import IdInfo ( GlobalIdDetails(VanillaGlobal) )
-import HscTypes ( InteractiveContext(..), TyThing(..) )
+import HscTypes ( InteractiveContext(..) )
import PrelNames ( iNTERACTIVE )
import StringBuffer ( stringToStringBuffer )
#endif
import OccName ( OccName )
import Name ( Name, nameModule, nameOccName, getName, isGlobalName )
import NameEnv ( emptyNameEnv, mkNameEnv )
-import Module ( Module, lookupModuleEnvByName )
-import Maybes ( orElse )
+import Module ( Module )
import IOExts ( newIORef, readIORef, writeIORef, unsafePerformIO )
grab names = foldl add emptyFM names
add env name
= addToFM env (moduleName (nameModule name), nameOccName name) name
-
-
-initRules :: PackageRuleBase
-initRules = emptyRuleBase
-{- SHOULD BE (ish)
- foldl add emptyVarEnv builtinRules
- where
- add env (name,rule)
- = extendRuleBase env name rule
--}
\end{code}
import PrimRep ( isFloatingRep, PrimRep(..) )
import StixInfo ( genCodeInfoTable, genBitmapInfoTable )
import StixMacro ( macroCode, checkCode )
-import StixPrim ( primCode, amodeToStix, amodeToStix' )
+import StixPrim ( primCode, foreignCallCode, amodeToStix, amodeToStix' )
import Outputable ( pprPanic, ppr )
import UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
import Util ( naturalMergeSortLe )
Now the PrimOps, some of which may need caller-saves register wrappers.
\begin{code}
+ gencode (COpStmt results (StgFCallOp fcall _) args vols)
+ = ASSERT( null vols )
+ foreignCallCode (nonVoid results) fcall (nonVoid args)
- gencode (COpStmt results op args vols)
+ gencode (COpStmt results (StgPrimOp op) args vols)
-- ToDo (ADR?): use that liveness mask
| primOpNeedsWrapper op
= let
- saves = volsaves vols
+ saves = volsaves vols
restores = volrestores vols
in
p2stix (nonVoid results) op (nonVoid args)
| otherwise = p2stix (nonVoid results) op (nonVoid args)
where
nonVoid = filter ((/= VoidRep) . getAmodeRep)
-
\end{code}
Now the dreaded conditional jump.
import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
snocOL, consOL, concatOL )
import AbsCUtils ( magicIdPrimRep )
-import CallConv ( CallConv )
+import ForeignCall ( CCallConv(..) )
import CLabel ( isAsmTemp, CLabel, labelDynamic )
import Maybes ( maybeToBool, expectJust )
import PrimRep ( isFloatingRep, PrimRep(..) )
import PrimOp ( PrimOp(..) )
-import CallConv ( cCallConv, stdCallConv )
import Stix ( getNatLabelNCG, StixTree(..),
StixReg(..), CodeSegment(..),
DestInfo, hasDestInfo,
Double2FloatOp -> coerceFltCode x
Float2DoubleOp -> coerceFltCode x
- other_op -> getRegister (StCall fn cCallConv DoubleRep [x])
+ other_op -> getRegister (StCall fn CCallConv DoubleRep [x])
where
fn = case other_op of
FloatExpOp -> SLIT("exp")
ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
- FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
- DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
+ FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
+ DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
where
{- ------------------------------------------------------------
Some bizarre special code for getting condition codes into
Int2DoubleOp -> coerceInt2FP DoubleRep x
other_op ->
- getRegister (StCall fn cCallConv DoubleRep [x])
+ getRegister (StCall fn CCallConv DoubleRep [x])
where
(is_float_op, fn)
= case primop of
ISraOp -> shift_code (SAR L) x y {-False-}
ISrlOp -> shift_code (SHR L) x y {-False-}
- FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
+ FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
[promote x, promote y])
where promote x = StPrim Float2DoubleOp [x]
- DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
+ DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
[x, y])
other
-> pprPanic "getRegister(x86,dyadic primop)"
then StPrim Float2DoubleOp [x]
else x
in
- getRegister (StCall fn cCallConv DoubleRep [fixed_x])
+ getRegister (StCall fn CCallConv DoubleRep [fixed_x])
where
(is_float_op, fn)
= case primop of
ISraOp -> trivialCode SRA x y
ISrlOp -> trivialCode SRL x y
- FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
+ FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
[promote x, promote y])
where promote x = StPrim Float2DoubleOp [x]
- DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
+ DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
[x, y])
other
(pprStixTree (StPrim primop [x, y]))
where
- imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y])
+ imul_div fn x y = getRegister (StCall fn CCallConv IntRep [x, y])
getRegister (StInd pk mem)
= getAmode mem `thenNat` \ amode ->
call = toOL (
[CALL (fn__2 tot_arg_size)]
++
- (if cconv == stdCallConv then [] else
+ (if cconv == StdCallConv then [] else
[ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
++
[DELTA (delta + tot_arg_size)]
= ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
stdcallsize tot_arg_size
- | cconv == stdCallConv = '@':show tot_arg_size
+ | cconv == StdCallConv = '@':show tot_arg_size
| otherwise = ""
arg_size DF = 8
import Ratio ( Rational )
import AbsCSyn ( node, tagreg, MagicId(..) )
-import CallConv ( CallConv, pprCallConv )
+import ForeignCall ( CCallConv )
import CLabel ( mkAsmTempLabel, CLabel, pprCLabel )
import PrimRep ( PrimRep(..) )
import PrimOp ( PrimOp )
-- Calls to C functions
- | StCall FAST_STRING CallConv PrimRep [StixTree]
+ | StCall FAST_STRING CCallConv PrimRep [StixTree]
-- A volatile memory scratch array, which is allocated
-- relative to the stack pointer. It is an array of
hsep (map pprStixTree ts))
StCall nm cc k args
-> paren (text "Call" <+> ptext nm <+>
- pprCallConv cc <+> ppr k <+>
+ ppr cc <+> ppr k <+>
hsep (map pprStixTree args))
StScratchWord i -> text "ScratchWord" <> paren (int i)
\end{code}
import {-# SOURCE #-} StixPrim ( amodeToStix )
import AbsCSyn hiding (spRel) -- bits and bobs..
-import CallConv ( cCallConv )
+import ForeignCall ( CCallConv(..) )
import PrimOp ( PrimOp(..) )
import PrimRep ( PrimRep(..) )
import Stix ( StixTree(..), StixTreeList, arrWordsHS )
(a1,a2,a3) = toStruct scratch1 (aa1,sa1,da1)
(a4,a5,a6) = toStruct scratch2 (aa2,sa2,da2)
- mpz_cmp = StCall SLIT("__gmpz_cmp") cCallConv IntRep [scratch1, scratch2]
+ mpz_cmp = StCall SLIT("__gmpz_cmp") CCallConv IntRep [scratch1, scratch2]
r1 = StAssign IntRep result mpz_cmp
in
returnUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs)
da1 = stgArrWords__BYTE_ARR_CTS (amodeToStix cda1)
ai = amodeToStix cai
(a1,a2,a3) = toStruct scratch1 (aa1,sa1,da1)
- mpz_cmp_si = StCall SLIT("__gmpz_cmp_si") cCallConv IntRep [scratch1, ai]
+ mpz_cmp_si = StCall SLIT("__gmpz_cmp_si") CCallConv IntRep [scratch1, ai]
r1 = StAssign IntRep result mpz_cmp_si
in
returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
da = stgArrWords__BYTE_ARR_CTS (amodeToStix cda)
(a1,a2,a3) = toStruct scratch1 (aa,sa,da)
- mpz_get_si = StCall SLIT("__gmpz_get_si") cCallConv IntRep [scratch1]
+ mpz_get_si = StCall SLIT("__gmpz_get_si") CCallConv IntRep [scratch1]
r1 = StAssign IntRep result mpz_get_si
in
returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
da = stgArrWords__BYTE_ARR_CTS (amodeToStix cda)
(a1,a2,a3) = toStruct scratch1 (aa,sa,da)
- mpz_get_ui = StCall SLIT("__gmpz_get_ui") cCallConv IntRep [scratch1]
+ mpz_get_ui = StCall SLIT("__gmpz_get_ui") CCallConv IntRep [scratch1]
r1 = StAssign WordRep result mpz_get_ui
in
returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
import AbsCSyn ( CStmtMacro(..), CAddrMode, tagreg,
CCheckMacro(..) )
import Constants ( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE )
-import CallConv ( cCallConv )
+import ForeignCall ( CCallConv(..) )
import PrimOp ( PrimOp(..) )
import PrimRep ( PrimRep(..) )
import Stix
w1 = StInd PtrRep (StIndex PtrRep cafptr fixedHS)
a1 = StAssign PtrRep w0 ind_static_info
a2 = StAssign PtrRep w1 bhptr
- a3 = StCall SLIT("newCAF") cCallConv VoidRep [cafptr]
+ a3 = StCall SLIT("newCAF") CCallConv VoidRep [cafptr]
in
returnUs (\xs -> a1 : a2 : a3 : xs)
\end{code}
macroCode REGISTER_FOREIGN_EXPORT [arg]
= returnUs (
- \xs -> StCall SLIT("getStablePtr") cCallConv VoidRep [amodeToStix arg]
+ \xs -> StCall SLIT("getStablePtr") CCallConv VoidRep [amodeToStix arg]
: xs
)
updatePAP, stackOverflow :: StixTree
updatePAP = StJump NoDestInfo stg_update_PAP
-stackOverflow = StCall SLIT("StackOverflow") cCallConv VoidRep []
+stackOverflow = StCall SLIT("StackOverflow") CCallConv VoidRep []
\end{code}
-----------------------------------------------------------------------------
import CLabel ( mkIntlikeClosureLabel, mkCharlikeClosureLabel,
mkMAP_FROZEN_infoLabel, mkEMPTY_MVAR_infoLabel,
mkForeignLabel )
-import CallConv ( cCallConv )
+import ForeignCall ( CCallConv(..) )
import Outputable
import FastTypes
#include "NCG.h"
\end{code}
-The main honcho here is primCode, which handles the guts of COpStmts.
+The main honchos here are primCode anf foreignCallCode, which handle the guts of COpStmts.
\begin{code}
+foreignCallCode
+ :: [CAddrMode] -- results
+ -> ForeignCall -- op
+ -> [CAddrMode] -- args
+ -> UniqSM StixTreeList
+
primCode
:: [CAddrMode] -- results
-> PrimOp -- op
-> UniqSM StixTreeList
\end{code}
+%************************************************************************
+%* *
+\subsubsection{Code for foreign calls}
+%* *
+%************************************************************************
+
First, the dreaded @ccall@. We can't handle @casm@s.
Usually, this compiles to an assignment, but when the left-hand side
btw Why not let programmer use casm to provide assembly code instead
of C code? ADR
+ToDo: saving/restoring of volatile regs around ccalls.
+
+JRS, 001113: always do the call of suspendThread and resumeThread as a ccall
+rather than inheriting the calling convention of the thing which we're really
+calling.
+
+\begin{code}
+foreignCallCode lhs (CCall (CCallSpec (StaticTarget fn) cconv safety is_asm)) rhs
+ | is_asm = error "ERROR: Native code generator can't handle casm"
+ | not (playSafe safety) = returnUs (\xs -> ccall : xs)
+
+ | otherwise
+ = save_thread_state `thenUs` \ save ->
+ load_thread_state `thenUs` \ load ->
+ getUniqueUs `thenUs` \ uniq ->
+ let
+ id = StReg (StixTemp uniq IntRep)
+
+ suspend = StAssign IntRep id
+ (StCall SLIT("suspendThread") {-no:cconv-} CCallConv
+ IntRep [stgBaseReg])
+ resume = StCall SLIT("resumeThread") {-no:cconv-} CCallConv
+ VoidRep [id]
+ in
+ returnUs (\xs -> save (suspend : ccall : resume : load xs))
+
+ where
+ args = map amodeCodeForCCall rhs
+ amodeCodeForCCall x =
+ let base = amodeToStix' x
+ in
+ case getAmodeRep x of
+ ArrayRep -> StIndex PtrRep base arrPtrsHS
+ ByteArrayRep -> StIndex IntRep base arrWordsHS
+ ForeignObjRep -> StInd PtrRep (StIndex PtrRep base fixedHS)
+ _ -> base
+
+ ccall = case lhs of
+ [] -> StCall fn cconv VoidRep args
+ [lhs] ->
+ let lhs' = amodeToStix lhs
+ pk = case getAmodeRep lhs of
+ FloatRep -> FloatRep
+ DoubleRep -> DoubleRep
+ other -> IntRep
+ in
+ StAssign pk lhs' (StCall fn cconv pk args)
+
+foreignCallCode lhs call rhs
+ = pprPanic "Native code generator can't handle foreign call" (ppr call)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsubsection{Code for primops}
+%* *
+%************************************************************************
+
The (MP) integer operations are a true nightmare. Since we don't have
a convenient abstract way of allocating temporary variables on the (C)
stack, we use the space just below HpLim for the @MP_INT@ structures,
\end{code}
-ToDo: saving/restoring of volatile regs around ccalls.
-
-JRS, 001113: always do the call of suspendThread and resumeThread as a ccall
-rather than inheriting the calling convention of the thing which we're really
-calling.
-
-\begin{code}
-primCode lhs (CCallOp (CCall (StaticTarget fn) is_asm may_gc cconv)) rhs
- | is_asm = error "ERROR: Native code generator can't handle casm"
- | not may_gc = returnUs (\xs -> ccall : xs)
- | otherwise =
- save_thread_state `thenUs` \ save ->
- load_thread_state `thenUs` \ load ->
- getUniqueUs `thenUs` \ uniq ->
- let
- id = StReg (StixTemp uniq IntRep)
-
- suspend = StAssign IntRep id
- (StCall SLIT("suspendThread") {-no:cconv-} cCallConv
- IntRep [stgBaseReg])
- resume = StCall SLIT("resumeThread") {-no:cconv-} cCallConv
- VoidRep [id]
- in
- returnUs (\xs -> save (suspend : ccall : resume : load xs))
-
- where
- args = map amodeCodeForCCall rhs
- amodeCodeForCCall x =
- let base = amodeToStix' x
- in
- case getAmodeRep x of
- ArrayRep -> StIndex PtrRep base arrPtrsHS
- ByteArrayRep -> StIndex IntRep base arrWordsHS
- ForeignObjRep -> StInd PtrRep (StIndex PtrRep base fixedHS)
- _ -> base
-
- ccall = case lhs of
- [] -> StCall fn cconv VoidRep args
- [lhs] ->
- let lhs' = amodeToStix lhs
- pk = case getAmodeRep lhs of
- FloatRep -> FloatRep
- DoubleRep -> DoubleRep
- other -> IntRep
- in
- StAssign pk lhs' (StCall fn cconv pk args)
-\end{code}
DataToTagOp won't work for 64-bit archs, as it is.
import IdInfo ( InlinePragInfo(..) )
import PrelNames ( mkTupNameStr )
import CmdLineOpts ( opt_HiVersion, opt_NoHiCheck )
+import ForeignCall ( Safety(..) )
import Demand ( Demand(..) {- instance Read -} )
import UniqFM ( listToUFM, lookupUFM )
import BasicTypes ( NewOrData(..), Boxity(..) )
| ITcoerce
| ITinlineMe
| ITinlineCall
- | ITccall (Bool,Bool,Bool) -- (is_dyn, is_casm, may_gc)
+ | ITccall (Bool,Bool,Safety) -- (is_dyn, is_casm, may_gc)
| ITdefaultbranch
| ITbottom
| ITinteger_lit
( "with", ITwith ),
( "stdcall", ITstdcallconv),
( "ccall", ITccallconv),
- ("_ccall_", ITccall (False, False, False)),
- ("_ccall_GC_", ITccall (False, False, True)),
- ("_casm_", ITccall (False, True, False)),
- ("_casm_GC_", ITccall (False, True, True)),
+ ("_ccall_", ITccall (False, False, PlayRisky)),
+ ("_ccall_GC_", ITccall (False, False, PlaySafe)),
+ ("_casm_", ITccall (False, True, PlayRisky)),
+ ("_casm_GC_", ITccall (False, True, PlaySafe)),
-- interface keywords
("__interface", ITinterface),
("__D", ITdeprecated),
("__U", ITunfold NoInlinePragInfo),
- ("__ccall", ITccall (False, False, False)),
- ("__ccall_GC", ITccall (False, False, True)),
- ("__dyn_ccall", ITccall (True, False, False)),
- ("__dyn_ccall_GC", ITccall (True, False, True)),
- ("__casm", ITccall (False, True, False)),
- ("__dyn_casm", ITccall (True, True, False)),
- ("__casm_GC", ITccall (False, True, True)),
- ("__dyn_casm_GC", ITccall (True, True, True)),
+ ("__ccall", ITccall (False, False, PlayRisky)),
+ ("__ccall_GC", ITccall (False, False, PlaySafe)),
+ ("__dyn_ccall", ITccall (True, False, PlayRisky)),
+ ("__dyn_ccall_GC", ITccall (True, False, PlaySafe)),
+ ("__casm", ITccall (False, True, PlayRisky)),
+ ("__dyn_casm", ITccall (True, True, PlayRisky)),
+ ("__casm_GC", ITccall (False, True, PlaySafe)),
+ ("__dyn_casm_GC", ITccall (True, True, PlaySafe)),
("/\\", ITbiglam)
]
)
import RdrName
import PrelNames ( unitTyCon_RDR )
-import CallConv
+import ForeignCall ( CCallConv(..) )
import OccName ( dataName, varName, tcClsName,
occNameSpace, setOccNameSpace, occNameUserString )
import FastString ( unpackFS )
----------------------------------------------------------------------------
-- Various Syntactic Checks
-callConvFM :: UniqFM CallConv
-callConvFM = listToUFM $
- map (\ (x,y) -> (_PK_ x,y))
- [ ("stdcall", stdCallConv),
- ("ccall", cCallConv)
--- ("pascal", pascalCallConv),
--- ("fastcall", fastCallConv)
- ]
-
checkInstType :: RdrNameHsType -> P RdrNameHsType
checkInstType t
= case t of
{-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.64 2001/05/18 08:46:20 simonpj Exp $
+$Id: Parser.y,v 1.65 2001/05/22 13:43:17 simonpj Exp $
Haskell grammar.
import PrelNames ( mAIN_Name, unitTyCon_RDR, funTyCon_RDR, listTyCon_RDR,
tupleTyCon_RDR, unitCon_RDR, nilCon_RDR, tupleCon_RDR
)
+import ForeignCall ( Safety(..), CCallConv(..), defaultCCallConv )
import OccName ( UserFS, varName, tcName, dataName, tcClsName, tvName )
import SrcLoc ( SrcLoc )
import Module
-import CallConv
import Demand ( StrictnessMark(..) )
import CmdLineOpts ( opt_SccProfilingOn )
import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), NewOrData(..) )
'with' { ITwith }
'stdcall' { ITstdcallconv }
'ccall' { ITccallconv }
- '_ccall_' { ITccall (False, False, False) }
- '_ccall_GC_' { ITccall (False, False, True) }
- '_casm_' { ITccall (False, True, False) }
- '_casm_GC_' { ITccall (False, True, True) }
+ '_ccall_' { ITccall (False, False, PlayRisky) }
+ '_ccall_GC_' { ITccall (False, False, PlaySafe) }
+ '_casm_' { ITccall (False, True, PlayRisky) }
+ '_casm_GC_' { ITccall (False, True, PlaySafe) }
'{-# SPECIALISE' { ITspecialise_prag }
'{-# SOURCE' { ITsource_prag }
| srcloc 'foreign' 'label' ext_name varid '::' sigtype
{ RdrHsDecl (ForD (ForeignDecl $5 FoLabel $7 (mkExtName $4 $5)
- defaultCallConv $1)) }
+ defaultCCallConv $1)) }
| '{-# DEPRECATED' deprecations '#-}' { $2 }
| '{-# RULES' rules '#-}' { $2 }
-----------------------------------------------------------------------------
-- Foreign import/export
-callconv :: { Int }
- : 'stdcall' { stdCallConv }
- | 'ccall' { cCallConv }
- | {- empty -} { defaultCallConv }
+callconv :: { CCallConv }
+ : 'stdcall' { StdCallConv }
+ | 'ccall' { CCallConv }
+ | {- empty -} { defaultCCallConv }
-unsafe_flag :: { Bool }
- : 'unsafe' { True }
- | {- empty -} { False }
+unsafe_flag :: { Safety }
+ : 'unsafe' { PlayRisky }
+ | {- empty -} { PlaySafe }
ext_name :: { Maybe ExtName }
: 'dynamic' { Just Dynamic }
| srcloc 'do' stmtlist {% checkDo $3 `thenP` \ stmts ->
returnP (HsDo DoExpr stmts $1) }
- | '_ccall_' ccallid aexps0 { HsCCall $2 $3 False False cbot }
- | '_ccall_GC_' ccallid aexps0 { HsCCall $2 $3 True False cbot }
- | '_casm_' CLITLIT aexps0 { HsCCall $2 $3 False True cbot }
- | '_casm_GC_' CLITLIT aexps0 { HsCCall $2 $3 True True cbot }
+ | '_ccall_' ccallid aexps0 { HsCCall $2 $3 PlayRisky False cbot }
+ | '_ccall_GC_' ccallid aexps0 { HsCCall $2 $3 PlaySafe False cbot }
+ | '_casm_' CLITLIT aexps0 { HsCCall $2 $3 PlayRisky True cbot }
+ | '_casm_GC_' CLITLIT aexps0 { HsCCall $2 $3 PlaySafe True cbot }
| scc_annot exp { if opt_SccProfilingOn
then HsSCC $1 $2
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[Foreign]{Foreign calls}
+
+\begin{code}
+module ForeignCall (
+ ForeignCall(..),
+ Safety(..), playSafe,
+
+ CCallSpec(..), ccallIsCasm,
+ CCallTarget(..), dynamicTarget, isDynamicTarget,
+ CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
+
+ DotNetCallSpec(..)
+ ) where
+
+#include "HsVersions.h"
+
+import CStrings ( CLabelString, pprCLabelString )
+import Outputable
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsubsection{Data types}
+%* *
+%************************************************************************
+
+\begin{code}
+data ForeignCall
+ = CCall CCallSpec
+ | DotNetCall DotNetCallSpec
+ deriving( Eq ) -- We compare them when seeing if an interface
+ -- has changed (for versioning purposes)
+
+-- We may need more clues to distinguish foreign calls
+-- but this simple printer will do for now
+instance Outputable ForeignCall where
+ ppr (CCall cc) = ppr cc
+ ppr (DotNetCall dn) = ppr dn
+\end{code}
+
+
+\begin{code}
+data Safety
+ = PlaySafe -- Might invoke Haskell GC, or do a call back, or
+ -- switch threads, etc. So make sure things are
+ -- tidy before the call
+
+ | PlayRisky -- None of the above can happen; the call will return
+ -- without interacting with the runtime system at all
+ deriving( Eq, Show )
+ -- Show used just for Show Lex.Token, I think
+
+instance Outputable Safety where
+ ppr PlaySafe = empty
+ ppr PlayRisky = ptext SLIT("unsafe")
+
+playSafe PlaySafe = True
+playSafe PlayRisky = False
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsubsection{Calling C}
+%* *
+%************************************************************************
+
+\begin{code}
+data CCallSpec
+ = CCallSpec CCallTarget -- What to call
+ CCallConv -- Calling convention to use.
+ Safety
+ Bool -- True <=> really a "casm"
+ deriving( Eq )
+
+
+ccallIsCasm :: CCallSpec -> Bool
+ccallIsCasm (CCallSpec _ _ _ c_asm) = c_asm
+\end{code}
+
+The call target:
+
+\begin{code}
+data CCallTarget
+ = StaticTarget CLabelString -- An "unboxed" ccall# to `fn'.
+ | DynamicTarget -- First argument (an Addr#) is the function pointer
+ deriving( Eq )
+
+isDynamicTarget DynamicTarget = True
+isDynamicTarget (StaticTarget _) = False
+
+dynamicTarget :: CCallTarget
+dynamicTarget = DynamicTarget
+\end{code}
+
+
+Stuff to do with calling convention
+
+\begin{code}
+data CCallConv = CCallConv | StdCallConv
+ deriving( Eq )
+
+instance Outputable CCallConv where
+ ppr StdCallConv = ptext SLIT("__stdcall")
+ ppr CCallConv = ptext SLIT("_ccall")
+
+defaultCCallConv :: CCallConv
+defaultCCallConv = CCallConv
+
+ccallConvToInt :: CCallConv -> Int
+ccallConvToInt StdCallConv = 0
+ccallConvToInt CCallConv = 1
+\end{code}
+
+Generate the gcc attribute corresponding to the given
+calling convention (used by PprAbsC):
+
+ToDo: The stdcall calling convention is x86 (win32) specific,
+so perhaps we should emit a warning if it's being used on other
+platforms.
+
+\begin{code}
+ccallConvAttribute :: CCallConv -> String
+ccallConvAttribute StdCallConv = "__stdcall"
+ccallConvAttribute CCallConv = ""
+\end{code}
+
+Printing into C files:
+
+\begin{code}
+instance Outputable CCallSpec where
+ ppr (CCallSpec fun cconv safety is_casm)
+ = hcat [ ifPprDebug callconv
+ , text "__", ppr_dyn
+ , text before , ppr_fun , after]
+ where
+ callconv = text "{-" <> ppr cconv <> text "-}"
+ play_safe = playSafe safety
+
+ before
+ | is_casm && play_safe = "casm_GC ``"
+ | is_casm = "casm ``"
+ | play_safe = "ccall_GC "
+ | otherwise = "ccall "
+
+ after
+ | is_casm = text "''"
+ | otherwise = empty
+
+ ppr_dyn = case fun of
+ DynamicTarget -> text "dyn_"
+ _ -> empty
+
+ ppr_fun = case fun of
+ DynamicTarget -> text "\"\""
+ StaticTarget fn -> pprCLabelString fn
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsubsection{.NET stuff}
+%* *
+%************************************************************************
+
+\begin{code}
+data DotNetCallSpec = DotNetCallSpec
+ deriving( Eq )
+
+instance Outputable DotNetCallSpec where
+ ppr DotNetCallSpec = text "DotNet!"
+\end{code}
primOpOkForSpeculation, primOpIsCheap, primOpIsDupable,
primOpHasSideEffects,
- getPrimOpResultInfo, PrimOpResultInfo(..),
-
- CCall(..), CCallTarget(..), ccallMayGC, ccallIsCasm, pprCCallOp,
- isDynamicTarget, dynamicTarget, setCCallUnique
+ getPrimOpResultInfo, PrimOpResultInfo(..)
) where
#include "HsVersions.h"
import Demand ( wwLazy, wwPrim, wwStrict, StrictnessInfo(..) )
import Var ( TyVar )
-import CallConv ( CallConv, pprCallConv )
import Name ( Name, mkWiredInName )
import RdrName ( RdrName, mkRdrOrig )
import OccName ( OccName, pprOccName, mkVarOcc )
-import TyCon ( TyCon, tyConArity )
-import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, mkTyVarTys,
- mkTyConApp, typePrimRep,
+import TyCon ( TyCon )
+import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, typePrimRep,
splitFunTy_maybe, splitAlgTyConApp_maybe, splitTyConApp,
mkUTy, usOnce, usMany
)
-import Unique ( Unique, mkPrimOpIdUnique )
+import Unique ( mkPrimOpIdUnique )
import BasicTypes ( Arity, Boxity(..) )
-import CStrings ( CLabelString, pprCLabelString )
import PrelNames ( pREL_GHC, pREL_GHC_Name )
import Outputable
import Util ( zipWithEqual )
-- supplies:
-- data PrimOp = ...
#include "primop-data-decl.hs-incl"
- | CCallOp CCall -- and don't forget to add CCall
\end{code}
Used for the Ord instance
allThePrimOps :: [PrimOp]
allThePrimOps =
#include "primop-list.hs-incl"
--- Doesn't include CCall, which is really a family of primops
\end{code}
%************************************************************************
perform a heap check or they block.
\begin{code}
-primOpOutOfLine (CCallOp c_call) = ccallMayGC c_call
#include "primop-out-of-line.hs-incl"
\end{code}
\begin{code}
primOpHasSideEffects :: PrimOp -> Bool
-primOpHasSideEffects (CCallOp _) = True
#include "primop-has-side-effects.hs-incl"
\end{code}
\begin{code}
primOpNeedsWrapper :: PrimOp -> Bool
-primOpNeedsWrapper (CCallOp _) = True
#include "primop-needs-wrapper.hs-incl"
\end{code}
-- as required by the UsageSP inference.
primOpUsg :: PrimOp -> ([TyVar],[Type],Type)
-primOpUsg p@(CCallOp _) = mangle p [] mkM
#include "primop-usage.hs-incl"
-- Things with no Haskell pointers inside: in actuality, usages are
-- be out of line, or the code generator won't work.
getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo
-getPrimOpResultInfo (CCallOp _)
- = ReturnsAlg unboxedPairTyCon
getPrimOpResultInfo op
= case (primOpInfo op) of
Dyadic _ ty -> ReturnsPrim (typePrimRep ty)
Utils:
\begin{code}
-mkPrimTyApp :: [TyVar] -> PrimRep -> ([TyVar], Type)
- -- CharRep --> ([], Char#)
- -- StablePtrRep --> ([a], StablePtr# a)
-mkPrimTyApp tvs kind
- = (forall_tvs, mkTyConApp tycon (mkTyVarTys forall_tvs))
- where
- tycon = primRepTyCon kind
- forall_tvs = take (tyConArity tycon) tvs
-
dyadic_fun_ty ty = mkFunTys [ty, ty] ty
monadic_fun_ty ty = mkFunTy ty ty
compare_fun_ty ty = mkFunTys [ty, ty] boolTy
Output stuff:
\begin{code}
pprPrimOp :: PrimOp -> SDoc
-
-pprPrimOp (CCallOp c_call) = pprCCallOp c_call
pprPrimOp other_op
= getPprStyle $ \ sty ->
if ifaceStyle sty then -- For interfaces Print it qualified with PrelGHC.
\end{code}
-%************************************************************************
-%* *
-\subsubsection{CCalls}
-%* *
-%************************************************************************
-
-A special ``trap-door'' to use in making calls direct to C functions:
-\begin{code}
-data CCall
- = CCall CCallTarget
- Bool -- True <=> really a "casm"
- Bool -- True <=> might invoke Haskell GC
- CallConv -- calling convention to use.
- deriving( Eq )
-
-data CCallTarget
- = StaticTarget CLabelString -- An "unboxed" ccall# to `fn'.
- | DynamicTarget Unique -- First argument (an Addr#) is the function pointer
- -- (unique is used to generate a 'typedef' to cast
- -- the function pointer if compiling the ccall# down to
- -- .hc code - can't do this inline for tedious reasons.)
-
-instance Eq CCallTarget where
- (StaticTarget l1) == (StaticTarget l2) = l1 == l2
- (DynamicTarget _) == (DynamicTarget _) = True
- -- Ignore the arbitrary unique; this is important when comparing
- -- a dynamic ccall read from an interface file A.hi with the
- -- one constructed from A.hs, when deciding whether the interface
- -- has changed
- t1 == t2 = False
-
-ccallMayGC :: CCall -> Bool
-ccallMayGC (CCall _ _ may_gc _) = may_gc
-
-ccallIsCasm :: CCall -> Bool
-ccallIsCasm (CCall _ c_asm _ _) = c_asm
-
-isDynamicTarget (DynamicTarget _) = True
-isDynamicTarget (StaticTarget _) = False
-
-dynamicTarget :: CCallTarget
-dynamicTarget = DynamicTarget (panic "Unique in DynamicTarget not yet set")
- -- The unique is really only to do with code generation, so it
- -- is only set in CoreToStg; before then it's just an error message
-
-setCCallUnique :: CCall -> Unique -> CCall
-setCCallUnique (CCall (DynamicTarget _) is_asm may_gc cconv) uniq
- = CCall (DynamicTarget uniq) is_asm may_gc cconv
-setCCallUnique ccall uniq = ccall
-\end{code}
-
-\begin{code}
-pprCCallOp (CCall fun is_casm may_gc cconv)
- = hcat [ ifPprDebug callconv
- , text "__", ppr_dyn
- , text before , ppr_fun , after]
- where
- callconv = text "{-" <> pprCallConv cconv <> text "-}"
-
- before
- | is_casm && may_gc = "casm_GC ``"
- | is_casm = "casm ``"
- | may_gc = "ccall_GC "
- | otherwise = "ccall "
-
- after
- | is_casm = text "''"
- | otherwise = empty
-
- ppr_dyn = case fun of
- DynamicTarget _ -> text "dyn_"
- _ -> empty
-
- ppr_fun = case fun of
- DynamicTarget _ -> text "\"\""
- StaticTarget fn -> pprCLabelString fn
-\end{code}
wordTy,
wordTyCon,
- isFFIArgumentTy, -- :: DynFlags -> Bool -> Type -> Bool
+ isFFIArgumentTy, -- :: DynFlags -> Safety -> Type -> Bool
isFFIImportResultTy, -- :: DynFlags -> Type -> Bool
isFFIExportResultTy, -- :: Type -> Bool
isFFIExternalTy, -- :: Type -> Bool
import TysPrim
-- others:
+import ForeignCall ( Safety, playSafe )
import Constants ( mAX_TUPLE_SIZE )
import Module ( mkPrelModule )
import Name ( Name, nameRdrName, nameUnique, nameOccName,
foreignObjDataCon
= pcDataCon foreignObjDataConName
[] [] [foreignObjPrimTy] foreignObjTyCon
-
-isForeignObjTy :: Type -> Bool
-isForeignObjTy = isTyCon foreignObjTyConKey
\end{code}
\begin{code}
being the )
\begin{code}
-isFFIArgumentTy :: DynFlags -> Bool -> Type -> Bool
+isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool
-- Checks for valid argument type for a 'foreign import'
-isFFIArgumentTy dflags is_safe ty
- = checkRepTyCon (legalOutgoingTyCon dflags is_safe) ty
+isFFIArgumentTy dflags safety ty
+ = checkRepTyCon (legalOutgoingTyCon dflags safety) ty
isFFIExternalTy :: Type -> Bool
-- Types that are allowed as arguments of a 'foreign export'
| tc == unitTyCon = True
| otherwise = boxedMarshalableTyCon tc
-legalOutgoingTyCon :: DynFlags -> Bool -> TyCon -> Bool
+legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool
-- Checks validity of types going from Haskell -> external world
--- The boolean is true for a 'safe' call (when we don't want to
--- pass Haskell pointers to the world)
-legalOutgoingTyCon dflags be_safe tc
- | be_safe && getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey]
+legalOutgoingTyCon dflags safety tc
+ | playSafe safety && getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey]
= False
| otherwise
= marshalableTyCon dflags tc
do_expr (StgConApp con args)
= boxHigherOrderArgs (\args -> StgConApp con args) args
- do_expr (StgPrimApp con args res_ty)
- = boxHigherOrderArgs (\args -> StgPrimApp con args res_ty) args
+ do_expr (StgOpApp con args res_ty)
+ = boxHigherOrderArgs (\args -> StgOpApp con args res_ty) args
do_expr (StgSCC cc expr) -- Ha, we found a cost centre!
= collectCC cc `thenMM_`
)
import CostCentre ( CostCentre(..), IsCafCC(..), IsDupdCC(..) )
import Demand ( StrictnessMark(..) )
-import CallConv ( cCallConv )
import Type ( Kind, mkArrowKind, liftedTypeKind, openTypeKind, usageTypeKind )
import IdInfo ( InlinePragInfo(..) )
-import PrimOp ( CCall(..), CCallTarget(..) )
+import ForeignCall ( ForeignCall(..), CCallConv(..), CCallSpec(..), CCallTarget(..) )
import Lex
import RnMonad ( ParsedIface(..), ExportItem, IfaceDeprecs )
{ let
(is_dyn, is_casm, may_gc) = $2
- target | is_dyn = DynamicTarget (error "CCall dyn target bogus unique")
+ target | is_dyn = DynamicTarget
| otherwise = StaticTarget $3
- ccall = CCall target is_casm may_gc cCallConv
+ ccall = CCallSpec target CCallConv may_gc is_casm
in
- UfCCall ccall $4
+ UfFCall (CCall ccall) $4
}
ufExprFVs (UfVar n) = unitFV n
ufExprFVs (UfLit l) = emptyFVs
ufExprFVs (UfLitLit l ty) = extractHsTyNames ty
-ufExprFVs (UfCCall cc ty) = extractHsTyNames ty
+ufExprFVs (UfFCall cc ty) = extractHsTyNames ty
ufExprFVs (UfType ty) = extractHsTyNames ty
ufExprFVs (UfTuple tc es) = hsTupConFVs tc `plusFV` plusFVs (map ufExprFVs es)
ufExprFVs (UfLam v e) = ufBndrFVs v (ufExprFVs e)
= rnHsType (text "litlit") ty `thenRn` \ ty' ->
returnRn (UfLitLit l ty')
-rnCoreExpr (UfCCall cc ty)
+rnCoreExpr (UfFCall cc ty)
= rnHsType (text "ccall") ty `thenRn` \ ty' ->
- returnRn (UfCCall cc ty')
+ returnRn (UfFCall cc ty')
rnCoreExpr (UfTuple (HsTupCon _ boxity arity) args)
= mapRn rnCoreExpr args `thenRn` \ args' ->
\begin{code}
srtExpr :: SrtOffset -> StgExpr -> (StgExpr, SrtIds, SrtOffset)
-srtExpr off e@(StgApp f args) = (e, [], off)
-srtExpr off e@(StgLit l) = (e, [], off)
-srtExpr off e@(StgConApp con args) = (e, [], off)
-srtExpr off e@(StgPrimApp op args ty) = (e, [], off)
+srtExpr off e@(StgApp f args) = (e, [], off)
+srtExpr off e@(StgLit l) = (e, [], off)
+srtExpr off e@(StgConApp con args) = (e, [], off)
+srtExpr off e@(StgOpApp op args ty) = (e, [], off)
srtExpr off (StgSCC cc expr) =
srtExpr off expr =: \(expr, srt, off) ->
import SRT ( computeSRTs )
import CmdLineOpts ( DynFlags, DynFlag(..), dopt,
- opt_StgDoLetNoEscapes,
StgToDo(..), dopt_StgToDo
)
import Id ( Id )
import Module ( Module )
import ErrUtils ( doIfSet_dyn, dumpIfSet_dyn, showPass )
-import UniqSupply ( mkSplitUniqSupply, splitUniqSupply, UniqSupply )
-import IO ( hPutStr, stdout )
+import UniqSupply ( mkSplitUniqSupply, splitUniqSupply )
import Outputable
\end{code}
\begin{code}
statExpr :: StgExpr -> StatEnv
-statExpr (StgApp _ _) = countOne Applications
-statExpr (StgLit _) = countOne Literals
-statExpr (StgConApp _ _) = countOne ConstructorApps
-statExpr (StgPrimApp _ _ _) = countOne PrimitiveApps
-statExpr (StgSCC l e) = statExpr e
+statExpr (StgApp _ _) = countOne Applications
+statExpr (StgLit _) = countOne Literals
+statExpr (StgConApp _ _) = countOne ConstructorApps
+statExpr (StgOpApp _ _ _) = countOne PrimitiveApps
+statExpr (StgSCC l e) = statExpr e
statExpr (StgLetNoEscape lvs_whole lvs_rhss binds body)
= statBinding False{-not top-level-} binds `combineSE`
import VarEnv
import DataCon ( dataConWrapId )
import IdInfo ( OccInfo(..) )
-import TysPrim ( foreignObjPrimTyCon )
import Maybes ( maybeToBool )
import Name ( getOccName, isExternallyVisibleName, isDllName )
import OccName ( occNameUserString )
returnLne (new_let, fvs, escs)
\end{code}
-If we've got a case containing a _ccall_GC_ primop, we need to
-ensure that the arguments are kept live for the duration of the
-call. This only an issue
-
-\begin{code}
-isForeignObjArg :: Id -> Bool
-isForeignObjArg x = isId x && isForeignObjPrimTy (idType x)
-
-isForeignObjPrimTy ty
- = case splitTyConApp_maybe ty of
- Just (tycon, _) -> tycon == foreignObjPrimTyCon
- Nothing -> False
-\end{code}
-
\begin{code}
mkStgAlgAlts ty alts deflt
= case alts of
-- continuation, but it does no harm to just union the
-- two regardless.
+ res_ty = exprType (mkApps (Var f) args)
app = case globalIdDetails f of
- DataConId dc -> StgConApp dc args'
- PrimOpId op -> StgPrimApp op args' (exprType (mkApps (Var f) args))
+ DataConId dc -> StgConApp dc args'
+ PrimOpId op -> StgOpApp (StgPrimOp op) args' res_ty
+ FCallId call -> StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
_other -> StgApp f args'
in
where
con_ty = dataConRepType con
-lintStgExpr e@(StgPrimApp op args _)
+lintStgExpr e@(StgOpApp (StgFCallOp _ _) args res_ty)
+ = -- We don't have enough type information to check
+ -- the application; ToDo
+ mapMaybeL lintStgArg args `thenL` \ maybe_arg_tys ->
+ returnL (Just res_ty)
+
+lintStgExpr e@(StgOpApp (StgPrimOp op) args _)
= mapMaybeL lintStgArg args `thenL` \ maybe_arg_tys ->
case maybe_arg_tys of
Nothing -> returnL Nothing
\begin{code}
module StgSyn (
- GenStgArg(..),
+ GenStgArg(..),
GenStgLiveVars,
GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
StgBinding, StgExpr, StgRhs,
StgCaseAlts, StgCaseDefault,
+ -- StgOp
+ StgOp(..),
+
-- SRTs
SRT(..), noSRT,
import Id ( Id, idName, idPrimRep, idType )
import Name ( isDllName )
import Literal ( Literal, literalType, isLitLitLit, literalPrimRep )
+import ForeignCall ( ForeignCall )
import DataCon ( DataCon, dataConName )
import PrimOp ( PrimOp )
import Outputable
import Type ( Type )
import TyCon ( TyCon )
import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet )
+import Unique ( Unique )
import CmdLineOpts ( opt_SccProfilingOn )
\end{code}
| StgConApp DataCon
[GenStgArg occ] -- Saturated
- | StgPrimApp PrimOp
+ | StgOpApp StgOp -- Primitive op or foreign call
[GenStgArg occ] -- Saturated
Type -- Result type; we need to know the result type
-- so that we can assign result registers.
%************************************************************************
%* *
+\subsubsection{StgOp}
+%* *
+%************************************************************************
+
+An StgOp allows us to group together PrimOps and ForeignCalls.
+It's quite useful to move these around together, notably
+in StgOpApp and COpStmt.
+
+\begin{code}
+data StgOp = StgPrimOp PrimOp
+
+ | StgFCallOp ForeignCall Unique
+ -- The Unique is occasionally needed by the C pretty-printer
+ -- (which lacks a unique supply), notably when generating a
+ -- typedef for foreign-export-dynamic
+\end{code}
+
+
+%************************************************************************
+%* *
\subsubsection[Static Reference Tables]{@SRT@}
%* *
%************************************************************************
pprStgExpr (StgConApp con args)
= hsep [ ppr con, brackets (interppSP args)]
-pprStgExpr (StgPrimApp op args _)
- = hsep [ ppr op, brackets (interppSP args)]
+pprStgExpr (StgOpApp op args _)
+ = hsep [ pprStgOp op, brackets (interppSP args)]
pprStgExpr (StgLam _ bndrs body)
=sep [ char '\\' <+> ppr bndrs <+> ptext SLIT("->"),
pprStgDefault (StgBindDefault expr) = hang (hsep [ptext SLIT("DEFAULT"), ptext SLIT("->")])
4 (ppr expr)
+pprStgOp (StgPrimOp op) = ppr op
+pprStgOp (StgFCallOp op _) = ppr op
\end{code}
\begin{code}
tyConTheta, maybeTyConSingleCon, isDataTyCon,
isEnumerationTyCon, TyCon
)
-import Type ( TauType, ThetaType, PredType, mkTyVarTys, mkTyConApp,
+import Type ( ThetaType, mkTyVarTys, mkTyConApp,
isUnLiftedType, mkClassPred )
import Var ( TyVar )
import PrelNames
isFFILabelTy
)
import Type ( Type )
+import ForeignCall ( Safety )
import PrelNames ( hasKey, ioTyConKey )
import Outputable
let i = (mkLocalId nm sig_ty) in
returnTc (i, (ForeignDecl i FoLabel undefined ext_nm cconv src_loc))
-tcFImport fo@(ForeignDecl nm imp_exp@(FoImport isUnsafe) hs_ty ext_nm cconv src_loc) =
+tcFImport fo@(ForeignDecl nm imp_exp@(FoImport safety) hs_ty ext_nm cconv src_loc) =
tcAddSrcLoc src_loc $
tcAddErrCtxt (foreignDeclCtxt fo) $
in
case splitFunTys t_ty of
(arg_tys, res_ty) ->
- checkForeignImport (isDynamicExtName ext_nm) (not isUnsafe) ty arg_tys res_ty `thenTc_`
+ checkForeignImport (isDynamicExtName ext_nm) safety ty arg_tys res_ty `thenTc_`
let i = (mkLocalId nm ty) in
returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc))
\begin{code}
-checkForeignImport :: Bool -> Bool -> Type -> [Type] -> Type -> TcM ()
-checkForeignImport is_dynamic is_safe ty args res
+checkForeignImport :: Bool -> Safety -> Type -> [Type] -> Type -> TcM ()
+checkForeignImport is_dynamic safety ty args res
| is_dynamic =
-- * first arg has got to be an Addr
case args of
(x:xs) ->
getDOptsTc `thenTc` \ dflags ->
check (isFFIDynArgumentTy x) (illegalForeignTyErr True{-Arg-} ty) `thenTc_`
- mapTc (checkForeignArg (isFFIArgumentTy dflags is_safe)) xs `thenTc_`
+ mapTc (checkForeignArg (isFFIArgumentTy dflags safety)) xs `thenTc_`
checkForeignRes True {-NonIO ok-} (isFFIImportResultTy dflags) res
| otherwise =
getDOptsTc `thenTc` \ dflags ->
- mapTc (checkForeignArg (isFFIArgumentTy dflags is_safe)) args `thenTc_`
+ mapTc (checkForeignArg (isFFIArgumentTy dflags safety)) args `thenTc_`
checkForeignRes True {-NonIO ok-} (isFFIImportResultTy dflags) res
checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM ()
import Id ( Id, mkVanillaGlobal, mkLocalId, idName, isDataConWrapId_maybe )
import Module ( Module )
-import MkId ( mkCCallOpId )
+import MkId ( mkFCallId )
import IdInfo
import DataCon ( DataCon, dataConId, dataConSig, dataConArgTys )
import Type ( mkTyVarTys, splitAlgTyConApp_maybe )
= tcIfaceType ty `thenTc` \ ty' ->
returnTc (Lit (MachLitLit lit ty'))
-tcCoreExpr (UfCCall cc ty)
+tcCoreExpr (UfFCall cc ty)
= tcIfaceType ty `thenTc` \ ty' ->
tcGetUnique `thenNF_Tc` \ u ->
- returnTc (Var (mkCCallOpId u cc ty'))
+ returnTc (Var (mkFCallId u cc ty'))
tcCoreExpr (UfTuple (HsTupCon _ boxity arity) args)
= mapTc tcCoreExpr args `thenTc` \ args' ->
import Generics ( validGenericInstanceType )
import Module ( Module, foldModuleEnv )
import Name ( getSrcLoc )
-import NameSet ( emptyNameSet, unitNameSet, nameSetToList )
+import NameSet ( unitNameSet, nameSetToList )
import PrelInfo ( eRROR_ID )
import PprType ( pprClassPred, pprPred )
import TyCon ( TyCon, isSynTyCon )
import Subst ( mkTopTyVarSubst, substTheta )
import VarSet ( varSetElems )
import TysWiredIn ( genericTyCons, isFFIArgumentTy, isFFIImportResultTy )
+import ForeignCall ( Safety(..) )
import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey )
import Name ( Name )
import SrcLoc ( SrcLoc )
maybe_tycon_app = splitTyConApp_maybe first_inst_tau
Just (tycon, arg_tys) = maybe_tycon_app
- ccallable_type dflags ty = isFFIArgumentTy dflags False {- Not safe call -} ty
+ ccallable_type dflags ty = isFFIArgumentTy dflags PlayRisky ty
creturnable_type ty = isFFIImportResultTy dflags ty
check_tyvars dflags clas inst_taus
import TcMonad
import TcMonoType ( kcHsSigTypes, tcScopedTyVars, checkSigTyVars, tcHsSigType, sigPatCtxt )
import Inst ( LIE, isEmptyLIE, plusLIE, emptyLIE, plusLIEs, lieToList )
-import TcEnv ( TcId, tcLookupLocalIds, tcExtendTyVarEnv, tcExtendLocalValEnv, tcExtendGlobalTyVars,
+import TcEnv ( TcId, tcLookupLocalIds, tcExtendLocalValEnv, tcExtendGlobalTyVars,
tcInLocalScope )
import TcPat ( tcPat, tcMonoPatBndr, polyPatSig )
import TcType ( TcType, newTyVarTy )
import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
import TcUnify ( unifyFunTy, unifyTauTy )
import Name ( Name )
-import TysWiredIn ( boolTy, mkListTy )
+import TysWiredIn ( boolTy )
import Id ( idType )
import BasicTypes ( RecFlag(..) )
import Type ( tyVarsOfType, isTauTy, mkFunTy,
import TcHsSyn ( TypecheckedRuleDecl, mkHsLet )
import TcMonad
import TcSimplify ( tcSimplifyToDicts, tcSimplifyInferCheck )
-import TcType ( zonkTcTyVarToTyVar, newTyVarTy )
+import TcType ( newTyVarTy )
import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar )
import TcMonoType ( kcHsSigTypes, tcHsSigType, tcScopedTyVars, checkSigTyVars )
import TcExpr ( tcExpr )
#include "HsVersions.h"
-import HsSyn ( TyClDecl(..), ConDecl(..), ConDetails(..), BangType(..),
+import HsSyn ( TyClDecl(..), ConDecl(..), ConDetails(..),
getBangType, getBangStrictness, conDetailsTys
)
import RnHsSyn ( RenamedTyClDecl, RenamedConDecl, RenamedContext )
projects / ghc-hetmet.git / commitdiff