From a49269e2db3d300a4211a7d6fc701e9fa42f9583 Mon Sep 17 00:00:00 2001 From: dyoo Date: Fri, 8 Apr 2011 16:03:39 -0400 Subject: [PATCH] massaging the code so general apply should work --- bootstrapped-primitives.rkt | 29 ++++++++++++++++++++++--- compile.rkt | 42 +++++++++++++++++++++---------------- il-structs.rkt | 15 ++++++++++++- runtime.js | 2 +- simulator-primitives.rkt | 28 +++++++++++++++---------- simulator-structs.rkt | 5 ++++- simulator.rkt | 37 +++++++++++++++++++++++++++++--- test-compiler.rkt | 11 ++++++++++ 8 files changed, 131 insertions(+), 38 deletions(-) diff --git a/bootstrapped-primitives.rkt b/bootstrapped-primitives.rkt index 6d3fbaa..241d12b 100644 --- a/bootstrapped-primitives.rkt +++ b/bootstrapped-primitives.rkt @@ -47,8 +47,8 @@ ;; Finally, do a tail call into f. (compile-general-procedure-call '() - '(?) - 1 + 1 ;; the stack at this point holds a single argument + 1 ;; and f needs to consume that single argument. 'val return-linkage) @@ -152,4 +152,27 @@ (make-MakeCompiledProcedure call/cc-label 1 '() 'call/cc)) ,(make-GotoStatement (make-Label after-call/cc-code))) (make-call/cc-code) - `(,after-call/cc-code))))) \ No newline at end of file + `(,after-call/cc-code))) + + + + ;; As is apply: + (let ([after-apply-code (make-label 'afterApplyCode)] + [apply-entry (make-label 'applyEntry)]) + (list + (make-GotoStatement (make-Label after-apply-code)) + apply-entry + + ;; Push the procedure into proc. + (make-AssignImmediateStatement 'proc (make-EnvLexicalReference 0 #f)) + (make-PopEnvironment 1 0) + ;; Correct the number of arguments to be passed. + (make-AssignPrimOpStatement 'val + (make-CallKernelPrimitiveProcedure 'sub1 + (list (make-Reg 'val)) + (list 'number) + (list #f))) + + after-apply-code + (make-AssignPrimOpStatement (make-PrimitivesReference 'apply) + (make-MakeCompiledProcedure apply-entry 1 '() 'apply)))))) \ No newline at end of file diff --git a/compile.rkt b/compile.rkt index 341b6cb..fd29df4 100644 --- a/compile.rkt +++ b/compile.rkt @@ -469,7 +469,7 @@ proc-code (juggle-operands operand-codes) (compile-general-procedure-call cenv - extended-cenv + (length extended-cenv) (length (App-operands exp)) target linkage)))) @@ -779,7 +779,7 @@ -(: compile-general-procedure-call (CompileTimeEnvironment CompileTimeEnvironment +(: compile-general-procedure-call (CompileTimeEnvironment Natural Natural Target Linkage -> InstructionSequence)) @@ -787,7 +787,7 @@ ;; n is the number of arguments passed in. ;; cenv is the compile-time enviroment before arguments have been shifted in. ;; extended-cenv is the compile-time environment after arguments have been shifted in. -(define (compile-general-procedure-call cenv extended-cenv n target linkage) +(define (compile-general-procedure-call cenv extended-cenv-length number-of-arguments target linkage) (let: ([primitive-branch : LabelLinkage (make-LabelLinkage (make-label 'primitiveBranch))] [compiled-branch : LabelLinkage (make-LabelLinkage (make-label 'compiledBranch))] [after-call : LabelLinkage (make-LabelLinkage (make-label 'afterCall))]) @@ -804,28 +804,34 @@ ;; Compiled branch (LabelLinkage-label compiled-branch) (make-instruction-sequence - `(,(make-AssignImmediateStatement 'val (make-Const n)) - ,(make-PerformStatement (make-CheckClosureArity!)))) - (compile-procedure-application extended-cenv (make-Reg 'val) n target compiled-linkage) - + `(,(make-AssignImmediateStatement 'val (make-Const number-of-arguments)) + ,(make-PerformStatement (make-CheckClosureArity! (make-Reg 'val))))) + (compile-procedure-application extended-cenv-length + (make-Reg 'val) + number-of-arguments + target + compiled-linkage) + ;; Primitive branch (LabelLinkage-label primitive-branch) (end-with-linkage linkage cenv (append-instruction-sequences (make-instruction-sequence - `(,(make-AssignPrimOpStatement + `(,(make-PerformStatement (make-CheckPrimitiveArity! (make-Const number-of-arguments))) + ,(make-AssignPrimOpStatement ;; Optimization: we put the result directly in the registers, or in ;; the appropriate spot on the stack. This takes into account the popenviroment ;; that happens right afterwards. - (adjust-target-depth target n) - (make-ApplyPrimitiveProcedure n)))) - (if (not (= n 0)) - (make-instruction-sequence - `(,(make-PopEnvironment n 0))) - empty-instruction-sequence) + (adjust-target-depth target number-of-arguments) + (make-ApplyPrimitiveProcedure number-of-arguments)))) + (make-instruction-sequence + `(,(make-PopEnvironment number-of-arguments 0))) + + + (LabelLinkage-label after-call))))))) @@ -837,7 +843,7 @@ linkage after-call)]) (append-instruction-sequences - (compile-procedure-application extended-cenv + (compile-procedure-application (length extended-cenv) (make-Label (StaticallyKnownLam-entry-point static-knowledge)) n target @@ -849,19 +855,19 @@ -(: compile-procedure-application (CompileTimeEnvironment (U Label Reg) Natural Target Linkage -> InstructionSequence)) +(: compile-procedure-application (Natural (U Label Reg) Natural Target Linkage -> InstructionSequence)) ;; Three fundamental cases for general compiled-procedure application. ;; 1. Tail calls. ;; 2. Non-tail calls (next/label linkage) that write to val ;; 3. Calls in argument position (next/label linkage) that write to the stack. -(define (compile-procedure-application cenv-with-args entry-point n target linkage) +(define (compile-procedure-application cenv-length-with-args entry-point n target linkage) (cond [(ReturnLinkage? linkage) (cond [(eq? target 'val) ;; This case happens when we're in tail position. ;; We clean up the stack right before the jump, and do not add ;; to the control stack. - (let: ([num-slots-to-delete : Natural (ensure-natural (- (length cenv-with-args) n))]) + (let: ([num-slots-to-delete : Natural (ensure-natural (- cenv-length-with-args n))]) (append-instruction-sequences (make-instruction-sequence `(,(make-AssignPrimOpStatement 'val diff --git a/il-structs.rkt b/il-structs.rkt index fdc2f71..fa7f418 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -233,8 +233,11 @@ ;; Check the closure procedure value in 'proc and make sure it can accept the ;; # of arguments (stored as a number in the val register.). -(define-struct: CheckClosureArity! () +(define-struct: CheckClosureArity! ([arity : OpArg]) #:transparent) +(define-struct: CheckPrimitiveArity! ([arity : OpArg]) + #:transparent) + ;; Extends the environment with a prefix that holds ;; lookups to the namespace. @@ -268,6 +271,7 @@ (define-type PrimitiveCommand (U CheckToplevelBound! CheckClosureArity! + CheckPrimitiveArity! ExtendEnvironment/Prefix! InstallClosureValues! FixClosureShellMap! @@ -361,4 +365,13 @@ + +(define-type Arity (U Natural + ArityAtLeast + (Listof (U Natural ArityAtLeast)))) +(define-struct: ArityAtLeast ([value : Natural]) + #:transparent) + + + (define-predicate OpArg? OpArg) \ No newline at end of file diff --git a/runtime.js b/runtime.js index 09ef3d2..c765870 100644 --- a/runtime.js +++ b/runtime.js @@ -235,7 +235,7 @@ var ArityAtLeast = function(n) { - this.n = n; + this.value = n; }; diff --git a/simulator-primitives.rkt b/simulator-primitives.rkt index 1d7dc7f..ce78e53 100644 --- a/simulator-primitives.rkt +++ b/simulator-primitives.rkt @@ -10,6 +10,19 @@ (hash-set! mutated-primitives n p)) +(define (extract-arity proc) + (let loop ([racket-arity (procedure-arity proc)]) + (cond + [(number? racket-arity) + racket-arity] + [(arity-at-least? racket-arity) + (make-ArityAtLeast (arity-at-least-value racket-arity))] + [(list? racket-arity) + (map loop racket-arity)]))) + + + + (define-syntax (make-lookup stx) (syntax-case stx () [(_ #:functions (name ...) @@ -27,7 +40,9 @@ (syntax/loc stx (let ([prim-name (make-primitive-proc (lambda (machine . args) - (apply name args)))] + (apply name args)) + (extract-arity name) + 'exported-name)] ...) (lambda (n) (cond @@ -43,13 +58,6 @@ (make-undefined)] )))))])) -;(define call/cc -; (make-closure call/cc-label -; 1 -; '() -; 'call/cc)) -;(define call-with-current-continuation call/cc) - (define e (exp 1)) (define my-cons (lambda (x y) @@ -173,8 +181,6 @@ symbol?) - #:constants (null pi e - #;call/cc - #;call-with-current-continuation))) + #:constants (null pi e))) diff --git a/simulator-structs.rkt b/simulator-structs.rkt index 4529efe..2dfba53 100644 --- a/simulator-structs.rkt +++ b/simulator-structs.rkt @@ -88,11 +88,14 @@ ;; Primitive procedure wrapper -(define-struct: primitive-proc ([f : (machine PrimitiveValue * -> PrimitiveValue)]) +(define-struct: primitive-proc ([f : (machine PrimitiveValue * -> PrimitiveValue)] + [arity : Arity] + [display-name : (U Symbol False)]) #:transparent) + ;; Compiled procedure closures (define-struct: closure ([label : Symbol] [arity : Natural] diff --git a/simulator.rkt b/simulator.rkt index d3120c2..42281a2 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -226,14 +226,28 @@ (let: ([clos : SlotValue (machine-proc m)]) (cond [(closure? clos) - (if (= (closure-arity clos) - (ensure-natural (ensure-primitive-value (machine-val m)))) + (if (arity-match? (closure-arity clos) + (ensure-natural (evaluate-oparg m (CheckClosureArity!-arity op)))) 'ok (error 'check-closure-arity "arity mismatch: passed ~s args to ~s" - (machine-val m) + (ensure-natural (evaluate-oparg m (CheckClosureArity!-arity op))) (closure-display-name clos)))] [else (error 'check-closure-arity "not a closure: ~s" clos)]))] + + [(CheckPrimitiveArity!? op) + (let: ([clos : SlotValue (machine-proc m)]) + (cond + [(primitive-proc? clos) + (if (arity-match? (primitive-proc-arity clos) + (ensure-natural (evaluate-oparg m (CheckPrimitiveArity!-arity op)))) + 'ok + (error 'check-primitive-arity "arity mismatch: passed ~s args to ~s" + (ensure-natural (evaluate-oparg m (CheckPrimitiveArity!-arity op))) + (primitive-proc-display-name clos)))] + [else + (error 'check-primitive-arity "not a primitive: ~s" clos)]))] + [(ExtendEnvironment/Prefix!? op) (env-push! m @@ -291,6 +305,23 @@ 'ok]))) +(: arity-match? (Arity Natural -> Boolean)) +(define (arity-match? an-arity n) + (cond + [(natural? an-arity) + (= n an-arity)] + [(ArityAtLeast? an-arity) + (>= n (ArityAtLeast-value an-arity))] + [(list? an-arity) + (ormap (lambda: ([atomic-arity : (U Natural ArityAtLeast)]) + (cond [(natural? atomic-arity) + (= n atomic-arity)] + [(ArityAtLeast? atomic-arity) + (>= n (ArityAtLeast-value atomic-arity))])) + an-arity)])) + + + (: compose-continuation-frames ((Listof frame) (Listof frame) -> (Listof frame))) ;; Stitch together the continuation. A PromptFrame must exist at the head of frames-2. diff --git a/test-compiler.rkt b/test-compiler.rkt index 7e30659..36ee8db 100644 --- a/test-compiler.rkt +++ b/test-compiler.rkt @@ -1016,6 +1016,17 @@ +(test '(begin (define (m f x y) + (f (f x y) y)) + (m + 7 4)) + 15) + +(test '(begin (define (m f x y) + (f (f x y) y)) + (m - 7 4)) + -1) + + #;(test (read (open-input-file "tests/conform/program0.sch")) (port->string (open-input-file "tests/conform/expected0.txt")))