some comments:
(1) we need shared libs now, otherwise the binary too big (~24MB).
please recompile from cabal (see README)
(2) as C doesn't allow '/', '(' and ')' as identifier names (unlike
forth <3), we replace them with '_', in order to identify a
(unique) native function. the pattern is as follows:
class__methodname__methodsignature
(3) `loadNativeFunction' is quite hackisch now. I don't know if we
get troubles with it at some point. we should consider:
(3a) ask on stackoverflow
(3b) patch this wtf stuff in ghc
(3c) just determine addresses at compile-time.
(3c) sucks, because you have to write much glue-code for every
native method. but maybe we could solve it with some magic TH
stuff (as suggested by hs_)
PACKAGES_ := bytestring harpy hs-java
PACKAGES := $(addprefix -package ,$(PACKAGES_))
PACKAGES_ := bytestring harpy hs-java
PACKAGES := $(addprefix -package ,$(PACKAGES_))
-GHC_OPT := -Wall -O0 -fno-warn-unused-do-bind
+GHC_OPT := -dynamic -Wall -O0 -fno-warn-unused-do-bind
GHC_LD := -optl-Xlinker -optl-x
GHC_LD := -optl-Xlinker -optl-x
./$< tests/DifferentClass1.class | grep mainresult
@printf "should be: 0x%08x\n" 8
@printf "should be: 0x%08x\n" 13
./$< tests/DifferentClass1.class | grep mainresult
@printf "should be: 0x%08x\n" 8
@printf "should be: 0x%08x\n" 13
+ ./$< tests/Native1.class | egrep -i -e '^printsomething: '
%.class: %.java
$(JAVAC) $<
%.class: %.java
$(JAVAC) $<
-mate: Mate.hs ffi/trap.c $(HS_FILES)
+ffi/native.o: ffi/native.c
+ ghc -Wall -O2 -c $< -o $@
+
+mate: Mate.hs ffi/trap.c $(HS_FILES) ffi/native.o
ghc --make $(GHC_OPT) Mate.hs ffi/trap.c -o $@ $(GHC_LD)
clean:
ghc --make $(GHC_OPT) Mate.hs ffi/trap.c -o $@ $(GHC_LD)
clean:
module Mate.MethodPool where
import Data.Binary
module Mate.MethodPool where
import Data.Binary
+import Data.String.Utils
import qualified Data.Map as M
import qualified Data.Map as M
+import qualified Data.Set as S
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Lazy as B
import Text.Printf
import Foreign.Ptr
import Foreign.C.Types
import Text.Printf
import Foreign.Ptr
import Foreign.C.Types
import JVM.Converter
import Harpy
import JVM.Converter
import Harpy
import Mate.BasicBlocks
import Mate.Types
import Mate.X86CodeGen
import Mate.BasicBlocks
import Mate.Types
import Mate.X86CodeGen
foreign import ccall "get_mmap"
foreign import ccall "get_mmap"
foreign import ccall "set_mmap"
set_mmap :: Ptr () -> IO ()
foreign import ccall "set_mmap"
set_mmap :: Ptr () -> IO ()
+foreign import ccall "dynamic"
+ code_void :: FunPtr (IO ()) -> (IO ())
+
+
foreign export ccall getMethodEntry :: CUInt -> Ptr () -> Ptr () -> IO CUInt
getMethodEntry :: CUInt -> Ptr () -> Ptr () -> IO CUInt
getMethodEntry signal_from ptr_mmap ptr_cmap = do
foreign export ccall getMethodEntry :: CUInt -> Ptr () -> Ptr () -> IO CUInt
getMethodEntry :: CUInt -> Ptr () -> Ptr () -> IO CUInt
getMethodEntry signal_from ptr_mmap ptr_cmap = do
cmap <- ptr2cmap ptr_cmap
let w32_from = fromIntegral signal_from
cmap <- ptr2cmap ptr_cmap
let w32_from = fromIntegral signal_from
- let mi@(MethodInfo method cm _) = cmap M.! w32_from
+ let mi@(MethodInfo method cm sig) = cmap M.! w32_from
-- TODO(bernhard): replace parsing with some kind of classpool
cls <- parseClassFile $ toString $ cm `B.append` ".class"
case M.lookup mi mmap of
Nothing -> do
printf "getMethodEntry(from 0x%08x): no method \"%s\" found. compile it\n" w32_from (show mi)
-- TODO(bernhard): replace parsing with some kind of classpool
cls <- parseClassFile $ toString $ cm `B.append` ".class"
case M.lookup mi mmap of
Nothing -> do
printf "getMethodEntry(from 0x%08x): no method \"%s\" found. compile it\n" w32_from (show mi)
- hmap <- parseMethod cls method
- printMapBB hmap
- case hmap of
- Just hmap' -> do
- entry <- compileBB hmap' mi
- return $ fromIntegral $ ((fromIntegral $ ptrToIntPtr entry) :: Word32)
+ let mm = lookupMethod method cls
+ case mm of
+ Just mm' -> do
+ let flags = methodAccessFlags mm'
+ case S.member ACC_NATIVE flags of
+ False -> do
+ hmap <- parseMethod cls method
+ printMapBB hmap
+ case hmap of
+ Just hmap' -> do
+ entry <- compileBB hmap' mi
+ return $ fromIntegral $ ((fromIntegral $ ptrToIntPtr entry) :: Word32)
+ Nothing -> error $ (show method) ++ " not found. abort"
+ True -> do
+ let symbol = (replace "/" "_" $ toString cm) ++ "__" ++ (toString method) ++ "__" ++ (replace "(" "_" (replace ")" "_" $ toString $ encode sig))
+ printf "native-call: symbol: %s\n" symbol
+ nf <- loadNativeFunction symbol
+ let w32_nf = fromIntegral nf
+ let mmap' = M.insert mi w32_nf mmap
+ mmap2ptr mmap' >>= set_mmap
+ return nf
Nothing -> error $ (show method) ++ " not found. abort"
Just w32 -> return (fromIntegral w32)
Nothing -> error $ (show method) ++ " not found. abort"
Just w32 -> return (fromIntegral w32)
+-- TODO(bernhard): UBERHAX. ghc patch?
+foreign import ccall safe "lookupSymbol"
+ c_lookupSymbol :: CString -> IO (Ptr a)
+
+loadNativeFunction :: String -> IO (CUInt)
+loadNativeFunction sym = do
+ _ <- loadRawObject "ffi/native.o"
+ -- TODO(bernhard): WTF
+ resolveObjs (return ())
+ ptr <- withCString sym c_lookupSymbol
+ if (ptr == nullPtr)
+ then error $ "dyn. loading of \"" ++ sym ++ "\" failed."
+ else return $ fromIntegral $ minusPtr ptr nullPtr
+
-- t_01 :: IO ()
-- t_01 = do
-- (entry, _) <- testCase "./tests/Fib.class" "fib"
-- t_01 :: IO ()
-- t_01 = do
-- (entry, _) <- testCase "./tests/Fib.class" "fib"
-foreign import ccall "dynamic"
- code_void :: FunPtr (IO ()) -> (IO ())
-
executeFuncPtr :: Ptr Word8 -> IO ()
executeFuncPtr entry = code_void $ ((castPtrToFunPtr entry) :: FunPtr (IO ()))
executeFuncPtr :: Ptr Word8 -> IO ()
executeFuncPtr entry = code_void $ ((castPtrToFunPtr entry) :: FunPtr (IO ()))
- emit _ = do cmovbe eax eax -- dummy
+ emit invalid = error $ "insn not implemented yet: " ++ (show invalid)
cArgs x = (8 + 4 * (fromIntegral x))
cArgs_ x = (8 + 4 * case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3)
cArgs x = (8 + 4 * (fromIntegral x))
cArgs_ x = (8 + 4 * case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3)
== DEPENDENCIES ==
=== HARPY ===
== DEPENDENCIES ==
=== HARPY ===
+ $ cabal install harpy --enable-shared
if this fails (e.g. you use ghc >= 7.0) then try our patched version:
$ git clone git://wien.tomnetworks.com/harpy.git
$ cd harpy
if this fails (e.g. you use ghc >= 7.0) then try our patched version:
$ git clone git://wien.tomnetworks.com/harpy.git
$ cd harpy
- $ cabal configure; cabal build; cabal install
+ $ cabal configure --enable-shared
+ $ cabal build
+ $ cabal install --enable-shared
$ git clone git://wien.tomnetworks.com/hs-java.git
$ cd hs-java
$ git checkout -t origin/v0.2
$ git clone git://wien.tomnetworks.com/hs-java.git
$ cd hs-java
$ git checkout -t origin/v0.2
- $ cabal configure; cabal build; cabal install
+ $ cabal configure --enable-shared
+ $ cabal build
+ $ cabal install --enable-shared
hint: for some unknown reason yet, it seems building from source will be easier
if you first install `hs-java' via cabal (like `harpy' above)
hint: for some unknown reason yet, it seems building from source will be easier
if you first install `hs-java' via cabal (like `harpy' above)
+=== MISC ===
+ $ cabal install missingh --enable-shared
+ $ cabal install heap --enable-shared
+ $ cabal install plugins --enable-shared
+
== NOTE ==
unfortunately, many haskell libaries arn't tested very well, so building
== NOTE ==
unfortunately, many haskell libaries arn't tested very well, so building
--- /dev/null
+#include <stdio.h>
+
+void tests_Native1__printSomething____V(void)
+{
+ printf("printSomething: woot \\o/\n");
+}
+
+void tests_Native1__printSomething___I_V(int a)
+{
+ printf("printSomething: 0x%08x\n", a);
+}
--- /dev/null
+package tests;
+
+public class Native1 {
+ public static void main(String []args) {
+ printSomething();
+ for (int i = 0; i < 10; i++)
+ printNumber(0x1337 + i);
+ printSomething();
+ printSomething();
+ printNumber(0x15a5);
+ }
+
+ public static void printNumber(int a) {
+ printSomething(a);
+ }
+
+ public static native void printSomething();
+ public static native void printSomething(int a);
+}