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
|#