Changeset 15580

Timestamp:

05/23/22 06:23:39 (10 months ago)

Author:

Mark Evenson

Message:

Compiler falls back to interpreted forms greater than 65535 bytes

This allows loading the FSET library by adding the too large sexps as
interpreted forms to loader, macroexpanding all forms before writing
the form to the loader to try follow the CL standard.

File:

• trunk/abcl/src/org/armedbear/lisp/compile-file.lisp (modified) (15 diffs)

trunk/abcl/src/org/armedbear/lisp/compile-file.lisp

@@ -74 +74 @@
         (setf (char name i) #\_)))
     name))
-  
+
 
 (declaim (ftype (function () t) next-classfile))
@@ -107 +107 @@
     (return-from verify-load nil))
   (with-open-file (cf classfile :direction :input)
-    (when 
+    (when
         (= 0 (file-length cf))
 ;;; TODO hook into a real ABCL compiler condition hierarchy
@@ -205 +205 @@
 ;; TODO        (annotate form toplevel-form classfile compiled-function fasl-class-number)
         ;;; ??? define an API by perhaps exporting these symbols?
-        (setf (getf form 'form-source) 
+        (setf (getf form 'form-source)
               toplevel-form
-              
-              (getf form 'classfile) 
+
+              (getf form 'classfile)
               classfile
-                   
-              (getf form 'compiled-function) 
+
+              (getf form 'compiled-function)
               compiled-function
-                  
-              (getf form 'class-number) 
+
+              (getf form 'class-number)
               saved-class-number))
       (setf form
@@ -323 +323 @@
                          (cl:get ',sym  'sys::source nil))))))
 
-          
+
 (declaim (ftype (function (t t t) t) process-toplevel-mop.ensure-method))
 (defun process-toplevel-mop.ensure-method (form stream compile-time-too)
@@ -393 +393 @@
               :element-type ',(array-element-type initial-value)
               :initial-contents ',(coerce initial-value 'list))))
-    `(progn 
+    `(progn
        (sys:put ',name 'sys::source
                 (cl:cons
@@ -497 +497 @@
                  when (eq (car method-form) :method)
                    collect
-                   (multiple-value-bind (function-name qualifiers lambda-list specializers documentation declarations body) 
+                   (multiple-value-bind (function-name qualifiers lambda-list specializers documentation declarations body)
                        (mop::parse-defmethod `(,(second form) ,@(rest method-form)))
                      ;;; FIXME: style points for refactoring double backquote to "normal" form
@@ -604 +604 @@
                                    (cl:cons '((:function ,name)
                                               ,(namestring *source*) ,*source-position*)
-                                            (cl:get ',sym  'sys::source nil)))                 
+                                            (cl:get ',sym  'sys::source nil)))
                           (sys:fset ',name
                                     (sys::get-fasl-function *fasl-loader*
@@ -640 +640 @@
     (push name *toplevel-functions*)
     (when (and (consp name)
-               (or 
+               (or
                 (eq 'setf (first name))
                 (eq 'cl:setf (first name))))
@@ -700 +700 @@
       (when (and (symbolp operator)
                  (macro-function operator *compile-file-environment*))
-        (when (eq operator 'define-setf-expander) 
+        (when (eq operator 'define-setf-expander)
           (push (second form) *toplevel-setf-expanders*))
-        (when (and (eq operator 'defsetf) 
+        (when (and (eq operator 'defsetf)
                    (consp (third form))) ;; long form of DEFSETF
           (push (second form) *toplevel-setf-expanders*))
@@ -742 +742 @@
                           (translate-logical-pathname output-file)
                           output-file))
-         (zipfile 
+         (zipfile
           (if (find :windows *features*)
               (make-pathname :defaults output-file :type type)
@@ -783 +783 @@
 
 (defun write-fasl-prologue (stream in-package)
-  "Write the forms that form the fasl to STREAM.  
-
-The last form will use IN-PACKAGE to set the *package* to its value when 
+  "Write the forms that form the fasl to STREAM.
+
+The last form will use IN-PACKAGE to set the *package* to its value when
 COMPILE-FILE was invoked."
   (let ((out stream)
@@ -824 +824 @@
 (defun compile-from-stream (in output-file temp-file temp-file2
                             extract-toplevel-funcs-and-macros
-                            functions-file macros-file exports-file 
+                            functions-file macros-file exports-file
                             setf-functions-file setf-expanders-file)
   (let* ((*compile-file-pathname* (make-pathname :defaults (pathname in)
@@ -855 +855 @@
             (jvm::with-file-compilation
               (handler-bind
-                  ((style-warning 
+                  ((style-warning
                     #'(lambda (c)
                         (setf warnings-p t)
@@ -876 +876 @@
                      (when (eq form in)
                        (return))
-                     (process-toplevel-form form out nil))))
+                     (if (>= (length (format nil "~a" form)) 65536)
+                         ;; Following the solution propose here:
+                         ;; see https://github.com/armedbear/abcl/issues/246#issuecomment-698854437
+                         ;; just include the offending interpreted form in the loader
+                         ;; using it instead of the compiled representation
+                         (write (ext:macroexpand-all form *compile-file-environment*)
+                                :stream out)
+                         (process-toplevel-form form out nil))
+                     )))
                     (finalize-fasl-output)
                     (dolist (name *fbound-names*)
@@ -1042 +1050 @@
             (compile-from-stream in output-file temp-file temp-file2
                                  extract-toplevel-funcs-and-macros
-                                 functions-file macros-file exports-file 
+                                 functions-file macros-file exports-file
                                  setf-functions-file setf-expanders-file)
           (values (truename output-file) warnings-p failure-p))))))