simyager/kurt
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Begin C code generation.

Browse Source
This commit is contained in:
mRnea
2024-08-08 17:13:29 +03:00
parent b215590395
commit 1056b74b11
3 changed files with 168 additions and 74 deletions
Download Patch File Download Diff File Expand all files Collapse all files

157
assembly.lisp
View File

@@ -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));"))

65
cl-forth.lisp
View File

@@ -164,17 +164,19 @@
(parse-tokens tokens)))
;;; COMPILER
(defun write-program (program out &key (mem-cap 640000))
;;(defgeneric write-program (target program stream))
(defmethod write-program ((target (eql :nasm)) program out
&key (mem-cap 640000))
(format out "~a~%" "segment .text")
(gen-dump out)
(format out "~{~a~%~}" '("global _start"
"_start:"))
(let ((strs nil))
(iter (for op in-sequence program)
(let ((gen-val (gen-code op out)))
(let ((gen-val (write-op target out (car op) (cdr op))))
(when (and (consp gen-val) (eq :string (car gen-val)))
(push (cdr gen-val) strs))))
(gen-code '(:exit 0) out)
(write-op target out :exit '(0))
(unless (null strs)
(format out "segment .data~%")
(dolist (str strs)
@@ -184,18 +186,59 @@
(format out "~a~%" "segment .bss")
(format out "~a ~a~%" "bel: resb" mem-cap))
(defun generate-program (program &key (path "output.asm") (compile nil)
(mem-cap 640000) (silence nil))
(with-open-file (out path :direction :output
:if-exists :supersede)
(write-program program out :mem-cap mem-cap))
(defmethod write-program ((target (eql :c)) program out &key (mem-cap 640000))
(declare (ignore mem-cap))
(format out
"#include <stdio.h>
struct Stack {
int content[100];
int i;
};
typedef struct Stack Stack;
void push(Stack* stack, int val){
stack->content[stack->i] = val;
stack->i += 1;
}
int pop(Stack* stack){
stack->i -= 1;
return stack->content[stack->i];
}
Stack stack;
int rax, rbx;
int main(void){
stack.i = 0;
")
(iter (for op in-sequence program)
(write-op target out (car op) (cdr op)))
(format out " return 0;~%}~%"))
(defun generate-program (program
&key (path "output.asm") (compile nil)
(mem-cap 640000) (silence nil) (target :nasm))
(with-open-file (out path :direction :output :if-exists :supersede)
(write-program target program out :mem-cap mem-cap))
(when compile
(compile-program target path silence)))
(defgeneric compile-program (target path silence))
(setf (documentation #'compile-program 'function)
(format nil "Produces the executable from source code, targets are ~a"
*targets*))
(defmethod compile-program ((target (eql :nasm)) path silence)
(run `("nasm" "-felf64" ,path) :output t :silence silence)
(let ((name (first (uiop:split-string path :separator '(#\.)))))
(run `("ld" "-o" ,name ,(concatenate 'string name ".o"))
:output t :silence silence))))
:output t :silence silence)))
(defmethod compile-program ((target (eql :c)) path silence)
(run `("gcc" ,path) :output t :silence silence))
(defun compile-program (path)
(generate-program (make-program path) :compile t))

2
main.lisp
View File

@@ -12,7 +12,7 @@
;; (let ((program (prog-from-tokens tokens)))
;; (format t "~s~%" program)
;; (generate-program program :compile t)))
(compile-program (second args)))
(generate-program (make-program (second args)) :compile t))
((string= flag "-i")
(interpret-program (make-program (second args))))
((string= flag "-p")