massaging the code so general apply should work

bootstrapped-primitives.rkt

@@ -47,8 +47,8 @@
     
     ;; Finally, do a tail call into f.
     (compile-general-procedure-call '()
-                                    '(?)
+                                    1 ;; the stack at this point holds a single argument
-                                    1 
+                                    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)))))
+      `(,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))))))

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-AssignImmediateStatement 'val (make-Const number-of-arguments))
-                  ,(make-PerformStatement (make-CheckClosureArity!))))
+                  ,(make-PerformStatement (make-CheckClosureArity! (make-Reg 'val)))))
-               (compile-procedure-application extended-cenv (make-Reg 'val) n target compiled-linkage)
+               (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)                     
+                      (adjust-target-depth target number-of-arguments)                     
-                      (make-ApplyPrimitiveProcedure n))))
+                      (make-ApplyPrimitiveProcedure number-of-arguments))))
-                 (if (not (= n 0))
                  (make-instruction-sequence
-                      `(,(make-PopEnvironment n 0)))
+                  `(,(make-PopEnvironment number-of-arguments 0)))
-                     empty-instruction-sequence)
+                 
+
+                 
                  (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 

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)

runtime.js

@@ -235,7 +235,7 @@
 
 
     var ArityAtLeast = function(n) {
-	this.n = n;
+	this.value = n;
     };
 
 

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 
+                                      #:constants (null pi e)))
-                                                        #;call/cc
-                                                        #;call-with-current-continuation)))
 
 

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]

simulator.rkt

@@ -226,15 +226,29 @@
            (let: ([clos : SlotValue (machine-proc m)])
                  (cond
                    [(closure? clos)
-                    (if (= (closure-arity clos)
+                    (if (arity-match? (closure-arity clos)
-                           (ensure-natural (ensure-primitive-value (machine-val m))))
+                                      (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 
                       (make-toplevel (ExtendEnvironment/Prefix!-names op)
@@ -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.

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")))