;; -*- Mode: Lisp; -*-
;; ---------------------------------------------------------------------------
;;     Title: Tiny Byte Code
;;   Created: 2020-03-08
;;    Author: Gilbert Baumann <gilbert@bauhh.de>
;; ---------------------------------------------------------------------------
;;  (c) copyright 2020 by Gilbert Baumann

(defpackage :alt-bc
  (:use :common-lisp)
  (:export #:bench #:fib))

(in-package :alt-bc)

;;;; -- Notes ---------------------------------------------------------------------------------

;; Since we now allocate the lexicals on the stack, we may consider to
;; have a 'value1' register as CLISP has, since a LET would otherwise
;; need to pop the result, skip, and push again.

;; OTOH doing so, we would need a PUSH instruction, to a PUSH flag to
;; instructions.

;;;; -- Symbols -------------------------------------------------------------------------------

;; ### Here is more needed: We also need to maintain a property
;; ### list. And we really also want some more properties like being a
;; ### compiler macro or, say, a constant.

(declaim (inline symval))

;; pick one:

#.(atom
   ;;(push :alt-bc-symbols-via-hash *features*)
   ;;(push :alt-bc-symbols-via-plist *features*)
   (push :alt-bc-symbols-via-shadows *features*)
   )

#+ALT-BC-SYMBOLS-VIA-HASH
(progn
  (defvar *global-env*
    (make-hash-table :test #'eq))

  (defun symval (sym)
    (multiple-value-bind (value foundp) (gethash sym *global-env*)
      (unless foundp
        (error "Symbol ~S is unbound." sym))
      value))

  (defun (setf symval) (new-value sym)
    (setf (gethash sym *global-env*) new-value))

  (defun bc-boundp (sym)
    (nth-value 1 (gethash sym *global-env*)))

  (defun bc-makunbound (sym)
    (remhash sym *global-env*)
    sym))

#+ALT-BC-SYMBOLS-VIA-PLIST
(progn
  (declaim (inline symval))
  (defun symval (sym)
    (let ((value (get sym 'value :unbound)))
      (when (eq value :unbound)
        (error "Symbol ~S is unbound." sym))
      value))

  (defun (setf symval) (new-value sym)
    (setf (get sym 'value) new-value)))

#+ALT-BC-SYMBOLS-VIA-SHADOWS
(progn
  (defvar *symbol-shadow*
    (make-hash-table :test #'eq))

  (defun symbol-shadow (symbol)
    (or (gethash symbol *symbol-shadow*)
        (setf (gethash symbol *symbol-shadow*)
              (cons symbol :unbound))))

  (defun symval (symbol)
    (cdr (symbol-shadow symbol)))

  (defun (setf symval) (value symbol)
    (setf (cdr (symbol-shadow symbol)) value)))

;;;; -- Initial Global Environment ------------------------------------------------------------

;; We just borrow our primitives.

(defmacro define-primitives (&rest primitives)
  `(progn
     ,@(mapcar (lambda (sym)
                 `(setf (symval ',(if (consp sym) (car sym) sym))
                        (function ,(if (consp sym) (cadr sym) sym))))
               primitives)
     t))

(define-primitives
    cons car cdr rplaca rplacd
    ;;
    consp atom symbolp numberp not null eq < > <= >= = /=
    ;;
    + - * / mod
    ;;
    (symbol-value symval)
    ;; (boundp bc-boundp)
    ;; (makunbound bc-makunbound)
    (set (lambda (sym val) (setf (symval sym) val)))
    ;;
    print
    list
    )

(setf (symval 'nil) nil)
(setf (symval 't) t)

;;;; -- Instruction Set -----------------------------------------------------------------------

;; (DUP n)              push (sp[n])
;; (SKIP n)             sp -= n
;; (SKIP* n)            x = pop(); sp -= n; push (x);
;; (STO n)              sp[n] = sp[0]

;; (GLOBAL sym)         push (symbol-value(sym))
;; (Q expr)             push (expr)

;; (CALL n)             do a call
;; (RETURN n)           res = pop (); skip (n); push (res); return;
;; (CLOSURE n pv)
;; (CREF n)             push (cv [n]);

;; (IF-FALSE L)         if (!pop ()) pc = L;
;; (GO L)               pc = L

;; (BOX n)              sp[n] = make_box (sp[n]);
;; (BOX-VALUE)          sp[0] = box_value (sp[0]);
;; (BOX-STORE)          box = pop (); box_value (box) = sp[0]

;; (CATCH-OPEN L)       tag = pop(); cpush (make-catch-frame (tag, L));
;; (THROW)              res = pop(); tag = pop();
;; (CSKIP n)            csp -= n;

;;;; -- Compiler ------------------------------------------------------------------------------

;;; Implemented special operators:

;; quote
;; if
;; setq
;; progn
;; let
;; let*
;; lambda
;; tagbody / go
;; catch / throw

(defmacro comp (form &key (env 'env)
                          (tailp 'tailp)
                          (nstack 'nstack)
                          (nbind 'nbind)
                          (ncontrol 'ncontrol)
                          (level 'level)
                          (closure 'closure))
  `(comp-1 ,form ,env ,tailp ,nstack ,nbind ,ncontrol ,level ,closure))

(defun compile-form (form)
  (comp form :env nil :tailp nil :nstack 0 :nbind 0 :ncontrol 0 :level 0
        :closure nil))

(defgeneric comp-2 (operator form env tailp nstack nbind ncontrol level closure))

(defmacro define-compiler (operator parameters &body body)
  `(progn
     (defmethod comp-2 ((operator
                         ,(if (eq operator 't)
                              't
                              `(eql ',operator)))
                        form env tailp nstack nbind ncontrol level closure)
       (declare (ignorable env tailp nstack nbind ncontrol level closure))
       (destructuring-bind ,parameters (cdr form)
         ,@body))
     ',operator))

(defstruct lexical-var
  symbol
  stack-pos
  level
  closed-over-p)

(defstruct comp-closure
  ;; This is also sticked into the environment
  nreq
  restp
  cv
  closed-pass)

(defstruct tag
  name
  label
  nstack
  ncontrol
  level)

(defun comp-1 (form env tailp nstack nbind ncontrol level closure)
  (cond
    ((symbolp form)
     (comp-sym form env tailp nstack nbind ncontrol level closure))
    ((atom form)
     (list `(q ,form)))
    ((symbolp (car form))
     (comp-2 (car form) form env tailp nstack nbind ncontrol level closure))
    (t
     (error "Bad function - ~S" (car form))) ))

(defun find-lexical (sym env)
  ;; -> :stack n          lexical in this env
  ;; -> :cv n             n'th in the closure vector
  ;; -> :global sym       global, hence free
  (let ((closures nil))                 ;stack of closures passed by
    (dolist (q env
             ;; not found
             (values :global sym))
      (cond ((comp-closure-p q)
             (push q closures))
            ((and (lexical-var-p q)
                  (eq (lexical-var-symbol q) sym))
             (return (found-lexical sym q closures)))))))

(defun found-lexical (sym lex closures)
  (declare (ignore sym))
  (cond ((null closures)
         (values :stack lex))
        (t
         ;; Mark lexical-var needing to be closed over
         (setf (lexical-var-closed-over-p lex) t)
         ;; Allocate in all closures
         (dolist (q closures)
           (unless (find lex (comp-closure-cv q))
             (setf (comp-closure-cv q)
                   (nconc (comp-closure-cv q) (list lex)))))
         ;;
         (values :cv (position lex (comp-closure-cv (car (last closures))))))))

(defun comp-sym (sym env tailp nstack nbind ncontrol level closure)
  (declare (ignorable env tailp nstack nbind ncontrol level closure))
  (multiple-value-bind (kind info) (find-lexical sym env)
    (ecase kind
      (:stack
       (list `(dup ,(- nstack (lexical-var-stack-pos info)) ,info)))
      (:global
       #+ALT-BC-SYMBOLS-VIA-SHADOWS
       (list `(global ,(symbol-shadow info)))
       #-ALT-BC-SYMBOLS-VIA-SHADOWS
       (list `(global ,info)) )
      (:cv
       (list `(cref.b ,info) )))))

(define-compiler quote (expr)
  (list `(q ,expr)))

(define-compiler if (test consequence &optional alternative)
  (let ((L1 (gensym "L."))
        (L2 (gensym "L.")))
    (nconc
     (comp test :tailp nil)
     (list `(if-false ,L1))
     (comp consequence)
     (list `(go ,L2))
     (list L1)
     (comp alternative)
     (list L2))))

(define-compiler setq (var val)
  (multiple-value-bind (kind info) (find-lexical var env)
    (ecase kind
      (:stack
       (nconc
        (prog1 (comp val :tailp nil) (incf nstack))
        (list `(sto ,(- nstack (lexical-var-stack-pos info)) ,info))))
      (:cv
       (list `(cref ,info)
             `(box-store)))
      (:global
       (comp `(set ',var ,val))))))

(define-compiler progn (&rest forms)
  (nconc (mapcan (lambda (form)
                   (nconc (comp form :tailp nil)
                          (list '(skip 1))))
                 (butlast forms))
         (comp (car (last forms)))))

(define-compiler let (bindings &rest forms)
  (let ((nenv env))
    (nconc
     (mapcan (lambda (binding)
               (let ((lex (make-lexical-var
                           :symbol (binding-var binding)
                           :stack-pos (1+ nstack)
                           :level level
                           :closed-over-p nil)))
                 (push lex nenv)
                 (prog1
                     (nconc
                      (comp (binding-val binding) :tailp nil)
                      (list `(box? 0 ,lex)))
                   (incf nstack))))
             bindings)
     (comp `(progn ,@forms) :env nenv)
     (list `(skip* ,(length bindings))))))

(define-compiler let* (bindings &rest forms)
  ;; ### make a LET-AUX
  (let ((nenv env))
    (nconc
     (mapcan (lambda (binding)
               (let ((lex (make-lexical-var
                           :symbol (binding-var binding)
                           :stack-pos (1+ nstack)
                           :level level
                           :closed-over-p nil)))
                 (prog1
                     (nconc
                      (comp (binding-val binding) :tailp nil :env nenv)
                      (list `(box? 0 ,lex)))
                   (incf nstack)
                   (push lex nenv))))
             bindings)
     (comp `(progn ,@forms) :env nenv)
     (list `(skip* ,(length bindings))))))

(defparameter +call-offset+ 3)

(define-compiler lambda (lambda-list &body body)
  (multiple-value-bind (req rest) (reverse* lambda-list)
    (let ((closure (make-comp-closure
                    :nreq (length req)
                    :restp (not (null rest))
                    :cv nil))
          (nenv env))
      ;;
      (push closure nenv)
      ;;
      (let* ((nreq (comp-closure-nreq closure))
             (restp (comp-closure-restp closure))
             (ntotal (+ nreq (if restp 1 0)))
             (boxing nil))
        ;; Construct the new environment
        (let* ((all (append (if rest (list rest)) req)))
          (do ((q all (cdr q))
               (k (- +call-offset+) (- k 1)))
              ((null q))
            (let ((lex (make-lexical-var
                        :symbol (car q)
                        :stack-pos k
                        :level level
                        :closed-over-p nil)))
              (push `(box? ,k ,lex) boxing)
              (push lex nenv))))
        ;; compile the body
        (let ((body (nconc
                     boxing
                     (comp `(progn ,@body)
                           :nstack 0
                           :ncontrol 0
                           :level (1+ level)
                           :tailp t
                           :env nenv)
                     (list `(return ,ntotal)))))
          (nconc
           (mapcan (lambda (v)
                     (prog1
                         (multiple-value-bind (kind info)
                             (find-lexical (lexical-var-symbol v) env)
                           (ecase kind
                             (:cv (list `(cref ,info)))
                             (:stack
                              (list `(dup* ,(- nstack (lexical-var-stack-pos info)))))))
                       (incf nstack)))
                   (reverse (comp-closure-cv closure)))
           (list
            `(closure
              ,(length (comp-closure-cv closure))
              ,(coerce (asm2
                        (asm body)
                        #+NIL
                        (list* `(function-header ,nreq ,restp)
                               (asm body)))
                       'vector)))))))))

(defun find-tag (name env)
  (dolist (q env)
    (cond ((and (tag-p q) (eql (tag-name q) name))
           (return q)))))

(define-compiler tagbody (&rest forms)
  (dolist (q forms)
    (when (atom q)
      (push (make-tag :name q
                      :label (gensym "T.")
                      :nstack nstack
                      :ncontrol ncontrol
                      :level level)
            env)))
  (nconc
   (mapcan (lambda (form)
             (cond ((atom form)
                    (list (tag-label (find-tag form env))))
                   (t
                    (nconc (comp form) (list '(skip 1))))))
           forms)
   (comp 'nil)))

(define-compiler go (tag)
  (let ((def (find-tag tag env)))
    (unless def
      (error "Undefined GO tag - ~S" tag))
    (unless (= (tag-level def) level)
      (error "Non-local exits not supported."))
    (nconc
     (let ((d (- nstack (tag-nstack def))))
       (unless (= 0 d)
         (list `(skip ,d))))
     (let ((d (- ncontrol (tag-ncontrol def))))
       (unless (= 0 d)
         (list `(cskip ,d))))
     (list `(go ,(tag-label def))))))

(define-compiler catch (tag &body body)
  (let ((L (gensym "L.")))
    (nconc
     (comp tag)
     (prog1 (list `(catch-open ,L)) (incf ncontrol))
     (comp `(progn ,@body))
     (prog1 (list '(cskip 1)) (decf ncontrol))
     (list L))))

(define-compiler throw (tag result)
  ;; without multiple values this is like a function call.
  (nconc
   (prog1 (comp tag) (incf nstack))
   (comp result)
   (list '(throw))))

(defun reverse* (list)
  (let ((res nil))
    (do ((q list (cdr q)))
        ((atom q)
         (values res q))
      (push (car q) res))))

(define-compiler t (&rest arguments)
  (cond #-NIL
        ((member operator '(+ - <=))
         (nconc (mapcan (lambda (form)
                          (prog1
                              (comp form :tailp nil)
                            (incf nstack)))
                        arguments)
                (list (list operator))))
        (t
         (nconc (mapcan (lambda (form)
                          (prog1
                              (comp form :tailp nil)
                            (incf nstack)))
                        form)
                (list `(call ,(length arguments) ,tailp))))))

(defun binding-var (binding)
  (if (symbolp binding)
      binding
      (car binding)))

(defun binding-val (binding)
  (if (symbolp binding)
      nil
      (cadr binding)))

;;;

(defun asm (ops)
  (mapcan (lambda (op)
            (cond ((atom op)
                   (list op))
                  (t
                   (case (car op)
                     ((dup)
                      (cond ((lexical-var-closed-over-p (third op))
                             (list `(dup ,(second op))
                                   `(box-value)))
                            (t
                             (list `(dup ,(second op))))))
                     ((sto)
                      (cond ((lexical-var-closed-over-p (third op))
                             (list `(dup ,(second op))
                                   `(box-store)))
                            (t
                             (list `(sto ,(second op))))))
                     ((box?)
                      (cond ((lexical-var-closed-over-p (third op))
                             (list `(box ,(second op))))
                            (t
                             nil)))
                     ((dup*)
                      (list `(dup ,(cadr op))))
                     #+NIL
                     ((if-false go)
                      (list `(,(car op)
                               ,(cdr (member (cadr op) ops)))))
                     (t
                      (list op))))))
          ops))

(defun asm2 (ops)
  ;; This turns labels in GO, IF-FALSE and CATCH into offsets
  (labels ((find-tag (tag)
             (let ((pc 0))
               (dolist (q ops)
                 (cond ((eql q tag)
                        (return pc))
                       ((atom q))
                       (t
                        (incf pc)))))))
    (mapcan (lambda (op)
              (cond ((atom op) nil)
                    ((member (car op) '(if-false go catch-open))
                     (list (list (car op) (find-tag (cadr op)))))
                    (t
                     (list op))))
            ops)))

;;;; -- Interpreter ---------------------------------------------------------------------------

(defvar *insn-count* 0)

(defstruct closure
  pv                                    ;code ["program"] vector
  cv)                                   ;closure vector

(declaim (inline box box-value (setf box-value)))

(defun box (x)
  (declare (optimize (speed 3) (safety 0)))
  (cons 'box x))

(defun box-value (x)
  (declare (optimize (speed 3) (safety 0)))
  (cdr x))

(defun (setf box-value) (v x)
  (declare (optimize (speed 3) (safety 0)))
  (setf (cdr x) v))

(eval-when (:compile-toplevel :execute :load-toplevel)
  (defparameter +optimization+ '(optimize (speed 3) (safety 0))))

(defun run-loop (closure)
  ;; CPU: Intel(R) Xeon(R) CPU E3-1276 v3 @ 3.60GHz
  ;; 247MIPS with SBCL
  ;; 115MIPS with CCL
  (declare #.+optimization+)
  (let ((%pc 0)
        (%pv (closure-pv closure))
        (%cv (closure-cv closure))
        (%stack (make-array 1000))
        (%sp 0)
        (ninsn 0) )
    (declare (ignorable ninsn)
             (type fixnum %pc %sp ninsn)
             (type simple-vector %pv %cv %stack))
    (macrolet ((%arg ()         `(cadr insn))
               (%arg1 ()        `(caddr insn))
               ;;
               (%push (val)
                 `(let ((g ,val))
                    (incf %sp) (setf (aref %stack %sp) g)))
               (%pop ()
                 `(prog1 (aref %stack %sp) (decf %sp)))
               (%tos (&optional (n 0))
                 `(aref %stack (- %sp (the fixnum ,n))))
               (%skip (n)
                 `(decf %sp (the fixnum ,n)))
               ;;
               (%label-pc (tag)
                 tag) )
      (loop
        (let ((insn (aref %pv %pc)))
          (incf %pc)
          (incf ninsn)
          ;; (print insn) (force-output) (sleep .1)
          (when (consp insn)
            (ecase (car insn)
              ((dup)
               (%push (%tos (the fixnum (%arg)))))
              ((sto)
               (setf (%tos (%arg)) (%tos)))
              ((global)
               #+ALT-BC-SYMBOLS-VIA-SHADOWS
               (%push (cdr (%arg)))
               #-ALT-BC-SYMBOLS-VIA-SHADOWS
               (%push (symval (%arg))) )
              ((q)
               (%push (%arg)))
              ((skip)
               (%skip (%arg)))
              ((skip*)
               (let ((x (%pop)))
                 (%skip (%arg))
                 (%push x)))
              ((if-false)
               ;; (print (%arg)) (force-output) (sleep .1)
               (
                unless (%pop)
                 ;; when (eq :false (%pop))
                 (setq %pc (%label-pc (%arg)))))
              ((go)
               (setq %pc (%label-pc (%arg))))
              ((call)
               (let* ((narg (%arg))
                      (fun (%tos narg)))
                 (declare (type fixnum narg))
                 (cond (t ;; (closure-p fun)
                        (let ()
                          (%push %pc)
                          (%push %pv)
                          (%push %cv)
                          (setf %pc 0
                                %pv (closure-pv fun)
                                %cv (closure-cv fun))))
                       #+NIL
                       ((functionp fun)
                        (case narg
                          (2
                           (let ((a1 (%pop))
                                 (a0 (%pop)))
                             (setf (%tos) (funcall fun a0 a1))))
                          (otherwise
                           (let ((args nil))
                             (dotimes (i narg)
                               (push (%pop) args))
                             (setf (%tos) (apply fun args))))))
                       (t
                        (error "Bad function - ~S" fun)))))
              ((return)
               (let ((n (%arg))
                     (res (%pop)))
                 (declare (type fixnum n))
                 (setf %cv (%pop)
                       %pv (%pop)
                       %pc (%pop))
                 (%skip n)
                 (setf (%tos) res)))
              ((+)
               (let* ((b (%pop))
                      (a (%tos))
                      (r (locally (declare (optimize (speed 1) (safety 1)))
                           (+ a b))))
                 (setf (%tos) r)))
              ((-)
               (let* ((b (%pop))
                      (a (%tos))
                      (r (locally (declare (optimize (speed 1) (safety 1)))
                           (- a b))))
                 (setf (%tos) r)))
              ((<=)
               (let* ((b (%pop))
                      (a (%tos))
                      (r (locally (declare (optimize (speed 1) (safety 1)))
                           (<= a b))))
                 (setf (%tos)
                       ;; (if r :true :false)
                       r
                       )))
              #||
              ((+) (let ((b (%pop))) (setf (%tos) (+ (%tos) b))))
              ((-) (let ((b (%pop))) (setf (%tos) (- (%tos) b))))
              ((<=) (let ((b (%pop))) (setf (%tos) (<= (%tos) b))))
              ||#
              ((cref)
               (%push (aref %cv (the fixnum (%arg)))))
              ((cref.b)
               (%push (cdr (aref %cv (the fixnum (%arg))))))
              ((box)
               (setf (%tos (%arg)) (box (%tos (%arg)))))
              ((box-value)
               ;; (setf (%tos) (box-value (%tos)))
               (setf (%tos) (cdr (%tos)))
               )
              ((box-store)
               (let ((box (%pop)))
                 (setf (box-value box) (%tos))))
              ((closure)
               (let ((n (%arg)))
                 (declare (type fixnum n))
                 (let ((new-cv (make-array n)))
                   (dotimes (i n)
                     (setf (aref new-cv i) (%pop)))
                   (%push (make-closure
                           :pv (%arg1)
                           :cv new-cv)))))
              ((function-header)
               )
              ((halt)
               (locally (declare (optimize (speed 1) (safety 1)))
                 (incf *insn-count* ninsn))
               (return-from run-loop (values (%pop) ninsn)))
              )))) )))

;;;; -- Benchmark -----------------------------------------------------------------------------

(defun e (x)
  (let ((code (asm (compile-form x))))
    #+NIL
    (let ((*print-pretty* t)
          (*print-circle* t))
      (print (cons 'tagbody code)))
    (run-loop
     (make-closure
      :pv (coerce (asm2 (nconc code (list '(halt)))) 'vector)
      :cv #()))))

(defun show-cpu (&aux p)
  (when (probe-file "/proc/cpuinfo")
    (with-open-file (input "/proc/cpuinfo")
      (loop for line = (read-line input nil nil)
            while line
            do (when (and (eql 0 (search "model name" line))
                          (setq p (position #\: line)))
                 (format t ";; CPU: ~A~%" (string-trim " " (subseq line (1+ p))))
                 (return))))))

(defun bench (&optional (form '(fib 25)))
  (let ((*package* (find-package #.(package-name *package*))))
    ;; Define the FIB function:
    (setf (symval 'fib)
          (e '(lambda (n)
               (if (<= n 1)
                   1
                   (+ (fib (- n 2)) (fib (- n 1)))))))
    ;;
    (setf (symval 'cfib)
          ;; Use a LABELS. This way we don't go through a symbol for
          ;; FIB in FIB. This is warranted by the ANSI spec.
          (e '(lambda (n)
               (let (fib)
                 (setq fib (lambda (n)
                             (if (<= n 1)
                                 1
                                 (+ (fib (- n 2)) (fib (- n 1))))))
                 (fib n)))))
    ;;
    (format t ";; ~A ~A~%" (lisp-implementation-type) (lisp-implementation-version))
    (show-cpu)
    (format t ";; Optimization: ~S~%" +optimization+)
    (format t ";;~%")
    (let* ((code
            (make-closure
             :pv (coerce (asm2 (nconc (asm (compile-form form))
                                      (list '(halt)))) 'vector)
             :cv #())))
      (dotimes (i 10)
        (let ((t0 (get-internal-run-time))
              t1
              (n 100))
          (setq *insn-count* 0)
          (loop repeat n do (run-loop code))
          (setq t1 (- (get-internal-run-time) t0))
          ;; (setq +fib-insns+ *insn-count*)
          (setq t1 (/ t1 n)
                *insn-count* (ceiling *insn-count* n))
          (format t "~&~12:D insns      ~4,2F MIPS ~10:Dus    ~S~%"
                  *insn-count*
                  (/ (/ *insn-count* (/ t1 internal-time-units-per-second))
                     1e6)
                  (round (/ t1 1/1000000 internal-time-units-per-second))
                  form)
          nil)))))

;;;; -- Herald --------------------------------------------------------------------------------

(format
 t ";;~%~
    ;; To run the benchmark type:~%~
    ;;~%~
    ;;    (alt-bc:bench)~%~
    ;;~%~
    ;; or e.g.~%~
    ;;    (alt-bc:bench '(alt-bc:fib 30))~%~
    ;;    (alt-bc:bench '(alt-bc:cfib 25))~%~
    ;;~%~
    ;;~%")