Merge pull request #6 from s-expressionists/fasl

Simplifies some FASL instructions to compact things a bit.

FASL.md

@@ -24,6 +24,10 @@ After the last instruction is executed, the FASL has been fully loaded. Any rema
 
 * `listify-rest-args` pushes to the stack again. `bind-optional-args` and `parse-key-args` do as well. (This makes compilation a little easier and cleaner.)
 * `parse-key-args` puts aokp in the low bit instead of the high bit, to simplify the long instruction.
+* `setf-row-major-aref` is replaced with `initialize-array`, which initializes the entire array at once - saves some space and some repeated accesses to grab array
+* `rplaca` and `rplacd` instructions are unified into `initialize-cons`: simpler and a byte shorter.
+* new FASL instructions: `base-string` and `utf8-string` for easy cases of character array.
+* new FASL instructions: `fcell-set` for simple defuns.
 
 ## 0.14
 

compile-file/cmpltv.lisp

@@ -39,13 +39,10 @@
 ;;; coalescence is still really possible.
 (defclass cons-creator (vcreator) ())
 
-(defclass rplaca-init (effect)
+(defclass initialize-cons (effect)
   ((%cons :initarg :cons :reader rplac-cons :type cons-creator)
-   (%value :initarg :value :reader rplac-value :type creator)))
-
-(defclass rplacd-init (effect)
-  ((%cons :initarg :cons :reader rplac-cons :type cons-creator)
-   (%value :initarg :value :reader rplac-value :type creator)))
+   (%car :initarg :car :reader rplac-car :type creator)
+   (%cdr :initarg :cdr :reader rplac-cdr :type creator)))
 
 ;;; dimensions and element-type are encoded with the array since
 ;;; they shouldn't really need to be coalesced.
@@ -54,23 +51,36 @@
    (%packing-info :initarg :packing-info :reader packing-info)
    (%element-type-info :initarg :element-type-info :reader element-type-info)))
 
-;; row-major.
-(defclass setf-aref (effect)
-  ((%array :initarg :array :reader setf-aref-array :type array-creator)
-   (%index :initarg :index :reader setf-aref-index :type (integer 0))
-   (%value :initarg :value :reader setf-aref-value :type creator)))
+;;; Initialize contents of a general array. This is a separate instruction
+;;; because such arrays may contain themselves.
+(defclass initialize-array (effect)
+  ((%array :initarg :array :reader initialized-array :type array-creator)
+   ;; A list of creators as long as the array's total size.
+   (%values :initarg :values :reader array-values :type list)))
+
+;;; Special cases of array-creator, since they're very very common
+;;; for e.g. symbol names.
+(defclass base-string-creator (vcreator) ())
+(defclass utf8-string-creator (vcreator)
+  ((%nbytes :initarg :nbytes :reader nbytes :type (unsigned-byte 16))))
 
 (defclass hash-table-creator (vcreator)
   (;; used in disltv
    (%test :initarg :test :reader hash-table-creator-test :type symbol)
    (%count :initarg :count :reader hash-table-creator-count
            :type (integer 0))))
 
