Implement a capi calling convention; fixes #2979
authorIan Lynagh <igloo@earth.li>
Sat, 26 Nov 2011 14:54:47 +0000 (14:54 +0000)
committerIan Lynagh <igloo@earth.li>
Mon, 28 Nov 2011 17:04:01 +0000 (17:04 +0000)
In GHC, this provides an easy way to call a C function via a C wrapper.
This is important when the function is really defined by CPP.

Requires the new CApiFFI extension.

Not documented yet, as it's still an experimental feature at this stage.

compiler/cmm/PprC.hs
compiler/deSugar/DsForeign.lhs
compiler/llvmGen/LlvmCodeGen/CodeGen.hs
compiler/main/DynFlags.hs
compiler/parser/Lexer.x
compiler/parser/Parser.y.pp
compiler/prelude/ForeignCall.lhs
compiler/typecheck/TcForeign.lhs

index fc97be2..4f8a061 100644 (file)
@@ -845,6 +845,7 @@ pprCall platform ppr_fn cconv results args _
 -- change in the future...
 is_cishCC :: CCallConv -> Bool
 is_cishCC CCallConv    = True
+is_cishCC CApiConv     = True
 is_cishCC StdCallConv  = True
 is_cishCC CmmCallConv  = False
 is_cishCC PrimCallConv = False
index 75c2dc4..6f9bbc2 100644 (file)
@@ -125,8 +125,8 @@ dsFImport :: Id
           -> Coercion
           -> ForeignImport
           -> DsM ([Binding], SDoc, SDoc)
-dsFImport id co (CImport cconv safety _ spec) = do
-    (ids, h, c) <- dsCImport id co spec cconv safety
+dsFImport id co (CImport cconv safety header spec) = do
+    (ids, h, c) <- dsCImport id co spec cconv safety header
     return (ids, h, c)
 
 dsCImport :: Id
@@ -134,8 +134,9 @@ dsCImport :: Id
           -> CImportSpec
           -> CCallConv
           -> Safety
+          -> FastString -- header
           -> DsM ([Binding], SDoc, SDoc)
-dsCImport id co (CLabel cid) cconv _ = do
+dsCImport id co (CLabel cid) cconv _ = do
    let ty = pFst $ coercionKind co
        fod = case tyConAppTyCon_maybe ty of
              Just tycon
