procedure application
This commit is contained in:
Danny Yoo
parent
73962380ff
commit
edc6707fc1
23
assemble.rkt
23
assemble.rkt
|
|
@ -140,6 +140,8 @@ EOF
|
|||
[(CaptureControl? op)
|
||||
empty]
|
||||
[(MakeBoxedEnvironmentValue? op)
|
||||
empty]
|
||||
[(CallKernelPrimitiveProcedure? op)
|
||||
empty]))
|
||||
|
||||
(: collect-primitive-command (PrimitiveCommand -> (Listof Symbol)))
|
||||
|
|
@ -327,6 +329,8 @@ EOF
|
|||
"null"]
|
||||
[(empty? val)
|
||||
(format "Primitives.null")]
|
||||
[(number? val)
|
||||
(format "(~s)" val)]
|
||||
[else
|
||||
(format "~s" val)])))
|
||||
|
||||
|
|
@ -391,15 +395,32 @@ EOF
|
|||
|
||||
[(GetControlStackLabel? op)
|
||||
(format "MACHINE.control[MACHINE.control.length-1].label")]
|
||||
|
||||
[(CaptureEnvironment? op)
|
||||
(format "MACHINE.env.slice(0, MACHINE.env.length - ~a)"
|
||||
(CaptureEnvironment-skip op))]
|
||||
|
||||
[(CaptureControl? op)
|
||||
(format "MACHINE.control.slice(0, MACHINE.control.length - ~a)"
|
||||
(CaptureControl-skip op))]
|
||||
|
||||
[(MakeBoxedEnvironmentValue? op)
|
||||
(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))
|
||||
|
|
|
|||
138
compile.rkt
138
compile.rkt
|
|
@ -349,70 +349,94 @@
|
|||
(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))
|
||||
;; 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)
|
||||
(let* ([extended-cenv (append (map (lambda: ([op : ExpressionCore])
|
||||
'?)
|
||||
(App-operands exp))
|
||||
cenv)]
|
||||
[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))))])
|
||||
|
||||
(let ([extended-cenv (append (map (lambda: ([op : ExpressionCore])
|
||||
'?)
|
||||
(App-operands exp))
|
||||
cenv)])
|
||||
(let: ([op-knowledge : (U '? StaticallyKnownLam)
|
||||
(extract-static-knowledge (App-operator exp)
|
||||
extended-cenv)])
|
||||
(cond
|
||||
[(eq? op-knowledge '?)
|
||||
(compile-general-application exp cenv extended-cenv target linkage)]
|
||||
[(StaticallyKnownLam? op-knowledge)
|
||||
(compile-statically-known-lam-application op-knowledge exp cenv extended-cenv target linkage)]))))
|
||||
|
||||
|
||||
(: 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
|
||||
(make-instruction-sequence `(,(make-PushEnvironment (length (App-operands exp)) #f)))
|
||||
proc-code
|
||||
(juggle-operands operand-codes)
|
||||
(compile-procedure-call (App-operator exp) cenv extended-cenv (length (App-operands exp))
|
||||
target linkage))))
|
||||
(compile-general-procedure-call cenv
|
||||
extended-cenv
|
||||
(length (App-operands exp))
|
||||
target
|
||||
linkage))))
|
||||
|
||||
|
||||
(: compile-procedure-call
|
||||
(ExpressionCore CompileTimeEnvironment CompileTimeEnvironment Natural Target Linkage -> InstructionSequence))
|
||||
(define (compile-procedure-call operator cenv-before-args extended-cenv n target linkage)
|
||||
(define (default)
|
||||
(compile-general-procedure-call cenv-before-args
|
||||
extended-cenv
|
||||
n
|
||||
target linkage))
|
||||
(let: ([static-knowledge : (U '? StaticallyKnownLam)
|
||||
(extract-static-knowledge operator extended-cenv)])
|
||||
(cond
|
||||
[(eq? static-knowledge '?)
|
||||
(default)]
|
||||
#;[(ModuleVariable? static-knowledge)
|
||||
(default)]
|
||||
[(StaticallyKnownLam? static-knowledge)
|
||||
(unless (= n (StaticallyKnownLam-arity static-knowledge))
|
||||
(error 'arity-mismatch "~s expected ~s arguments, but received ~s"
|
||||
(StaticallyKnownLam-name static-knowledge)
|
||||
(StaticallyKnownLam-arity static-knowledge)
|
||||
n))
|
||||
(compile-procedure-call/statically-known-lam static-knowledge
|
||||
extended-cenv
|
||||
n
|
||||
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))))
|
||||
|
||||
(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
|
||||
(make-instruction-sequence `(,(make-PushEnvironment (length (App-operands exp)) #f)))
|
||||
proc-code
|
||||
(juggle-operands operand-codes)
|
||||
(compile-procedure-call/statically-known-lam static-knowledge
|
||||
extended-cenv
|
||||
(length (App-operands exp))
|
||||
target
|
||||
linkage))))
|
||||
|
||||
|
||||
(: juggle-operands ((Listof InstructionSequence) -> InstructionSequence))
|
||||
|
|
|
|||
|
|
@ -53,8 +53,10 @@
|
|||
|
||||
;; instruction sequences
|
||||
(define-type UnlabeledStatement (U
|
||||
|
||||
AssignImmediateStatement
|
||||
AssignPrimOpStatement
|
||||
|
||||
PerformStatement
|
||||
|
||||
GotoStatement
|
||||
|
|
@ -116,12 +118,14 @@
|
|||
(define-type PrimitiveOperator (U GetCompiledProcedureEntry
|
||||
MakeCompiledProcedure
|
||||
ApplyPrimitiveProcedure
|
||||
|
||||
GetControlStackLabel
|
||||
MakeBoxedEnvironmentValue
|
||||
|
||||
CaptureEnvironment
|
||||
CaptureControl
|
||||
))
|
||||
|
||||
CallKernelPrimitiveProcedure))
|
||||
|
||||
;; Gets the label from the closure stored in the 'proc register and returns it.
|
||||
(define-struct: GetCompiledProcedureEntry ()
|
||||
|
|
@ -143,6 +147,14 @@
|
|||
#: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.
|
||||
(define-struct: GetControlStackLabel ()
|
||||
#:transparent)
|
||||
|
|
|
|||
|
|
@ -327,10 +327,25 @@
|
|||
(CaptureControl-skip op))))]
|
||||
[(MakeBoxedEnvironmentValue? op)
|
||||
(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
|
||||
(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))
|
||||
(define (ensure-CapturedControl x)
|
||||
(if (CapturedControl? x)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user