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

procedure application

Browse Source
This commit is contained in:
Danny Yoo 2011-03-26 18:52:49 -04:00
parent 73962380ff
commit edc6707fc1
4 changed files with 139 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
assemble.rkt
View File

@ -140,6 +140,8 @@ EOF
[(CaptureControl? op) [(CaptureControl? op)
empty] empty]
[(MakeBoxedEnvironmentValue? op) [(MakeBoxedEnvironmentValue? op)
empty]
[(CallKernelPrimitiveProcedure? op)
empty])) empty]))
(: collect-primitive-command (PrimitiveCommand -> (Listof Symbol))) (: collect-primitive-command (PrimitiveCommand -> (Listof Symbol)))
@ -327,6 +329,8 @@ EOF
"null"] "null"]
[(empty? val) [(empty? val)
(format "Primitives.null")] (format "Primitives.null")]
[(number? val)
(format "(~s)" val)]
[else [else
(format "~s" val)]))) (format "~s" val)])))
@ -391,15 +395,32 @@ EOF
[(GetControlStackLabel? op) [(GetControlStackLabel? op)
(format "MACHINE.control[MACHINE.control.length-1].label")] (format "MACHINE.control[MACHINE.control.length-1].label")]
[(CaptureEnvironment? op) [(CaptureEnvironment? op)
(format "MACHINE.env.slice(0, MACHINE.env.length - ~a)" (format "MACHINE.env.slice(0, MACHINE.env.length - ~a)"
(CaptureEnvironment-skip op))] (CaptureEnvironment-skip op))]
[(CaptureControl? op) [(CaptureControl? op)
(format "MACHINE.control.slice(0, MACHINE.control.length - ~a)" (format "MACHINE.control.slice(0, MACHINE.control.length - ~a)"
(CaptureControl-skip op))] (CaptureControl-skip op))]
[(MakeBoxedEnvironmentValue? op) [(MakeBoxedEnvironmentValue? op)
(format "[MACHINE.env[MACHINE.env.length - 1 - ~a]]" (format "[MACHINE.env[MACHINE.env.length - 1 - ~a]]"
(MakeBoxedEnvironmentValue-depth op))])) (MakeBoxedEnvironmentValue-depth op))]
[(CallKernelPrimitiveProcedure? op)
(open-code-kernel-primitive-procedure op)]))
(: 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))])
(cond
[(eq? operator '+)
;; FIXME: this needs to check that all the values are numbers!
(string-join rand-vals " + ")])))
(: assemble-op-statement (PrimitiveCommand -> String)) (: assemble-op-statement (PrimitiveCommand -> String))

134
compile.rkt
View File

