trying to reduce cost of primitive application

compiler/compiler.rkt

@@ -1000,7 +1000,8 @@
              [(KernelPrimitiveName/Inline? id)
               (compile-open-codeable-application id exp cenv target linkage)]
              [((current-primitive-identifier?) id)
-              (compile-primitive-application exp cenv target linkage)]
+              => (lambda (expected-arity)
+                   (compile-primitive-application exp cenv target linkage id expected-arity))]
              [else
               (default)]))]
         [(StaticallyKnownLam? op-knowledge)
@@ -1079,8 +1080,8 @@
 
 
 
-(: compile-primitive-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence))
+(: compile-primitive-application (App CompileTimeEnvironment Target Linkage Symbol Arity -> InstructionSequence))
-(define (compile-primitive-application exp cenv target linkage)
+(define (compile-primitive-application exp cenv target linkage primitive-name expected-arity)
   (let* ([extended-cenv
           (extend-compile-time-environment/scratch-space 
            cenv 
@@ -1101,10 +1102,39 @@
      (apply append-instruction-sequences operand-codes)
      proc-code
      (make-AssignImmediate 'argcount (make-Const (length (App-operands exp))))
-     (compile-primitive-procedure-call cenv 
+     (if (arity-matches? expected-arity (length (App-operands exp)))
-                                       (make-Const (length (App-operands exp)))
+         (compile-primitive-procedure-call primitive-name
-                                       target
+                                           cenv 
-                                       linkage))))
+                                           (make-Const (length (App-operands exp)))
+                                           target
+                                           linkage)
+         (make-Perform (make-RaiseArityMismatchError! 
+                       (make-Reg 'proc)
+                       expected-arity
+                       (make-Const (length (App-operands exp)))))))))
+
+
+;; If we know the procedure is implemented as a primitive (as opposed to a general closure),
+;; we can do a little less work.
+;; We don't need to check arity (as that's already been checked statically).
+;; Assumes 1. the procedure value is loaded into proc,
+;;         2. number-of-arguments has been written into the argcount register,
+; ;        3. the number-of-arguments values are on the stack.
+(: compile-primitive-procedure-call (Symbol CompileTimeEnvironment OpArg Target Linkage -> InstructionSequence))
+(define (compile-primitive-procedure-call primitive-name cenv number-of-arguments target linkage)
+  (end-with-linkage
+   linkage
+   cenv
+   (append-instruction-sequences
+    (make-AssignPrimOp 'val (make-ApplyPrimitiveProcedure primitive-name))
+    (make-PopEnvironment number-of-arguments (make-Const 0))
+    (if (eq? target 'val)
+        empty-instruction-sequence
+        (make-AssignImmediate target (make-Reg 'val)))
+    (emit-singular-context linkage))))
+
+
+
 
 
 
@@ -1511,29 +1541,6 @@
 
 
 
-;; If we know the procedure is implemented as a primitive (as opposed to a general closure),
-;; we can do a little less work.
-;; Assumes 1. the procedure value is loaded into proc,
-;;         2. number-of-arguments has been written into the argcount register,
-; ;        3. the number-of-arguments values are on the stack.
-(: compile-primitive-procedure-call (CompileTimeEnvironment OpArg Target Linkage 
-                                                            -> InstructionSequence))
-(define (compile-primitive-procedure-call cenv number-of-arguments target linkage)
-  (end-with-linkage
-   linkage
-   cenv
-   (append-instruction-sequences
-    (make-Perform (make-CheckPrimitiveArity!))
-    (make-AssignPrimOp 'val (make-ApplyPrimitiveProcedure))
-    (make-PopEnvironment number-of-arguments (make-Const 0))
-    (if (eq? target 'val)
-        empty-instruction-sequence
-        (make-AssignImmediate target (make-Reg 'val)))
-    (emit-singular-context linkage))))
-
-
-
-
 
 
 (: compile-procedure-call/statically-known-lam 

compiler/il-structs.rkt

@@ -339,7 +339,7 @@
   #:transparent)
 
 
-(define-struct: ApplyPrimitiveProcedure () #:transparent)
+(define-struct: ApplyPrimitiveProcedure ([name : Symbol]) #:transparent)
 
 
 (define-struct: MakeBoxedEnvironmentValue ([depth : Natural])

js-assembler/find-primitive-implemented.rkt

@@ -2,7 +2,8 @@
 
 (require racket/runtime-path
          racket/list
-         (for-syntax racket/base))
+         (for-syntax racket/base)
+         "../compiler/arity-structs.rkt")
 
 ;; Provides a list of symbols of the function implemented primitively.  Knowing
 ;; this allows us to do certain procedure applications more efficiently without
@@ -10,18 +11,41 @@
 (provide primitive-ids)
 
 (define a-regexp 
-  #px"installPrimitiveProcedure\\s*\\(\\s*['\"]([^'\"]+)['\"]")
+  #px"installPrimitiveProcedure\\s*\\(\\s*['\"]([^'\"]+)['\"]\\s*,\\s*([^\n]+)\n")
 
 (define-runtime-path baselib-primitives.js
   (build-path "runtime-src" "baselib-primitives.js"))
 
 (define ip (open-input-file baselib-primitives.js))
 
+(define (parse-arity-string s)
+  (define arity
+    (let loop ([s s])
+      (let ([s (regexp-replace #px",\\s+$" s "")])
+        (cond
+          [(regexp-match #px"^(\\d+)" s)
+           =>
+           (lambda (m) (string->number (second m)))]
+          [(regexp-match #px"^makeList\\((.+)\\)" s)
+           =>
+           (lambda (m) 
+             (map string->number (regexp-split #px"\\s*,\\s*" (second m))))]
+          [(regexp-match #px"^baselib.arity.makeArityAtLeast\\((\\d+)\\)" s)
+           =>
+           (lambda (m) 
+             (ArityAtLeast (string->number (second m))))]
+          [else
+           (error 'parse-arity-string "How to parse? ~e" s)]))))
+  arity)
+  
 (define primitive-ids
   (let loop ()
     (let ([a-match (regexp-match a-regexp ip)])
       (cond
         [a-match => (lambda (a-match)
-                      (cons (string->symbol (bytes->string/utf-8 (second a-match)))
+                      (define name (second a-match))
+                      (define arity-string (bytes->string/utf-8 (third a-match)))
+                      (define arity (parse-arity-string arity-string))
+                      (cons (cons (string->symbol (bytes->string/utf-8 name)) arity)
                             (loop)))]
         [else empty]))))

js-assembler/package.rkt

@@ -59,15 +59,15 @@
 
 
 
-(define primitive-identifiers-set
+(define primitive-identifiers-ht
-  (list->set primitive-ids))
+  (make-hash primitive-ids))
 
 ;; Sets up the compiler parameters we need to do javascript-specific compilation.
 (define (with-compiler-params thunk)
   (parameterize ([compile-context-preservation-enabled #t]
                  [current-primitive-identifier?
                   (lambda (a-name)
-                    (set-member? primitive-identifiers-set a-name))])
+                    (hash-ref primitive-identifiers-ht a-name #f))])
     (thunk)))
 
 

js-assembler/runtime-src/baselib-primitives.js

@@ -1635,7 +1635,7 @@
 
     installPrimitiveProcedure(
         'random',
-        baselib.lists.makeList(0, 1),
+        makeList(0, 1),
         function (M) {
             if (M.a === 0) {
                 return makeFloat(Math.random());

parameters.rkt

@@ -2,6 +2,7 @@
 
 (require "compiler/expression-structs.rkt"
          "compiler/lexical-structs.rkt"
+         "compiler/arity-structs.rkt"
          "sets.rkt"
          racket/path
          racket/port)
@@ -55,7 +56,7 @@
 
 
 
-(: current-primitive-identifier? (Parameterof (Symbol -> Boolean)))
+(: current-primitive-identifier? (Parameterof (Symbol -> (U False Arity))))
 (define current-primitive-identifier? (make-parameter (lambda: ([name : Symbol]) #f)))
 
 

version.rkt

@@ -7,4 +7,4 @@
 (provide version)
 (: version String)
 
-(define version "1.198")
+(define version "1.199")