Hs2lib-0.5.6: WinDll/CodeGen/C.hs
-----------------------------------------------------------------------------
-- |
-- Module : Windll
-- Copyright : (c) Tamar Christina 2009 - 2010
-- License : BSD3
--
-- Maintainer : tamar@zhox.com
-- Stability : experimental
-- Portability : portable
--
-- Generates the needed C code needed by the FFI Calls.
--
-----------------------------------------------------------------------------
module WinDll.CodeGen.C where
import WinDll.CodeGen.Lookup
import WinDll.Structs.Structures
import WinDll.Utils.Feedback
import WinDll.Builder
import WinDll.Identifier
import WinDll.Session.Hs2lib
import WinDll.Structs.C
import qualified WinDll.Structs.C as C
import WinDll.Structs.MShow.MShow
import WinDll.Structs.MShow.C
import WinDll.Structs.Folds.HaskellSrcExts
import WinDll.Utils.HaddockRead
import Data.List
import Data.Char
import Data.Maybe
import Data.Generics (everywhere,mkT)
import qualified Data.Map as M
import Control.Monad
import qualified Language.Haskell.Exts as Exts
-- | For internal use only.
type CodeGen = CDataType
-- | Write out the main header file and the definition file for the exports
writeCFiles :: Component
writeCFiles = do inform _normal "Generating C/C++ files for pipeline"
modInfo <- generateMain
session <- get
ann <- makeSessionAnn
let name = namespace session
symb = native_symbols session
spec = (specs.pipeline) session
natives = (n_exports.workingset) session
datatypes = d1++d2
functions = modFunctions modInfo
(d1 , d2) = modDatatypes modInfo
exports = modExports modInfo
callbacks = modCallbacks modInfo
callconv = call session
defs = natives ++ manualdef ++ debugdefs
natDefs = natives ++ debugdefs
modnm = []
ctType = Exts.TyApp (Exts.TyCon (Exts.UnQual (Exts.Ident "IO"))) (Exts.TyCon (Exts.Special Exts.UnitCon))
ptType = Exts.TyApp (Exts.TyCon (Exts.UnQual (Exts.Ident "Ptr"))) (Exts.TyCon (Exts.Special Exts.UnitCon))
ftType = Exts.TyFun ptType ctType
manualdef = if dllmanual session -- | we're going to threat the Hs* functions as if they were just normal haskell functions, with type IO ()
then [HaskellExport callconv ann $ Export "HsStart" "HsStart" ctType ctType modnm
,HaskellExport callconv ann $ Export "HsEnd" "HsEnd" ctType ctType modnm]
else []
debugdefs = if debugging session
then case callconv of
StdCall -> [HaskellExport callconv ann $ Export "Ex.freeS" "freeS" ftType ftType modnm
,HaskellExport callconv ann $ Export "Ex.recordS" "recordS" ftType ftType modnm]
CCall -> [HaskellExport callconv ann $ Export "Ex.freeC" "freeC" ftType ftType modnm
,HaskellExport callconv ann $ Export "Ex.recordS" "recordS" ftType ftType modnm]
else []
inform _detail "Creating export definition file"
extra_defs <- liftIO $ fmap (fmap (" "++)) $ mapM readFile symb
createComponent "exports.def" ((return.unlines) (generateExports ann callconv name exports
++ concatMap (createLocalExports ann) defs
++ extra_defs))
inform _detail "Creating C/C++ structures header file"
createComponent (name++".h") (return $ mkHeader ++ (mshow $ generateHeaderFile ann callconv callbacks datatypes))
inform _detail "Creating C/C++ function include header file"
createComponent (name++"_FFI.h") (generateFFIHeader ann (call session) name exports natDefs manualdef)
-- | Generate the export list from a list of defined FFI Export systems
createLocalExports :: Ann -> HaskellExport -> [String]
createLocalExports ann (HaskellExport clp _ (Export _ a t _ modnm)) =
case clp of
StdCall -> [" _" ++ a ++ "@" ++ getSize ann t ++ " = " ++ a ++ "@" ++ getSize ann t," " ++ a ++ "@" ++ getSize ann t]
CCall -> [" " ++ a]
-- | Generate the export list from the list of functions.
generateExports :: Ann -> CallConvention -> String -> [Export] -> [String]
generateExports ann clp name funcs = ("LIBRARY " ++ name) : "EXPORTS" :
case clp of
StdCall -> concatMap (\(Export _ a t _ modnm)->[" _" ++ a ++ "@" ++ getSize ann t ++ " = " ++ a ++ "@" ++ getSize ann t," " ++ a ++ "@" ++ getSize ann t]) funcs
CCall -> map (\(Export _ a t _ modnm)->" " ++ a) funcs
-- | Return the size of a specified type
getSize ann x = let types = createCType (annWorkingSetC ann) x
args = init types
sizes = map (rnd . lookupSize (annWorkingSetCSize ann)) args
rnd m = let i = m + 3 in (i - (i `mod` 4)) -- round up to nearest mutiple of 4
in show (sum sizes)
-- | Generate the C extern list from the list of functions.
generateFFIHeader :: Ann -> CallConvention -> String -> [Export] -> [HaskellExport] -> [HaskellExport] -> Exec String
generateFFIHeader ann clp name funcs natives defs
= do session <- get
list <- getDocumentationInfo
-- declare exported functions
let types = concatMap (\(Export _ n t _ modnm)->
let x = createCType (annWorkingSetC ann) t -- genAndLookupC t
restype = last x
rest = case length x > 1 of
True -> init x
False -> []
names = ["arg"++show n|n<-[1..(length x-1)]]
resp = foldl (\a b->a ++ " " ++ b) "" . lines
args = let value = intercalate ", " (zipWith (\a b->a++" "++b) rest names)
in if null value then " void " else value
in unlines $ [[],"// " ++ n ++ " ::" ++ (resp $ mshowM 2 t)]
++ maybe [] id (fmap (\x->map ("// "++) (description x)) $ M.lookup n list) ++
["extern CALLTYPE(" ++ restype ++ ") " ++ n ++ " (" ++ args ++ ");"
])
-- re-export previously reclared export statements
native_declares = let decls = types (map (\(HaskellExport clp _ e) -> e) natives)
in if null natives
then ""
else unlines ["// Preserved export statements", decls]
-- declare the runtime system control functions (start & stop)
rts_controldecl = let decls = types (map (\(HaskellExport _ _ e) -> e) defs)
in if null defs
then ""
else unlines ["// Runtime control methods", tail decls]
-- declare the calling convention
mkMacros conven = unlines ["#ifdef _MSC_VER"
,""
,"#if _WIN64 || __amd64__"
,"#define CALLTYPE(x) __declspec(dllimport) x"
,"#else"
,"#define CALLTYPE(x) __declspec(dllimport) x __" ++ conven
,"#endif"
,""
,"#else"
,""
,"#if _WIN64 || __amd64__"
,"#define CALLTYPE(x) x"
,"#else"
,"#define CALLTYPE(x) x __attribute__((__" ++ conven ++ "__))"
,"#endif"
,""
,"#endif"]
return $ unlines $ mkHeader
: ("#include \"" ++ name ++ ".h\"")
: ""
: mkMacros (map toLower (genCcall clp))
: "#ifdef __cplusplus"
: "extern \"C\" {"
: "#endif"
: rts_controldecl
: types funcs
: native_declares
: ["#ifdef __cplusplus"
,"}"
,"#endif"]
-- | Create the enum list from the Datatype if required.
-- No enum is needed for newtypes or when only 1 constructor is available for the Data instance
generateEnum :: DataType -> Maybe DataEnum
generateEnum (DataType name _ t _) = guard (length t > 1) >> return (mkEnum name t)
generateEnum (NewType name _ t _) = Nothing
-- | Create an enum list from a list of Constructors
mkEnum name t = DataEnum name (map enum t)
where enum (Constr name ft _) = filter isAlphaNum name --filter isAlpha (map toLower name)
-- | Generate complete file from given structures
generateHeaderFile :: Ann -> CallConvention -> [Callback] -> DataTypes -> C
generateHeaderFile ann cc cb = (\(a,b,c)->C d_includes cc cb (join a) (join b) (join c)) . unzip3 . map (generateCCode (lookupC (annWorkingSetC ann)))
where d_includes = [LibInclude "string.h"
,LibInclude "stdint.h"
,LocalInclude "Instances.h"
,LocalInclude "Tuples.h"
]
-- | Create the Structures and Unions required for the C code along with the enums if needed.
generateCCode :: LookupType -> DataType -> ([DataEnum],[DataField],[DataField])
generateCCode lc d = (maybeToList (generateEnum d), nub (generateStructs d), generateTopLevelStruct d)
where
generateStructs :: DataType -> [DataField] -- ("struct " ++ name ++ ";") :
-- generateStructs (DataType name e [_] _) = [Forward Struct name] -- treat datastructures with only 1 constructor as a newtype
generateStructs (DataType name e t _) = Forward Struct name : map (\(Constr n _ _)->Forward Struct n) t
generateStructs (NewType name e _ _) = [Forward Struct name]
--generateStructs (NewType name e t _) = generateStructs (DataType name e [t] NoTag)
generateTopLevelStruct :: DataType -> [DataField]
generateTopLevelStruct (DataType name e t _) =
case length t `compare` 1 of
GT -> join [wrapStruct Struct name entries, mkStructs e t, mkUnion name t]
LT -> join [wrapStruct Struct name [Value Union (name++"Union") C.Normal (Just "elt")],mkStructs e t,mkUnion name t]
EQ -> generateTopLevelStruct (NewType name e (head t) NoTag) -- treat as newtype.
where entries = [Value ENum ("List"++name) C.Normal (Just "tag"),Value Union (name++"Union") Pointer (Just "elt")]
generateTopLevelStruct (NewType name e t NoTag) = wrapStruct Struct name (concatMap inline' (mkStruct e t))
mkStructs :: TypeNames -> [DataType] -> [DataField]
mkStructs types constrs = concatMap (mkStruct types) constrs
mkStruct :: TypeNames -> DataType -> [DataField]
mkStruct types (Constr name ft values) = wrapStruct Struct name (concatMap mkLine values)
where lpc = mshowM 1 . lc types -- TODO: rewrite this to support type applied types in datatypes
mkLine x = let ann = antAnn x
base = Value VAlue (lpc (antType x)) C.Normal (Just (antName x))
size = Value VAlue (lpc (Exts.TyCon $ Exts.UnQual $ Exts.Ident "Int")) C.Normal (Just (antName x ++ "_Size"))
in case annArrayIsList ann of
True -> [base, size]
False -> [base]
mkStruct _ _ = error "mkStruct can only be called with a the 'Const' argument."
mkUnion :: Name -> DataTypes -> [DataField]
mkUnion name types = wrapStruct Union (name++"Union") (map mkEntry types)
-- name ++ "* " for pointers
where mkEntry (Constr name ft _) = Value Struct name C.Normal (Just $ "var_" ++ filter isAlphaNum name ) --(map toLower name))
wrapStruct :: CodeGen -> String -> [DataField] -> [DataField]
wrapStruct Struct n l = [Field NormalDef Struct n [] l]-- TypeDef Struct n n l]
wrapStruct Union n l = [Field NormalDef Union n [] l]