diff --git a/data/blas.csv b/data/blas.csv --- a/data/blas.csv +++ b/data/blas.csv @@ -1,7 +1,6 @@ Generic,Real,Float,Double,Complex,ComplexFloat,ComplexDouble,Miscellaneous asum,asum,sasum.f,dasum.f,,,, axpy,axpy,saxpy.f,daxpy.f,axpy,caxpy.f,zaxpy.f, -cabs1,,,,cabs1,scabs1.f,dcabs1.f, casum,,,,casum,scasum.f,dzasum.f, cnrm2,,,,cnrm2,scnrm2.f,dznrm2.f, copy,copy,scopy.f,dcopy.f,copy,ccopy.f,zcopy.f, diff --git a/lapack-ffi-tools.cabal b/lapack-ffi-tools.cabal --- a/lapack-ffi-tools.cabal +++ b/lapack-ffi-tools.cabal @@ -1,5 +1,5 @@ Name: lapack-ffi-tools -Version: 0.1.1 +Version: 0.1.2 License: BSD3 License-File: LICENSE Author: Henning Thielemann @@ -12,7 +12,8 @@ The original implementation is written in FORTRAN. . The program in this package generates the modules - for the packages @blas-ffi@, @blas-carray@, @lapack-ffi@, @lapack-carray@ + for the packages @blas-ffi@, @blas-comfort-array@, @blas-carray@, + @lapack-ffi@, @lapack-comfort-array@, @lapack-carray@ from the FORTRAN source files. Tested-With: GHC==7.4.2, GHC==7.8.4 Cabal-Version: 1.14 @@ -22,7 +23,7 @@ data/lapack.csv Source-Repository this - Tag: 0.1.1 + Tag: 0.1.2 Type: darcs Location: http://hub.darcs.net/thielema/lapack-ffi-tools/ diff --git a/src/CreateBinding.hs b/src/CreateBinding.hs --- a/src/CreateBinding.hs +++ b/src/CreateBinding.hs @@ -168,6 +168,12 @@ Parser.InputWorkspace -> True _ -> False +isTmpIOArray :: Parser.Direction -> Bool +isTmpIOArray dir = + case dir of + Parser.Input -> False + _ -> True + contFromArrayType :: Parameter -> String contFromArrayType (name, (typ, dims, dir)) = case dims of @@ -176,7 +182,7 @@ then contFromType typ ++ " " ++ name else "Call.alloca" Type.Array _ -> - (if isIOArray dir then "Call.ioarray " else "Call.array ") ++ name + (if isTmpIOArray dir then "Call.ioarray " else "Call.array ") ++ name Type.Function _ _ -> "pure " ++ name parens :: String -> String @@ -185,12 +191,6 @@ parensIfNeeded :: String -> String parensIfNeeded expr = if all isAlphaNum expr then expr else parens expr -arrayTypeFromBool :: Bool -> String -arrayTypeFromBool mutable = if mutable then "IOCArray" else "CArray" - -arrayTypeFromDir :: Parser.Direction -> String -arrayTypeFromDir = arrayTypeFromBool . isIOArray - isInputDir :: Parser.Direction -> Bool isInputDir dir = case dir of @@ -274,22 +274,27 @@ peekOut :: Parameter -> String -peekOut (name, (typ, dims, _dir)) = +peekOut (name, (typ, dims, dir)) = case dims of Type.Scalar -> case typ of Type.Character -> printf "fmap castCCharToChar (peek %sPtr)" name Type.Integer -> printf "fmap fromIntegral (peek %sPtr)" name _ -> printf "peek %sPtr" name - Type.Array _ -> "pure " ++ name + Type.Array _ -> + if isIOArray dir + then "pure " ++ name + else "Call.freezeArray " ++ name Type.Function _ _ -> printf "error \"function %s cannot be an output\"" name -formatOutputTuple :: Type.Format typ => Type.Wrapper typ -> String -formatOutputTuple (Type.Wrapper _inputs returnType outputs) = +formatOutputTuple :: + (Type.Array array, Type.Format typ) => + array -> Type.Wrapper array typ -> String +formatOutputTuple array (Type.Wrapper _inputs returnType outputs) = let outputTuple = CreateBinding.parens $ List.intercalate ", " $ - map (uncurry $ Type.formatArray "CArray") outputs + map (uncurry $ Type.formatArray array False) outputs in case (returnType, outputs) of (Nothing, _) -> outputTuple (Just t, []) -> Type.format t @@ -297,9 +302,12 @@ (Just t, _) -> printf "(%s, %s)" (Type.format t) outputTuple -formatCArrayWrapper :: - (String, [Parameter], Maybe Type.Mono) -> (String, Type.Wrapper Type.Mono) -formatCArrayWrapper (name, params0, returnType) = +formatWrapper :: + (Type.Array array) => + array -> + (String, [Parameter], Maybe Type.Mono) -> + (String, Type.Wrapper array Type.Mono) +formatWrapper array (name, params0, returnType) = let prepare (param,info) = (param, mapSnd3 @@ -372,16 +380,20 @@ map (\(param,(typ,dims,dir)) -> printf " %s {- ^ %s -} ->" - (Type.formatArray (arrayTypeFromDir dir) typ dims) param) + (Type.formatArray array (isIOArray dir) typ dims) param) inputs ++ - (" IO " ++ formatOutputTuple wrapper) : + (" IO " ++ formatOutputTuple array wrapper) : (name ++ concatMap ((' ':) . fst) inputs ++ " = do") : map (\(param,(dimVars,dir)) -> let format = - if isIOArray dir - then " %s <- Call.sizes%d <$> getBounds %s" - else " let %s = Call.sizes%d $ bounds %s" + Type.caseComfortCArray array + (if isIOArray dir + then " let %s = Call.sizes%d $ MutArray.shape %s" + else " let %s = Call.sizes%d $ Array.shape %s") + (if isIOArray dir + then " %s <- Call.sizes%d <$> getBounds %s" + else " let %s = Call.sizes%d $ bounds %s") dimIdents = Match.take dimVars $ dimNames param in printf format (Type.formatTuple dimIdents) (length dimIdents) param) diff --git a/src/MainAll.hs b/src/MainAll.hs --- a/src/MainAll.hs +++ b/src/MainAll.hs @@ -4,8 +4,8 @@ import qualified Type import Parser.Signature (Identifier(Identifier)) import CreateBinding - (formatForeignCall, formatCArrayWrapper, parseHeader, - foreignFromParameters, arrayTypeFromBool) + (formatForeignCall, formatWrapper, parseHeader, + foreignFromParameters) import qualified Text.ParserCombinators.Parsec as Parsec import qualified Text.ParserCombinators.Parsec.Error as ParsecError @@ -36,7 +36,7 @@ import Data.HashMap.Lazy (HashMap) import Data.Map (Map) import Data.Csv ((.:)) -import Data.Tuple.HT (mapSnd, thd3) +import Data.Tuple.HT (mapSnd, fst3, snd3, thd3) import Data.Maybe (isNothing, mapMaybe) import Data.Bool.HT (if') import Data.Char (toUpper) @@ -57,13 +57,15 @@ instance Generalize Type.Foreign where formatGenericSig = Type.formatForeign -instance Generalize Type.Wrapper where +instance (Type.Array array) => Generalize (Type.Wrapper array) where formatGenericSig wrapper@(Type.Wrapper inputs _returnType _outputs) = + let array = Type.arrayFromWrapper wrapper + in concatMap - (\(typ,dims,dir) -> - printf "%s -> " (Type.formatArray (arrayTypeFromBool dir) typ dims)) + (\(typ,dims,mut) -> + printf "%s -> " (Type.formatArray array mut typ dims)) inputs ++ - "IO " ++ CreateBinding.formatOutputTuple wrapper + "IO " ++ CreateBinding.formatOutputTuple array wrapper prepareClassCall :: (Generalize f) => (String, f Type.Poly) -> (String, String, String) @@ -228,10 +230,13 @@ processFunction :: (PathClass.AbsRel ar) => Bool -> - (Path.File ar, Path.File ar) -> + (Path.File ar, Path.File ar, Path.File ar) -> URL -> String -> Path.File ar -> - IO (Maybe (Type.Foreign Type.Mono, Type.Wrapper Type.Mono)) -processFunction output (ffiFile, carrayFile) url haskellName srcPath = do + IO (Maybe (Type.Foreign Type.Mono, + Type.Wrapper Type.ComfortArray Type.Mono, + Type.Wrapper Type.CArray Type.Mono)) +processFunction output + (ffiFile, comfortArrayFile, carrayFile) url haskellName srcPath = do content <- PathIO.readFile srcPath let msignature = do sig <- @@ -256,14 +261,21 @@ (printf url (Path.toString $ takeFileName srcPath) :: String) let foreignSig = foreignFromParameters params returnType + comfortArrayWrapper <- do + let (mono,poly) = + formatWrapper Type.ComfortArray + (haskellName, params, returnType) + when output $ PathIO.appendFile comfortArrayFile $ haddock ++ mono + return poly carrayWrapper <- do let (mono,poly) = - formatCArrayWrapper (haskellName, params, returnType) + formatWrapper Type.CArray + (haskellName, params, returnType) when output $ PathIO.appendFile carrayFile $ haddock ++ mono return poly when output $ PathIO.appendFile ffiFile $ haddock ++ formatForeignCall ((haskellName, name), foreignSig) - return $ Just (foreignSig, carrayWrapper) + return $ Just (foreignSig, comfortArrayWrapper, carrayWrapper) unifyFunctions :: (Type.Unification f, PathClass.AbsRel ar) => @@ -345,7 +357,8 @@ optParser :: OP.Parser - (URL, (Path.AbsRelFile, Path.AbsRelDir, Path.AbsRelDir, Path.AbsRelDir)) + (URL, (Path.AbsRelFile, Path.AbsRelDir, + (Path.AbsRelDir, Path.AbsRelDir, Path.AbsRelDir))) optParser = App.lift2 (,) (OP.strOption $ @@ -353,17 +366,22 @@ OP.metavar "URL" <> OP.value "" <> OP.help "Printf template for URL of online help") $ - App.lift4 (,,,) + App.lift3 (,,) (pathArgument $ OP.metavar "CSV" <> OP.help "Spreadsheet containing grouped Fortran file names") (pathArgument $ OP.metavar "SRCDIR" <> OP.help "Input directory containing Fortran files") + $ + App.lift3 (,,) (pathArgument $ OP.metavar "FFIDIR" <> OP.help "Output directory for Haskell FFI modules") (pathArgument $ + OP.metavar "COMFORTARRAYDIR" <> + OP.help "Output directory for Haskell comfort-array wrapper modules") + (pathArgument $ OP.metavar "CARRAYDIR" <> OP.help "Output directory for Haskell CArray wrapper modules") @@ -378,9 +396,10 @@ main :: IO () main = do - (url, (csvFile, srcDir, ffiDir, carrayDir)) <- + (url, (csvFile, srcDir, (ffiDir, comfortArrayDir, carrayDir))) <- OP.execParser $ optionInfo optParser createDirectoryIfMissing True ffiDir + createDirectoryIfMissing True comfortArrayDir createDirectoryIfMissing True carrayDir (headers, functionSets) <- @@ -392,8 +411,9 @@ for (filter (not . flip HashMap.member unifiedColumnsMap) $ Fold.toList headers) $ \columnName -> fmap ((,) columnName) $ - liftA2 (,) + App.lift3 (,,) (writeHeader ffiDir columnName Nothing) + (writeHeader comfortArrayDir columnName Nothing) (writeHeader carrayDir columnName Nothing) sigs <- @@ -417,5 +437,7 @@ writeUnified dstDir =<< traverse (Func.mapSnd (unifyFunctions msg . fmap (mapSnd select))) sigs - runUnification ffiDir "Cannot generalize FFI functions." fst - runUnification carrayDir "Cannot generalize CArray functions." snd + runUnification ffiDir "Cannot generalize FFI functions." fst3 + runUnification comfortArrayDir + "Cannot generalize comfort-array functions." snd3 + runUnification carrayDir "Cannot generalize CArray functions." thd3 diff --git a/src/Parser/Signature.hs b/src/Parser/Signature.hs --- a/src/Parser/Signature.hs +++ b/src/Parser/Signature.hs @@ -60,7 +60,9 @@ (Type.ComplexDouble <$ Parsec.string "COMPLEX"))) <|> (Parsec.string "COMPLEX" >> - ((Type.ComplexDouble <$ Parsec.string "*16") <|> return Type.ComplexSingle)) + ((Type.ComplexDouble <$ Parsec.string "*16") + <|> + return Type.ComplexSingle)) expression :: Parser String expression = diff --git a/src/Type.hs b/src/Type.hs --- a/src/Type.hs +++ b/src/Type.hs @@ -95,15 +95,37 @@ mfilter (Fold.any isVar) $ unify uni floatSig doubleSig -data Wrapper typ = +data ComfortArray = ComfortArray +data CArray = CArray + +class Array array where + arrayFromWrapper :: Wrapper array typ -> array + formatArrayName :: array -> Bool -> String + formatDimName :: array -> String + caseComfortCArray :: array -> a -> a -> a + +instance Array ComfortArray where + arrayFromWrapper _ = ComfortArray + formatArrayName ComfortArray mutable = + (if mutable then "IO" else "") ++ "Array" + formatDimName ComfortArray = "ZeroInt" + caseComfortCArray ComfortArray x _ = x + +instance Array CArray where + arrayFromWrapper _ = CArray + formatArrayName CArray mutable = (if mutable then "IO" else "") ++ "CArray" + formatDimName CArray = "Int" + caseComfortCArray CArray _ x = x + +data Wrapper array typ = Wrapper [(typ, Mapping String typ, Bool)] (Maybe typ) [(typ, Mapping String typ)] -instance Foldable Wrapper where +instance Foldable (Wrapper array) where foldMap f (Wrapper inputs returnType outputs) = foldMap (f.fst3) inputs <> foldMap f returnType <> foldMap (f.fst) outputs -instance Unification Wrapper where +instance Unification (Wrapper array) where unify uni (Wrapper aInputs aReturn aOutputs) (Wrapper bInputs bReturn bOutputs) = @@ -143,8 +165,8 @@ [x] -> x _ -> "(" ++ List.intercalate "," elems ++ ")" -formatIndex :: [String] -> String -formatIndex = formatTuple . flip Match.replicate "Int" +formatShape :: (Array array) => array -> [String] -> String +formatShape array = formatTuple . flip Match.replicate (formatDimName array) formatPtr :: (Format typ) => typ -> String formatPtr typ = "Ptr " ++ format typ @@ -154,11 +176,15 @@ printf "FunPtr (%sIO %s)" (concat $ replicate n $ formatPtr param ++ " -> ") (format ret) -formatArray :: (Format typ) => String -> typ -> Mapping String typ -> String -formatArray array elm mapping = +formatArray :: + (Array array, Format typ) => + array -> Bool -> typ -> Mapping String typ -> String +formatArray array mutable elm mapping = case mapping of Scalar -> formatParameter elm - Array dims -> array ++ " " ++ formatIndex dims ++ " " ++ format elm + Array dims -> + formatArrayName array mutable ++ " " ++ + formatShape array dims ++ " " ++ format elm Function n param -> formatFunPtr n param elm instance Format Mono where