From b2155903956b6ddf41ed64fccb4263858fff8d4f Mon Sep 17 00:00:00 2001 From: mRnea Date: Tue, 6 Aug 2024 23:02:14 +0300 Subject: defop uses generic functions now. extended stack syntax --- assembly.lisp | 170 ++++++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 111 insertions(+), 59 deletions(-) (limited to 'assembly.lisp') diff --git a/assembly.lisp b/assembly.lisp index c1efe45..422ea6c 100644 --- a/assembly.lisp +++ b/assembly.lisp @@ -15,6 +15,8 @@ (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) @@ -67,12 +69,39 @@ ((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)) - :stack) + (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))) @@ -96,29 +125,60 @@ (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) + (: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*))) - (setf (gethash ,(string op-name) *operations*) - (lambda (,out-stream ,@args) - ,@(mapcar #'(lambda (group) (expand-group group out-stream - :indent indent)) - (group-by-syntax body)))))))) + ,@(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 @@ -126,15 +186,6 @@ ;;; the stack op documentation (this seems easily doable) ;;; Hopefully these two are done, need testing... -;; ( -- 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 + () (rbx rax -- (:add rax rbx))) @@ -142,11 +193,7 @@ (rbx rax -- (:sub rbx rax))) (defop = () - (:mov rcx 0) - (:mov rdx 1) - (rbx rax -- ) - (:cmp rax rbx) - ( -- (:cmove rcx rdx))) + (rbx rax -- (:= rbx rax :ise 1 :değilse 0))) (defop eş () (rax -- rax rax)) @@ -155,32 +202,14 @@ (rax -- )) (defop < () - (:mov rcx 0) - (:mov rdx 1) - (rax rbx -- ) - (:cmp rax rbx) - ( -- (:cmovl rcx rdx))) + (rax rbx -- (:< rax rbx :ise 1 :değilse 0))) (defop > () - (:mov rcx 0) - (:mov rdx 1) - (rax rbx -- ) - (:cmp rax rbx) - ( -- (:cmovg rcx rdx))) + (rax rbx -- (:> rax rbx :ise 1 :değilse 0))) (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)) @@ -196,12 +225,31 @@ (defop >> () (rbx rcx -- (:shr rbx cl))) -(defop "|" () +(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") @@ -257,12 +305,16 @@ (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) - (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)))) + (gen-header op str) + (write-op :nasm str (car op) (cdr op))) (defun gen-dump (str) (format str "~{~a~%~}" -- cgit v1.2.3