defop uses generic functions now. extended stack syntax
This commit is contained in:
168
assembly.lisp
168
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)))))))
|
||||
(: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)))))))
|
||||
|
||||
(defmacro defop (op-name+args (&key (indent 4) (lex t)) &body body)
|
||||
(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~%~}"
|
||||
|
||||
Reference in New Issue
Block a user