e4fc71a · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

Merge pull request #322 from raichoo/javascript

javascript: make FFI work with HOFs

commite4fc71a36b9c4e3bef6920b33f0769c3335fc860 authorEdwin Brady <edwin.brady@gmail.com> dateMon 3 Jun 2013, 01:53 (13 years ago) parentd9435c6 c999e14

5 files changed+68−26

compare with master

unifiedsplit

js/Runtime-common.js+8−1 lib/IO.idr+18−10 src/IRTS/CodegenJavaScript.hs+24−9 src/IRTS/Compiler.hs+9−5 src/IRTS/Lang.hs+9−1

js/Runtime-common.js+8−1

@@ -10,12 +10,19 @@ __IDRRT__.Char = new __IDRRT__.Type('Char');

1010__IDRRT__.String = new __IDRRT__.Type('String');

1111__IDRRT__.Integer = new __IDRRT__.Type('Integer');

1212__IDRRT__.Float = new __IDRRT__.Type('Float');

13−__IDRRT__.Ptr = new __IDRRT__.Type('Pointer')

13+__IDRRT__.Ptr = new __IDRRT__.Type('Pointer');

1414__IDRRT__.Forgot = new __IDRRT__.Type('Forgot');

1515

1616

1717/** @constructor */

1818__IDRRT__.Tailcall = function(f) { this.f = f };

19+__IDRRT__.ffiWrap = function(fid) {

20+ return function(arg) {

21+ return __IDRRT__.tailcall(function(){

22+ return __IDR__.APPLY0(fid, arg);

23+ });

24+ };

25+};

1926

2027/** @constructor */

