From f1ed02095ca68d71a916fb71539a031c5be0343c Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Fri, 19 Aug 2011 18:24:18 -0400 Subject: [PATCH] fixing compile-time error on using kernel primitives: turned into runtime errors as appropriate --- compiler/analyzer-structs.rkt | 3 +- compiler/arity-structs.rkt | 12 ++ compiler/bootstrapped-primitives.rkt | 3 +- compiler/compiler.rkt | 282 +++++++++++++++------------ compiler/il-structs.rkt | 23 +-- compiler/kernel-primitives.rkt | 84 ++++---- js-assembler/assemble-helpers.rkt | 1 + js-assembler/assemble-open-coded.rkt | 8 + simulator/simulator-primitives.rkt | 1 + simulator/simulator-structs.rkt | 3 +- simulator/simulator.rkt | 1 + tests/test-assemble.rkt | 1 + tests/test-simulator.rkt | 1 + 13 files changed, 241 insertions(+), 182 deletions(-) create mode 100644 compiler/arity-structs.rkt diff --git a/compiler/analyzer-structs.rkt b/compiler/analyzer-structs.rkt index 66ab6e5..ca0fdb3 100644 --- a/compiler/analyzer-structs.rkt +++ b/compiler/analyzer-structs.rkt @@ -1,7 +1,8 @@ #lang typed/racket/base -(require "expression-structs.rkt" +(require "arity-structs.rkt" + "expression-structs.rkt" "lexical-structs.rkt" "kernel-primitives.rkt" "il-structs.rkt") diff --git a/compiler/arity-structs.rkt b/compiler/arity-structs.rkt new file mode 100644 index 0000000..7299ffd --- /dev/null +++ b/compiler/arity-structs.rkt @@ -0,0 +1,12 @@ +#lang typed/racket/base + +(provide (all-defined-out)) + +;; Arity +(define-type Arity (U AtomicArity (Listof (U AtomicArity)))) +(define-type AtomicArity (U Natural ArityAtLeast)) +(define-struct: ArityAtLeast ([value : Natural]) + #:transparent) +(define-predicate AtomicArity? AtomicArity) +(define-predicate listof-atomic-arity? (Listof AtomicArity)) + diff --git a/compiler/bootstrapped-primitives.rkt b/compiler/bootstrapped-primitives.rkt index a796a5f..9826ddd 100644 --- a/compiler/bootstrapped-primitives.rkt +++ b/compiler/bootstrapped-primitives.rkt @@ -1,5 +1,6 @@ #lang typed/racket/base -(require "expression-structs.rkt" +(require "arity-structs.rkt" + "expression-structs.rkt" "lexical-structs.rkt" "il-structs.rkt" "compiler.rkt" diff --git a/compiler/compiler.rkt b/compiler/compiler.rkt index e15f71f..d77f236 100644 --- a/compiler/compiler.rkt +++ b/compiler/compiler.rkt @@ -1,6 +1,7 @@ #lang typed/racket/base -(require "expression-structs.rkt" +(require "arity-structs.rkt" + "expression-structs.rkt" "lexical-structs.rkt" "il-structs.rkt" "compiler-structs.rkt" @@ -1028,135 +1029,166 @@ ;; ;; We have to be sensitive to mutation. (define (compile-kernel-primitive-application kernel-op exp cenv target linkage) - (let ([singular-context-check (emit-singular-context linkage)]) + (let ([singular-context-check (emit-singular-context linkage)] + [n (length (App-operands exp))]) + + (define expected-operand-types + (kernel-primitive-expected-operand-types kernel-op n)) + + (: make-runtime-arity-mismatch-code (Arity -> InstructionSequence)) + (define (make-runtime-arity-mismatch-code expected-arity) + ;; We compile the code to generate a runtime arity error here. + (end-with-linkage + linkage cenv + (append-instruction-sequences + (make-PushEnvironment n #f) + (apply append-instruction-sequences + (map (lambda: ([operand : Expression] + [target : Target]) + (compile operand + (extend-compile-time-environment/scratch-space + cenv + (length (App-operands exp))) + target + next-linkage/expects-single)) + (App-operands exp) + (build-list (length (App-operands exp)) + (lambda: ([i : Natural]) + (make-EnvLexicalReference i #f))))) + (make-AssignImmediateStatement 'proc (make-PrimitiveKernelValue kernel-op)) + (make-AssignImmediateStatement 'argcount + (make-Const (length (App-operands exp)))) + (make-PerformStatement (make-RaiseArityMismatchError! + (make-Reg 'proc) + expected-arity + (make-Const n)))))) + (cond - ;; If all the arguments are primitive enough (all constants, localrefs, or toplevelrefs), - ;; then application requires no stack space at all, and application is especially simple. - [(andmap (lambda (op) - ;; TODO: as long as the operand contains no applications? - (or (Constant? op) - (ToplevelRef? op) - (LocalRef? op))) - (App-operands exp)) - (let* ([n (length (App-operands exp))] - - [operand-knowledge - (map (lambda: ([arg : Expression]) - (extract-static-knowledge - arg - (extend-compile-time-environment/scratch-space - cenv n))) - (App-operands exp))] - - [typechecks? - (map (lambda: ([dom : OperandDomain] - [known : CompileTimeEnvironmentEntry]) - (not (redundant-check? dom known))) - (kernel-primitive-expected-operand-types kernel-op n) - operand-knowledge)] - - [expected-operand-types - (kernel-primitive-expected-operand-types kernel-op n)] - [operand-poss - (simple-operands->opargs (map (lambda: ([op : Expression]) - (adjust-expression-depth op n n)) - (App-operands exp)))]) - (end-with-linkage - linkage cenv - (append-instruction-sequences - (make-AssignPrimOpStatement target - (make-CallKernelPrimitiveProcedure - kernel-op - operand-poss - expected-operand-types - typechecks?)) - singular-context-check)))] + [(IncorrectArity? expected-operand-types) + (make-runtime-arity-mismatch-code (IncorrectArity-expected expected-operand-types))] + + [(not (= n (length expected-operand-types))) + (make-runtime-arity-mismatch-code (length expected-operand-types))] [else - ;; Otherwise, we can split the operands into two categories: constants, and the rest. - (let*-values ([(n) - (length (App-operands exp))] - - [(expected-operand-types) - (kernel-primitive-expected-operand-types kernel-op n)] - - [(constant-operands rest-operands) - (split-operands-by-constants + (cond + ;; If all the arguments are primitive enough (all constants, localrefs, or toplevelrefs), + ;; then application requires no stack space at all, and application is especially simple. + [(andmap (lambda (op) + ;; TODO: as long as the operand contains no applications? + (or (Constant? op) + (ToplevelRef? op) + (LocalRef? op))) + (App-operands exp)) + (let* ([operand-knowledge + (map (lambda: ([arg : Expression]) + (extract-static-knowledge + arg + (extend-compile-time-environment/scratch-space + cenv n))) (App-operands exp))] - - ;; here, we rewrite the stack references so they assume no scratch space - ;; used by the constant operands. - [(extended-cenv constant-operands rest-operands) - (values (extend-compile-time-environment/scratch-space - cenv - (length rest-operands)) - - (map (lambda: ([constant-operand : Expression]) - (ensure-simple-expression - (adjust-expression-depth constant-operand - (length constant-operands) - n))) - constant-operands) - - (map (lambda: ([rest-operand : Expression]) - (adjust-expression-depth rest-operand - (length constant-operands) - n)) - rest-operands))] - - [(operand-knowledge) - (append (map (lambda: ([arg : Expression]) - (extract-static-knowledge arg extended-cenv)) - constant-operands) - (map (lambda: ([arg : Expression]) - (extract-static-knowledge arg extended-cenv)) - rest-operands))] - - [(typechecks?) - (map (lambda: ([dom : OperandDomain] - [known : CompileTimeEnvironmentEntry]) - (not (redundant-check? dom known))) - (kernel-primitive-expected-operand-types kernel-op n) - operand-knowledge)] - - [(stack-pushing-code) - (make-PushEnvironment (length rest-operands) - #f)] - [(stack-popping-code) - (make-PopEnvironment (make-Const (length rest-operands)) - (make-Const 0))] - - [(constant-operand-poss) - (simple-operands->opargs constant-operands)] - - [(rest-operand-poss) - (build-list (length rest-operands) - (lambda: ([i : Natural]) - (make-EnvLexicalReference i #f)))] - [(rest-operand-code) - (apply append-instruction-sequences - (map (lambda: ([operand : Expression] - [target : Target]) - (compile operand - extended-cenv - target - next-linkage/expects-single)) - rest-operands - rest-operand-poss))]) + + [typechecks? + (map (lambda: ([dom : OperandDomain] + [known : CompileTimeEnvironmentEntry]) + (not (redundant-check? dom known))) + expected-operand-types + operand-knowledge)] + + [operand-poss + (simple-operands->opargs (map (lambda: ([op : Expression]) + (adjust-expression-depth op n n)) + (App-operands exp)))]) + (end-with-linkage + linkage cenv + (append-instruction-sequences + (make-AssignPrimOpStatement target + (make-CallKernelPrimitiveProcedure + kernel-op + operand-poss + expected-operand-types + typechecks?)) + singular-context-check)))] - (end-with-linkage - linkage cenv - (append-instruction-sequences - stack-pushing-code - rest-operand-code - (make-AssignPrimOpStatement (adjust-target-depth target (length rest-operands)) - (make-CallKernelPrimitiveProcedure - kernel-op - (append constant-operand-poss rest-operand-poss) - expected-operand-types - typechecks?)) - stack-popping-code - singular-context-check)))]))) + [else + ;; Otherwise, we can split the operands into two categories: constants, and the rest. + (let*-values ([(constant-operands rest-operands) + (split-operands-by-constants + (App-operands exp))] + + ;; here, we rewrite the stack references so they assume no scratch space + ;; used by the constant operands. + [(extended-cenv constant-operands rest-operands) + (values (extend-compile-time-environment/scratch-space + cenv + (length rest-operands)) + + (map (lambda: ([constant-operand : Expression]) + (ensure-simple-expression + (adjust-expression-depth constant-operand + (length constant-operands) + n))) + constant-operands) + + (map (lambda: ([rest-operand : Expression]) + (adjust-expression-depth rest-operand + (length constant-operands) + n)) + rest-operands))] + + [(operand-knowledge) + (append (map (lambda: ([arg : Expression]) + (extract-static-knowledge arg extended-cenv)) + constant-operands) + (map (lambda: ([arg : Expression]) + (extract-static-knowledge arg extended-cenv)) + rest-operands))] + + [(typechecks?) + (map (lambda: ([dom : OperandDomain] + [known : CompileTimeEnvironmentEntry]) + (not (redundant-check? dom known))) + expected-operand-types + operand-knowledge)] + + [(stack-pushing-code) + (make-PushEnvironment (length rest-operands) + #f)] + [(stack-popping-code) + (make-PopEnvironment (make-Const (length rest-operands)) + (make-Const 0))] + + [(constant-operand-poss) + (simple-operands->opargs constant-operands)] + + [(rest-operand-poss) + (build-list (length rest-operands) + (lambda: ([i : Natural]) + (make-EnvLexicalReference i #f)))] + [(rest-operand-code) + (apply append-instruction-sequences + (map (lambda: ([operand : Expression] + [target : Target]) + (compile operand + extended-cenv + target + next-linkage/expects-single)) + rest-operands + rest-operand-poss))]) + + (end-with-linkage + linkage cenv + (append-instruction-sequences + stack-pushing-code + rest-operand-code + (make-AssignPrimOpStatement (adjust-target-depth target (length rest-operands)) + (make-CallKernelPrimitiveProcedure + kernel-op + (append constant-operand-poss rest-operand-poss) + expected-operand-types + typechecks?)) + stack-popping-code + singular-context-check)))])]))) diff --git a/compiler/il-structs.rkt b/compiler/il-structs.rkt index 1cb2bfa..5af500f 100644 --- a/compiler/il-structs.rkt +++ b/compiler/il-structs.rkt @@ -3,7 +3,8 @@ (require "expression-structs.rkt" "lexical-structs.rkt" - "kernel-primitives.rkt") + "kernel-primitives.rkt" + "arity-structs.rkt") @@ -493,24 +494,4 @@ - - - - - - - - - -;; Arity -(define-type Arity (U AtomicArity (Listof (U AtomicArity)))) -(define-type AtomicArity (U Natural ArityAtLeast)) -(define-struct: ArityAtLeast ([value : Natural]) - #:transparent) -(define-predicate AtomicArity? AtomicArity) -(define-predicate listof-atomic-arity? (Listof AtomicArity)) - - - - (define-predicate OpArg? OpArg) \ No newline at end of file diff --git a/compiler/kernel-primitives.rkt b/compiler/kernel-primitives.rkt index 14fdf76..32be395 100644 --- a/compiler/kernel-primitives.rkt +++ b/compiler/kernel-primitives.rkt @@ -2,7 +2,7 @@ (provide (all-defined-out)) - +(require "arity-structs.rkt") (define-type OperandDomain (U 'number 'string 'box @@ -30,6 +30,7 @@ 'cadr 'caddr 'list + 'list? 'list* 'list->vector 'vector->list @@ -88,6 +89,8 @@ 'car 'cdr 'list + 'list? + 'pair? 'null? 'not 'eq?)) @@ -95,9 +98,11 @@ (define-predicate KernelPrimitiveName/Inline? KernelPrimitiveName/Inline) +(define-struct: IncorrectArity ([expected : Arity])) -(: kernel-primitive-expected-operand-types (KernelPrimitiveName/Inline Natural -> (Listof OperandDomain))) +(: kernel-primitive-expected-operand-types (KernelPrimitiveName/Inline Natural -> (U (Listof OperandDomain) + IncorrectArity))) ;; Given a primitive and the number of arguments, produces the list of expected domains. ;; TODO: do something more polymorphic. (define (kernel-primitive-expected-operand-types prim arity) @@ -106,72 +111,85 @@ (build-list arity (lambda (i) 'number))] [(eq? prim '-) - (unless (> arity 0) - (error '- "expects at least one argument, given ~a" arity)) - (build-list arity (lambda (i) 'number))] + (cond [(> arity 0) + (build-list arity (lambda (i) 'number))] + [else + (make-IncorrectArity (make-ArityAtLeast 1))])] [(eq? prim '*) (build-list arity (lambda (i) 'number))] [(eq? prim '/) - (unless (> arity 0) - (error '/ "expects at least one argument, given ~a" arity)) - (build-list arity (lambda (i) 'number))] + (cond [(> arity 0) + (build-list arity (lambda (i) 'number))] + [else + (make-IncorrectArity (make-ArityAtLeast 1))])] [(eq? prim 'add1) - (unless (= arity 1) - (error 'add1 "expects exactly one argument, given ~a" arity)) - (list 'number)] + (cond [(= arity 1) + (list 'number)] + [else + (make-IncorrectArity (make-ArityAtLeast 1))])] [(eq? prim 'sub1) - (unless (= arity 1) - (error 'sub1 "expects exactly one argument, given ~a" arity)) - (list 'number)] - + (cond [(= arity 1) + (list 'number)] + [else + (make-IncorrectArity (make-ArityAtLeast 1))])] + [(eq? prim '<) - (build-list arity (lambda (i) 'number))] + (cond [(>= arity 2) + (build-list arity (lambda (i) 'number))] + [else + (make-IncorrectArity (make-ArityAtLeast 2))])] [(eq? prim '<=) - (build-list arity (lambda (i) 'number))] + (cond [(>= arity 2) + (build-list arity (lambda (i) 'number))] + [else + (make-IncorrectArity (make-ArityAtLeast 2))])] [(eq? prim '=) - (build-list arity (lambda (i) 'number))] + (cond [(>= arity 2) + (build-list arity (lambda (i) 'number))] + [else + (make-IncorrectArity (make-ArityAtLeast 2))])] [(eq? prim '>) - (build-list arity (lambda (i) 'number))] + (cond [(>= arity 2) + (build-list arity (lambda (i) 'number))] + [else + (make-IncorrectArity (make-ArityAtLeast 2))])] [(eq? prim '>=) - (build-list arity (lambda (i) 'number))] + (cond [(>= arity 2) + (build-list arity (lambda (i) 'number))] + [else + (make-IncorrectArity (make-ArityAtLeast 2))])] [(eq? prim 'cons) - (unless (= arity 2) - (error 'cons "expects exactly two arguments, given ~a" arity)) (list 'any 'any)] [(eq? prim 'car) - (unless (= arity 1) - (error 'car "expects exactly one argument, given ~a" arity)) (list 'pair)] [(eq? prim 'cdr) - (unless (= arity 1) - (error 'cdr "expects exactly one argument, given ~a" arity)) (list 'pair)] [(eq? prim 'list) (build-list arity (lambda (i) 'any))] - + + [(eq? prim 'list?) + (list 'any)] + + [(eq? prim 'pair?) + (list 'any)] + [(eq? prim 'null?) - (unless (= arity 1) - (error 'null? "expects exactly one argument, given ~a" arity)) (list 'any)] [(eq? prim 'not) - (unless (= arity 1) - (error 'not "expects exactly one argument, given ~a" arity)) (list 'any)] [(eq? prim 'eq?) - (unless (= arity 2) - (error 'eq? "expects exactly two arguments, given ~a" arity)) (list 'any 'any)])) \ No newline at end of file diff --git a/js-assembler/assemble-helpers.rkt b/js-assembler/assemble-helpers.rkt index 23697ca..5d89403 100644 --- a/js-assembler/assemble-helpers.rkt +++ b/js-assembler/assemble-helpers.rkt @@ -3,6 +3,7 @@ (require "../compiler/il-structs.rkt" "../compiler/expression-structs.rkt" "../compiler/lexical-structs.rkt" + "../compiler/arity-structs.rkt" racket/list racket/string) diff --git a/js-assembler/assemble-open-coded.rkt b/js-assembler/assemble-open-coded.rkt index 390a54b..42deda7 100644 --- a/js-assembler/assemble-open-coded.rkt +++ b/js-assembler/assemble-open-coded.rkt @@ -83,6 +83,14 @@ [(list) (let loop ([checked-operands checked-operands]) (assemble-listof-assembled-values checked-operands))] + + [(list?) + (format "RUNTIME.isList(~a)" + (first checked-operands))] + + [(pair?) + (format "RUNTIME.isPair(~a)" + (first checked-operands))] [(null?) (format "(~a === RUNTIME.NULL)" (first checked-operands))] diff --git a/simulator/simulator-primitives.rkt b/simulator/simulator-primitives.rkt index a674e86..547485b 100644 --- a/simulator/simulator-primitives.rkt +++ b/simulator/simulator-primitives.rkt @@ -2,6 +2,7 @@ (require "simulator-structs.rkt" "simulator-helpers.rkt" "../compiler/il-structs.rkt" + "../compiler/arity-structs.rkt" racket/math racket/list (for-syntax racket/base)) diff --git a/simulator/simulator-structs.rkt b/simulator/simulator-structs.rkt index bd615c0..752e9fc 100644 --- a/simulator/simulator-structs.rkt +++ b/simulator/simulator-structs.rkt @@ -2,7 +2,8 @@ (provide (all-defined-out)) -(require "../compiler/il-structs.rkt" +(require "../compiler/arity-structs.rkt" + "../compiler/il-structs.rkt" "../compiler/expression-structs.rkt" "../compiler/lexical-structs.rkt") diff --git a/simulator/simulator.rkt b/simulator/simulator.rkt index 40e5bf0..bd475c5 100644 --- a/simulator/simulator.rkt +++ b/simulator/simulator.rkt @@ -9,6 +9,7 @@ "../compiler/expression-structs.rkt" "../compiler/il-structs.rkt" "../compiler/lexical-structs.rkt" + "../compiler/arity-structs.rkt" "../compiler/bootstrapped-primitives.rkt" "../compiler/kernel-primitives.rkt" racket/list diff --git a/tests/test-assemble.rkt b/tests/test-assemble.rkt index 6ec2026..a9551ed 100644 --- a/tests/test-assemble.rkt +++ b/tests/test-assemble.rkt @@ -5,6 +5,7 @@ "../js-assembler/package.rkt" "../compiler/lexical-structs.rkt" "../compiler/il-structs.rkt" + "../compiler/arity-structs.rkt" racket/port racket/promise racket/runtime-path) diff --git a/tests/test-simulator.rkt b/tests/test-simulator.rkt index 1f51bd4..4f33c08 100644 --- a/tests/test-simulator.rkt +++ b/tests/test-simulator.rkt @@ -2,6 +2,7 @@ (require "../compiler/il-structs.rkt" "../compiler/lexical-structs.rkt" + "../compiler/arity-structs.rkt" "../simulator/simulator-structs.rkt" "../simulator/simulator-primitives.rkt" "../simulator/simulator.rkt")