A Nock Interpreter and Compiler in Common Lisp #Urbit

nock.lisp

;; A nock interpreter
(defun tar (a f)
  (labels ((fas (b a)
	     (declare (integer b))
	     (cond
               ((= b 1) a)
               ((= b 2) (car a))
               ((= b 3) (cdr a))
               ((evenp b) (car (fas (/ b 2) a)))
               ((oddp b) (cdr (fas (/ (1- (the integer b)) 2) a))))))
    
        (if (consp (car f))
            (cons
             (tar a (car f))
             (tar a (cdr f)))
          (case (car f)
                (0 (let ((b (cdr f)))
                     (fas b a)))
                (1 (cdr f))
                (2 (let ((b (cadr f))
                         (c (cddr f)))
		     (let ((x (tar a b))
			   (y (tar a c)))
		       (tar x y))))
                (3 (let ((b (cdr f)))
		     (let ((x (tar a b)))
		       (if (consp x) 0 1))))
                (4 (let ((b (cdr f)))
		     (let ((x (tar a b)))
		       (1+ (the integer x)))))
                (5 (let ((b (cdr f)))
		     (let ((x (tar a b)))
		       (if (= (the integer (car x)) (the integer (cdr x))) 0 1))))
		(6 (let ((b (cadr f))
			 (c (caddr f))
			 (d (cdddr f)))
		     (tar a `(2 (0 . 1) 2 (1 ,c . ,d) (1 . 0) 2
			      (1 2 . 3) (1 . 0) 4 4 . ,b))))
		(7 (let ((b (cadr f))
			 (c (cddr f)))
		     (tar a `(2 ,b 1 . ,c))))
		(8 (let ((b (cadr f))
			 (c (cddr f)))
		     (tar a `(7 ((7 (0 . 1) . ,b) 0 . 1) . ,c))))
		(9 (let ((b (cadr f))
			 (c (cddr f)))
		     (tar a `(7 ,c 2 (0 . 1) 0 . ,b))))
		))))

;; A nock compiler
(defun dao (f)
  (declare (inline cons car cdr 1+))
  (labels
      ((fas (b)
	 (declare (integer b))
	 (cond
	   ((= b 1) 'a)
	   ((= b 2) '(car a))
	   ((= b 3) '(cdr a))
	   ((evenp b) `(car ,(fas (/ b 2))))
	   ((oddp b)
	    `(cdr ,(fas (/ (1- b) 2)))))))
    (declare (inline fas))
    (if (or (integerp f)
	    (symbolp f))
	f
	(if (consp (car f))
	    (let ((m (dao (car f)))
		  (n (dao (cdr f))))
	      `(cons ,m ,n))
	    (case (car f)
	      (0 (fas (cdr f)))
	      (1 (if (or (integerp (cdr f))
			 (symbolp (cdr f)))
		     (cdr f)
		     `',(cdr f)))
	      (2 (let ((bc (dao (cadr f)))
		       (d (dao (cddr f))))
		   (if (eq (car d) 'quote)
		       (let ((x (dao (cadr d))))
			 (if (or (eq bc 'a)
				 (integerp x))
			     x
			     `(let ((a ,bc))
				,x)))
		       `(funcall (the function (phi ,d a)) ,bc))))
	      (3 `(if (consp ,(dao (cdr f))) 0 1))
	      (4 `(1+ (the integer ,(dao (cdr f)))))
	      (5 (destructuring-bind (m . n) (cdr f)
		   `(if (= ,(dao m) ,(dao n)) 0 1)))
	      (6 (let ((b (dao (cadr f)))
		       (c (dao (caddr f)))
		       (d (dao (cdddr f))))
		   `(if (= (the integer ,b) 0)
			,c ,d)))
	      (7 (let ((b (dao (cadr f)))
		       (c (dao (cddr f))))
		   `(flet ((f (a) ,b)
			   (g (a) ,c))
		      (declare (inline f g))
		      (g (f a)))))
	      (8 (let ((b (dao (cadr f)))
		       (c (dao (cddr f))))
		   `(let ((a (cons ,b a)))
		      ,c)))
	      (9
	       (let ((b (dao (cadr f)))
		     (c (dao (cddr f))))
		 `(flet ((f (a) ,c))
		    (declare (inline f))
		    (let ((x (f a)))
		      (funcall (the function
				    (phi (let ((a x))
					    ,(fas b)))) x))))))
	      ))))

;; A nock compiler driver
(defparameter cache (make-hash-table :test #'equal))
(defun phi (f &optional a)
  (let ((compiled (gethash f cache)))
    (if compiled
	compiled
	(let ((code `(lambda (a)
		       (declare (optimize (speed 3) (safety 0)))
		       ,(dao f))))
	  (print code)
	  (setf (gethash f cache) (compile nil code))))))

#|
;; Running (dec 100.000.000)...
CL-USER> (time (tar 0 '(8 (8 (1 . 0) 8 (1 . 0) (1 6 (5 (4 0 . 14) 0 . 6) (0 . 14) 9 2 (0 . 2) (0 . 6) (4 0 . 14) 0 . 15) 0 . 1) 9 2 (0 . 4) (7 (0 . 3) 1 . 100000000) 0 . 11)))
Evaluation took:
  154.804 seconds of real time
  154.191088 seconds of total run time (151.147045 user, 3.044043 system)
  [ Run times consist of 4.769 seconds GC time, and 149.423 seconds non-GC time. ]
  99.60% CPU
  433,556,434,319 processor cycles
  195,199,995,456 bytes consed

99999999
CL-USER> (time (funcall (phi '(8 (8 (1 . 0) 8 (1 . 0) (1 6 (5 (4 0 . 14) 0 . 6) (0 . 14) 9 2 (0 . 2) (0 . 6) (4 0 . 14) 0 . 15) 0 . 1) 9 2 (0 . 4) (7 (0 . 3) 1 . 100000000) 0 . 11)) 0))
Evaluation took:
  2.575 seconds of real time
  2.563883 seconds of total run time (2.488210 user, 0.075673 system)
  [ Run times consist of 0.093 seconds GC time, and 2.471 seconds non-GC time. ]
  99.57% CPU
  7,212,489,149 processor cycles
  4,800,019,808 bytes consed

99999999
|#

This was my first "code compiler" I managed to write. First I wrote the interpreter (tar), then I added backticks and massaged it a bit to get the compiler (dao) and then wrote the compiler driver (phi). Was impressed with the speedup (154 seconds vs 2.5 seconds) with such little work and skill required to write it. Showed it to Curtis Yarvin, but didn't expect him to rewrite Urbit in Common Lisp.