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

massive overhaul to defop, temporarily disable interpretation

Browse Source
This commit is contained in:
mRnea
2024-07-31 14:53:18 +03:00
parent 7f6bb99e08
commit e4419034ce
2 changed files with 229 additions and 206 deletions
Download Patch File Download Diff File Expand all files Collapse all files

286
assembly.lisp
View File

@@ -2,6 +2,18 @@
(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
(defun normalize-op-list (asm-list)
(cons 'list
@@ -22,55 +34,175 @@
,(normalize-op-list (cdr forms)))
(cons (replace-write out-stream indent (car forms))
(replace-write out-stream indent (cdr forms))))
forms)))
forms))
(defmacro defop (op-name+args (&key (indent 4)) &body body)
(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)))))))))
(defun syntax-of (form)
(cond ((or (stringp form)
(and (consp form) (stringp (car form))))
:string)
((and (listp form) (find '-- form))
: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))))
(: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)
(with-gensyms (out-stream)
(destructuring-bind (op-name . args) (mklist op-name+args)
`(setf (gethash ,(string op-name) *operations*)
(lambda (,out-stream ,@args)
,(if (or (stringp (car body)) (stringp (caar body)))
`(defop-format ,out-stream ,indent
,(normalize-op-list body))
(replace-write out-stream indent (car body))))))))
`(progn
,@(append
(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))))))))))
;;; TODO: Turn stack operation comments to DEFOP option,
;;; which then can be used by the user as a documentation
;;; TODO: Better yet, generate the asm code directly from
;;; the stack op documentation (this seems easily doable)
;;; Hopefully these two are done, need testing...
;; ( -- a)
(defop (push a) ()
(defop (push a) (:lex nil)
("push ~d" a))
;; (rbx rax -- (rbx + rax))
(defop + ()
"pop rax"
"pop rbx"
"add rax, rbx"
"push rax")
(rbx rax -- (:add rax rbx)))
;; (rbx rax -- (rbx - rax))
(defop - ()
"pop rax"
"pop rbx"
"sub rbx, rax"
"push rbx")
(rbx rax -- (:sub rbx rax)))
(defop = ()
(:mov rcx 0)
(:mov rdx 1)
(rbx rax -- )
(:cmp rax rbx)
( -- (:cmove rcx rdx)))
(defop eş ()
(rax -- rax rax))
(defop düş ()
(rax -- ))
(defop < ()
(:mov rcx 0)
(:mov rdx 1)
(rax rbx -- )
(:cmp rax rbx)
( -- (:cmovl rcx rdx)))
(defop > ()
(:mov rcx 0)
(:mov rdx 1)
(rax rbx -- )
(:cmp rax rbx)
( -- (:cmovg rcx rdx)))
(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))
(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 "|" ()
(rbx rcx -- (:or rbx cl)))
(defop & ()
(rbx rcx -- (:and rbx cl)))
(defop dump ()
"pop rdi"
"call dump")
(defop = ()
"mov rcx, 0"
"mov rdx, 1"
"pop rax"
"pop rbx"
"cmp rax, rbx"
"cmove rcx, rdx"
"push rcx")
(defop (exit code) ()
(defop (exit code) (:lex nil)
"mov rax, 60"
("mov rdi, ~a" code)
"syscall")
@@ -90,16 +222,6 @@
(:write (" jmp et_~a" döngü-num)
("et_~a:" label-num))))
;; (rax -- rax rax)
(defop eş ()
"pop rax"
"push rax"
"push rax")
;; (rax -- )
(defop düş ()
"pop rax")
(defop (iken label-num) ()
"pop rax"
"test rax, rax"
@@ -108,97 +230,13 @@
(defop (döngü label-num) (:indent 0)
("et_~a:" label-num))
(defop < ()
"mov rcx, 0"
"mov rdx, 1"
"pop rbx"
"pop rax"
"cmp rax, rbx"
"cmovl rcx, rdx"
"push rcx")
(defop > ()
"mov rcx, 0"
"mov rdx, 1"
"pop rbx"
"pop rax"
"cmp rax, rbx"
"cmovg rcx, rdx"
"push rcx")
(defop bel ()
"push bel")
(defop oku ()
"pop rax"
"xor rbx, rbx"
"mov bl, [rax]"
"push rbx")
(defop yaz ()
"pop rbx"
"pop rax"
"mov [rax], bl")
(defop (syscall 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"))))
;;; (rbx rax -- rbx rax rbx)
(defop üst ()
"pop rax"
"pop rbx"
"push rbx"
"push rax"
"push rbx")
;;; (rcx rbx rax -- rbx rax rcx)
(defop rot ()
"pop rax"
"pop rbx"
"pop rcx"
"push rbx"
"push rax"
"push rcx")
;;; (rbx rax -- rax rbx)
(defop değiş ()
"pop rax"
"pop rbx"
"push rax"
"push rbx")
;;; (rbx rcx -- (:shl rbx cl))
(defop << ()
"pop rcx"
"pop rbx"
"shl rbx, cl"
"push rbx")
;;; (rbx rcx -- (:shr rbx cl))
(defop >> ()
"pop rcx"
"pop rbx"
"shr rbx, cl"
"push rbx")
;;; (rbx rcx -- (:or rbx cl))
(defop "|" ()
"pop rax"
"pop rbx"
"or rbx, rax"
"push rbx")
;;; (rbx rcx -- (:and rbx cl))
(defop & ()
"pop rax"
"pop rbx"
"and rbx, rax"
"push rbx")
(defun gen-header (op str)
(format str " ;; -- ~s --~%" op))

149
cl-forth.lisp
View File

@@ -1,13 +1,5 @@
(in-package :cl-forth)
(eval-always
(defparameter *identifiers*
'(+ - dump = ise yoksa yap eş push değiş üst rot düş döngü iken < >
syscall-1 syscall-2 syscall-3 syscall-4 syscall-5 syscall-6
bel oku yaz >> << & "|"))
(defun is-identifier (sym)
(find sym *identifiers* :test #'string=)))
(defun assembly-undefined-ops ()
(iter (for (k) in-hashtable *operations*)
(collect k into defops)
@@ -150,83 +142,76 @@
;;; INTERPRETER
(eval-always
(define-condition op-not-implemented (style-warning)
((undef-ops :initarg :ops :reader undef-ops))
(:report (lambda (condition stream)
(format stream "These ops are not defined in op-case: ~s"
(undef-ops condition)))))
;; (eval-always
;; (define-condition op-not-implemented (style-warning)
;; ((undef-ops :initarg :ops :reader undef-ops))
;; (:report (lambda (condition stream)
;; (format stream "These ops are not defined in op-case: ~s"
;; (undef-ops condition)))))
(defun identifier-coverage (defined-ops)
(let ((undef-ops (set-difference *identifiers* defined-ops)))
(unless (null undef-ops)
(warn (make-condition 'op-not-implemented :ops undef-ops))))))
(defmacro op-case (case-form &body body)
(iter (for (op-id) in body)
(when (not (is-identifier op-id))
(error "op-case: ~a is not an identifier" op-id))
(collect op-id into defined-ops)
(finally (identifier-coverage defined-ops)))
(let ((case-sym (gensym)))
`(let ((,case-sym ,case-form))
(case ,case-sym
,@body
(otherwise (if (is-identifier (first ,case-sym))
(error "op: ~a -- Not implemented yet"
(first ,case-sym))
(error "op: ~a -- Does not exist"
(first ,case-sym))))))))
(defun interpret-program (program)
(iter (with stack = (make-array 100 :fill-pointer 0 :adjustable t))
;; (for op in-sequence program)
(for i from 0 below (length program))
(let ((op (aref program i)))
(op-case (first op)
(push (vector-push-extend (second op) stack))
(+ (vector-push-extend (+ (vector-pop stack)
(vector-pop stack))
stack))
(- (vector-push-extend (let ((top (vector-pop stack)))
(- (vector-pop stack) top))
stack))
(dump (print (vector-pop stack)))
(= (vector-push-extend (if (= (vector-pop stack)
(vector-pop stack))
1 0)
stack))
(yap (next-iteration))
(yoksa (setf i (second op)))
(ise (if (= (vector-pop stack) 1)
nil
(setf i (second op))))
(eş (let ((top (vector-pop stack)))
(vector-push-extend top stack)
(vector-push-extend top stack)))
(değiş (let* ((fst (vector-pop stack))
(snd (vector-pop stack)))
(vector-push-extend fst stack)
(vector-push-extend snd stack)))
(düş (vector-pop stack))
(üst (let* ((fst (vector-pop stack))
(snd (vector-pop stack)))
(vector-push-extend snd stack)
(vector-push-extend fst stack)
(vector-push-extend snd stack)))
(rot (let* ((fst (vector-pop stack))
(snd (vector-pop stack))
(trd (vector-pop stack)))
(vector-push-extend snd stack)
(vector-push-extend fst stack)
(vector-push-extend trd stack)))))))
;; swap, değiş
;; dup, eş
;; over, üst
;; rot, rot
;; drop, düşür
;; (defun identifier-coverage (defined-ops)
;; (let ((undef-ops (set-difference *identifiers* defined-ops)))
;; (unless (null undef-ops)
;; (warn (make-condition 'op-not-implemented :ops undef-ops))))))
;; (defmacro op-case (case-form &body body)
;; (iter (for (op-id) in body)
;; (when (not (is-identifier op-id))
;; (error "op-case: ~a is not an identifier" op-id))
;; (collect op-id into defined-ops)
;; (finally (identifier-coverage defined-ops)))
;; (let ((case-sym (gensym)))
;; `(let ((,case-sym ,case-form))
;; (case ,case-sym
;; ,@body
;; (otherwise (if (is-identifier (first ,case-sym))
;; (error "op: ~a -- Not implemented yet"
;; (first ,case-sym))
;; (error "op: ~a -- Does not exist"
;; (first ,case-sym))))))))
;; (defun interpret-program (program)
;; (iter (with stack = (make-array 100 :fill-pointer 0 :adjustable t))
;; ;; (for op in-sequence program)
;; (for i from 0 below (length program))
;; (let ((op (aref program i)))
;; (op-case (first op)
;; (push (vector-push-extend (second op) stack))
;; (+ (vector-push-extend (+ (vector-pop stack)
;; (vector-pop stack))
;; stack))
;; (- (vector-push-extend (let ((top (vector-pop stack)))
;; (- (vector-pop stack) top))
;; stack))
;; (dump (print (vector-pop stack)))
;; (= (vector-push-extend (if (= (vector-pop stack)
;; (vector-pop stack))
;; 1 0)
;; stack))
;; (yap (next-iteration))
;; (yoksa (setf i (second op)))
;; (ise (if (= (vector-pop stack) 1)
;; nil
;; (setf i (second op))))
;; (eş (let ((top (vector-pop stack)))
;; (vector-push-extend top stack)
;; (vector-push-extend top stack)))
;; (değiş (let* ((fst (vector-pop stack))
;; (snd (vector-pop stack)))
;; (vector-push-extend fst stack)
;; (vector-push-extend snd stack)))
;; (düş (vector-pop stack))
;; (üst (let* ((fst (vector-pop stack))
;; (snd (vector-pop stack)))
;; (vector-push-extend snd stack)
;; (vector-push-extend fst stack)
;; (vector-push-extend snd stack)))
;; (rot (let* ((fst (vector-pop stack))
;; (snd (vector-pop stack))
;; (trd (vector-pop stack)))
;; (vector-push-extend snd stack)
;; (vector-push-extend fst stack)
;; (vector-push-extend trd stack)))))))
;;; COMPILER
(defun write-program (program out &key (mem-cap 640000))