-
Notifications
You must be signed in to change notification settings - Fork 29
/
FFI.hs
128 lines (117 loc) · 4.81 KB
/
FFI.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
{-# 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 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