;; -*- Mode: Lisp; -*-
;; ---------------------------------------------------------------------------
;;     Title: A primitive byte code
;;   Created: 2020-03-01
;;    Author: Gilbert Baumann
;;   License: MIT style (see below)
;; ---------------------------------------------------------------------------
;;  (c) copyright 2020 by Gilbert Baumann

(defpackage :pico-bc
  (:use :common-lisp))

(in-package :pico-bc)

(eval-when (:compile-toplevel :execute :load-toplevel)
  ;; Whether %TOS is a local function in RUN-LOOP, pick one
  ;; (pushnew :tos-is-function *features*)
  (setf *features* (remove :tos-is-function *features*))
  )

(eval-when (:compile-toplevel :execute :load-toplevel)
  ;; Whether to thse (SETF %TOS) or name it SET-%TOS
  ;; (pushnew :set-tos *features*)
  ;; (setf *features* (remove :tos-is-function *features*))
  )

;; Run (PICO-BC::BENCH)

;;;; -- Overview ------------------------------------------------------------------------------

;;;; -- 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.

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

#-NIL
(progn
  (declaim (inline symval))

  (defun symval (x) (symbol-value x))
  (defun (setf symval) (v x) (setf (symbol-value x) v)))

#+NIL
(progn
  (defvar *shadows*
    (make-hash-table :test #'eq))

  (declaim (inline shadow-value (setf shadow-value)))
  (defun shadow-value (x) (cdr x))
  (defun (setf shadow-value) (v x) (setf (cdr x) v))
  (defun shadow-symbol (x) (car x))
  (defun make-shadow (s v) (cons s v))

  (defvar +unbound+ (list "unbound"))

  (defun find-shadow (symbol)
    (let ((q (gethash symbol *shadows*)))
      (unless q
        (setq q (make-shadow symbol +unbound+))
        (setf (gethash symbol *shadows*) q))
      q))

  (defun symval (sym)
    (shadow-value (find-shadow sym)))

  (defun (setf symval) (v sym)
    (setf (shadow-value (find-shadow sym)) v)))

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

(defstruct closure
  env
  body)

(defstruct closure-body
  req                                   ;list of required parameters
  rest                                  ;rest parameter, if any
  code)                                 ;code vector

;; Don't look.

(defmacro comp (form &key (env 'env)
                          (tailp 'tailp))
  `(comp-1 ,form ,env ,tailp))

(defmacro define-compiler (name params &body body)
  `(progn
     (setf (get ',name 'compiler)
           (lambda (form env tailp)
             (declare (ignorable env tailp))
             (destructuring-bind ,params (cdr form)
               ,@body)))
     ',name))

(defun comp-1 (form env tailp &aux fun)
  (cond
    #-NIL
    ((eq form 'fib)                     ;###
     (list `(gvar ,form)))
    ((symbolp form)
     (list `(var ,form)))
    ((atom form)
     (list `(quote ,form)))
    ((and (symbolp (car form))
          (setq fun (get (car form) 'compiler)))
     (funcall fun form env tailp))
    (t
     (case (car form)
       ((+ <= -)
        (destructuring-bind (x y) (cdr form)
          (nconc
           (comp x :tailp nil)
           (comp y :tailp nil)
           (list (list (car form))))))       
       ;;
       (otherwise
        (nconc (mapcan #'(lambda (x)
                           (comp x :tailp nil))
                       form)
               (list `(call ,(length (cdr form)))))) ))))

;;; Special Operators

(define-compiler quote (value)
  (list `(quote ,value)))

(define-compiler setq (var val)
    (nconc (comp val :tailp nil)
           (list `(setq ,var))))

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

(define-compiler progn (&body body)
  (let ((res nil))
    (cond ((null body)
           (comp `'nil))
          (t
           (do ((q body (cdr q)))
               ((null q) res)
             (setq res (nconc res (comp (car q) :tailp (and tailp (null (cdr q))))))
             (unless (null (cdr q))
               (setq res (nconc res (list `(pop))))))))))

