diff options
| -rw-r--r-- | sarcasm.asd | 5 | ||||
| -rw-r--r-- | src/ast.lisp | 60 | ||||
| -rw-r--r-- | src/instr.lisp | 87 | ||||
| -rw-r--r-- | src/raw-instrs.lisp | 3 | ||||
| -rw-r--r-- | src/types.lisp | 68 | ||||
| -rw-r--r-- | src/util.lisp | 20 |
6 files changed, 151 insertions, 92 deletions
diff --git a/sarcasm.asd b/sarcasm.asd index dc8b4e8..0569a5d 100644 --- a/sarcasm.asd +++ b/sarcasm.asd @@ -5,8 +5,11 @@ :author "Colin <colin@cicadas.surf>" :license "GPL3" :version "0.0.1" - :depends-on (#:alexandria #:yacc) + :depends-on (#:alexandria #:closer-mop) :pathname "src/" :serial t :components ((:file "util") + (:file "types") + (:file "raw-instrs") + (:file "instr") (:file "ast"))) diff --git a/src/ast.lisp b/src/ast.lisp index eef5c05..9987ddf 100644 --- a/src/ast.lisp +++ b/src/ast.lisp @@ -1,70 +1,16 @@ (defpackage #:sarcasm.ast - (:use #:cl) + (:use #:cl #:sarcasm.types) (:import-from #:sarcasm.util #:def/class) (:local-nicknames (#:a #:alexandria-2) - (#:util #:sarcasm.util))) + (#:util #:sarcasm.util) + (#:instr #:sarcasm.instr))) (in-package #:sarcasm.ast) ;;; TYPES - -(deftype i32 () - '(integer 0 #.(expt 2 32))) - -(deftype i64 () - '(integer 0 #. (expt 2 64))) - -(deftype f32 () - 'single-float) - -(deftype f64 () - 'double-float) - -(deftype numtype () - '(or i32 i64 f32 f64)) - -(deftype typeidx () - 'i32) - -(deftype vectype () - '(bit-vector 128)) - -(deftype funcref () - 't) - -(deftype externref () - 't) - -(deftype reftype () - '(or funcref externref)) - -(deftype valtype () - '(or numtype vectype reftype)) - -(defun stack-effect-type-p (thing) - "A stack effect type is a two element list of lists of keywords. - -It describes the types of values consumed off the stack and returned -to the stack by instructions." - (and (listp thing) - (= 2 (length thing)) - (listp (first thing)) - (listp (second thing)) - (every #'keywordp (first thing)) - (every #'keywordp (second thing)))) - -(deftype stack-effect-type () - "This is not part of the standard grammar, but appears implicitly in -the WASM table of instructions found - - https://webassembly.github.io/spec/core/appendix/index-instructions.html - -In the `Type` column." - '(satisfies stack-effect-type-p)) - ;;; MODULE-STRUCTURES (def/class instr () diff --git a/src/instr.lisp b/src/instr.lisp index a5c94c6..db13941 100644 --- a/src/instr.lisp +++ b/src/instr.lisp @@ -1,45 +1,66 @@ (defpackage #:sarcasm.instr - (:use #:cl) + (:use #:cl #:sarcasm.types) (:shadow cl:return cl:if cl:block cl:loop cl:t) (:local-nicknames - (#:a #:alexandria-2))) + (#:a #:alexandria-2)) + (:export + ;; generic readers functions on every instruction + #:instr-name + #:instr-code + #:instr-type)) (in-package #:sarcasm.instr) (defclass instr () ()) (eval-when (:compile-toplevel :load-toplevel :execute) - (defun expand-instr-plist (plist) - (destructuring-bind (&key instr code type) plist - (let* ((class-name - (intern (string-upcase (first instr)))) - (immediates - (cl:loop - :for arg :in (rest instr) - :for slot-name := (intern (string-upcase arg)) - :for reader := (intern (format nil "~a-~a" class-name slot-name)) - :for initarg := (a:make-keyword slot-name) - :collect `(,slot-name - :reader ,reader - :initarg ,initarg - :initform (error "~a required" ',slot-name))))) - `(defclass ,class-name (instr) - ((instr-name - :allocation :class - :type string - :initform ,(first instr) - :reader instr-name) - (instr-code - :allocation :class - :type (vector (unsigned-byte 8) ,(length code)) - :initform (make-array ,(length code) - :element-type '(unsigned-byte 8) - :initial-contents ',code)) - (instr-type - :allocation :class - :type t - :initform ',type) - ,@immediates)))))) + (let ((defined (make-hash-table :test #'eql))) + (defun expand-instr-plist (plist) + (destructuring-bind (&key instr code type) plist + (let* ((class-name + (let ((class-name (intern (string-upcase (first instr))))) + (cl:if (gethash class-name defined) + (intern (format nil "~a_" class-name)) + class-name))) + (immediates + (cl:loop + :for arg :in (rest instr) + :for slot-name := (intern (string-upcase arg)) + :for reader := (intern (format nil "~a-~a" class-name slot-name)) + :for initarg := (a:make-keyword slot-name) + :collect `(,slot-name + :reader ,reader + :initarg ,initarg + :initform (error "~a required" ',slot-name))))) + + (setf (gethash class-name defined) cl:t) + + `(progn + (format cl:t "DEFINING ~A~%" ',class-name) + (defclass ,class-name (instr) + ((instr-name + :allocation :class + :type string + :initform ,(first instr) + :reader instr-name) + (instr-code + :allocation :class + :type (vector (unsigned-byte 8) ,(length code)) + :initform (make-array ,(length code) + :element-type '(unsigned-byte 8) + :initial-contents ',code)) + (instr-type + :allocation :class + :type stacksig + :initform ',type) + ,@immediates) + + ,@(when (not immediates) + '((:metaclass sarcasm.util::singleton)))) + + (export '(,class-name + ,@(mapcar #'first immediates) + ,@(mapcar #'third immediates))))))))) (macrolet ((create-instr-classes (raw) `(progn diff --git a/src/raw-instrs.lisp b/src/raw-instrs.lisp index 7fdbe66..dbb830d 100644 --- a/src/raw-instrs.lisp +++ b/src/raw-instrs.lisp @@ -518,4 +518,5 @@ (:INSTR ("f64x2.vconvert_low_i32x4_s") :CODE (253 254 1) :TYPE ((:V128) (:V128))) (:INSTR ("f64x2.vconvert_low_i32x4_u") :CODE (253 255 1) :TYPE - ((:V128) (:V128)))))
\ No newline at end of file + ((:V128) (:V128))))) + diff --git a/src/types.lisp b/src/types.lisp new file mode 100644 index 0000000..7bd9775 --- /dev/null +++ b/src/types.lisp @@ -0,0 +1,68 @@ +(defpackage #:sarcasm.types + (:use #:cl) + (:export + #:i32 #:i64 #:f32 #:f64 + #:numtype + #:typeidx + #:vectype + #:funcref + #:externref + #:reftype + #:valtype + #:stacksig)) + +(in-package #:sarcasm.types) + +(deftype i32 () + '(integer 0 #.(expt 2 32))) + +(deftype i64 () + '(integer 0 #. (expt 2 64))) + +(deftype f32 () + 'single-float) + +(deftype f64 () + 'double-float) + +(deftype numtype () + '(or i32 i64 f32 f64)) + +(deftype typeidx () + 'i32) + +(deftype vectype () + '(bit-vector 128)) + +(deftype funcref () + 't) + +(deftype externref () + 't) + +(deftype reftype () + '(or funcref externref)) + +(deftype valtype () + '(or numtype vectype reftype)) + +(defun stacksig-p (thing) + "A stack effect type is a two element list of lists of keywords. + +It describes the types of values consumed off the stack and returned +to the stack by instructions." + (and (listp thing) + (= 2 (length thing)) + (listp (first thing)) + (listp (second thing)) + (every #'keywordp (first thing)) + (every #'keywordp (second thing)))) + +(deftype stacksig () + "This is not part of the standard grammar, but appears implicitly in +the WASM table of instructions found + + https://webassembly.github.io/spec/core/appendix/index-instructions.html + +In the `Type` column." + '(satisfies stack-effect-type-p)) diff --git a/src/util.lisp b/src/util.lisp index 5899b36..e561778 100644 --- a/src/util.lisp +++ b/src/util.lisp @@ -82,3 +82,23 @@ CLASS-OPTIONS is a PLIST of class options." `(defclass ,name ,supers (,@slot-defs) ,@options)))) + +;;; SINGLETON CLASSES + +(defclass singleton (closer-mop:standard-class) + ((instance :reader singleton-instance + :initarg :instance + :documentation "The instance of a singleton class.")) + (:documentation "Metaclass for singleton classes.")) + + +(defmethod closer-mop:validate-superclass + ((sub singleton) (sup closer-mop:standard-class)) + t) + +(defmethod make-instance ((class singleton) &rest kwargs) + (declare (ignorable kwargs)) + (if (slot-boundp class 'instance) + (slot-value class 'instance) + (setf (slot-value class 'instance) (call-next-method)))) + |