-(defclass setf-gethash (effect)
-  ((%hash-table :initarg :hash-table :reader setf-gethash-hash-table
-                :type hash-table-creator)
-   (%key :initarg :key :reader setf-gethash-key :type creator)
-   (%value :initarg :value :reader setf-gethash-value :type creator)))
+;;; Initialize contents of a hash table. Separate instruction because
+;;; circular references are possible.
+(defclass initialize-hash-table (effect)
+  ((%table :initarg :table :reader initialized-table :type hash-table-creator)
+   ;; We have to store the count ourselves, since the hash table size may
+   ;; not be identical to the number of elements.
+   (%count :initarg :count :reader initialized-table-count
+           :type (unsigned-byte 32))
+   ;; An alist of all the keys and values in the table.
+   ;; The keys and values are creators.
+   (%alist :initarg :alist :reader alist :type list)))
 
 (defclass symbol-creator (vcreator)
   (;; Is there actually a point to trying to coalesce symbol names?
@@ -125,6 +135,11 @@
 (defclass fcell-lookup (creator)
   ((%name :initarg :name :reader name :type creator)))
 
+;;; Set what's in an fcell.
+(defclass fcell-set (effect)
+  ((%fcell :initarg :fcell :reader fcell :type creator)
+   (%value :initarg :value :reader value :type creator)))
+
 ;;; Look up the "cell" for special variable binding. This is used by the
 ;;; SPECIAL-BIND, SYMBOL-VALUE, and SYMBOL-VALUE-SET VM instructions
 ;;; as a lookup key for the binding, as well as for establishing new
@@ -217,6 +232,12 @@
 
 ;;;
 
+;;; If this is true, symbols are avoided when possible, and attributes
+;;; are not dumped. Experimental for use with chalybeate.
+(defvar *primitive* nil)
+
+;;;
+
 ;;; Return true iff the value is similar to the existing creator.
 (defgeneric similarp (creator value)
   (:method (creator value) (declare (ignore creator value)) nil))
@@ -329,10 +350,10 @@
 (defmethod add-constant ((value cons))
   (let ((cons (add-creator
                value (make-instance 'cons-creator :prototype value))))
-    (add-instruction (make-instance 'rplaca-init
-                       :cons cons :value (ensure-constant (car value))))
-    (add-instruction (make-instance 'rplacd-init
-                       :cons cons :value (ensure-constant (cdr value))))
+    (add-instruction (make-instance 'initialize-cons
+                       :cons cons
+                       :car (ensure-constant (car value))
+                       :cdr (ensure-constant (cdr value))))
     cons))
 
 ;;; Arrays are encoded with a code describing how elements are packed.
@@ -413,25 +434,60 @@
               (eql (second element-type-info) +other-uaet+))
       ;; (we have to separate initialization here in case the array
       ;;  contains itself. packed arrays can't contain themselves)
-      (loop for i below (array-total-size value)
-            do (add-instruction
-                (make-instance 'setf-aref
-                  :array arr :index i
-                  :value (ensure-constant (row-major-aref value i))))))
+      (add-instruction
+       (make-instance 'initialize-array
+         :array arr
+         :values (loop for i below (array-total-size value)
+                       for e = (row-major-aref value i)
+                       collect (ensure-constant e)))))
     arr))
 
+(defun utf8-length (string)
+  (loop for c across string
+        for cpoint = (char-code c)
+        sum (cond ((< cpoint #x80) 1)
+                  ((< cpoint #x800) 2)
+                  ((< cpoint #x10000) 3)
+                  ((< cpoint #x110000) 4)
+                  #-sbcl ; whines about deleted code
+                  (t (error "Codepoint #x~x for ~:c too big" cpoint c)))))
+
+(defmethod add-constant ((value string))
+  (case (array-element-type value)
+    (base-char (let ((L (length value)))
+                 (if (< L #.(ash 1 16))
+                     ;; FIXME: Check that characters are all ASCII?
+                     (add-creator
+                      value
+                      (make-instance 'base-string-creator
+                        :prototype value))
+                     (call-next-method))))
+    (character (let ((L (utf8-length value)))
+                 (if (< L #.(ash 1 16))
+                     (add-creator
+                      value
+                      (make-instance 'utf8-string-creator
+                        :nbytes L
+                        :prototype value))
+                     (call-next-method))))
+    (otherwise (call-next-method))))
+
 (defmethod add-constant ((value hash-table))
-  (let ((ht (add-creator
-             value
-             (make-instance 'hash-table-creator :prototype value
-                            :test (hash-table-test value)
-                            :count (hash-table-count value)))))
-    (maphash (lambda (k v)
-               (add-instruction
-                (make-instance 'setf-gethash
-                  :hash-table ht
-                  :key (ensure-constant k) :value (ensure-constant v))))
-             value)
+  (let* ((count (hash-table-count value))
+         (ht (add-creator
+              value
+              (make-instance 'hash-table-creator :prototype value
+                             :test (hash-table-test value)
+                             :count count)))
+         (alist nil))
+    (unless (zerop count) ; empty hash table, so nothing to initialize
+      (maphash (lambda (k v)
+                 (let ((ck (ensure-constant k)) (cv (ensure-constant v)))
+                   (push (cons ck cv) alist)))
+               value)
+      (add-instruction
+       (make-instance 'initialize-hash-table
+         :table ht :count count :alist alist)))
     ht))
 
 (defmethod add-constant ((value symbol))
@@ -684,27 +740,33 @@
     ;; Something to consider: Any of these, but most likely the lambda list,
     ;; could contain unexternalizable data. In this case we should find a way
     ;; to gracefully and silently not dump the attribute.
-    (when (cmp:cfunction-name value)
-      (add-instruction (make-instance 'name-attr
-                         :object inst
-                         :objname (ensure-constant
-                                   (cmp:cfunction-name value)))))
-    (when (cmp:cfunction-doc value)
-      (add-instruction (make-instance 'docstring-attr
-                         :object inst
-                         :docstring (ensure-constant
-                                     (cmp:cfunction-doc value)))))
-    (when (cmp:cfunction-lambda-list-p value)
-      (add-instruction (make-instance 'lambda-list-attr
-                         :function inst
-                         :lambda-list (ensure-constant
-                                       (cmp:cfunction-lambda-list value)))))
+    (unless *primitive*
+      (when (cmp:cfunction-name value)
+        (add-instruction (make-instance 'name-attr
+                           :object inst
+                           :objname (ensure-constant
+                                     (cmp:cfunction-name value)))))
+      (when (cmp:cfunction-doc value)
+        (add-instruction (make-instance 'docstring-attr
+                           :object inst
+                           :docstring (ensure-constant
+                                       (cmp:cfunction-doc value)))))
+      (when (cmp:cfunction-lambda-list-p value)
+        (add-instruction (make-instance 'lambda-list-attr
+                           :function inst
+                           :lambda-list (ensure-constant
+                                         (cmp:cfunction-lambda-list value))))))
     inst))
 
 (defclass bytemodule-creator (vcreator)
   ((%cmodule :initarg :cmodule :reader bytemodule-cmodule)
    (%lispcode :initform nil :initarg :lispcode :reader bytemodule-lispcode)))
 
+(defmethod print-object ((object bytemodule-creator) stream)
+  (print-unreadable-object (object stream :type t)
+    (format stream "~d" (index object)))
+  object)
+
 (defclass setf-literals (effect)
   ((%module :initarg :module :reader setf-literals-module :type creator)
    ;; The literals are not practically coalesceable and are always a T vector,
@@ -733,9 +795,9 @@
 
 (defun ensure-fcell (name)
   (or (find-fcell name)
-      (add-fcell name
-                 (make-instance 'fcell-lookup
-                   :name (ensure-constant name)))))
+    (add-fcell name
+               (make-instance 'fcell-lookup
+                 :name (ensure-constant name)))))
 
 (defmethod ensure-module-literal ((info cmp:fdefinition-info))
   (ensure-fcell (cmp:fdefinition-info-name info)))

compile-file/encode.lisp

@@ -29,12 +29,13 @@
     (ratio 67)
     (complex 68)
     (cons 69 sind)
-    (rplaca 70 ind1 ind2) ; (setf (car [ind1]) [ind2])
-    (rplacd 71 ind1 ind2)
+    (initialize-cons 70 consind carind cdrind)
+    (base-string 72 size . data)
+    (utf8-string 73 nbytes . data)
     (make-array 74 sind rank . dims)
-    (setf-row-major-aref 75 arrayind rmindex valueind)
+    (initialize-array 75 arrayind . valueinds)
     (make-hash-table 76 sind test count)
-    ((setf gethash) 77 htind keyind valueind)
+    (initialize-hash-table 77 htind keyind valueind)
     (make-sb64 78 sind sb64)
     (find-package 79 sind nameind)
     (make-bignum 80 sind size . words)
@@ -55,6 +56,9 @@
     (find-class 98 sind cnind)
     (init-object-array 99 ub64)
     (environment 100)
+    (fcell-set 101 nameind)
+    (vcell-set 102 nameind)
+    (ccell-set 103 nameind)
     (attribute 255 name nbytes . data)))
 
 ;; how many bytes are needed to represent an index?
@@ -112,15 +116,11 @@
 (defmethod encode ((inst cons-creator) stream)
   (write-mnemonic 'cons stream))
 
-(defmethod encode ((inst rplaca-init) stream)
-  (write-mnemonic 'rplaca stream)
+(defmethod encode ((inst initialize-cons) stream)
+  (write-mnemonic 'initialize-cons stream)
   (write-index (rplac-cons inst) stream)
-  (write-index (rplac-value inst) stream))
-
-(defmethod encode ((inst rplacd-init) stream)
-  (write-mnemonic 'rplacd stream)
-  (write-index (rplac-cons inst) stream)
-  (write-index (rplac-value inst) stream))
+  (write-index (rplac-car inst) stream)
+  (write-index (rplac-cdr inst) stream))
 
 (defun write-dimensions (dimensions stream)
   (let ((rank (length dimensions)))
@@ -182,6 +182,7 @@
 		 ;; The following is deleted as unreachable on e.g. SBCL because
 		 ;; it knows that char-code doesn't go this high.
 		 ;; Don't worry about it.
+                 #-sbcl
 		 (t ; not allowed by RFC3629
 		  (error "Code point #x~x for character ~:c is out of range for UTF-8"
 			 cpoint char)))))
@@ -247,14 +248,30 @@
             ((equal packing-type '(signed-byte 64))
              (dump (write-b64 elem stream)))
             ;; TODO: Signed bytes
-            ((equal packing-type 't)) ; handled by setf-aref instructions
+            ((equal packing-type 't)) ; handled by initialize-array instruction
             (t (error "BUG: Unknown packing-type ~s" packing-type))))))
 
-(defmethod encode ((inst setf-aref) stream)
-  (write-mnemonic 'setf-row-major-aref stream)
-  (write-index (setf-aref-array inst) stream)
-  (write-b16 (setf-aref-index inst) stream)
-  (write-index (setf-aref-value inst) stream))
+(defmethod encode ((inst initialize-array) stream)
+  (write-mnemonic 'initialize-array stream)
+  (write-index (initialized-array inst) stream)
+  ;; length is implicit from the array being initialized
+  (loop for c in (array-values inst)
+        do (write-index c stream)))
+
+(defmethod encode ((inst base-string-creator) stream)
+  (write-mnemonic 'base-string stream)
+  (write-b16 (length (prototype inst)) stream)
+  (loop for c across (prototype inst)
+        for code = (char-code c)
+        do (write-byte code stream)))
+
+;;; Here we encode the number of bytes rather than the number of chars.
+;;; This is smarter, since it means the I/O can be batched. We should
+;;; do it for general arrays as well.
+(defmethod encode ((inst utf8-string-creator) stream)
+  (write-mnemonic 'utf8-string stream)
+  (write-b16 (nbytes inst) stream)
+  (write-utf8 (prototype inst) stream))
 
 (defmethod encode ((inst hash-table-creator) stream)
   (let* ((ht (prototype inst))
@@ -280,11 +297,13 @@
     (write-byte testcode stream)
     (write-b16 count stream)))
 
-(defmethod encode ((inst setf-gethash) stream)
-  (write-mnemonic '(setf gethash) stream)
-  (write-index (setf-gethash-hash-table inst) stream)
-  (write-index (setf-gethash-key inst) stream)
-  (write-index (setf-gethash-value inst) stream))
+(defmethod encode ((inst initialize-hash-table) stream)
+  (write-mnemonic 'initialize-hash-table stream)
+  (write-index (initialized-table inst) stream)
+  (write-b32 (initialized-table-count inst) stream)
+  (loop for (k . v) in (alist inst)
+        do (write-index k stream)
+           (write-index v stream)))
 
 (defmethod encode ((inst singleton-creator) stream)
   (ecase (prototype inst)
@@ -360,6 +379,11 @@
   (write-mnemonic 'fcell stream)
   (write-index (name inst) stream))
 
+(defmethod encode ((inst fcell-set) stream)
+  (write-mnemonic 'fcell-set stream)
+  (write-index (fcell inst) stream)
+  (write-index (value inst) stream))
+
 (defmethod encode ((inst vcell-lookup) stream)
   (write-mnemonic 'vcell stream)
   (write-index (name inst) stream))

compile/compilation-unit.lisp

@@ -39,7 +39,7 @@ If the compiler encounters an unresolvable problem it can of course fail immedia
                         (lambda (e)
                           (signal e)
                           (setq ,warningsp t ,failurep t))))
-         (values ,@body ,warningsp ,failurep)))))
+         (values (progn ,@body) ,warningsp ,failurep)))))
 
 (defvar *in-compilation-unit* nil)
 

compile/compile.lisp

@@ -1374,7 +1374,7 @@
     (compile-form symbols env (new-context context :receiving 1))
     (compile-form values env (new-context context :receiving 1))
     (assemble context m:progv (env-index context))
-    (compile-progn body env context)
+    (compile-progn body env (new-context context :dynenv '(:special)))
     (emit-unbind context 1)))
 
 (defmethod compile-special ((op (eql 'unwind-protect))