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

(in-package :hu.dwim.excosy)

;;;;;;
;;; LLVM
;;;
;;; These definitions are done according to the corresponding primitives in http://llvm.org/docs/LangRef.html

;; TODO: distinguish between immediates and registers as values when the llvm code is interpreted

(def function llvm/generate-new-register-name (name)
  (string-downcase (gensym (string-downcase name))))

(def macro llvm/block (&body forms)
  ;; TODO:
  `(progn
     ,@forms))

(def function llvm/label (machine label-name)
  (declare (ignore machine))
  label-name)

(def function llvm/label-reference (machine name)
  (declare (ignore machine))
  name)

(def function llvm/register (machine name)
  (declare (ignore machine))
  name)

(def function llvm/alloca (machine result type count)
  )

(def function llvm/load (machine result type pointer)
  (setf (find-register-value (runtime-state-of machine) result) (find-register-value (runtime-state-of machine) pointer)))

(def function llvm/store (machine source-type source-value target-type target-pointer)
  (setf (find-register-value (runtime-state-of machine) target-pointer) source-value))

(def function llvm/icmp (machine condition type left-operand right-operand)
  )

(def function llvm/conditional-br (machine condition true-label false-label)
  )

(def function llvm/unconditional-br (machine label)
  )

(def function llvm/switch (machine type value default-label &rest type-value-label-triplets)
  ;; TODO:
  )

(def function llvm/phi (machine result type &rest value-label-tuples)
  ;; TODO: find out value
  (setf (find-register-value (runtime-state-of machine) result) 1))

(def function llvm/ret (machine type value)
  (find-register-value (runtime-state-of machine) value))

;;;;;;;;
;;;; 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 class* virtual-machine ()
  ((configuration :type configuration)
   (memory-location-map :type memory-location-map)
   (runtime-state :type runtime-state)))

(def (function e) make-virtual-machine (ast-names)
  (bind ((configuration (make-configuration ast-names))
         (memory-location-map (make-memory-location-map))
         (machine (make-instance 'virtual-machine
                                 :configuration configuration
                                 :memory-location-map memory-location-map
                                 :runtime-state (make-runtime-state))))
    (maphash-values [ensure-memory-location-for-ast-node memory-location-map !1] (well-known-abstractions-of configuration))
    machine))

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

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

(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)
                 :counter 0))

(def function generate-new-memory-location (memory-location-map)
  (incf (counter-of memory-location-map)))

(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-for-ast-node (memory-location-map ast-node)
  (or (find-memory-location-for-ast-node memory-location-map ast-node :otherwise #f)
      (bind ((memory-location (generate-new-memory-location memory-location-map)))
        (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))))

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

;;;;;;
;;; Runtime

(def class* runtime-state ()
  ((register-to-value :type hash-table)
   (static-space :type memory-segment)))

(def function make-runtime-state ()
  (make-instance 'runtime-state
                 :register-to-value (make-hash-table :test #'equal)
                 :static-space (make-memory-segment (expt 2 10))))

(def function find-register-value (runtime-state register &key (otherwise :error otherwise?))
  (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)
  (setf (gethash register (register-to-value-of runtime-state)) value))

;;;;;;
;;; Memory segment

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

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

;;;;;;
;;; Printer

(def (function e) print-excosy (machine ast output)
  (funcall (printer-function-of ast) machine ast output))

;;;;;;
;;; Reader

(def (function e) read-excosy (machine input)
  ;;TODO:
  (make-instance 'abstraction/ast))

;;;;;;
;;; Evaluator

(def (function e) evaluate-excosy (machine ast)
  ;; TODO:
  (if #t
      (interpret-excosy machine ast)
      (execute-excosy machine (compile-excosy machine ast))))

;;;;;;
;;; Interpreter

(def (function e) interpret-excosy (machine ast)
  (find-ast-node-for-memory-location (memory-location-map-of machine) (%interpret-excosy machine ast)))

(def function %interpret-excosy (machine ast)
  (llvm/ret machine (word-bit-size-of (configuration-of machine)) (interpret-ast machine ast)))

(def function interpret-ast (machine ast)
  (funcall (interpreter-function-of ast) machine ast))

;;;;;;
;;; Compiler

(def (function e) compile-excosy (machine ast)
  (load-system :hu.dwim.excosy)
  (hu.dwim.util::clear-definition-source-texts)
  (hu.dwim.util::clear-definition-source-forms)
  (hu.dwim.partial-eval::clear-definition-lambda-forms)
  (partial-eval `(%interpret-excosy ,machine ,ast)
                :inline-functions '(interpret-excosy %interpret-excosy interpret-ast
                                    interpret-abstraction interpret-if)
                :eval-functions '(memory-location-map-of word-bit-size-of configuration-of interpreter-function-of ensure-memory-location-for-ast-node
                                  find-well-known-abstraction find-memory-location-for-ast-node runtime-state-of
                                  condition-of then-branch-of else-branch-of
                                  llvm/generate-new-register-name)))

