Implement "value" imports with the CAPI
authorIan Lynagh <igloo@earth.li>
Sun, 26 Feb 2012 01:46:06 +0000 (01:46 +0000)
committerIan Lynagh <igloo@earth.li>
Sun, 26 Feb 2012 13:04:44 +0000 (13:04 +0000)
This allows us to import values (i.e. non-functions) with the CAPI.
This means we can access values even if (on some or all platforms)
they are simple #defines.

15 files changed:
compiler/codeGen/CgForeignCall.hs
compiler/codeGen/StgCmmForeign.hs
compiler/coreSyn/MkExternalCore.lhs
compiler/deSugar/DsCCall.lhs
compiler/deSugar/DsForeign.lhs
compiler/deSugar/DsMeta.hs
compiler/ghci/ByteCodeGen.lhs
compiler/hsSyn/HsDecls.lhs
compiler/parser/ParserCore.y
compiler/parser/RdrHsSyn.lhs
compiler/prelude/ForeignCall.lhs
compiler/rename/RnSource.lhs
compiler/stgSyn/CoreToStg.lhs
compiler/typecheck/TcForeign.lhs
docs/users_guide/ffi-chap.xml

index 09636bc..16e77ec 100644 (file)
@@ -78,9 +78,11 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
   where
       (call_args, cmm_target)
         = case target of
+           StaticTarget _   _      False ->
+               panic "emitForeignCall: unexpected FFI value import"
            -- If the packageId is Nothing then the label is taken to be in the
            --   package currently being compiled.
-           StaticTarget lbl mPkgId
+           StaticTarget lbl mPkgId True
             -> let labelSource
                         = case mPkgId of
                                 Nothing         -> ForeignLabelInThisPackage
