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

structurizing the primitive operators, specializing them to the racket machine.

Browse Source
This commit is contained in:
dyoo 2011-03-02 17:31:31 -05:00
parent e6cb5d87a1
commit e9ba3cee85
2 changed files with 74 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
compile.rkt
View File

@ -58,8 +58,7 @@
(cond (cond
[(eq? linkage 'return) [(eq? linkage 'return)
(make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc (make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc
'read-control-label (make-GetControlStackLabel))
(list))
,(make-PopEnv (lexical-environment-pop-depth cenv) ,(make-PopEnv (lexical-environment-pop-depth cenv)
;; FIXME: not right ;; FIXME: not right
0) 0)
@ -91,11 +90,9 @@
(end-with-linkage linkage (end-with-linkage linkage
cenv cenv
(make-instruction-sequence (make-instruction-sequence
`(,(make-AssignPrimOpStatement target `(,(make-AssignPrimOpStatement
'lexical-address-lookup target
(list (make-Const (make-LookupLexicalAddress (LocalAddress-depth lexical-pos))))))]
(LocalAddress-depth lexical-pos))
(make-Reg 'env))))))]
[(PrefixAddress? lexical-pos) [(PrefixAddress? lexical-pos)
(end-with-linkage linkage (end-with-linkage linkage
cenv cenv
@ -104,12 +101,12 @@
(list (make-Const (PrefixAddress-depth lexical-pos)) (list (make-Const (PrefixAddress-depth lexical-pos))
(make-Const (PrefixAddress-pos lexical-pos)) (make-Const (PrefixAddress-pos lexical-pos))
(make-Const (PrefixAddress-name lexical-pos)))) (make-Const (PrefixAddress-name lexical-pos))))
,(make-AssignPrimOpStatement target ,(make-AssignPrimOpStatement
'toplevel-lookup target
(list (make-Const (PrefixAddress-depth lexical-pos)) (make-LookupToplevelAddress
(make-Const (PrefixAddress-pos lexical-pos)) (PrefixAddress-depth lexical-pos)
(make-Const (PrefixAddress-name lexical-pos)) (PrefixAddress-pos lexical-pos)
(make-Reg 'env))))))]))) (PrefixAddress-name lexical-pos))))))])))
(: compile-definition (Def CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-definition (Def CompileTimeEnvironment Target Linkage -> InstructionSequence))
@ -184,13 +181,13 @@
[lexical-references : (Listof (U EnvLexicalReference EnvWholePrefixReference)) [lexical-references : (Listof (U EnvLexicalReference EnvWholePrefixReference))
(collect-lexical-references lexical-addresses)]) (collect-lexical-references lexical-addresses)])
(append-instruction-sequences (append-instruction-sequences
(end-with-linkage lambda-linkage (end-with-linkage
cenv lambda-linkage
(make-instruction-sequence cenv
`(,(make-AssignPrimOpStatement target (make-instruction-sequence
'make-compiled-procedure `(,(make-AssignPrimOpStatement target
(list* (make-Label proc-entry) (make-MakeCompiledProcedure proc-entry
lexical-references))))) lexical-references)))))
(compile-lambda-body exp cenv (compile-lambda-body exp cenv
lexical-references lexical-references
proc-entry) proc-entry)
@ -306,11 +303,9 @@
(end-with-linkage linkage (end-with-linkage linkage
cenv cenv
(make-instruction-sequence (make-instruction-sequence
`(,(make-AssignPrimOpStatement target `(,(make-AssignPrimOpStatement
'apply-primitive-procedure target
(list (make-Reg 'proc) (make-ApplyPrimitiveProcedure n)))))
(make-Const n)
(make-Reg 'env))))))
after-call)))) after-call))))
@ -332,8 +327,7 @@
;; tail position. ;; tail position.
(make-instruction-sequence (make-instruction-sequence
`(,(make-PushControlFrame linkage) `(,(make-PushControlFrame linkage)
,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry ,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))
(list (make-Reg 'proc)))
,(make-GotoStatement (make-Reg 'val))))] ,(make-GotoStatement (make-Reg 'val))))]
[(and (not (eq? target 'val)) [(and (not (eq? target 'val))
@ -343,8 +337,8 @@
(let ([proc-return (make-label 'procReturn)]) (let ([proc-return (make-label 'procReturn)])
(make-instruction-sequence (make-instruction-sequence
`(,(make-PushControlFrame proc-return) `(,(make-PushControlFrame proc-return)
,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry ,(make-AssignPrimOpStatement 'val
(list (make-Reg 'proc))) (make-GetCompiledProcedureEntry))
,(make-GotoStatement (make-Reg 'val)) ,(make-GotoStatement (make-Reg 'val))
,proc-return ,proc-return
,(make-AssignImmediateStatement target (make-Reg 'val)) ,(make-AssignImmediateStatement target (make-Reg 'val))
@ -356,8 +350,9 @@
;; FIXME: do tail call stuff! ;; FIXME: do tail call stuff!
;; Must shift existing environment to replace ;; Must shift existing environment to replace
(make-instruction-sequence (make-instruction-sequence
`(,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry `(,(make-AssignPrimOpStatement 'val
(list (make-Reg 'proc))) (make-GetCompiledProcedureEntry))
;; FIXME: shift off the environment?
,(make-GotoStatement (make-Reg 'val))))] ,(make-GotoStatement (make-Reg 'val))))]
[(and (not (eq? target 'val)) [(and (not (eq? target 'val))

65
il-structs.rkt
View File

@ -35,6 +35,9 @@
#:transparent) #:transparent)
(define-type LexicalReference (U EnvLexicalReference
EnvWholePrefixReference))
@ -60,8 +63,7 @@
[value : OpArg]) [value : OpArg])
#:transparent) #:transparent)
(define-struct: AssignPrimOpStatement ([target : Target] (define-struct: AssignPrimOpStatement ([target : Target]
[op : PrimitiveOperator] [op : PrimitiveOperator])
[rands : (Listof OpArg)])
#:transparent) #:transparent)
@ -90,33 +92,50 @@
(define-type PrimitiveOperator (U
;; register -> label ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Get the label from the closure stored in ;; Primitive Operators
;; the register and return it.
'compiled-procedure-entry
;; label LexicalReference * -> closure ;; The operators that return values, that are used in AssignPrimopStatement.
'make-compiled-procedure (define-type PrimitiveOperator (U GetCompiledProcedureEntry
MakeCompiledProcedure
ApplyPrimitiveProcedure
LookupLexicalAddress
LookupToplevelAddress
GetControlStackLabel))
;; primitive-procedure arity -> any ;; Gets the label from the closure stored in the 'proc register and returns it.
'apply-primitive-procedure (define-struct: GetCompiledProcedureEntry ()
#:transparent)
;; Constructs a closure, given the label and the set of lexical references
;; into the environment that the closure needs to close over.
(define-struct: MakeCompiledProcedure ([label : Symbol]
[closed-vals : (Listof LexicalReference)])
#:transparent)
;; Applies the primitive procedure that's stored in the proc register, using
;; the arity number of values that are bound in the environment as arguments
;; to that primitive.
(define-struct: ApplyPrimitiveProcedure ([arity : Natural])
#:transparent)
;; Gets the value stored at the given depth in the environment.
(define-struct: LookupLexicalAddress ([depth : Natural])
#:transparent)
;; Looks up the value in the prefix installed in the environment.
(define-struct: LookupToplevelAddress ([depth : Natural]
[pos : Natural]
[name : Symbol])
#:transparent)
;; Gets the return address embedded at the top of the control stack.
(define-struct: GetControlStackLabel ()
#:transparent)
;; depth -> any
;; Lookup the value in the environment
'lexical-address-lookup
;; depth pos symbol -> any
;; lookup the value in the prefix installed in the
;; environment.
'toplevel-lookup
;; -> label
;; Grabs the label embedded in the top
;; of the control stack
'read-control-label
))
(define-type PrimitiveTest (U (define-type PrimitiveTest (U