diff --git a/assemble.rkt b/assemble.rkt index 59a06b8..bc460e6 100644 --- a/assemble.rkt +++ b/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)) diff --git a/compile.rkt b/compile.rkt index 8b470fc..95dbcc4 100644 --- a/compile.rkt +++ b/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)) diff --git a/il-structs.rkt b/il-structs.rkt index 5eb251d..d316345 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -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) diff --git a/simulator.rkt b/simulator.rkt index 277eab1..b4a07d5 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -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)