native: demo for a call to haskell functions at runtime

[mate.git] / Mate / MethodPool.hs

diff --git a/Mate/MethodPool.hs b/Mate/MethodPool.hs
index 5330ade2e6a5b8d1eac3b3878fd08622a9f91a25..73f47c090a76259fde609f4b1139a28a4191baca 100644 (file)
--- 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 =