From 39935eaee30200b25f4ac596a38acbf866a066ee Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Mon, 9 May 2011 18:17:15 -0400 Subject: [PATCH] adding kernel primitive as opargs. --- assemble-helpers.rkt | 7 +++++- collect-jump-targets.rkt | 7 ++++-- compiler.rkt | 31 ++++++++++++++++++++++--- expression-structs.rkt | 8 ++++++- il-structs.rkt | 3 ++- kernel-primitives.rkt | 22 ++++++++++++++++++ optimize-il.rkt | 7 ++++-- parse-bytecode-5.1.1.rkt | 43 ++++++++++++++++++++++++++++++++++- simulator.rkt | 8 +++++-- test-parse-bytecode-5.1.1.rkt | 39 +++++++++++++++++++++++++++---- 10 files changed, 158 insertions(+), 17 deletions(-) diff --git a/assemble-helpers.rkt b/assemble-helpers.rkt index c8b7cc7..73f9924 100644 --- a/assemble-helpers.rkt +++ b/assemble-helpers.rkt @@ -51,7 +51,9 @@ [(CompiledProcedureEntry? v) (assemble-compiled-procedure-entry v)] [(CompiledProcedureClosureReference? v) - (assemble-compiled-procedure-closure-reference v)])) + (assemble-compiled-procedure-closure-reference v)] + [(PrimitiveKernelValue? v) + (assemble-primitive-kernel-value v)])) @@ -260,3 +262,6 @@ (assemble-label a-location)])) +(: assemble-primitive-kernel-value (PrimitiveKernelValue -> String)) +(define (assemble-primitive-kernel-value a-prim) + (format "MACHINE.primitives[~s]" (symbol->string (PrimitiveKernelValue-id a-prim)))) \ No newline at end of file diff --git a/collect-jump-targets.rkt b/collect-jump-targets.rkt index 95cc2b8..2f7be9e 100644 --- a/collect-jump-targets.rkt +++ b/collect-jump-targets.rkt @@ -1,5 +1,6 @@ #lang typed/racket/base -(require "il-structs.rkt" +(require "expression-structs.rkt" + "il-structs.rkt" "lexical-structs.rkt" "helpers.rkt" racket/list) @@ -88,7 +89,9 @@ [(CompiledProcedureEntry? an-input) (collect-input (CompiledProcedureEntry-proc an-input))] [(CompiledProcedureClosureReference? an-input) - (collect-input (CompiledProcedureClosureReference-proc an-input))])) + (collect-input (CompiledProcedureClosureReference-proc an-input))] + [(PrimitiveKernelValue? an-input) + empty])) (: collect-location ((U Reg Label) -> (Listof Symbol))) diff --git a/compiler.rkt b/compiler.rkt index 3d3d7cb..dd6fa9e 100644 --- a/compiler.rkt +++ b/compiler.rkt @@ -137,7 +137,9 @@ (append (loop (ApplyValues-proc exp) cenv) (loop (ApplyValues-args-expr exp) cenv))] [(DefValues? exp) - (append (loop (DefValues-rhs exp) cenv))]))) + (append (loop (DefValues-rhs exp) cenv))] + [(PrimitiveKernelValue? exp) + '()]))) @@ -205,7 +207,9 @@ [(ApplyValues? exp) (compile-apply-values exp cenv target linkage)] [(DefValues? exp) - (compile-def-values exp cenv target linkage)])) + (compile-def-values exp cenv target linkage)] + [(PrimitiveKernelValue? exp) + (compile-primitive-kernel-value exp cenv target linkage)])) @@ -1764,6 +1768,24 @@ +(: compile-primitive-kernel-value (PrimitiveKernelValue CompileTimeEnvironment Target Linkage -> InstructionSequence)) +(define (compile-primitive-kernel-value exp cenv target linkage) + (let ([id (PrimitiveKernelValue-id exp)]) + (cond + [(KernelPrimitiveName? id) + + (let ([singular-context-check (emit-singular-context linkage)]) + ;; Compiles constant values. + (end-with-linkage linkage + cenv + (append-instruction-sequences + (make-instruction-sequence + `(,(make-AssignImmediateStatement target exp) + singular-context-check)))))] + [else + (error 'unimplemented-kernel-primitive + "Primitive Kernel Value ~s has not been implemented" + id)]))) @@ -1974,4 +1996,7 @@ (ensure-toplevelref (adjust-expression-depth id n skip))) (DefValues-ids exp)) - (adjust-expression-depth (DefValues-rhs exp) n skip))])) \ No newline at end of file + (adjust-expression-depth (DefValues-rhs exp) n skip))] + + [(PrimitiveKernelValue? exp) + exp])) \ No newline at end of file diff --git a/expression-structs.rkt b/expression-structs.rkt index 09437b9..c79c2db 100644 --- a/expression-structs.rkt +++ b/expression-structs.rkt @@ -25,7 +25,8 @@ BoxEnv WithContMark ApplyValues - DefValues)) + DefValues + PrimitiveKernelValue)) ;; A ModuleName is an identifier for a Module. (define-struct: ModuleName ([name : Symbol]) @@ -135,6 +136,11 @@ +(define-struct: PrimitiveKernelValue ([id : Symbol]) #:transparent) + + + + (: last-exp? ((Listof Expression) -> Boolean)) (define (last-exp? seq) (null? (cdr seq))) diff --git a/il-structs.rkt b/il-structs.rkt index 42ec5bc..ac0228b 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -32,7 +32,8 @@ ControlStackLabel/MultipleValueReturn ControlFrameTemporary CompiledProcedureEntry - CompiledProcedureClosureReference)) + CompiledProcedureClosureReference + PrimitiveKernelValue)) ;; Targets: these are the allowable lhs's for a targetted assignment. diff --git a/kernel-primitives.rkt b/kernel-primitives.rkt index c30cef0..584da46 100644 --- a/kernel-primitives.rkt +++ b/kernel-primitives.rkt @@ -34,6 +34,28 @@ (define-predicate KernelPrimitiveName? KernelPrimitiveName) +;; These are the primitives that we know how to inline. +(define-type KernelPrimitiveName/Inline (U '+ + '- + '* + '/ + 'add1 + 'sub1 + '< + '<= + '= + '> + '>= + 'cons + 'car + 'cdr + 'list + 'null? + 'not + 'eq?)) + + + (: kernel-primitive-expected-operand-types (KernelPrimitiveName Natural -> (Listof OperandDomain))) ;; Given a primitive and the number of arguments, produces the list of expected domains. diff --git a/optimize-il.rkt b/optimize-il.rkt index 70560e4..3b5da13 100644 --- a/optimize-il.rkt +++ b/optimize-il.rkt @@ -1,5 +1,6 @@ #lang typed/racket/base -(require "il-structs.rkt" +(require "expression-structs.rkt" + "il-structs.rkt" "lexical-structs.rkt" racket/list) @@ -132,7 +133,9 @@ [(CompiledProcedureClosureReference? oparg) (make-CompiledProcedureClosureReference (adjust-oparg-depth (CompiledProcedureClosureReference-proc oparg) n) - (CompiledProcedureClosureReference-n oparg))])) + (CompiledProcedureClosureReference-n oparg))] + [(PrimitiveKernelValue? oparg) + oparg])) (define-predicate natural? Natural) diff --git a/parse-bytecode-5.1.1.rkt b/parse-bytecode-5.1.1.rkt index c3dd237..0fbf39e 100644 --- a/parse-bytecode-5.1.1.rkt +++ b/parse-bytecode-5.1.1.rkt @@ -38,6 +38,43 @@ + + + +;; Code is copied-and-pasted from compiler/decompile. Maps the primval ids to their respective +;; symbolic names. +(define primitive-table + ;; Figure out number-to-id mapping for kernel functions in `primitive' + (let ([bindings + (let ([ns (make-base-empty-namespace)]) + (parameterize ([current-namespace ns]) + (namespace-require ''#%kernel) + (namespace-require ''#%unsafe) + (namespace-require ''#%flfxnum) + (for/list ([l (namespace-mapped-symbols)]) + (cons l (with-handlers ([exn:fail? (lambda (x) + #f)]) + (compile l))))))] + [table (make-hash)]) + (for ([b (in-list bindings)]) + (let ([v (and (cdr b) + (zo-parse (let ([out (open-output-bytes)]) + (write (cdr b) out) + (close-output-port out) + (open-input-bytes (get-output-bytes out)))))]) + (let ([n (match v + [(struct compilation-top (_ prefix (struct primval (n)))) n] + [else #f])]) + (hash-set! table n (car b))))) + table)) + + + + + + + + ;; parse-bytecode: Input-Port -> Expression (define (parse-bytecode in) (parameterize ([seen-closures (make-hasheq)]) @@ -430,5 +467,9 @@ (define (parse-apply-values expr) (error 'fixme)) + (define (parse-primval expr) - (error 'fixme)) \ No newline at end of file + (match expr + [(struct primval (id)) + (let ([name (hash-ref primitive-table id)]) + (make-PrimitiveKernelValue name))])) diff --git a/simulator.rkt b/simulator.rkt index a6a13a8..e1f55cc 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -5,7 +5,8 @@ ;; For example, I'll need to be able to count the number of statements executed by an evaluation. ;; I also need to do things like count pushes and pops. Basically, low-level benchmarking. -(require "il-structs.rkt" +(require "expression-structs.rkt" + "il-structs.rkt" "lexical-structs.rkt" "simulator-structs.rkt" "bootstrapped-primitives.rkt" @@ -766,7 +767,10 @@ [(CompiledProcedureClosureReference? an-oparg) (let ([proc (ensure-closure (evaluate-oparg m (CompiledProcedureClosureReference-proc an-oparg)))]) - (list-ref (closure-vals proc) (CompiledProcedureClosureReference-n an-oparg)))])) + (list-ref (closure-vals proc) (CompiledProcedureClosureReference-n an-oparg)))] + + [(PrimitiveKernelValue? an-oparg) + (lookup-primitive (PrimitiveKernelValue-id an-oparg))])) diff --git a/test-parse-bytecode-5.1.1.rkt b/test-parse-bytecode-5.1.1.rkt index f221238..a8583c2 100644 --- a/test-parse-bytecode-5.1.1.rkt +++ b/test-parse-bytecode-5.1.1.rkt @@ -23,6 +23,9 @@ (parse-bytecode (open-input-bytes (get-output-bytes op)))))) +(check-equal? (run-my-parse #''hello) + (make-Top (make-Prefix '()) + (make-Constant 'hello))) (check-equal? (run-my-parse #'"hello world") (make-Top (make-Prefix (list)) @@ -85,6 +88,7 @@ +;; let1's (check-equal? (run-my-parse #'(let ([y (f)]) 'ok)) (make-Top (make-Prefix (list (make-GlobalBucket 'f))) @@ -123,6 +127,9 @@ (make-LocalRef 0 #f))))) + + +;; branches (check-equal? (run-my-parse #'(if (f) (g) (h))) (make-Top (make-Prefix (list (make-GlobalBucket 'f) (make-GlobalBucket 'g) @@ -140,6 +147,31 @@ +(check-equal? (run-my-parse #'(if x (if y z 1) #t)) + (make-Top (make-Prefix (list (make-GlobalBucket 'x) + (make-GlobalBucket 'y) + (make-GlobalBucket 'z))) + (make-Branch (make-ToplevelRef 0 0) + (make-Branch (make-ToplevelRef 0 1) + (make-ToplevelRef 0 2) + (make-Constant 1)) + (make-Constant #t)))) + + +(check-equal? (run-my-parse #'(cond [x y])) + (make-Top (make-Prefix (list (make-GlobalBucket 'x) + (make-GlobalBucket 'y))) + (make-Branch (make-ToplevelRef 0 0) + (make-ToplevelRef 0 1) + (make-Constant (void))))) + + + + +(check-equal? (run-my-parse #'+) + (make-Top (make-Prefix (list)) + (make-PrimitiveKernelValue '+))) + ;; make sure we don't see an infinite loop @@ -147,13 +179,12 @@ (g))) (void (run-my-parse #'(letrec ([g (lambda () (g))]) (g)))) -;; todo: add tests to make sure we're parsing this as expected. - +;; todo: add tests to make sure we're parsing this as expected. We expect to see an EmptyClosureReference here. #;(run-zo-parse #'(letrec ([g (lambda () (h))] - [h (lambda () (g))]) - (g))) + [h (lambda () (g))]) + (g))) ;; FIXME: we need to handle closure cycles here.