@ -349,70 +349,94 @@
(compile-lambda-bodies (rest exps)))])) (compile-lambda-bodies (rest exps)))]))
;; FIXME: I need to implement important special cases.
;; 1. We may be able to open-code if the operator is primitive
;; 2. We may have a static location to jump to if the operator is lexically scoped.
(: compile-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence))
;; Compiles procedure application
;; Special cases: if we know something about the operator, the compiler will special case.
;; This includes:
;; Known closure
;; Known kernel primitive
;; Finally, general procedure application.
(define (compile-application exp cenv target linkage) (define (compile-application exp cenv target linkage)
(let* ([extended-cenv (append (map (lambda: ([op : ExpressionCore]) (let ([extended-cenv (append (map (lambda: ([op : ExpressionCore])
'?) '?)
(App-operands exp)) (App-operands exp))
cenv)] cenv)])
[proc-code (compile (App-operator exp) (let: ([op-knowledge : (U '? StaticallyKnownLam)
extended-cenv (extract-static-knowledge (App-operator exp)
(if (empty? (App-operands exp)) extended-cenv)])
'proc (cond
(make-EnvLexicalReference [(eq? op-knowledge '?)
(ensure-natural (sub1 (length (App-operands exp)))) (compile-general-application exp cenv extended-cenv target linkage)]
#f)) [(StaticallyKnownLam? op-knowledge)
'next)] (compile-statically-known-lam-application op-knowledge exp cenv extended-cenv target linkage)]))))
[operand-codes (map (lambda: ([operand : Expression]
[target : Target])
(compile operand extended-cenv target 'next))
(App-operands exp)
(build-list (length (App-operands exp))
(lambda: ([i : Natural])
(if (< i (sub1 (length (App-operands exp))))
(make-EnvLexicalReference i #f)
'val))))])
(: compile-general-application (App CompileTimeEnvironment CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-general-application exp cenv extended-cenv target linkage)
(let ([proc-code (compile (App-operator exp)
extended-cenv
(if (empty? (App-operands exp))
'proc
(make-EnvLexicalReference
(ensure-natural (sub1 (length (App-operands exp))))
#f))
'next)]
[operand-codes (map (lambda: ([operand : Expression]
[target : Target])
(compile operand extended-cenv target 'next))
(App-operands exp)
(build-list (length (App-operands exp))
(lambda: ([i : Natural])
(if (< i (sub1 (length (App-operands exp))))
(make-EnvLexicalReference i #f)
'val))))])
(append-instruction-sequences (append-instruction-sequences
(make-instruction-sequence `(,(make-PushEnvironment (length (App-operands exp)) #f))) (make-instruction-sequence `(,(make-PushEnvironment (length (App-operands exp)) #f)))
proc-code proc-code
(juggle-operands operand-codes) (juggle-operands operand-codes)
(compile-procedure-call (App-operator exp) cenv extended-cenv (length (App-operands exp)) (compile-general-procedure-call cenv
target linkage)))) extended-cenv
(length (App-operands exp))
target
linkage))))
(: compile-statically-known-lam-application
(StaticallyKnownLam App CompileTimeEnvironment CompileTimeEnvironment Target Linkage
-> InstructionSequence))
(define (compile-statically-known-lam-application static-knowledge exp cenv extended-cenv target linkage)
(unless (= (length (App-operands exp))
(StaticallyKnownLam-arity static-knowledge))
(error 'arity-mismatch "~s expected ~s arguments, but received ~s"
(StaticallyKnownLam-name static-knowledge)
(StaticallyKnownLam-arity static-knowledge)
(length (App-operands exp))))
(: compile-procedure-call (let ([proc-code (compile (App-operator exp)
(ExpressionCore CompileTimeEnvironment CompileTimeEnvironment Natural Target Linkage -> InstructionSequence)) extended-cenv
(define (compile-procedure-call operator cenv-before-args extended-cenv n target linkage) (if (empty? (App-operands exp))
(define (default) 'proc
(compile-general-procedure-call cenv-before-args (make-EnvLexicalReference
extended-cenv (ensure-natural (sub1 (length (App-operands exp))))
n #f))
target linkage)) 'next)]
(let: ([static-knowledge : (U '? StaticallyKnownLam) [operand-codes (map (lambda: ([operand : Expression]
(extract-static-knowledge operator extended-cenv)]) [target : Target])
(cond (compile operand extended-cenv target 'next))
[(eq? static-knowledge '?) (App-operands exp)
(default)] (build-list (length (App-operands exp))
#;[(ModuleVariable? static-knowledge) (lambda: ([i : Natural])
(default)] (if (< i (sub1 (length (App-operands exp))))
[(StaticallyKnownLam? static-knowledge) (make-EnvLexicalReference i #f)
(unless (= n (StaticallyKnownLam-arity static-knowledge)) 'val))))])
(error 'arity-mismatch "~s expected ~s arguments, but received ~s" (append-instruction-sequences
(StaticallyKnownLam-name static-knowledge) (make-instruction-sequence `(,(make-PushEnvironment (length (App-operands exp)) #f)))
(StaticallyKnownLam-arity static-knowledge) proc-code
n)) (juggle-operands operand-codes)
(compile-procedure-call/statically-known-lam static-knowledge (compile-procedure-call/statically-known-lam static-knowledge
extended-cenv extended-cenv
n (length (App-operands exp))
target target
linkage)]))) linkage))))
(: juggle-operands ((Listof InstructionSequence) -> InstructionSequence)) (: juggle-operands ((Listof InstructionSequence) -> InstructionSequence))

14
il-structs.rkt
View File

@ -53,8 +53,10 @@
;; instruction sequences ;; instruction sequences
(define-type UnlabeledStatement (U (define-type UnlabeledStatement (U
AssignImmediateStatement AssignImmediateStatement
AssignPrimOpStatement AssignPrimOpStatement
PerformStatement PerformStatement
GotoStatement GotoStatement
@ -116,12 +118,14 @@
(define-type PrimitiveOperator (U GetCompiledProcedureEntry (define-type PrimitiveOperator (U GetCompiledProcedureEntry
MakeCompiledProcedure MakeCompiledProcedure
ApplyPrimitiveProcedure ApplyPrimitiveProcedure
GetControlStackLabel GetControlStackLabel
MakeBoxedEnvironmentValue MakeBoxedEnvironmentValue
CaptureEnvironment CaptureEnvironment
CaptureControl CaptureControl
))
CallKernelPrimitiveProcedure))
;; Gets the label from the closure stored in the 'proc register and returns it. ;; Gets the label from the closure stored in the 'proc register and returns it.
(define-struct: GetCompiledProcedureEntry () (define-struct: GetCompiledProcedureEntry ()
@ -143,6 +147,14 @@
#:transparent) #:transparent)
(define-type KernelPrimitiveName (U '+))
(define-struct: CallKernelPrimitiveProcedure ([operator : KernelPrimitiveName]
[operands : (Listof OpArg)])
#:transparent)
;; Gets the return address embedded at the top of the control stack. ;; Gets the return address embedded at the top of the control stack.
(define-struct: GetControlStackLabel () (define-struct: GetControlStackLabel ()
#:transparent) #:transparent)

24
simulator.rkt
View File

@ -327,8 +327,23 @@
(CaptureControl-skip op))))] (CaptureControl-skip op))))]
[(MakeBoxedEnvironmentValue? op) [(MakeBoxedEnvironmentValue? op)
(target-updater! m (box (ensure-primitive-value (target-updater! m (box (ensure-primitive-value
(env-ref m (MakeBoxedEnvironmentValue-depth op)))))]))) (env-ref m (MakeBoxedEnvironmentValue-depth op)))))]
[(CallKernelPrimitiveProcedure? op)
(target-updater! m (evaluate-kernel-primitive-procedure-call m op))])))
(: evaluate-kernel-primitive-procedure-call (machine CallKernelPrimitiveProcedure -> PrimitiveValue))
(define (evaluate-kernel-primitive-procedure-call m op)
(let: ([op : KernelPrimitiveName (CallKernelPrimitiveProcedure-operator op)]
[rand-vals : (Listof SlotValue)
(map (lambda: ([a : OpArg])
(evaluate-oparg m a))
(CallKernelPrimitiveProcedure-operands op))])
(cond
[(eq? op '+)
(apply + (map ensure-number rand-vals))])))
@ -425,6 +440,13 @@
x x
(error 'ensure-natural))) (error 'ensure-natural)))
(: ensure-number (Any -> Number))
(define (ensure-number x)
(if (number? x)
x
(error 'ensure-number "Not a number: ~s" x)))
(: ensure-CapturedControl (Any -> CapturedControl)) (: ensure-CapturedControl (Any -> CapturedControl))
(define (ensure-CapturedControl x) (define (ensure-CapturedControl x)
(if (CapturedControl? x) (if (CapturedControl? x)