2128__IDRRT__.Con = function(i,vars) {

lib/IO.idr+18−10

@@ -22,7 +22,13 @@ run__IO : IO () -> IO ()

2222run__IO v = io_bind v (\v' => io_return v')

2323

2424data IntTy = ITNative | IT8 | IT16 | IT32 | IT64

25+data FTy = FIntT IntTy

26+ | FFunction FTy FTy

27+ | FFloat

28+ | FString

29+ | FPtr

30+ | FAny Type

31+ | FUnit

2632

2733FInt : FTy

2834FInt = FIntT ITNative

@@ -38,15 +44,17 @@ FLong = FIntT IT64

3844

3945interpFTy : FTy -> Type

4046interpFTy (FIntT ITNative) = Int

41−interpFTy (FIntT IT8) = Bits8

42−interpFTy (FIntT IT16) = Bits16

43−interpFTy (FIntT IT32) = Bits32

44−interpFTy (FIntT IT64) = Bits64

45−interpFTy FFloat = Float

46−interpFTy FString = String

47−interpFTy FPtr = Ptr

48−interpFTy (FAny t) = t

49−interpFTy FUnit = ()

47+interpFTy (FIntT IT8) = Bits8

48+interpFTy (FIntT IT16) = Bits16

49+interpFTy (FIntT IT32) = Bits32

50+interpFTy (FIntT IT64) = Bits64

51+interpFTy (FAny t) = t

52+interpFTy FFloat = Float

53+interpFTy FString = String

54+interpFTy FPtr = Ptr

55+interpFTy FUnit = ()

56+

57+interpFTy (FFunction a b) = interpFTy a -> interpFTy b

5058

5159ForeignTy : (xs:List FTy) -> (t:FTy) -> Type

5260ForeignTy Nil rt = IO (interpFTy rt)

src/IRTS/CodegenJavaScript.hs+24−9

@@ -200,7 +200,7 @@ translateExpression (SApp True name vars) =

200200 "new __IDRRT__.Tailcall("

201201 ++ "function(){\n"

202202 ++ "return " ++ translateFunctionCall name vars

203− ++ ";\n});"

203+ ++ ";\n})"

204204

205205translateExpression (SOp op vars)

206206 | (LPlus _) <- op

@@ -356,19 +356,27 @@ translateExpression (SOp op vars)

356356 ++ translateVariableName rhs

357357

358358translateExpression (SError msg) =

359− "(function(){throw \'" ++ msg ++ "\';})();"

359+ "(function(){throw \'" ++ msg ++ "\';})()"

360360

361361translateExpression (SForeign _ _ "putStr" [(FString, var)]) =

362− "__IDRRT__.print(" ++ translateVariableName var ++ ");"

362+ "__IDRRT__.print(" ++ translateVariableName var ++ ")"

363363

364364translateExpression (SForeign _ _ fun args)

365− | "." `isPrefixOf` fun, "[]=" `isSuffixOf` fun

365+ | "[]=" `isSuffixOf` fun

366366 , (obj:idx:val:[]) <- args =

367− concat [object obj, field, index idx, assign val]

367+ concat [object obj, index idx, assign val]

368368

369− | "." `isPrefixOf` fun, "[]" `isSuffixOf` fun

369+ | "[]" `isSuffixOf` fun

370370 , (obj:idx:[]) <- args =

371− concat [object obj, field, index idx]

371+ object obj ++ index idx

372+

373+ | "[" `isPrefixOf` fun && "]=" `isSuffixOf` fun

374+ , (obj:val:[]) <- args =

375+ concat [object obj, '[' : name ++ "]", assign val]

376+

377+ | "[" `isPrefixOf` fun && "]" `isSuffixOf` fun

378+ , (obj:[]) <- args =

379+ object obj ++ '[' : name ++ "]"

372380

373381 | "." `isPrefixOf` fun, "=" `isSuffixOf` fun

374382 , (obj:val:[]) <- args =

@@ -402,9 +410,16 @@ translateExpression (SForeign _ _ fun args)

402410 array = name

403411 object o = translateVariableName (snd o)

404412 index i = "[" ++ translateVariableName (snd i) ++ "]"

405− assign v = '=' : translateVariableName (snd v)

413+ assign v = '=' : generateWrapper v

406414 arguments as =

407− '(' : intercalate "," (map (translateVariableName . snd) as) ++ ")"

415+ '(' : intercalate "," (map generateWrapper as) ++ ")"

416+

417+ generateWrapper (ffunc, name)

418+ | FFunction <- ffunc = "__IDRRT__.ffiWrap(" ++ translateVariableName name ++ ")"

419+ | FFunctionIO <- ffunc = "__IDRRT__.ffiWrap(" ++ translateVariableName name ++ ")"

420+

421+ generateWrapper (_, name) =

422+ translateVariableName name

408423

409424translateExpression (SChkCase var cases) =

410425 "(function(e){\n"

src/IRTS/Compiler.hs+9−5

@@ -287,13 +287,17 @@ getFTypes tm = case unApply tm of

287287

288288mkIty' (P _ (UN ty) _) = mkIty ty

289289mkIty' (App (P _ (UN "FIntT") _) (P _ (UN intTy) _)) = mkIntIty intTy

290+mkIty' (App (App (P _ (UN "FFunction") _) _) (App (P _ (UN "FAny") _) (App (P _ (UN "IO") _) _))) = FFunctionIO

291+mkIty' (App (App (P _ (UN "FFunction") _) _) _) = FFunction

290292mkIty' _ = FAny

291293

292−mkIty "FFloat" = FDouble

293−mkIty "FChar" = FChar

294−mkIty "FString" = FString

295−mkIty "FPtr" = FPtr

296−mkIty "FUnit" = FUnit

294+mkIty "FFloat" = FDouble

295+mkIty "FChar" = FChar

296+mkIty "FString" = FString

297+mkIty "FPtr" = FPtr

298+mkIty "FUnit" = FUnit

299+mkIty "FFunction" = FFunction

300+mkIty "FFunctionIO" = FFunctionIO

297301

298302mkIntIty "ITNative" = FInt ITNative

299303mkIntIty "IT8" = FInt IT8

src/IRTS/Lang.hs+9−1

@@ -79,7 +79,15 @@ data PrimFn = LPlus IntTy | LMinus IntTy | LTimes IntTy

7979data FLang = LANG_C

8080 deriving (Show, Eq)

8181

82+data FType = FInt IntTy

83+ | FFunction

84+ | FFunctionIO

85+ | FChar

86+ | FString

87+ | FUnit

88+ | FPtr

89+ | FDouble

90+ | FAny

8391 deriving (Show, Eq)

8492

8593data LAlt = LConCase Int Name [Name] LExp