path: root/assembly.lisp

(in-package :cl-forth)

(defparameter *operations* (make-hash-table :test 'equal))

(defparameter *psuedo-identifiers*
  '(syscall-1 syscall-2 syscall-3 syscall-4 syscall-5 syscall-6)
  "These do not map to operations directly, but are valid to lexer")

(defparameter *identifiers* ())
;; '(+ - dump = ise yoksa yap eş push değiş üst rot düş döngü iken < >
;;   bel oku yaz >> << & "|")

(defun is-identifier (sym)
  (or (find sym *identifiers* :test #'string=)
      (find sym *psuedo-identifiers* :test #'string=)))

(eval-always
  (defparameter *targets* '(:nasm :c))

  (defun normalize-op-list (asm-list)
    (cons 'list
          (mapcar (lambda (el) (cond ((stringp el) el)
                                ((listp el) `(format nil ,@el))))
                  asm-list)))

  (defun defop-format (str space-num asm-list)
    (format str
            (format nil "~~{~a~~a~~%~~}" 
                    (make-string space-num :initial-element #\Space))
            asm-list))

  (defun replace-write (out-stream indent forms)
    (if (consp forms)
        (if (eq :write (car forms))
            `(defop-format ,out-stream ,indent
               ,(normalize-op-list (cdr forms)))
            (cons (replace-write out-stream indent (car forms))
                  (replace-write out-stream indent (cdr forms))))
        forms))

  (defun add-indent (indent fmt-string)
    (format nil "~a~a"
            (make-string indent :initial-element #\Space)
            fmt-string))

  (defun split-stack (stack)
    (let ((split-num (position '-- stack)))
      (values (butlast stack (- (length stack) split-num))
              (nthcdr (+ 1 split-num) stack))))

  (defun op->string (asm-instruction &key (push? t))
    "asm-instruction is something like (:add rax rbx)"
    (destructuring-bind (op arg1 arg2) asm-instruction
      (let ((*print-case* :downcase))
        (if (null push?)
            (format nil (format nil "~a ~a, ~a" op arg1 arg2))
            (list (format nil "~a ~a, ~a" op arg1 arg2)
                  (format nil "push ~a" arg1))))))

  (defun stack->string (stack)
    (multiple-value-bind (prev next) 
        (split-stack stack)
      (let ((*print-case* :downcase))
        (append (iter (for sym in (reverse prev))
                      (collect (format nil "pop ~a" sym)))
                (iter (for form in next)
                      (cond ((symbolp form)
                             (appending (list (format nil "push ~a" form))))
                            ((listp form)
                             (appending (op->string form)))))))))

  (defparameter *stack-fn-assoc* '((:= :cmove)
                                   (:> :cmovg)
                                   (:< :cmovl)))
  
  (defun stack-unextend (stack)
    "Turns an extended stack to body of a defop, second part of an extended stack is in the form of (:op arg1 arg2 :then val1 :else val2) which is asserted."
    (multiple-value-bind (fst snd) (split-stack stack)
      (assert (= 1 (length snd)))
      (append (iter (for x in (reverse fst))
                    (let ((*print-case* :downcase))
                      (collect (format nil "pop ~a" x))))
              (let* ((push-part (car snd))
                     (ifs (nthcdr 3 push-part)))
                (list `(:mov rdx ,(getf ifs :ise))
                      `(:mov rcx ,(getf ifs :değilse))
                      `(:cmp ,(second push-part) ,(third push-part))
                      `(,(cadr (assoc (car push-part) *stack-fn-assoc*))
                        rcx rdx)
                      (format nil "push rcx"))))))
  
  (defun syntax-of (form)
    (cond ((or (stringp form)
               (and (consp form) (stringp (car form))))
           :string)
          ((and (listp form) (find '-- form))
           (if (multiple-value-bind (fst snd) (split-stack form)
                 (declare (ignore fst))
                 (and (consp snd)
                      (consp (car snd))
                      (find (caar snd) *stack-fn-assoc*
                            :key #'car)))
               :stack-extended
               :stack))
          ((and (listp form) (keywordp (car form)))
           :op)
          (t :general)))

  (defun group-by-syntax (forms &optional (syntax nil) (cur ()) (acc ()))
    (when (null forms)
      (return-from group-by-syntax
        (cdr (reverse (append (list (cons (syntax-of (car cur))
                                          (reverse cur)))
                              acc)))))
    (let* ((form (car forms))
           (form-syntax (syntax-of form)))
      (cond ((eq syntax form-syntax)
             (group-by-syntax (cdr forms) syntax
                              (cons form cur) acc))
            (t (group-by-syntax (cdr forms) form-syntax
                                (list form) (append (list (cons syntax
                                                                (reverse cur)))
                                                    acc))))))

  (defun expand-group (group out-stream &key (indent 4))
    (destructuring-bind (syntax-type . forms) group
      (case syntax-type
        (:stack `((defop-format ,out-stream ,indent
                     ,(cons 'list (mapcan (lambda (form) (stack->string form))
                                          forms)))))
        (:stack-extended (expand-nasm out-stream indent
                                      (stack-unextend (car forms))))
        (:op `((defop-format ,out-stream ,indent
                  ,(cons 'list (mapcar (lambda (form) (op->string form :push? nil))
                                       forms)))))
        (:string `((defop-format ,out-stream ,indent
                      ,(normalize-op-list forms))))
        (:general `((progn ,@(mapcar (lambda (form) (replace-write out-stream indent
                                                               form))
                                      forms)))))))

  (defun expand-nasm (out-stream indent body)
    (mapcan #'(lambda (group) (expand-group group out-stream
                                       :indent indent))
            (group-by-syntax body)))
  
  (defun expand-for-target (target out-stream body &optional (indent 4))
    (case target
      (:nasm (expand-nasm out-stream indent body))
      (:c '(nil))))
  
  (defun expand-method (target out-stream indent op-name args body)
    (with-gensyms (_op _args _target)
      (declare (ignorable _args))
      `(defmethod write-op
           ((,_target (eql ,target)) ,out-stream
            (,_op (eql ,(intern (string op-name) "KEYWORD")))
            ,_args)
         ,@(if (null args)
               (expand-for-target target out-stream body indent)
               `((destructuring-bind ,args ,_args
                   ,@(expand-for-target target out-stream body indent))))))))

(defgeneric write-op (target stream op args)
  (:documentation "Generate code for OP and ARGS and write it to STREAM according to the TARGET"))

(defmacro defop (op-name+args (&key (indent 4) (lex t) (targets :nasm)
                                 (as nil))
                 &body body)
  (declare (ignorable indent))
  (with-gensyms (out-stream)
    (destructuring-bind (op-name . args) (mklist op-name+args)
      `(progn
         ,@(unless (null lex)
             `((push ',op-name *identifiers*)))
         ,@(iter (for target in (if (eq :all targets)
                                    *targets*
                                    (mklist targets)))
                 (collect (expand-method target out-stream indent
                                         (if (null as) op-name as)
                                         args body)))))))

;;; TODO: Turn stack operation comments to DEFOP option,
;;;       which then can be used by the user as a documentation
;;; DONE: Better yet, generate the asm code directly from
;;;       the stack op documentation (this seems easily doable)
;;; Hopefully these two are done, need testing...

(defop + ()
  (rbx rax -- (:add rax rbx)))

(defop - ()
  (rbx rax -- (:sub rbx rax)))

(defop = ()
  (rbx rax -- (:= rbx rax :ise 1 :değilse 0)))

(defop eş ()
  (rax -- rax rax))

(defop düş ()
  (rax -- ))

(defop < ()
  (rax rbx -- (:< rax rbx :ise 1 :değilse 0)))

(defop > ()
  (rax rbx -- (:> rax rbx :ise 1 :değilse 0)))

(defop bel ()
  ( -- bel))

(defop üst ()
  (rbx rax -- rbx rax rbx))

(defop rot ()
  (rcx rbx rax -- rbx rax rcx))

(defop değiş ()
  (rbx rax -- rax rbx))

(defop << ()
  (rbx rcx -- (:shl rbx cl)))

(defop >> ()
  (rbx rcx -- (:shr rbx cl)))

(defop "|" (:as pipe)
  (rbx rax -- (:or rbx rax)))

(defop & ()
  (rbx rax -- (:and rbx rax)))

(defop oku ()
  (rax -- )
  (:xor rbx rbx)
  (:mov bl [rax])
  ( -- rbx))

(defop yaz ()
  (rax rbx -- )
  (:mov [rax] bl))

;; ( -- a)
(defop (push-int a) (:lex nil)
  ("push ~d" a))

(defop (push-str len addr str) (:lex nil)
  (progn (:write ("push ~d" len)
                 ("push str_~d" addr))
         (list :string addr str)))

(defop dump ()
  "pop rdi"
  "call dump")

(defop (exit code) (:lex nil)
  "mov rax, 60"
  ("mov rdi, ~a" code)
  "syscall")

(defop (ise label-num) ()
  "pop rax"
  "test rax, rax"
  ("jz et_~a" label-num))

(defop (yoksa yap-num ise-num) (:indent 0)
  ("    jmp et_~a" yap-num)
  ("et_~a:" ise-num))

(defop (yap label-num &optional döngü-num) (:indent 0)
  (if (null döngü-num)
      (:write ("et_~a:" label-num))
      (:write ("    jmp et_~a" döngü-num)
              ("et_~a:" label-num))))

(defop (iken label-num) ()
  "pop rax"
  "test rax, rax"
  ("jz et_~a" label-num))

(defop (döngü label-num) (:indent 0)
  ("et_~a:" label-num))

(defop (syscall num) (:lex nil)
  (iter (with call-regs = #("rdi" "rsi" "rdx" "r10" "r8" "r9"))
        (initially (:write "pop rax"))
        (for i from (- num 1) downto 0)
        (:write ("pop ~a" (aref call-regs i)))
        (finally (:write "syscall"))))

(defun comment-safe-str (str)
  "Handle newlines for asm comment"
  (with-output-to-string (new-str)
    (iter (for ch in-string str with-index i)
          (cond ((> i 10)
                 (princ "..." new-str)
                 (finish))
                ((char= #\Newline ch)
                 (princ "\\n" new-str))
                (t (write-char ch new-str))))))

(defun gen-header (op str)
  (format str "    ;; -- ~s --~%"
          (mapcar (lambda (x) (if (stringp x) (comment-safe-str x) x)) 
                  op)))

;; (defun gen-code (op str)
;;   (let ((op-fn (gethash (string (car op)) *operations*)))
;;     (when (null op-fn)
;;       (error "~s is not a valid op" op))
;;     (gen-header op str)
;;     (apply op-fn str (cdr op))))

(defun gen-code (op str)
  (gen-header op str)
  (write-op :nasm str (car op) (cdr op)))

(defun gen-dump (str)
  (format str "~{~a~%~}"
          '("dump:"
            "    mov     r9, -3689348814741910323"
            "    sub     rsp, 40"
            "    mov     BYTE [rsp+31], 10"
            "    lea     rcx, [rsp+30]"
            ".L2:"
            "    mov     rax, rdi"
            "    lea     r8, [rsp+32]"
            "    mul     r9"
            "    mov     rax, rdi"
            "    sub     r8, rcx"
            "    shr     rdx, 3"
            "    lea     rsi, [rdx+rdx*4]"
            "    add     rsi, rsi"
            "    sub     rax, rsi"
            "    add     eax, 48"
            "    mov     BYTE [rcx], al"
            "    mov     rax, rdi"
            "    mov     rdi, rdx"
            "    mov     rdx, rcx"
            "    sub     rcx, 1"
            "    cmp     rax, 9"
            "    ja      .L2"
            "    lea     rax, [rsp+32]"
            "    mov     edi, 1"
            "    sub     rdx, rax"
            "    xor     eax, eax"
            "    lea     rsi, [rsp+32+rdx]"
            "    mov     rdx, r8"
            "    mov     rax, 1"
            "    syscall"
            "    add     rsp, 40"
            "    ret")))