Merge branch 'fcells'

AST-to-BIR/compile-general-purpose-asts.lisp

@@ -398,7 +398,7 @@
   (with-compiled-ast (rv (ast:value-ast ast) inserter system)
     (let* ((during (make-iblock inserter))
            (ode (dynamic-environment inserter))
-           (const (bir:constant-in-module (ast:name ast) *current-module*))
+           (const (bir:variable-cell-in-module (ast:name ast) *current-module*))
            (bind (make-instance 'bir:constant-bind
                    :inputs (list* const rv) :next (list during))))
       (setf (bir:dynamic-environment during) bind)
@@ -472,7 +472,7 @@
 (defmethod compile-ast ((ast ast:constant-symbol-value-ast)
                         inserter system)
   (declare (ignore system))
-  (let ((const (bir:constant-in-module (ast:name ast) *current-module*))
+  (let ((const (bir:variable-cell-in-module (ast:name ast) *current-module*))
         (sv-out (make-instance 'bir:output :name (ast:name ast))))
     (insert inserter 'bir:constant-symbol-value
             :inputs (list const) :outputs (list sv-out))
@@ -481,15 +481,15 @@
 (defmethod compile-ast ((ast ast:set-constant-symbol-value-ast)
                         inserter system)
   (with-compiled-ast (rv (ast:value-ast ast) inserter system)
-    (let ((const (bir:constant-in-module (ast:name ast) *current-module*)))
+    (let ((const (bir:variable-cell-in-module (ast:name ast) *current-module*)))
       (insert inserter 'bir:set-constant-symbol-value
               :inputs (list* const rv))
       :no-value)))
 
 (defmethod compile-ast ((ast ast:constant-fdefinition-ast)
                         inserter system)
   (declare (ignore system))
-  (let ((const (bir:constant-in-module (ast:name ast) *current-module*))
+  (let ((const (bir:function-cell-in-module (ast:name ast) *current-module*))
         (fdef-out (make-instance 'bir:output
                     :name (ast:name ast)
                     :attributes (ast:attributes ast))))

BIR/cleavir-bir.asd

@@ -5,7 +5,7 @@
   :author ("Bike <aeshtaer@gmail.com>" "Charles Zhang")
   :maintainer "Bike <aeshtaer@gmail.com>"
   :homepage "https://s-expressionists.github.io/Cleavir/cleavir-bir/"
-  :version "1.0.0"
+  :version "1.1.0"
   :license "BSD"
   :bug-tracker "https://github.com/s-expressionists/Cleavir/issues"
   :source-control (:git "https://github.com/s-expressionists/Cleavir.git")

BIR/condition-reporters-english.lisp

@@ -11,15 +11,16 @@
 
 (defmethod acclimation:report-condition
     ((condition type-conflict) stream (language acclimation:english))
-  (format stream "The derived type of ~:[<nameless datum>~;~:*~a~]
+  (let ((origin (conditions:origin condition)))
+    (format stream "The derived type of ~:[<nameless datum>~;~:*~a~]
 is ~s~%but is asserted as ~s
 by ~a~:[~; in ~s~]."
-          (name (datum condition))
-          (derived-type condition)
-          (asserted-type condition)
-          (asserted-by condition)
-          (conditions:origin condition)
-          (cst:raw (conditions:origin condition))))
+            (name (datum condition))
+            (derived-type condition)
+            (asserted-type condition)
+            (asserted-by condition)
+            origin
+            (when origin (cst:raw origin)))))
 
 (defun group-problems (problems)
   ;; Group by subject. Also, put function problems before iblock problems, and

BIR/disassemble.lisp

@@ -151,7 +151,7 @@
       (list* (list (disassemble-datum function) (iblock-id (start function))
                    (disassemble-lambda-list (lambda-list function))
                    (set:mapset 'list #'disassemble-datum
-                                       (environment function)))
+                               (environment function)))
              iblocks))))
 
 (defmethod cleavir-bir-disassembler:disassemble ((module module))

BIR/graph-modifications.lisp

@@ -18,6 +18,10 @@
   (set:nremovef (readers datum) use))
 (defmethod remove-use ((datum load-time-value) use)
   (set:nremovef (readers datum) use))
+(Defmethod remove-use ((datum function-cell) use)
+  (set:nremovef (readers datum) use))
+(Defmethod remove-use ((datum variable-cell) use)
+  (set:nremovef (readers datum) use))
 (defmethod remove-use ((datum function) (use abstract-local-call))
   (set:nremovef (local-calls datum) use))
 (defmethod remove-use ((datum function) (use thei))
@@ -37,6 +41,10 @@
   (set:nadjoinf (readers datum) use))
 (defmethod add-use ((datum load-time-value) use)
   (set:nadjoinf (readers datum) use))
+(defmethod add-use ((datum function-cell) use)
+  (set:nadjoinf (readers datum) use))
+(defmethod add-use ((datum variable-cell) use)
+  (set:nadjoinf (readers datum) use))
 (defmethod add-use ((datum function) (use abstract-local-call))
   (set:nadjoinf (local-calls datum) use))
 (defmethod add-use ((datum function) (use thei))
@@ -203,33 +211,33 @@
     (when (set:empty-set-p (readers constant))
       (let ((module (module (function inst))))
         (set:nremovef (constants module) constant)
-        (remhash (constant-value constant) (constant-table module))))))
+        (remhash (function-name constant) (function-cell-table module))))))
 (defmethod clean-up-instruction progn ((inst constant-symbol-value))
   (let ((constant (first (inputs inst))))
     (set:nremovef (readers constant) inst)
     (when (set:empty-set-p (readers constant))
       (let ((module (module (function inst))))
         (set:nremovef (constants module) constant)
-        (remhash (constant-value constant) (constant-table module))))))
+        (remhash (variable-name constant) (variable-cell-table module))))))
 (defmethod clean-up-instruction progn ((inst set-constant-symbol-value))
   (let ((constant (first (inputs inst))))
     (set:nremovef (readers constant) inst)
     (when (set:empty-set-p (readers constant))
       (let ((module (module (function inst))))
         (set:nremovef (constants module) constant)
-        (remhash (constant-value constant) (constant-table module))))))
+        (remhash (variable-name constant) (variable-cell-table module))))))
 (defmethod clean-up-instruction progn ((inst constant-bind))
   (let ((constant (first (inputs inst))))
     (set:nremovef (readers constant) inst)
     (when (set:empty-set-p (readers constant))
       (let ((module (module (function inst))))
         (set:nremovef (constants module) constant)
-        (remhash (constant-value constant) (constant-table module))))))
+        (remhash (variable-name constant) (variable-cell-table module))))))
 (defmethod clean-up-instruction progn ((inst load-time-value-reference))
   (let ((ltv (first (inputs inst))))
     (set:nremovef (readers ltv) inst)
     (when (set:empty-set-p (readers ltv))
-      (set:nremovef (load-time-values (module (function inst))) ltv))))
+      (set:nremovef (constants (module (function inst))) ltv))))
 (defmethod clean-up-instruction progn ((inst enclose))
   (let ((code (code inst)))
     (setf (enclose code) nil)
@@ -399,7 +407,8 @@ See MAYBE-DELETE-IBLOCK"
     ;; iblocks that have already been deleted, somehow). FIXME.
     #+(or)
     (assert (eq (%next prev) iblock))
-    (setf (%next prev) next)
+    (when prev
+      (setf (%next prev) next))
     (cond (next
            #+(or)
            (assert (eq (%prev next) iblock))

BIR/instructions.lisp

@@ -44,7 +44,9 @@ See EXTENT"))
 ;;; Retrieve the function bound to a constant.
 (defclass constant-fdefinition (one-input one-output instruction)
   ()
-  (:documentation "Instruction representing the lookup of a global function with a known name. The single input is a CONSTANT whose value must be a function name, and the single output is the function looked up."))
+  (:documentation "Instruction representing the lookup of a global function with a known name. The single input is a FUNCTION-CELL, and the single output is the function looked up.
+
+See FUNCTION-CELL"))
 
 (defclass load-time-value-reference (one-input one-output instruction)
   ()
@@ -53,11 +55,11 @@ See EXTENT"))
 ;;; Retrieve the value bound to a known symbol.
 (defclass constant-symbol-value (one-input one-output instruction)
   ()
-  (:documentation "Instruction representing the lookup of the value of a symbol with a known name. The single input is a CONSTANT whose value must be a symbol, and the single output is its value."))
+  (:documentation "Instruction representing the lookup of the value of a symbol with a known name. The single input is a VARIABLE-CELL, and the single output is its value."))
 
 (defclass set-constant-symbol-value (no-output instruction)
   ()
-  (:documentation "Instruction representing the modification of the value of a symbol with a known name. The first input is a CONSTANT whose value must be a symbol, and the second is the value the symbol's value will be changed to. No output."))
+  (:documentation "Instruction representing the modification of the value of a symbol with a known name. The first input is a VARIABLE-CELL, and the second is the value the symbol's value will be changed to. No output."))
 
 (defclass primop (instruction)
   ((%info :initarg :info :reader info
@@ -180,7 +182,7 @@ See LETI"))
 ;;; Dynamic binding. Inputs are the symbol and the new value.
 (defclass constant-bind (dynamic-environment no-output terminator1)
   ()
-  (:documentation "Terminator and dynamic environment representing the binding of a dynamic variable. Within this dynamic environment, the symbol has this value (unless there is a more recent binding, of course). The first input is the symbol being bound, and the second input its new value. No outputs."))
+  (:documentation "Terminator and dynamic environment representing the binding of a dynamic variable. Within this dynamic environment, the symbol has this value (unless there is a more recent binding, of course). The first input is the VARIABLE-CELL being bound, and the second input its new value. No outputs."))
 
 (defclass unwind (terminator0)
   ((%come-from :initarg :come-from :reader come-from

BIR/packages.lisp

@@ -10,7 +10,8 @@
                     (#:conditions #:cleavir-conditions)
                     (#:ctype #:cleavir-ctype))
   (:export #:module #:functions #:constants #:constant-in-module
-           #:load-time-values #:load-time-value-in-module)
+           #:load-time-value-in-module #:function-cell-in-module
+           #:variable-cell-in-module)
   (:export #:function #:iblocks #:start #:end #:inputs #:variables #:come-froms
            #:environment #:other-uses
            #:local-calls #:lambda-list #:name #:docstring #:original-lambda-list)
@@ -25,7 +26,9 @@
            #:record-variable-ref #:record-variable-set
            #:immutablep #:closed-over-p)
   (:export #:constant #:load-time-value
-           #:constant-value #:form #:read-only-p)
+           #:constant-value #:form #:read-only-p
+           #:function-cell #:function-name
+           #:variable-cell #:variable-name)
   (:export #:instruction #:inputs #:outputs #:input
            #:no-input #:one-input #:no-output #:one-output
            #:terminator #:terminator0 #:terminator1

BIR/structure.lisp

@@ -108,10 +108,36 @@ For linearity purposes, constants cannot be used directly as inputs to most inst
 
 See CONSTANT-REFERENCE"))
 
+(defclass function-cell (value)
+  (;; %FUNCTION-NAME is a separate slot from %NAME, even though they are
+   ;; usually identical, to emphasize that they don't have to be, and that
+   ;; the %NAME is only for debugging.
+   (%function-name :initarg :function-name :reader function-name)
+   (%readers :initform (set:empty-set) :accessor readers))
+  (:documentation "A datum representing a function cell.
+A function cell is an implementation defined object that is the identity of a function definition, so for example (setf fdefinition) on the name does alter the cell to refer to the new function. This separates the definition from the name, which is useful for e.g. allowing the same name to refer to different functions in different global environments.
+If an implementation does not have special function cells, it could just use the function name as a cell.
+Cleavir marks cells as different from other constants so that they may be resolved specially by an implementation's linking loader.
+
+See CONSTANT-FDEFINITION"))
+
+(defclass variable-cell (value)
+  ((%variable-name :initarg :variable-name :reader variable-name)
+   (%readers :initform (set:empty-set) :accessor readers))
+  (:documentation "A datum representing a variable cell.
+A variable cell is an implementation defined object that is the identity of a dynamic variable definition, so for example makunbound followed by (setf symbol-value) on the name does alter the cell to refer to the new value. This separates the definition from the name, which is useful for e.g. allowing the same name to refer to different functions in different global environments.
+If an implementation does not have special variable cells, it could just use the variable name as a cell.
+Cleavir marks cells as different from other constants so that they may be resolved specially by an implementation's linking loader.
+
+See CONSTANT-SYMBOL-VALUE
+See SET-CONSTANT-SYMBOL-VALUE
+See CONSTANT-BIND"))
+
 (defmethod print-object ((object constant) stream)
   (print-unreadable-object (object stream :type t :identity t)
     (write (constant-value object) :stream stream)))
 
+;;; FIXME: move load time value handling more to client
 (defclass load-time-value (value)
   ((%form :initarg :form :reader form)
    (%read-only-p :initarg :read-only-p :reader read-only-p)
@@ -466,21 +492,21 @@ In other words this is a conventional \"basic block\", except that Cleavir will
    (%constants :accessor constants
                :initform (set:empty-set)
                :type set:set)
-   ;; FIXME: move load time value handling more to client
-   (%load-time-values :accessor load-time-values
-                      :initform (set:empty-set)
-                      :type set:set)
    ;; This table ensures that only one constant object per similar
    ;; object is created.
-   (%constant-table :accessor constant-table))
+   (%constant-table :accessor constant-table)
+   (%function-cell-table :accessor function-cell-table)
+   (%variable-cell-table :accessor variable-cell-table))
   (:documentation "A set of functions which are compiled together (as opposed to \"separate compilation\") and which can participate in interprocedural optimizations such as inlining.
  For example, lexically nested functions are always compiled together."))
 
 (defmethod initialize-instance :after ((module module) &key)
   ;; FIXME: In code with file compilation semantics, we are allowed to
   ;; coalesce EQUAL constants. Figure out how to allow clients to plug
   ;; into the table initialization logic here.
-  (setf (constant-table module) (make-hash-table :test #'eq)))
+  (setf (constant-table module) (make-hash-table :test #'eq)
+        (function-cell-table module) (make-hash-table :test #'equal)
+        (variable-cell-table module) (make-hash-table :test #'eq)))
 
 (defun constant-in-module (constant-value module)
   "Find the CONSTANT for the given value in MODULE, allocating a new one in the module if necessary.
@@ -500,9 +526,33 @@ See CONSTANT"
   ;; We can look into coalescence later if we need to.
   (let ((ltv (make-instance 'load-time-value
                :form form :read-only-p read-only-p)))
-    (set:nadjoinf (load-time-values module) ltv)
+    (set:nadjoinf (constants module) ltv)
     ltv))
 
+(defun function-cell-in-module (function-name module)
+  "Find the FUNCTION-CELL for the given name in MODULE, or allocate a new one in the module if necessary.
+
+See FUNCTION-CELL"
+  (let ((table (function-cell-table module)))
+    (or (gethash function-name table)
+        (let ((fcell (make-instance 'function-cell
+                       :name function-name :function-name function-name)))
+          (set:nadjoinf (constants module) fcell)
+          (setf (gethash function-name table) fcell)
+          fcell))))
+
+(defun variable-cell-in-module (variable-name module)
+  "Find the VARIABLE-CELL for the given name in MODULE, or allocate a new one in the module if necessary.
+
+See VARIABLE-CELL"
+  (let ((table (variable-cell-table module)))
+    (or (gethash variable-name table)
+        (let ((vcell (make-instance 'variable-cell
+                       :name variable-name :variable-name variable-name)))
+          (set:nadjoinf (constants module) vcell)
+          (setf (gethash variable-name table) vcell)
+          vcell))))
+
 (defmethod entrances ((function function))
   "The set of blocks in a function that have nonlocal entrances."
   (let ((entrances (set:empty-set)))