;;;;;;
;;; Assembler

(def (function e) assemble-excosy (machine binary-ast &key stream)
  (if (null stream)
      (with-output-to-string (stream)
        (assemble-excosy machine binary-ast :stream stream))
      (bind ((walked-ast (walk-form binary-ast)))
        (format stream "define i32 @main() nounwind readnone {~%")
        (assemble-ast walked-ast stream)
        (format stream "}"))))

(def generic assemble-ast (ast stream)
  (:method ((ast implicit-progn-mixin) stream)
    (prog1-bind result nil
      (dolist (child-ast (body-of ast))
        (setf result (assemble-ast child-ast stream)))))

  (:method ((ast constant-form) stream)
    (format nil "~A" (value-of ast)))

  (:method ((ast free-application-form) stream)
    (bind ((arguments (arguments-of ast)))
      (ecase (operator-of ast)
        (llvm/register
         (format nil "%~A" (assemble-ast (elt arguments 1) stream)))
        (llvm/label
         (format stream "~A:~%" (string-downcase (assemble-ast (elt arguments 1) stream))))
        (llvm/label-reference
         (format nil "%~A" (string-downcase (assemble-ast (elt arguments 1) stream))))
        (llvm/alloca
         (format stream "        ~A = alloca i32~%" (assemble-ast (elt arguments 1) stream)))
        (llvm/load
         (format stream "        ~A = load i32* ~A~%" (assemble-ast (elt arguments 1) stream) (assemble-ast (elt arguments 3) stream)))
        (llvm/store
         (format stream "        store i32 ~A, i32* ~A~%" (assemble-ast (elt arguments 2) stream) (assemble-ast (elt arguments 4) stream)))
        (llvm/icmp
         (format stream "        icmp ~%"))
        (llvm/ret
         (format stream "        ret i32 ~A~%" (assemble-ast (elt arguments 2) stream)))
        (llvm/conditional-br
         (format stream "        br ~%"))
        (llvm/unconditional-br
         (format stream "        br label ~A~%" (assemble-ast (elt arguments 1) stream)))
        (llvm/switch
         (format stream "        switch i32 ~A, label ~A [ i32 ~A, label ~A i32 ~A, label ~A ]~%"
                 (assemble-ast (elt arguments 1) stream)
                 (assemble-ast (elt arguments 2) stream)
                 (assemble-ast (elt arguments 3) stream)
                 (assemble-ast (elt arguments 4) stream)
                 (assemble-ast (elt arguments 5) stream)
                 (assemble-ast (elt arguments 6) stream)))
        (llvm/phi
         (format stream "        ~A = phi i32 [ ~A, ~A ], [ ~A, ~A ], [ ~A, ~A ]~%"
                 (assemble-ast (elt arguments 1) stream)
                 (assemble-ast (elt arguments 3) stream)
                 (assemble-ast (elt arguments 4) stream)
                 (assemble-ast (elt arguments 5) stream)
                 (assemble-ast (elt arguments 6) stream)
                 (assemble-ast (elt arguments 7) stream)
                 (assemble-ast (elt arguments 8) stream)))))))

;;;;;;
;;; Executor

(def (function e) execute-excosy (machine binary-ast)
  (find-ast-node-for-memory-location (memory-location-map-of machine) (eval binary-ast)))

;;;;;;
;;; Builder

