From f182cf25ba0a5461f55d62953d8f33c6d8f32c01 Mon Sep 17 00:00:00 2001
From: raichoo <raichoo@googlemail.com>
Date: Mon, 3 Feb 2014 20:19:09 +0100
Subject: [PATCH] javascript: moved EVALTC and APPLYTC into codegen

---
 jsrts/Runtime-common.js       | 17 ---------
 src/IRTS/CodegenJavaScript.hs | 66 ++++++++++++++++++++++++++++++++---
 2 files changed, 61 insertions(+), 22 deletions(-)

diff --git a/jsrts/Runtime-common.js b/jsrts/Runtime-common.js
index 873054001..6d59936a8 100644
--- a/jsrts/Runtime-common.js
+++ b/jsrts/Runtime-common.js
@@ -37,20 +37,3 @@ var __IDRRT__tailcall = function(k) {
 
   return ret;
 };
-
-var __IDRRT__EVALTC = function(arg0) {
-  var ret = (arg0 instanceof __IDRRT__Con && __IDRLT__mEVAL0[arg0.tag])?(__IDRLT__mEVAL0[arg0.tag](arg0)):(arg0);
-  while (ret instanceof __IDRRT__Cont)
-    ret = ret.k();
-
-  return ret;
-};
-
-var __IDRRT__APPLYTC = function(fn0, arg0) {
-  var ev  = __IDRRT__EVALTC(fn0);
-  var ret = (ev instanceof __IDRRT__Con && __IDRLT__mAPPLY0[ev.tag])?(__IDRLT__mAPPLY0[ev.tag](fn0,arg0,ev)):(null)
-  while (ret instanceof __IDRRT__Cont)
-    ret = ret.k();
-
-  return ret;
-}
diff --git a/src/IRTS/CodegenJavaScript.hs b/src/IRTS/CodegenJavaScript.hs
index a1e6e6f40..8f0d6a087 100644
--- a/src/IRTS/CodegenJavaScript.hs
+++ b/src/IRTS/CodegenJavaScript.hs
@@ -766,9 +766,9 @@ elimDuplicateEvals (JSAlloc fun (Just (JSFunction args (JSSeq seq)))) =
 elimDuplicateEvals js = js
 
 
-optimizeEvalTailcalls :: (String, String) -> JS -> JS
-optimizeEvalTailcalls (fun, tc) js =
-  optHelper js
+optimizeRuntimeCalls :: String -> String -> [JS] -> [JS]
+optimizeRuntimeCalls fun tc js =
+  optTC tc : map optHelper js
   where
     optHelper :: JS -> JS
     optHelper (JSApp (JSIdent "__IDRRT__tailcall") [
@@ -779,6 +779,62 @@ optimizeEvalTailcalls (fun, tc) js =
     optHelper js = transformJS optHelper js
 
 
+    optTC :: String -> JS
+    optTC tc@"__IDRRT__EVALTC" =
+      JSAlloc tc (Just $ JSFunction ["arg0"] (
+        JSSeq [ JSAlloc "ret" $ Just (
+                  JSTernary (
+                    (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
+                    (hasProp "__IDRLT__mEVAL0" "arg0")
+                  ) (JSApp
+                      (JSIndex
+                        (JSIdent "__IDRLT__mEVAL0")
+                        (JSProj (JSIdent "arg0") "tag")
+                      )
+                      [JSIdent "arg0"]
+                  ) (JSIdent "arg0")
+                )
+              , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
+                  JSAssign (JSIdent "ret") (
+                    JSApp (JSProj (JSIdent "ret") "k") []
+                  )
+                )
+              , JSReturn $ JSIdent "ret"
+              ]
+      ))
+
+    optTC tc@"__IDRRT__APPLYTC" =
+      JSAlloc tc (Just $ JSFunction ["fn0", "arg0"] (
+        JSSeq [ JSAlloc "ev" $ Just (JSApp
+                  (JSIdent "__IDRRT__EVALTC") [JSIdent "fn0"]
+                )
+              , JSAlloc "ret" $ Just (
+                  JSTernary (
+                    (JSIdent "ev" `jsInstanceOf` jsCon) `jsAnd`
+                    (hasProp "__IDRLT__mAPPLY0" "ev")
+                  ) (JSApp
+                      (JSIndex
+                        (JSIdent "__IDRLT__mAPPLY0")
+                        (JSProj (JSIdent "ev") "tag")
+                      )
+                      [JSIdent "fn0", JSIdent "arg0", JSIdent "ev"]
+                  ) JSNull
+                )
+              , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
+                  JSAssign (JSIdent "ret") (
+                    JSApp (JSProj (JSIdent "ret") "k") []
+                  )
+                )
+              , JSReturn $ JSIdent "ret"
+              ]
+      ))
+
+
+    hasProp :: String -> String -> JS
+    hasProp table var =
+      JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
+
+
 unfoldLookupTable :: [JS] -> [JS]
 unfoldLookupTable input =
   let (evals, evalunfold)   = unfoldLT "__IDRLT__mEVAL0" input
@@ -967,8 +1023,8 @@ codegenJavaScript target definitions filename outputType = do
           , map removeAllocations
           , elimDeadLoop
           , map elimDuplicateEvals
-          , map (optimizeEvalTailcalls ("__IDR__mEVAL0", "__IDRRT__EVALTC"))
-          , map (optimizeEvalTailcalls ("__IDR__mAPPLY0", "__IDRRT__APPLYTC"))
+          , optimizeRuntimeCalls "__IDR__mEVAL0" "__IDRRT__EVALTC"
+          , optimizeRuntimeCalls "__IDR__mAPPLY0" "__IDRRT__APPLYTC"
           , map removeInstanceChecks
           , inlineFunctions
           , map reduceContinuations