Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

129 lines (117 sloc) 4.928 kB
{-# LANGUAGE CPP #-}
{- |
Module : Language.Scheme.FFI
Copyright : Justin Ethier
Licence : MIT (see LICENSE in the distribution)
Maintainer : github.com/justinethier
Stability : experimental
Portability : non-portable (GHC API)
This module contains the foreign function interface.
-}
module Language.Scheme.FFI (evalfuncLoadFFI) where
import Language.Scheme.Types
import Language.Scheme.Variables
import Control.Monad.Error
import qualified GHC
import qualified GHC.Paths (libdir)
import qualified DynFlags
import qualified Unsafe.Coerce (unsafeCoerce)
-- |Load a Haskell function into husk using the GHC API.
evalfuncLoadFFI :: [LispVal] -> IOThrowsError LispVal
{-
- |Load a Haskell function into husk using the foreign function inteface (FFI)
-
- Based on example code from:
-
- http://stackoverflow.com/questions/5521129/importing-a-known-function-from-an-already-compiled-binary-using-ghcs-api-or-hi
- and
- http://www.bluishcoder.co.nz/2008/11/dynamic-compilation-and-loading-of.html
-
-
- TODO: pass a list of functions to import. Need to make sure this is done in an efficient way
- (IE, result as a list that can be processed)
-}
evalfuncLoadFFI [(Continuation env _ _ _), String targetSrcFile,
String moduleName,
String externalFuncName,
String internalFuncName] = do
result <- liftIO $ defaultRunGhc $ do
dynflags <- GHC.getSessionDynFlags
_ <- GHC.setSessionDynFlags dynflags
-- let m = GHC.mkModule (GHC.thisPackage dynflags) (GHC.mkModuleName "Test")
--
{- TODO: migrate duplicate code into helper functions to drive everything
FUTURE: should be able to load multiple functions in one shot (?). -}
--
target <- GHC.guessTarget targetSrcFile Nothing
GHC.addTarget target
r <- GHC.load GHC.LoadAllTargets
case r of
GHC.Failed -> error "Compilation failed"
GHC.Succeeded -> do
m <- GHC.findModule (GHC.mkModuleName moduleName) Nothing
#if __GLASGOW_HASKELL__ < 700
GHC.setContext [] [m]
#elif __GLASGOW_HASKELL__ == 702
-- Fix from dflemstr:
-- http://stackoverflow.com/questions/9198140/ghc-api-how-to-dynamically-load-haskell-code-from-a-compiled-module-using-ghc
GHC.setContext []
-- import qualified Module
[ (GHC.simpleImportDecl . GHC.mkModuleName $ moduleName)
{GHC.ideclQualified = True}
]
#elif __GLASGOW_HASKELL__ >= 704
GHC.setContext
-- import qualified Module
[ GHC.IIDecl $
(GHC.simpleImportDecl . GHC.mkModuleName $ moduleName)
{GHC.ideclQualified = True}
]
#else
GHC.setContext [] [(m, Nothing)]
#endif
fetched <- GHC.compileExpr (moduleName ++ "." ++ externalFuncName)
return (Unsafe.Coerce.unsafeCoerce fetched :: [LispVal] -> IOThrowsError LispVal)
defineVar env internalFuncName (IOFunc result) -- >>= continueEval env cont
-- Overload that loads code from a compiled module
evalfuncLoadFFI [(Continuation env _ _ _), String moduleName, String externalFuncName, String internalFuncName] = do
result <- liftIO $ defaultRunGhc $ do
dynflags <- GHC.getSessionDynFlags
_ <- GHC.setSessionDynFlags dynflags
m <- GHC.findModule (GHC.mkModuleName moduleName) Nothing
#if __GLASGOW_HASKELL__ < 700
GHC.setContext [] [m]
#elif __GLASGOW_HASKELL__ == 702
-- Fix from dflemstr:
-- http://stackoverflow.com/questions/9198140/ghc-api-how-to-dynamically-load-haskell-code-from-a-compiled-module-using-ghc
GHC.setContext []
-- import qualified Module
[ (GHC.simpleImportDecl . GHC.mkModuleName $ moduleName)
{GHC.ideclQualified = True}
]
#elif __GLASGOW_HASKELL__ >= 704
GHC.setContext
-- import qualified Module
[ GHC.IIDecl $
(GHC.simpleImportDecl . GHC.mkModuleName $ moduleName)
{GHC.ideclQualified = True}
]
#else
GHC.setContext [] [(m, Nothing)]
#endif
fetched <- GHC.compileExpr $ moduleName ++ "." ++ externalFuncName
return (Unsafe.Coerce.unsafeCoerce fetched :: [LispVal] -> IOThrowsError LispVal)
defineVar env internalFuncName (IOFunc result) -- >>= continueEval env cont
evalfuncLoadFFI _ = throwError $ NumArgs (Just 3) []
defaultRunGhc :: GHC.Ghc a -> IO a
defaultRunGhc =
#if __GLASGOW_HASKELL__ <= 700
-- Old syntax for GHC 7.0.x and lower
GHC.defaultErrorHandler DynFlags.defaultDynFlags . GHC.runGhc (Just GHC.Paths.libdir)
#elif __GLASGOW_HASKELL__ < 706
-- New syntax in GHC 7.2
GHC.defaultErrorHandler DynFlags.defaultLogAction . GHC.runGhc (Just GHC.Paths.libdir)
#else
-- New syntax in GHC 7.6
GHC.defaultErrorHandler DynFlags.defaultFatalMessager DynFlags.defaultFlushOut . GHC.runGhc (Just GHC.Paths.libdir)
#endif
Jump to Line
Something went wrong with that request. Please try again.