Begin C code generation.
This commit is contained in:
157
assembly.lisp
157
assembly.lisp
@@ -1,7 +1,5 @@
|
||||
(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")
|
||||
@@ -122,7 +120,7 @@
|
||||
(reverse cur)))
|
||||
acc))))))
|
||||
|
||||
(defun expand-group (group out-stream &key (indent 4))
|
||||
(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
|
||||
@@ -140,14 +138,27 @@
|
||||
forms)))))))
|
||||
|
||||
(defun expand-nasm (out-stream indent body)
|
||||
(mapcan #'(lambda (group) (expand-group group out-stream
|
||||
(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)))))))
|
||||
|
||||
(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 '(nil))))
|
||||
(:c (expand-c out-stream indent body))))
|
||||
|
||||
(defun expand-method (target out-stream indent op-name args body)
|
||||
(with-gensyms (_op _args _target)
|
||||
@@ -159,12 +170,67 @@
|
||||
,@(if (null args)
|
||||
(expand-for-target target out-stream body indent)
|
||||
`((destructuring-bind ,args ,_args
|
||||
,@(expand-for-target target out-stream body indent))))))))
|
||||
,@(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(&stack);" 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(&stack, ~a ~a ~a);"
|
||||
arg1 opstr (not-cl arg2)))
|
||||
(collect (format nil
|
||||
"push(&stack, (~a ~a ~a) ? ~a : ~a);"
|
||||
arg1 opstr (not-cl arg2)
|
||||
(getf conds :ise)
|
||||
(getf conds :değilse))))))
|
||||
(collect (format nil "push(&stack, ~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"))
|
||||
(: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 :nasm)
|
||||
(defmacro defop (op-name+args (&key (indent 4) (lex t) (targets *targets*)
|
||||
(as nil))
|
||||
&body body)
|
||||
(declare (ignorable indent))
|
||||
@@ -173,9 +239,7 @@
|
||||
`(progn
|
||||
,@(unless (null lex)
|
||||
`((push ',op-name *identifiers*)))
|
||||
,@(iter (for target in (if (eq :all targets)
|
||||
*targets*
|
||||
(mklist targets)))
|
||||
,@(iter (for target in (mklist targets))
|
||||
(collect (expand-method target out-stream indent
|
||||
(if (null as) op-name as)
|
||||
args body)))))))
|
||||
@@ -207,9 +271,6 @@
|
||||
(defop > ()
|
||||
(rax rbx -- (:> rax rbx :ise 1 :değilse 0)))
|
||||
|
||||
(defop bel ()
|
||||
( -- bel))
|
||||
|
||||
(defop üst ()
|
||||
(rbx rax -- rbx rax rbx))
|
||||
|
||||
@@ -231,91 +292,70 @@
|
||||
(defop & ()
|
||||
(rbx rax -- (:and rbx rax)))
|
||||
|
||||
(defop oku ()
|
||||
|
||||
|
||||
;;; NASM operations
|
||||
(defop bel (:targets :nasm)
|
||||
( -- bel))
|
||||
|
||||
(defop oku (:targets :nasm)
|
||||
(rax -- )
|
||||
(:xor rbx rbx)
|
||||
(:mov bl [rax])
|
||||
( -- rbx))
|
||||
|
||||
(defop yaz ()
|
||||
(defop yaz (:targets :nasm)
|
||||
(rax rbx -- )
|
||||
(:mov [rax] bl))
|
||||
|
||||
;; ( -- a)
|
||||
(defop (push-int a) (:lex nil)
|
||||
(defop (push-int a) (:lex nil :targets :nasm)
|
||||
("push ~d" a))
|
||||
|
||||
(defop (push-str len addr str) (:lex nil)
|
||||
(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 ()
|
||||
(defop dump (:targets :nasm)
|
||||
"pop rdi"
|
||||
"call dump")
|
||||
|
||||
(defop (exit code) (:lex nil)
|
||||
(defop (exit code) (:lex nil :targets :nasm)
|
||||
"mov rax, 60"
|
||||
("mov rdi, ~a" code)
|
||||
"syscall")
|
||||
|
||||
(defop (ise label-num) ()
|
||||
(defop (ise label-num) (:targets :nasm)
|
||||
"pop rax"
|
||||
"test rax, rax"
|
||||
("jz et_~a" label-num))
|
||||
|
||||
(defop (yoksa yap-num ise-num) (:indent 0)
|
||||
(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)
|
||||
(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) ()
|
||||
(defop (iken label-num) (:targets :nasm)
|
||||
"pop rax"
|
||||
"test rax, rax"
|
||||
("jz et_~a" label-num))
|
||||
|
||||
(defop (döngü label-num) (:indent 0)
|
||||
(defop (döngü label-num) (:indent 0 :targets :nasm)
|
||||
("et_~a:" label-num))
|
||||
|
||||
(defop (syscall num) (:lex nil)
|
||||
(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 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:"
|
||||
@@ -351,3 +391,14 @@
|
||||
" syscall"
|
||||
" add rsp, 40"
|
||||
" ret")))
|
||||
|
||||
|
||||
;;; C operations
|
||||
(defop (push-int a) (:lex nil :targets :c)
|
||||
("push(&stack, ~d);" a))
|
||||
|
||||
;; (defop (push-str a) (:lex nil :targets :c)
|
||||
;; ("push(&stack, ~d);" a))
|
||||
|
||||
(defop dump (:targets :c)
|
||||
("printf(\"%d\\n\", pop(&stack));"))
|
||||
|
||||
Reference in New Issue
Block a user