From 59bde2bf1829e5722f39bc53d38b02c9c8a1e3d7 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Tue, 29 Mar 2011 20:57:37 -0400 Subject: [PATCH] trying to move the type analysis over to compile time rather than assemble time --- assemble-open-coded.rkt | 6 +-- compile.rkt | 36 +++++++++++-- il-structs.rkt | 31 +++-------- kernel-primitives.rkt | 115 ++++++++++++++++++++++++++++++++++++++++ 4 files changed, 157 insertions(+), 31 deletions(-) create mode 100644 kernel-primitives.rkt diff --git a/assemble-open-coded.rkt b/assemble-open-coded.rkt index 1036fdc..9258181 100644 --- a/assemble-open-coded.rkt +++ b/assemble-open-coded.rkt @@ -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)) diff --git a/compile.rkt b/compile.rkt index 10c2a0d..0f919a4 100644 --- a/compile.rkt +++ b/compile.rkt @@ -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. diff --git a/il-structs.rkt b/il-structs.rkt index 66011a4..4721d5c 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -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) diff --git a/kernel-primitives.rkt b/kernel-primitives.rkt new file mode 100644 index 0000000..c30cef0 --- /dev/null +++ b/kernel-primitives.rkt @@ -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)])) \ No newline at end of file