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

trying to move the type analysis over to compile time rather than assemble time

Browse Source
This commit is contained in:
Danny Yoo 2011-03-29 20:57:37 -04:00
parent 7cd6c998c2
commit 59bde2bf18
4 changed files with 157 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
assemble-open-coded.rkt
View File

@ -3,6 +3,7 @@
(require "il-structs.rkt"
"lexical-structs.rkt"
"assemble-helpers.rkt"
"kernel-primitives.rkt"
racket/string
racket/list)
@ -160,11 +161,6 @@
(define-type OperandDomain (U 'number
'string
'box
'list
'pair))
(: assemble-domain-check (OperandDomain String Natural -> String))

36
compile.rkt
View File

@ -3,6 +3,7 @@
(require "expression-structs.rkt"
"lexical-structs.rkt"
"il-structs.rkt"
"kernel-primitives.rkt"
racket/bool
racket/list)
@ -439,9 +440,15 @@
;; of hardcoded primitives.
(define (compile-kernel-primitive-application kernel-op exp cenv extended-cenv target linkage)
(let* ([n (length (App-operands exp))]
[expected-operand-types (kernel-primitive-expected-operand-types kernel-op n)]
[operand-knowledge (map (lambda: ([arg : Expression])
(extract-static-knowledge arg extended-cenv))
(App-operands exp))])
(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)])
(cond
;; Special case optimization: we can avoid touching the stack altogether
[(all-operands-are-constant-or-stack-references (App-operands exp))
@ -455,7 +462,8 @@
(map (lambda: ([arg : OpArg])
(adjust-oparg-depth arg (- n)))
opargs)
operand-knowledge))))))]
expected-operand-types
typechecks?))))))]
[else
(let* ([operand-poss
(build-list (length (App-operands exp))
@ -484,12 +492,34 @@
(adjust-target-depth target n)
(make-CallKernelPrimitiveProcedure kernel-op
operand-poss
operand-knowledge))))
expected-operand-types
typechecks?))))
(if (> n 0)
(make-instruction-sequence `(,(make-PopEnvironment n 0)))
empty-instruction-sequence))))])))
(: redundant-check? (OperandDomain CompileTimeEnvironmentEntry -> Boolean))
;; Produces true if we know the knowledge implies the domain-type.
(define (redundant-check? domain-type knowledge)
(cond [(Const? knowledge)
(case domain-type
[(number)
(number? (Const-const knowledge))]
[(string)
(string? (Const-const knowledge))]
[(box)
(box? (Const-const knowledge))]
[(list)
(list? (Const-const knowledge))]
[(pair)
(pair? (Const-const knowledge))]
[(any)
#t])]
[else
#f]))
(: all-operands-are-constant-or-stack-references ((Listof Expression) -> (U False (Listof OpArg))))
;; Produces a list of OpArgs if all the operands are particularly simple, and false otherwise.

31
il-structs.rkt
View File

@ -1,7 +1,8 @@
#lang typed/racket/base
(provide (all-defined-out))
(require "lexical-structs.rkt")
(require "lexical-structs.rkt"
"kernel-primitives.rkt")
@ -157,32 +158,16 @@
;; The following are primitives that the compiler knows about:
(define-type KernelPrimitiveName (U '+
'-
'*
'/
'add1
'sub1
'<
'<=
'=
'>
'>=
'cons
'car
'cdr
'list
'null?
'not
'eq?
))
(define-predicate KernelPrimitiveName? KernelPrimitiveName)
(define-struct: CallKernelPrimitiveProcedure ([operator : KernelPrimitiveName]
[operands : (Listof OpArg)]
[operands-knowledge : (Listof CompileTimeEnvironmentEntry)])
[expected-operand-types : (Listof OperandDomain)]
;; For each operand, #t will add code to typecheck the operand
[typechecks? : (Listof Boolean)])
#:transparent)

115
kernel-primitives.rkt Normal file
View File

@ -0,0 +1,115 @@
#lang typed/racket/base
(provide (all-defined-out))
(define-type OperandDomain (U 'number
'string
'box
'list
'pair
'any))
;; The following are primitives that the compiler knows about:
(define-type KernelPrimitiveName (U '+
'-
'*
'/
'add1
'sub1
'<
'<=
'=
'>
'>=
'cons
'car
'cdr
'list
'null?
'not
'eq?
))
(define-predicate KernelPrimitiveName? KernelPrimitiveName)
(: kernel-primitive-expected-operand-types (KernelPrimitiveName Natural -> (Listof OperandDomain)))
;; 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)
(cond
[(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))]
[(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))]
[(eq? prim 'add1)
(unless (= arity 1)
(error 'add1 "expects exactly one argument, given ~a" arity))
(list 'number)]
[(eq? prim 'sub1)
(unless (= arity 1)
(error 'sub1 "expects exactly one argument, given ~a" arity))
(list 'number)]
[(eq? prim '<)
(build-list arity (lambda (i) 'number))]
[(eq? prim '<=)
(build-list arity (lambda (i) 'number))]
[(eq? prim '=)
(build-list arity (lambda (i) 'number))]
[(eq? prim '>)
(build-list arity (lambda (i) 'number))]
[(eq? prim '>=)
(build-list arity (lambda (i) 'number))]
[(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 '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)]))