(define-compiler lambda (params &body body)
  (multiple-value-bind (req rest) (reverse* params)
    (list `(closure
            ,(make-closure-body
              :req req
              :rest rest
              :code (asm (nconc
                          (comp `(progn ,@body) :tailp t)
                          (list `(return)))))))))

(define-compiler let (bindings &body body)
  (nconc (mapcan (lambda (binding)
                   (comp (binding-val binding) :tailp nil))
                 bindings)
         (mapcar (lambda (binding)
                   `(bind ,(binding-var binding)))
                 (reverse bindings))
         (comp `(progn ,@body))
         (list `(unbind ,(length bindings)))))

(define-compiler let* (bindings &body body)
  (nconc (mapcan (lambda (binding)
                   (nconc (comp (binding-val binding) :tailp nil)
                          (list `(bind ,(binding-var binding)))))
                 bindings)
         (comp `(progn ,@body))
         (list `(unbind ,(length bindings)))))

;;; APPLY and FUNCALL

;; APPLY needs support from the interpreter because we otherwise don't
;; have a means to push the arguments and invoke the function. FUNCALL
;; could be implemented in terms of APPLY, but it's cheap to have it
;; here. [And note: This is a Lisp-1; no need for FUNCALL.]

(define-compiler apply (fun arg &rest more)
  (declare (ignore fun arg more))   
  (nconc (mapcan #'(lambda (x) (comp x :tailp nil)) (cdr form))
         (list `(apply ,(length (cdr form))))))

(define-compiler funcall (fun &rest args)
  (nconc (comp fun :tailp nil)
         (mapcan #'(lambda (x) (comp x :tailp nil)) args)
         (list `(call ,(length args)))))

;;; Helpers

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

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

(defun reverse* (list)
  ;; Like REVERSE, but works on dotted lists, too. The second return
  ;; value is the possible tail.
  (let ((res nil))
    (do ((q list (cdr q)))
        ((atom q)
         (values res q))
      (push (car q) res))))

;;;; -- Assembler -----------------------------------------------------------------------------

(eval-when (:compile-toplevel :execute :load-toplevel)
  (defparameter +insns+
    '(QUOTE POP IF-FALSE VAR GVAR SETQ CALL RETURN GO CLOSURE BIND UNBIND APPLY
      HALT
      ;;
      + - <=
      ))

  (defun opcode (op)
    (or (position op +insns+)
        (error "Unknown opcode - ~S" op))))

(defun asm (code)
  (let ((pc 0) (map nil))
    ;; Collect the code positions of all labels
    (dolist (insn code)
      (cond ((atom insn)
             (push (cons insn pc) map))
            (t
             (incf pc (length insn)))))
    ;; Convert the LAP
    (coerce
     (mapcan (lambda (insn)
               (destructuring-bind (op &rest args) insn
                 (cond ((member op '(go if-false))
                        (list (opcode op) (cdr (assoc (car args) map))))
                       (t
                        (cons (opcode (car insn)) args)) )))
             (remove-if #'atom code))
     'vector)))

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

(defvar *insn-count* 0)

(defmacro insn-case (insn &rest clauses)
  `(ecase ,insn
     ,@(mapcar (lambda (clause)
                 (cons (opcode (caar clause))
                       (cdr clause)))
               clauses)))

(defun run-loop (%cv)
  (declare (optimize (speed 3) (safety 1)))
  (setq *insn-count* 0)
  (let ((%pc 0)
        (%env nil)
        (%stack (make-array 1000))
        (%sp -1))
    (declare (type fixnum %pc %sp)
             (type simple-vector %cv %stack))
    (macrolet ((%push (val)
                 `(progn (incf %sp) (setf (aref %stack %sp) ,val)))
               (%pop ()
                 `(prog1 (aref %stack %sp) (decf %sp)))
               #-TOS-IS-FUNCTION
               (%tos (&optional (n 0))
                 `(aref %stack (- %sp ,n)))
               ;;
               (%arg ()
                 '(prog1 (aref %cv %pc) (incf %pc))) )
      ;;
      (labels ((bind (fun n req rest nenv)
                 (declare (type fixnum n)
                          (type list req))
                 (let* ((nreq (length req)))
                   (cond ((< n nreq)
                          (error "Too few argumentes to - ~S" fun))
                         (rest)
                         ((> n nreq)
                          (error "Too many argumentes to - ~S" fun)))
                   ;; rest args
                   (when rest
                     (let ((q nil))
                       (do () ((<= n nreq))
                         (push (%pop) q)
                         (decf n))
                       (push (cons rest q) nenv)))
                   ;; required args
                   (dolist (sym req)
                     (push (cons sym (%pop)) nenv))
                   nenv) )
               ;;
               (call (n)
                 (declare (type fixnum n))
                 (let* ((fun (%tos n)))
                   '(when (symbolp fun)
                     (setq fun (symval fun)))
                   (cond ((closure-p fun)
                          (let* ((body (closure-body fun))
                                 (nenv (bind fun n
                                             (closure-body-req body)
                                             (closure-body-rest body)
                                             (closure-env fun))))
                            (%pop)      ;function
                            (save-state)
                            (setf %pc 0
                                  %cv (closure-body-code body)
                                  %env nenv) ))
                         ((functionp fun)
                          (let ((args nil))
                            (loop repeat n do (push (%pop) args))
                            (%pop)
                            (%push (apply fun args))))
                         (t
                          (error "Not a function - ~S" fun)))))
               ;;
               (save-state ()
                 (%push %pc)
                 (%push %env)
                 (%push %cv))
               ;;
               (restore-state ()
                 (setf %cv (%pop))
                 (setf %env (%pop))
                 (setf %pc (%pop)))
               ;;
               #+TOS-IS-FUNCTION
               (%tos (&optional (n 0))
                 (aref %stack (- %sp n)))
               #+(AND TOS-IS-FUNCTION SET-TOS)
               (set-%tos (v &optional (n 0))
                 (setf (aref %stack (- %sp n)) v))
               #+(AND TOS-IS-FUNCTION (NOT SET-TOS))
               ((setf %tos) (v &optional (n 0))
                 (setf (aref %stack (- %sp n)) v))
               )
        ;;
        (declare (inline call bind save-state restore-state
                         #+TOS-IS-FUNCTION %tos
                         #+(AND TOS-IS-FUNCTION SET-TOS) set-%tos
                         #+(AND TOS-IS-FUNCTION (NOT SET-TOS)) (setf %tos)
                         ))
        (loop
          (let ((insn (aref %cv %pc)))
            (incf %pc)
            ;;(incf (the fixnum *insn-count*))
            (insn-case insn
              ((quote)
               (%push (%arg)))
              ((pop)
               (%pop))
              ((if-false)
               (let ((test (%pop))
                     (L (%arg)))
                 (unless test
                   (setq %pc L))))
              ((var)
               (let ((sym (%arg)))
                 (do ((q %env (cdr q)))
                     ((null q)
                      (%push (symval sym)))
                   (when (eq (caar q) sym)
                     (%push (cdar q))
                     (return)))))
              ((gvar)
               (%push (symbol-value (%arg))))
              ((setq)
               (let ((val (%tos)))
                 (let* ((v (%arg))
                        (q (assoc v %env :test #'eq)))
                   (if q
                       (setf (cdr q) val)
                       (setf (symval v) val)))))
              ((call)
               (call (%arg)))
              ((go)
               (setq %pc (%arg)))
              ((return)
               (let ((val (%pop)))
                 (restore-state)
                 (%push val)))
              ((closure)
               (%push (make-closure :env %env :body (%arg))))
              ((bind)
               (push (cons (%arg) (%pop)) %env))
              ((unbind)
               (setq %env (nthcdr (%arg) %env)))
              ((apply)
               (let ((n (- (the fixnum (%arg)) 2))
                     (more (%pop)))
                 (declare (type fixnum n))
                 (dolist (k more)
                   (%push k)
                   (incf n))
                 (call n)))
              ;;
              ((halt)
               (return-from run-loop (%tos)))

              ;; primitives
              ((+)
               (let ((b (%pop)))
                 #+(AND TOS-IS-FUNCTION SET-TOS)
                 (set-%tos (locally
                           (declare (optimize (speed 1)))
                            (+ (%tos) b)))
                 #-SET-TOS
                 (setf (%tos)
                       (locally
                           (declare (optimize (speed 1)))
                         (+ (%tos) b)))))
              ((-)
               (let ((b (%pop)))
                 #+(AND TOS-IS-FUNCTION SET-TOS)
                 (set-%tos (locally
                           (declare (optimize (speed 1)))
                            (- (%tos) b)))
                 #-SET-TOS
                 (setf (%tos)
                       (locally
                           (declare (optimize (speed 1)))
                         (- (%tos) b)))))
              ((<=)
               (let ((b (%pop)) (a (%pop)))
                 (%push (locally
                            (declare (optimize (speed 1)))
                          (<= a b)))))
              
              )))))))

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

#+NIL
(progn
  (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))

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

(defmacro e (form)
  `(eval-form ',form))

;;;; -- Instructions --------------------------------------------------------------------------

;; QUOTE <x>

;;   pushes <x> onto the stack

;; POP

;;   pops the top most stack element

;; GO <label>

;;   branches to the label <label>

;; IF-FALSE <label>

;;   pops the top most stack element and if it is NIL branches to
;;   label <label>.

;; VAR <sym>

;;   Get the value of the symbol <sym> from the lexical environment
;;   and failing that from the global environment.

;; SETQ <sym>

;;   Set the value of the symbol <sym> in the lexical environment to
;;   the value found at the top of the stack. When <sym> is not in the
;;   lexical environment the global environment is used.

;; BIND <sym>

;;   Pops the stack and creates a new binding of <sym> to value in the
;;   lexical environment.

;; UNBIND <n>

;;   Undo the last <n> BIND operations.

;; CLOSURE <body>

;; CALL <n>

;;   Perform a function call. The top-most <n> stack elements are the
;;   arguments to the function. The next stack element is the function
;;   to call. All these elements are poped.

;; APPLY <n>

;; RETURN

;;   Return from the current function.

;; HALT

;;   Halt the machine

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

(defparameter +fib-program+ nil)
(defparameter +fib-insns+ 11827261)

(defun compile-form (form)
  (comp form :env nil :tailp nil))

(defun eval-form (&optional (form '(+ 1 2)))
  (run-loop (asm (nconc (compile-form form)
                        (list '(halt))))))

(defun ensure-fib-program ()
  ;; GIB local
  (unless +fib-program+
    (setf (symval 'fib)
          (e (lambda (n)
               (if (<= n 1)
                   1
                   (+ (fib (- n 1)) (fib (- n 2)))))))
    (setq +fib-program+
          (let ((form
                 `(fib 25)))
            (asm (nconc (compile-form form)
                        (list '(halt))))))))

(defun bench ()
  (setf *print-circle* t)
  (ensure-fib-program)
  (let ((t0 (get-internal-run-time))
        t1
        (n 30))
    (loop repeat n do (run-loop +fib-program+))
    (setq t1 (- (get-internal-run-time) t0))
    (setq +fib-insns+ *insn-count*)
    (setq +fib-insns+ 2792027)
    (setq 
          t1 (/ t1 n))
    (format t "~&~12:D insns      ~4,2F MIPS ~10:Dus~%"
            +fib-insns+
            (/ (/ +fib-insns+ (/ t1 internal-time-units-per-second))
               1e6)
            (round (/ t1 1/1000000 internal-time-units-per-second))
            )
    nil))

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