diff --git a/compiler/compiler.rkt b/compiler/compiler.rkt index 10c6973..b39c6b9 100644 --- a/compiler/compiler.rkt +++ b/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)) -(define (compile-primitive-application exp cenv target linkage) +(: compile-primitive-application (App CompileTimeEnvironment Target Linkage Symbol Arity -> InstructionSequence)) +(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 - (make-Const (length (App-operands exp))) - target - linkage)))) + (if (arity-matches? expected-arity (length (App-operands exp))) + (compile-primitive-procedure-call primitive-name + cenv + (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 diff --git a/compiler/il-structs.rkt b/compiler/il-structs.rkt index edc2a75..af413ef 100644 --- a/compiler/il-structs.rkt +++ b/compiler/il-structs.rkt @@ -339,7 +339,7 @@ #:transparent) -(define-struct: ApplyPrimitiveProcedure () #:transparent) +(define-struct: ApplyPrimitiveProcedure ([name : Symbol]) #:transparent) (define-struct: MakeBoxedEnvironmentValue ([depth : Natural]) diff --git a/js-assembler/find-primitive-implemented.rkt b/js-assembler/find-primitive-implemented.rkt index 9467927..aeb8d28 100644 --- a/js-assembler/find-primitive-implemented.rkt +++ b/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])))) \ No newline at end of file diff --git a/js-assembler/package.rkt b/js-assembler/package.rkt index 0f15dfd..2e4ff92 100644 --- a/js-assembler/package.rkt +++ b/js-assembler/package.rkt @@ -59,15 +59,15 @@ -(define primitive-identifiers-set - (list->set primitive-ids)) +(define primitive-identifiers-ht + (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))) diff --git a/js-assembler/runtime-src/baselib-primitives.js b/js-assembler/runtime-src/baselib-primitives.js index 93c7e7a..3728ce7 100644 --- a/js-assembler/runtime-src/baselib-primitives.js +++ b/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()); diff --git a/parameters.rkt b/parameters.rkt index 2b3592d..d9b76e3 100644 --- a/parameters.rkt +++ b/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))) diff --git a/version.rkt b/version.rkt index d12d1ca..6320d29 100644 --- a/version.rkt +++ b/version.rkt @@ -7,4 +7,4 @@ (provide version) (: version String) -(define version "1.198") +(define version "1.199")