-- | Needs 'IdSupply'
module ForeignCode
( Foreign(..), toForeign, strForeign
, ForeignMemo, foreignMemo
, ImpExp(..)
, Style(..)
, Arg(..), Res
, cTypename
) where
import Maybe (fromJust,isNothing)
import List (isPrefixOf,isSuffixOf,intersperse)
import SysDeps (unpackPS)
import Syntax
import Id
import Info
import NT
import TokenId
import qualified Data.Map as Map
import Util.Extra (mix,warning)
import GcodeLow (fun,foreignfun,fixStr)
data ImpExp = Imported | Exported
data Style = Ordinary | CCast | Address | FunAddress | Dynamic | Wrapper
deriving Eq
data Foreign = Foreign ImpExp -- import or export?
Bool -- generate C prototype?
Style -- cast / address / dynamic etc
(Maybe FilePath) -- C header file (for proto checking)
String -- foreign function name
TokenId -- Haskell function name
Int -- arity
[Arg] -- argument types
Res -- result type
instance Show ImpExp where
showsPrec _ Imported = showString "import"
showsPrec _ Exported = showString "export"
instance Show Style where
showsPrec _ Ordinary = showString "ccall"
showsPrec _ CCast = showString "cast"
showsPrec _ Address = showString "ccall &"
showsPrec _ FunAddress = showString "ccall &"
showsPrec _ Dynamic = showString "ccall dynamic"
showsPrec _ Wrapper = showString "ccall wrapper"
instance Show Foreign where
showsPrec _ (Foreign ie _proto style incl cname hname arity args res) =
word "foreign" . space . shows ie . space . shows style . space .
showChar '"' . maybe id (\i-> word i . space) incl . word cname .
showChar '"' . space .
shows hname . space . shows arity . showString " :: " .
showString (mix " -> " (map show args)) .
showString " -> " . shows res
data Arg = Int8 | Int16 | Int32 | Int64
| Word8 | Word16 | Word32 | Word64
| Float | Double | Char | Bool | Int
| Ptr | FunPtr [Arg] | StablePtr | ForeignPtr
| Addr | ForeignObj | Integer | PackedString
| Unknown String | Unit | HaskellFun [Arg]
instance Show Arg where
showsPrec _ Int8 = showString "FFI.Int8"
showsPrec _ Int16 = showString "FFI.Int16"
showsPrec _ Int32 = showString "FFI.Int32"
showsPrec _ Int64 = showString "FFI.Int64"
showsPrec _ Word8 = showString "FFI.Word8"
showsPrec _ Word16 = showString "FFI.Word16"
showsPrec _ Word32 = showString "FFI.Word32"
showsPrec _ Word64 = showString "FFI.Word64"
showsPrec _ Int = showString "Prelude.Int"
showsPrec _ Float = showString "Prelude.Float"
showsPrec _ Double = showString "Prelude.Double"
showsPrec _ Char = showString "Prelude.Char"
showsPrec _ Bool = showString "Prelude.Bool"
showsPrec _ Ptr = showString "FFI.Ptr"
showsPrec _ (FunPtr t) = showString "FFI.FunPtr"
. parens (showString (concat (intersperse " -> " (map show t))))
showsPrec _ StablePtr = showString "FFI.StablePtr"
showsPrec _ ForeignPtr = showString "FFI.ForeignPtr"
showsPrec _ Addr = showString "FFI.Addr" -- deprecated
showsPrec _ ForeignObj = showString "FFI.ForeignObj" -- deprecated
showsPrec _ Integer = showString "Prelude.Integer" -- non-standard
showsPrec _ PackedString = showString "PackedString.PackedString" -- non-std
showsPrec _ Unit = showString "Prelude.()"
showsPrec _ (HaskellFun as) =
parens (showString (concat (intersperse " -> " (map show as))))
showsPrec _ (Unknown s) = showString s
-- Note: as of 2000-10-18, the result can never have an IO type - pure only.
-- (IO results are created by wrapping auxiliary _mkIOokN around a pure call.)
type Res = Arg
foreignname, localname, profname :: TokenId -> ShowS
foreignname hname = showString foreignfun . fixStr (show hname)
localname hname = showString fun . fixStr (show hname)
profname hname = showString "pf_" . fixStr (show hname)
----
toForeign :: Map.Map Id Info -> ForeignMemo
-> CallConv -> ImpExp -> String -> Int -> Id -> Foreign
-- toForeign _symboltable _memo (Other callconv) _ie _cname _arity _var
-- callconv `notElem` ["primitive","fastccall","faststdcall","builtin"] =
-- error ("Foreign calling convention \""++callconv++"\" not supported.")
toForeign symboltable memo callconv ie cname arity var =
Foreign ie proto style include cfunc hname arity' args res
where
info = fromJust (Map.lookup var symboltable)
hname = tidI info
hnameStr = (reverse . (\w->if head w=='#' then tail w else w)
. unpackPS . extractV) hname
(args,res) = searchType style symboltable memo info
(cfunc,style,include) = case callconv of Cast -> (hnameStr,CCast,Nothing)
_ -> parseEntity cname hnameStr
proto = (callconv/=Noproto) && (isNothing include)
arity' = if arity==length args then arity
else error ("foreign function: arity does not match: "
++hnameStr++" has "++show arity
++" args, expected "++show (length args)++"\n")
parseEntity :: String -> String -> (String,Style,Maybe FilePath)
parseEntity entity hname =
case words entity of
("dynamic":_) -> (hname, Dynamic, Nothing)
("wrapper":_) -> (hname, Wrapper, Nothing)
("static":ws) -> filename ws
ws -> filename ws
where
filename [] = (hname, Ordinary, Nothing)
filename (w:ws) | ".h" `isSuffixOf` w = address (Just w) ws
| otherwise = address Nothing (w:ws)
address file ("&":ws) = lib file Address ws
address file (w:ws) | "&" `isPrefixOf` w = lib file Address (tail w:ws)
address file ws = lib file Ordinary ws
lib file style [] = (hname, style, file)
lib file style (w:ws) | "[" `isPrefixOf` w && "]" `isSuffixOf` w
= cfunc file style ws
| otherwise = cfunc file style (w:ws)
cfunc file style [] = (hname, style, file)
cfunc file style [cname] = (cname, style, file)
cfunc _file _style _ws =
error ("Couldn't parse entity string in foreign import: "++entity)
searchType :: Style -> Map.Map Id Info -> ForeignMemo -> Info -> ([Arg],Res)
searchType style st (arrow,io) info =
let
toList (NTcons c _ nts) | c==arrow = let [a,b] = nts in a: toList b
toList (NTcons c _ nts) | c==io = let [a] = nts in [a] -- within FunPtr
toList (NTstrict nt) = toList nt
toList nt = [nt]
toTid (NTcons c _ nts) =
case Map.lookup c st of
Just i | isRealData i ->
case toArg (tidI i) of
FunPtr _ -> FunPtr (map toTid (toList (head nts)))
HaskellFun _ -> HaskellFun (map toTid (toList (head nts)))
t -> t
| otherwise -> toTid (getNT (isRenamingFor st i))
toTid (NTapp t1 _t2) = toTid t1
toTid (NTstrict t) = toTid t
toTid t = Unknown (show t) -- error ("Unrecognised NT: "++show t)
-- 'Unknown' lets polymorphic heap-values across unmolested
toArg t | t==tInt = Int
-- t==tWord = Word32
| t==tBool = Bool
| t==tChar = Char
| t==tFloat = Float
| t==tDouble = Double
| t==tPtr = Ptr
| t==tPtrBC = Ptr
| t==tFunPtr = FunPtr []
| t==tFunPtrBC = FunPtr []
| t==tStablePtr = StablePtr
| t==tStablePtrBC = StablePtr
| t==tForeignPtr = ForeignPtr
| t==tForeignPtrBC = ForeignPtr
| t==tAddr = Addr -- deprecated
| t==tAddrBC = Addr -- deprecated
| t==tForeignObj = ForeignObj -- deprecated
| t==tForeignObjBC = ForeignObj -- deprecated
| t==(t_Tuple 0) = Unit -- no void args, but need void results
| t==tInt8 = Int8
| t==tInt8BC = Int8
| t==tInt16 = Int16
| t==tInt16BC = Int8
| t==tInt32 = Int32
| t==tInt32BC = Int32
| t==tInt64 = Int64
| t==tInt64BC = Int64
| t==tWord8 = Word8
| t==tWord8BC = Word8
| t==tWord16 = Word16
| t==tWord16BC = Word16
| t==tWord32 = Word32
| t==tWord32BC = Word32
| t==tWord64 = Word64
| t==tWord64BC = Word64
| t==tPackedString = PackedString -- non-standard
| t==tInteger = Integer -- non-standard
| style==Wrapper
&& t==t_Arrow = HaskellFun [] -- foreign export "wrapper"
| otherwise =
warning ("foreign import/export has non-primitive type: "
++show t++"\n") (Unknown (show t))
getNT (NewType _ _ _ [nt]) = nt
getNT (NewType _ _ _ (nt:_)) = nt
getNT _ = error ("Unable to retrieve newtype info.")
splitRes args = (init args, last args)
in
(splitRes . map toTid . toList . getNT . ntI) info
----
type ForeignMemo = (Id,Id)
foreignMemo :: Map.Map Id Info -> ForeignMemo
foreignMemo st =
-- (findFirst (check t_Arrow . flip Map.lookup st) [1..]
-- ,findFirst (check tIO . flip Map.lookup st) [1..])
(findFirst (check t_Arrow) minfos
,findFirst (check tIO ) minfos)
where
minfos = map (Just . snd) (Map.toList st) ++ [Nothing]
check tid (Just info) | cmpTid tid info = Just (uniqueI info)
| otherwise = Nothing
-- If the ident doesn't exist after typecheck, it won't be used!
check _tid Nothing = error "ForeignCode.foreignMemo: used unused identifier?"
findFirst :: (a->Maybe b) -> [a] -> b
-- specification: findFirst = head . catMaybes . map
findFirst _ [] = error "findFirst failed"
findFirst f (x:xs) =
case f x of
Just b -> b
Nothing -> findFirst f xs
----
strForeign :: Foreign -> ShowS
strForeign f@(Foreign Imported proto style incl cname hname arity args res) =
nl . comment (shows f) . nl .
maybe id
(\i-> word "#include " . showChar '"' . word i . showChar '"' . nl)
incl .
(if proto then genProto style else id) .
word "#ifdef PROFILE" . nl .
word "static SInfo" . space . profinfo . space . equals . space .
opencurly . strquote (word modname) . comma .
strquote (shows hname) . comma .
strquote (shows res) .
closecurly . semi .
word "#endif" . nl .
word "C_HEADER" . parens (foreignname hname) . space .
opencurly . nl .
indent . word "NodePtr nodeptr" . semi .
cResDecl res .
listsep semi (zipWith cArg args [1..]) . semi .
foldr (.) id (zipWith cArgDefn args [1..]) . nl .
(case style of
CCast -> cCast arity res
Address -> cAddr cname res
FunAddress -> cFunAddr cname
Dynamic -> cDynamic arity res
_ -> if length args == 1 && noarg (head args)
then cCall cname 0 res
else cCall cname arity res) . nl .
cFooter profinfo res .
closecurly . nl
where
genProto :: Style -> ShowS
genProto Ordinary =
case res of
FunPtr t ->
word "extern" . space . cResType (last t)
. parens (star . word cname
. parens (listsep comma (map cTypename args)))
. parens (listsep comma (map cTypename (init t))) . semi
_ ->
word "extern" . space . cResType res . space . word cname
. parens (listsep comma (map cTypename args)) . semi
genProto FunAddress =
word "extern" . space . cResType res . space . word cname
. parens id . semi
genProto CCast = id
genProto Address = id
genProto Dynamic = id
genProto Wrapper = error "foreign import wrapper not yet supported."
cArg a n = indent . cArgDecl a n
modname = (reverse . unpackPS . extractM) hname
profinfo = profname hname
noarg Unit = True
noarg _ = False
strForeign f@(Foreign Exported _ _ _ cname hname arity args res) =
nl . comment (shows f) . nl .
cCodeDecl cname args res . space .
opencurly . nl .
--cResDecl res .
hCall arity hname args .
hResult res .
closecurly . nl
---- foreign import ----
cArgDecl :: Arg -> Int -> ShowS
cArgDecl (FunPtr t) n = cResType (last t) . parens (star . narg n)
. parens (listsep comma (map cTypename (init t)))
cArgDecl Unit n = comment (cTypename Unit . space . narg n)
cArgDecl arg n = cTypename arg . space . narg n
cArgDefn :: Arg -> Int -> ShowS
cArgDefn Unit _n =
id
cArgDefn arg n =
indent . word "nodeptr = C_GETARG1" . parens (shows n) . semi .
indent . word "IND_REMOVE(nodeptr)" . semi .
indent . narg n . showString " = " .
parens (cTypename arg) . cConvert arg . semi
cResDecl :: Res -> ShowS
cResDecl (FunPtr t) = indent . cResType (last t) . parens (star . word "result")
. parens (listsep comma (map cTypename (init t))) . semi
cResDecl Unit = id
cResDecl arg = indent . cTypename arg . space . word "result" . semi
cCall :: String -> Int -> Res -> ShowS
cCall cname arity res =
indent . (case res of
Unit -> id
_ -> word "result = ") .
word cname . parens (listsep comma (map narg [1..arity])) . semi
cCast :: Int -> Res -> ShowS
cCast arity res =
if arity /= 1 then
error ("\"foreign import cast\" has wrong arity.")
else
indent . word "result = " . parens (cResType res) . parens (narg 1) . semi
cAddr :: String -> Res -> ShowS
cAddr cname res =
indent . word "result = " . parens (cResType res) . word "&" .
word cname . semi
cFunAddr :: String -> ShowS
cFunAddr cname =
indent . word "result = " . word cname . semi
cDynamic :: Int -> Res -> ShowS
cDynamic arity res =
indent . (case res of
Unit -> id
_ -> word "result = ") .
word "(*arg1)" . parens (listsep comma (map narg [2..arity])) . semi
cFooter :: ShowS -> Arg -> ShowS
cFooter profinfo arg =
indent . word "nodeptr = " . hConvert arg (word "result") . semi .
indent . word "INIT_PROFINFO(nodeptr,&" . profinfo . word ")" . semi .
indent . word "C_RETURN(nodeptr)" . semi
---- foreign export ----
cCodeDecl :: String -> [Arg] -> Res -> ShowS
cCodeDecl cname args res =
cResType res . space . word cname . space .
parens (listsep comma (zipWith cArgDecl args [1..]))
cResType :: Res -> ShowS
cResType res = cTypename res
hCall :: Int -> TokenId -> [Arg] -> ShowS
hCall arity hname args =
indent . word "NodePtr nodeptr, vap, args" . squares (shows arity) . semi .
indent . word "C_CHECK" .
parens (parens (shows (arity+1) . word "+EXTRA") . word "*2") . semi .
foldr (.) id (zipWith hArg1 args [1..]) .
indent . word "vap = Hp" . semi .
indent . word "*Hp = " . parens (word "Node") .
word "C_VAPTAG" . parens (localname hname) . semi .
indent . word "Hp += 1+EXTRA" . semi .
foldr (.) id (zipWith hArg2 args [1 :: Int ..]) .
indent . word "nodeptr = evalExport(vap)" . semi .
indent . word "IND_REMOVE(nodeptr)" . semi
where
hArg1 arg n = indent . word "args" . squares (shows (n-1)) . space .
equals . space . hConvert arg (narg n) . semi
hArg2 _ n = indent . word "*Hp++ = (Node)args" . squares (shows (n-1)) . semi
hResult :: Res -> ShowS
hResult Unit = id -- allow for IO ()
hResult res = indent . word "return" . space . cConvert res . semi
---- shared between foreign import/export ----
cTypename :: Arg -> ShowS
cTypename Int8 = word "HsInt8"
cTypename Int16 = word "HsInt16"
cTypename Int32 = word "HsInt32"
cTypename Int64 = word "HsInt64"
cTypename Word8 = word "HsWord8"
cTypename Word16 = word "HsWord16"
cTypename Word32 = word "HsWord32"
cTypename Word64 = word "HsWord64"
cTypename Int = word "HsInt"
cTypename Bool = word "HsBool"
cTypename Char = word "char"
cTypename Float = word "float"
cTypename Double = word "double"
cTypename Ptr = word "void*"
cTypename (FunPtr t) = cResType (last t) . parens star
. parens (listsep comma (map cTypename (init t)))
cTypename StablePtr = word "StablePtr"
cTypename ForeignPtr = word "void*"
cTypename Unit = word "void"
cTypename Addr = word "void*" -- deprecated
cTypename ForeignObj = word "void*" -- deprecated
cTypename PackedString = word "char*" -- non-standard
cTypename Integer = word "Node*" -- non-standard
cTypename (Unknown _) = word "Node*" -- for passing Haskell heap values
-- cTypename x = error ("*** cTypename [" ++ show x ++ "]")
cConvert :: Arg -> ShowS
cConvert Int = word "GET_INT_VALUE(nodeptr)"
cConvert Bool = word "GET_BOOL_VALUE(nodeptr)"
cConvert Char = word "GET_CHAR_VALUE(nodeptr)"
cConvert Float = word "get_float_value(nodeptr)"
cConvert Double = word "get_double_value(nodeptr)"
cConvert Int8 = word "GET_8BIT_VALUE(nodeptr)"
cConvert Int16 = word "GET_16BIT_VALUE(nodeptr)"
cConvert Int32 = word "GET_32BIT_VALUE(nodeptr)"
cConvert Int64 = word "nhc_get_64bit_value(nodeptr)"
cConvert Word8 = word "GET_8BIT_VALUE(nodeptr)"
cConvert Word16 = word "GET_16BIT_VALUE(nodeptr)"
cConvert Word32 = word "GET_32BIT_VALUE(nodeptr)"
cConvert Word64 = word "nhc_get_64bit_value(nodeptr)"
cConvert Ptr = word "GET_INT_VALUE(nodeptr)"
cConvert (FunPtr _) = word "GET_INT_VALUE(nodeptr)"
cConvert StablePtr = word "GET_INT_VALUE(nodeptr)"
cConvert ForeignPtr = word "derefForeignObj((ForeignObj*)GET_INT_VALUE(nodeptr))"
cConvert Addr = word "GET_INT_VALUE(nodeptr)"
cConvert ForeignObj = word "derefForeignObj((ForeignObj*)GET_INT_VALUE(nodeptr))"
cConvert PackedString = word "nhc_getPackedString(nodeptr)"
cConvert Integer = word "nodeptr"
cConvert Unit = word "0"
cConvert (Unknown _) = word "nodeptr"
hConvert :: Arg -> ShowS -> ShowS
hConvert Int s = word "nhc_mkInt" . parens s
hConvert Bool s = word "nhc_mkBool" . parens s
hConvert Char s = word "nhc_mkChar" . parens s
hConvert Float s = word "nhc_mkFloat" . parens s
hConvert Double s = word "nhc_mkDouble" . parens s
hConvert Int8 s = word "nhc_mkInt8" . parens s
hConvert Int16 s = word "nhc_mkInt16" . parens s
hConvert Int32 s = word "nhc_mkInt32" . parens s
hConvert Int64 s = word "nhc_mkInt64" . parens s
hConvert Word8 s = word "nhc_mkWord8" . parens s
hConvert Word16 s = word "nhc_mkWord16" . parens s
hConvert Word32 s = word "nhc_mkWord32" . parens s
hConvert Word64 s = word "nhc_mkWord64" . parens s
hConvert Ptr s = word "nhc_mkInt" . parens (word "(int)" . s)
hConvert (FunPtr _) s = word "nhc_mkInt" . parens (word "(int)" . s)
hConvert StablePtr s = word "nhc_mkInt" . parens (word "(int)" . s)
{- Returning ForeignPtr's to Haskell is usually illegal: -}
hConvert ForeignPtr s =
warning ("foreign import/export should not return ForeignPtr type.\n") s
hConvert Addr s = word "nhc_mkInt" . parens (word "(int)" . s)
{- Returning ForeignObj's to Haskell is usually illegal: -}
hConvert ForeignObj s =
warning ("foreign import/export should not return ForeignObj type.\n") s
hConvert PackedString s = word "nhc_mkString" . parens (word "(char*)" . s)
hConvert Integer s = s
hConvert Unit _ = word "nhc_mkUnit()"
hConvert (Unknown _) s = s -- for passing Haskell heap values untouched
openparen, closeparen, opencurly, closecurly, semi,
nl, space, equals, comma, star, indent :: ShowS
openparen = showChar '('
closeparen = showChar ')'
opencurly = showChar '{'
closecurly = showChar '}'
semi = showChar ';' . nl
nl = showChar '\n'
space = showChar ' '
equals = showChar '='
comma = showChar ','
star = showChar '*'
indent = space . space
parens, squares, strquote, comment :: ShowS -> ShowS
parens s = openparen . s . closeparen
squares s = showChar '[' . s . showChar ']'
strquote s = showChar '"' . s . showChar '"'
comment s = word "/*" . space . s . space . word "*/"
word :: String -> ShowS
word = showString
narg :: Int -> ShowS
narg n = word "arg" . shows n
listsep :: ShowS -> [ShowS] -> ShowS
listsep s x = if length x > 0 then foldr1 (\l r -> l . s . r) x else id
|
