block compilation: Add START-BLOCK and END-BLOCK declarations.

And respect ANSI with the proclamation processing at that. (The CMU CL
code did some magic proclaim handling instead which was the initial
reason the support got gutted in the first place, as far as I can
tell.)

NEWS

@@ -1,5 +1,9 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
 
+changes relative to sbcl-2.0.4:
+  * enchancement: CMUCL-style START-BLOCK and END-BLOCK declarations are now
+    supported for block compiling forms at a sub-file granularity.
+
 changes in sbcl-2.0.4 relative to sbcl-2.0.3:
   * platform support:
     ** 32-bit RISC-V is now fully supported. Unlike other ports, its backend

doc/manual/compiler.texinfo

@@ -1138,9 +1138,7 @@ compiler's behavior and how to maximally optimize code in their
 manual. In particular, while SBCL no longer supports byte-code
 compilation, it does support CMUCL's block compilation facility allowing
 whole program optimization and increased use of the local call
-convention. We do not currently support the @code{start-block} and
-@code{end-block} declarations, although we do support the same arguments
-to @code{compile-file} regarding block compilation.
+convention.
 
 Unlike CMUCL, SBCL is able to open-code forward-referenced type tests
 while block compiling. This helps for mutually referential

package-data-list.lisp-expr

@@ -851,7 +851,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
 
                ;; extended declarations..
                "ALWAYS-BOUND" "FREEZE-TYPE" "GLOBAL" "INHIBIT-WARNINGS"
-               "MAYBE-INLINE"
+               "MAYBE-INLINE" "START-BLOCK" "END-BLOCK"
 
                ;; ..and variables to control compiler policy
                "*INLINE-EXPANSION-LIMIT*"

src/code/cross-early.lisp

@@ -18,9 +18,9 @@
 
 (declaim (declaration truly-dynamic-extent))
 
-;;; MAYBE-INLINE and FREEZE-TYPE declarations can be safely ignored
+;;; MAYBE-INLINE, FREEZE-TYPE, and block compilation declarations can be safely ignored
 ;;; (possibly at some cost in efficiency).
-(declaim (declaration freeze-type maybe-inline))
+(declaim (declaration freeze-type maybe-inline start-block end-block))
 
 ;;; SB-C::LAMBDA-LIST declarations can be ignored.
 ;;; Cross-compilation does not rely on introspection for anything.

src/compiler/early-c.lisp

@@ -154,6 +154,12 @@ possible. Potentially long (over one page in size) vectors are, however, not
 stack allocated except in zero SAFETY code, as such a vector could overflow
 the stack without triggering overflow protection.")
 
+;;; *BLOCK-COMPILE-ARGUMENT* holds the original value of the :BLOCK-COMPILE
+;;; argument, which overrides any internal declarations.
+(defvar *block-compile-argument*)
+(declaim (type (member nil t :specified)
+               *block-compile-default* *block-compile-argument*))
+
 ;;; This lock is seized in the compiler, and related areas -- like the
 ;;; classoid/layout/class system.
 ;;; Assigning a literal object enables genesis to dump and load it

src/compiler/main.lisp

@@ -16,12 +16,6 @@
 (defvar *block-compile-default* nil
   "The default value for the :Block-Compile argument to COMPILE-FILE.")
 
-;;; *BLOCK-COMPILE-ARGUMENT* holds the original value of the :BLOCK-COMPILE
-;;; argument, which overrides any internal declarations.
-(defvar *block-compile-argument*)
-(declaim (type (member nil t :specified)
-               *block-compile-default* *block-compile-argument*))
-;;; Ditto.
 (defvar *entry-points-argument*)
 (declaim (type list *entry-points-argument*))
 
