From 94a3c50f1c43a7001791fed77560f268fc6d72a3 Mon Sep 17 00:00:00 2001
From: Bernhard Urban <lewurm@gmail.com>
Date: Wed, 22 Aug 2012 20:01:07 +0200
Subject: [PATCH] native: demo for a call to haskell functions at runtime

still a hack though
---
 Mate/GarbageAlloc.hs        |  9 +++++++--
 Mate/MethodPool.hs          | 32 +++++++++++++++++++++++---------
 examples/RuntimeInfo.java   |  9 +++++++++
 jmate/lang/MateRuntime.java |  5 +++++
 4 files changed, 44 insertions(+), 11 deletions(-)
 create mode 100644 examples/RuntimeInfo.java
 create mode 100644 jmate/lang/MateRuntime.java

diff --git a/Mate/GarbageAlloc.hs b/Mate/GarbageAlloc.hs
index 56bb8f1..e7c1cc9 100644
--- a/Mate/GarbageAlloc.hs
+++ b/Mate/GarbageAlloc.hs
@@ -6,9 +6,7 @@ module Mate.GarbageAlloc where
 import Foreign
 import Foreign.C
 
-#ifdef DEBUG
 import Text.Printf
-#endif
 import Mate.Debug
 
 -- unified place for allocating Memory
@@ -30,3 +28,10 @@ mallocObject size = do
   ptr <- mallocBytes size
   printfStr "mallocObject: %d\n" size
   return $ fromIntegral $ ptrToIntPtr ptr
+
+-- TODO: delete me
+foreign export ccall demoInterfaceCall :: CUInt -> IO ()
+demoInterfaceCall :: CUInt -> IO ()
+demoInterfaceCall val = do
+  printf "demoInterfaceCall: 0x%08x\n" (fromIntegral val :: Word32)
+  return ()
diff --git a/Mate/MethodPool.hs b/Mate/MethodPool.hs
index 5330ade..73f47c0 100644
--- a/Mate/MethodPool.hs
+++ b/Mate/MethodPool.hs
@@ -36,6 +36,9 @@ import Mate.Utilities
 foreign import ccall "dynamic"
    code_void :: FunPtr (IO ()) -> IO ()
 
+foreign import ccall "&demoInterfaceCall"
+  demoInterfaceCallAddr :: FunPtr (CUInt -> IO ())
+
 
 getMethodEntry :: CPtrdiff -> CPtrdiff -> IO CPtrdiff
 getMethodEntry signal_from methodtable = do
@@ -65,15 +68,23 @@ getMethodEntry signal_from methodtable = do
             let flags = methodAccessFlags mm'
             if S.member ACC_NATIVE flags
               then do
-                -- TODO(bernhard): cleaner please... *do'h*
-                let sym1 = replace "/" "_" $ toString cm
-                    parenth = replace "(" "_" $ replace ")" "_" $ toString $ encode sig
-                    sym2 = replace ";" "_" $ replace "/" "_" parenth
-                    symbol = sym1 ++ "__" ++ toString method ++ "__" ++ sym2
-                printfMp "native-call: symbol: %s\n" symbol
-                nf <- loadNativeFunction symbol
-                setMethodMap $ M.insert mi' nf mmap
-                return nf
+                let scm = toString cm; smethod = toString method
+                if scm == "jmate/lang/MateRuntime" then do
+                  case smethod of
+                    "demoInterfaceCall" ->
+                       return . funPtrToAddr $ demoInterfaceCallAddr
+                    _ ->
+                       error $ "native-call: " ++ smethod ++ " not found."
+                else do
+                  -- TODO(bernhard): cleaner please... *do'h*
+                  let sym1 = replace "/" "_" scm
+                      parenth = replace "(" "_" $ replace ")" "_" $ toString $ encode sig
+                      sym2 = replace ";" "_" $ replace "/" "_" parenth
+                      symbol = sym1 ++ "__" ++ smethod ++ "__" ++ sym2
+                  printfMp "native-call: symbol: %s\n" symbol
+                  nf <- loadNativeFunction symbol
+                  setMethodMap $ M.insert mi' nf mmap
+                  return nf
               else do
                 rawmethod <- parseMethod cls' method sig
                 entry <- compileBB rawmethod (MethodInfo method (thisClass cls') sig)
@@ -83,6 +94,9 @@ getMethodEntry signal_from methodtable = do
     Just w32 -> return w32
   return $ fromIntegral entryaddr
 
+funPtrToAddr :: Num b => FunPtr a -> b
+funPtrToAddr = fromIntegral . ptrToIntPtr . castFunPtrToPtr
+
 lookupMethodRecursive :: B.ByteString -> MethodSignature -> [B.ByteString] -> Class Direct
                          -> IO (Maybe (Method Direct, [B.ByteString], Class Direct))
 lookupMethodRecursive name sig clsnames cls =
diff --git a/examples/RuntimeInfo.java b/examples/RuntimeInfo.java
new file mode 100644
index 0000000..5727199
--- /dev/null
+++ b/examples/RuntimeInfo.java
@@ -0,0 +1,9 @@
+package examples;
+
+import jmate.lang.*;
+
+public class RuntimeInfo {
+	public static void main(String []args) {
+		MateRuntime.demoInterfaceCall(0x1337);
+	}
+}
diff --git a/jmate/lang/MateRuntime.java b/jmate/lang/MateRuntime.java
new file mode 100644
index 0000000..1a04df9
--- /dev/null
+++ b/jmate/lang/MateRuntime.java
@@ -0,0 +1,5 @@
+package jmate.lang;
+
+public class MateRuntime {
+	public static native void demoInterfaceCall(int val);
+}
-- 
2.25.1