Correct implementation of Knock:

* Fix stack alignment, we couldn't tickle the bug, but we know it was there
* Implement tail-call for `(call (fun f) x y z)`
* Add a few tests

Author: jmct

langs/knock/compile.rkt

@@ -63,6 +63,9 @@
       [(App f es)    (if (<= (length es) s)
                          (compile-tail-call f es c)
                          (compile-app f es c))]
+      [(FCall e1 es) (if (<= (length es) s)
+                         (compile-tail-fun-call e1 es c)
+                         (compile-fun-call e1 es c))]
       [(Begin e1 e2) (compile-tail-begin e1 e2 c s)]
       [_             (compile-e e c)])))
 
@@ -104,17 +107,6 @@
        ; Bump the heap pointer
        (Add rbx 8)))
 
-(define (compile-fun-call e es c)
-  (let ((d (length es)))
-       (seq (compile-e e c)
-            (assert-proc rax)
-            (Push rax)
-            (compile-es es (cons #f c))
-            (Mov rax (Offset rsp (* 8 d)))
-            (Xor rax type-proc)
-            (Call (Offset rax 0))
-            (Add rsp (* 8 (add1 d))))))
-
 ;; Op0 CEnv -> Asm
 (define (compile-prim0 p c)
   (match p
@@ -248,6 +240,50 @@
             (Add rsp (* 8 (+ cnt (in-frame c))))
             (Jmp (symbol->label f)))))
 
+;; Similar to `compile-app` we have to be concerned about 16-byte alignment
+;; of `rsp`. However, the wrinkle is that we also have the function pointer
+;; on the stack, so we have to do the calculation with an `extended` env: `env`
+(define (compile-fun-call e es c)
+  (let ((d (length es))
+        (env (cons #f c)))
+       ; We have to computer the function pointer either way.
+       (seq (compile-e e c)
+            (assert-proc rax)
+            (Push rax)
+
+       ; Then we worry about alignment
+       (if (even? (+ d (length env)))
+
+           ; We will be 16-byte aligned
+           (seq (compile-es es env)
+                (Mov rax (Offset rsp (* 8 d)))
+                (Xor rax type-proc)
+                (Call (Offset rax 0))
+                (Add rsp (* 8 (add1 d))))
+
+           ; We won't be 16-byte aligned, and need to adjust `rsp`
+           (seq (Sub rsp 8)
+                (compile-es es env)
+                (Mov rax (Offset rsp (* 8 (add1 d))))
+                (Xor rax type-proc)
+                (Call (Offset rax 0))
+                ; pop arguments, padding, and function pointer
+                (Add rsp (* 8 (+ 2 d))))))))
+
+;; Variable (Listof Expr) CEnv -> Asm
+;; Compile a call in tail position
+(define (compile-tail-fun-call f es c)
+  (let ((cnt (length es)))
+       (seq (compile-e f c)
+            (assert-proc rax)
+            (Push rax)
+            (compile-es es (cons #f c))
+            (move-args cnt (+ cnt (add1 (in-frame c))))
+            (Mov rax (Offset rsp (* 8 cnt)))
+            (Xor rax type-proc)
+            (Add rsp (* 8 (+ cnt (add1 (in-frame c)))))
+            (Jmp (Offset rax 0)))))
+
 ;; Integer Integer -> Asm
 ;; Move i arguments upward on stack by offset off
 (define (move-args i cnt)

langs/knock/interp.rkt

@@ -10,6 +10,7 @@
 ;; | Integer
 ;; | Boolean
 ;; | Character
+;; | (Fun f)
 ;; | Eof
 ;; | Void
 ;; | '()
@@ -70,8 +71,22 @@
           ; arity check
           (if (= (length vs) (length xs))
               (interp-env body (zip xs vs) ds)
-              'err)])]
-      [_         'err])]))
+              'err)])])]
+    [(Fun f)
+      (match (defns-lookup ds f)
+        [(Defn f xs body)
+         (lambda (es r)
+          (match (interp-env* es r ds)
+            [(list vs ...)
+             (if (= (length vs) (length xs))
+                 (interp-env body (zip xs vs) ds)
+                 'err)]))]
+        [_ 'err])]
+    [(FCall f es)
+      (match (interp-env f r ds)
+       [(? procedure? f) (f es r)]
+       [_ 'err])]
+    [_         'err]))
 
 ;; (Listof Expr) REnv Defns -> (Listof Value) | 'err
 (define (interp-env* es r ds)

langs/knock/test/test-runner.rkt

@@ -104,6 +104,16 @@
                                (+ x (tri (sub1 x)))))
                          (tri 9)))
                 45)
+  ;; Knock tests
+  (check-equal? (run
+                  '(begin (define (f x) x)
+                          (call (fun f) 42)))
+                42)
+  (check-equal? (run
+                  '(begin (define (f x) x)
+                          (define (g x) x)
+                          (call (car (cons (fun f) (cons (fun g) '()))) 42)))
+                42)
 #|
   (check-equal? (run
                  '(begin (define (even? x)