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

(in-package :hu.dwim.excosy)

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

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

(def class* llvm/type ()
  ((kind)
   (size)
   (dereference-count)))

(def function llvm/type (machine kind &optional size dereference-count)
  (declare (ignore machine))
  (make-instance 'llvm/type :kind kind :size size :dereference-count dereference-count))

(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)
  (bind ((runtime-state (runtime-state-of machine))
         (stack-pointer (stack-pointer-of runtime-state)))
    (incf (stack-pointer-of runtime-state) (* (size-of type) count))
    (setf (find-register-value runtime-state result) stack-pointer))
  (values))

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

(def function llvm/store (machine source-type source-value target-type target-pointer)
  ;; TODO: dereference source-value based on type
  (bind ((runtime-state (runtime-state-of machine))
         (target-address (find-register-value runtime-state target-pointer)))
    (setf (find-memory-value runtime-state target-address) (find-register-value runtime-state source-value)))
  (values))

(def function llvm/icmp (machine result condition type left-operand right-operand)
  (bind ((runtime-state (runtime-state-of machine)))
    (setf (find-register-value runtime-state result)
          (if (= (if (integerp left-operand)
                     left-operand
                     (find-register-value runtime-state left-operand))
                 (if (integerp right-operand)
                     right-operand
                     (find-register-value runtime-state right-operand)))
              1
              0))
    (values)))

;; TODO: there's no such condition/unconditional distinction in llvm
(def function llvm/conditional-br (machine condition true-label false-label)
  (bind ((runtime-state (runtime-state-of machine))
         (target-label (if (= (find-register-value runtime-state condition) 1)
                           true-label
                           false-label)))
    (setf (current-special-form-of runtime-state) (find-label-special-form runtime-state target-label))
    (throw :go-to-current-special-form nil)))

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

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

(def function llvm/add (machine result type left right)
  (declare (ignore type))
  (bind ((runtime-state (runtime-state-of machine)))
    (setf (find-register-value runtime-state result)
          (+ (if (integerp left)
                 left
                 (find-register-value runtime-state left))
             (if (integerp right)
                 right
                 (find-register-value runtime-state right))))
    (values)))

(def function llvm/sub (machine result type left right)
  (declare (ignore type))
  (bind ((runtime-state (runtime-state-of machine)))
    (setf (find-register-value runtime-state result)
          (- (if (integerp left)
                 left
                 (find-register-value runtime-state left))
             (if (integerp right)
                 right
                 (find-register-value runtime-state right))))
    (values)))

(def function llvm/srem (machine result type left right)
  (declare (ignore type))
  (bind ((runtime-state (runtime-state-of machine)))
    (setf (find-register-value runtime-state result)
          (rem (find-register-value runtime-state left)
               (find-register-value runtime-state right)))
    (values)))

(def function llvm/declare (machine result-type name &rest argument-types)
  (declare (ignore machine result-type name argument-types)))

(def function llvm/call (machine result type name &rest argument-type-value-pairs)
  (declare (ignore type))
  (bind ((runtime-state (runtime-state-of machine))
         (value (eswitch (name :test #'string=)
                  ("getchar"
                   (char-code (read-char)))
                  ("putchar"
                   (bind ((code (find-register-value runtime-state (second argument-type-value-pairs))))
                     #+nil(break/print (code-char code))
                     (write-char (code-char code))
                     1))
                  ("llvm.memset.i32"
                   ;; TODO:
                   0))))
    (when result
      (setf (find-register-value runtime-state result) value))
    (values)))

(def function llvm/getelementptr (machine result type pointer offset-type offset)
  (bind ((runtime-state (runtime-state-of machine)))
    ;; TODO:
    (setf (find-register-value runtime-state result)
          (+ (find-register-value runtime-state pointer) offset))
    (values)))

(def function llvm/malloc (machine result type element-type count)
  (bind ((runtime-state (runtime-state-of machine))
         (address 2000000))
    (push (make-memory-segment 2000000 count) (dynamic-spaces-of runtime-state))
    (setf (find-register-value runtime-state result) address)
    (values)))

(def function llvm/free (machine type pointer)
  (values))

(def function llvm/trunc (machine result source-type source-value result-type)
  (bind ((runtime-state (runtime-state-of machine)))
    (setf (find-register-value runtime-state result) (find-register-value runtime-state source-value))
    (values)))

(def function llvm/zext (machine result source-type source-value result-type)
  (bind ((runtime-state (runtime-state-of machine)))
    (setf (find-register-value runtime-state result) (find-register-value runtime-state source-value))
    (values)))

(def function llvm/sext (machine result source-type source-value result-type)
  (bind ((runtime-state (runtime-state-of machine)))
    (setf (find-register-value runtime-state result) (find-register-value runtime-state source-value))
    (values)))

(def function llvm/ptrtoint (machine result source-type source-value result-type)
  (values))

(def function llvm/inttoptr (machine result source-type source-value result-type)
  (values))