;; -*- 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)

(eval-when (:compile-toplevel :execute :load-toplevel)
  (defvar *instruction-table* nil))

(eval-when (:compile-toplevel :execute :load-toplevel)
  (pushnew :linear-code *features*))

;;;; -- TODO ----------------------------------------------------------------------------------

;; - clean up the JIT, it's a mess
;;
;; - catch/throw in interpreter
;;
;; - (THROW) in JIT
;;
;; - Lisp-2 ?
;;
;; - argc check
;;
;; - rest args

;;;; -- 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))
    ((and (consp (car form))
          (eq 'lambda (caar form)))
     (comp (lambda-to-let form)))
    (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
       (nconc
        (prog1 (comp val :tailp nil) (incf nstack))
        (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
                        #+NIL
                        (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) :tailp nil)
     (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))))

(defvar *cur-fun* nil)

(define-compiler t (&rest arguments)
  (cond #-NIL
        ((member operator '(+ - <= >= < > * / = /= eq eql cons))
         (nconc (mapcan (lambda (form)
                          (prog1
                              (comp form :tailp nil)
                            (incf nstack)))
                        arguments)
                (list (list operator))))
        ((eq operator *cur-fun*)
         (nconc (prog1 (list `(q ,operator)) (incf nstack))
                (mapcan (lambda (form)
                          (prog1
                              (comp form :tailp nil)
                            (incf nstack)))
                        arguments)
                (list `(scall ,(length arguments) ,tailp))))
        (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))

(eval-when (:compile-toplevel :execute :load-toplevel)
  (defun opcode (x)
    (position x (reverse *instruction-table*) :key #'car)))

(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))
                       ((member (car q) '(call scall))
                        #+LINEAR-CODE (incf pc 2)
                        #-LINEAR-CODE (incf pc))
                       (t
                        #+LINEAR-CODE (incf pc (length q))
                        #-LINEAR-CODE (incf pc))))))
           )
    (mapcan (lambda (op)
              (cond ((atom op) nil)
                    ((member (car op) '(if-false go catch-open))
                     (#+LINEAR-CODE copy-list #-LINEAR-CODE list
                                    (list (opcode (car op)) (find-tag (cadr op)))))
                    ((member (car op) '(scall call))
                     (#+LINEAR-CODE copy-list #-LINEAR-CODE list
                                    (list (opcode (car op)) (cadr op))))
                    (t
                     (#+LINEAR-CODE copy-list #-LINEAR-CODE list
                                    (cons (opcode (car op)) (cdr 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))

(defmacro define-insn (name params &body body)
  (declare (ignore params))
  `(eval-when (:compile-toplevel :execute :load-toplevel)
     (progn
       (let ((q (assoc ',name *instruction-table*)))
         (unless q
           (push (setq q (list ',name)) *instruction-table*))
         (setf (cdr q) ',body))
       ',name)))

(define-insn dup ()
  (%push (%tos (the fixnum (%arg)))))

(define-insn sto ()
  (setf (%tos (%arg)) (%tos)))

(define-insn global ()
  #+ALT-BC-SYMBOLS-VIA-SHADOWS
  (%push (cdr (%arg)))
  #-ALT-BC-SYMBOLS-VIA-SHADOWS
  (%push (symval (%arg))) )

(define-insn q ()
  (%push (%arg)))

(define-insn skip ()
  (%skip (%arg)))

(define-insn skip* ()
  (let ((x (%pop)))
    (%skip (%arg))
    (%push x)))

(define-insn if-false ()
  (let ((target (%arg)))
    (unless (%pop)
      (setq %pc (%label-pc target)))))

(define-insn go ()
  (setq %pc (%label-pc (%arg))))

(define-insn call ()
  (let* ((narg (%arg))
         (fun (%tos narg)))
    (declare (type fixnum narg))
    (cond ((closure-p fun)
           (%push %pc)
           (%push %pv)
           (%push %cv)
           (setf %pc #+LINEAR-CODE 3 #-LINEAR-CODE 1
                 %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)))))

(define-insn scall ()
  (%arg)
  (%push %pc)
  (%push %pv)
  (%push %cv)
  (setf %pc 0))

(define-insn return ()
  (let ((n (%arg))
        (res (%pop)))
    (declare (type fixnum n))
    (setf %cv (%pop)
          %pv (%pop)
          %pc (%pop))
    (%skip n)
    (setf (%tos) res)))

(define-insn + ()
  (let* ((b (%pop))
         (a (%tos))
         (r (locally (declare (optimize (speed 1) (safety 1)))
              (+ a b))))
    (setf (%tos) r)))

(define-insn - ()
  (let* ((b (%pop))
         (a (%tos))
         (r (locally (declare (optimize (speed 1) (safety 1)))
              (- a b))))
    (setf (%tos) r)))

(define-insn <= ()
  (let* ((b (%pop))
         (a (%tos)))
    (setf (%tos)
          (locally (declare (optimize (speed 1) (safety 1)))
            (<= a b)))))

(define-insn cref ()
  (%push (aref %cv (the fixnum (%arg)))))

(define-insn cref.b ()
  (%push (cdr (aref %cv (the fixnum (%arg))))))

(define-insn box ()
  (let ((n (%arg)))
    (setf (%tos n) (box (%tos n)))))

(define-insn box-value ()
  ;; (setf (%tos) (box-value (%tos)))
  (setf (%tos) (cdr (%tos)))
  )

(define-insn box-store ()
  (let ((box (%pop)))
    (setf (box-value box) (%tos))))

(define-insn 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)))))

(define-insn function-header ()
  (%arg)
  (%arg1)
  )

(define-insn halt ()
  (locally (declare (optimize (speed 1) (safety 1)))
    (incf *insn-count* ninsn))
  (return-from run-loop (values (%pop) ninsn)))

;;

(defmacro %instruct-dispatch ()
  `(ecase #+LINEAR-CODE insn #-LINEAR-CODE (car insn)
     ,@(mapcar (lambda (x)
                 (cons (opcode (car x))
                       (cdr x)))
               (reverse *instruction-table*))))

;;

;; SBCL-2.0.2: 385MIPS (safety 0), 291MIPS (safety 1)

(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
  ;; 263MIPS with SBCL and SCALL
  ;; 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 (#-LINEAR-CODE
               (%arg ()         `(cadr insn))
               #-LINEAR-CODE
               (%arg1 ()        `(caddr insn))
               #+LINEAR-CODE
               (%arg () `(prog1 (aref %pv %pc) (incf %pc)))
               #+LINEAR-CODE
               (%arg1 () `(prog1 (aref %pv %pc) (incf %pc)))
               ;;
               (%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)
          '(progn(print (list (1- %pc)
                       (car (elt (reverse *instruction-table*) insn))
                       (ignore-errors (aref %pv %pc))
                       ))
          (force-output))
          (%instruct-dispatch))) )))

;;;; -- 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)
          (let ((*cur-fun* '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))~%~
    ;;~%~
    ;;~%")

;;;; -- JIT -----------------------------------------------------------------------------------

(defun setq-merge (body)
  (cond ((null body)
         nil)
        ((and (consp (car body))
              (eq (caar body) 'setq))
         (let ((res nil))
           (do ((q body (cdr q)))
               ((not (and (consp (car q))
                          (eq (caar q) 'setq)))
                (cons `(setq ,@(reverse res))
                      (setq-merge q)))
             (push (second (car q)) res)
             (push (third (car q)) res))))
        (t
         (cons (car body)
               (setq-merge (cdr body))))))




(defun compile-form-2 (form)
  (e `(lambda () ,form)))

(defun foo ()
  (compile-form-2
   '(let ((i 0))
     (tagbody
      10
        (if (>= i 10) (go 90))
        (print i)
        (setq i (+ i 1))
        (go 10)
      90))))

(defun foo ()
  (compile-form-2
   '(let ((i 0))
     (tagbody
      10
        (let ((x 'foo))
          (if (>= i 10)
              (progn
                (go 90)
                (print 'bar))))
        (print i)
        (setq i (+ i 1))
        (go 10)
      90))))

;;;; ------------------------------------------------------------------------------------------

(defun e2 (x)
  (funcall (compile nil (jit (compile-form-2 x)))))

(defun bench-jit (&optional (form '(fib 25)))
  (let ((*package* (find-package #.(package-name *package*))))
    ;; Define the FIB function:
    (setf (symbol-value 'fib)
          (e2 '(lambda (n)
               (if (<= n 1)
                   1
                   (+ (fib (- n 2)) (fib (- n 1)))))))
    ;;
    (setf (symbol-value 'cfib)
          ;; Use a LABELS. This way we don't go through a symbol for
          ;; FIB in FIB. This is warranted by the ANSI spec.
          (e2 '(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
            (e2 `(lambda () ,form))))
      (dotimes (i 10)
        (let ((t0 (get-internal-run-time))
              t1
              (n 100))
          (setq *insn-count* 0)
          (loop repeat n do (funcall 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)))))


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


;; Correct would be the follwoing: Starting with the CATCH-OPEN, we
;; would follow execution path until we hit a CSKIP. There could be
;; multiple CSKIPs. Then we would arrange for all those instructions
;; being removed from the main program vector and collected to a new
;; vector. Then each CSKIP will be compiled to a GO to the next
;; instruction, which will be found in the main program vector.

(defun de-global (x)
  (map 'vector (lambda (x)
                 (cond ((and (eq (car x) 'global)
                             (consp (cadr x)))
                        `(global ,(car (cadr x))))
                       (t x)))
       x))

(defun foo ()
  (progn ;;de-global
   (closure-pv
    (compile-form-2
     '(let ((x 10))
       (catch 'foo
         (print 'hi))
       (blah x))))))

(defun catch-separate (pv pc)
  (let* ((pv2 (make-array (length pv) :initial-element nil))
         (conts nil))
    (labels ((walk (pc)
               (unless (aref pv2 pc)
                 (let ((insn (aref pv pc)))
                   (psetf ;; (aref pv pc) '(nop)
                          (aref pv2 pc) (aref pv pc))
                   (case (car insn)
                     ((go)
                      (walk (cadr insn)))
                     ((if-false)
                      (walk (1+ pc))
                      (walk (cadr insn)))
                     ((return))
                     ((cskip)
                      ;; ### *sigh* we also must know the stack offset
                      (push (1+ pc) conts)
                      (setf (aref pv2 pc) `(go* ,(1+ pc))))
                     (otherwise
                      (walk (1+ pc))))))))
      (walk (1+ pc))
      (values pv2 conts))))

(defun bar ()
  (let* ((pv (foo))
         (k (position 'catch-open pv :key #'car)))
    (multiple-value-bind (pv2 conts)
        (catch-separate pv k)
      (values pv pv2 conts))))

(defun foo ()
  (progn ;;de-global
    (closure-pv
     (compile-form-2
      '(let ((x 10))
        (tagbody
           (blup
            (catch 'foo
             (if (< x 10) (go fail))
             (print 'hi)
             :catch-value))
           (blah x)
           (go done)
         fail
           (fail)
         done
           ))))))

(defun foo ()
  (progn ;;de-global
    (closure-pv
     (compile-form-2
      '(let ((x 10))
        (tagbody
           (blup
            (catch 'foo
             (print 'hi)
             :catch-value))
           (blah x)
           (go done)
         fail
           (fail)
         done
           ))))))

(defun foo ()                           ;<--
  (progn ;;de-global
    (closure-pv
     (compile-form-2
      '(progn ;;let ((x 10))
        (tagbody
           (catch 'foo
             (if (< x 10) (go fail))
             (print 'hi)
             :catch-value)
           (blah x)
           (go done)
         fail
           (fail)
         done
           ))))))

(defun foo ()
  (cons 'tagbody
        (asm
         (compile-form
          '(let ((x 10))
            (tagbody
               (blup
                (catch 'foo
                  (if (< x 10) (go fail))
                  (print 'hi)
                  :catch-value))
               (blah x)
               (go done)
             fail
               (fail)
             done
               ))))))

;; CSKIP n/=1
;; label in catch-open

(defun foo (&aux (*gensym-counter* 1))                           ;<--
  (let ((form
         '(let ((x 10))
           (tagbody
              (catch 'foo
                (if (< x 10) (go fail))
                (print 'hi)
                :catch-value)
              (blah x)
              (go done)
            fail
              (fail)
            done
              ))))
    (let ((*print-circle* nil))
      (print (cons 'tagbody (asm (compile-form form))))
      (terpri))
    (progn ;;de-global
      (closure-pv
       (compile-form-2
        form)))))

(defun foo (&aux (*gensym-counter* 1))  ;<--
  (let ((form
         '(foo
           (catch 'bar
             ))))
    (let ((*print-circle* nil))
      (print (cons 'tagbody (asm (compile-form form))))
      (terpri))
    (progn ;;de-global
      (closure-pv
       (compile-form-2
        form)))))

;;;; ------------------------------------------------------------------------------------------

(defun lambda-to-let (form)
  (let ((params (cadr (car form)))
        (body (cddr (car form)))
        (args (cdr form)))
    (labels ((foo (p a)
               (cond ((null p) nil)
                     ((symbolp p) (list `(,p (list ,@a))))
                     (t
                      (cons `(,(car p) ,(car a))
                            (foo (cdr p) (cdr a)))))))
      `(let ,(foo params args)
         ,@body))))

;;;; ------------------------------------------------------------------------------------------

(defun jit (closure)
  (nth-value 0 (jit-3 (closure-pv closure) 0 -1 t)))

(defun jit-3 (pv pc sp &optional lambdap)
  ;; -> code; todo2; tags2; max-sp
  (let* ((narg
          (let ((header (aref pv 0)))
            (+ (second header) (if (third header) 1 0))))
         (done (make-array (length pv) :initial-element nil))
         (tags nil)                     ;x
         (tags2 nil)                    ;x
         (todo nil)                     ;x
         (todo2 nil)                    ;x
         (code (make-array (length pv) :initial-element nil)) ;x
         (max-sp 0))
    (labels ((s (k)
               (let ((p (if '(= level 0)
                            ""
                            (format nil ".~D." level))))
                 (cond ((< k 0)
                        (intern (format nil "%A~A~D" p (+ k 3 narg))))
                       (t
                        (setq max-sp (max max-sp k))
                        (intern (format nil "%R~A~D" p k))))))
             ;;
             (c (k)
               (intern (format nil "%C~D" k)))
             ;;
             (walk (pc sp)
               (unless (aref done pc)
                 (setf (aref done pc) t)
                 (setf (aref code pc)
                       (multiple-value-bind (code new-sp)
                           (compile-insn (aref pv pc) pc sp)
                         (setq sp new-sp)
                         code)))
               (unless (member (car (aref pv pc)) '(go go* cskip return catch-open))
                 (walk (1+ pc) sp)))
             ;;
             (compile-insn (insn pc sp)
               (values
                (ecase (car insn)
                  ((dup)
                   (incf sp)
                   (list `(setq ,(s sp) ,(s (- sp (cadr insn) 1)))))
                  ((sto)
                   (list `(setq ,(s (- sp (cadr insn))) ,(s sp))))
                  ((skip*)
                   (prog1
                       (list `(setq ,(s (- sp (cadr insn))) ,(s sp)))
                     (decf sp (cadr insn))))
                  ((q)
                   (incf sp)
                   (list `(setq ,(s sp) ',(cadr insn))))
                  ((+ - <= >= < > * / = /= eq eql cons)
                   (decf sp)
                   (list `(setq ,(s sp) (,(car insn) ,(s sp) ,(s (1+ sp))))))
                  ((go)
                   (let ((tag (cadr insn)))
                     (pushnew tag tags)
                     (unless (aref done tag)
                       (pushnew (list tag sp) todo))
                     (list `(go ,tag))))
                  ;;
                  ((cskip)
                   (let ((tag (+ pc 1)))
                     (push (list tag sp) todo2)
                     (push tag tags2)
                     (list `(go ,tag))))
                  ((go*)
                   ;; This is an exit out of a control frame
                   (let ((tag (cadr insn)))
                     (push (list tag sp) todo2)
                     (list `(go ,tag))))
                  ;;
                  ((if-false)
                   (let ((tag (cadr insn)))
                     (decf sp)
                     (pushnew tag tags)
                     (unless (aref done tag)
                       (pushnew (list tag sp) todo))
                     (list `(unless ,(s (1+ sp)) (go ,tag)))))
                  ((global)
                   (incf sp)
                   (list `(setq ,(s sp) ,(car (cadr insn)))))
                  ((call)
                   (let ((n (cadr insn)))
                     (decf sp n)
                     (list
                      `(setq
                        ,(s sp)
                        (funcall ,@(loop for k from sp to (+ sp n)
                                         collect (s k)))))))
                  ((function-header)
                   nil)
                  ((return)
                   (list `(return ,(s 0))))
                  ((skip)
                   (decf sp (cadr insn))
                   nil)
                  ;;
                  ((box)
                   (list `(setq ,(s (+ sp (cadr insn))) (box ,(s (+ sp (cadr insn)))))))
                  ((cref.b)
                   (incf sp)
                   (list `(setq ,(s sp) (box-value ,(c (cadr insn))))))
                  ((cref)
                   (incf sp)
                   (list `(setq ,(s sp) ,(c (cadr insn)))))
                  ((box-value)
                   (list `(setq ,(s sp) (box-value ,(s sp)))))
                  ((box-store)
                   (decf sp)
                   (list `(setf (box-value ,(s (1+ sp))) ,(s sp))))
                  ((closure)
                   (let ((n (cadr insn))
                         (c (caddr insn)))
                     (decf sp (1- n))
                     (let ((cv (loop
                                     for i from 0
                                     for k from sp below (+ sp n)
                                     collect (list (c i) (s k)))))
                       (list
                        `(setq ,(s sp)
                               (let ,cv
                                 ,(jit-3 c 0 -1 t)))))))
                  ;;
                  ((catch-open)
                   (multiple-value-bind (code todo2 tags2 max-sp2)
                       (jit-3 pv (1+ pc) (1- sp))
                     (dolist (k todo2)
                       (push k todo))
                     (dolist (k tags2)
                       (push k tags))
                     (setf max-sp (max max-sp max-sp2))
                     (list `(setq
                             ,(s sp)
                             (catch ,(s sp)
                               (tagbody
                                  ,@code))))))
                  )
                sp))
             ;;
             (flatten (code)
               (let ((pc -1))
                 (progn ;;setq-merge
                 (mapcan (lambda (x)
                           (incf pc)
                           (nconc
                            (if (member pc tags) (list pc) nil)
                            x))
                         (coerce code 'list)))))
             )
      (push (list pc sp) todo)
      (do () ((null todo)) (apply #'walk (pop todo)))
      (setq code (flatten code))
      (when lambdap
        (setq code `(lambda ,(loop for i from (- 0 3 narg) below -3 collect (s i))
                      ;; (declare (optimize (speed 0) (safety 3) (debug 3)))
                      (prog ,(loop for i to max-sp collect (s i))
                         ,@code))))
      (values code todo2 tags2 max-sp))))