354 lines
12 KiB
Common Lisp
354 lines
12 KiB
Common 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")))
|