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

working on extendenvironment/prefix

Browse Source
This commit is contained in:
Danny Yoo 2011-03-04 15:32:29 -05:00
parent 9277109351
commit b2df94e060
6 changed files with 94 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
compile.rkt
View File

@ -47,8 +47,7 @@
[names : (Listof Symbol) (Prefix-names (Top-prefix top))]) [names : (Listof Symbol) (Prefix-names (Top-prefix top))])
(append-instruction-sequences (append-instruction-sequences
(make-instruction-sequence (make-instruction-sequence
`(,(make-PerformStatement 'extend-environment/prefix! `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! names))))
(list (make-Const names)))))
(compile (Top-code top) cenv target linkage)))) (compile (Top-code top) cenv target linkage))))
@ -127,10 +126,10 @@
(end-with-linkage linkage (end-with-linkage linkage
cenv cenv
(make-instruction-sequence (make-instruction-sequence
`(,(make-PerformStatement 'check-bound! `(,(make-PerformStatement (make-CheckToplevelBound!
(list (make-Const (PrefixAddress-depth lexical-pos)) (PrefixAddress-depth lexical-pos)
(make-Const (PrefixAddress-pos lexical-pos)) (PrefixAddress-pos lexical-pos)
(make-Const (PrefixAddress-name lexical-pos)))) (PrefixAddress-name lexical-pos)))
,(make-AssignPrimOpStatement ,(make-AssignPrimOpStatement
target target
(make-LookupToplevelAddress (make-LookupToplevelAddress
@ -154,10 +153,10 @@
cenv cenv
(append-instruction-sequences (append-instruction-sequences
get-value-code get-value-code
(make-instruction-sequence `(,(make-PerformStatement 'toplevel-set! (make-instruction-sequence `(,(make-PerformStatement (make-SetToplevel!
(list (make-Const (PrefixAddress-depth lexical-pos)) (PrefixAddress-depth lexical-pos)
(make-Const (PrefixAddress-pos lexical-pos)) (PrefixAddress-pos lexical-pos)
(make-Const var))) var))
,(make-AssignImmediateStatement target (make-Const 'ok))))))]))) ,(make-AssignImmediateStatement target (make-Const 'ok))))))])))
@ -247,8 +246,7 @@
(append-instruction-sequences (append-instruction-sequences
(make-instruction-sequence (make-instruction-sequence
`(,proc-entry `(,proc-entry
,(make-PerformStatement 'install-closure-values! ,(make-PerformStatement (make-InstallClosureValues!))))
(list (make-Reg 'proc)))))
(compile (Lam-body exp) extended-cenv 'val 'return)))) (compile (Lam-body exp) extended-cenv 'val 'return))))

54
il-structs.rkt
View File

@ -87,9 +87,9 @@
(define-struct: GotoStatement ([target : (U Label Reg)]) (define-struct: GotoStatement ([target : (U Label Reg)])
#:transparent) #:transparent)
(define-struct: PerformStatement ([op : PrimitiveCommand] (define-struct: PerformStatement ([op : PrimitiveCommand])
[rands : (Listof (U Label Reg Const))])
#:transparent) #:transparent)
(define-struct: TestAndBranchStatement ([op : PrimitiveTest] (define-struct: TestAndBranchStatement ([op : PrimitiveTest]
[register : AtomicRegisterSymbol] [register : AtomicRegisterSymbol]
[label : Symbol]) [label : Symbol])
@ -143,7 +143,6 @@
;; The following is used with TestStatement: each is passed the register-rand and ;; The following is used with TestStatement: each is passed the register-rand and
;; is expected to ;; is expected to
(define-type PrimitiveTest (U (define-type PrimitiveTest (U
;; register -> boolean ;; register -> boolean
;; Meant to branch when the register value is false. ;; Meant to branch when the register value is false.
'false? 'false?
@ -155,27 +154,36 @@
)) ))
;; Assign the value in the val register into
;; the prefix installed at (depth, pos).
(define-struct: SetToplevel! ([depth : Natural]
[pos : Natural]
[name : Symbol])
#:transparent)
;; Check that the value in the prefix has been defined.
;; If not, raise an error and stop evaluation.
(define-struct: CheckToplevelBound! ([depth : Natural]
[pos : Natural]
[name : Symbol])
#:transparent)
;; Extends the environment with a prefix that holds
;; lookups to the namespace.
(define-struct: ExtendEnvironment/Prefix! ([names : (Listof Symbol)])
#:transparent)
;; Adjusts the environment by pushing the values in the
;; closure (held in the proc register) into itself.
(define-struct: InstallClosureValues! ()
#:transparent)
(define-type PrimitiveCommand (U (define-type PrimitiveCommand (U
;; depth pos symbol SetToplevel!
;; Assign the value in the val register into CheckToplevelBound!
;; the prefix installed at (depth, pos). ExtendEnvironment/Prefix!
'toplevel-set! InstallClosureValues!))
;; depth pos symbol -> void
;; Check that the value in the prefix has been defined.
;; If not, raise an error and stop evaluation.
'check-bound!
;; (listof symbol) -> void
;; Extends the environment with a prefix that holds
;; lookups to the namespace.
'extend-environment/prefix!
;; register -> void
;; Adjusts the environment by pushing the values in the
;; closure (held in the register) into itself.
'install-closure-values!
))

42
simulator-prims.rkt
View File

@ -1,13 +1,35 @@
#lang racket/base #lang racket/base
(require "simulator-structs.rkt") (require "simulator-structs.rkt"
racket/math
(for-syntax racket/base))
(define-syntax (make-lookup stx)
(syntax-case stx ()
[(_ #:functions (name ...)
#:constants (cname ...))
(with-syntax ([(prim-name ...) (generate-temporaries #'(name ...))])
(syntax/loc stx
(let ([prim-name (make-primitive-proc
(lambda args
(apply name args)))]
...)
(lambda (n)
(cond
[(eq? n 'name)
prim-name]
...
[(eq? n 'cname)
cname]
...
[else
(error 'lookup)]
)))))]))
(define e (exp 1))
(provide lookup-primitive) (provide lookup-primitive)
(define lookup-primitive (make-lookup #:functions (+ - * / = < <= > >= cons list car cdr
(define (lookup-primitive name) display newline displayln)
(cond #:constants (null pi e)))
[(eq? name '+)
(make-primitive-proc +)]
[(eq? name '=)
(make-primitive-proc =)]
[else
(void)]))

5
simulator-structs.rkt
View File

@ -19,6 +19,11 @@
(define-struct: frame ([return : Symbol]) (define-struct: frame ([return : Symbol])
#:transparent) #:transparent)
(define-struct: toplevel ([vals : (Vectorof Any)])
#:transparent)
;; Primitive procedure wrapper ;; Primitive procedure wrapper
(define-struct: primitive-proc ([f : (Any * -> Any)])) (define-struct: primitive-proc ([f : (Any * -> Any)]))

7
simulator.rkt
View File

@ -65,15 +65,12 @@
(cond [(Label? t) (cond [(Label? t)
(jump m (Label-name t))] (jump m (Label-name t))]
[(Reg? t) [(Reg? t)
(let: ([reg : RegisterSymbol (Reg-name t)]) (let: ([reg : AtomicRegisterSymbol (Reg-name t)])
(cond [(AtomicRegisterSymbol? reg) (cond [(AtomicRegisterSymbol? reg)
(cond [(eq? reg 'val) (cond [(eq? reg 'val)
(jump m (ensure-symbol (machine-val m)))] (jump m (ensure-symbol (machine-val m)))]
[(eq? reg 'proc) [(eq? reg 'proc)
(jump m (ensure-symbol (machine-proc m)))])] (jump m (ensure-symbol (machine-proc m)))])]))])))
[else
(error 'step-goto "Register '~s is supposed to be either 'val or 'proc"
reg)]))])))
(: step-assign-immediate (machine AssignImmediateStatement -> machine)) (: step-assign-immediate (machine AssignImmediateStatement -> machine))
(define (step-assign-immediate m stmt) (define (step-assign-immediate m stmt)

12
test-simulator.rkt
View File

@ -220,3 +220,15 @@
end))]) end))])
(test (machine-val (run m)) (test (machine-val (run m))
'a-procedure)) 'a-procedure))
;; AssignPrimOpStatement
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+ - * =)))))])
(test (machine-env (run m))
(list (make-toplevel (vector (lookup-primitive +)
(lookup-primitive -)
(lookup-primitive *)
(lookup-primitive =))))))