;;;; Random Common Lisp code useful to use here and there.
(defmacro with-gensyms ((&rest vars) &body body)
- `(let ,(mapcar (lambda (var) `(,var (gensym ,(string var)))) vars)
+ `(let ,(mapcar (lambda (var) `(,var (gensym ,(concatenate 'string (string var) "-")))) vars)
,@body))
(defun singlep (x)
(assert (singlep x))
(first x))
+(defun generic-printer (x stream)
+ (print-unreadable-object (x stream :type t :identity t)))
+
;;;; Intermediate representation structures
;;;;
;;; A lambda expression. Why do we name it `functional'? Well,
;;; function is reserved by the ANSI, isn't it?
-(defstruct (functional (:include leaf))
+(defstruct (functional (:include leaf) (:print-object generic-printer))
;; The symbol which names this function in the source code or null
;; if we do not know or it is an anonymous function.
name
;;; A base structure for every single computation. Most of the
;;; computations are valued.
-(defstruct node
+(defstruct (node (:print-object generic-printer))
;; The next and the prev slots are the next nodes and the previous
;; node in the basic block sequence respectively.
next prev
variable
value)
-;;; Call the lvar FUNCTION with a list of lvars as ARGUMENTS.
-(defstruct (call (:include node))
- function
+;;; A base node to function calls with a list of lvar as ARGUMENTS.
+(defstruct (combination (:include node) (:constructor))
arguments)
+;;; A function call to the ordinary Lisp function in the lvar FUNCTION.
+(defstruct (call (:include combination))
+ function)
+
+;;; A function call to the primitive FUNCTION.
+(defstruct (primitive-call (:include combination))
+ function)
+
+
;;; A conditional branch. If the LVAR is not NIL, then we will jump to
;;; the basic block CONSEQUENT, jumping to ALTERNATIVE otherwise. By
;;; definition, a conditional must appear at the end of a basic block.
alternative)
+;;;; Components
+;;;;
+;;;; Components are connected pieces of the control flow graph of
+;;;; basic blocks with some additional information. Components have
+;;;; well-defined entry and exit nodes. It is the toplevel
+;;;; organizational entity in the compiler. The IR translation result
+;;;; is accumulated into components incrementally.
+(defstruct (component (:print-object generic-printer))
+ entry
+ exit)
+
+;;; The current component. We accumulate the results of the IR
+;;; conversion in this component.
+(defvar *component*)
+
+;;; Create a new component with an empty basic block, ready to start
+;;; conversion to IR. It returns the component and the basic block as
+;;; multiple values.
+(defun make-empty-component ()
+ (let ((*component* (make-component)))
+ (let ((entry (make-component-entry))
+ (block (make-empty-block))
+ (exit (make-component-exit)))
+ (setf (block-succ entry) (list block)
+ (block-pred exit) (list block)
+ (block-succ block) (list exit)
+ (block-pred block) (list entry)
+ (component-entry *component*) entry
+ (component-exit *component*) exit)
+ (values *component* block))))
+
+;;; Prepare a new component with a current empty block ready to start
+;;; IR conversion bound in the current cursor. BODY is evaluated and
+;;; the value of the last form is returned.
+(defmacro with-component-compilation (&body body)
+ (with-gensyms (block)
+ `(multiple-value-bind (*component* ,block)
+ (make-empty-component)
+ (let ((*cursor* (cursor :block ,block)))
+ ,@body))))
+
+;;; Return the list of blocks in COMPONENT, conveniently sorted.
+(defun component-blocks (component)
+ (let ((seen nil)
+ (output nil))
+ (labels ((compute-rdfo-from (block)
+ (unless (or (component-exit-p block) (find block seen))
+ (push block seen)
+ (dolist (successor (block-succ block))
+ (unless (component-exit-p block)
+ (compute-rdfo-from successor)))
+ (push block output))))
+ (compute-rdfo-from (unlist (block-succ (component-entry component))))
+ output)))
+
+;;; Iterate across different blocks in COMPONENT.
+(defmacro do-blocks ((block component &optional result) &body body)
+ `(dolist (,block (component-blocks ,component) ,result)
+ ,@body))
+
+(defmacro do-blocks-backward ((block component &optional result) &body body)
+ `(dolist (,block (reverse (component-blocks ,component)) ,result)
+ ,@body))
+
+;;; A few consistency checks in the IR useful for catching bugs.
+(defun check-ir-consistency (&optional (component *component*))
+ (with-simple-restart (continue "Continue execution")
+ (do-blocks (block component)
+ (dolist (succ (block-succ block))
+ (unless (find block (block-pred succ))
+ (error "The block `~S' does not belong to the predecessors list of the its successor `~S'"
+ (block-id block)
+ (block-id succ))))
+ (dolist (pred (block-pred block))
+ (unless (find block (block-succ pred))
+ (error "The block `~S' does not belong to the successors' list of its predecessor `~S'"
+ (block-id block)
+ (block-id pred)))))))
+
+
;;; Blocks are `basic block`. Basic blocks are organized as a control
;;; flow graph with some more information in omponents.
(defstruct (basic-block
;; List of successors and predecessors of this basic block.
succ pred
;; The sentinel nodes of the sequence.
- entry exit)
+ entry exit
+ ;; The component where this block belongs
+ (component *component*))
;;; Sentinel nodes in the control flow graph of basic blocks.
(defstruct (component-entry (:include basic-block)))
(split-block cursor)))
-;;;; Components
-;;;;
-;;;; Components are connected pieces of the control flow graph of
-;;;; basic blocks with some additional information. Components have
-;;;; well-defined entry and exit nodes. It is the toplevel
-;;;; organizational entity in the compiler. The IR translation result
-;;;; is accumulated into components incrementally.
-(defstruct (component #-jscl (:print-object print-component))
- entry
- exit)
-
-;;; Create a new component with an empty basic block, ready to start
-;;; conversion to IR. It returns the component and the basic block as
-;;; multiple values.
-(defun make-empty-component ()
- (let ((entry (make-component-entry))
- (block (make-empty-block))
- (exit (make-component-exit)))
- (setf (block-succ entry) (list block)
- (block-pred exit) (list block)
- (block-succ block) (list exit)
- (block-pred block) (list entry))
- (values (make-component :entry entry :exit exit) block)))
-
-;;; Return the list of blocks in COMPONENT, conveniently sorted.
-(defun component-blocks (component)
- (let ((output nil))
- (labels ((compute-rdfo-from (block)
- (unless (or (component-exit-p block) (find block output))
- (dolist (successor (block-succ block))
- (unless (component-exit-p block)
- (compute-rdfo-from successor)))
- (push block output))))
- (compute-rdfo-from (unlist (block-succ (component-entry component))))
- output)))
-
-;;; Iterate across different blocks in COMPONENT.
-(defmacro do-blocks ((block component &optional result) &body body)
- `(dolist (,block (component-blocks ,component) ,result)
- ,@body))
-
-;;; A few consistency checks in the IR useful for catching bugs.
-(defun check-ir-consistency (component)
- (with-simple-restart (continue "Continue execution")
- (do-blocks (block component)
- (dolist (succ (block-succ block))
- (unless (find block (block-pred succ))
- (error "The block `~S' does not belong to the predecessors list of the its successor `~S'"
- (block-id block)
- (block-id succ))))
- (dolist (pred (block-pred block))
- (unless (find block (block-succ pred))
- (error "The block `~S' does not belong to the successors' list of its predecessor `~S'"
- (block-id block)
- (block-id pred)))))))
-
;;;; Lexical environment
;;;;
(defstruct binding
name namespace type value)
-(defvar *lexenv*)
+(defvar *lexenv* nil)
(defun find-binding (name namespace)
(find-if (lambda (b)
;;;; The function `ir-complete' will coalesce basic blocks in a
;;;; component to generate proper maximal basic blocks.
-;;; The current component. We accumulate the results of the IR
-;;; conversion in this component.
-(defvar *component*)
-
;;; A alist of IR translator functions.
(defvar *ir-translator* nil)
;;; unique successor, and so it should be when the translator returns.
(defmacro define-ir-translator (name lambda-list &body body)
(check-type name symbol)
- (let ((fname (intern (format nil "IR-CONVERT-~a" (string name))))
- (result (gensym))
- (form (gensym)))
- `(progn
- (defun ,fname (,form ,result)
- (flet ((result-lvar () ,result))
- (declare (ignorable (function result-lvar)))
- (destructuring-bind ,lambda-list ,form
- ,@body)))
- (push (cons ',name #',fname) *ir-translator*))))
+ (let ((fname (intern (format nil "IR-CONVERT-~a" (string name)))))
+ (with-gensyms (result form)
+ `(progn
+ (defun ,fname (,form ,result)
+ (flet ((result-lvar () ,result))
+ (declare (ignorable (function result-lvar)))
+ (destructuring-bind ,lambda-list ,form
+ ,@body)))
+ (push (cons ',name #',fname) *ir-translator*)))))
;;; Return the unique successor of the current block. If it is not
;;; unique signal an error.
;;; Set the next block of the current one.
(defun (setf next-block) (new-value)
- (let ((block (current-block))
- (next (next-block)))
- (setf (block-pred next) (remove block (block-pred next)))
+ (let ((block (current-block)))
+ (dolist (succ (block-succ block))
+ (setf (block-pred succ) (remove block (block-pred succ))))
(setf (block-succ block) (list new-value))
(push block (block-pred new-value))
new-value))
-
(defun ir-convert-constant (form result)
(let* ((leaf (make-constant :value form)))
(insert-node (make-ref :leaf leaf :lvar result))))
(define-ir-translator if (test then &optional else)
;; It is the schema of how the basic blocks will look like
;;
- ;; / ..then.. \
- ;; <aaaa|> -- => <aaaaXX> --< >-- <|> --<zzzz>
- ;; \ ..else.. /
+ ;; / ..then.. \
+ ;; <aaaaXX> --< >-- <|> -- <zzzz>
+ ;; \ ..else.. /
;;
;; Note that is important to leave the cursor in an empty basic
;; block, as zzz could be the exit basic block of the component,
(set-cursor :block join-block)))
(define-ir-translator block (name &body body)
- (push-binding name 'block (cons (next-block) (result-lvar)))
- (ir-convert `(progn ,@body) (result-lvar)))
+ (let ((new (split-block)))
+ (push-binding name 'block (cons (next-block) (result-lvar)))
+ (ir-convert `(progn ,@body) (result-lvar))
+ (set-cursor :block new)))
(define-ir-translator return-from (name &optional value)
(let ((binding
(destructuring-bind (jump-block . lvar)
(binding-value binding)
(ir-convert value lvar)
- (let ((new (split-block)))
- (setf (next-block) jump-block)
- (set-cursor :block new)))))
+ (setf (next-block) jump-block)
+ ;; This block is really unreachable, even if the following code
+ ;; is labelled in a tagbody, as tagbody will create a new block
+ ;; for each label. However, we have to leave the cursor
+ ;; somewhere to convert new input.
+ (let ((dummy (make-empty-block)))
+ (set-cursor :block dummy)))))
+
+(define-ir-translator tagbody (&rest statements)
+ (flet ((go-tag-p (x)
+ (or (integerp x) (symbolp x))))
+ (let* ((tags (remove-if-not #'go-tag-p statements))
+ (tag-blocks nil))
+ ;; Create a chain of basic blocks for the tags, recording each
+ ;; block in a alist in TAG-BLOCKS.
+ (let ((*cursor* *cursor*))
+ (dolist (tag tags)
+ (setq *cursor* (cursor :block (split-block)))
+ (push-binding tag 'tag (current-block))
+ (if (assoc tag tag-blocks)
+ (error "Duplicated tag `~S' in tagbody." tag)
+ (push (cons tag (current-block)) tag-blocks))))
+ ;; Convert the statements into the correct block.
+ (dolist (stmt statements)
+ (if (go-tag-p stmt)
+ (set-cursor :block (cdr (assoc stmt tag-blocks)))
+ (ir-convert stmt))))))
+
+(define-ir-translator go (label)
+ (let ((tag-binding
+ (or (find-binding label 'tag)
+ (error "Unable to jump to the label `~S'" label))))
+ (setf (next-block) (binding-value tag-binding))
+ ;; Unreachable block.
+ (let ((dummy (make-empty-block)))
+ (set-cursor :block dummy))))
+
+
+(defun ir-convert-functoid (result name arguments &rest body)
+ (let ((component)
+ (return-lvar (make-lvar)))
+ (with-component-compilation
+ (ir-convert `(progn ,@body) return-lvar)
+ (setq component *component*))
+ (let ((functional
+ (make-functional
+ :name name
+ :arguments arguments
+ :entry-point component
+ :return-lvar return-lvar)))
+ (insert-node (make-ref :leaf functional :lvar result)))))
+
+(define-ir-translator function (name)
+ (if (atom name)
+ (ir-convert `(symbol-function ,name) (result-lvar))
+ (ecase (car name)
+ ((lambda named-lambda)
+ (let ((desc (cdr name)))
+ (when (eq 'lambda (car name))
+ (push nil desc))
+ (apply #'ir-convert-functoid (result-lvar) desc)))
+ (setf))))
(defun ir-convert-var (form result)
- (let* ((leaf (make-var :name form)))
- (insert-node (make-ref :leaf leaf :lvar result))))
+ (let ((binds (find-binding form 'variable)))
+ (if binds
+ (insert-node (make-ref :leaf (binding-value binds) :lvar result))
+ (ir-convert `(symbol-value ',form) result))))
(defun ir-convert-call (form result)
(destructuring-bind (function &rest args) form
(let ((func-lvar (make-lvar))
(args-lvars nil))
- (when (symbolp function)
- (ir-convert `(%symbol-function ,function) func-lvar))
+ ;; Argument list
(dolist (arg args)
(let ((arg-lvar (make-lvar)))
(push arg-lvar args-lvars)
(ir-convert arg arg-lvar)))
(setq args-lvars (reverse args-lvars))
- (let ((call (make-call :function func-lvar :arguments args-lvars :lvar result)))
- (insert-node call)))))
-
-;;; Convert the Lisp expression FORM into IR before the NEXT node, it
-;;; may create new basic blocks into the current component. RESULT is
-;;; the lvar representing the result of the computation or null if the
-;;; value should be discarded. The IR is inserted at *CURSOR*.
+ ;; Funcall
+ (if (find-primitive function)
+ (insert-node (make-primitive-call
+ :function (find-primitive function)
+ :arguments args-lvars
+ :lvar result))
+ (progn
+ (ir-convert `(symbol-function ,function) func-lvar)
+ (insert-node (make-call :function func-lvar
+ :arguments args-lvars
+ :lvar result)))))))
+
+;;; Convert the Lisp expression FORM, it may create new basic
+;;; blocks. RESULT is the lvar representing the result of the
+;;; computation or null if the value should be discarded. The IR is
+;;; inserted at *CURSOR*.
(defun ir-convert (form &optional result (*cursor* *cursor*))
;; Rebinding the lexical environment here we make sure that the
;; lexical information introduced by FORM is just available for
(values)))
-;;; Prepare a new component with a current empty block ready to start
-;;; IR conversion bound in the current cursor. BODY is evaluated and
-;;; the value of the last form is returned.
-(defmacro with-component-compilation (&body body)
- (let ((block (gensym)))
- `(multiple-value-bind (*component* ,block)
- (make-empty-component)
- (let ((*cursor* (cursor :block ,block))
- (*lexenv* nil))
- ,@body))))
+;;; Change all the predecessors of BLOCK to precede NEW-BLOCK instead.
+(defun replace-block (block new-block)
+ (let ((predecessors (block-pred block)))
+ (setf (block-pred new-block) (union (block-pred new-block) predecessors))
+ (dolist (pred predecessors)
+ (setf (block-succ pred) (substitute new-block block (block-succ pred)))
+ (unless (component-entry-p pred)
+ (let ((last-node (node-prev (block-exit pred))))
+ (when (conditional-p last-node)
+ (macrolet ((replacef (place)
+ `(setf ,place (if (eq block ,place) new-block ,place))))
+ (replacef (conditional-consequent last-node))
+ (replacef (conditional-alternative last-node)))))))))
(defun delete-empty-block (block)
(when (or (component-entry-p block) (component-exit-p block))
(error "Cannot delete entry or exit basic blocks."))
(unless (empty-block-p block)
(error "Block `~S' is not empty!" (block-id block)))
- (let ((succ (unlist (block-succ block))))
- (setf (block-pred succ) (remove block (block-pred succ)))
- (dolist (pred (block-pred block))
- (setf (block-succ pred) (substitute succ block (block-succ pred)))
- (pushnew pred (block-pred succ)))))
+ (replace-block block (unlist (block-succ block))))
;;; Try to coalesce BLOCK with the successor if it is unique and block
;;; is its unique predecessor.
(defun maybe-coalesce-block (block)
(when (singlep (block-succ block))
(let ((succ (first (block-succ block))))
- (when (and (singlep (block-pred succ))
- (not (component-exit-p succ)))
+ (when (and (not (component-exit-p succ)) (singlep (block-pred succ)))
(link-nodes (node-prev (block-exit block))
(node-next (block-entry succ)))
(setf (block-succ block) (block-succ succ))
t))))
(defun ir-complete (&optional (component *component*))
- (do-blocks (block component)
- (if (empty-block-p block)
- (delete-empty-block block)
- (maybe-coalesce-block block))))
+ (do-blocks-backward (block component)
+ (maybe-coalesce-block block)
+ (when (empty-block-p block)
+ (delete-empty-block block))))
;;; IR Debugging
((var-p leaf)
(format t "~a" (var-name leaf)))
((constant-p leaf)
- (format t "'~a" (constant-value leaf)))
+ (format t "'~s" (constant-value leaf)))
((functional-p leaf)
- (format t "#<function ~a at ~a>"
- (functional-name leaf)
- (functional-entry-point leaf))))))
+ (format t "#<function ~a>" (functional-name leaf))))))
((assignment-p node)
(format t "set ~a ~a"
(var-name (assignment-variable node))
(lvar-id (assignment-value node))))
+ ((primitive-call-p node)
+ (format t "primitive ~a" (primitive-name (primitive-call-function node)))
+ (dolist (arg (primitive-call-arguments node))
+ (format t " ~a" (lvar-id arg))))
((call-p node)
(format t "call ~a" (lvar-id (call-function node)))
(dolist (arg (call-arguments node))
;;; Translate FORM into IR and print a textual repreresentation of the
;;; component.
-(defun describe-ir (form)
+(defun convert-toplevel-and-print (form &optional (complete t))
(with-component-compilation
(ir-convert form (make-lvar :id "$out"))
- (ir-complete)
- (check-ir-consistency *component*)
+ (when complete (ir-complete))
+ (check-ir-consistency)
(print-component *component*)))
+(defmacro /ir (form)
+ `(convert-toplevel-and-print ',form))
+
+
+;;;; Primitives
+;;;;
+;;;; Primitive functions are a set of functions provided by the
+;;;; compiler. They cannot usually be written in terms of other
+;;;; functions. When the compiler tries to compile a function call, it
+;;;; looks for a primitive function firstly, and if it is found and
+;;;; the declarations allow it, a primitive call is inserted in the
+;;;; IR. The back-end of the compiler knows how to compile primitive
+;;;; calls.
+;;;;
+
+(defvar *primitive-function-table* nil)
+
+(defstruct primitive
+ name)
+
+(defmacro define-primitive (name args &body body)
+ (declare (ignore args body))
+ `(push (make-primitive :name ',name)
+ *primitive-function-table*))
+
+(defun find-primitive (name)
+ (find name *primitive-function-table* :key #'primitive-name))
+
+(define-primitive symbol-function (symbol))
+(define-primitive symbol-value (symbol))
+
;;; compiler.lisp ends here
projects / jscl.git / blobdiff