Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Implement FFI import. It is now possible to call Javascript from with…

…in Haskell and pass around Javascript objects
  • Loading branch information...
commit 0313023ee8ba83ec16f14a067345d12627ee76cf 1 parent e3be61e
@sviperll sviperll authored
View
8 .gitignore
@@ -1,7 +1,9 @@
/base-*
/ghc-*
/dist
-/examples/*.hi
-/examples/*.o
-/examples/Test*.js
+/examples/main/*.hi
+/examples/main/*.o
+/examples/main/*.c
+/examples/main/*.h
+/examples/main/*.js
View
2  examples/BuildTest.hs
@@ -20,7 +20,7 @@ main =
, dstPath = "."
}
mapM_ (system . uncurry (buildCommand env)) packages
- system . intercalate " " $ [ ghcJs env, "Test.hs" ]
+ system . intercalate " " $ [ ghcJs env, concat ["-i", dstPath env, "/main"], "Test" ]
packages =
[ ( "ghc-prim"
View
32 examples/Test.hs
@@ -1,32 +0,0 @@
-module Test where
-
-import Data.List
-
-test1 :: Int
-test1 = sum [1..5]
-
-test2 :: Int
-test2 = product [1..5]
-
-test3 :: Int
-test3 = product [2..10]
-
-test4 :: String
-test4 = show test3
-
-test5 :: String
-test5 = "Hello World"
-
-test6 :: String
-test6 = show (sum [1..5] :: Integer)
-
-test7 :: String
-test7 = show $ take 7 primes
-
-primes :: [Int]
-primes = sieve [2..]
- where sieve (x:xs) = x : sieve [y | y <- xs, y `mod` x /= 0]
-
-test8 :: String
-test8 = show (product [1..5] :: Integer)
-
View
56 examples/main/Test.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}
+module Test where
+
+import Data.List
+import Foreign.C.Types
+import Foreign.Ptr
+
+data JSObject
+
+foreign import ccall "zdhszicons" -- $hs.cons
+ jscons :: CChar -> Ptr JSObject -> IO (Ptr JSObject)
+foreign import ccall "zdhszinil" -- $hs.nil
+ jsnil :: IO (Ptr JSObject)
+foreign import ccall "alert"
+ jsalert :: Ptr JSObject -> IO ()
+
+string2JSString :: String -> IO (Ptr JSObject)
+string2JSString [] = jsnil
+string2JSString (x:xs) =
+ do t <- string2JSString xs
+ jscons (toEnum . fromEnum $ x) t
+
+test1 :: Int
+test1 = sum [1..5]
+
+test2 :: Int
+test2 = product [1..5]
+
+test3 :: Int
+test3 = product [2..10]
+
+test4 :: String
+test4 = show test3
+
+test5 :: String
+test5 = "Hello World"
+
+test6 :: String
+test6 = show (sum [1..5] :: Integer)
+
+test7 :: String
+test7 = show $ take 7 primes
+
+primes :: [Int]
+primes = sieve [2..]
+ where sieve (x:xs) = x : sieve [y | y <- xs, y `mod` x /= 0]
+
+test8 :: String
+test8 = show (product [1..5] :: Integer)
+
+test9 :: IO Int
+test9 =
+ do s <- string2JSString "Haskell says hello"
+ jsalert s
+ return 9
+
View
19 examples/rts-common.js
@@ -133,6 +133,25 @@ $hs.fromHaskellInt = function() {
var i = $hs.force.apply($hs, arguments);
return i.data[0];
};
+$hs.fromHaskellIO = function() {
+ var newArguments = [];
+ for (var i = 0; i < arguments.length; i++)
+ newArguments[i] = arguments[i];
+ newArguments[arguments.length] = $hs.modules.GHCziPrim.hs_realWorldzh;
+ var i = $hs.force.apply($hs, newArguments);
+ return i[1];
+ };
+$hs.toHaskellInt = function(i) {
+ var hsi = new $hs.Data(1);
+ hsi.data = [(0 + i) & ~0];
+ return hsi;
+};
+$hs.nil = function() {
+ return "";
+};
+$hs.cons = function(x, xs) {
+ return String.fromCharCode(x) + xs;
+};
$hs.init = function() {
$hs.modules.GHCziPrim = new $hs.Module();
View
50 examples/test.html
@@ -6,46 +6,46 @@
<script type="text/javascript">
window.onload = function() {
// URLs to load modules from in order of precedence
+
$hs.loadPaths = ["."];
// Used packages
- $hs.packages = ["", "/ghc-prim", "/integer-simple", "/base"];
+ $hs.packages = ["/main", "/ghc-prim", "/integer-simple", "/base"];
// Must be called first
$hs.init();
$hs.loadModule("Test");
- var res = $hs.fromHaskellInt($hs.modules.Test.hs_test1);
- alert(res);
+ try {
+
+ var res = $hs.fromHaskellInt($hs.modules.Test.hs_test1);
+ alert(res);
+
+ var res = $hs.fromHaskellInt($hs.modules.Test.hs_test2);
+ alert(res);
+
+ var res = $hs.fromHaskellInt($hs.modules.Test.hs_test3);
+ alert(res);
- var res = $hs.fromHaskellInt($hs.modules.Test.hs_test2);
- alert(res);
+ var res = $hs.fromHaskellString($hs.modules.Test.hs_test4);
+ alert(res);
- var res = $hs.fromHaskellInt($hs.modules.Test.hs_test3);
- alert(res);
+ var res = $hs.fromHaskellString($hs.modules.Test.hs_test5);
+ alert(res);
- var res = $hs.fromHaskellString($hs.modules.Test.hs_test4);
- alert(res);
+ var res = $hs.fromHaskellString($hs.modules.Test.hs_test6);
+ alert(res);
- var res = $hs.fromHaskellString($hs.modules.Test.hs_test5);
- alert(res);
+ var res = $hs.fromHaskellString($hs.modules.Test.hs_test7);
+ alert(res);
- // I wasn't able to make Integer type work.
- //
- // "simple-integer" package provides Integer implementation
- // wich differs signigicantly depending on platform bit-width.
- // I have 64-bit machine, but I can only emulate
- // 32-bit ints in javascript. I think it may work with
- // "simple-integer" built on 32bit machine.
- // But I have no one for now...
- //
- // OR we may emulate 64bit ints with pair of javascript-numbers
- var res = $hs.fromHaskellString($hs.modules.Test.hs_test6);
- alert(res);
+ var res = $hs.fromHaskellInt($hs.fromHaskellIO($hs.modules.Test.hs_test9));
+ alert(res);
- var res = $hs.fromHaskellString($hs.modules.Test.hs_test7);
- alert(res);
+ } catch (e) {
+ alert(e);
+ }
}
</script>
</head>
View
6 src/Generator/Core.hs
@@ -116,9 +116,9 @@ caseExpressionScrut binder expr = go expr
Js.declareMethodCallResult (stgIdToJsId binder) object RTS.applyMethodName (map stgArgToJs args)
where object = stgIdToJs f
go (StgLit lit) = Js.declare (stgIdToJsId binder) $ stgLiteralToJs $ lit
- go (StgOpApp (StgFCallOp f g) args _ty) = bindForeignFunctionCallResult binder f g args
- go (StgOpApp (StgPrimOp op) args _ty) = bindPrimitiveOperationResult binder op args
- go (StgOpApp (StgPrimCallOp call) args _ty) = bindPrimitiveCallResult binder call args
+ go (StgOpApp (StgFCallOp f g) args _ty) = declareForeignFunctionCallResult binder f g args
+ go (StgOpApp (StgPrimOp op) args _ty) = declarePrimitiveOperationResult binder op args
+ go (StgOpApp (StgPrimCallOp call) args _ty) = declarePrimitiveCallResult binder call args
go e = Js.declareFunctionCallResult (stgIdToJsId binder) f []
where f = Js.function [] (expression e)
View
36 src/Generator/FFI.hs
@@ -1,19 +1,41 @@
-module Generator.FFI where
+module Generator.FFI
+ ( returnForeignFunctionCallResult
+ , declareForeignFunctionCallResult
+ , returnPrimitiveCallResult
+ , declarePrimitiveCallResult
+ ) where
import Id as Stg
+import Unique as Stg
import StgSyn as Stg
+import ForeignCall (ForeignCall (CCall), CCallSpec (CCallSpec), CCallTarget (DynamicTarget, StaticTarget))
+import FastString (FastString, unpackFS)
+import Encoding (zDecodeString)
import PrimOp
import Javascript.Language as Js
+import Generator.Helpers
-returnForeignFunctionCallResult :: Javascript js => a -> b -> c -> js
-returnForeignFunctionCallResult _ _ _ = Js.throw . Js.string $ "Unsupported: foreign function call"
+returnForeignFunctionCallResult :: Javascript js => ForeignCall -> Stg.Unique -> [StgArg] -> js
+returnForeignFunctionCallResult (CCall (CCallSpec target _ccallConv _safety)) _ args =
+ case target
+ of DynamicTarget -> Js.throw . Js.string $ "Unsupported: foreign function call"
+ (StaticTarget clabelString) ->
+ Js.return $ foreignCall clabelString args
-bindForeignFunctionCallResult :: Javascript js => Stg.Id -> a -> b -> c -> js
-bindForeignFunctionCallResult _ _ _ _ = Js.throw . Js.string $ "Unsupported: foreign function call"
+declareForeignFunctionCallResult :: Javascript js => Stg.Id -> ForeignCall -> Stg.Unique -> [StgArg] -> js
+declareForeignFunctionCallResult binder (CCall (CCallSpec target _ccallConv _safety)) _ args =
+ case target
+ of DynamicTarget -> Js.throw . Js.string $ "Unsupported: foreign function call"
+ (StaticTarget clabelString) ->
+ Js.declare (stgIdToJsId binder) $ foreignCall clabelString args
+
+foreignCall :: Javascript js => FastString -> [StgArg] -> Expression js
+foreignCall clabelString args =
+ Js.list [stgArgToJs . last $ args, nativeFunctionCall (Js.var . zDecodeString . unpackFS $ clabelString) (map stgArgToJs . init $ args)]
returnPrimitiveCallResult :: Javascript js => PrimCall -> [StgArg] -> js
returnPrimitiveCallResult _ _ = Js.throw . Js.string $ "Unsupported: primitive call"
-bindPrimitiveCallResult :: Javascript js => Stg.Id -> PrimCall -> [StgArg] -> js
-bindPrimitiveCallResult _ _ _ = Js.throw . Js.string $ "Unsupported: primitive call"
+declarePrimitiveCallResult :: Javascript js => Stg.Id -> PrimCall -> [StgArg] -> js
+declarePrimitiveCallResult _ _ _ = Js.throw . Js.string $ "Unsupported: primitive call"
View
40 src/Generator/Helpers.hs
@@ -15,6 +15,27 @@ import qualified Literal as Stg
import Javascript.Language as Js
import qualified RTS.Objects as RTS
+-- | Convert Haskell literal to Javascript object
+-- this function should really go into PrimOp module...
+stgLiteralToJs :: Javascript js => Stg.Literal -> Expression js
+stgLiteralToJs (Stg.MachChar c) = Js.string [c] -- Char#
+stgLiteralToJs (Stg.MachStr s) = Js.string (unpackFS s ++ "\0") -- Addr#
+stgLiteralToJs (Stg.MachInt i) = Js.int i -- Int#
+stgLiteralToJs (Stg.MachInt64 _) = Js.nativeMethodCall RTS.root "alert" [Js.string "Unsupported literal: Int64"]
+stgLiteralToJs (Stg.MachWord i) -- Word#
+ | i > 2^(31 :: Int) - 1 = Js.int (i - 2^(32 :: Int) + 1)
+ | otherwise = Js.int i
+stgLiteralToJs (Stg.MachWord64 _) = Js.nativeMethodCall RTS.root "alert" [Js.string "Unsupported literal: Int64"]
+stgLiteralToJs (Stg.MachFloat i) = Js.float i -- Float#
+stgLiteralToJs (Stg.MachDouble i) = Js.float i -- Doable#
+stgLiteralToJs (Stg.MachNullAddr) = Js.null -- Addr#
+stgLiteralToJs (Stg.MachLabel {}) = Js.nativeMethodCall RTS.root "alert" [Js.string "Unsupported literal: MachLabel"]
+
+stgArgToJs :: Javascript js => Stg.StgArg -> Expression js
+stgArgToJs (Stg.StgVarArg id) = stgIdToJs id
+stgArgToJs (Stg.StgLitArg l) = stgLiteralToJs l
+stgArgToJs (Stg.StgTypeArg _) = panic "Compiler bug: StgTypeArg in expression"
+
jsBoolToHs :: Javascript js => Expression js -> Expression js
jsBoolToHs ex = Js.ternary ex RTS.true RTS.false
@@ -48,25 +69,6 @@ stgBindingToList (StgRec bs) = bs
stgArgsToJs :: Javascript js => [Stg.StgArg] -> Expression js
stgArgsToJs = Js.list . map stgArgToJs
-stgArgToJs :: Javascript js => Stg.StgArg -> Expression js
-stgArgToJs (Stg.StgVarArg id) = stgIdToJs id
-stgArgToJs (Stg.StgLitArg l) = stgLiteralToJs l
-stgArgToJs (Stg.StgTypeArg _) = panic "Compiler bug: StgTypeArg in expression"
-
-stgLiteralToJs :: Javascript js => Stg.Literal -> Expression js
-stgLiteralToJs (Stg.MachChar c) = Js.string [c]
-stgLiteralToJs (Stg.MachStr s) = Js.string (unpackFS s ++ "\0")
-stgLiteralToJs (Stg.MachInt i) = Js.int i
-stgLiteralToJs (Stg.MachInt64 _) = Js.nativeMethodCall RTS.root "alert" [Js.string "Unsupported literal: Int64"]
-stgLiteralToJs (Stg.MachWord i)
- | i > 2^(31 :: Int) - 1 = Js.int (i - 2^(32 :: Int) + 1)
- | otherwise = Js.int i
-stgLiteralToJs (Stg.MachWord64 _) = Js.nativeMethodCall RTS.root "alert" [Js.string "Unsupported literal: Int64"]
-stgLiteralToJs (Stg.MachFloat i) = Js.float i
-stgLiteralToJs (Stg.MachDouble i) = Js.float i
-stgLiteralToJs (Stg.MachNullAddr) = Js.null
-stgLiteralToJs (Stg.MachLabel {}) = Js.nativeMethodCall RTS.root "alert" [Js.string "Unsupported literal: MachLabel"]
-
intToBase62 :: Int -> String
intToBase62 n = go n ""
where go n cs
View
49 src/Generator/PrimOp.hs
@@ -1,6 +1,16 @@
+-- | Tries to implement GHC primitive operations as described at
+-- http://www.haskell.org/ghc/docs/6.12.2/html/libraries/ghc-prim-0.2.0.0/GHC-Prim.html
+-- Char# is Javascript string
+-- Int# is Javascript number
+-- Word# is Javascript number
+-- Float# is Javascript number
+-- Doable# is Javascript number
+-- Addr# is Javascript string
+-- MutableByteArray# s is Javascript string
+-- ByteArray# s is Javascript string
module Generator.PrimOp
( returnPrimitiveOperationResult
- , bindPrimitiveOperationResult
+ , declarePrimitiveOperationResult
) where
import Id as Stg
@@ -8,8 +18,8 @@ import StgSyn as Stg
import PrimOp
import Javascript.Language as Js
-import Generator.Helpers
import qualified RTS.Objects as RTS
+import Generator.Helpers
returnPrimitiveOperationResult :: Javascript js => PrimOp -> [StgArg] -> js
returnPrimitiveOperationResult op args =
@@ -17,14 +27,12 @@ returnPrimitiveOperationResult op args =
of Just e -> Js.return e
Nothing -> Js.throw . Js.string . concat $ ["primitive operation ", show op, ". Not implemeted yet."]
-bindPrimitiveOperationResult :: Javascript js => Stg.Id -> PrimOp -> [StgArg] -> js
-bindPrimitiveOperationResult id op args =
+declarePrimitiveOperationResult :: Javascript js => Stg.Id -> PrimOp -> [StgArg] -> js
+declarePrimitiveOperationResult id op args =
case primOp op args
of Just e -> Js.declare (stgIdToJsId id) e
Nothing -> Js.throw . Js.string . concat $ ["primitive operation ", show op, ". Not implemeted yet."]
--- | primOp tries to implement GHC primitive operations as described at
--- http://www.haskell.org/ghc/docs/6.12.2/html/libraries/ghc-prim-0.2.0.0/GHC-Prim.html
primOp :: Javascript js => PrimOp -> [StgArg] -> Maybe (Expression js)
-- char:
primOp CharGtOp [a, b] = Just $ boolOp Js.greater a b
@@ -54,7 +62,10 @@ primOp IntNegOp [a] = Just $ Js.unaryMinus (stgArgToJs a)
-- overflow sensitive operations:
-- (a >>> 16) == 0 && (b >>> 16) == 0
-primOp IntMulMayOfloOp [a, b] = Just $ Js.and (Js.equal (Js.shiftRA (stgArgToJs a) (Js.int (16 :: Int))) (Js.int (0 :: Int))) (Js.equal (Js.shiftRA (stgArgToJs b) (Js.int (16 :: Int))) (Js.int (0 :: Int)))
+primOp IntMulMayOfloOp [a, b] = Just $ Js.and (test a) (test b)
+ where zero = Js.int (0 :: Int)
+ sixteen = Js.int (16 :: Int)
+ test x = Js.equal (Js.shiftRA (stgArgToJs x) sixteen) zero
-- $hs.Int.addCarry(a, b, 0)
primOp IntAddCOp [a, b] = Just $ Js.nativeMethodCall (Js.property RTS.root "Int") "addCarry" [stgArgToJs a, stgArgToJs b, Js.int (0 :: Int)]
@@ -93,8 +104,30 @@ primOp XorOp [a, b] = Just $ Js.bitXOr (stgArgToJs a) (stgArgToJs b)
primOp NotOp [a] = Just $ Js.bitNot (stgArgToJs a)
primOp Word2IntOp[a] = Just $ stgArgToJs a
-primOp IndexOffAddrOp_Char [a, b] = Just $ Js.subscript (stgArgToJs a) (stgArgToJs b)
+primOp Narrow8IntOp [a] = Just $
+ Js.ternary (Js.greaterOrEqual arg zero)
+ (Js.bitAnd arg bitMask7)
+ (inv (inv arg `Js.bitAnd` bitMask7))
+ where arg = stgArgToJs a
+ inv f = Js.bitXOr f (Js.bitNot zero)
+ bitMask7 = Js.int (127 :: Int)
+ zero = Js.int (0 :: Int)
+primOp Narrow16IntOp [a] = Just $
+ Js.ternary (Js.greaterOrEqual arg zero)
+ (Js.bitAnd arg bitMask15)
+ (inv (inv arg `Js.bitAnd` bitMask15))
+ where arg = stgArgToJs a
+ inv f = Js.bitXOr f (Js.bitNot zero)
+ bitMask15 = Js.int (32767 :: Int)
+ zero = Js.int (0 :: Int)
+primOp Narrow32IntOp [a] = Just $ stgArgToJs a
+primOp Narrow8WordOp [a] = Just $ Js.bitAnd (stgArgToJs a) (Js.int (0xFF :: Int))
+primOp Narrow16WordOp [a] = Just $ Js.bitAnd (stgArgToJs a) (Js.int (0xFFFF :: Int))
+primOp Narrow32WordOp [a] = Just $ stgArgToJs a
+
primOp DataToTagOp [a] = Just $ RTS.conAppTag (stgArgToJs a)
+
+primOp IndexOffAddrOp_Char [a, b] = Just $ Js.nativeMethodCall (stgArgToJs a) "charAt" [stgArgToJs b]
primOp _ _ = Nothing
boolOp :: Javascript js => (Expression js -> Expression js -> Expression js) -> StgArg -> StgArg -> Expression js
Please sign in to comment.
Something went wrong with that request. Please try again.