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

(in-package :hu.dwim.excosy)

;;;;;;;;
;;;; NOTE: we avoid using generic functions inside the interpreter on purpose, while anywhere else they can be freely used.
;;;;  - we want to be able to partially evaluate this code and generic function complicate and slow down things
;;;;  - we also want the machine to be a completely first class citizen, so that you can plass machines around
;;;;  - it will probably simplify bootstrap or later porting to other runtime environments

;;; TODO: machine -> *machine*?
;;; TODO: ast means abstract syntax tree, but at lot of places used as ast node, rename?

;;;;;;
;;; Machine

(def type memory-location ()
  'integer)

(def class* virtual-machine ()
  ((configuration :type configuration)
   (memory-location-map :type memory-location-map)
   (environment :type environment)
   (runtime-state :type runtime-state)))

(def (function e) make-virtual-machine (ast-names)
  (make-instance 'virtual-machine
                 :configuration (make-configuration ast-names)
                 :memory-location-map (make-memory-location-map)
                 :environment (make-environment)
                 :runtime-state (make-runtime-state)))

;;;;;;
;;; Configuration

(def class* configuration ()
  ((word-bit-size :type integer)
   (ast-names :type list)
   (well-known-abstractions :type hash-table)))

(def function make-configuration (ast-names)
  (bind ((well-known-abstractions (make-hash-table)))
    (setf (gethash :true well-known-abstractions) (make-instance 'abstraction/ast
                                                                 :reader-function 'read-boolean
                                                                 :printer-function 'print-boolean
                                                                 :interpreter-function 'interpret-abstraction))
    (setf (gethash :false well-known-abstractions) (make-instance 'abstraction/ast
                                                                  :reader-function 'read-boolean
                                                                  :printer-function 'print-boolean
                                                                  :interpreter-function 'interpret-abstraction))
    (make-instance 'configuration
                   :word-bit-size 32
                   :ast-names ast-names
                   :well-known-abstractions well-known-abstractions)))

(def function find-well-known-abstraction (configuration name &key (otherwise :error otherwise?))
  (or (gethash name (well-known-abstractions-of configuration))
      (handle-otherwise (error "~S: ~A not found" 'find-well-known-abstraction name))))

;;;;;;
;;; Memory location map

(def class* memory-location-map ()
  ((ast-to-memory-location :type hash-table)
   (memory-location-to-ast :type hash-table)))

(def function make-memory-location-map ()
  (make-instance 'memory-location-map
                 :ast-to-memory-location (make-hash-table)
                 :memory-location-to-ast (make-hash-table)))

(def function find-memory-location-for-ast-node (memory-location-map ast-node &key (otherwise :error otherwise?))
  (or (gethash ast-node (ast-to-memory-location-of memory-location-map))
      (handle-otherwise (error "~S: ~A not found" 'find-memory-location-for-ast-node ast-node))))

(def function (setf find-memory-location-for-ast-node) (memory-location memory-location-map ast-node)
  (setf (gethash ast-node (ast-to-memory-location-of memory-location-map)) memory-location))

(def function find-ast-node-for-memory-location (memory-location-map memory-location &key (otherwise :error otherwise?))
  (or (gethash memory-location (memory-location-to-ast-of memory-location-map))
      (handle-otherwise (error "~S: ~A not found" 'find-ast-node-for-memory-location memory-location))))

(def function (setf find-ast-node-for-memory-location) (ast-node memory-location-map memory-location)
  (setf (gethash memory-location (memory-location-to-ast-of memory-location-map)) ast-node))

(def function ensure-memory-location (machine ast-node)
  (bind ((memory-location-map (memory-location-map-of machine)))
    (or (find-memory-location-for-ast-node memory-location-map ast-node :otherwise #f)
        (bind ((memory-location (funcall (memory-location-allocator-function-of ast-node) machine ast-node)))
          (setf (find-ast-node-for-memory-location memory-location-map memory-location) ast-node)
          (setf (find-memory-location-for-ast-node memory-location-map ast-node) memory-location)))))

;;;;;;
;;; Environment

(def class* environment ()
  ((labels nil :type list)))

(def function make-environment ()
  (make-instance 'environment))

;;;;;;
;;; Runtime

(def class* runtime-state ()
  ((current-special-form :type ast)
   (register-to-value :type hash-table)
   (stack-space :type integer)
   (stack-pointer :type integer)
   (static-space :type memory-segment)
   (dynamic-spaces :type list)))

(def function make-runtime-state ()
  (make-instance 'runtime-state
                 :register-to-value (make-hash-table :test #'equal)
                 :stack-space (make-memory-segment 0 (expt 2 10))
                 :stack-pointer 0
                 :static-space (make-memory-segment 1000000 (expt 2 10))
                 :dynamic-spaces nil))

(def function find-label-special-form (runtime-state label)
  )

(def function find-register-value (runtime-state register &key (otherwise :error otherwise?))
  (check-type register string)
  (or (gethash register (register-to-value-of runtime-state))
      (handle-otherwise (error "~S: ~A not found" 'find-register-value register))))

(def function (setf find-register-value) (value runtime-state register)
  (check-type value integer)
  (check-type register string)
  (setf (gethash register (register-to-value-of runtime-state)) value))

(def function find-memory-segment (runtime-state address &key (otherwise :error otherwise?))
  (or (iter (for memory-segment :in (list* (stack-space-of runtime-state)
                                           (static-space-of runtime-state)
                                           (dynamic-spaces-of runtime-state)))
            (for memory-segment-address = (address-of memory-segment))
            (when (and (<= memory-segment-address address)
                       (< address (+ memory-segment-address (size-of memory-segment))))
              (return memory-segment)))
      (handle-otherwise (error "~S: ~A not found" 'find-memory-segment address))))

(def function find-memory-value (runtime-state address &key (otherwise :error otherwise?))
  (bind ((memory-segment (find-memory-segment runtime-state address)))
    (elt (bytes-of memory-segment) (- address (address-of memory-segment)))))

(def function (setf find-memory-value) (value runtime-state address &key (otherwise :error otherwise?))
  (check-type value integer)
  (bind ((memory-segment (find-memory-segment runtime-state address)))
    (setf (elt (bytes-of memory-segment) (- address (address-of memory-segment))) value)))

;;;;;;
;;; Memory segment

(def class* memory-segment ()
  ((address :type integer)
   (size :type integer)
   (bytes :type (simple-array (unsigned-byte 8)))))

(def function make-memory-segment (address size)
  (make-instance 'memory-segment
                 :address address
                 :size size
                 :bytes (make-array size :element-type '(simple-array (unsigned-byte 8)))))