From e4419034ceb01bc58a5cbe228ff8be7439e8defd Mon Sep 17 00:00:00 2001 From: mRnea Date: Wed, 31 Jul 2024 14:53:18 +0300 Subject: massive overhaul to defop, temporarily disable interpretation --- assembly.lisp | 288 +++++++++++++++++++++++++++++++++------------------------- 1 file changed, 163 insertions(+), 125 deletions(-) (limited to 'assembly.lisp') diff --git a/assembly.lisp b/assembly.lisp index e4582de..13623c7 100644 --- a/assembly.lisp +++ b/assembly.lisp @@ -2,6 +2,18 @@ (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 (defun normalize-op-list (asm-list) (cons 'list @@ -22,55 +34,175 @@ ,(normalize-op-list (cdr forms))) (cons (replace-write out-stream indent (car forms)) (replace-write out-stream indent (cdr forms)))) - forms))) - -(defmacro defop (op-name+args (&key (indent 4)) &body body) + 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))))))))) + + (defun syntax-of (form) + (cond ((or (stringp form) + (and (consp form) (stringp (car form)))) + :string) + ((and (listp form) (find '-- form)) + :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)))) + (: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))))))) + +(defmacro defop (op-name+args (&key (indent 4) (lex t)) &body body) (with-gensyms (out-stream) (destructuring-bind (op-name . args) (mklist op-name+args) - `(setf (gethash ,(string op-name) *operations*) - (lambda (,out-stream ,@args) - ,(if (or (stringp (car body)) (stringp (caar body))) - `(defop-format ,out-stream ,indent - ,(normalize-op-list body)) - (replace-write out-stream indent (car body)))))))) + `(progn + ,@(append + (unless (null lex) + `((push ',op-name *identifiers*))) + `((setf (gethash ,(string op-name) *operations*) + (lambda (,out-stream ,@args) + ,@(mapcar #'(lambda (group) (expand-group group out-stream + :indent indent)) + (group-by-syntax body)))))))))) ;;; TODO: Turn stack operation comments to DEFOP option, ;;; which then can be used by the user as a documentation ;;; TODO: Better yet, generate the asm code directly from ;;; the stack op documentation (this seems easily doable) +;;; Hopefully these two are done, need testing... ;; ( -- a) -(defop (push a) () +(defop (push a) (:lex nil) ("push ~d" a)) -;; (rbx rax -- (rbx + rax)) (defop + () - "pop rax" - "pop rbx" - "add rax, rbx" - "push rax") + (rbx rax -- (:add rax rbx))) -;; (rbx rax -- (rbx - rax)) (defop - () - "pop rax" - "pop rbx" - "sub rbx, rax" - "push rbx") + (rbx rax -- (:sub rbx rax))) + +(defop = () + (:mov rcx 0) + (:mov rdx 1) + (rbx rax -- ) + (:cmp rax rbx) + ( -- (:cmove rcx rdx))) + +(defop eş () + (rax -- rax rax)) + +(defop düş () + (rax -- )) + +(defop < () + (:mov rcx 0) + (:mov rdx 1) + (rax rbx -- ) + (:cmp rax rbx) + ( -- (:cmovl rcx rdx))) + +(defop > () + (:mov rcx 0) + (:mov rdx 1) + (rax rbx -- ) + (:cmp rax rbx) + ( -- (:cmovg rcx rdx))) + +(defop bel () + ( -- bel)) + +(defop oku () + (rax -- ) + (:xor rbx rbx) + (:mov bl [rax]) + ( -- rbx)) + +(defop yaz () + (rax rbx -- ) + (:mov [rax] bl)) + +(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 "|" () + (rbx rcx -- (:or rbx cl))) + +(defop & () + (rbx rcx -- (:and rbx cl))) (defop dump () "pop rdi" "call dump") -(defop = () - "mov rcx, 0" - "mov rdx, 1" - "pop rax" - "pop rbx" - "cmp rax, rbx" - "cmove rcx, rdx" - "push rcx") - -(defop (exit code) () +(defop (exit code) (:lex nil) "mov rax, 60" ("mov rdi, ~a" code) "syscall") @@ -90,16 +222,6 @@ (:write (" jmp et_~a" döngü-num) ("et_~a:" label-num)))) -;; (rax -- rax rax) -(defop eş () - "pop rax" - "push rax" - "push rax") - -;; (rax -- ) -(defop düş () - "pop rax") - (defop (iken label-num) () "pop rax" "test rax, rax" @@ -108,97 +230,13 @@ (defop (döngü label-num) (:indent 0) ("et_~a:" label-num)) -(defop < () - "mov rcx, 0" - "mov rdx, 1" - "pop rbx" - "pop rax" - "cmp rax, rbx" - "cmovl rcx, rdx" - "push rcx") - -(defop > () - "mov rcx, 0" - "mov rdx, 1" - "pop rbx" - "pop rax" - "cmp rax, rbx" - "cmovg rcx, rdx" - "push rcx") - -(defop bel () - "push bel") - -(defop oku () - "pop rax" - "xor rbx, rbx" - "mov bl, [rax]" - "push rbx") - -(defop yaz () - "pop rbx" - "pop rax" - "mov [rax], bl") - -(defop (syscall 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")))) -;;; (rbx rax -- rbx rax rbx) -(defop üst () - "pop rax" - "pop rbx" - "push rbx" - "push rax" - "push rbx") - -;;; (rcx rbx rax -- rbx rax rcx) -(defop rot () - "pop rax" - "pop rbx" - "pop rcx" - "push rbx" - "push rax" - "push rcx") - -;;; (rbx rax -- rax rbx) -(defop değiş () - "pop rax" - "pop rbx" - "push rax" - "push rbx") - -;;; (rbx rcx -- (:shl rbx cl)) -(defop << () - "pop rcx" - "pop rbx" - "shl rbx, cl" - "push rbx") - -;;; (rbx rcx -- (:shr rbx cl)) -(defop >> () - "pop rcx" - "pop rbx" - "shr rbx, cl" - "push rbx") - -;;; (rbx rcx -- (:or rbx cl)) -(defop "|" () - "pop rax" - "pop rbx" - "or rbx, rax" - "push rbx") - -;;; (rbx rcx -- (:and rbx cl)) -(defop & () - "pop rax" - "pop rbx" - "and rbx, rax" - "push rbx") - (defun gen-header (op str) (format str " ;; -- ~s --~%" op)) -- cgit v1.2.3