diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/codeGen/StgCmmExpr.hs | 2 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmForeign.hs | 166 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmPrim.hs | 4 | ||||
| -rw-r--r-- | compiler/stgSyn/CoreToStg.hs | 2 | ||||
| -rw-r--r-- | compiler/stgSyn/StgSyn.hs | 10 |
5 files changed, 139 insertions, 45 deletions
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 70a044a7ab..b49cee39c2 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -577,7 +577,7 @@ isSimpleScrut _ _ = return False isSimpleOp :: StgOp -> [StgArg] -> FCode Bool -- True iff the op cannot block or allocate -isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe) +isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _ _) _ = return $! not (playSafe safe) -- dataToTag# evalautes its argument, see Note [dataToTag#] in primops.txt.pp isSimpleOp (StgPrimOp DataToTagOp) _ = return False isSimpleOp (StgPrimOp op) stg_args = do diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index c1103e7d77..45e5733fc1 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -34,7 +34,6 @@ import CmmUtils import MkGraph import Type import RepType -import TysPrim import CLabel import SMRep import ForeignCall @@ -44,20 +43,26 @@ import Outputable import UniqSupply import BasicTypes +import TyCoRep +import TysPrim +import Util (zipEqual) + import Control.Monad ----------------------------------------------------------------------------- -- Code generation for Foreign Calls ----------------------------------------------------------------------------- --- | emit code for a foreign call, and return the results to the sequel. --- +-- | Emit code for a foreign call, and return the results to the sequel. +-- Precondition: the length of the arguments list is the same as the +-- arity of the foreign function. cgForeignCall :: ForeignCall -- the op + -> Type -- type of foreign function -> [StgArg] -- x,y arguments -> Type -- result type -> FCode ReturnKind -cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty +cgForeignCall (CCall (CCallSpec target cconv safety)) typ stg_args res_ty = do { dflags <- getDynFlags ; let -- in the stdcall calling convention, the symbol needs @size appended -- to it, where size is the total number of bytes of arguments. We @@ -70,7 +75,7 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty -- ToDo: this might not be correct for 64-bit API arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType dflags arg) (wORD_SIZE dflags) - ; cmm_args <- getFCallArgs stg_args + ; cmm_args <- getFCallArgs stg_args typ ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty ; let ((call_args, arg_hints), cmm_target) = case target of @@ -492,43 +497,128 @@ stack_SP dflags = closureField dflags (oFFSET_StgStack_sp dflags) closureField :: DynFlags -> ByteOff -> ByteOff closureField dflags off = off + fixedHdrSize dflags --- ----------------------------------------------------------------------------- +-- Note [Unlifted boxed arguments to foreign calls] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- -- For certain types passed to foreign calls, we adjust the actual --- value passed to the call. For ByteArray#/Array# we pass the --- address of the actual array, not the address of the heap object. - -getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)] +-- value passed to the call. For ByteArray#, Array#, SmallArray#, +-- and ArrayArray#, we pass the address of the array's payload, not +-- the address of the heap object. For example, consider +-- foreign import "c_foo" foo :: ByteArray# -> Int# -> IO () +-- At a Haskell call like `foo x y`, we'll generate a C call that +-- is more like +-- c_foo( x+8, y ) +-- where the "+8" takes the heap pointer (x :: ByteArray#) and moves +-- it past the header words of the ByteArray object to point directly +-- to the data inside the ByteArray#. (The exact offset depends +-- on the target architecture and on profiling) By contrast, (y :: Int#) +-- requires no such adjustment. +-- +-- This adjustment is performed by 'add_shim'. The size of the +-- adjustment depends on the type of heap object. But +-- how can we determine that type? There are two available options. +-- We could use the types of the actual values that the foreign call +-- has been applied to, or we could use the types present in the +-- foreign function's type. Prior to GHC 8.10, we used the former +-- strategy since it's a little more simple. However, in issue #16650 +-- and more compellingly in the comments of +-- https://gitlab.haskell.org/ghc/ghc/merge_requests/939, it was +-- demonstrated that this leads to bad behavior in the presence +-- of unsafeCoerce#. Returning to the above example, suppose the +-- Haskell call looked like +-- foo (unsafeCoerce# p) +-- where the types of expressions comprising the arguments are +-- p :: (Any :: TYPE 'UnliftedRep) +-- i :: Int# +-- so that the unsafe-coerce is between Any and ByteArray#. +-- These two types have the same kind (they are both represented by +-- a heap pointer) so no GC errors will occur if we do this unsafe coerce. +-- By the time this gets to the code generator the cast has been +-- discarded so we have +-- foo p y +-- But we *must* adjust the pointer to p by a ByteArray# shim, +-- *not* by an Any shim (the Any shim involves no offset at all). +-- +-- To avoid this bad behavior, we adopt the second strategy: use +-- the types present in the foreign function's type. +-- In collectStgFArgTypes, we convert the foreign function's +-- type to a list of StgFArgType. Then, in add_shim, we interpret +-- these as numeric offsets. + +getFCallArgs :: + [StgArg] + -> Type -- the type of the foreign function + -> FCode [(CmmExpr, ForeignHint)] -- (a) Drop void args -- (b) Add foreign-call shim code -- It's (b) that makes this differ from getNonVoidArgAmodes - -getFCallArgs args - = do { mb_cmms <- mapM get args +-- Precondition: args and typs have the same length +-- See Note [Unlifted boxed arguments to foreign calls] +getFCallArgs args typ + = do { mb_cmms <- mapM get (zipEqual "getFCallArgs" args (collectStgFArgTypes typ)) ; return (catMaybes mb_cmms) } where - get arg | null arg_reps - = return Nothing - | otherwise - = do { cmm <- getArgAmode (NonVoid arg) - ; dflags <- getDynFlags - ; return (Just (add_shim dflags arg_ty cmm, hint)) } - where - arg_ty = stgArgType arg - arg_reps = typePrimRep arg_ty - hint = typeForeignHint arg_ty - -add_shim :: DynFlags -> Type -> CmmExpr -> CmmExpr -add_shim dflags arg_ty expr - | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon - = cmmOffsetB dflags expr (arrPtrsHdrSize dflags) - - | tycon == smallArrayPrimTyCon || tycon == smallMutableArrayPrimTyCon - = cmmOffsetB dflags expr (smallArrPtrsHdrSize dflags) - - | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon - = cmmOffsetB dflags expr (arrWordsHdrSize dflags) - - | otherwise = expr + get (arg,typ) + | null arg_reps + = return Nothing + | otherwise + = do { cmm <- getArgAmode (NonVoid arg) + ; dflags <- getDynFlags + ; return (Just (add_shim dflags typ cmm, hint)) } + where + arg_ty = stgArgType arg + arg_reps = typePrimRep arg_ty + hint = typeForeignHint arg_ty + +-- The minimum amount of information needed to determine +-- the offset to apply to an argument to a foreign call. +-- See Note [Unlifted boxed arguments to foreign calls] +data StgFArgType + = StgPlainType + | StgArrayType + | StgSmallArrayType + | StgByteArrayType + +-- See Note [Unlifted boxed arguments to foreign calls] +add_shim :: DynFlags -> StgFArgType -> CmmExpr -> CmmExpr +add_shim dflags ty expr = case ty of + StgPlainType -> expr + StgArrayType -> cmmOffsetB dflags expr (arrPtrsHdrSize dflags) + StgSmallArrayType -> cmmOffsetB dflags expr (smallArrPtrsHdrSize dflags) + StgByteArrayType -> cmmOffsetB dflags expr (arrWordsHdrSize dflags) + +-- From a function, extract information needed to determine +-- the offset of each argument when used as a C FFI argument. +-- See Note [Unlifted boxed arguments to foreign calls] +collectStgFArgTypes :: Type -> [StgFArgType] +collectStgFArgTypes = go [] + where + -- Skip foralls + go bs (ForAllTy _ res) = go bs res + go bs (AppTy{}) = reverse bs + go bs (TyConApp{}) = reverse bs + go bs (LitTy{}) = reverse bs + go bs (TyVarTy{}) = reverse bs + go _ (CastTy{}) = panic "myCollectTypeArgs: CastTy" + go _ (CoercionTy{}) = panic "myCollectTypeArgs: CoercionTy" + go bs (FunTy {ft_arg = arg, ft_res=res}) = + go (typeToStgFArgType arg:bs) res + +-- Choose the offset based on the type. For anything other +-- than an unlifted boxed type, there is no offset. +-- See Note [Unlifted boxed arguments to foreign calls] +typeToStgFArgType :: Type -> StgFArgType +typeToStgFArgType typ + | tycon == arrayPrimTyCon = StgArrayType + | tycon == mutableArrayPrimTyCon = StgArrayType + | tycon == arrayArrayPrimTyCon = StgArrayType + | tycon == mutableArrayArrayPrimTyCon = StgArrayType + | tycon == smallArrayPrimTyCon = StgSmallArrayType + | tycon == smallMutableArrayPrimTyCon = StgSmallArrayType + | tycon == byteArrayPrimTyCon = StgByteArrayType + | tycon == mutableByteArrayPrimTyCon = StgByteArrayType + | otherwise = StgPlainType where - tycon = tyConAppTyCon (unwrapType arg_ty) - -- should be a tycon app, since this is a foreign call + -- should be a tycon app, since this is a foreign call + tycon = tyConAppTyCon (unwrapType typ) + diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 0a667560f7..5e3d03579a 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -71,8 +71,8 @@ cgOpApp :: StgOp -- The op -> FCode ReturnKind -- Foreign calls -cgOpApp (StgFCallOp fcall _) stg_args res_ty - = cgForeignCall fcall stg_args res_ty +cgOpApp (StgFCallOp fcall ty _) stg_args res_ty + = cgForeignCall fcall ty stg_args res_ty -- Note [Foreign call results] -- tagToEnum# is special: we need to pull the constructor diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs index 7f60bb21d2..12766e90d4 100644 --- a/compiler/stgSyn/CoreToStg.hs +++ b/compiler/stgSyn/CoreToStg.hs @@ -539,7 +539,7 @@ coreToStgApp _ f args ticks = do -- A regular foreign call. FCallId call -> ASSERT( saturated ) - StgOpApp (StgFCallOp call (idUnique f)) args' res_ty + StgOpApp (StgFCallOp call (idType f) (idUnique f)) args' res_ty TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args') _other -> StgApp f args' diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs index 3a6cf3f133..274b0696fb 100644 --- a/compiler/stgSyn/StgSyn.hs +++ b/compiler/stgSyn/StgSyn.hs @@ -686,10 +686,14 @@ data StgOp | StgPrimCallOp PrimCall - | StgFCallOp ForeignCall Unique + | StgFCallOp ForeignCall Type 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 + -- typedef for foreign-export-dynamic. The Type, which is + -- obtained from the foreign import declaration itself, is + -- needed by the stg-to-cmm pass to determine the offset to + -- apply to unlifted boxed arguments in StgCmmForeign. + -- See Note [Unlifted boxed arguments to foreign calls] {- ************************************************************************ @@ -860,7 +864,7 @@ pprStgAlt indent (con, params, expr) pprStgOp :: StgOp -> SDoc pprStgOp (StgPrimOp op) = ppr op pprStgOp (StgPrimCallOp op)= ppr op -pprStgOp (StgFCallOp op _) = ppr op +pprStgOp (StgFCallOp op _ _) = ppr op instance Outputable AltType where ppr PolyAlt = text "Polymorphic" |