X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=experimental%2Fcompiler.lisp;h=6b57adc49ef389fcbdd0af039d866644ff354271;hb=c004f075967a919a6c99da2d029d55885c147f9e;hp=388157f70911fd317bfbcfe6b07e2cca656ba054;hpb=fc74a350c8382575b8e924e60cdaf5033e70d49e;p=jscl.git

diff --git a/experimental/compiler.lisp b/experimental/compiler.lisp
index 388157f..6b57adc 100644
--- a/experimental/compiler.lisp
+++ b/experimental/compiler.lisp
@@ -25,7 +25,7 @@
 ;;;; 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)
@@ -35,6 +35,9 @@
   (assert (singlep x))
   (first x))
 
+(defun generic-printer (x stream)
+  (print-unreadable-object (x stream :type t :identity t)))
+
 
 ;;;; Intermediate representation structures
 ;;;;
@@ -65,7 +68,7 @@
 
 ;;; 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
@@ -82,7 +85,7 @@
 
 ;;; 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
@@ -104,11 +107,19 @@
   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.
@@ -118,6 +129,86 @@
   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
@@ -128,7 +219,9 @@
   ;; 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)))
@@ -296,69 +389,6 @@
     (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 ((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 (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
 ;;;;
@@ -369,7 +399,7 @@
 (defstruct binding
   name namespace type value)
 
-(defvar *lexenv*)
+(defvar *lexenv* nil)
 
 (defun find-binding (name namespace)
   (find-if (lambda (b)
@@ -396,10 +426,6 @@
 ;;;; 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)
 
@@ -412,16 +438,15 @@
 ;;; 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.
@@ -488,8 +513,10 @@
     (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
@@ -515,7 +542,7 @@
       ;; block in a alist in TAG-BLOCKS.
       (let ((*cursor* *cursor*))
         (dolist (tag tags)
-          (set-cursor :block (split-block))
+          (setq *cursor* (cursor :block (split-block)))
           (push-binding tag 'tag (current-block))
           (if (assoc tag tag-blocks)
               (error "Duplicated tag `~S' in tagbody." tag)
@@ -536,28 +563,63 @@
       (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
@@ -582,17 +644,6 @@
     (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)))
@@ -648,13 +699,15 @@
          ((constant-p 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))
@@ -691,14 +744,43 @@
 
 ;;; Translate FORM into IR and print a textual repreresentation of the
 ;;; component.
-(defun describe-ir (form &optional (complete t))
+(defun convert-toplevel-and-print (form &optional (complete t))
   (with-component-compilation
     (ir-convert form (make-lvar :id "$out"))
     (when complete (ir-complete))
-    (check-ir-consistency *component*)
+    (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