diff --git a/Hs2lib.cabal b/Hs2lib.cabal --- a/Hs2lib.cabal +++ b/Hs2lib.cabal @@ -1,5 +1,5 @@ Name: Hs2lib -Version: 0.5.2 +Version: 0.5.5 Cabal-Version: >= 1.10 Build-Type: Custom License: BSD3 @@ -66,6 +66,7 @@ WinDll/Structs/MShow/*.hs, WinDll/Utils/*.hs, Tests/*.hs, + Tests/Exec/*.hs, Tests/Src/*.hs, Tests/Src/*.txt, *.hs, @@ -163,6 +164,38 @@ ghc-options: -threaded -fspec-constr-count=16 -rtsopts cpp-options: -DDEBUG + + Other-Modules: Paths_Hs2lib, + WinDll.Lib.NativeMapping, + WinDll.Lib.NativeMapping_Debug, + WinDll.Debug.Records, + WinDll.Debug.Stack + + Default-Language: Haskell98 + +Executable Hs2lib-testgen + Main-is: Tests\Exec\Hs2lib-testgen.hs + + Build-Depends: QuickCheck >= 2.1.0.1, + directory >= 1.0.0.3, + ghc-paths >= 0.1.0.5, + filepath >= 1.1.0.2, + random >= 1.0.0.1, + process >= 1.0.1.1, + ghc >= 6.12 && < 7.0 || >= 7.0.2, + mtl >= 1.1.0.2, + containers >= 0.2.0.0, + array >= 0.2.0.0, + haskell-src-exts >= 1.9.0, + haddock >= 2.7.2, + base >= 4 && < 5, + syb >= 0.1.0.2, + time >= 1.2.0.3, + old-locale >= 1.0.0.2, + cereal >= 0.3.0.0 + + ghc-options: -threaded -fspec-constr-count=16 -rtsopts + cpp-options: -UDEBUG Other-Modules: Paths_Hs2lib, WinDll.Lib.NativeMapping, diff --git a/LIMITS.txt b/LIMITS.txt --- a/LIMITS.txt +++ b/LIMITS.txt @@ -1,3 +1,15 @@ +Version 0.5.5 + - (Started) implementing a better test mechanism + +Version 0.5.4 + - fixed a major marshalling bug having to do with lists of pointer types. + +Version 0.5.3 + - Fixed an error with parsing pragmas + - Renamed pragma hs2c# to hs2cs + - Fixed an alignment issue with stdcall + - Fixed an issue with lists and type synonyms + Version 0.5.2 - No longer frees Strings, in order to prevent heap corruptions on calls from C#. diff --git a/Tests/Exec/Analyze.hs b/Tests/Exec/Analyze.hs new file mode 100644 --- /dev/null +++ b/Tests/Exec/Analyze.hs @@ -0,0 +1,27 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- This module contains code to analyze datatypes in order to generate +-- QuickCheck arbitrary instances. +-- +----------------------------------------------------------------------------- + +module Tests.Exec.Analyze where + +import WinDll.Identifier +import WinDll.Utils.Feedback +import WinDll.Session.Hs2lib + +import Tests.Exec.Structs + +analyzeModule :: Exec [Arbitrary] +analyzeModule + = do modinfo <- generateMain + return [] diff --git a/Tests/Exec/CmdArgs.hs b/Tests/Exec/CmdArgs.hs new file mode 100644 --- /dev/null +++ b/Tests/Exec/CmdArgs.hs @@ -0,0 +1,162 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- A module to handle commandline arguments and parsing +-- for the test generator program. +-- +----------------------------------------------------------------------------- + +module Tests.Exec.CmdArgs where + +import WinDll.Session.Hs2lib +import Tests.Exec.Version +import WinDll.Utils.Feedback +import WinDll.Structs.Structures +import WinDll.Utils.Pragma + +import System.Directory +import System.Environment +import System.FilePath +import System.Console.GetOpt +import System.Exit + +import Data.Maybe +import Data.Char +import Data.List + +import Control.Monad + +-- | just renaming it to something that might make more sense to read in this module +type Config = Session + +-- | Default configuration set for both the client and server. +defaultConfig :: Mode -> Config +defaultConfig Windows = newSession +defaultConfig Unix = let session = newSession + in session { call = CCall } + + +-- | The parse mode for processArgs +type Mode = Platform + +-- | Read all the pragmas that contain options and then update the session with the new flags +enablePragmas :: Exec () +enablePragmas = + do session <- get + inform _normal "Enabling commandline pragmas..." + let prgmas = (pragmas.workingset) session + cmds = getPragmas (upper_name ++ "_OPTS") prgmas + args = mainFile session : concatMap (\(Pragma _ x)->x) cmds + mode = platform session + + session' <- processConversionPragmas prgmas session + (result,errs) <- if (null args) then return (session',[]) else + liftIO $ do (result,errs) <- processArgs session' mode args + if (not.null) errs then putStrLn " Error(s):" else do return () + mapM_ (\i -> putStrLn (" -> unrecognized input '"++i++"')")) errs + return (result,errs) + if null errs + then put result + else die "Error processing dynamic options" + +-- | Process args tries to parse the commandline arguments for either the client or the server. +-- 1 = The session to initialize things with +-- 2 = Mode to parse for +-- 3 = arguments to parse +-- return = Parsed config or error message +processArgs :: Config -> Mode -> [String] -> IO (Config, [String]) +processArgs cfg mode argv= + case getOpt Permute opt argv of + (o,n,[]) -> process (foldl (flip id) cfg o) n opt + (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header opt)) + where header = "Usage: " ++ name ++ " [OPTION...]" + name = if mode == Windows then exename ++ ".exe" else exename + opt = optDescr --if mode == Windows then optDescrClient else optDescrServer + process a r opt = + case Help `elem` opts of + True -> ioError (userError $ usageInfo header opt) + False -> case Version `elem` opts of + True -> putStrLn versionmsg >> exitSuccess + + False -> case r of + (x:[]) -> do path <- canonicalizePath (addTrailingPathSeparator (tempDIR a)) + base <- getCurrentDirectory + abs_path <- guessPath x + let dir = takeDirectory (normalise x) + bin = combine base dir + return (a { mainFile = x + , platform = mode + , tempDIR = path + , absPath = abs_path + , baseDir = base + },[]) + _ -> ioError (userError $ usageInfo header opt) + where opts = options a + +-- | Create a boolean flag +boolFlag :: String -> String -> (a->Bool->a) -> String -> [OptDescr (a->a)] +boolFlag short long update descr = [ template (update' True) short long descr + , template (update' False) "" ("no"++long) [] ] + where + template value short long descr = Option short [long] (NoArg value) descr + update' = flip update + +-- | Collection of options available +optDescr = optVerbose + : optCall + : optNamespace + : optTempDir + : optVersion + : optHelp + : optGhc + : boolFlag "W" "warnings" (\cfg new -> cfg { warnings = new }) "print all warnings (Default True)" + ++ boolFlag "E" "warnings-as-errors" (\cfg new -> cfg { warnings_as_errors = new + , warnings = new || warnings cfg }) "treat all warnings as errors (Default False)" + ++ boolFlag "T" "keep-temp-files" (\cfg new -> cfg { keep_temps = new }) "keep all the temporary files generated by the pre-processor (Default False)" + ++ boolFlag "" "debug" (\cfg new -> cfg { debugging = new }) ("Enable debugging support which enabled memory profiling.") + +-- | Collection of simple actions +optVerbose = Option ['v'] ["verbose","verbosity" ] (OptArg (\value cfg -> cfg { verbosity = fread (verbosity cfg) value }) "") "set the verbosity level. Requires a number between 0 (off) and 3" +optCall = Option ['C'] ["convention" ] (ReqArg (\value cfg -> cfg { call = cread StdCall value }) "") "set the calling convention used in FFI (Default stdcall)" +optNamespace = Option ['n'] ["name" ] (ReqArg (\value cfg -> cfg { namespace = correct value }) "") ("set the name to use in every generated code. (Default \"" ++ exename ++ "\")") +optTempDir = Option [ ] ["temp","temp-directory" ] (ReqArg (\value cfg -> cfg { tempDIR = value }) "") "set the temporary directory of the pre-processor (Default system temp)" +optHelp = Option ['?'] ["h","help" ] (NoArg (\cfg -> cfg {options = Help:(options cfg)}) ) "Show this help screen" +optVersion = Option [ ] ["version" ] (NoArg (\cfg -> cfg {options = Version:(options cfg)}) ) "Show program version information" +optGhc = Option [ ] ["opt-ghc" ] (ReqArg (\value cfg -> cfg { optGHC = value }) "\"\"") "options to pass along unmodified to ghc during main compilation." + +fread :: Int -> Maybe String -> Int +fread c q = let p = maybe 1 (read' 1) q + in if (p + c) > 3 || (c + p) < 0 then 1 else (c+p) + +cread c q = let p = reads q + hasValue = not $ null p + value = if hasValue then fst $ head p else c + in value + +-- | Get the read in namespace name into a useable format +correct :: String -> String +correct [] = [] +correct (x:xs) = toUpper x : filter isAlphaNum xs + +-- | Because read can fail for parsing stuff other than strings. +-- this function is used to either accept the change. or use the default +read' :: Int -> String -> Int +read' def str = let r = reads str + in if null r then def else (fst.head) r + +-- | The main parse function to call. It takes a mode as parameters and takes a pointer +-- to a function to call should it all succeed. +goArgs :: Mode -> (Config -> IO ()) -> IO () +goArgs mode call = + do args <- getArgs + (result,errs) <- processArgs (defaultConfig mode) mode args + if (not.null) errs then putStrLn " Errors:" else do return () + mapM_ (\i -> putStrLn (" -> unrecognized input '"++i++"')")) errs + if null errs then call result else do return () diff --git a/Tests/Exec/Default.hs b/Tests/Exec/Default.hs new file mode 100644 --- /dev/null +++ b/Tests/Exec/Default.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- Defines a generic producer which is able to generate values to feed to +-- QuickCheck in order to feed the test values. +-- +----------------------------------------------------------------------------- + +module Tests.Exec.Default + ( Default(..) + , geq + , Wrap(..) + , Data() + , Typeable() + , genDefault + ) where + +import Data.Data +import Data.Typeable + +import Data.Generics.Builders +import Data.Generics.Twins + +class Default phi where + nDefault :: phi + +-- | Avoid the need for Undecidable Instances +newtype Wrap a = Wrap { unWrap :: a } + +instance Data a => Default (Wrap a) where + nDefault = Wrap empty + +genDefault :: (Data a, Default (Wrap a)) => a +genDefault = unWrap nDefault + diff --git a/Tests/Exec/Example.hs b/Tests/Exec/Example.hs new file mode 100644 --- /dev/null +++ b/Tests/Exec/Example.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Tests.Exec.Example where + +import Tests.Exec.Default + +data Expr = Mul Expr Expr + | Div Expr Expr + | Sub Expr Expr + | Add Expr Expr + | Parens Expr + | Val Int + | Var String + | Let String Expr Expr + +-- @@ Expr +printExpr :: Expr -> String +printExpr (Mul e1 e2) = printExpr e1 ++ " * " ++ printExpr e2 +printExpr (Div e1 e2) = printExpr e1 ++ " / " ++ printExpr e2 +printExpr (Sub e1 e2) = printExpr e1 ++ " - " ++ printExpr e2 +printExpr (Add e1 e2) = printExpr e1 ++ " + " ++ printExpr e2 +printExpr (Parens e) = "(" ++ printExpr e ++ ")" +printExpr (Val i) = show i +printExpr (Var str) = str +printExpr (Let v e1 e2) = "Let " ++ v ++ " = " ++ printExpr e1 ++ " in " ++ printExpr e2 + +deriving instance Data Expr +deriving instance Typeable Expr +deriving instance Eq Expr diff --git a/Tests/Exec/Hs2lib-testgen.hs b/Tests/Exec/Hs2lib-testgen.hs new file mode 100644 --- /dev/null +++ b/Tests/Exec/Hs2lib-testgen.hs @@ -0,0 +1,65 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : GPL +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- The main entry file for the preprocessor +-- part of the WinDll suite +-- +----------------------------------------------------------------------------- + +module Main where + +import Tests.Exec.CmdArgs +import Tests.Exec.Analyze + +import WinDll.Session.Hs2lib +import WinDll.Utils.Feedback +import WinDll.Utils.DepScanner hiding (main) +import WinDll.Parsers.Hs2lib +import WinDll.Identifier + +import System.Info +import Control.Monad.State +import Control.Monad.Error + +-- | Determine the platform we're currently running on, so we can tweak the defaults a bit +mode :: Platform +mode = case os of + "mingw32" -> Windows + _ -> Unix + +main = goArgs mode bootstrap + +-- | Get the ball rolling on everything +bootstrap :: Config -> IO () +bootstrap cfg = + do val <- runErrorT (evalStateT mainStart cfg) + case val of + (Left str) -> fail ("Program returned error in computation: '" ++ str ++ "'") + (Right _) -> return () + +-- | Start of the main computation +mainStart :: Exec () +mainStart = do inform _normal "Program starting up..." + session <- get + + -- These lines do all the needed calculations + + traceDeps -- Read all dependencies, so we find the tree of files which need parsing + readFromFiles -- Read all datastructures from the read dependencies. + enablePragmas -- Process the enabled commandline pragmas. The other pragmas are determined later on + + -- The following lines do actual writing of outputs + value <- analyzeModule + + -- clean up + cleanup + + inform _detail "Program terminating..." + liftIO $ putStrLn "Done." diff --git a/Tests/Exec/Structs.hs b/Tests/Exec/Structs.hs new file mode 100644 --- /dev/null +++ b/Tests/Exec/Structs.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- This module contains structural information on the module +-- +----------------------------------------------------------------------------- + +module Tests.Exec.Structs where + +import WinDll.Structs.Structures + +import Data.Data +import Data.Typeable + +-- | A Extended version of \Datatype\ to support weighing of +-- constructors etc. +data Arbitrary = Arbitrary { arName :: Name + , arVars :: [TypeName] + , arCons :: DataTypes + , arTag :: TypeTag + } + | Variant { arCost :: Int + , arName :: Name + , arFix :: DataFixity + , arNamed :: AnnWeighedTypes + } + deriving(Eq,Data,Typeable) + +type AnnWeighedTypes = [AnnWeighedType] + +data AnnWeighedType = AnnWeighedType { awtCost :: Int + , awtType :: AnnType + } + deriving(Eq,Data,Typeable) diff --git a/Tests/Exec/Version.hs b/Tests/Exec/Version.hs new file mode 100644 --- /dev/null +++ b/Tests/Exec/Version.hs @@ -0,0 +1,44 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- This module contains versioning information about the test generator tool. +-- +----------------------------------------------------------------------------- + +module Tests.Exec.Version where + +import Data.List ( intercalate ) +import Data.Char ( toUpper ) + +-- | Version Number +verNum :: [Int] +verNum = [0,0,1] + +-- | Version string +verStr :: String +verStr = (intercalate "." . map show) verNum + +-- | Product version +version :: String +version = verStr ++ " ~Experimental~" + +-- | Version message including product name +versionmsg :: String +versionmsg = exename + ++ " Build version " ++ version + ++ "\n(c) Tamar Christina . 2009 - 2011." + +-- | Product name +exename :: String +exename = "Hs2lib-testgen" + +-- | Product name converted to uppercase +upper_name :: String +upper_name = map toUpper exename diff --git a/WinDll/CmdArgs/Hs2lib.hs b/WinDll/CmdArgs/Hs2lib.hs --- a/WinDll/CmdArgs/Hs2lib.hs +++ b/WinDll/CmdArgs/Hs2lib.hs @@ -121,6 +121,7 @@ : optHelp : optLibmain : optIncludes + : optGhc : boolFlag "W" "warnings" (\cfg new -> cfg { warnings = new }) "print all warnings (Default True)" ++ boolFlag "E" "warnings-as-errors" (\cfg new -> cfg { warnings_as_errors = new , warnings = new || warnings cfg }) "treat all warnings as errors (Default False)" @@ -130,7 +131,7 @@ ++ boolFlag "M" "lib" (\cfg new -> cfg { mvcpp = new }) "create a .LIB file for use with the Microsoft Visual C++ compiler. NOTE: This requires the %VSBIN% (case sensitive) environment variable to be set." ++ boolFlag "d" "incl-def" (\cfg new -> cfg { incDef = new }) "Copy the generated .DEF file also to the specified output folder." ++ boolFlag "" "link-dyn" (\cfg new -> cfg { link_dynamic = new }) ("If you have the dynamic version of all your libs installed you can use this flag. (this includes having installed " ++ exename ++ " using -dynamic)") - ++ boolFlag "" "debug" (\cfg new -> cfg { debugging = new }) ("Enable debugging support which enabled memory profiling.") + ++ boolFlag "" "debug" (\cfg new -> cfg { debugging = new }) ("Enable debugging support which enabled memory profiling.") ++ boolFlag "" "preserve-comments" (\cfg new -> cfg { pres_comment = new }) "Enabling this allows you to preserve the haddock description comments of your functions in the generated C _FFI file (Default True)" ++ boolFlag "" "preserve-foreigns" (\cfg new -> cfg { include_foreigns = new }) ("Enabling this will preserve and re-export any foreign declarations you already have declared in modules. NOTE: The Naming Convention must be the same as the generated functions. " ++ exename ++ " finds. (Default True)") ++ boolFlag "" "no-dllmain" (\cfg new -> cfg { dllmanual = new }) "Enabling this will allow you to manual initialise the RTS. Dllmain will no longer make the call to HsInit(). -L and --libmain will be ignored. (Default True)" @@ -151,6 +152,7 @@ optVersion = Option [ ] ["version" ] (NoArg (\cfg -> cfg {options = Version:(options cfg)}) ) "Show program version information" optLibmain = Option ['L'] ["libmain" ] (ReqArg (\value cfg -> cfg { dllmain = value }) "") "set the dllmain file to be used by when compiling the library" optIncForeign = Option [ ] ["native-symbols" ] (ReqArg (\value cfg -> cfg { native_symbols = value : (native_symbols cfg) }) "") "include the .DEF file specified here into the final generated Exports table." +optGhc = Option [ ] ["opt-ghc" ] (ReqArg (\value cfg -> cfg { optGHC = value }) "\"\"") "options to pass along unmodified to ghc during main compilation." fread :: Int -> Maybe String -> Int fread c q = let p = maybe 1 (read' 1) q diff --git a/WinDll/CodeGen/C.hs b/WinDll/CodeGen/C.hs --- a/WinDll/CodeGen/C.hs +++ b/WinDll/CodeGen/C.hs @@ -106,7 +106,8 @@ -- | Return the size of a specified type getSize ann x = let types = createCType (annWorkingSetC ann) x args = init types - sizes = map (lookupSize (annWorkingSetCSize ann)) args + 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. diff --git a/WinDll/CodeGen/CSharp/CSharp.hs b/WinDll/CodeGen/CSharp/CSharp.hs --- a/WinDll/CodeGen/CSharp/CSharp.hs +++ b/WinDll/CodeGen/CSharp/CSharp.hs @@ -192,30 +192,31 @@ else maybe [] id (lookup ty attlist) -- | List containing mapping to C# Attributes from type -attlist ::[(String , [Attr] )] -attlist = [("String" , mk "LPWStr" ) - ,("char*" , [] ) - ,("Int" , [] ) - ,("Int8" , mk "SByte" ) - ,("Int16" , mk "I2" ) - ,("Int32" , mk "I4" ) - ,("Int64" , mk "I8" ) - ,("Word8" , mk "U1" ) - ,("Word16" , mk "U2" ) - ,("Word32" , mk "U4" ) - ,("Word64" , mk "U8" ) - ,("Float" , [] ) - ,("Double" , [] ) - ,("CWString" , mk "LPWStr" ) - ,("CInt" , mk "I4" ) - ,("Bool" , mk "I1" ) - ,("FastString" , mk "LPWStr" ) - ,("FastInt" , mk "I4" ) - ,("Char" , [] ) - ,("CWchar" , [] ) - ,("CChar" , [] ) - ,("Integer" , mk "I8" ) - ,("Rational" , mk "I8" ) - ,("StablePtr" , [] ) - ,("()" , [] )] +attlist ::[(String , [Attr] )] +attlist = [("String" , mk "LPWStr" ) + ,("StringBuilder", mk "LPWStr" ) + ,("char*" , [] ) + ,("Int" , [] ) + ,("Int8" , mk "SByte" ) + ,("Int16" , mk "I2" ) + ,("Int32" , mk "I4" ) + ,("Int64" , mk "I8" ) + ,("Word8" , mk "U1" ) + ,("Word16" , mk "U2" ) + ,("Word32" , mk "U4" ) + ,("Word64" , mk "U8" ) + ,("Float" , [] ) + ,("Double" , [] ) + ,("CWString" , mk "LPWStr" ) + ,("CInt" , mk "I4" ) + ,("Bool" , mk "I1" ) + ,("FastString" , mk "LPWStr" ) + ,("FastInt" , mk "I4" ) + ,("Char" , [] ) + ,("CWchar" , [] ) + ,("CChar" , [] ) + ,("Integer" , mk "I8" ) + ,("Rational" , mk "I8" ) + ,("StablePtr" , [] ) + ,("()" , [] )] where mk x = [Attr Cs.Normal "MarshalAs" ["UnmanagedType." ++ x]] diff --git a/WinDll/CodeGen/Haskell.hs b/WinDll/CodeGen/Haskell.hs --- a/WinDll/CodeGen/Haskell.hs +++ b/WinDll/CodeGen/Haskell.hs @@ -76,14 +76,20 @@ stables = modStablePtrs modInfo debug = debugging session + (simple_datatypes, spec_datatypes) = modDatatypes modInfo -- Code from pragmas - cmds = getPragmas "IMPORT" ((pragmas.workingset) session) - prag_imps = map Import $ concatMap (\(ST.Pragma _ x)->x) cmds + pragmaBuf = (pragmas.workingset) session + cmds0 = getPragmas "IMPORT" pragmaBuf + prag_imps = map Import $ concatMap (\(ST.Pragma _ x)->x) cmds0 - cmds' = getPragmas "INSTANCE" $ (pragmas.workingset) session - args = map (\(ST.Pragma _ x)->unwords x) cmds' + cmds1 = getPragmas "INSTANCE" pragmaBuf + args = map (\(ST.Pragma _ x)->unwords x) cmds1 + + cmds2 = getPragmas "LANGUAGE" pragmaBuf + langs = concatMap (\(ST.Pragma _ x)-> x) cmds2 + mkType' x = let (y:n:_) = words x -- TODO: this is unsafe, fix it ns = read n typenames = zipWith (flip (++).show) [1..ns] (repeat "a") @@ -104,7 +110,8 @@ ,Pragma LANGUAGE "TypeSynonymInstances" ,Pragma LANGUAGE "FlexibleInstances" ,Pragma LANGUAGE "MultiParamTypeClasses" - ] ++ if debug then [Pragma LANGUAGE "CPP"] else []) + ] ++ if debug then [Pragma LANGUAGE "CPP"] else [] + ++ map (Pragma LANGUAGE) langs) (imp ++ map Import deps ++ prag_imps) lets [LocalInclude (name++".h") diff --git a/WinDll/Identifier.hs b/WinDll/Identifier.hs --- a/WinDll/Identifier.hs +++ b/WinDll/Identifier.hs @@ -31,6 +31,8 @@ import WinDll.Structs.Structures import WinDll.Utils.Feedback import WinDll.Utils.Types (simplify) +import WinDll.Utils.KnownTypes +import WinDll.Utils.ListTypes import WinDll.Builder import WinDll.Parsers.Hs2lib import WinDll.Session.Hs2lib @@ -61,7 +63,9 @@ Nothing -> do let _modules = ((map fst) . modules . workingset) session - merged@(Module _ _ _ _ d f _ t) = subject args $ fixpoint (mergeModules _modules) + merged@(Module _ _ _ _ d f _ t) = updateModule + $ subject args + $ fixpoint (mergeModules _modules) (simple_datatypes, spec_datatypes) = partition isSimpleData d (t_mods,missing,spec) = traceModules spec_datatypes imps merged @@ -386,25 +390,6 @@ -- | Lookup typing information using GHC API, in order to find out whether the type is a custom defined type, or a primitive type. lookupType :: Type -> Maybe Type lookupType _type = undefined - --- | A list of the most frequently used types, It's much faster to do list lookup than query GHC, --- so we first look up in this list and then make a call to GHC -knownPrimitives :: TypeNames -knownPrimitives = [ "Int" , "Integer", "Float" , "Double" , "String" , "Char" ,"Word64" - , "Int8" , "Int16" , "Int32" , "Int64" , "Word8" , "Word16" ,"Word32" - , "Int#" , "Float#" , "Double#" , "CWString" , "Bool" , "IO" , "()" - , "CInt" - ] ++ knownPointerTypes - --- | A list of known pointer types, if we find these we should not trace their dependencies. --- because they matter not. -knownPointerTypes :: TypeNames -knownPointerTypes = ["StablePtr", "Ptr"] - --- | The first lookup venue to GHC is looking up based on the type classes that we've already covered by the FFI class. --- So if the type is an instance of the following classes it's safe to ignore them. -knownClasses :: TypeNames -knownClasses = ["Storable" , "IO" , "Num" , "FFIType" ] -- askGHC :: [Types] -> IO [String] -- askGHC diff --git a/WinDll/Lib/Native.hs b/WinDll/Lib/Native.hs --- a/WinDll/Lib/Native.hs +++ b/WinDll/Lib/Native.hs @@ -74,21 +74,21 @@ -- | List of type conversion from C/C++ to C# types nativeC2cslist :: [(String , String )] nativeC2cslist = [("wchar_t*" , "char*" ) - ,("int" , "int" ) - ,("int8_t" , "SByte" ) - ,("int16_t" , "Int16" ) - ,("int32_t" , "Int32" ) - ,("int64_t" , "Int64" ) - ,("uint8_t" , "Byte" ) - ,("uint16_t" , "UInt16" ) - ,("uint32_t" , "UInt32" ) - ,("uint64_t" , "UInt64" ) - ,("float" , "float" ) - ,("double" , "double" ) - ,("wchar_t" , "char" ) - ,("void*" , "void*" ) - ,("void" , "void" ) - ,("long long int" , "long" )] + ,("int" , "int" ) + ,("int8_t" , "SByte" ) + ,("int16_t" , "Int16" ) + ,("int32_t" , "Int32" ) + ,("int64_t" , "Int64" ) + ,("uint8_t" , "Byte" ) + ,("uint16_t" , "UInt16" ) + ,("uint32_t" , "UInt32" ) + ,("uint64_t" , "UInt64" ) + ,("float" , "float" ) + ,("double" , "double" ) + ,("wchar_t" , "char" ) + ,("void*" , "void*" ) + ,("void" , "void" ) + ,("long long int" , "long" )] -- | List containing mapping to C# Types nativeCslist :: Bool -> [(String , String )] @@ -117,7 +117,7 @@ ,("StablePtr" , "IntPtr" ) ,("IntPtr" , "IntPtr" ) ,("()" , "void" )] - where str = if struct then "char*" else "String" + where str = if struct then "char*" else "StringBuilder" -- | List containing mapping to CSizes nativeC_sizes ::[(String , Int)] diff --git a/WinDll/Lib/NativeMapping_Base.cpphs b/WinDll/Lib/NativeMapping_Base.cpphs --- a/WinDll/Lib/NativeMapping_Base.cpphs +++ b/WinDll/Lib/NativeMapping_Base.cpphs @@ -1,7 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE EmptyDataDecls #-} @@ -235,9 +235,9 @@ -- TODO: Can this even be defined using the native functions? -- This instance can't be generated. It'll stay here for now, buy it can only -- be used by types which define toFFI/fromFFI instead of toNative/fromNative -instance (FFIType a b, FFIType c d) => FFIType (a -> c) (b -> d) where - toFFI _ST_ f x = toFFI _ST_ (f (fromFFI _ST_ x)) - fromFFI _ST_ f x = fromFFI _ST_ (f (toFFI _ST_ x)) +-- instance (FFIType a b, FFIType c d) => FFIType (a -> c) (b -> d) where + -- toFFI _ST_ f x = toFFI _ST_ (f (fromFFI _ST_ x)) + -- fromFFI _ST_ f x = fromFFI _ST_ (f (toFFI _ST_ x)) -- | I decided to use a CAString because on windows this gives me a constant 16 value instance FFIType String CWString where @@ -251,7 +251,7 @@ -- | Intermediate conversion instance for storing values of arrays instance (Storable a, FFIType b a) => FFIType [b] (Ptr a) where - toNative _ST_ = (RECORDM(__FILE__, __LINE__, "newArray", (\val -> newArray =<< mapM (toNative _ST_) val))) _ST_ + toNative _ST_ = (RECORDM(__FILE__, __LINE__, "newArray", (\val -> newArray =<< mapM (toNative _ST_ $!) val))) _ST_ fromList _ST_ x ptr = do {(RECORD(__FILE__, __LINE__, "peekArray", id)) _ST_ ptr; i <- fromNative _ST_ x; v <- peekArray i ptr; @@ -365,6 +365,12 @@ poke ptr value = do newptr <- newArray value #endif copyArray (castPtr ptr) newptr (length value) +#ifdef DEBUG + (FREE(__FILE__, __LINE__, "freeArray", F.free)) emptyStack undefined ptr +#else + F.free ptr +#endif + peekElemOff ptr c = do val <- peekArray c (castPtr ptr) #ifdef DEBUG (FREE(__FILE__, __LINE__, "freeArray", F.free)) emptyStack undefined ptr @@ -380,9 +386,9 @@ -- | Instance for Functor classes -- TODO: rewrite this. -instance (Functor f, FFIType a b) => FFIType (f a) (f b) where - toFFI _ST_ = fmap (toFFI _ST_) - fromFFI _ST_ = fmap (fromFFI _ST_) +-- instance (Functor f, FFIType a b) => FFIType (f a) (f b) where + -- toFFI _ST_ = fmap (toFFI _ST_) + -- fromFFI _ST_ = fmap (fromFFI _ST_) -- -- | Instance for Functor classes directly to pointers {- instance (Functor f, FFIType a b,Storable (f b)) => FFIType (f a) (Ptr (f b)) where diff --git a/WinDll/Parsers/Hs2lib.hs b/WinDll/Parsers/Hs2lib.hs --- a/WinDll/Parsers/Hs2lib.hs +++ b/WinDll/Parsers/Hs2lib.hs @@ -103,9 +103,10 @@ -- . {- @@ INSTANCE @@ -} -=- generate type info required to work correctly but also hides the warning of missing data definition -- . {- @@ IMPORT @@ -} -=- Imports to carry over to the new generated module -- . {- @@ HS2C @ @@ -} -=- Specifies what to translate the Haskell htype to the C type, but we also need its size in bytes --- . {- @@ HS2C# @@ -} -=- Specifies what to translate the Haskell htype to the C# type, but we also need its size in bytes +-- . {- @@ HS2CS @@ -} -=- Specifies what to translate the Haskell htype to the C# type, but we also need its size in bytes -- . {- @@ HS2HS @@ -} -=- Specifies what to translate the Haskell htype should be in terms of a compatible FFI type. -- . There needs to be an FFIType instance for these types, or be covered by one of the defaults` +-- . {- @@ LANGUAGE [Pragmas] @@ -} -=- Enable these pragmas in the generated source code. -- . parseComments :: [Comment] -> [Maybe Pragma] parseComments [] = [] @@ -274,11 +275,10 @@ fixC = map (\(c,d)->(map prep c,d)) createFunction :: CommentDecl -> Function - createFunction (p,(TypeSig _ name' typ')) = Function name (tlength typ - 1) ty ann typ + createFunction (p,(TypeSig _ name' typ')) = Function name (tlength typ - 1) typ newAnn typ where args = findStrings typ t_name = head $ findStrings name' typ = simplify typ' - (ann ,ty) = upgradeType newAnn typ export = strip $ drop 6 $ head' $ filter ((=="export").map toLower.takeWhile (not.(\a->isSpace a || a=='='))) p name = t_name @@ -294,9 +294,8 @@ mkName (Exts.Symbol s) = s createExport :: CommentDecl -> Export - createExport (p,(TypeSig _ name' _type)) = Export name exportn ty typ modname + createExport (p,(TypeSig _ name' _type)) = Export name exportn typ typ modname where t_name = head $ findStrings name' - (_ ,ty) = upgradeType newAnn typ typ = simplify _type export = strip $ drop 6 $ head' $ filter ((=="export").map toLower.takeWhile (not.(\a->isSpace a || a=='='))) p exportn = if ("=" `isPrefixOf` export) then (takeWhile (not.isSpace).strip.tail) export else name @@ -330,13 +329,11 @@ -- | Generate free variable names genFreeVars :: WinDll.ModuleName -> (String -> String) -> Int -> [BangType] -> AnnNamedTypes genFreeVars nm f _ [] = [] -genFreeVars nm f n (x:xs) = let (ann, ty) = upgradeType noAnn t - t = getTypeFromBang x - name = (f.show) n - ann' = ann{ annArrayIsList = True, annArrayIndices = [], annModule = nm } - value = case isOnlyList t of - False -> AnnType name ty ann t nm - True -> AnnType name t ann' t nm +genFreeVars nm f n (x:xs) = let ann = noAnn + t = getTypeFromBang x + name = (f.show) n + ann' = ann{ annModule = nm } + value = AnnType name t ann' t nm in value : genFreeVars nm f (n+1) xs -- | Strip a layer away and get to the real type. @@ -348,20 +345,12 @@ -- | Create elements of constructor for records. genNamedVars :: Data b => WinDll.ModuleName -> [([b],BangType)] -> AnnNamedTypes genNamedVars _ [] = [] -genNamedVars n (((x:_),a):xs) = let (ann,val) = upgradeType noAnn ty - ann' = ann{ annArrayIsList = True, annArrayIndices = [], annModule = n } - ty = getTypeFromBang a - name = head $ findStrings x - value = case isOnlyList ty of - False -> AnnType name val ann ty n - True -> AnnType name ty ann' ty n +genNamedVars n (((x:_),a):xs) = let ann = noAnn + ann' = ann{ annModule = n } + ty = getTypeFromBang a + name = head $ findStrings x + value = AnnType name ty ann' ty n in value : genNamedVars n xs - --- | See if the type is just a list type -isOnlyList :: Exts.Type -> Bool -isOnlyList (Exts.TyParen a) = isOnlyList a -isOnlyList (Exts.TyList _) = True -isOnlyList _ = False -- | Find all type strings, taking care to support things like type application findTypeString :: Language.Haskell.Exts.Syntax.Type -> [String] @@ -397,185 +386,6 @@ in not (case y of [] -> True (o:_) -> any (\a->y' `isPrefixOf` a || y'' `isSuffixOf` a || y''' `isInfixOf` a) x) - --- | Upgrade a type by performing actions such as identifying list --- and changing the type to also pass along list counters -upgradeType :: Ann -> Exts.Type -> (Ann, Exts.Type) -upgradeType ann x = - let t' = updateType True ann' t - t = simplify x - lst' = findListIndices ty' - ann' = ann{annArrayIndices = lst'} - ty' = analyzeType True t' - in (ann', ty') - --- | Check to see if the last argument of the type is a list --- in which case we should change the Int before it to Ptr CInt -analyzeType :: Bool -> Exts.Type -> Exts.Type -analyzeType esc t = - let t' = everywhere (mkT embedded) t - lst = findListIndices t' - arr' = tlength t' - 1 - part = arr' `elem` lst - ty' = if part - then changeType esc arr' (\val -> case val of - Exts.TyCon (Exts.UnQual (Exts.Ident "Int")) -> (Exts.TyApp - (Exts.TyCon $ Exts.UnQual $ Exts.Ident "Ptr") - (Exts.TyCon $ Exts.UnQual $ Exts.Ident $ if esc then "CInt" else "Int")) - _ -> val) t' - else t' - in ty' -- D.trace ("IN: " ++ mshowM 2 t') $ D.trace ("OUT: " ++ mshowM 2 ty') $ D.trace (show arr' ++ " - " ++ show lst) ty' - where embedded :: Exts.Type -> Exts.Type - embedded (Exts.TyParen a) = (Exts.TyParen (analyzeType esc a)) - embedded x = x - --- | Update the n-th element of the type with whatever we want -changeType :: Bool -> Int -> (Exts.Type -> Exts.Type) -> Exts.Type -> Exts.Type -changeType _esc n f ty = fst $ (foldTypeIO alg ty) 0 - where alg :: TypeAlgebraIO (Int -> (Exts.Type, Int)) - alg = (\a b c i -> let (c', i') = c i - in (Exts.TyForall a b c', i') - ,\a b i -> let (a', i' ) = a i - (b', i'') = b i' - in (Exts.TyFun a' b', i'') - ,\a b i -> let (b', i') = app b i - in (Exts.TyTuple a b', i) - ,\a i -> let (a', i') = a i - in (Exts.TyList a', i') - ,\o a b i -> let (a', i' ) = a i - (b', i'') = b i' - ix = if o then i'' else i' - in (Exts.TyApp a' b', ix) -- i'') - ,\a i -> let i' = i + 1 - a' = Exts.TyVar a - in if i' == n - then (f a', i') - else (a' , i') - ,\a i -> let i' = i + 1 - a' = Exts.TyCon a - in if i' == n - then (f a', i') - else (a' , i') - ,\a i -> let (a', i') = a i - in (Exts.TyParen a', i') - ,\a b c i -> let (a', i' ) = a i - (c', i'') = c i' - in (Exts.TyInfix a' b c', i'') - ,\a b i -> let (a', i') = a i - in (Exts.TyKind a' b, i') - ) - app :: [Int -> (Exts.Type, Int)] -> Int -> ([Exts.Type], Int) - app [] i = ([], i) - app (x:xs) i = let (x' , i' ) = x i - (xs', i'') = app xs i' - in (x':xs', i'') - --- | Update a type according to the annotations present -updateType :: Bool -> Ann -> Exts.Type -> Exts.Type -updateType esc ann = everywhere (mkT pushType) - where -- | Types to update - pushType :: Exts.Type -> Exts.Type - pushType (Exts.TyFun a b) = let f x = case isIOList x of - True -> Exts.TyFun - (Exts.TyCon $ Exts.UnQual $ Exts.Ident "Int") - False -> id - g x = case isIOList x of - True -> Exts.TyFun - (Exts.TyApp - (Exts.TyCon $ Exts.UnQual $ Exts.Ident "Ptr") - (Exts.TyCon $ Exts.UnQual $ Exts.Ident $ if esc then "CInt" else "Int")) - x - False -> x - in f a $ Exts.TyFun a (g b) - -- pushType (Exts.TyApp a b) = let f x = case isList x of - -- True -> Exts.TyFun - -- (Exts.TyCon $ Exts.UnQual $ Exts.Ident "Int") x - -- False -> x - -- in if isIO a - -- then simplify (move a $ f b) - -- else Exts.TyApp a b - pushType x = x - - -- | Move an IO declaration inwards. - move :: Exts.Type -> Exts.Type -> Exts.Type - move io (Exts.TyFun a b) = Exts.TyFun a (Exts.TyApp io b) - move io rest = Exts.TyApp io rest - - --- | Identifies locations within a Type where lists are found --- The indices provided are the locations of the size variables --- of arrays. The counters start at 0 and not 1 anymore. --- So keep this in mind :) -findListIndices :: Exts.Type -> [Int] -findListIndices ty = coords (embed ty) - where embed :: Exts.Type -> [Bool] - embed (Exts.TyFun a b) = let res = isList a - in if isFun b - then res:embed b - else res:[isIOList b] - embed (Exts.TyParen a) = embed a - embed _ = [] - - coords :: [Bool] -> [Int] - coords b = [i | (x,i) <- zip b [(-1)..], x] - --- | A variant of isList that looks inside IO -isIOList :: Exts.Type -> Bool -isIOList (Exts.TyApp a b) = if isIO a - then isList b - else False -isIOList x = isList x - --- | Update the n-th element of the type with whatever we want, --- only looking at the amount of (->) constructors. -processTypeNode :: Int -> (Exts.Type -> Exts.Type) -> Exts.Type -> Exts.Type -processTypeNode n f ty = fst $ (foldTypeIO alg ty) 1 - where alg :: TypeAlgebraIO (Int -> (Exts.Type, Int)) - alg = (\a b c i -> let (c', i') = c i - in (Exts.TyForall a b c', i') - ,\a b i -> let (a', i' ) = a i - (b', i'') = b (i + 1) - value = Exts.TyFun (if i == n then f a' else a') - (if i+1 == n then f b' else b') - in (value , i'') - ,\a b i -> let (b', i') = app b i - in (Exts.TyTuple a b', i) - ,\a i -> let (a', i') = a i - in (Exts.TyList a', i') - ,\o a b i -> let (a', i' ) = a 0 - (b', i'') = b 0 - in (Exts.TyApp a' b', i) - ,\a i -> (Exts.TyVar a, i) - ,\a i -> (Exts.TyCon a, i) - ,\a i -> let (a', i') = a i - in (Exts.TyParen a', i') - ,\a b c i -> let (a', i' ) = a i - (c', i'') = c i' - in (Exts.TyInfix a' b c', i'') - ,\a b i -> let (a', i') = a i - in (Exts.TyKind a' b, i') - ) - app :: [Int -> (Exts.Type, Int)] -> Int -> ([Exts.Type], Int) - app [] i = ([], i) - app (x:xs) i = let (x' , i' ) = x i - (xs', i'') = app xs i' - in (x':xs', i'') - --- | Updates a type to that which uses IO -mkIO :: Exts.Type -> Exts.Type -mkIO ty = let arr = tlength ty - mk = simplify . Exts.TyApp (Exts.TyCon $ Exts.UnQual $ Exts.Ident "IO") - in if isIO ty - then ty - else if arr == 1 -- if there are no arguments, just directly apply mk - then mk ty - else processTypeNode arr mk ty - --- | Checks to see if the function being returned is in IO -isIO :: Exts.Type -> Bool -isIO ty = let tys = collectLessTypes ty - ret = last tys - in "IO" `isPrefixOf` ret -- simpleTest :: FilePath -> [CommentDecl] -- simpleTest path = let (m0, c0) = unsafePerformIO $ parseFromFile path diff --git a/WinDll/Session/Hs2lib.hs b/WinDll/Session/Hs2lib.hs --- a/WinDll/Session/Hs2lib.hs +++ b/WinDll/Session/Hs2lib.hs @@ -132,6 +132,7 @@ , workingset :: WorkingSet -- ^ @workingset@ The current working set for the project , pipeline :: Builder -- ^ @pipeline@ Contains cleanup information needed when program is exiting , include_foreigns :: Bool -- ^ @include_foreigns@ re-expose foreign declarations found when analyzing modules. + , optGHC :: String -- ^ @optGHC@ Extra options to pass along to ghc , native_symbols :: [FilePath] -- ^ @native_symbols@ The list of Native Symbols to include in the generated .DEF files. } deriving Show @@ -219,6 +220,7 @@ , threaded = False , options = [] , includes = [] + , optGHC = [] , native_symbols = [] , workingset = WorkingSet { dependencies = [] , modules = [] diff --git a/WinDll/Structs/MShow/Haskell.hs b/WinDll/Structs/MShow/Haskell.hs --- a/WinDll/Structs/MShow/Haskell.hs +++ b/WinDll/Structs/MShow/Haskell.hs @@ -22,6 +22,7 @@ import WinDll.Structs.C import WinDll.Structs.MShow.Alignment import WinDll.Parsers.Hs2lib +import WinDll.Utils.ListTypes import WinDll.Session.Hs2lib(addParen) @@ -69,33 +70,37 @@ instance MShow HaskellFunction where mshow (HaskellFunction name orign typ ann _orig) = - let line1 = name ++ " :: " ++ mshowM 3 resTy -- (translatePartial typ) - resTy = (mkIO $ translatePartial (annWorkingSet ann) typ) - arity = tlength typ - 1 -- last argument is result type not an actual argument - vars' = ["a"++show x|x<- [1..arity]] - isList = (arity - 1) `elem` idx - vars = if isList - then init vars' - else vars' - size = last vars' - debug = annDebug ann - pokesz = "poke " ++ size ++ " (toFFI " ++ st ++ "$! length res)" - idx = annArrayIndices ann - front = unwords [name, unwords vars',"="] - indent = (replicate 5 ' ' ++) -- (replicate (length front) ' ' ++) - lines = munch mkFFI debug ((arity - 1) `delete` idx) vars - inner = ((maximum $ map (length.fst) lines)) `max` 3 - binds = map (indent . (\(l,v) -> unwords [l ++ replicate (inner - length l - 1) ' ', "<-", v])) lines - names = map fst lines - res = if isIO typ - then ["res" ++ replicate (inner - 3) ' ', "<-", orign] ++ names - else ["let res =", orign] ++ names - ret = "toNative " ++ st ++ "res" - st = if debug then "st " else "" - defs = map indent $ [unwords res] ++ if isList then [pokesz, ret] else [ret] - dbgDef = if debug - then [indent $ "let st = newStack (__FILE__ ++ \":\" ++ (show __LINE__) ++ \"(" ++ name ++ ")\")"] - else [] + let line1 = name ++ " :: " ++ mshowM 3 resTy -- (translatePartial typ) + resTy = (mkIO $ translatePartial (annWorkingSet ann) typ) + arity = tlength typ - 1 -- last argument is result type not an actual argument + vars' = ["a"++show x|x<- [1..arity]] + isList = (arity - 1) `elem` idx + vars = if isList + then init vars' + else vars' + size = last vars' + debug = annDebug ann + pokesz = [(st `add` "s") ++ " <- toNative " ++ st ++ "$! length res" + ,"poke " ++ size ++ " " ++ (st `add` "s") + ] + trim x = filter (/=' ') x + add x y = trim x ++ trim y + idx = annArrayIndices ann + front = unwords [name, unwords vars',"="] + indent = (replicate 5 ' ' ++) -- (replicate (length front) ' ' ++) + lines = munch mkFFI debug ((arity - 1) `delete` idx) vars + inner = ((maximum $ map (length.fst) lines)) `max` 3 + binds = map (indent . (\(l,v) -> unwords [l ++ replicate (inner - length l - 1) ' ', "<-", v])) lines + names = map fst lines + res = if isIO typ + then ["res" ++ replicate (inner - 3) ' ', "<-", orign] ++ names + else ["let res =", orign] ++ names + ret = "toNative " ++ st ++ "res" + st = if debug then "st " else "" + defs = map indent $ [unwords res] ++ if isList then pokesz ++ [ret] else [ret] + dbgDef = if debug + then [indent $ "let st = newStack (__FILE__ ++ \":\" ++ (show __LINE__) ++ \"(" ++ name ++ ")\")"] + else [] in unlines $ [line1,front] ++ addDo (dbgDef ++ binds ++ defs) where addDo :: [String] -> [String] addDo [] = [" do "] @@ -128,7 +133,7 @@ then let (a:xs) = l st1 = mkBinds dbg "st" "toNative" st2 = mkBinds dbg "st" "toNative" - in ([(a++"sp", mkDbgSym dbg st1 "toNative " ++ "$ length "++a) + in ([(a++"sp", mkDbgSym dbg st1 "toNative " ++ "$! length "++a) ,(a++ "p", mkDbgSym dbg st2 "toNative " ++ a)], xs, (+1)) else let (a:xs) = l st = mkBinds dbg "st" "toNative" @@ -172,19 +177,23 @@ else vars' size = last vars' debug = annDebug ann - pokesz = "poke " ++ size ++ " (toFFI " ++ st ++ "$! length res)" + pokesz = [(st `add` "s") ++ " <- toNative " ++ st ++ "$! length res" + ,"poke " ++ size ++ " $! " ++ (st `add` "s") + ] ret = "toNative " ++ st ++ "res" ret2 = if isList && not origIO then mkDbg debug "fromNative " ++ "(lld res)" else mkDbg debug "fromNative " ++ "res" mkUsf b = if not b then (++" unsafePerformIO $") else id transtyIO = isIO transty origIO = isIO orig st = if debug then "st " else "" + trim x = filter (/=' ') x + add x y = trim x ++ trim y in unlines $ ["instance FFIType " ++ mshowM 2 (addParen orig) ++ " " ++ name ++ "Ptr where" - ," toNative " ++ st ++ "x = mk" ++ name ++ " (toFFI " ++ st ++ "x)" - ," fromFFI " ++ st ++ "x = fromFFI " ++ st ++ "(dyn" ++ name ++ " x)" + ," toNative " ++ st ++ "x = mk" ++ name ++ " =<< toNative " ++ st ++ "x" + ," fromNative " ++ st ++ "x = fromNative " ++ st ++ "(dyn" ++ name ++ " x)" ," freeFFI " ++ st ++ "x = freeHaskellFunPtr " - ] ++ if null (annArrayIndices ann) then [] + ] ++ if False then [] -- null (annArrayIndices ann) then [] else ["" ,"instance FFIType " ++ mshowM 2 (addParen orig) ++ " " ++ mshowM 3 (addParen transty) ++ " where" ,unlines $ (unwords $ (" toFFI " ++ st ++ "f") : vars' ++ [mkUsf transtyIO "="]) : mkResult mkFFI vars ret pokesz isList transtyIO idx' True @@ -203,7 +212,7 @@ res = if io && sat then ["res" ++ replicate (inner - 3) ' ', "<- f"] ++ names else ["let res = f"] ++ names - defs = map indent $ [unwords res] ++ if lst then [pk, rt] else [rt] + defs = map indent $ [unwords res] ++ if lst then pk ++ [rt] else [rt] in addDo (binds ++ defs) instance MShow Include where diff --git a/WinDll/Structs/MShow/HaskellSrcExts.hs b/WinDll/Structs/MShow/HaskellSrcExts.hs --- a/WinDll/Structs/MShow/HaskellSrcExts.hs +++ b/WinDll/Structs/MShow/HaskellSrcExts.hs @@ -17,6 +17,7 @@ import WinDll.Structs.MShow.MShow import WinDll.Structs.Folds.HaskellSrcExts import WinDll.Structs.Types +import WinDll.Utils.KnownTypes -- import WinDll.Utils.Types import qualified Language.Haskell.Exts as Exts @@ -25,6 +26,8 @@ import Data.List +import qualified Debug.Trace as D + instance MShow Exts.Name where mshow (Exts.Ident s) = s mshow (Exts.Symbol s) = s @@ -106,7 +109,7 @@ fold f (Exts.TyInfix a b c) = (fold f a) ++ " " ++ mshow b ++ " " ++ (fold f c) fold f (Exts.TyKind a b) = const (fold f a) b - mshowM 4 = fold True + mshowM 4 = fold True where fold f (Exts.TyForall a b c) = (const . const id) a b (fold f c) fold f (Exts.TyFun a b) = (fold f a) ++" -> "++ (fold f b) @@ -114,14 +117,18 @@ True -> showTuple a b (fold f) False -> prettyPrint t fold f t@(Exts.TyList a) = case f of - True -> "(Ptr ("++ (fold f a) ++ "))" + True -> "(Ptr ("++ (fold (isPrime a) a) ++ "))" False -> prettyPrint t fold f (Exts.TyApp a b) = let name = (fold True a) in case name of "IO" -> name ++ " (" ++ fold f b ++ ")" - _ -> "(" ++ name ++ " " ++ fold False b ++ ")" + _ | isPrime a || "Ptr" `isSuffixOf` name + -> "(" ++ name ++ " " ++ fold (not $ isList b) b ++ ")" + | otherwise -> "(" ++ name ++ " " ++ fold False b ++ ")" fold f (Exts.TyVar a) = mshow a - fold f (Exts.TyCon a) = mshow a + fold f (Exts.TyCon a) = case f of + True -> mshow a + False -> "(Ptr " ++ mshow a ++ ")" fold f (Exts.TyParen a) = "(" ++ (fold f a) ++ ")" fold f (Exts.TyInfix a b c) = (fold f a) ++ " " ++ mshow b ++ " " ++ (fold f c) fold f (Exts.TyKind a b) = const (fold f a) b @@ -132,6 +139,21 @@ isList (Exts.TyList _) = True isList (Exts.TyParen a) = isList a isList _ = False + +-- | Checks to see if the given type is a constructor. Also checks in Parens +isCon :: Type -> Bool +isCon (Exts.TyCon _) = True +isCon (Exts.TyParen a) = isCon a +isCon _ = False + +-- | checks to see if a type is part of the known list of primitives +isPrime :: Type -> Bool +isPrime ty = if isCon ty + then (take ty) `elem` knownPrimitives + else False + where take :: Type -> TypeName + take (Exts.TyParen a) = take a + take x = prettyPrint x -- | Checks to see if the given type is a function. Also checks in Parens isFun :: Type -> Bool diff --git a/WinDll/Structs/Structures.hs b/WinDll/Structs/Structures.hs --- a/WinDll/Structs/Structures.hs +++ b/WinDll/Structs/Structures.hs @@ -87,9 +87,20 @@ -- | Datatype and Newtype declarations Tagged with some extra information -- like the full type name. This is needed because the declarations will be -- processed independently of their module declarations. So this information is needed -data DataType = DataType Name [TypeName] DataTypes TypeTag - | NewType Name [TypeName] DataType TypeTag - | Constr Name DataFixity AnnNamedTypes +data DataType = DataType { dtName :: Name + , dtVars :: [TypeName] + , dtCons :: DataTypes + , dtTag :: TypeTag + } + | NewType { dtName :: Name + , dtVars :: [TypeName] + , dtCon :: DataType + , dtTag :: TypeTag + } + | Constr { dtName :: Name + , dtFix :: DataFixity + , dtNamed :: AnnNamedTypes + } deriving(Eq,Data,Typeable) -- | The fixity of the constructor diff --git a/WinDll/Utils/KnownTypes.hs b/WinDll/Utils/KnownTypes.hs new file mode 100644 --- /dev/null +++ b/WinDll/Utils/KnownTypes.hs @@ -0,0 +1,36 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- This modules contains the list of known primitive types. This is one of the +-- the lists that needs expanding in order to add new native types. +-- +----------------------------------------------------------------------------- +module WinDll.Utils.KnownTypes where + +import WinDll.Structs.Types + +-- | A list of the most frequently used types, It's much faster to do list lookup than query GHC, +-- so we first look up in this list and then make a call to GHC +knownPrimitives :: TypeNames +knownPrimitives = [ "Int" , "Integer", "Float" , "Double" , "String" , "Char" ,"Word64" + , "Int8" , "Int16" , "Int32" , "Int64" , "Word8" , "Word16" ,"Word32" + , "Int#" , "Float#" , "Double#" , "CWString" , "Bool" , "IO" , "()" + , "CInt" + ] ++ knownPointerTypes + +-- | A list of known pointer types, if we find these we should not trace their dependencies. +-- because they matter not. +knownPointerTypes :: TypeNames +knownPointerTypes = ["StablePtr", "Ptr"] + +-- | The first lookup venue to GHC is looking up based on the type classes that we've already covered by the FFI class. +-- So if the type is an instance of the following classes it's safe to ignore them. +knownClasses :: TypeNames +knownClasses = ["Storable" , "IO" , "Num" , "FFIType" ] diff --git a/WinDll/Utils/ListTypes.hs b/WinDll/Utils/ListTypes.hs new file mode 100644 --- /dev/null +++ b/WinDll/Utils/ListTypes.hs @@ -0,0 +1,231 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- Various functions to detect and record list types within a +-- given type. +-- +----------------------------------------------------------------------------- + +module WinDll.Utils.ListTypes where + +import qualified Language.Haskell.Exts as Exts + +import Data.Generics +import Data.List + +import WinDll.Structs.Structures hiding (Module) +import qualified WinDll.Structs.Structures as WinDll +import WinDll.Structs.MShow.HaskellSrcExts +import WinDll.Structs.Folds.HaskellSrcExts +import WinDll.Utils.Types + +-- | Upgrade a type by performing actions such as identifying list +-- and changing the type to also pass along list counters +upgradeType :: Ann -> Exts.Type -> (Ann, Exts.Type) +upgradeType ann x = + let t' = updateType True ann' t + t = simplify x + lst' = findListIndices ty' + ann' = ann{annArrayIndices = lst'} + ty' = analyzeType True t' + in (ann', ty') + +-- | Check to see if the last argument of the type is a list +-- in which case we should change the Int before it to Ptr CInt +analyzeType :: Bool -> Exts.Type -> Exts.Type +analyzeType esc t = + let t' = everywhere (mkT embedded) t + lst = findListIndices t' + arr' = tlength t' - 1 + part = arr' `elem` lst + ty' = if part + then changeType esc arr' (\val -> case val of + Exts.TyCon (Exts.UnQual (Exts.Ident "Int")) -> (Exts.TyApp + (Exts.TyCon $ Exts.UnQual $ Exts.Ident "Ptr") + (Exts.TyCon $ Exts.UnQual $ Exts.Ident $ if esc then "CInt" else "Int")) + _ -> val) t' + else t' + in ty' -- D.trace ("IN: " ++ mshowM 2 t') $ D.trace ("OUT: " ++ mshowM 2 ty') $ D.trace (show arr' ++ " - " ++ show lst) ty' + where embedded :: Exts.Type -> Exts.Type + embedded (Exts.TyParen a) = (Exts.TyParen (analyzeType esc a)) + embedded x = x + +-- | Update the n-th element of the type with whatever we want +changeType :: Bool -> Int -> (Exts.Type -> Exts.Type) -> Exts.Type -> Exts.Type +changeType _esc n f ty = fst $ (foldTypeIO alg ty) 0 + where alg :: TypeAlgebraIO (Int -> (Exts.Type, Int)) + alg = (\a b c i -> let (c', i') = c i + in (Exts.TyForall a b c', i') + ,\a b i -> let (a', i' ) = a i + (b', i'') = b i' + in (Exts.TyFun a' b', i'') + ,\a b i -> let (b', i') = app b i + in (Exts.TyTuple a b', i) + ,\a i -> let (a', i') = a i + in (Exts.TyList a', i') + ,\o a b i -> let (a', i' ) = a i + (b', i'') = b i' + ix = if o then i'' else i' + in (Exts.TyApp a' b', ix) -- i'') + ,\a i -> let i' = i + 1 + a' = Exts.TyVar a + in if i' == n + then (f a', i') + else (a' , i') + ,\a i -> let i' = i + 1 + a' = Exts.TyCon a + in if i' == n + then (f a', i') + else (a' , i') + ,\a i -> let (a', i') = a i + in (Exts.TyParen a', i') + ,\a b c i -> let (a', i' ) = a i + (c', i'') = c i' + in (Exts.TyInfix a' b c', i'') + ,\a b i -> let (a', i') = a i + in (Exts.TyKind a' b, i') + ) + app :: [Int -> (Exts.Type, Int)] -> Int -> ([Exts.Type], Int) + app [] i = ([], i) + app (x:xs) i = let (x' , i' ) = x i + (xs', i'') = app xs i' + in (x':xs', i'') + +-- | Update a type according to the annotations present +updateType :: Bool -> Ann -> Exts.Type -> Exts.Type +updateType esc ann = everywhere (mkT pushType) + where -- | Types to update + pushType :: Exts.Type -> Exts.Type + pushType (Exts.TyFun a b) = let f x = case isIOList x of + True -> Exts.TyFun + (Exts.TyCon $ Exts.UnQual $ Exts.Ident "Int") + False -> id + g x = case isIOList x of + True -> Exts.TyFun + (Exts.TyApp + (Exts.TyCon $ Exts.UnQual $ Exts.Ident "Ptr") + (Exts.TyCon $ Exts.UnQual $ Exts.Ident $ if esc then "CInt" else "Int")) + x + False -> x + in f a $ Exts.TyFun a (g b) + -- pushType (Exts.TyApp a b) = let f x = case isList x of + -- True -> Exts.TyFun + -- (Exts.TyCon $ Exts.UnQual $ Exts.Ident "Int") x + -- False -> x + -- in if isIO a + -- then simplify (move a $ f b) + -- else Exts.TyApp a b + pushType x = x + + -- | Move an IO declaration inwards. + move :: Exts.Type -> Exts.Type -> Exts.Type + move io (Exts.TyFun a b) = Exts.TyFun a (Exts.TyApp io b) + move io rest = Exts.TyApp io rest + + +-- | Identifies locations within a Type where lists are found +-- The indices provided are the locations of the size variables +-- of arrays. The counters start at 0 and not 1 anymore. +-- So keep this in mind :) +findListIndices :: Exts.Type -> [Int] +findListIndices ty = coords (embed ty) + where embed :: Exts.Type -> [Bool] + embed (Exts.TyFun a b) = let res = isList a + in if isFun b + then res:embed b + else res:[isIOList b] + embed (Exts.TyParen a) = embed a + embed _ = [] + + coords :: [Bool] -> [Int] + coords b = [i | (x,i) <- zip b [(-1)..], x] + +-- | A variant of isList that looks inside IO +isIOList :: Exts.Type -> Bool +isIOList (Exts.TyApp a b) = if isIO a + then isList b + else False +isIOList x = isList x + +-- | Update the n-th element of the type with whatever we want, +-- only looking at the amount of (->) constructors. +processTypeNode :: Int -> (Exts.Type -> Exts.Type) -> Exts.Type -> Exts.Type +processTypeNode n f ty = fst $ (foldTypeIO alg ty) 1 + where alg :: TypeAlgebraIO (Int -> (Exts.Type, Int)) + alg = (\a b c i -> let (c', i') = c i + in (Exts.TyForall a b c', i') + ,\a b i -> let (a', i' ) = a i + (b', i'') = b (i + 1) + value = Exts.TyFun (if i == n then f a' else a') + (if i+1 == n then f b' else b') + in (value , i'') + ,\a b i -> let (b', i') = app b i + in (Exts.TyTuple a b', i) + ,\a i -> let (a', i') = a i + in (Exts.TyList a', i') + ,\o a b i -> let (a', i' ) = a 0 + (b', i'') = b 0 + in (Exts.TyApp a' b', i) + ,\a i -> (Exts.TyVar a, i) + ,\a i -> (Exts.TyCon a, i) + ,\a i -> let (a', i') = a i + in (Exts.TyParen a', i') + ,\a b c i -> let (a', i' ) = a i + (c', i'') = c i' + in (Exts.TyInfix a' b c', i'') + ,\a b i -> let (a', i') = a i + in (Exts.TyKind a' b, i') + ) + app :: [Int -> (Exts.Type, Int)] -> Int -> ([Exts.Type], Int) + app [] i = ([], i) + app (x:xs) i = let (x' , i' ) = x i + (xs', i'') = app xs i' + in (x':xs', i'') + +-- | Updates a type to that which uses IO +mkIO :: Exts.Type -> Exts.Type +mkIO ty = let arr = tlength ty + mk = simplify . Exts.TyApp (Exts.TyCon $ Exts.UnQual $ Exts.Ident "IO") + in if isIO ty + then ty + else if arr == 1 -- if there are no arguments, just directly apply mk + then mk ty + else processTypeNode arr mk ty + +-- | Checks to see if the function being returned is in IO +isIO :: Exts.Type -> Bool +isIO ty = let tys = collectLessTypes ty + ret = last tys + in "IO" `isPrefixOf` ret + +-- | See if the type is just a list type +isOnlyList :: Exts.Type -> Bool +isOnlyList (Exts.TyParen a) = isOnlyList a +isOnlyList (Exts.TyList _) = True +isOnlyList _ = False + +updateModule :: WinDll.Module -> WinDll.Module +updateModule = everywhere (mkT mkFunction `extT` mkExport `extT` mkDataType) + where mkFunction e@(WinDll.Function{}) = let (newAnn, ty) = upgradeType (fnAnn e) (fnType e) + in e{fnType = ty, fnAnn = newAnn } + mkExport e@(WinDll.Export{} ) = let (_, ty) = upgradeType noAnn (exType e) + in e{exType = ty} + mkDataType e@(WinDll.DataType{}) = let dt = dtCons e + in e{dtCons = map mkConstr dt} + mkDataType e@(WinDll.NewType{} ) = let dt = dtCon e + in e{dtCon = mkConstr dt} + mkDataType e = e + mkConstr e@(WinDll.Constr{} ) = let dt = dtNamed e + in e{dtNamed = map mkAnnNamedTypes dt} + mkAnnNamedTypes e@(AnnType{} ) = let (newAnn, ty) = upgradeType (antAnn e) (antType e) + ann' = newAnn{annArrayIsList = True, annArrayIndices = []} + in case isOnlyList (antType e) of + False -> e{antType = ty, antAnn = newAnn} + True -> e{antAnn = ann'} diff --git a/WinDll/Utils/Pragma.hs b/WinDll/Utils/Pragma.hs --- a/WinDll/Utils/Pragma.hs +++ b/WinDll/Utils/Pragma.hs @@ -31,7 +31,7 @@ -- consists of two strings seperated by a @ sign. validate :: String -> Pragma -> Exec Pragma validate mask p@(Pragma nm ld) - = do guard (not $ isValid (words mask) ld) >> + = do when (not $ isValid (words mask) ld) (die $ "Syntax error in Pragma " ++ nm ++ ", supplied value '" ++ unwords ld ++ "' does not match mask '" ++ mask ++ "'") return p @@ -51,10 +51,12 @@ -- proper conversion sets processConversionPragmas :: [Pragma] -> Session -> Exec Session processConversionPragmas prg session - = do hs2c <- mapM (validate "# #@#") $ getPragmas "HS2C" prg - hs2cs <- mapM (validate "# #" ) $ getPragmas "HS2C#" prg + = do inform _detail "Validating pragmas..." + hs2c <- mapM (validate "# #@#") $ getPragmas "HS2C" prg + hs2cs <- mapM (validate "# #" ) $ getPragmas "HS2CS" prg hs2hs <- mapM (validate "# #" ) $ getPragmas "HS2HS" prg + inform _detail "Updating session..." put session updateFromPragma hs2c updt1 (\x y->y{n_hs2c =x ++ nativeLisths2c}) updateFromPragma hs2c updt2 (\x y->y{n_csize=x ++ nativeC_sizes}) diff --git a/WinDll/Utils/Processes.hs b/WinDll/Utils/Processes.hs --- a/WinDll/Utils/Processes.hs +++ b/WinDll/Utils/Processes.hs @@ -145,6 +145,7 @@ fullfile = dirPath build os = platform session dir = baseDir session + extras = optGHC session return (output,["-fglasgow-exts" ,"--make" ] @@ -169,6 +170,10 @@ ,"-funfolding-use-threshold=16" ,"-optc-O3" ,"-optc-ffast-math" + ] + ++ if null extras then [] else [extras] ++ + [ + -- ,"-debug" -- ,"-fno-full-laziness" -- due to calls to unsafePerformIO -- ,"-fno-cse" -- prevent any cse to be performed. -- ,"-prof" diff --git a/WinDll/Version/Hs2lib.hs b/WinDll/Version/Hs2lib.hs --- a/WinDll/Version/Hs2lib.hs +++ b/WinDll/Version/Hs2lib.hs @@ -19,7 +19,7 @@ -- | Version Number verNum :: [Int] -verNum = [0,5,2] +verNum = [0,5,5] -- | Version string verStr :: String