suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fixing compile-time error on using kernel primitives: turned into runtime errors as appropriate

Browse Source
This commit is contained in:
Danny Yoo 2011-08-19 18:24:18 -04:00
parent 304a951490
commit f1ed02095c
13 changed files with 241 additions and 182 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
compiler/analyzer-structs.rkt
View File

@ -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")

12
compiler/arity-structs.rkt Normal file
View File

@ -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))

3
compiler/bootstrapped-primitives.rkt
View File

@ -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"

282
compiler/compiler.rkt
View File

@ -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)))])])))

23
compiler/il-structs.rkt
View File

@ -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)

84
compiler/kernel-primitives.rkt
View File

@ -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)]))

1
js-assembler/assemble-helpers.rkt
View File

@ -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)

8
js-assembler/assemble-open-coded.rkt
View File

@ -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))]

1
simulator/simulator-primitives.rkt
View File

@ -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))

3
simulator/simulator-structs.rkt
View File

@ -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")

1
simulator/simulator.rkt
View File

@ -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

1
tests/test-assemble.rkt
View File

@ -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)

1
tests/test-simulator.rkt
View File

@ -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")