adding type checks

This commit is contained in:
Danny Yoo 2011-03-29 18:18:21 -04:00
parent df958aa6ec
commit a3f323a687
6 changed files with 432 additions and 249 deletions

123
assemble-helpers.rkt Normal file
View File

@ -0,0 +1,123 @@
#lang typed/racket/base
(require "il-structs.rkt"
"lexical-structs.rkt"
racket/list)
(provide assemble-oparg
assemble-target
assemble-const
assemble-lexical-reference
assemble-prefix-reference
assemble-whole-prefix-reference
assemble-reg
assemble-label
assemble-input)
(: assemble-oparg (OpArg -> String))
(define (assemble-oparg v)
(cond
[(Reg? v)
(assemble-reg v)]
[(Label? v)
(assemble-label v)]
[(Const? v)
(assemble-const v)]
[(EnvLexicalReference? v)
(assemble-lexical-reference v)]
[(EnvPrefixReference? v)
(assemble-prefix-reference v)]
[(EnvWholePrefixReference? v)
(assemble-whole-prefix-reference v)]))
(: assemble-target (Target -> String))
(define (assemble-target target)
(cond
[(eq? target 'proc)
"MACHINE.proc"]
[(eq? target 'val)
"MACHINE.val"]
[(EnvLexicalReference? target)
(assemble-lexical-reference target)]
[(EnvPrefixReference? target)
(assemble-prefix-reference target)]
[(PrimitivesReference? target)
(format "Primitives[~s]" (symbol->string (PrimitivesReference-name target)))]))
;; fixme: use js->string
(: assemble-const (Const -> String))
(define (assemble-const stmt)
(let: loop : String ([val : Any (Const-const stmt)])
(cond [(symbol? val)
(format "~s" (symbol->string val))]
[(pair? val)
(format "[~a, ~a]"
(loop (car val))
(loop (cdr val)))]
[(boolean? val)
(if val "true" "false")]
[(void? val)
"null"]
[(empty? val)
(format "Primitives.null")]
[(number? val)
(format "(~s)" val)]
[else
(format "~s" val)])))
(: assemble-lexical-reference (EnvLexicalReference -> String))
(define (assemble-lexical-reference a-lex-ref)
(if (EnvLexicalReference-unbox? a-lex-ref)
(format "MACHINE.env[MACHINE.env.length - 1 - ~a][0]"
(EnvLexicalReference-depth a-lex-ref))
(format "MACHINE.env[MACHINE.env.length - 1 - ~a]"
(EnvLexicalReference-depth a-lex-ref))))
(: assemble-prefix-reference (EnvPrefixReference -> String))
(define (assemble-prefix-reference a-ref)
(format "MACHINE.env[MACHINE.env.length - 1 - ~a][~a]"
(EnvPrefixReference-depth a-ref)
(EnvPrefixReference-pos a-ref)))
(: assemble-whole-prefix-reference (EnvWholePrefixReference -> String))
(define (assemble-whole-prefix-reference a-prefix-ref)
(format "MACHINE.env[MACHINE.env.length - 1 - ~a]"
(EnvWholePrefixReference-depth a-prefix-ref)))
(: assemble-reg (Reg -> String))
(define (assemble-reg a-reg)
(string-append "MACHINE." (symbol->string (Reg-name a-reg))))
(: assemble-label (Label -> String))
(define (assemble-label a-label)
(symbol->string (Label-name a-label)))
(: assemble-input (OpArg -> String))
(define (assemble-input an-input)
(cond
[(Reg? an-input)
(assemble-reg an-input)]
[(Const? an-input)
(assemble-const an-input)]
[(Label? an-input)
(assemble-label an-input)]
[(EnvLexicalReference? an-input)
(assemble-lexical-reference an-input)]
[(EnvPrefixReference? an-input)
(assemble-prefix-reference an-input)]
[(EnvWholePrefixReference? an-input)
(assemble-whole-prefix-reference an-input)]))

225
assemble-open-coded.rkt Normal file
View File

@ -0,0 +1,225 @@
#lang typed/racket/base
(require "il-structs.rkt"
"lexical-structs.rkt"
"assemble-helpers.rkt"
racket/string
racket/list)
(provide open-code-kernel-primitive-procedure)
(: open-code-kernel-primitive-procedure (CallKernelPrimitiveProcedure -> String))
(define (open-code-kernel-primitive-procedure op)
(let: ([operator : KernelPrimitiveName (CallKernelPrimitiveProcedure-operator op)]
[rand-knowledge : (Listof CompileTimeEnvironmentEntry)
(CallKernelPrimitiveProcedure-operands-knowledge op)]
[rand-vals : (Listof String) (map assemble-input (CallKernelPrimitiveProcedure-operands op))])
(case operator
[(+)
(let ([checked-rands (maybe-typecheck-operands (repeat 'number (length rand-vals))
rand-vals
rand-knowledge)])
(cond [(empty? rand-vals)
"0"]
[else
(string-append "(" (string-join checked-rands " + ") ")")]))]
[(-)
(let ([checked-rands (maybe-typecheck-operands (repeat 'number (length rand-vals))
rand-vals
rand-knowledge)])
(cond [(empty? rand-vals)
(error '- "Expects at least 1 argument, given 0")]
[(empty? (rest rand-vals))
(format "(-(~a))" (first rand-vals))]
[else
(string-append "(" (string-join checked-rands "-") ")")]))]
[(*)
(let ([checked-rands (maybe-typecheck-operands (repeat 'number (length rand-vals))
rand-vals
rand-knowledge)])
(cond [(empty? rand-vals)
"1"]
[else
(string-append "(" (string-join checked-rands "*") ")")]))]
[(/)
(let ([checked-rands (maybe-typecheck-operands (repeat 'number (length rand-vals))
rand-vals
rand-knowledge)])
(cond [(empty? rand-vals)
(error '/ "Expects at least 1 argument, given 0")]
[else
(string-append "(" (string-join checked-rands "/") ")")]))]
[(add1)
(unless (= 1 (length rand-vals))
(error 'add1 "Expected one argument"))
(format "(~a + 1)"
(maybe-typecheck-operand 'number 0 (first rand-vals) (first rand-knowledge)))]
[(sub1)
(unless (= 1 (length rand-vals))
(error 'sub1 "Expected one argument"))
(format "(~a - 1)"
(maybe-typecheck-operand 'number 0 (first rand-vals) (first rand-knowledge)))]
[(<)
(unless (> (length rand-vals) 0)
(error '< "Expected at least one argument"))
(assemble-chain "<" (maybe-typecheck-operands (repeat 'number (length rand-vals))
rand-vals
rand-knowledge))]
[(<=)
(unless (> (length rand-vals) 0)
(error '<= "Expected at least one argument"))
(assemble-chain "<=" (maybe-typecheck-operands (repeat 'number (length rand-vals))
rand-vals
rand-knowledge))]
[(=)
(unless (> (length rand-vals) 0)
(error '= "Expected at least one argument"))
(assemble-chain "==" (maybe-typecheck-operands (repeat 'number (length rand-vals))
rand-vals
rand-knowledge))]
[(>)
(unless (> (length rand-vals) 0)
(error '> "Expected at least one argument"))
(assemble-chain ">" (maybe-typecheck-operands (repeat 'number (length rand-vals))
rand-vals
rand-knowledge))]
[(>=)
(unless (> (length rand-vals) 0)
(error '>= "Expected at least one argument"))
(assemble-chain ">=" (maybe-typecheck-operands (repeat 'number (length rand-vals))
rand-vals
rand-knowledge))]
[(cons)
(unless (= (length rand-vals) 2)
(error 'cons "Expected two arguments"))
(format "[~a, ~a]" (first rand-vals) (second rand-vals))]
[(car)
(unless (= (length rand-vals) 1)
(error 'car "Expected one argument"))
(format "(~a)[0]" (maybe-typecheck-operand 'pair 0 (first rand-vals)
(first rand-knowledge)))]
[(cdr)
(unless (= (length rand-vals) 1)
(error 'cdr "Expected one argument"))
(format "(~a)[1]" (maybe-typecheck-operand 'pair 0 (first rand-vals)
(first rand-knowledge)))]
[(list)
(let loop ([rand-vals rand-vals])
(cond
[(empty? rand-vals)
"Primitives.null"]
[else
(format "[~a,~a]" (first rand-vals) (loop (rest rand-vals)))]))]
[(null?)
(unless (= (length rand-vals) 1)
(error 'null? "Expected one argument"))
(format "(~a === Primitives.null)"
(first rand-vals))]
[(not)
(unless (= (length rand-vals) 1)
(error 'not? "Expected one argument"))
(format "(!~a)" (first rand-vals))]
[(eq?)
(unless (= (length rand-vals) 2)
(error 'eq? "Expected 2 arguments"))
(format "(~a === ~a)" (first rand-vals) (second rand-vals))])))
(: assemble-chain (String (Listof String) -> String))
(define (assemble-chain rator rands)
(string-append "("
(string-join (let: loop : (Listof String) ([rands : (Listof String) rands])
(cond
[(empty? rands)
'()]
[(empty? (rest rands))
'()]
[else
(cons (format "(~a ~a ~a)" (first rands) rator (second rands))
(loop (rest rands)))]))
"&&")
")"))
(define-type OperandDomain (U 'number
'string
'box
'list
'pair))
(: assemble-domain-check (OperandDomain String Natural -> String))
(define (assemble-domain-check domain operand-string pos)
(let ([test-string
(case domain
[(number)
(format "typeof(~a) === 'number'"
operand-string)]
[(string)
(format "typeof(~a) === 'string'"
operand-string)]
[(list)
(format "(~a === [] || (typeof(~a) === 'object' && (~a).length === 2))"
operand-string operand-string operand-string)]
[(pair)
(format "(typeof(~a) === 'object' && (~a).length === 2)"
operand-string operand-string)])])
(format "(~a ? ~a : raise(new Error('Expected ' + ~a + ' as argument ' + ~s + ' but received ' + ~a)))"
test-string
operand-string
domain
pos
operand-string)))
(: maybe-typecheck-operands ((Listof OperandDomain)
(Listof String)
(Listof CompileTimeEnvironmentEntry) -> (Listof String)))
(define (maybe-typecheck-operands expected-domains rand-vals rand-knowledge)
(map (lambda: ([rand : String]
[expected-domain : OperandDomain]
[knowledge : CompileTimeEnvironmentEntry]
[position : Natural])
(maybe-typecheck-operand expected-domain position rand knowledge))
rand-vals
expected-domains
rand-knowledge
(build-list (length rand-vals)
(lambda: ([i : Natural]) i))))
(: maybe-typecheck-operand (OperandDomain Natural String CompileTimeEnvironmentEntry -> String))
(define (maybe-typecheck-operand domain-type position operand-string knowledge)
(cond
[(redundant-check? domain-type knowledge)
operand-string]
[else
(assemble-domain-check domain-type operand-string position)]))
(: redundant-check? (OperandDomain CompileTimeEnvironmentEntry -> Boolean))
(define (redundant-check? domain-type knowledge)
#f)
(: repeat (All (A) (A Natural -> (Listof A))))
(define (repeat x n)
(build-list n (lambda (i) x)))

View File

@ -2,6 +2,8 @@
(require "il-structs.rkt"
"lexical-structs.rkt"
"helpers.rkt"
"assemble-helpers.rkt"
"assemble-open-coded.rkt"
racket/string
racket/list)
@ -218,21 +220,7 @@ EOF
(string-join (map assemble-statement (BasicBlock-stmts a-basic-block))
"\n")))
(: assemble-oparg (OpArg -> String))
(define (assemble-oparg v)
(cond
[(Reg? v)
(assemble-reg v)]
[(Label? v)
(assemble-label v)]
[(Const? v)
(assemble-const v)]
[(EnvLexicalReference? v)
(assemble-lexical-reference v)]
[(EnvPrefixReference? v)
(assemble-prefix-reference v)]
[(EnvWholePrefixReference? v)
(assemble-whole-prefix-reference v)]))
(: assemble-statement (UnlabeledStatement -> String))
@ -300,64 +288,10 @@ EOF
(: assemble-target (Target -> String))
(define (assemble-target target)
(cond
[(eq? target 'proc)
"MACHINE.proc"]
[(eq? target 'val)
"MACHINE.val"]
[(EnvLexicalReference? target)
(assemble-lexical-reference target)]
[(EnvPrefixReference? target)
(assemble-prefix-reference target)]
[(PrimitivesReference? target)
(format "Primitives[~s]" (symbol->string (PrimitivesReference-name target)))]))
;; fixme: use js->string
(: assemble-const (Const -> String))
(define (assemble-const stmt)
(let: loop : String ([val : Any (Const-const stmt)])
(cond [(symbol? val)
(format "~s" (symbol->string val))]
[(pair? val)
(format "[~a, ~a]"
(loop (car val))
(loop (cdr val)))]
[(boolean? val)
(if val "true" "false")]
[(void? val)
"null"]
[(empty? val)
(format "Primitives.null")]
[(number? val)
(format "(~s)" val)]
[else
(format "~s" val)])))
(: assemble-lexical-reference (EnvLexicalReference -> String))
(define (assemble-lexical-reference a-lex-ref)
(if (EnvLexicalReference-unbox? a-lex-ref)
(format "MACHINE.env[MACHINE.env.length - 1 - ~a][0]"
(EnvLexicalReference-depth a-lex-ref))
(format "MACHINE.env[MACHINE.env.length - 1 - ~a]"
(EnvLexicalReference-depth a-lex-ref))))
(: assemble-prefix-reference (EnvPrefixReference -> String))
(define (assemble-prefix-reference a-ref)
(format "MACHINE.env[MACHINE.env.length - 1 - ~a][~a]"
(EnvPrefixReference-depth a-ref)
(EnvPrefixReference-pos a-ref)))
(: assemble-whole-prefix-reference (EnvWholePrefixReference -> String))
(define (assemble-whole-prefix-reference a-prefix-ref)
(format "MACHINE.env[MACHINE.env.length - 1 - ~a]"
(EnvWholePrefixReference-depth a-prefix-ref)))
(: assemble-env-reference/closure-capture (Natural -> String))
;; When we're capturing the values for a closure, we need to not unbox
@ -423,112 +357,6 @@ EOF
;; FIXME: this needs to check that the domains are good!
(: open-code-kernel-primitive-procedure (CallKernelPrimitiveProcedure -> String))
(define (open-code-kernel-primitive-procedure op)
(let: ([operator : KernelPrimitiveName (CallKernelPrimitiveProcedure-operator op)]
[rand-vals : (Listof String) (map assemble-input (CallKernelPrimitiveProcedure-operands op))])
(case operator
[(+)
(cond [(empty? rand-vals)
"0"]
[else
(string-append "("
(string-join rand-vals " + ")
")")])]
[(-)
(cond [(empty? rand-vals)
(error '- "Expects at least 1 argument, given 0")]
[(empty? (rest rand-vals))
(format "(-(~a))" (first rand-vals))]
[else
(string-append "(" (string-join rand-vals "-") ")")])]
[(*)
(cond [(empty? rand-vals)
"1"]
[else
(string-append "(" (string-join rand-vals "*") ")")])]
[(/)
(cond [(empty? rand-vals)
(error '/ "Expects at least 1 argument, given 0")]
[else
(string-append "(" (string-join rand-vals "/") ")")])]
[(add1)
(unless (= 1 (length rand-vals))
(error 'add1 "Expected one argument"))
(format "(~a + 1)" (first rand-vals))]
[(sub1)
(unless (= 1 (length rand-vals))
(error 'sub1 "Expected one argument"))
(format "(~a - 1)" (first rand-vals))]
[(<)
(unless (> (length rand-vals) 0)
(error '< "Expected at least one argument"))
(assemble-chain "<" rand-vals)]
[(<=)
(unless (> (length rand-vals) 0)
(error '<= "Expected at least one argument"))
(assemble-chain "<=" rand-vals)]
[(=)
(unless (> (length rand-vals) 0)
(error '= "Expected at least one argument"))
(assemble-chain "==" rand-vals)]
[(>)
(unless (> (length rand-vals) 0)
(error '> "Expected at least one argument"))
(assemble-chain ">" rand-vals)]
[(>=)
(unless (> (length rand-vals) 0)
(error '>= "Expected at least one argument"))
(assemble-chain ">=" rand-vals)]
[(cons)
(unless (= (length rand-vals) 2)
(error 'cons "Expected two arguments"))
(format "[~a, ~a]" (first rand-vals) (second rand-vals))]
[(car)
(unless (= (length rand-vals) 1)
(error 'car "Expected one argument"))
(format "(~a)[0]" (first rand-vals))]
[(cdr)
(unless (= (length rand-vals) 1)
(error 'cdr "Expected one argument"))
(format "(~a)[1]" (first rand-vals))]
[(list)
(let loop ([rand-vals rand-vals])
(cond
[(empty? rand-vals)
"Primitives.null"]
[else
(format "[~a,~a]" (first rand-vals) (loop (rest rand-vals)))]))]
[(null?)
(unless (= (length rand-vals) 1)
(error 'null? "Expected one argument"))
(format "(~a === Primitives.null)"
(first rand-vals))]
[(not)
(unless (= (length rand-vals) 1)
(error 'not? "Expected one argument"))
(format "(!~a)" (first rand-vals))]
[(eq?)
(unless (= (length rand-vals) 2)
(error 'eq? "Expected 2 arguments"))
(format "(~a === ~a)" (first rand-vals) (second rand-vals))])))
(: assemble-chain (String (Listof String) -> String))
(define (assemble-chain rator rands)
(string-append "("
(string-join (let: loop : (Listof String) ([rands : (Listof String) rands])
(cond
[(empty? rands)
'()]
[(empty? (rest rands))
'()]
[else
(cons (format "(~a ~a ~a)" (first rands) rator (second rands))
(loop (rest rands)))]))
"&&")
")"))
@ -591,21 +419,6 @@ EOF
", "))]))
(: assemble-input (OpArg -> String))
(define (assemble-input an-input)
(cond
[(Reg? an-input)
(assemble-reg an-input)]
[(Const? an-input)
(assemble-const an-input)]
[(Label? an-input)
(assemble-label an-input)]
[(EnvLexicalReference? an-input)
(assemble-lexical-reference an-input)]
[(EnvPrefixReference? an-input)
(assemble-prefix-reference an-input)]
[(EnvWholePrefixReference? an-input)
(assemble-whole-prefix-reference an-input)]))
(: assemble-location ((U Reg Label) -> String))
(define (assemble-location a-location)
@ -615,10 +428,4 @@ EOF
[(Label? a-location)
(assemble-label a-location)]))
(: assemble-reg (Reg -> String))
(define (assemble-reg a-reg)
(string-append "MACHINE." (symbol->string (Reg-name a-reg))))
(: assemble-label (Label -> String))
(define (assemble-label a-label)
(symbol->string (Label-name a-label)))

View File

@ -13,19 +13,6 @@
;; We try to keep at compile time a mapping from environment positions to
;; statically known things, to generate better code.
(define-struct: StaticallyKnownLam ([name : (U Symbol False)]
[entry-point : Symbol]
[arity : Natural]) #:transparent)
(define-type CompileTimeEnvironmentEntry
(U '? Prefix StaticallyKnownLam ModuleVariable))
(define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry))
(: -compile (ExpressionCore Target Linkage -> (Listof Statement)))
@ -450,17 +437,11 @@
;; of hardcoded primitives.
(define (compile-kernel-primitive-application kernel-op exp cenv extended-cenv target linkage)
(let* ([n (length (App-operands exp))]
[operand-poss
(build-list (length (App-operands exp))
(lambda: ([i : Natural])
(make-EnvLexicalReference i #f)))]
[operand-codes (map (lambda: ([operand : Expression]
[target : Target])
(compile operand extended-cenv target next-linkage))
(App-operands exp)
operand-poss)])
[operand-knowledge (map (lambda: ([arg : ExpressionCore])
(extract-static-knowledge arg extended-cenv))
(App-operands exp))])
(cond
;; Special case optimization: we can avoid pushing the stack altogether
;; Special case optimization: we can avoid touching the stack altogether
[(all-operands-are-constant-or-stack-references (App-operands exp))
=> (lambda (opargs)
(end-with-linkage
@ -468,31 +449,43 @@
(make-instruction-sequence
`(,(make-AssignPrimOpStatement
target
(make-CallKernelPrimitiveProcedure kernel-op (map (lambda: ([arg : OpArg])
(adjust-oparg-depth arg (- n)))
opargs)))))))]
(make-CallKernelPrimitiveProcedure kernel-op
(map (lambda: ([arg : OpArg])
(adjust-oparg-depth arg (- n)))
opargs)
operand-knowledge))))))]
[else
(end-with-linkage
linkage cenv
(append-instruction-sequences
(if (not (empty? (App-operands exp)))
(make-instruction-sequence `(,(make-PushEnvironment (length (App-operands exp)) #f)))
empty-instruction-sequence)
(apply append-instruction-sequences operand-codes)
(make-instruction-sequence
`(,(make-AssignPrimOpStatement
;; Optimization: we put the result directly in the registers, or in
;; the appropriate spot on the stack. This takes into account the popenviroment
;; that happens right afterwards.
(adjust-target-depth target n)
(make-CallKernelPrimitiveProcedure kernel-op operand-poss))))
(if (> n 0)
(make-instruction-sequence `(,(make-PopEnvironment n 0)))
empty-instruction-sequence)))])))
(let* ([operand-poss
(build-list (length (App-operands exp))
(lambda: ([i : Natural])
(make-EnvLexicalReference i #f)))]
[operand-codes (map (lambda: ([operand : Expression]
[target : Target])
(compile operand extended-cenv target next-linkage))
(App-operands exp)
operand-poss)])
(end-with-linkage
linkage cenv
(append-instruction-sequences
(if (not (empty? (App-operands exp)))
(make-instruction-sequence `(,(make-PushEnvironment (length (App-operands exp)) #f)))
empty-instruction-sequence)
(apply append-instruction-sequences operand-codes)
(make-instruction-sequence
`(,(make-AssignPrimOpStatement
;; Optimization: we put the result directly in the registers, or in
;; the appropriate spot on the stack. This takes into account the popenviroment
;; that happens right afterwards.
(adjust-target-depth target n)
(make-CallKernelPrimitiveProcedure kernel-op
operand-poss
operand-knowledge))))
(if (> n 0)
(make-instruction-sequence `(,(make-PopEnvironment n 0)))
empty-instruction-sequence))))])))

View File

@ -181,7 +181,8 @@
(define-struct: CallKernelPrimitiveProcedure ([operator : KernelPrimitiveName]
[operands : (Listof OpArg)])
[operands : (Listof OpArg)]
[operands-knowledge : (Listof CompileTimeEnvironmentEntry)])
#:transparent)
@ -304,6 +305,34 @@
;; Static knowledge about a value
;; We try to keep at compile time a mapping from environment positions to
;; statically known things, to generate better code.
(define-struct: StaticallyKnownLam ([name : (U Symbol False)]
[entry-point : Symbol]
[arity : Natural]) #:transparent)
(define-type CompileTimeEnvironmentEntry
(U '? ;; no knowledge
Prefix ;; placeholder: necessary since the toplevel lives in the environment too
StaticallyKnownLam ;; The value is a known lam
ModuleVariable ;; The value is a known module variable
))
(define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Assembly

View File

@ -27,6 +27,8 @@ var Closure = function(label, arity, closedVals, displayName) {
this.displayName = displayName;
};
// A primitive function is just a Javascript function.
@ -42,14 +44,18 @@ var testArgument = function(expectedTypeName,
if (predicate(val)) {
return true;
}
throw new Error(callerName + ": expected " + expectedTypeName
+ " as argument #" + position
+ " but received " + val + " instead");
else {
raise(new Error(callerName + ": expected " + expectedTypeName
+ " as argument #" + position
+ " but received " + val + " instead"));
}
};
var isNumber = function(x) { return typeof(x) === 'number'; };
var raise = function(e) { throw e; }
var Primitives = (function() {
var NULL = [];
@ -144,7 +150,7 @@ var Primitives = (function() {
},
'-': function(MACHINE, arity) {
if (arity === 0) { throw new Error(); }
if (arity === 0) { raise(new Error()); }
if (arity === 1) {
testArgument('number',
isNumber,
@ -166,7 +172,7 @@ var Primitives = (function() {
},
'/': function(MACHINE, arity) {
if (arity === 0) { throw new Error(); }
if (arity === 0) { raise(new Error();) }
testArgument('number',
isNumber,
MACHINE.env[MACHINE.env.length - 1],