diff options
| -rw-r--r-- | compiler/typecheck/TcForeign.lhs | 11 | ||||
| -rw-r--r-- | compiler/typecheck/TcType.lhs | 34 |
2 files changed, 45 insertions, 0 deletions
diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 35f627e48d..23756d97c3 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -151,6 +151,16 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction t checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty return idecl + | cconv == PrimCallConv = do + checkCg (checkCOrAsmOrDotNetOrInterp) + checkCTarget target + check (safety == PlayRisky) + (text "A `foreign import prim' must always be annotated as `unsafe'") + dflags <- getDOpts + checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys + -- prim import result is more liberal, allows (#,,#) + checkForeignRes nonIOok (isFFIPrimResultTy dflags) res_ty + return idecl | otherwise = do -- Normal foreign import checkCg (checkCOrAsmOrDotNetOrInterp) checkCConv cconv @@ -348,6 +358,7 @@ checkCConv StdCallConv = return () #else checkCConv StdCallConv = addErrTc (text "calling convention not supported on this platform: stdcall") #endif +checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only be used with `foreign import'") checkCConv CmmCallConv = panic "checkCConv CmmCallConv" \end{code} diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 738f1cd009..f50b9b085c 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -84,6 +84,8 @@ module TcType ( isFFIExternalTy, -- :: Type -> Bool isFFIDynArgumentTy, -- :: Type -> Bool isFFIDynResultTy, -- :: Type -> Bool + isFFIPrimArgumentTy, -- :: DynFlags -> Type -> Bool + isFFIPrimResultTy, -- :: DynFlags -> Type -> Bool isFFILabelTy, -- :: Type -> Bool isFFIDotnetTy, -- :: DynFlags -> Type -> Bool isFFIDotnetObjTy, -- :: Type -> Bool @@ -1228,6 +1230,18 @@ isFFILabelTy :: Type -> Bool -- or a newtype of either. isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey] +isFFIPrimArgumentTy :: DynFlags -> Type -> Bool +-- Checks for valid argument type for a 'foreign import prim' +-- Currently they must all be simple unlifted types. +isFFIPrimArgumentTy dflags ty + = checkRepTyCon (legalFIPrimArgTyCon dflags) ty + +isFFIPrimResultTy :: DynFlags -> Type -> Bool +-- Checks for valid result type for a 'foreign import prim' +-- Currently it must be an unlifted type, including unboxed tuples. +isFFIPrimResultTy dflags ty + = checkRepTyCon (legalFIPrimResultTyCon dflags) ty + isFFIDotnetTy :: DynFlags -> Type -> Bool isFFIDotnetTy dflags ty = checkRepTyCon (\ tc -> (legalFIResultTyCon dflags tc || @@ -1353,6 +1367,26 @@ boxedMarshalableTyCon tc , stablePtrTyConKey , boolTyConKey ] + +legalFIPrimArgTyCon :: DynFlags -> TyCon -> Bool +-- Check args of 'foreign import prim', only allow simple unlifted types. +-- Strictly speaking it is unnecessary to ban unboxed tuples here since +-- currently they're of the wrong kind to use in function args anyway. +legalFIPrimArgTyCon dflags tc + = dopt Opt_UnliftedFFITypes dflags + && isUnLiftedTyCon tc + && not (isUnboxedTupleTyCon tc) + +legalFIPrimResultTyCon :: DynFlags -> TyCon -> Bool +-- Check result type of 'foreign import prim'. Allow simple unlifted +-- types and also unboxed tuple result types '... -> (# , , #)' +legalFIPrimResultTyCon dflags tc + = dopt Opt_UnliftedFFITypes dflags + && isUnLiftedTyCon tc + && (isUnboxedTupleTyCon tc + || case tyConPrimRep tc of -- Note [Marshalling VoidRep] + VoidRep -> False + _ -> True) \end{code} Note [Marshalling VoidRep] |