@@ -151,11 +152,11 @@ dsCImport id co (CLabel cid) cconv _ = do
     in
     return ([(id, rhs')], empty, empty)
 
-dsCImport id co (CFunction target) cconv@PrimCallConv safety
+dsCImport id co (CFunction target) cconv@PrimCallConv safety _
   = dsPrimCall id co (CCall (CCallSpec target cconv safety))
-dsCImport id co (CFunction target) cconv safety
-  = dsFCall id co (CCall (CCallSpec target cconv safety))
-dsCImport id co CWrapper cconv _
+dsCImport id co (CFunction target) cconv safety header
+  = dsFCall id co (CCall (CCallSpec target cconv safety)) header
+dsCImport id co CWrapper cconv _ _
   = dsFExportDynamic id co cconv
 
 -- For stdcall labels, if the type was a FunPtr or newtype thereof,
@@ -181,8 +182,9 @@ fun_type_arg_stdcall_info _other_conv _
 %************************************************************************
 
 \begin{code}
-dsFCall :: Id -> Coercion -> ForeignCall -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
-dsFCall fn_id co fcall = do
+dsFCall :: Id -> Coercion -> ForeignCall -> FastString
+        -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
+dsFCall fn_id co fcall headerFilename = do
     let
         ty                   = pFst $ coercionKind co
         (tvs, fun_ty)        = tcSplitForAllTys ty
@@ -200,10 +202,48 @@ dsFCall fn_id co fcall = do
 
     ccall_uniq <- newUnique
     work_uniq  <- newUnique
+
+    (fcall', cDoc) <-
+              case fcall of
+              CCall (CCallSpec (StaticTarget cName mPackageId) CApiConv safety) ->
+               do fcall_uniq <- newUnique
+                  let wrapperName = mkFastString "ghc_wrapper_" `appendFS`
+                                    mkFastString (showSDoc (ppr fcall_uniq)) `appendFS`
+                                    mkFastString "_" `appendFS`
+                                    cName
+                      fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageId) CApiConv safety)
+                      c = include
+                       $$ fun_proto <+> braces (cRet <> semi)
+                      include
+                       | nullFS headerFilename = empty
+                       | otherwise = text "#include <" <> ftext headerFilename <> text ">"
+                      fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes
+                      cRet
+                       | isVoidRes =                   cCall
+                       | otherwise = text "return" <+> cCall
+                      cCall = ppr cName <> parens argVals
+                      raw_res_ty = case tcSplitIOType_maybe io_res_ty of
+                                   Just (_ioTyCon, res_ty) -> res_ty
+                                   Nothing                 -> io_res_ty
+                      isVoidRes = raw_res_ty `eqType` unitTy
+                      cResType | isVoidRes = text "void"
+                               | otherwise = showStgType raw_res_ty
+                      pprCconv = ccallConvAttribute CApiConv
+                      argTypes
+                       | null arg_tys = text "void"
+                       | otherwise = hsep $ punctuate comma
+                                         [ showStgType t <+> char 'a' <> int n
+                                         | (t, n) <- zip arg_tys [1..] ]
+                      argVals = hsep $ punctuate comma
+                                    [ char 'a' <> int n
+                                    | (_, n) <- zip arg_tys [1..] ]
+                  return (fcall', c)
+              _ ->
+                  return (fcall, empty)
     let
         -- Build the worker
         worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
-        the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty
+        the_ccall_app = mkFCall ccall_uniq fcall' val_args ccall_result_ty
         work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
         work_id       = mkSysLocal (fsLit "$wccall") work_uniq worker_ty
 
@@ -214,7 +254,7 @@ dsFCall fn_id co fcall = do
         wrap_rhs'    = Cast wrap_rhs co
         fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineUnfolding (Just (length args)) wrap_rhs'
 
-    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, empty)
+    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc)
 \end{code}
 
 
index b2ad4c5..b039d39 100644 (file)
@@ -239,6 +239,7 @@ genCall env target res args ret = do
                             ArchX86_64 -> CC_X86_Stdcc
                             _          -> CC_Ccc
             CCallConv    -> CC_Ccc
+            CApiConv     -> CC_Ccc
             PrimCallConv -> CC_Ccc
             CmmCallConv  -> panic "CmmCallConv not supported here!"
 
index fce75b0..9d6d15c 100644 (file)
@@ -378,6 +378,7 @@ data ExtensionFlag
    | Opt_ForeignFunctionInterface
    | Opt_UnliftedFFITypes
    | Opt_InterruptibleFFI
+   | Opt_CApiFFI
    | Opt_GHCForeignImportPrim
    | Opt_ParallelArrays           -- Syntactic support for parallel arrays
    | Opt_Arrows                   -- Arrow-notation syntax
@@ -1898,6 +1899,7 @@ xFlags = [
   ( "ForeignFunctionInterface",         Opt_ForeignFunctionInterface, nop ),
   ( "UnliftedFFITypes",                 Opt_UnliftedFFITypes, nop ),
   ( "InterruptibleFFI",                 Opt_InterruptibleFFI, nop ),
+  ( "CApiFFI",                          Opt_CApiFFI, nop ),
   ( "GHCForeignImportPrim",             Opt_GHCForeignImportPrim, nop ),
   ( "LiberalTypeSynonyms",              Opt_LiberalTypeSynonyms, nop ),
   ( "Rank2Types",                       Opt_Rank2Types, nop ),
index 1486b64..fa73be0 100644 (file)
@@ -457,6 +457,7 @@ data Token
   | ITunsafe
   | ITstdcallconv
   | ITccallconv
+  | ITcapiconv
   | ITprimcallconv
   | ITmdo
   | ITfamily
@@ -642,6 +643,7 @@ reservedWordsFM = listToUFM $
          ( "unsafe",         ITunsafe,        bit ffiBit),
          ( "stdcall",        ITstdcallconv,   bit ffiBit),
          ( "ccall",          ITccallconv,     bit ffiBit),
+         ( "capi",           ITcapiconv,      bit cApiFfiBit),
          ( "prim",           ITprimcallconv,  bit ffiBit),
 
          ( "rec",            ITrec,           bit recBit),
@@ -1754,6 +1756,8 @@ ffiBit :: Int
 ffiBit= 0
 interruptibleFfiBit :: Int
 interruptibleFfiBit = 1
+cApiFfiBit :: Int
+cApiFfiBit = 2
 parrBit :: Int
 parrBit = 3
 arrowsBit :: Int
@@ -1879,6 +1883,7 @@ mkPState flags buf loc =
     where
       bitmap =     ffiBit                      `setBitIf` xopt Opt_ForeignFunctionInterface flags
                .|. interruptibleFfiBit         `setBitIf` xopt Opt_InterruptibleFFI         flags
+               .|. cApiFfiBit                  `setBitIf` xopt Opt_CApiFFI                  flags
                .|. parrBit                     `setBitIf` xopt Opt_ParallelArrays           flags
                .|. arrowsBit                   `setBitIf` xopt Opt_Arrows                   flags
                .|. thBit                       `setBitIf` xopt Opt_TemplateHaskell          flags
index c07714d..8a57504 100644 (file)
@@ -244,6 +244,7 @@ incorrect.
  'family'       { L _ ITfamily }
  'stdcall'      { L _ ITstdcallconv }
  'ccall'        { L _ ITccallconv }
+ 'capi'         { L _ ITcapiconv }
  'prim'         { L _ ITprimcallconv }
  'proc'         { L _ ITproc }          -- for arrow notation extension
  'rec'          { L _ ITrec }           -- for arrow notation extension
@@ -922,6 +923,7 @@ fdecl : 'import' callconv safety fspec
 callconv :: { CCallConv }
           : 'stdcall'                   { StdCallConv }
           | 'ccall'                     { CCallConv   }
+          | 'capi'                      { CApiConv    }
           | 'prim'                      { PrimCallConv}
 
 safety :: { Safety }
@@ -1945,6 +1947,7 @@ special_id
         | 'dynamic'             { L1 (fsLit "dynamic") }
         | 'stdcall'             { L1 (fsLit "stdcall") }
         | 'ccall'               { L1 (fsLit "ccall") }
+        | 'capi'                { L1 (fsLit "capi") }
         | 'prim'                { L1 (fsLit "prim") }
         | 'group'               { L1 (fsLit "group") }
 
index 458e7c6..f959fb0 100644 (file)
@@ -151,13 +151,15 @@ platforms.
 See: http://www.programmersheaven.com/2/Calling-conventions
 
 \begin{code}
-data CCallConv = CCallConv | StdCallConv | CmmCallConv | PrimCallConv
+data CCallConv = CCallConv | CApiConv | StdCallConv
+               | CmmCallConv | PrimCallConv
   deriving (Eq, Data, Typeable)
   {-! derive: Binary !-}
 
 instance Outputable CCallConv where
   ppr StdCallConv = ptext (sLit "stdcall")
   ppr CCallConv   = ptext (sLit "ccall")
+  ppr CApiConv    = ptext (sLit "capi")
   ppr CmmCallConv = ptext (sLit "C--")
   ppr PrimCallConv = ptext (sLit "prim")
 
@@ -167,6 +169,7 @@ defaultCCallConv = CCallConv
 ccallConvToInt :: CCallConv -> Int
 ccallConvToInt StdCallConv = 0
 ccallConvToInt CCallConv   = 1
+ccallConvToInt CApiConv    = panic "ccallConvToInt CApiConv"
 ccallConvToInt (CmmCallConv {})  = panic "ccallConvToInt CmmCallConv"
 ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv"
 \end{code}
@@ -178,6 +181,7 @@ calling convention (used by PprAbsC):
 ccallConvAttribute :: CCallConv -> SDoc
 ccallConvAttribute StdCallConv       = text "__attribute__((__stdcall__))"
 ccallConvAttribute CCallConv         = empty
+ccallConvAttribute CApiConv          = empty
 ccallConvAttribute (CmmCallConv {})  = panic "ccallConvAttribute CmmCallConv"
 ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv"
 \end{code}
@@ -294,11 +298,14 @@ instance Binary CCallConv where
             putByte bh 2
     put_ bh CmmCallConv = do
             putByte bh 3
+    put_ bh CApiConv = do
+            putByte bh 4
     get bh = do
             h <- getByte bh
             case h of
               0 -> do return CCallConv
               1 -> do return StdCallConv
               2 -> do return PrimCallConv
-              _ -> do return CmmCallConv
+              3 -> do return CmmCallConv
+              _ -> do return CApiConv
 \end{code}
index 5a4bf77..6bc5a4f 100644 (file)
@@ -453,6 +453,7 @@ Calling conventions
 \begin{code}
 checkCConv :: CCallConv -> TcM ()
 checkCConv CCallConv    = return ()
+checkCConv CApiConv     = return ()
 checkCConv StdCallConv  = do dflags <- getDOpts
                              let platform = targetPlatform dflags
                              unless (platformArch platform == ArchX86) $