The file compiler.

Currently incomplete, does not deal with defstruct.

.gitignore

@@ -1,2 +1,3 @@
 *~
 *.fasl
+*.llf

bootstrap/file-compiler.lisp

@@ -105,3 +105,288 @@ NOTE: Non-compound forms (after macro-expansion) are ignored."
 	  (t (when (eql mode :compile-time-too)
 	       (funcall eval-fn expansion env))
 	     (funcall load-fn expansion env))))))
+
+(defvar *compile-verbose* t)
+(defvar *compile-print* t)
+
+(defun compile-file-default-output (input-file)
+  (make-pathname :type "llf" :defaults input-file))
+
+(defconstant +llf-end-of-load+ #xFF)
+(defconstant +llf-backlink+ #x01)
+(defconstant +llf-function+ #x02)
+(defconstant +llf-cons+ #x03)
+(defconstant +llf-symbol+ #x04)
+(defconstant +llf-uninterned-symbol+ #x05)
+(defconstant +llf-unbound+ #x06)
+(defconstant +llf-string+ #x07)
+(defconstant +llf-setf-symbol+ #x08)
+(defconstant +llf-integer+ #x09)
+(defconstant +llf-invoke+ #x0A)
+(defconstant +llf-setf-fdefinition+ #x0B)
+(defconstant +llf-simple-vector+ #x0C)
+(defconstant +llf-character+ #x0D)
+
+(defun write-llf-header (output-stream input-file)
+  ;; TODO: write the source file name out as well.
+  (write-sequence #(#x4C #x4C #x46 #x00) output-stream)) ; LLF\x00
+
+(defun check-llf-header (stream)
+  (assert (and (eql (read-byte stream) #x4C)
+               (eql (read-byte stream) #x4C)
+               (eql (read-byte stream) #x46)
+               (eql (read-byte stream) #x00))))
+
+(defun save-integer (integer stream)
+  (do ()
+      ((zerop (logand integer (lognot #x7F)))
+       (write-byte integer stream))
+    (write-byte (logior #x80 (logand integer #x7F))
+                stream)
+    (setf integer (ash integer -7))))
+
+;;; FIXME: This should allow saving of all attributes and arbitrary codes.
+(defun save-character (character stream)
+  (let ((code (char-code character)))
+    (assert (zerop (char-bits character)) (character))
+    (assert (and (<= 0 code #x1FFFFF)
+                 (not (<= #xD800 code #xDFFF)))
+            (character))
+    (cond ((<= code #x7F)
+           (write-byte code stream))
+          (t (error "TODO character ~S." character)))))
+
+(defgeneric save-one-object (object object-map stream))
+
+(defmethod save-one-object ((object function) omap stream)
+  (write-byte +llf-function+ stream)
+  (write-byte (function-tag object) stream)
+  (save-integer (function-code-size object) stream)
+  (dotimes (i (function-code-size object))
+    (write-byte (function-code-byte object i) stream))
+  (save-object (function-fixups object) omap stream)
+  (save-integer (function-pool-size object) stream)
+  (dotimes (i (function-pool-size object))
+    (save-object (function-pool-object object i) omap stream)))
+
+(defmethod save-one-object ((object cons) omap stream)
+  (write-byte +llf-cons+ stream)
+  (save-object (cdr object) omap stream)
+  (save-object (car object) omap stream))
+
+(defmethod save-one-object ((object symbol) omap stream)
+  (cond ((symbol-package object)
+         (write-byte +llf-symbol+ stream)
+         (save-integer (length (symbol-name object)) stream)
+         (dotimes (i (length (symbol-name object)))
+           (save-character (char (symbol-name object) i) stream))
+         (save-integer (length (package-name (symbol-package object))) stream)
+         (dotimes (i (length (package-name (symbol-package object))))
+           (save-character (char (package-name (symbol-package object)) i) stream)))
+        ((get object 'setf-symbol-backlink)
+         (write-byte +llf-setf-symbol+ stream)
+         (save-object (get object 'setf-symbol-backlink) omap stream))
+        (t (write-byte +llf-uninterned-symbol+ stream)
+           (save-integer (length (symbol-name object)) stream)
+           (dotimes (i (length (symbol-name object)))
+             (save-character (char (symbol-name object) i) stream))
+           ;; Should save flags?
+           (if (boundp object)
+               (save-object (symbol-value object) omap stream)
+               (write-byte +llf-unbound+ stream))
+           (if (fboundp object)
+               (save-object (symbol-function object) omap stream)
+               (write-byte +llf-unbound+ stream))
+           (save-object (symbol-plist object) omap stream))))
+
+(defmethod save-one-object ((object string) omap stream)
+  (write-byte +llf-string+ stream)
+  (save-integer (length object) stream)
+  (dotimes (i (length object))
+    (save-character (char object i) stream)))
+
+(defmethod save-one-object ((object integer) omap stream)
+  (write-byte +llf-integer+ stream)
+  (save-integer object stream))
+
+(defmethod save-one-object ((object vector) omap stream)
+  (write-byte +llf-simple-vector+ stream)
+  (save-integer (length object) stream)
+  (dotimes (i (length object))
+    (save-object (aref object i) omap stream)))
+
+(defmethod save-one-object ((object character) omap stream)
+  (write-byte +llf-character+ stream)
+  (save-character object stream))
+
+(defun save-object (object omap stream)
+  (let ((id (gethash object omap)))
+    (when id
+      (write-byte +llf-backlink+ stream)
+      (save-integer id stream)
+      (return-from save-object))
+    (setf (gethash object omap) (hash-table-count omap))
+    (save-one-object object omap stream)))
+
+(defun fastload-form (form omap stream)
+  (cond ((and (listp form)
+              (= (list-length form) 4)
+              (eql (first form) 'funcall)
+              (equal (second form) '(function (setf fdefinition)))
+              (listp (third form))
+              (= (list-length (third form)) 2)
+              (eql (first (third form)) 'function)
+              (listp (second (third form)))
+              (eql (first (second (third form))) 'lambda)
+              (listp (third form))
+              (= (list-length (fourth form)) 2)
+              (eql (first (fourth form)) 'quote))
+         ;; FORM looks like (FUNCALL #'(SETF FDEFINITION) #'(LAMBDA ...) 'name)
+         (write-byte +llf-setf-fdefinition+ stream)
+         (save-object (compile nil (second (third form))) omap stream)
+         (save-object (second (fourth form)) omap stream)
+         t)
+        ((and (listp form)
+              (= (list-length form 2))
+              (eql (first form) 'quote))
+         t)))
+
+(defun compile-file (input-file &key
+                     (output-file (compile-file-default-output input-file))
+                     (verbose *compile-verbose*)
+                     (print *compile-print*)
+                     (external-format :default))
+  (with-open-file (input-stream input-file :external-format external-format)
+    (with-open-file (output-stream output-file
+                     :element-type '(unsigned-byte 8)
+                     :if-exists :supersede
+                     :direction :output)
+      (format t ";; Compiling file ~S.~%" input-file)
+      (write-llf-header output-stream input-file)
+      (let ((*package* *package*)
+            (*readtable* *readtable*)
+            (*compile-verbose* verbose)
+            (*compile-print* print)
+            (omap (make-hash-table))
+            (eof-marker (cons nil nil)))
+        (do ((form (read input-stream nil eof-marker)
+                   (read input-stream nil eof-marker)))
+            ((eql form eof-marker))
+          (format t ";; Compiling form ~S.~%" form)
+          ;; TODO: Deal with lexical environments.
+          (handle-top-level-form form
+                                 (lambda (f env)
+                                   (assert (not env))
+                                   (or (fastload-form f omap output-stream)
+                                       (progn (write-byte +llf-invoke+ output-stream)
+                                              (save-object (compile nil `(lambda () (progn ,f)))
+                                                           omap output-stream))))
+                                 (lambda (f env)
+                                   (assert (not env))
+                                   (eval f))))
+        (write-byte +llf-end-of-load+ output-stream)))))
+
+(defun load-integer (stream)
+  (do* ((b (read-byte stream) (read-byte stream))
+        (shift 0 (+ shift 7))
+        (value (logand b #x7F)
+               (logior value (ash (logand b #x7F) shift))))
+       ((not (logtest b #x80))
+        value)))
+
+(defun load-character (stream)
+  (let ((lead-byte (read-byte stream)))
+    (when (logtest lead-byte #x80)
+      (error "TODO: non-ascii utf-8 sequence"))
+    (code-char lead-byte)))
+
+(defun load-ub8-vector (stream)
+  (let* ((len (load-integer stream))
+         (seq (make-array len :element-type '(unsigned-byte 8))))
+    (read-sequence seq stream)
+    seq))
+
+(defun load-vector (stream omap)
+  (let* ((len (load-integer stream))
+         (seq (make-array len)))
+    (dotimes (i len)
+      (setf (aref seq i) (load-object stream omap)))
+    seq))
+
+(defun load-string (stream)
+  (let* ((len (load-integer stream))
+         (seq (make-array len :element-type 'character)))
+    (dotimes (i len)
+      (setf (aref seq i) (load-character stream)))
+    seq))
+
+(defun llf-next-is-unbound-p (stream)
+  (let ((current-position (file-position stream)))
+    (cond ((eql (read-byte stream) +llf-unbound+)
+           t)
+          (t (file-position stream current-position)
+             nil))))
+
+(defun load-one-object (command stream omap)
+  (ecase command
+    (#.+llf-function+
+     (let* ((tag (read-byte stream))
+            (mc (load-ub8-vector stream))
+            (fixups (load-object stream omap))
+            (constants (load-vector stream omap)))
+       (make-function-with-fixups tag mc fixups constants)))
+    (#.+llf-cons+
+     (let* ((cdr (load-object stream omap))
+            (car (load-object stream omap)))
+       (cons car cdr)))
+    (#.+llf-symbol+
+     (let* ((name (load-string stream))
+            (package (load-string stream)))
+       (intern name package)))
+    (#.+llf-uninterned-symbol+
+     (let* ((name (load-string stream))
+            (sym (make-symbol name)))
+       (unless (llf-next-is-unbound-p stream)
+         (setf (symbol-value sym) (load-object stream omap)))
+       (unless (llf-next-is-unbound-p stream)
+         (setf (symbol-function sym) (load-object stream omap)))
+       (setf (symbol-plist sym) (load-object stream omap))
+       sym))
+    (#.+llf-string+ (load-string stream))
+    (#.+llf-setf-symbol+
+     (let ((symbol (load-object stream omap)))
+       (function-symbol `(setf ,symbol))))
+    (#.+llf-integer+ (load-integer stream))
+    (#.+llf-simple-vector+ (load-vector stream omap))
+    (#.+llf-character+ (load-character stream))))
+
+(defun load-object (stream omap)
+  (let ((command (read-byte stream)))
+    (case command
+      (#.+llf-end-of-load+
+       (values nil t))
+      (#.+llf-backlink+
+       (let ((id (load-integer stream)))
+         (assert (< id (hash-table-count omap)) () "Object id ~S out of bounds." id)
+         (values (gethash id omap) nil)))
+      (#.+llf-invoke+
+       (values (funcall (load-object stream omap)) nil))
+      (#.+llf-setf-fdefinition+
+       (let ((fn (load-object stream omap))
+             (name (load-object stream omap)))
+         (funcall #'(setf fdefinition) fn name)))
+      (#.+llf-unbound+ (error "Should not seen UNBOUND here."))
+      (t (let ((id (hash-table-count omap)))
+           (setf (gethash id omap) '"!!!LOAD PLACEHOLDER!!!")
+           (let ((obj (load-one-object command stream omap)))
+             (setf (gethash id omap) obj)
+             (values obj nil)))))))
+
+(defun load-llf (stream)
+  (check-llf-header stream)
+  (let ((object-map (make-hash-table)))
+    (loop (multiple-value-bind (object stop)
+              (load-object stream object-map)
+            (declare (ignore object))
+            (when stop
+              (return))))))

genesis/dump.lisp

@@ -283,6 +283,11 @@
 			   :constants (strip-array-header constants)
                            :fixups fixups)))
 
+(defbuiltin make-function-with-fixups (tag mc fixups constants)
+  (make-genesis-function :assembled-code mc
+                         :fixups fixups
+                         :constants constants))
+
 (defun generate-dump-layout (undefined-function-thunk &optional extra-static-objects)
   "Scan the entire Genesis environment, creating a final memory layout for a dump image."
   (let ((static-objects (make-hash-table))