git.iko.soy/Idris-dev
on master help sign in
Merge pull request #817 from raichoo/javascript
3e07c44Edwin Brady
jsrts/Runtime-common.js+17
compare with master
unifiedsplit
@@ -49,3 +49,20 @@ var __IDRRT__tailcall = function(k) {
49
49
50 return ret;
50 return ret;
51};
51};
52+
53+var __IDRRT__EVALTC = function(arg0) {
54+ var ret = (arg0 instanceof __IDRRT__Con && __IDRLT__mEVAL0[arg0.tag])?(__IDRLT__mEVAL0[arg0.tag](arg0)):(arg0);
55+ while (ret instanceof __IDRRT__Cont)
56+ ret = ret.k();
57+
58+ return ret;
59+};
60+
61+var __IDRRT__APPLYTC = function(fn0, arg0) {
62+ var ev = __IDRRT__EVALTC(fn0);
63+ var ret = (ev instanceof __IDRRT__Con && __IDRLT__mAPPLY0[ev.tag])?(__IDRLT__mAPPLY0[ev.tag](fn0,arg0,ev)):(null)
64+ while (ret instanceof __IDRRT__Cont)
65+ ret = ret.k();
66+
67+ return ret;
68+}
src/IRTS/CodegenJavaScript.hs+174−26
@@ -246,14 +246,17 @@ jsLet name value body =
246 ) [value]
246 ) [value]
247
247
248
248
249−jsSubst :: String -> JS -> JS -> JS
249+jsSubst :: JS -> JS -> JS -> JS
250−jsSubst var new (JSVar old)
250+jsSubst var new old
251+ | var == old = new
252+
253+jsSubst (JSIdent var) new (JSVar old)
251 | var == translateVariableName old = new
254 | var == translateVariableName old = new
252− | otherwise = JSVar old
255+ | otherwise = JSVar old
253
256
254−jsSubst var new (JSIdent old)
257+jsSubst var new old@(JSIdent _)
255 | var == old = new
258 | var == old = new
256− | otherwise = JSIdent old
259+ | otherwise = old
257
260
258jsSubst var new (JSArray fields) =
261jsSubst var new (JSArray fields) =
259 JSArray (map (jsSubst var new) fields)
262 JSArray (map (jsSubst var new) fields)
@@ -261,25 +264,25 @@ jsSubst var new (JSArray fields) =
261jsSubst var new (JSNew con vals) =
264jsSubst var new (JSNew con vals) =
262 JSNew con $ map (jsSubst var new) vals
265 JSNew con $ map (jsSubst var new) vals
263
266
264−jsSubst var new (JSApp (JSProj (JSFunction args body) "apply") vals)
267+jsSubst (JSIdent var) new (JSApp (JSProj (JSFunction args body) "apply") vals)
265 | var `notElem` args =
268 | var `notElem` args =
266− JSApp (JSProj (JSFunction args (jsSubst var new body)) "apply") (
269+ JSApp (JSProj (JSFunction args (jsSubst (JSIdent var) new body)) "apply") (
267− map (jsSubst var new) vals
270+ map (jsSubst (JSIdent var) new) vals
268 )
271 )
269 | otherwise =
272 | otherwise =
270 JSApp (JSProj (JSFunction args body) "apply") (
273 JSApp (JSProj (JSFunction args body) "apply") (
271− map (jsSubst var new) vals
274+ map (jsSubst (JSIdent var) new) vals
272 )
275 )
273
276
274−jsSubst var new (JSApp (JSFunction [arg] body) vals)
277+jsSubst (JSIdent var) new (JSApp (JSFunction [arg] body) vals)
275 | var /= arg =
278 | var /= arg =
276 JSApp (JSFunction [arg] (
279 JSApp (JSFunction [arg] (
277− jsSubst var new body
280+ jsSubst (JSIdent var) new body
278− )) $ map (jsSubst var new) vals
281+ )) $ map (jsSubst (JSIdent var) new) vals
279 | otherwise =
282 | otherwise =
280 JSApp (JSFunction [arg] (
283 JSApp (JSFunction [arg] (
281 body
284 body
282− )) $ map (jsSubst var new) vals
285+ )) $ map (jsSubst (JSIdent var) new) vals
283
286
284jsSubst var new (JSApp lhs rhs) =
287jsSubst var new (JSApp lhs rhs) =
285 JSApp (jsSubst var new lhs) (map (jsSubst var new) rhs)
288 JSApp (jsSubst var new lhs) (map (jsSubst var new) rhs)
@@ -324,7 +327,7 @@ removeAllocations (JSSeq body) =
324 removeHelper :: [JS] -> [JS]
327 removeHelper :: [JS] -> [JS]
325 removeHelper [js] = [js]
328 removeHelper [js] = [js]
326 removeHelper ((JSAlloc name (Just val@(JSIdent _))):js) =
329 removeHelper ((JSAlloc name (Just val@(JSIdent _))):js) =
327− map (jsSubst name val) (removeHelper js)
330+ map (jsSubst (JSIdent name) val) (removeHelper js)
328 removeHelper (j:js) = j : removeHelper js
331 removeHelper (j:js) = j : removeHelper js
329
332
330removeAllocations (JSFunction args body) =
333removeAllocations (JSFunction args body) =
@@ -378,7 +381,7 @@ isJSConstant js
378
381
379inlineJS :: JS -> JS
382inlineJS :: JS -> JS
380inlineJS (JSReturn (JSApp (JSFunction ["cse"] body) [val@(JSVar _)])) =
383inlineJS (JSReturn (JSApp (JSFunction ["cse"] body) [val@(JSVar _)])) =
381− inlineJS $ jsSubst "cse" val body
384+ inlineJS $ jsSubst (JSIdent "cse") val body
382
385
383inlineJS (JSReturn (JSApp (JSFunction [arg] cond@(JSCond _)) [val])) =
386inlineJS (JSReturn (JSApp (JSFunction [arg] cond@(JSCond _)) [val])) =
384 JSSeq [ JSAlloc arg (Just (inlineJS val))
387 JSSeq [ JSAlloc arg (Just (inlineJS val))
@@ -394,7 +397,7 @@ inlineJS (JSApp (JSProj (JSFunction args (JSReturn body)) "apply") [
394 inlineApply [] body _ = inlineJS body
397 inlineApply [] body _ = inlineJS body
395 inlineApply (a:as) body n =
398 inlineApply (a:as) body n =
396 inlineApply as (
399 inlineApply as (
397− jsSubst a (JSIndex (JSProj var "vars") (JSNum (JSInt n))) body
400+ jsSubst (JSIdent a) (JSIndex (JSProj var "vars") (JSNum (JSInt n))) body
398 ) (n + 1)
401 ) (n + 1)
399
402
400inlineJS (JSApp (JSIdent "__IDR__mEVAL0") [val])
403inlineJS (JSApp (JSIdent "__IDR__mEVAL0") [val])
@@ -408,33 +411,43 @@ inlineJS (JSApp (JSIdent "__IDRRT__tailcall") [
408inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])
411inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])
409 | JSNew con [tag, vals] <- ret
412 | JSNew con [tag, vals] <- ret
410 , opt <- inlineJS val =
413 , opt <- inlineJS val =
411− JSNew con [tag, jsSubst arg opt vals]
414+ JSNew con [tag, jsSubst (JSIdent arg) opt vals]
412
415
413 | JSNew con [JSFunction [] (JSReturn (JSApp fun vars))] <- ret
416 | JSNew con [JSFunction [] (JSReturn (JSApp fun vars))] <- ret
414 , opt <- inlineJS val =
417 , opt <- inlineJS val =
415 JSNew con [JSFunction [] (
418 JSNew con [JSFunction [] (
419+ JSReturn (
420+ JSApp (
421+ jsSubst (JSIdent arg) opt fun
422+ ) (
416− JSReturn $ JSApp (jsSubst arg opt fun) (map (jsSubst arg opt) vars)
423+ map (jsSubst (JSIdent arg) opt) vars
424+ )
425+ )
417 )]
426 )]
418
427
419 | JSApp (JSProj obj field) args <- ret
428 | JSApp (JSProj obj field) args <- ret
420 , opt <- inlineJS val =
429 , opt <- inlineJS val =
430+ JSApp (
421− JSApp (JSProj (jsSubst arg opt obj) field) $ map (jsSubst arg opt) args
431+ JSProj (jsSubst (JSIdent arg) opt obj) field
432+ ) (
433+ map (jsSubst (JSIdent arg) opt) args
434+ )
422
435
423 | JSIndex (JSProj obj field) idx <- ret
436 | JSIndex (JSProj obj field) idx <- ret
424 , opt <- inlineJS val =
437 , opt <- inlineJS val =
425 JSIndex (JSProj (
438 JSIndex (JSProj (
426− jsSubst arg opt obj
439+ jsSubst (JSIdent arg) opt obj
427 ) field
440 ) field
428− ) (jsSubst arg opt idx)
441+ ) (jsSubst (JSIdent arg) opt idx)
429
442
430 | JSOp op lhs rhs <- ret
443 | JSOp op lhs rhs <- ret
431 , opt <- inlineJS val =
444 , opt <- inlineJS val =
432− JSOp op (jsSubst arg opt lhs) $
445+ JSOp op (jsSubst (JSIdent arg) opt lhs) $
433− (jsSubst arg opt rhs)
446+ (jsSubst (JSIdent arg) opt rhs)
434
447
435 | JSApp (JSIdent fun) args <- ret
448 | JSApp (JSIdent fun) args <- ret
436 , opt <- inlineJS val =
449 , opt <- inlineJS val =
437− JSApp (JSIdent fun) $ map (jsSubst arg opt) args
450+ JSApp (JSIdent fun) $ map (jsSubst (JSIdent arg) opt) args
438
451
439inlineJS (JSApp fun args) =
452inlineJS (JSApp fun args) =
440 JSApp (inlineJS fun) (map inlineJS args)
453 JSApp (inlineJS fun) (map inlineJS args)
@@ -480,6 +493,11 @@ reduceJS js = reduceLoop [] ([], js)
480funName :: JS -> String
493funName :: JS -> String
481funName (JSAlloc fun _) = fun
494funName (JSAlloc fun _) = fun
482
495
496+elimDeadLoop :: [JS] -> [JS]
497+elimDeadLoop js
498+ | ret <- deadEvalApplyCases js
499+ , ret /= js = elimDeadLoop ret
500+ | otherwise = js
483
501
484deadEvalApplyCases :: [JS] -> [JS]
502deadEvalApplyCases :: [JS] -> [JS]
485deadEvalApplyCases js =
503deadEvalApplyCases js =
@@ -816,6 +834,131 @@ reduceConstants js
816 , ret /= js = reduceConstants ret
834 , ret /= js = reduceConstants ret
817 | otherwise = js
835 | otherwise = js
818
836
837+
838+elimDuplicateEvals :: JS -> JS
839+elimDuplicateEvals (JSAlloc fun (Just (JSFunction args (JSSeq seq)))) =
840+ JSAlloc fun $ Just (JSFunction args $ JSSeq (elimHelper seq))
841+ where
842+ elimHelper :: [JS] -> [JS]
843+ elimHelper (j@(JSAlloc var (Just val)):js) =
844+ j : map (jsSubst val (JSIdent var)) (elimHelper js)
845+ elimHelper (j:js) =
846+ j : elimHelper js
847+ elimHelper [] = []
848+
849+elimDuplicateEvals js = js
850+
851+optimizeEvalTailcalls :: (String, String) -> JS -> JS
852+optimizeEvalTailcalls (fun, tc) js =
853+ optHelper js
854+ where
855+ optHelper :: JS -> JS
856+ optHelper (JSApp (JSIdent "__IDRRT__tailcall") [
857+ JSFunction [] (JSReturn (JSApp (JSIdent n) args))
858+ ])
859+ | n == fun = JSApp (JSIdent tc) $ map optHelper args
860+
861+ optHelper (JSFunction args body) =
862+ JSFunction args $ optHelper body
863+
864+ optHelper (JSSeq seq) =
865+ JSSeq $ map optHelper seq
866+
867+ optHelper (JSReturn ret) =
868+ JSReturn $ optHelper ret
869+
870+ optHelper (JSApp lhs rhs) =
871+ JSApp (optHelper lhs) (map optHelper rhs)
872+
873+ optHelper (JSNew con args) =
874+ JSNew con $ map optHelper args
875+
876+ optHelper (JSOp op lhs rhs) =
877+ JSOp op (optHelper lhs) (optHelper rhs)
878+
879+ optHelper (JSProj obj field) =
880+ JSProj (optHelper obj) field
881+
882+ optHelper (JSArray vals) =
883+ JSArray $ map optHelper vals
884+
885+ optHelper (JSAssign lhs rhs) =
886+ JSAssign (optHelper lhs) (optHelper rhs)
887+
888+ optHelper (JSAlloc var (Just val)) =
889+ JSAlloc var (Just $ optHelper val)
890+
891+ optHelper (JSIndex lhs rhs) =
892+ JSIndex (optHelper lhs) (optHelper rhs)
893+
894+ optHelper (JSCond conds) =
895+ JSCond $ map (optHelper *** optHelper) conds
896+
897+ optHelper (JSTernary c t f) =
898+ JSTernary (
899+ optHelper c
900+ ) (
901+ optHelper t
902+ ) (
903+ optHelper f
904+ )
905+
906+ optHelper js = js
907+
908+
909+removeInstanceChecks :: JS -> JS
910+removeInstanceChecks (JSCond conds) =
911+ JSCond $ map (removeHelper *** removeInstanceChecks) conds
912+ where
913+ removeHelper (
914+ JSOp "&&" (JSOp "instanceof" _ (JSIdent "__IDRRT__Con")) check
915+ ) = removeHelper check
916+ removeHelper js = js
917+
918+removeInstanceChecks (JSFunction args body) =
919+ JSFunction args $ removeInstanceChecks body
920+
921+removeInstanceChecks (JSSeq seq) =
922+ JSSeq $ map removeInstanceChecks seq
923+
924+removeInstanceChecks (JSReturn ret) =
925+ JSReturn $ removeInstanceChecks ret
926+
927+removeInstanceChecks (JSApp lhs rhs) =
928+ JSApp (removeInstanceChecks lhs) $ map removeInstanceChecks rhs
929+
930+removeInstanceChecks (JSNew con args) =
931+ JSNew con $ map removeInstanceChecks args
932+
933+removeInstanceChecks (JSOp op lhs rhs) =
934+ JSOp op (removeInstanceChecks lhs) (removeInstanceChecks rhs)
935+
936+removeInstanceChecks (JSProj obj field) =
937+ JSProj (removeInstanceChecks obj) field
938+
939+removeInstanceChecks (JSArray vals) =
940+ JSArray $ map removeInstanceChecks vals
941+
942+removeInstanceChecks (JSAssign lhs rhs) =
943+ JSAssign (removeInstanceChecks lhs) (removeInstanceChecks rhs)
944+
945+removeInstanceChecks (JSAlloc var (Just val)) =
946+ JSAlloc var (Just $ removeInstanceChecks val)
947+
948+removeInstanceChecks (JSIndex lhs rhs) =
949+ JSIndex (removeInstanceChecks lhs) (removeInstanceChecks rhs)
950+
951+removeInstanceChecks (JSTernary c t f) =
952+ JSTernary (
953+ removeInstanceChecks c
954+ ) (
955+ removeInstanceChecks t
956+ ) (
957+ removeInstanceChecks f
958+ )
959+
960+removeInstanceChecks js = js
961+
819reduceLoop :: [String] -> ([JS], [JS]) -> [JS]
962reduceLoop :: [String] -> ([JS], [JS]) -> [JS]
820reduceLoop reduced (cons, program) =
963reduceLoop reduced (cons, program) =
821 case partition findConstructors program of
964 case partition findConstructors program of
@@ -942,8 +1085,13 @@ codegenJavaScript target definitions filename outputType = do
942 constRemoved = map reduceConstants reduced
1085 constRemoved = map reduceConstants reduced
943 constrInit = initConstructors constRemoved
1086 constrInit = initConstructors constRemoved
944 removeAlloc = map removeAllocations constrInit
1087 removeAlloc = map removeAllocations constrInit
945− deadElim = deadEvalApplyCases removeAlloc
1088+ deadElim = elimDeadLoop removeAlloc
946− js = inlineFunctions deadElim in
1089+ inlined = inlineFunctions deadElim
1090+ elimDup = map elimDuplicateEvals inlined
1091+ evalTC = map (optimizeEvalTailcalls ("__IDR__mEVAL0", "__IDRRT__EVALTC")) elimDup
1092+ applyTC = map (optimizeEvalTailcalls ("__IDR__mAPPLY0", "__IDRRT__APPLYTC")) evalTC
1093+ remChecks = map removeInstanceChecks applyTC
1094+ js = remChecks in
947 map compileJS js
1095 map compileJS js
948
1096
949 mainLoop :: JS
1097 mainLoop :: JS