git.iko.soy/Idris-dev
on master help sign in
Merge pull request #514 from raichoo/javascript
ff726feEdwin Brady
js/Runtime-common.js+18−25
compare with master
unifiedsplit
@@ -13,21 +13,22 @@ var __IDRRT__Forgot = new __IDRRT__Type('Forgot');
13
13
14
14
15/** @constructor */
15/** @constructor */
16−var __IDRRT__Tailcall = function(f) { this.f = f };
16+var __IDRRT__Tailcall = function(fun, args) {
17+ this.fun = fun;
18+ this.args = args;
19+};
17
20
18var __IDRRT__ffiWrap = function(fid) {
21var __IDRRT__ffiWrap = function(fid) {
19 return function(){
22 return function(){
20− var res = fid;
23+ var res = fid;
21− var i = 0;
24+ var i = 0;
22− var arg;
25+ var arg;
23− while (res instanceof __IDRRT__Con){
26+ while (res instanceof __IDRRT__Con){
24− arg = arguments[i];
27+ arg = arguments[i];
25− res = __IDRRT__tailcall(function(){
26− return __IDR__mAPPLY0(res, arg);
28+ res = __IDRRT__tailcall(__IDR__mAPPLY0, [res, arg]);
27− });
28− ++i;
29+ ++i;
29− }
30+ }
30− return res;
31+ return res;
31 }
32 }
32};
33};
33
34
@@ -37,20 +38,12 @@ var __IDRRT__Con = function(tag,vars) {
37 this.vars = vars;
38 this.vars = vars;
38};
39};
39
40
40−var __IDRRT__tailcall = function(f) {
41+var __IDRRT__tailcall = function(fun, args) {
41− var __f = f;
42+ var ret = new __IDRRT__Tailcall(fun, args);
42− var ret;
43+ while (ret instanceof __IDRRT__Tailcall)
43− while (__f) {
44+ ret = ret.fun.apply(this, ret.args);
44− f = __f;
45− __f = null;
46− ret = f();
47
45
48− if (ret instanceof __IDRRT__Tailcall) {
49− __f = ret.f;
50− } else {
51− return ret;
46+ return ret;
52− }
53− }
54};
47};
55
48
56/*
49/*
src/IRTS/CodegenJavaScript.hs+49−13
@@ -163,11 +163,9 @@ compileJS (JSTernary cond true false) =
163 f = compileJS false in
163 f = compileJS false in
164 "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"
164 "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"
165
165
166−jsTailcall :: JS -> JS
166+jsTailcall :: String -> [JS] -> JS
167−jsTailcall call =
167+jsTailcall fun args =
168− jsCall (idrRTNamespace ++ "tailcall") [
168+ jsCall (idrRTNamespace ++ "tailcall") [JSRaw fun, JSArray args]
169− JSFunction [] (JSReturn call)
170− ]
171
169
172jsCall :: String -> [JS] -> JS
170jsCall :: String -> [JS] -> JS
173jsCall fun = JSApp (JSRaw fun)
171jsCall fun = JSApp (JSRaw fun)
@@ -212,6 +210,43 @@ jsLet name value body =
212 )
210 )
213 ) [value]
211 ) [value]
214
212
213+jsSubst :: String -> [JS] -> JS -> [JS]
214+jsSubst _ [] _ = []
215+jsSubst var (x@(JSVar old) : xs) new
216+ | var == translateVariableName old = new : xs
217+ | otherwise = x : jsSubst var xs new
218+jsSubst _ xs _ = xs
219+
220+optimizeJS :: JS -> JS
221+optimizeJS (JSApp
222+ (JSFunction [arg] (JSReturn ret))
223+ [val]
224+ )
225+ | JSNew con [tag, JSArray vals] <- ret =
226+ JSNew con [tag, JSArray $ jsSubst arg vals (optimizeJS val)]
227+ | JSApp (JSRaw tc@"__IDRRT__tailcall") [fun, JSArray args] <- ret =
228+ JSApp (JSRaw tc) [fun, JSArray $ jsSubst arg args (optimizeJS val)]
229+
230+optimizeJS (JSSeq seq) =
231+ JSSeq (map optimizeJS seq)
232+
233+optimizeJS (JSFunction args body) =
234+ JSFunction args (optimizeJS body)
235+
236+optimizeJS (JSApp fun args) =
237+ JSApp (optimizeJS fun) (map optimizeJS args)
238+
239+optimizeJS (JSReturn js) =
240+ JSReturn $ optimizeJS js
241+
242+optimizeJS (JSAlloc name (Just js)) =
243+ JSAlloc name (Just $ optimizeJS js)
244+
245+optimizeJS js = js
246+
247+optJS :: Int -> JS -> JS
248+optJS c = foldr (.) id $ take c $ repeat optimizeJS
249+
215codegenJavaScript
250codegenJavaScript
216 :: JSTarget
251 :: JSTarget
217 -> [(Name, SDecl)]
252 -> [(Name, SDecl)]
@@ -241,12 +276,12 @@ codegenJavaScript target definitions filename outputType = do
241 def = map (first translateNamespace) definitions
276 def = map (first translateNamespace) definitions
242
277
243 functions :: [String]
278 functions :: [String]
244− functions = map (compileJS . translateDeclaration) def
279+ functions = map (compileJS . optJS 1 . translateDeclaration) def
245
280
246 mainLoop :: String
281 mainLoop :: String
247 mainLoop = compileJS $
282 mainLoop = compileJS $
248 JSSeq [ JSAlloc "main" $ Just $ JSFunction [] (
283 JSSeq [ JSAlloc "main" $ Just $ JSFunction [] (
249− jsTailcall $ jsCall mainFun []
284+ jsTailcall mainFun []
250 )
285 )
251 , jsCall "main" []
286 , jsCall "main" []
252 ]
287 ]
@@ -468,14 +503,15 @@ translateExpression (SV var) =
468
503
469translateExpression (SApp tc name vars)
504translateExpression (SApp tc name vars)
470 | False <- tc =
505 | False <- tc =
471− jsTailcall $ translateFunctionCall name vars
506+ jsTailcall (translateFunctionCall name) (map JSVar vars)
472 | True <- tc =
507 | True <- tc =
473− JSNew (idrRTNamespace ++ "Tailcall") [JSFunction [] (
508+ JSNew (idrRTNamespace ++ "Tailcall")
474− JSReturn $ translateFunctionCall name vars
509+ [ JSRaw $ translateFunctionCall name
510+ , JSArray $ map JSVar vars
475− )]
511+ ]
476 where
512 where
477− translateFunctionCall name vars =
513+ translateFunctionCall name =
478− jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
514+ translateNamespace name ++ translateName name
479
515
480translateExpression (SOp op vars)
516translateExpression (SOp op vars)
481 | LNoOp <- op = JSVar (last vars)
517 | LNoOp <- op = JSVar (last vars)