summaryrefslogtreecommitdiff
path: root/assembly.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'assembly.lisp')
-rw-r--r--assembly.lisp482
1 files changed, 0 insertions, 482 deletions
diff --git a/assembly.lisp b/assembly.lisp
deleted file mode 100644
index 16183f7..0000000
--- a/assembly.lisp
+++ /dev/null
@@ -1,482 +0,0 @@
-(in-package :cl-forth)
-
-(defparameter *psuedo-identifiers*
- '(syscall-1 syscall-2 syscall-3 syscall-4 syscall-5 syscall-6 makro son kütüphane)
- "These do not map to operations that generate code directly, but are valid to lexer and parser")
-
-(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-nasm-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-nasm-group group out-stream
- :indent indent))
- (group-by-syntax body)))
-
- (defun expand-c-group (group out-stream &key (indent 4))
- (destructuring-bind (syntax-type . forms) group
- (case syntax-type
- ((:stack :stack-extended) `((defop-format ,out-stream ,indent
- ,(cons 'list
- (c-stack->string (car 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-c (out-stream indent body)
- (mapcan #'(lambda (group) (expand-c-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 (expand-c out-stream indent body))))
-
- (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)))))))
-
- ;;hack, because there is no cl in C only nasm
- (defun not-cl (sym)
- (if (eq 'cl sym)
- 'rcx
- sym))
-
- (defparameter *c-ops* '((:add "+")
- (:sub "-")
- (:shl "<<")
- (:shr ">>")
- (:or "|")
- (:and "&")
- (:< "<")
- (:> ">")
- (:= "==")))
-
- (defun c-stack->string (stack)
- (multiple-value-bind (prev next) (split-stack stack)
- (let ((*print-case* :downcase))
- (append (iter (for x in (reverse prev))
- (collect (format nil "~a = pop();" x)))
- (iter (for x in next)
- (if (and (consp x) (assoc (car x) *c-ops*))
- (destructuring-bind (op arg1 arg2 . conds) x
- (let ((opstr (cadr (assoc op *c-ops*))))
- (if (null conds)
- (collect (format nil "push(~a ~a ~a);"
- arg1 opstr (not-cl arg2)))
- (collect (format nil
- "push((~a ~a ~a) ? ~a : ~a);"
- arg1 opstr (not-cl arg2)
- (getf conds :ise)
- (getf conds :değilse))))))
- (collect (format nil "push(~a);" x)))))))))
-
-(defun comment-safe-str (str)
- "Handle newlines for 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))))))
-
-(defgeneric write-op (target stream op args)
- (:documentation "Generate code for OP and ARGS and write it to STREAM according to the TARGET. WRITE-OP methods are defined by the DEFOP macro.")
- (:method :before ((target (eql :nasm)) stream op args)
- (format stream " ;; -- ~s --~%"
- (mapcar (lambda (x) (if (stringp x) (comment-safe-str x) x))
- (cons op args))))
- (:method :before ((target (eql :c)) stream op args)
- (format stream "~% /* ~s */~%"
- ;; comment-safe is probably not necessary with multiline comments
- (mapcar (lambda (x) (if (stringp x) (comment-safe-str x) x))
- (cons op args)))))
-
-(defmacro defop (op-name+args (&key (indent 4) (lex t) (targets *targets*)
- (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 (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 ü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)))
-
-
-
-;;; NASM operations
-(defop bel (:targets :nasm)
- ( -- bel))
-
-(defop oku (:targets :nasm)
- (rax -- )
- (:xor rbx rbx)
- (:mov bl [rax])
- ( -- rbx))
-
-(defop yaz (:targets :nasm)
- (rax rbx -- )
- (:mov [rax] bl))
-
-;; ( -- a)
-(defop (push-int a) (:lex nil :targets :nasm)
- ("push ~d" a))
-
-(defop (push-str len addr str) (:lex nil :targets :nasm)
- (progn (:write ("push ~d" len)
- ("push str_~d" addr))
- (list :string addr str)))
-
-(defop dump (:targets :nasm)
- "pop rdi"
- "call dump")
-
-(defop (exit code) (:lex nil :targets :nasm)
- "mov rax, 60"
- ("mov rdi, ~a" code)
- "syscall")
-
-(defop (ise label-num) (:targets :nasm)
- "pop rax"
- "test rax, rax"
- ("jz et_~a" label-num))
-
-(defop (yoksa yap-num ise-num) (:indent 0 :targets :nasm)
- (" jmp et_~a" yap-num)
- ("et_~a:" ise-num))
-
-(defop (yap label-num &optional döngü-num) (:indent 0 :targets :nasm)
- (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) (:targets :nasm)
- "pop rax"
- "test rax, rax"
- ("jz et_~a" label-num))
-
-(defop (döngü label-num) (:indent 0 :targets :nasm)
- ("et_~a:" label-num))
-
-(defop (syscall num) (:lex nil :targets :nasm)
- (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 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")))
-
-
-;;; C operations
-(defop (push-int a) (:lex nil :targets :c)
- ("push(~d);" a))
-
-;; (defop (push-str a) (:lex nil :targets :c)
-;; ("push(&stack, ~d);" a))
-
-(defop dump (:targets :c)
- ("printf(\"%d\\n\", pop());"))
-
-(defop (ise label-num) (:targets :c)
- "rax = pop();"
- ("if(!rax){ goto et_~a; }" label-num))
-
-(defop (yoksa yap-num ise-num) (:indent 0 :targets :c)
- (" goto et_~a;" yap-num)
- ("et_~a:" ise-num))
-
-(defop (yap label-num &optional döngü-num) (:indent 0 :targets :c)
- (if (null döngü-num)
- (:write ("et_~a:" label-num))
- (:write (" goto et_~a;" döngü-num)
- ("et_~a:" label-num))))
-
-(defop (iken label-num) (:targets :c)
- "rax = pop();"
- ("if(!rax){ goto et_~a; }" label-num))
-
-(defop (döngü label-num) (:indent 0 :targets :c)
- ("et_~a:" label-num))
-
-(defop bel (:targets :c)
- "push((uintptr_t) bel);")
-
-(defop oku (:targets :c)
- "push(*((char*) pop()));")
-
-(defop yaz (:targets :c)
- "rax = pop();"
- "*((char*) pop()) = rax;")
-
-(defop (syscall num) (:lex nil :targets :c)
- (iter (with call-regs = #("rdi" "rsi" "rdx" "r10" "r8" "r9"))
- (initially (:write "rax = pop();"))
- (for i from (- num 1) downto 0)
- (:write ("~a = pop();" (aref call-regs i)))
- (collect (aref call-regs i) into used-regs)
- (finally (:write ("syscall(rax~{, ~a~});" (reverse used-regs))))))
-
-(defun gen-c-stack (stream)
- (format stream "~{~a~%~}"
- '("#include <stdio.h>"
- "#include <stdint.h>"
- ""
- "struct Stack {"
- " uintptr_t content[1000000];"
- " int i;"
- "};"
- ""
- "typedef struct Stack Stack;"
- ""
- "Stack stack = { .i = 0 };"
- ""
- "void push(uintptr_t val){"
- " stack.content[stack.i] = val;"
- " stack.i += 1;"
- "}"
- ""
- "uintptr_t pop(){"
- " stack.i -= 1;"
- " return stack.content[stack.i];"
- "}"
- ""
- "uintptr_t rax, rbx, rcx, rdi, rsi, rdx, r10, r8, r9;"
- "char bel[640000];"
- "")))
-
-(defmacro with-c-fn ((ret name) args out &body body)
- `(let ((*print-case* :downcase))
- (format ,out "~a ~a(~{~a ~a~^, ~}){~%" ',ret ',name ',args)
- ,@body
- (format ,out "~&}~%")))
-
-
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-28 20:05:04 +0000