Skip to content

Instantly share code, notes, and snippets.

@burtonsamograd

burtonsamograd/nock.lisp

Created October 9, 2015 02:48
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save burtonsamograd/29103c2dfaa67f4fd344 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save burtonsamograd/29103c2dfaa67f4fd344 to your computer and use it in GitHub Desktop.
Download ZIP

Revisions

  1. burtonsamograd created this gist Oct 9, 2015.
    151 changes: 151 additions & 0 deletions nock.lisp
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,151 @@
    ;; 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
    |#