@@ -1533,19 +1527,20 @@ necessary, since type inference may take arbitrarily long to converge.")
 ;;; Actually compile any stuff that has been queued up for block
 ;;; compilation.
 (defun finish-block-compilation ()
-  (when (block-compile *compilation*)
+  (let ((compilation *compilation*))
+    (when (block-compile compilation)
       (when sb-xc:*compile-print*
         (compiler-mumble "~&; block compiling converted top level forms..."))
-    (when (toplevel-lambdas *compilation*)
+      (when (toplevel-lambdas compilation)
         ;; FIXME: Use the source information from the initial
         ;; conversion. CMUCL does this right.
         (with-source-paths
-        (compile-toplevel (nreverse (toplevel-lambdas *compilation*)) nil))
-      (setf (toplevel-lambdas *compilation*) nil))
+            (compile-toplevel (nreverse (toplevel-lambdas compilation)) nil))
+        (setf (toplevel-lambdas compilation) nil))
       ;; CMUCL always reverts this to :SPECIFIED. But we probably want
       ;; to restore it to the user default.
-    (setf (block-compile *compilation*) *block-compile-default*)
-    (setf (entry-points *compilation*) nil)))
+      (setf (block-compile compilation) *block-compile-argument*)
+      (setf (entry-points compilation) nil))))
 
 (declaim (ftype function handle-condition-p))
 (flet ((get-handled-conditions ()
@@ -1784,8 +1779,6 @@ returning its filename.
      compilation.  A value of T indicates that all forms in the file(s) should
      be compiled as a unit.  The default is the value of
      SB-EXT:*BLOCK-COMPILE-DEFAULT*, which is initially NIL.
-     (Note: We currently do not support START-BLOCK or END-BLOCK as the behavior
-     of these proclamations are not ANSI.)
 
   :ENTRY-POINTS
      This specifies a list of function names for functions in the file(s) that

src/compiler/proclaim.lisp

@@ -222,6 +222,16 @@
   (warn-if-inline-failed/proclaim name kind)
   (setf (info :function :inlinep name) kind))
 
+(defun process-block-compile-declaration (entries kind)
+  (ecase kind
+    (start-block
+     (finish-block-compilation)
+     (let ((compilation *compilation*))
+       (setf (block-compile compilation) t)
+       (setf (entry-points compilation) entries)))
+    (end-block
+     (finish-block-compilation))))
+
 (defun check-deprecation-declaration (state since form)
   (unless (typep state 'deprecation-state)
     (error 'simple-type-error
@@ -331,6 +341,13 @@
              (push raw-form *queued-proclaims*)))
         (freeze-type
          (map-args #'process-freeze-type-declaration))
+        ((start-block end-block)
+         (when (and *compile-time-eval* (boundp '*compilation*))
+           (if (eq *block-compile-argument* :specified)
+               (process-block-compile-declaration args kind)
+               (compiler-notify "ignoring ~S declaration since ~
+                                :BLOCK-COMPILE is not :SPECIFIED"
+                                kind))))
         (optimize
          (multiple-value-bind (new-policy specified-qualities)
              (process-optimize-decl form *policy*)

tests/block-compile-test-4.lisp

@@ -0,0 +1,18 @@
+;;; From the CMU CL user manual.
+(declaim (sb-ext:start-block fun1 fun3))
+
+(defun fun1 (x)
+  (print x))
+
+(defun fun2 ()
+  (1+ (fun1 6)))
+
+(defun fun3 (x)
+  (if x
+      (fun1 3)
+      (fun2)))
+
+(declaim (sb-ext:end-block))
+
+(defun fun4 (z)
+  (+ 2 (fun1 z)))

tests/compiler.impure.lisp

@@ -3024,6 +3024,16 @@
         (frob #'bar2))
       (assert (= (length components) 4)))))
 
+(with-test (:name (:block-compile :start-block/end-block))
+  (with-scratch-file (fasl "fasl")
+    (compile-file "block-compile-test-4.lisp" :output-file fasl :block-compile :specified)
+    (load fasl)
+    (assert (eq (sb-kernel::fun-code-header #'fun1)
+                (sb-kernel::fun-code-header #'fun3)))
+    (assert (not (eq (sb-kernel::fun-code-header #'fun1)
+                     (sb-kernel::fun-code-header #'fun4))))
+    (assert (not (fboundp 'fun2)))))
+
 (with-test (:name :symbol-value-constant)
   (let* ((package-name (gensym "SYMBOL-VALUE-CONSTANT-TEST"))
          (*package* (make-package package-name :use '(cl))))

tests/input-manifest.lisp-expr

@@ -31,7 +31,8 @@
   "tests/symbol-macrolet-test.lisp"
   "tests/block-compile-test.lisp"
   "tests/block-compile-test-2.lisp"
-  "tests/block-compile-test-3.lisp")
+  "tests/block-compile-test-3.lisp"
+  "tests/block-compile-test-4.lisp")
  ("debug.impure.lisp" "tests/bug-414.lisp")
  ("defstruct.impure-cload.lisp" "tests/block-compile-defstruct-test.lisp")
  ("elfcore.test.sh" "src/runtime/shrinkwrap-sbcl")