index af88ba8..c41832a 100644 (file)
@@ -56,7 +56,9 @@ cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_a
   = do  { cmm_args <- getFCallArgs stg_args
         ; let ((call_args, arg_hints), cmm_target)
                 = case target of
-                   StaticTarget lbl mPkgId
+                   StaticTarget _   _      False ->
+                       panic "cgForeignCall: unexpected FFI value import"
+                   StaticTarget lbl mPkgId True
                      -> let labelSource
                                 = case mPkgId of
                                         Nothing         -> ForeignLabelInThisPackage
index cb12973..89c0c91 100644 (file)
@@ -138,8 +138,10 @@ make_exp (Var v) = do
   isLocal <- isALocal vName
   return $
      case idDetails v of
-       FCallId (CCall (CCallSpec (StaticTarget nm _) callconv _)) 
+       FCallId (CCall (CCallSpec (StaticTarget nm _ True) callconv _)) 
            -> C.External (unpackFS nm) (showSDoc (ppr callconv)) (make_ty (varType v))
+       FCallId (CCall (CCallSpec (StaticTarget _ _ False) _ _)) ->
+           panic "make_exp: FFI values not supported"
        FCallId (CCall (CCallSpec DynamicTarget     callconv _)) 
            -> C.DynExternal            (showSDoc (ppr callconv)) (make_ty (varType v))
        -- Constructors are always exported, so make sure to declare them
index 06a41bc..2fff5fd 100644 (file)
@@ -98,7 +98,7 @@ dsCCall lbl args may_gc result_ty
        (ccall_result_ty, res_wrapper) <- boxResult result_ty
        uniq <- newUnique
        let
-           target = StaticTarget lbl Nothing
+           target = StaticTarget lbl Nothing True
            the_fcall    = CCall (CCallSpec target CCallConv may_gc)
            the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
        return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
index 46c4a54..88caaef 100644 (file)
@@ -207,13 +207,13 @@ dsFCall fn_id co fcall mDeclHeader = do
 
     (fcall', cDoc) <-
               case fcall of
-              CCall (CCallSpec (StaticTarget cName mPackageId) CApiConv safety) ->
+              CCall (CCallSpec (StaticTarget cName mPackageId isFun) 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)
+                      fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageId True) CApiConv safety)
                       c = includes
                        $$ fun_proto <+> braces (cRet <> semi)
                       includes = vcat [ text "#include <" <> ftext h <> text ">"
@@ -222,7 +222,11 @@ dsFCall fn_id co fcall mDeclHeader = do
                       cRet
                        | isVoidRes =                   cCall
                        | otherwise = text "return" <+> cCall
-                      cCall = ppr cName <> parens argVals
+                      cCall = if isFun
+                              then ppr cName <> parens argVals
+                              else if null arg_tys
+                                    then ppr cName
+                                    else panic "dsFCall: Unexpected arguments to FFI value import"
                       raw_res_ty = case tcSplitIOType_maybe io_res_ty of
                                    Just (_ioTyCon, res_ty) -> res_ty
                                    Nothing                 -> io_res_ty
index 181a25e..7daa037 100644 (file)
@@ -350,10 +350,11 @@ repForD (L loc (ForeignImport name typ _ (CImport cc s mch cis)))
  where
     conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
     conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
-    conv_cimportspec (CFunction (StaticTarget fs _)) = return (unpackFS fs)
+    conv_cimportspec (CFunction (StaticTarget fs _ True)) = return (unpackFS fs)
+    conv_cimportspec (CFunction (StaticTarget _  _ False)) = panic "conv_cimportspec: values not supported yet"
     conv_cimportspec CWrapper = return "wrapper"
     static = case cis of
-                 CFunction (StaticTarget _ _) -> "static "
+                 CFunction (StaticTarget _ _ _) -> "static "
                  _ -> ""
     chStr = case mch of
             Nothing -> ""
index afc5116..046d6ec 100644 (file)
@@ -986,7 +986,9 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
                  DynamicTarget
                     -> return (False, panic "ByteCodeGen.generateCCall(dyn)")
 
-                 StaticTarget target _
+                 StaticTarget _ _ False ->
+                     panic "generateCCall: unexpected FFI value import"
+                 StaticTarget target _ True
                     -> do res <- ioToBc (lookupStaticPtr stdcall_adj_target)
                           return (True, res)
                    where
index 4d8c01d..49a5b91 100644 (file)
@@ -1024,8 +1024,11 @@ instance Outputable ForeignImport where
 
       pprCEntity (CLabel lbl) = 
         ptext (sLit "static") <+> pp_hdr <+> char '&' <> ppr lbl
-      pprCEntity (CFunction (StaticTarget lbl _)) = 
-        ptext (sLit "static") <+> pp_hdr <+> ppr lbl
+      pprCEntity (CFunction (StaticTarget lbl _ isFun)) = 
+            ptext (sLit "static")
+        <+> pp_hdr
+        <+> (if isFun then empty else ptext (sLit "value"))
+        <+> ppr lbl
       pprCEntity (CFunction (DynamicTarget)) =
         ptext (sLit "dynamic")
       pprCEntity (CWrapper) = ptext (sLit "wrapper")
index 3a786ea..80d4943 100644 (file)
@@ -278,7 +278,7 @@ exp :: { IfaceExpr }
 --            "InlineMe"   -> IfaceNote IfaceInlineMe $3
 --            }
         | '%external' STRING aty   { IfaceFCall (ForeignCall.CCall 
-                                                    (CCallSpec (StaticTarget (mkFastString $2) Nothing) 
+                                                    (CCallSpec (StaticTarget (mkFastString $2) Nothing True
                                                                CCallConv PlaySafe)) 
                                                  $3 }
 
index 3ba9673..59e6727 100644 (file)
@@ -914,7 +914,7 @@ mkImport :: CCallConv
          -> P (HsDecl RdrName)
 mkImport cconv safety (L loc entity, v, ty)
   | cconv == PrimCallConv                      = do
-  let funcTarget = CFunction (StaticTarget entity Nothing)
+  let funcTarget = CFunction (StaticTarget entity Nothing True)
       importSpec = CImport PrimCallConv safety Nothing funcTarget
   return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
 
@@ -937,9 +937,11 @@ parseCImport cconv safety nm str =
        r <- choice [
           string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)),
           string "wrapper" >> return (mk Nothing CWrapper),
-          optional (token "static" >> skipSpaces) >>
-           (mk Nothing <$> cimp nm) +++
-           (do h <- munch1 hdr_char; skipSpaces; mk (Just (Header (mkFastString h))) <$> cimp nm)
+          do optional (token "static" >> skipSpaces)
+             ((mk Nothing <$> cimp nm) +++
+              (do h <- munch1 hdr_char
+                  skipSpaces
+                  mk (Just (Header (mkFastString h))) <$> cimp nm))
          ]
        skipSpaces
        return r
@@ -960,7 +962,15 @@ parseCImport cconv safety nm str =
    id_char       c = isAlphaNum c || c == '_'
 
    cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
