;;; -*- mode: Lisp; Syntax: Common-Lisp; -*-
;;;
;;; Copyright (c) 2009 by the authors.
;;;
;;; See LICENCE for details.

(in-package :hu.dwim.vm)

;;;;;;
;;; TODO
;;;
;;; type registry
;;; reify mapping
;;; don't use constants, use a completely reified vm description (e.g. a class instance)

;;;;;;
;;; VM

(def constant +vm-word-bit-size+ 64)

(def constant +vm-tag-bit-size+ 3)

;;;;;;
;;; Util

(eval-always
  (def function make-bit-vector (bit-size &key (initial-element 0 initial-element?) (initial-contents nil initial-contents?))
    (apply #'make-array bit-size
           :element-type 'bit
           (append (when initial-element?
                     (list :initial-element initial-element))
                   (when initial-contents?
                     (list :initial-contents (prog1-bind initial-bits (make-bit-vector bit-size)
                                               (replace initial-bits initial-contents :start1 (- bit-size (length initial-contents))))))))))

;;;;;;
;;; Tag

(def constant +vm-tag-mask+ (make-bit-vector +vm-word-bit-size+ :initial-contents (make-bit-vector +vm-tag-bit-size+ :initial-element 1)))

(def constant +vm-payload-mask+ (bit-not +vm-tag-mask+))

