121 lines
4.6 KiB
Common Lisp
121 lines
4.6 KiB
Common Lisp
(in-package #:user-side-compiler)
|
|
|
|
(defclass ir-inst ()
|
|
((%next :accessor next :initarg :successor)
|
|
(%previous :accessor previous :initarg :predecessor)
|
|
(%inputs :accessor inputs :initarg :inputs :initform '())
|
|
(%output :accessor output :initarg :output :initform nil)
|
|
(%iblock :accessor iblock :initarg :iblock)
|
|
(%source :accessor source :initarg :source)))
|
|
|
|
(defmethod effect-used-p ((inst ir-inst))
|
|
nil)
|
|
|
|
(defmethod (setf inputs) ((new-value list) (object ir-inst))
|
|
(when (slot-boundp object '%inputs)
|
|
(mapc (lambda (i) (remove-user i object)) (inputs object)))
|
|
(dolist (data new-value)
|
|
(add-user data object))
|
|
(setf (slot-value object '%inputs) new-value))
|
|
|
|
(defmethod shared-initialize :before
|
|
((instance ir-inst) slot-names &rest initargs
|
|
&key (inputs nil inputsp) (input nil inputp) (output nil outputp)
|
|
&allow-other-keys)
|
|
(declare (ignore slot-names initargs))
|
|
(when outputp
|
|
(when (slot-boundp instance '%output)
|
|
(setf (definition (output instance)) nil))
|
|
(setf (output instance) output
|
|
(definition output) instance))
|
|
(assert (not (and inputsp inputp))) ; cannot give both singular and plural
|
|
(when inputsp
|
|
(setf (inputs instance) inputs))
|
|
(when inputp
|
|
(setf (inputs instance) (list input))))
|
|
|
|
(defclass ir-one-input (ir-inst)
|
|
((%inputs :type (or null (cons t null))))
|
|
(:documentation "Mixin for instructions that may take only one input."))
|
|
|
|
(defclass ir-effect-use (ir-inst) ()
|
|
(:documentation "An instruction used at least in part for its side-effects. May not be deleted
|
|
solely due to its output being unused."))
|
|
|
|
(defmethod effect-used-p ((inst ir-effect-use))
|
|
t)
|
|
|
|
(defclass ir-no-output (ir-effect-use)
|
|
((%output :accessor output :type null :initform nil))
|
|
(:documentation "Mixin forbidding an instruction from having an output."))
|
|
|
|
(defmethod input ((inst ir-one-input))
|
|
(first (inputs inst)))
|
|
|
|
(defclass ir-terminator (ir-inst)
|
|
((%destinations :accessor destinations :initarg :destinations)
|
|
(%next :initform nil :type null))
|
|
(:documentation "An instruction that ends a basic block."))
|
|
|
|
(defclass ir-return (ir-terminator)
|
|
((%destinations :initform nil :type null)))
|
|
|
|
(defclass ir-if (ir-terminator ir-one-input) ())
|
|
(defclass ir-jump (ir-terminator) ())
|
|
|
|
(defclass ir-getconst (ir-one-input ir-inst)
|
|
((%inputs :type (or null (cons fixnum null)))))
|
|
|
|
(tlk:define-simple-print-object (ir-getconst %inputs) :format-string "~{~A~}")
|
|
|
|
(defmethod shared-initialize :after ((instance ir-getconst) slot-names &rest initargs
|
|
&key &allow-other-keys)
|
|
(declare (ignore slot-names initargs))
|
|
(unless (null (output instance))
|
|
(check-type (output instance) ir-constant)
|
|
(setf (value (output instance))
|
|
(input instance))))
|
|
|
|
(defclass ir-fetchvar (ir-one-input ir-inst) ())
|
|
(defclass ir-assign (ir-one-input ir-inst) ())
|
|
|
|
(defclass ir-operation (ir-inst) ())
|
|
(defclass ir-comparison (ir-operation) ())
|
|
|
|
(defclass ir-call (ir-inst)
|
|
((%callee :accessor callee :initarg :callee)))
|
|
|
|
(defmethod effect-used-p ((inst ir-call))
|
|
;; TODO: Return the non-pureness of the callee
|
|
t)
|
|
|
|
;;; A messy but quick way to define all the very similar arithmetic operations
|
|
(defvar *expr-inst-mappings* '())
|
|
|
|
(defun get-ir-expr-inst-type (node)
|
|
(loop :for (node-class . ir-class) :in *expr-inst-mappings*
|
|
:when (typep node node-class)
|
|
:return ir-class))
|
|
|
|
(macrolet ((ops ((&rest superclasses) &rest classes)
|
|
`(progn
|
|
,@(loop :for (class-name ignore symbol) :in classes
|
|
:collect `(progn
|
|
(defclass ,class-name ,superclasses ())
|
|
(defmethod print-ir-inst ((inst ,class-name))
|
|
(format t " (~A~{ ~A~}) -> ~A~%"
|
|
,symbol (inputs inst) (output inst)))))
|
|
(setf *expr-inst-mappings*
|
|
(append
|
|
*expr-inst-mappings*
|
|
',(loop :for (ir-class node-class ignore) :in classes
|
|
:unless (null node-class)
|
|
:collect `(,node-class . ,ir-class)))))))
|
|
(setf *expr-inst-mappings* '())
|
|
(ops (ir-operation) ; NILs indicate TODOs here for now
|
|
(ir-plus node-expr-plus "+") (ir-minus node-expr-minus "-") (ir-mult node-expr-multiply "*") (ir-div node-expr-divide "/"))
|
|
(ops (ir-comparison)
|
|
(ir-test-equal node-expr-test-equal "==")
|
|
(ir-test-not-equal node-expr-test-not-equal "!=")
|
|
(ir-test-less nil "<") (ir-test-greater nil ">")
|
|
(ir-test-less-or-equal nil "<=") (ir-test-greater-or-equal nil ">=")))
|