-             +++ ((\c -> CFunction (StaticTarget c Nothing)) <$> cid)
+             +++ (do isFun <- case cconv of
+                              CApiConv ->
+                                  option True
+                                         (do token "value"
+                                             skipSpaces
+                                             return False)
+                              _ -> return True
+                     cid' <- cid
+                     return (CFunction (StaticTarget cid' Nothing isFun)))
           where
             cid = return nm +++
                   (do c  <- satisfy id_first_char
index b245e83..b3a2ad3 100644 (file)
@@ -127,6 +127,9 @@ data CCallTarget
 
   -- The first argument of the import is the name of a function pointer (an Addr#).
   --    Used when importing a label as "foreign import ccall "dynamic" ..."
+        Bool                            -- True => really a function
+                                        -- False => a value; only
+                                        -- allowed in CAPI imports
   | DynamicTarget
 
   deriving( Eq, Data, Typeable )
@@ -219,11 +222,14 @@ instance Outputable CCallSpec where
       gc_suf | playSafe safety = text "_GC"
              | otherwise       = empty
 
-      ppr_fun (StaticTarget fn Nothing)
-        = text "__pkg_ccall" <> gc_suf <+> pprCLabelString fn
-
-      ppr_fun (StaticTarget fn (Just pkgId))
-        = text "__pkg_ccall" <> gc_suf <+> ppr pkgId <+> pprCLabelString fn
+      ppr_fun (StaticTarget fn mPkgId isFun)
+        = text (if isFun then "__pkg_ccall"
+                         else "__pkg_ccall_value")
+       <> gc_suf
+       <+> (case mPkgId of
+            Nothing -> empty
+            Just pkgId -> ppr pkgId)
+       <+> pprCLabelString fn
 
       ppr_fun DynamicTarget
         = text "__dyn_ccall" <> gc_suf <+> text "\"\""
@@ -297,10 +303,11 @@ instance Binary CCallSpec where
           return (CCallSpec aa ab ac)
 
 instance Binary CCallTarget where
-    put_ bh (StaticTarget aa ab) = do
+    put_ bh (StaticTarget aa ab ac) = do
             putByte bh 0
             put_ bh aa
             put_ bh ab
+            put_ bh ac
     put_ bh DynamicTarget = do
             putByte bh 1
     get bh = do
@@ -308,7 +315,8 @@ instance Binary CCallTarget where
             case h of
               0 -> do aa <- get bh
                       ab <- get bh
-                      return (StaticTarget aa ab)
+                      ac <- get bh
+                      return (StaticTarget aa ab ac)
               _ -> do return DynamicTarget
 
 instance Binary CCallConv where
index e747b85..1969229 100644 (file)
@@ -407,8 +407,8 @@ patchCImportSpec packageId spec
 patchCCallTarget :: PackageId -> CCallTarget -> CCallTarget
 patchCCallTarget packageId callTarget
  = case callTarget of
-       StaticTarget label Nothing
-        -> StaticTarget label (Just packageId)
+       StaticTarget label Nothing isFun
+        -> StaticTarget label (Just packageId) isFun
 
        _                       -> callTarget   
 
index 98e5303..71bdfe9 100644 (file)
@@ -545,7 +545,7 @@ coreToStgApp _ f args = do
                                     StgOpApp (StgPrimOp op) args' res_ty
 
                 -- A call to some primitive Cmm function.
-                FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId)) PrimCallConv _))
+                FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId) True) PrimCallConv _))
                                  -> ASSERT( saturated )
                                     StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty
 
index 9fbcff6..ab85039 100644 (file)
@@ -263,13 +263,18 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar
       checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
       checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
       checkMissingAmpersand dflags arg_tys res_ty
+      case target of
+          StaticTarget _ _ False
+           | not (null arg_tys) ->
+              addErrTc (text "`value' imports cannot have function types")
+          _ -> return ()
       return idecl
 
 
 -- This makes a convenient place to check
 -- that the C identifier is valid for C
 checkCTarget :: CCallTarget -> TcM ()
-checkCTarget (StaticTarget str _) = do
+checkCTarget (StaticTarget str _ _) = do
     checkCg checkCOrAsmOrLlvmOrDotNetOrInterp
     check (isCLabelString str) (badCName str)
 
index b5ae0e0..34c2b35 100644 (file)
@@ -169,8 +169,7 @@ foreign import ccall interruptible
           declarations, e.g.
 
 <programlisting>
-foreign import capi
-    "header.h f" :: CInt -> IO CInt
+foreign import capi "header.h f" f :: CInt -> IO CInt
 </programlisting>
 
           Rather than generating code to call <literal>f</literal>
@@ -182,6 +181,25 @@ foreign import capi
         </para>
 
         <para>
+          When using <literal>capi</literal>, it is also possible to
+          import values, rather than functions. For example,
+
+<programlisting>
+foreign import capi "pi.h pi" c_pi :: CDouble
+</programlisting>
+
+          will work regardless of whether <literal>pi</literal> is
+          defined as
+<programlisting>
+const double pi = 3.14;
+</programlisting>
+          or with
+<programlisting>
+#define pi 3.14
+</programlisting>
+        </para>
+
+        <para>
           In order to tell GHC the C type that a Haskell type
           corresponds to when it is used with the CAPI, a
           <literal>CTYPE</literal> pragma can be used on the type