(def (function e) build-excosy (machine binary-ast)
  (with-output-to-file (stream #P"/tmp/excosy.as" :if-exists :supersede)
    (assemble-excosy machine binary-ast :stream stream))
  (trivial-shell:shell-command "llvm-as -f /tmp/excosy.as")
  (trivial-shell:shell-command "llvm-ld -native -o /tmp/excosy /tmp/excosy.as.bc"))

;;;;;;
;;; AST

(def class* ast ()
  ((reader-function :type symbol)
   (printer-function :type symbol)
   (interpreter-function :type symbol)))

;;;;;;
;;; Nothing

(def class* nothing/ast (ast)
  ())

(def function print-nothing (machine ast output)
  (values))

(def function read-nothing (machine ast input)
  (make-instance 'nothing))

(def function interpret-nothing (machine ast)
  (values))

;;;;;;
;;; Abstraction

;; TODO: rather call it object? or something-that-has-memory-location? or whatever?
(def class* abstraction/ast (ast)
  ((printer-function 'print-abstraction)
   (interpreter-function 'interpret-abstraction)))

(def function print-abstraction (machine ast output)
  (format output "(abstraction)"))

(def function read-abstraction (machine ast input)
  (make-instance 'abstraction))

(def function interpret-abstraction (machine ast)
  (bind ((memory-location (ensure-memory-location-for-ast-node (memory-location-map-of machine) ast))
         (register (llvm/generate-new-register-name :abstraction))
         (type (word-bit-size-of (configuration-of machine))))
    (llvm/alloca machine (llvm/register machine register) type 1)
    (llvm/store machine type memory-location type (llvm/register machine register))
    (llvm/register machine register)))

;;;;;;
;;; Application

(def class* application/ast (ast)
  ((applied-abstraction :type abstraction)))

(def function print-application (machine ast output)
  (format output "(~A)" (applied-abstraction-of ast)))

(def function read-application (machine ast input)
  ;; TODO:
  (make-instance 'application))

(def function interpret-application (machine ast)
  ast)

;;;;;;
;;; Argument

(def class* argument/ast (ast)
  ((name :type string)))

(def function print-argument (machine ast output)
  (format output "(~A)" (applied-abstraction-of ast)))

(def function read-argument (machine ast input)
  ;; TODO:
  (make-instance 'argument :name nil))

(def function interpret-argument (machine ast)
  (error ""))

;;;;;;
;;; Single argument abstraction

(def class* single-argument-abstraction/ast (abstraction)
  ((argument :type ast)
   (body :type ast)))

;;;;;;
;;; Single argument application

(def class* single-argument-application/ast (application)
  ((argument :type ast)))

;;;;;;
;;; Boolean

;; TODO: kill?
#+nil
(def class* boolean/ast (ast)
  ((printer-function 'print-boolean)
   (interpreter-function 'interpret-boolean)
   (value :type boolean)))

(def function print-boolean (machine ast output)
  (if (value-of ast)
      (format output "true")
      (format output "false")))

(def function read-boolean (machine ast input)
  ;; TODO:
  nil)

;;;;;;
;;; Integer

(def class* integer/ast (abstraction)
  ((value :type integer)))

(def function print-integer (machine ast output)
  (format output "~A" (value-of ast)))

(def function read-integer (machine ast input)
  (make-instance 'integer :value (parse-integer input)))

(def function interpret-integer (machine ast)
  ast)

;;;;;;
;;; If

(def class* if/ast (ast)
  ((printer-function 'print-if)
   (interpreter-function 'interpret-if)
   (condition :type ast)
   (then-branch :type ast)
   (else-branch :type ast)))

(def function print-if (machine ast output)
  (not-yet-implemented))

(def function read-if (machine ast input)
  (not-yet-implemented))

(def function interpret-if (machine ast)
  (bind ((true-memory-location (find-memory-location-for-ast-node (memory-location-map-of machine) (find-well-known-abstraction (configuration-of machine) :true)))
         (false-memory-location (find-memory-location-for-ast-node (memory-location-map-of machine) (find-well-known-abstraction (configuration-of machine) :false)))
         (conditional-register (llvm/generate-new-register-name :conditional))
         (then-register (llvm/generate-new-register-name :then-branch))
         (else-register (llvm/generate-new-register-name :else-branch))
         (result-register (llvm/generate-new-register-name :result))
         (type (word-bit-size-of (configuration-of machine))))
    (llvm/block
      (llvm/label machine :if-entry)
      (llvm/load machine (llvm/register machine conditional-register) type (interpret-ast machine (condition-of ast)))
      (llvm/switch machine (llvm/register machine conditional-register) (llvm/label-reference machine :if-exit)
                   true-memory-location (llvm/label-reference machine :then-branch) false-memory-location  (llvm/label-reference machine :else-branch))
      (llvm/label machine :then-branch)
      (llvm/load machine (llvm/register machine then-register) type (interpret-ast machine (then-branch-of ast)))
      (llvm/unconditional-br machine (llvm/label-reference machine :if-exit))
      (llvm/label machine :else-branch)
      (llvm/load machine (llvm/register machine else-register) type (interpret-ast machine (else-branch-of ast)))
      (llvm/unconditional-br machine (llvm/label-reference machine :if-exit))
      (llvm/label machine :if-exit)
      (llvm/phi machine (llvm/register machine result-register) type
                (llvm/register machine then-register) (llvm/label-reference machine :then-branch)
                (llvm/register machine else-register) (llvm/label-reference machine :else-branch)
                (llvm/register machine conditional-register) (llvm/label-reference machine :if-entry))
      (llvm/register machine result-register))))