(eval-always
  (def function make-vm-word (tag-bits &optional (default-bit 0))
    (bit-ior (bit-and (make-array +vm-word-bit-size+ :element-type 'bit :initial-element default-bit)
                      +vm-payload-mask+)
             (prog1-bind word-size-tag-bits (make-bit-vector +vm-word-bit-size+)
               (replace word-size-tag-bits tag-bits :start1 (- +vm-word-bit-size+ (length tag-bits)))))))

;;;;;;
;;; Boolean

(def constant +vm-tag-bits/boolean+ (make-vm-word (make-bit-vector +vm-tag-bit-size+ :initial-element 1)))

(def constant +vm-true-bits+ (make-vm-word +vm-tag-bits/boolean+ 1))

(def constant +vm-false-bits+ (make-vm-word +vm-tag-bits/boolean+))

(def (constant e) +lisp-true+ '+lisp-true+)

(def (constant e) +lisp-false+ '+lisp-false+)

;;;;;;
;;; Native integer

(def constant +vm-tag-bits/native-integer+ (make-vm-word (make-bit-vector +vm-tag-bit-size+ :initial-element 0)))

(def constant +vm-bit-size/native-integer+ (- +vm-word-bit-size+ +vm-tag-bit-size+))

;;;;;;
;;; To VM

(def function to-vm/boolean (value)
  (eswitch (value)
    (+lisp-true+ +vm-true-bits+)
    (+lisp-false+ +vm-false-bits+)))

(def function to-vm/boolean/generalized (value)
  (if value
      +vm-true-bits+
      +vm-false-bits+))

;; TODO: handle negative integers
(def function to-vm/native-integer (value)
  (bind ((bits (make-vm-word +vm-tag-bits/native-integer+))
         (length (integer-length value)))
    (iter (for index :from 0 :to length)
          (when (logbitp index value)
            (setf (aref bits (- +vm-word-bit-size+ +vm-tag-bit-size+ index 1)) 1)))
    bits))

(def function to-vm (value)
  (etypecase value
    ((member +lisp-true+ +lisp-false+) (to-vm/boolean value))
    (fixnum (to-vm/native-integer value))
    (symbol value)
    (cons (cons (to-vm (car value))
                (to-vm (cdr value))))))

;;;;;;
;;; To Lisp

(def function to-lisp/boolean (bits)
  (eswitch (bits :test #'equal)
    (+vm-true-bits+ +lisp-true+)
    (+vm-false-bits+ +lisp-false+)))

(def function to-lisp/native-integer (bits)
  (prog1-bind value 0
    (iter (for index :from 0)
          (for bit :in-sequence bits)
          (unless (zerop bit)
            (setf (logbitp (- +vm-word-bit-size+ +vm-tag-bit-size+ index 1) value) 1)))))

(def function to-lisp (bits)
  (bind ((tag-bits (bit-and bits +vm-tag-mask+)))
    (cond ((equal +vm-tag-bits/boolean+ tag-bits)
           (to-lisp/boolean bits))
          ((equal +vm-tag-bits/native-integer+ tag-bits)
           (to-lisp/native-integer bits))
          (t
           (error "Unknown value ~A" bits)))))

;;;;;;
;;; VM primitives

;; TODO: this is boring
(def function vm-primitive/if (condition then else environment)
  (bind ((condition (evaluate/vm condition environment)))
    (cond ((eq +lisp-true+ (to-lisp/boolean (vm-primitive/equal condition +vm-true-bits+)))
           (evaluate/vm then environment))
          ((eq +lisp-true+ (to-lisp/boolean (vm-primitive/equal condition +vm-false-bits+)))
           (evaluate/vm else environment))
          (t (error "If condition evaluated to a non boolean value")))))

(def function vm-primitive/equal (left right)
  (to-vm/boolean/generalized (equal left right)))

(def function vm-primitive/=/native-integer (left right)
  (to-vm/boolean/generalized (= (to-lisp/native-integer left)
                                (to-lisp/native-integer right))))

(def function vm-primitive/</native-integer (left right)
  (to-vm/boolean/generalized (< (to-lisp/native-integer left)
                                (to-lisp/native-integer right))))

(def function vm-primitive/>/native-integer (left right)
  (to-vm/boolean/generalized (< (to-lisp/native-integer left)
                                (to-lisp/native-integer right))))

(def function vm-primitive/+/native-integer (left right)
  (to-vm/native-integer (+ (to-lisp/native-integer left)
                           (to-lisp/native-integer right))))

(def function vm-primitive/-/native-integer (left right)
  (to-vm/native-integer (- (to-lisp/native-integer left)
                           (to-lisp/native-integer right))))

(def function vm-primitive/mod/native-integer (left right)
  (to-vm/native-integer (mod (to-lisp/native-integer left)
                             (to-lisp/native-integer right))))

;;;;;;
;;; Lexical environment

(def function lexical-binding (name environment)
  (bind ((value-cell (iter (for cell :in environment)
                           (when (eq (car cell) name)
                             (return cell)))))
    (if value-cell
        (cdr value-cell)
        (error "The name ~A is unbound" name))))

(def function (setf lexical-binding) (new-value name environment)
  (bind ((value-cell (assoc name environment)))
    (if value-cell
        (progn
          (setf (cdr value-cell) new-value)
          environment)
        (cons (cons name new-value) environment))))

(def function to-vm/environment (environment)
  (iter (with result = nil)
        (for cell :in environment)
        (push (cons (car cell)
                    (to-vm (cdr cell)))
              result)
        (finally (return result))))

;;;;;;
;;; Evaluate

;; TODO: as soon as partial-eval supports specials use this as default argument during evaluate
(def special-variable *environment*)

(def (function e) evaluate/vm (form environment)
  (etypecase form
    (simple-bit-vector form)
    (symbol (lexical-binding form environment))
    (cons (bind ((first-element (first form)))
            (case first-element
              (if (vm-primitive/if (second form) (third form) (fourth form) environment))
              (equal (vm-primitive/equal (evaluate/vm (second form) environment)
                                         (evaluate/vm (third form) environment)))
              (= (vm-primitive/=/native-integer (evaluate/vm (second form) environment)
                                                (evaluate/vm (third form) environment)))
              (< (vm-primitive/</native-integer (evaluate/vm (second form) environment)
                                                (evaluate/vm (third form) environment)))
              (> (vm-primitive/>/native-integer (evaluate/vm (second form) environment)
                                                (evaluate/vm (third form) environment)))
              (+ (vm-primitive/+/native-integer (evaluate/vm (second form) environment)
                                                (evaluate/vm (third form) environment)))
              (- (vm-primitive/-/native-integer (evaluate/vm (second form) environment)
                                                (evaluate/vm (third form) environment)))
              (mod (vm-primitive/mod/native-integer (evaluate/vm (second form) environment)
                                                    (evaluate/vm (third form) environment)))
              (t (bind ((lambda-form (lexical-binding first-element environment))
                        (extended-environment environment))
                   (iter (for argument-name :in (second lambda-form))
                         (for argument-value :in (rest form))
                         (push (cons argument-name (evaluate/vm argument-value environment)) extended-environment))
                   (evaluate/vm (third lambda-form) extended-environment))))))))

(def (function e) evaluate/lisp (form &optional environment)
  (to-lisp (evaluate/vm (to-vm form) (to-vm/environment environment))))

;;;;;;
;;; Compile

(def function vm-partial-eval (form)
  (partial-eval form
                :eval-functions '(typep
                                  evaluate/vm lexical-binding
                                  to-vm to-vm/boolean to-vm/boolean/generalized to-vm/native-integer
                                  to-lisp to-lisp/boolean to-lisp/native-integer
                                  vm-primitive/if vm-primitive/equal
                                  vm-primitive/=/native-integer vm-primitive/</native-integer vm-primitive/>/native-integer
                                  vm-primitive/+/native-integer vm-primitive/-/native-integer vm-primitive/mod/native-integer)
                :inline-functions '(evaluate/lisp evaluate/vm lexical-binding to-vm/environment vm-primitive/if)))

(def (macro e) compile/vm (form &optional environment)
  `',(vm-partial-eval `(evaluate/vm ,form ,environment)))

(def (macro e) compile/lisp (form &optional environment)
  `',(vm-partial-eval `(evaluate/lisp ,form ,environment)))