Rework default pathname defaults and working directory pathname.

New logic:

- *default-pathname-defaults* is just #!default, which as an argument
  to pathname operations has the same effect as not passing it and
  implying the default pathname defaults parameter instead.

- (param:default-pathname-defaults) can be set to #f (default),
  meaning use whatever (working-directory-pathname) returns

- wrkdir.scm no longer depends on the default pathname defaults
  mechanism at all (although it is still kind of broken: it should be
  a thread-local file descriptor fit for use with openat &c.)

This way nothing gets stored in a band.

If the extra parsing turns out to be slow, we can the working
directory pathname in a string that we clear with a secondary GC
daemon, but let's wait for a measurement of slowness before
bothering.

(cherry picked from commit a0d7954f8f61e39155bf937d54be9497a3637c23)

diff --git a/src/runtime/pathname.scm b/src/runtime/pathname.scm
index 505d29f6aebd8466132a1979755947eb4ee95cee..73449693e9f64a2a7db95acf528413d49c20623f 100644 (file)
--- a/src/runtime/pathname.scm
+++ b/src/runtime/pathname.scm
@@ -31,7 +31,8 @@ USA.
 
 (add-boot-deps! '(runtime pathname unix)
                '(runtime pathname dos)
-               '(runtime reader))
+               '(runtime reader)
+               '(runtime working-directory))
 \f
 #|
 
@@ -441,27 +442,34 @@ these rules:
 \f
 ;;;; Pathname Merging
 
-(define *default-pathname-defaults*)
+(define *default-pathname-defaults* #!default)
 (define param:default-pathname-defaults)
 
 (define (make-param:default-pathname-defaults)
-  (make-general-parameter (make-pathname local-host #f #f #f #f #f)
+  (make-general-parameter #f
                          defaults-converter
                          defaults-merger
-                         default-parameter-getter
+                         defaults-getter
                          defaults-setter))
 
 (define (defaults-converter object)
-  (parse-namestring object local-host))
+  (and object
+       (parse-namestring object local-host)))
 
 (define (defaults-merger old new)
-  (pathname-simplify (merge-pathnames new old)))
+  (if old
+      (and new (pathname-simplify (merge-pathnames new old)))
+      new))
 
 (define (defaults-setter set-param defaults)
   (set-param defaults)
-  (set! *default-pathname-defaults* defaults)
   unspecific)
 
+(define (defaults-getter value)
+  (or value
+      (working-directory-pathname)
+      (make-pathname local-host #f #f #f #f #f)))
+
 (define (merge-pathnames pathname #!optional defaults default-version)
   (let* ((defaults
           (if (and (not (default-object? defaults)) defaults)
@@ -728,7 +736,6 @@ these rules:
       (set! host-types types)
       (set! local-host (make-host host-type #f))))
   (set! param:default-pathname-defaults (make-param:default-pathname-defaults))
-  (set! *default-pathname-defaults* (param:default-pathname-defaults))
   unspecific)
 
 (add-boot-init!

diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm
index c23dd5dec240db1a065e215cf1d4792f5a94718e..e2ee57e7f1910e4be933302eb2526da14d747218 100644 (file)
--- a/src/runtime/rep.scm
+++ b/src/runtime/rep.scm
@@ -117,8 +117,7 @@ USA.
   (port/set-default-directory (cmdl/port cmdl) pathname))
 \f
 (define (cmdl/start cmdl message)
-  (let ((port (cmdl/port cmdl))
-       (pathname-defaults (param:default-pathname-defaults)))
+  (let ((port (cmdl/port cmdl)))
     (let ((thunk
           (lambda ()
             (parameterize ((current-input-port #f)
@@ -133,13 +132,13 @@ USA.
                            (param:standard-error-hook #f)
                            (param:standard-warning-hook #f)
                            (param:standard-breakpoint-hook #f)
-                           (param:default-pathname-defaults pathname-defaults)
+                           (param:default-pathname-defaults #f)
                            (dynamic-handler-frames '())
                            (param:bound-restarts
                             (if (cmdl/parent cmdl)
                                 (param:bound-restarts)
                                 '())))
-              (fluid-let ((*default-pathname-defaults* pathname-defaults))
+              (fluid-let ((*default-pathname-defaults* #!default))
                 (let loop ((message message))
                   (loop
                    (bind-abort-restart cmdl

diff --git a/src/runtime/wrkdir.scm b/src/runtime/wrkdir.scm
index bc82a063094cf1dace40197f32460679e1f6e1cd..f092717340677787b9a6a3830866f1ef800af201 100644 (file)
--- a/src/runtime/wrkdir.scm
+++ b/src/runtime/wrkdir.scm
@@ -28,8 +28,6 @@ USA.
 ;;; package: (runtime working-directory)
 
 (declare (usual-integrations))
-
-(add-boot-deps! '(runtime pathname))
 \f
 (define-deferred *working-directory-pathname*
   (make-general-parameter #f
@@ -40,21 +38,16 @@ USA.
 
 (define (wd-setter set-param pathname)
   (set-param pathname)
-  (param:default-pathname-defaults pathname)
   pathname)
 
 (define (working-directory-pathname)
-  (*working-directory-pathname*))
-
-(define (reset!)
-  (*working-directory-pathname*
-   (pathname-simplify
-    (pathname-as-directory
-     (string-from-primitive
-      ((ucode-primitive working-directory-pathname)))))))
-(add-boot-init!
- (lambda ()
-   (run-now-and-after-restore! reset!)))
+  (or (*working-directory-pathname*)
+      (pathname-simplify
+       (pathname-as-directory
+       (parse-namestring
+        (string-from-primitive
+         ((ucode-primitive working-directory-pathname)))
+        local-host)))))
 
 (define (set-working-directory-pathname! name)
   (let ((pathname (new-pathname name)))
@@ -78,10 +71,8 @@ USA.
 
 (define (with-working-directory-pathname name thunk)
   (let ((pathname (new-pathname name)))
-    (fluid-let ((*default-pathname-defaults* pathname))
-      (parameterize ((param:default-pathname-defaults pathname)
-                    (*working-directory-pathname* pathname))
-       (thunk)))))
+    (parameterize ((*working-directory-pathname* pathname))
+      (thunk))))
 
 (define (new-pathname name)
   (pathname-simplify