Rewrite install code in '#%kernel to avoid startup time.

src/download-libs.rkt

@@ -0,0 +1,98 @@
+#lang racket/base
+
+(require racket/tcp)
+(provide do-download)
+
+(define url-host "download.racket-lang.org")
+(define url-path "/libs/4/")
+(define url-base (string-append "http://" url-host url-path))
+(define architecture #f) ;; set in `do-download'
+
+
+(define (delete-path path)
+  (cond [(directory-exists? path)
+         (parameterize ([current-directory path])
+           (for-each delete-path (directory-list)))
+         (delete-directory path)]
+        [(or (file-exists? path) (link-exists? path)) (delete-file path)]))
+
+(define (purify-port port)
+  (let ([m (regexp-match-peek-positions #rx#"^HTTP/.*?(?:\r\n\r\n|\n\n|\r\r)"
+                                        port)])
+    (if m (read-bytes (cdar m) port) "")))
+
+(define (copy-port src dest)
+  (let ([s (make-bytes 4096)])
+    (let loop ()
+      (let ([c (read-bytes-avail! s src)])
+        (cond [(number? c)
+               (let loop ([start 0])
+                 (unless (= start c)
+                   (let ([c2 (write-bytes-avail s dest start c)])
+                     (loop (+ start c2)))))
+               (loop)]
+              ;; Must be EOF
+              [else (void)])))))
+
+(define (download* file target)
+  (define src (format "~a~a/~a" url-path architecture file))
+  (define-values [i o] (tcp-connect url-host 80))
+  (fprintf o "GET ~a HTTP/1.0\r\nHost: ~a\r\n\r\n" src url-host)
+  (flush-output o) (tcp-abandon-port o)
+  (purify-port i)
+  (call-with-output-file target #:exists 'truncate/replace
+    (λ (out) (copy-port i out))))
+
+(define (download file size)
+  (define tmp (format "~a.download" file))
+  (let loop ([n 0])
+    (when (> n 0) (printf " retry #~a," n) (flush-output))
+    (define thd (thread (λ () (download* file tmp))))
+    (unless (sync/timeout (+ 10 (* 5 n)) thd)
+      (kill-thread thd)
+      (when (> n 3) (raise-user-error 'download "could not retrieve ~a" file))
+      (when (zero? n) (printf " timeout,"))
+      (loop (add1 n))))
+  (rename-file-or-directory tmp file #t)
+  (define sz (file-size file))
+  (unless (= size sz)
+    (eprintf "\n")
+    (raise-user-error 'get-libs
+                      "size of ~a is ~a; doesn't match expected size ~a"
+                      file sz size)))
+
+
+(define (unpack-tgz tgz)
+  (printf " unpacking...") (flush-output)
+  (define-values [p pout pin perr]
+    (subprocess
+     (current-output-port) (current-input-port) (current-error-port)
+     (find-executable-path "tar") "zxf" tgz))
+  (subprocess-wait p)
+  (delete-file tgz))
+
+(define (install file)
+  (cond [(regexp-match? #rx"[.]tgz" file) (unpack-tgz file)]
+        [else (eprintf "\n")
+              (raise-user-error 'get-libs "don't know how to install file: ~a"
+                                file)]))
+
+
+(define (do-download needed really-needed arch)
+  (set! architecture arch)
+  (printf ">> Downloading files from\n>>   ~a~a\n" url-base architecture)
+  (printf ">> If you don't want automatic download, download each file\n")
+  (printf ">> yourself from there to\n")
+  (printf ">>   ~a\n" (path->complete-path (current-directory)))
+  (for ([file+size (in-list needed)])
+    (define file (car file+size))
+    (define size (cadr file+size))
+    (printf "  ~a" file)
+    (if (member file+size really-needed)
+        (begin (printf " downloading...") (flush-output)
+               (download file size)
+               (when (pair? (cddr file+size))
+                 (delete-path (caddr file+size))
+                 (install file))
+               (printf " done.\n"))
+        (printf " already exists.\n"))))

src/get-libs.rkt

@@ -1,22 +1,18 @@
-#lang racket/base
+;; This program avoids is written in #%kernel and
+;; dynamic-requires the real downloading,
+;; because it is loaded without using bytecode.
+(module get-libs '#%kernel
+  (#%require '#%paramz (for-syntax '#%kernel))
+  (#%provide all-files+sizes)
   
-(require racket/cmdline racket/tcp)
+  (define-values (all-files+sizes)
-
-;; This program avoids racket/port and net/url, because it is loaded
-;; without using bytecode.
-
-(define url-host "download.racket-lang.org")
-(define url-path "/libs/4/")
-(define url-base (string-append "http://" url-host url-path))
-
-(provide all-files+sizes)
-(define all-files+sizes
     ;; alist mapping package to
     ;;   alist mapping architecture to
     ;;    a list of entries, each has filename and size
     ;;    and optionally a path that it would install to and the installed size
-  `(;; Core Libraries
+    (list 
-    [core
+     ;; Core Libraries
+     '[core
        [win32/i386
         ["iconv.dll" 892928]
         ["libeay32.dll" 1089536]
@@ -26,8 +22,9 @@
         ["libeay32.dll" 1410560]
         ["ssleay32.dll" 247808]]]
      ;; GUI Libraries
-    [gui
+     [list 
-     [i386-macosx
+      'gui
+      '[i386-macosx
         ["libcairo.2.dylib" 803196]
         ["libintl.8.dylib" 57604]
         ["libgio-2.0.0.dylib" 736720]
@@ -41,7 +38,7 @@
         ["libgthread-2.0.0.dylib" 24368]
         ["libpng14.14.dylib" 182732]
         ["PSMTabBarControl.tgz" 94103 "PSMTabBarControl.framework" 251764]]
-     [x86_64-macosx
+      '[x86_64-macosx
         ["libcairo.2.dylib" 919840]
         ["libintl.8.dylib" 61016]
         ["libgio-2.0.0.dylib" 897624]
@@ -55,7 +52,7 @@
         ["libgthread-2.0.0.dylib" 21728]
         ["libpng14.14.dylib" 192224]
         ["PSMTabBarControl.tgz" 107267 "PSMTabBarControl.framework" 316528]]
-     [ppc-macosx
+      '[ppc-macosx
         ["libcairo.2.dylib" 2716096]
         ["libintl.8.dylib" 133156]
         ["libgio-2.0.0.dylib" 936176]
@@ -69,7 +66,8 @@
         ["libgthread-2.0.0.dylib" 25416]
         ["libpng14.14.dylib" 505920]
         ["PSMTabBarControl.tgz" 96039 "PSMTabBarControl.framework" 229501]]
-     [win32/i386
+      (append 
+       '[win32/i386
          ["libjpeg-7.dll" 233192]
          ["libcairo-2.dll" 921369]
          ["libpango-1.0-0.dll" 336626]
@@ -83,8 +81,8 @@
          ["libgmodule-2.0-0.dll" 31692]
          ["libpangocairo-1.0-0.dll" 94625]
          ["libpangowin32-1.0-0.dll" 102210]
-      ["libpangoft2-1.0-0.dll" 679322]
+         ["libpangoft2-1.0-0.dll" 679322]]
-      ,@(if (getenv "PLT_WIN_GTK")
+       (if (getenv "PLT_WIN_GTK")
            '(["libatk-1.0-0.dll" 153763]
              ["libgtk-win32-2.0-0.dll" 4740156]
              ["libgdk-win32-2.0-0.dll" 827670]
@@ -92,8 +90,8 @@
              ["libgio-2.0-0.dll" 669318]
              ["libwimp.dll" 69632]
              ["gtkrc" 1181])
-          '())]
+           '()))
-     [win32/x86_64
+      '[win32/x86_64
         ["libjpeg-8.dll" 214016]
         ["libcairo-2.dll" 1266147]
         ["libpango-1.0-0.dll" 423199]
@@ -111,142 +109,99 @@
         ["libpangowin32-1.0-0.dll" 192656]
         ["libpangoft2-1.0-0.dll" 1188615]]]
      ;; Database libraries
-    [db
+     '[db
        [win32/i386
         ["sqlite3.dll" 570947]]
        [win32/x86_64
         ["sqlite3.dll" 617472]]]))
   
   (define-values [package dest-dir]
-  (command-line #:args [package [dest-dir (current-directory)]]
+    (let-values ([(args) (vector->list (current-command-line-arguments))])
-    (values (string->symbol package) dest-dir)))
+      (let-values
+          ([(package) (if (null? args) (error 'get-libs) (car args))])
+        (let-values ([(dd) 
+                      (if (null? (cdr args)) (current-directory) (cadr args))])
+          (values (string->symbol package) dd)))))
   
-(define (unixize p)
+  (define-values (unixize)
+    (lambda (p)
       (let-values ([(base name dir?) (split-path p)])
         (if (path? base)
             (string-append (unixize base) "/" (path->string name))
-      (path->string name))))
+            (path->string name)))))
   
-(define architecture (string->symbol (unixize (system-library-subpath #f))))
+  (define-values (architecture)
+    (string->symbol (unixize (system-library-subpath #f))))
   
-(define (needed-files+sizes)
+  (define-values (needed-files+sizes)
-  (let ([files+sizes
+    (lambda ()
-         (cdr (or (assq package all-files+sizes)
+      (define-values (l) (assq package all-files+sizes))
+      (define-values (files+sizes)
+        (cdr (if l
+                 l
                  (error 'get-libs "bad package: ~s, expecting one of ~s"
-                         package (map car all-files+sizes))))])
+                        package (map car all-files+sizes)))))
-    (cond [(assq architecture files+sizes) => cdr]
+      (define-values (arch) (assq architecture files+sizes))
-          [else '()])))
+      (if arch
+          (cdr arch)
+          '())))
   
-(define (purify-port port)
+  (define-values (directory-size)
-  (let ([m (regexp-match-peek-positions #rx#"^HTTP/.*?(?:\r\n\r\n|\n\n|\r\r)"
+    (lambda (dir)
-                                        port)])
+      (define-values (loop)
-    (if m (read-bytes (cdar m) port) "")))
+        (lambda (l)
+	  (if (null? l) 
+	      0
+	      (+ (path-size (build-path dir (car l))) (loop (cdr l))))))
+      (loop (directory-list dir))))
   
-(define (copy-port src dest)
+  (define-values (path-size)
-  (let ([s (make-bytes 4096)])
+    (lambda (path)
-    (let loop ()
+      (if (file-exists? path) (file-size path)
-      (let ([c (read-bytes-avail! s src)])
+          (if (directory-exists? path) 
-        (cond [(number? c)
+              (directory-size path)
-               (let loop ([start 0])
+              0))))
-                 (unless (= start c)
-                   (let ([c2 (write-bytes-avail s dest start c)])
-                     (loop (+ start c2)))))
-               (loop)]
-              ;; Must be EOF
-              [else (void)])))))
   
-(define (download* file target)
+  (define-values (got-path?) ; approximate, using size
-  (define src (format "~a~a/~a" url-path architecture file))
-  (define-values [i o] (tcp-connect url-host 80))
-  (fprintf o "GET ~a HTTP/1.0\r\nHost: ~a\r\n\r\n" src url-host)
-  (flush-output o) (tcp-abandon-port o)
-  (purify-port i)
-  (call-with-output-file target #:exists 'truncate/replace
-    (λ (out) (copy-port i out))))
-
-(define (download file size)
-  (define tmp (format "~a.download" file))
-  (let loop ([n 0])
-    (when (> n 0) (printf " retry #~a," n) (flush-output))
-    (define thd (thread (λ () (download* file tmp))))
-    (unless (sync/timeout (+ 10 (* 5 n)) thd)
-      (kill-thread thd)
-      (when (> n 3) (raise-user-error 'download "could not retrieve ~a" file))
-      (when (zero? n) (printf " timeout,"))
-      (loop (add1 n))))
-  (rename-file-or-directory tmp file #t)
-  (define sz (file-size file))
-  (unless (= size sz)
-    (eprintf "\n")
-    (raise-user-error 'get-libs
-                      "size of ~a is ~a; doesn't match expected size ~a"
-                      file sz size)))
-
-(define (unpack-tgz tgz)
-  (printf " unpacking...") (flush-output)
-  (define-values [p pout pin perr]
-    (subprocess
-     (current-output-port) (current-input-port) (current-error-port)
-     (find-executable-path "tar") "zxf" tgz))
-  (subprocess-wait p)
-  (delete-file tgz))
-
-(define (install file)
-  (cond [(regexp-match? #rx"[.]tgz" file) (unpack-tgz file)]
-        [else (eprintf "\n")
-              (raise-user-error 'get-libs "don't know how to install file: ~a"
-                                file)]))
-
-(define (delete-path path)
-  (cond [(directory-exists? path)
-         (parameterize ([current-directory path])
-           (for-each delete-path (directory-list)))
-         (delete-directory path)]
-        [(or (file-exists? path) (link-exists? path)) (delete-file path)]))
-
-(define (directory-size dir)
-  (parameterize ([current-directory dir])
-    (for/fold ([sum 0]) ([path (in-list (directory-list))])
-      (+ sum (path-size path)))))
-
-(define (path-size path)
-  (cond [(file-exists? path) (file-size path)]
-        [(directory-exists? path) (directory-size path)]
-        [else 0]))
-
-(define got-path? ; approximate, using size
     (case-lambda [(path size unpacked-path unpacked-size)
                   (got-path? unpacked-path unpacked-size)]
                  [(path size)
                   (equal? size (path-size path))]))
   
-(unless (eq? package 'nothing)
+  
-  (unless (directory-exists? dest-dir) (make-directory dest-dir))
+  ;; not provided by #%kernel
-  (parameterize ([current-directory dest-dir])
+  (define-values (filter)
-    (define needed (needed-files+sizes))
+    (lambda (f l)
-    (define really-needed (filter (λ (n) (not (apply got-path? n))) needed))
+      (if (null? l)
+          l
+          (if (f (car l))
+              (cons (car l) (filter f (cdr l)))
+              (filter f (cdr l))))))
+  
+  (define-syntaxes (here-dir)
+    (λ (stx) 
+      (define-values (base name dir?) (split-path (syntax-source stx)))
+      (datum->syntax (quote-syntax 'here) base)))
+
+  (if (eq? package 'nothing)
+      (void)
+      (begin
+        (if (directory-exists? dest-dir) (void) (make-directory dest-dir))
+        (with-continuation-mark parameterization-key
+          (extend-parameterization
+           (continuation-mark-set-first #f parameterization-key)
+           current-directory dest-dir)
+          (let-values ()
+            (define-values (needed) (needed-files+sizes))
+            (define-values (really-needed) 
+              (filter (λ (n) (not (apply got-path? n))) needed))
             (printf (if (null? needed)
                         ">> No ~a libraries to download for ~a\n"
                         ">> Getting ~a libraries for ~a\n")
                     package architecture)
-    (cond
+            (if (null? needed)
-      [(null? needed) (void)]
+                (void)
-      [(null? really-needed)
+                (if (null? really-needed)                
-       (printf ">> All files present, no downloads needed.\n")]
+                    (printf ">> All files present, no downloads needed.\n")
-      [else
+                    ((dynamic-require (build-path here-dir "download-libs.rkt") 'do-download)
-       (printf ">> Downloading files from\n>>   ~a~a\n" url-base architecture)
+                     needed really-needed architecture))))))))
-       (printf ">> If you don't want automatic download, download each file\n")
-       (printf ">> yourself from there to\n")
-       (printf ">>   ~a\n" (path->complete-path (current-directory)))
-       (for ([file+size (in-list needed)])
-         (define file (car file+size))
-         (define size (cadr file+size))
-         (printf "  ~a" file)
-         (if (member file+size really-needed)
-           (begin (printf " downloading...") (flush-output)
-                  (download file size)
-                  (when (pair? (cddr file+size))
-                    (delete-path (caddr file+size))
-                    (install file))
-                  (printf " done.\n"))
-           (printf " already exists.\n")))])))

src/racket/collects-path.rkt

@@ -2,18 +2,19 @@
 ;; This module is executed by the install process to update
 ;;  the embedded path to "collects" in an executable.
 
-(module collects-path mzscheme
+;; written in #%kernel because it's loaded with -c (ie, no compiled files)
+(module collects-path '#%kernel  
+  (define-values (label) #rx#"coLLECTs dIRECTORy:")
   
-  (define label "coLLECTs dIRECTORy:")
+  (let-values ([(dest) (vector-ref (current-command-line-arguments) 0)]
-
+               [(path) (vector-ref (current-command-line-arguments) 1)])
-  (let ([dest (vector-ref (current-command-line-arguments) 0)]
-	[path (vector-ref (current-command-line-arguments) 1)])
     (let-values ([(i o) (open-input-output-file dest 'update)])
-      (let ([m (regexp-match-positions label i)]
+      (let-values ([(m) (regexp-match-positions label i)]
-	    [path (if (string? path)
+                   [(path) (if (string? path)
                                (string->path path)
                                path)])        
-	(unless m
+        (if m
+            (void)
             (error 'set-collects-path
                    "cannot find collection-path label in executable file"))
         (file-position o (cdar m))

src/racket/mkincludes.rkt

@@ -5,40 +5,54 @@
 ;; 2. The location of the src/mzscheme directory,
 ;; 3. The location of mzconfig.
 
-#lang scheme/base
+;; written in #%kernel because it's loaded with -c (ie, no compiled files)
+
+(module mkincludes '#%kernel
+  (#%require '#%utils)
   
   (define-values (incdir mzsrcdir mzconfdir)
-  (let ([args (vector->list (current-command-line-arguments))])
+    (let-values ([(args) (vector->list (current-command-line-arguments))])
-    (define (dir path) (normal-case-path (simplify-path (cleanse-path path))))
+      (define-values (dir) (lambda (path) (normal-case-path (simplify-path (cleanse-path path)))))
-    (unless (= 3 (length args)) (error 'mkincludes "bad arguments"))
+      (if (= 3 (length args)) (void) (error 'mkincludes "bad arguments"))
       (apply values (map dir args))))
   
   (printf "Making ~a\n" incdir)
   
-(define ((change-regexp from to) src dst)
+  (define-values (change-regexp)
+    (lambda (from to)
+      (lambda (src dst)
         (call-with-input-file src
           (lambda (src)
             (call-with-output-file dst
               (lambda (dst)
-          (when (regexp-match from src 0 #f dst)
+                (if (regexp-match from src 0 #f dst)
-            (display to dst)
+                    (begin (display to dst)
-            (regexp-match "$" src 0 #f dst))))))
+                           (regexp-match "$" src 0 #f dst))
-  (void))
+                    (void))))))
+        (void))))
   
-(define (copy-if-newer basedir source-path [base #f] [copy copy-file])
+  (define-values (copy-if-newer) 
-  (define source (build-path basedir source-path))
+    (case-lambda 
-  (define target
+      [(basedir source-path) (copy-if-newer basedir source-path #f copy-file)]
+      [(basedir source-path base) (copy-if-newer basedir source-path base copy-file)]
+      [(basedir source-path base copy)
+       (define-values (source) (build-path basedir source-path))
+       (define-values (target)
          (build-path incdir
-                (or base
+                     (if base
+                         base
                          (let-values ([(_1 name _2) (split-path source)]) name))))
-  (define source-t (file-or-directory-modify-seconds source))
+       (define-values (source-t) (file-or-directory-modify-seconds source))
-  (define target-t (and (file-exists? target)
+       (define-values (target-t) (if (file-exists? target)
-                        (file-or-directory-modify-seconds target)))
+                                     (file-or-directory-modify-seconds target)
-  (cond
+                                     #f))
-   [(not target-t) (copy source target)]
+       (if (not target-t)
-   [(< target-t source-t) (delete-file target) (copy source target)]))
+           (copy source target)
+           (if (< target-t source-t)
+               (begin (delete-file target) (copy source target))
+               (void)))]))
   
-(unless (directory-exists? incdir) (make-directory incdir))
+  (if (directory-exists? incdir) (void) (make-directory incdir))
   (copy-if-newer mzconfdir "mzconfig.h")
   (copy-if-newer mzsrcdir "sconfig.h")
   (copy-if-newer mzsrcdir "uconfig.h")
@@ -60,4 +74,4 @@
   (copy-if-newer mzsrcdir "gc2/gc2.h" "schemegc2.h")
   (copy-if-newer mzsrcdir "gc2/gc2_obj.h" "schgc2obj.h")
   
-(printf "Done.\n")
+  (printf "Done.\n"))