From 0522354d84a090fd47d3f2d703b079b20f80aaa0 Mon Sep 17 00:00:00 2001
From: Danny Yoo <dyoo@cs.wpi.edu>
Date: Wed, 2 Nov 2011 14:38:16 -0400
Subject: [PATCH] primitive compliation is in

---
 compiler/compiler.rkt    | 35 +++++++++++++++++++++++++++++++++++
 js-assembler/package.rkt | 21 +++++++++++++++++++--
 parameters.rkt           |  6 ++++++
 version.rkt              |  2 +-
 4 files changed, 61 insertions(+), 3 deletions(-)

diff --git a/compiler/compiler.rkt b/compiler/compiler.rkt
index 44bcb03..8cc49ce 100644
--- a/compiler/compiler.rkt
+++ b/compiler/compiler.rkt
@@ -957,6 +957,8 @@
            (cond
              [(KernelPrimitiveName/Inline? id)
               (compile-open-codeable-application id exp cenv target linkage)]
+             [((current-primitive-identifier?) id)
+              (compile-primitive-application exp cenv target linkage)]
              [else
               (default)]))]
         [(StaticallyKnownLam? op-knowledge)
@@ -1042,6 +1044,39 @@
                                      linkage))))
 
 
+
+
+
+
+(: compile-primitive-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence))
+(define (compile-primitive-application exp cenv target linkage)
+  (let* ([extended-cenv
+          (extend-compile-time-environment/scratch-space 
+           cenv 
+           (length (App-operands exp)))]
+         [proc-code (compile (App-operator exp) extended-cenv 'proc next-linkage/expects-single)]
+         [operand-codes (map (lambda: ([operand : Expression]
+                                       [target : Target])
+                               (compile operand
+                                        extended-cenv
+                                        target
+                                        next-linkage/expects-single))
+                             (App-operands exp)
+                             (build-list (length (App-operands exp))
+                                         (lambda: ([i : Natural])
+                                           (make-EnvLexicalReference i #f))))])
+    (append-instruction-sequences
+     (make-PushEnvironment (length (App-operands exp)) #f)
+     (apply append-instruction-sequences operand-codes)
+     proc-code
+     (make-AssignImmediateStatement 'argcount (make-Const (length (App-operands exp))))
+     (compile-primitive-procedure-call cenv 
+                                       (make-Const (length (App-operands exp)))
+                                       target
+                                       linkage))))
+
+
+
 (: compile-open-codeable-application
    (KernelPrimitiveName/Inline App CompileTimeEnvironment Target Linkage -> InstructionSequence))
 ;; This is a special case of application, where the operator is statically
diff --git a/js-assembler/package.rkt b/js-assembler/package.rkt
index 7f58e46..fd492a9 100644
--- a/js-assembler/package.rkt
+++ b/js-assembler/package.rkt
@@ -13,6 +13,7 @@
 	 "../promise.rkt"
          "../get-module-bytecode.rkt"
          "check-valid-module-source.rkt"
+         "find-primitive-implemented.rkt"
          (prefix-in hash-cache: "hash-cache.rkt")
          racket/match
          racket/list
@@ -58,6 +59,19 @@
 
 
 
+(define primitive-identifiers-set
+  (list->set primitive-ids))
+
+;; Sets up the compiler parameters we need to do javascript-specific compilation.
+(define (with-compiler-params thunk)
+  (parameterize ([current-primitive-identifier?
+                  (lambda (a-name)
+                    (set-member? primitive-identifiers-set a-name))])
+    (thunk)))
+
+
+
+
 (define current-on-resource
   (make-parameter (lambda (r)
                     (log-debug "Resource ~s should be written"
@@ -363,7 +377,8 @@ M.modules[~s] =
      ;; last
      on-last-src))
   
-  (make (list source-code) packaging-configuration)
+  (with-compiler-params
+   (lambda () (make (list source-code) packaging-configuration)))
   
   (for ([r resources])
     ((current-on-resource) r)))
@@ -467,7 +482,9 @@ M.modules[~s] =
     
     (newline op)
     (fprintf op "(function(M, SUCCESS, FAIL, PARAMS) {")
-    (make (list (my-force only-bootstrapped-code)) packaging-configuration)
+    (with-compiler-params
+     (lambda ()
+       (make (list (my-force only-bootstrapped-code)) packaging-configuration)))
     (fprintf op "})(plt.runtime.currentMachine,\nfunction(){ plt.runtime.setReadyTrue(); },\nfunction(){},\n{});\n")))
 
 
diff --git a/parameters.rkt b/parameters.rkt
index 8f92efd..c355ec0 100644
--- a/parameters.rkt
+++ b/parameters.rkt
@@ -18,6 +18,9 @@
          current-seen-unimplemented-kernel-primitives
 
          current-kernel-module-locator?
+
+         current-primitive-identifier?
+         
          current-compress-javascript?
          current-one-module-per-file?
          current-with-cache?
@@ -74,6 +77,9 @@
 
 
 
+(: current-primitive-identifier? (Parameterof (Symbol -> Boolean)))
+(define current-primitive-identifier? (make-parameter (lambda: ([name : Symbol]) #f)))
+
 
 (: current-compress-javascript? (Parameterof Boolean))
 (define current-compress-javascript? (make-parameter #f))
diff --git a/version.rkt b/version.rkt
index b97a94d..3f35af7 100644
--- a/version.rkt
+++ b/version.rkt
@@ -6,4 +6,4 @@
 
 (provide version)
 (: version String)
-(define version "1.49")
+(define version "1.50")