add --launcher'/-l' flag to `raco exe' to create launchers

This addition triggered several other changes:

 * -k for a Mac OS X embedding is now relative to the __PLTSCHEME
   segment (which means that executables won't break if you strip
   them, for example)

 * the command-line no longer has a limited size for Mac OS X
   launchers and embedding executables

 * Mac OS X GUI and Windows launchers record the creation-time
   collection path, unless they are created as "relative" launchers

collects/compiler/commands/exe.rkt

@@ -10,6 +10,7 @@
 
 (define gui (make-parameter #f))
 (define 3m (make-parameter #t))
+(define launcher (make-parameter #f))
 
 (define exe-output (make-parameter #f))
 (define exe-embedded-flags (make-parameter '("-U" "--")))
@@ -26,6 +27,8 @@
     (exe-output file)]
    [("--gui") "Generate GUI executable"
     (gui #t)]
+   [("-l" "--launcher") "Generate a launcher"
+    (launcher #t)]
    [("--collects-path") path "Set <path> as main collects for executable"
     (exe-embedded-collects-path path)]
    [("--collects-dest") dir "Write collection code to <dir>"
@@ -70,6 +73,17 @@
                  (extract-base-filename/ss source-file
                                            (string->symbol (short-program+command-name))))
              (gui))])
+  (cond
+   [(launcher)
+    (parameterize ([current-launcher-variant (if (3m) '3m 'cgc)])
+      ((if (gui) 
+           make-gracket-launcher 
+           make-racket-launcher)
+       (append (list "-t" (path->string (path->complete-path source-file)))
+               (exe-embedded-flags))
+       dest
+       (exe-aux)))]
+   [else
     (mzc:create-embedding-executable
      dest
      #:mred? (gui)
@@ -91,6 +105,6 @@
      #:cmdline (exe-embedded-flags)
      #:collects-path (exe-embedded-collects-path)
      #:collects-dest (exe-embedded-collects-dest)
-   #:aux (exe-aux))
+     #:aux (exe-aux))])
   (when (verbose)
     (printf " [output to \"~a\"]\n" dest)))

collects/compiler/embed-unit.rkt

@@ -1048,7 +1048,8 @@
                     cmdline
                     [aux null]
                     [launcher? #f]
-                    [variant (system-type 'gc)])
+                    [variant (system-type 'gc)]
+                    [collects-path #f])
         (create-embedding-executable dest
                                      #:mred? mred?
                                      #:verbose? verbose?
@@ -1058,7 +1059,8 @@
                                      #:cmdline cmdline
                                      #:aux aux
                                      #:launcher? launcher?
-                                     #:variant variant)))
+                                     #:variant variant
+                                     #:collects-path collects-path)))
     
     ;; Use `write-module-bundle', but figure out how to put it into an executable
     (define (create-embedding-executable dest
@@ -1096,7 +1098,7 @@
                                    (or (not m)
                                        (not (cdr m))))))
       (define long-cmdline? (or (eq? (system-type) 'windows)
-                                (and use-starter-info? mred? (eq? 'macosx (system-type)))
+                                (eq? (system-type) 'macosx)
                                 unix-starter?))
       (define relative? (let ([m (assq 'relative? aux)])
                           (and m (cdr m))))
@@ -1227,19 +1229,40 @@
 						  (relativize dir dest-exe values)
 						  dir)
 					      "")))
-				  full-cmdline))))])
+				  full-cmdline))))]
+                  [write-cmdline
+                   (lambda (full-cmdline out)
+                     (for-each
+                      (lambda (s)
+                        (fprintf out "~a~a~c"
+                                 (integer->integer-bytes 
+                                  (add1 (bytes-length (string->bytes/utf-8 s)) )
+                                  4 #t #f)
+                                 s
+                                 #\000))
+                      full-cmdline)
+                     (display "\0\0\0\0" out))])
               (let-values ([(start decl-end end cmdline-end)
                             (if (and (eq? (system-type) 'macosx)
                                      (not unix-starter?))
                                 ;; For Mach-O, we know how to add a proper segment
                                 (let ([s (open-output-bytes)])
                                   (define decl-len (write-module s))
-                                  (let ([s (get-output-bytes s)])
+                                  (let* ([s (get-output-bytes s)]
-                                    (let ([start (add-plt-segment dest-exe s)])
+                                         [cl (let ([o (open-output-bytes)])
+                                               ;; position is relative to __PLTSCHEME:
+                                               (write-cmdline (make-full-cmdline 0 decl-len (bytes-length s)) o)
+                                               (get-output-bytes o))])
+                                    (let ([start (add-plt-segment 
+                                                  dest-exe 
+                                                  (bytes-append
+                                                   s
+                                                   cl))])
+                                      (let ([start 0]) ; i.e., relative to __PLTSCHEME
                                         (values start
                                                 (+ start decl-len)
                                                 (+ start (bytes-length s))
-					      #f))))
+                                                (+ start (bytes-length s) (bytes-length cl)))))))
                                 ;; Unix starter: Maybe ELF, in which case we 
                                 ;; can add a proper section
                                 (let-values ([(s e dl p)
@@ -1336,7 +1359,8 @@
                                                 (lambda () (find-cmdline 
                                                             "instance-check"
                                                             #"yes, please check for another"))))]
-                             [out (open-output-file dest-exe #:exists 'update)])
+                             [out (open-output-file dest-exe #:exists 'update)]
+                             [cmdline-done? cmdline-end])
                          (dynamic-wind
                           void
                           (lambda ()
@@ -1345,28 +1369,22 @@
                               (write-bytes #"no," out))
                             (if long-cmdline?
                                 ;; write cmdline at end:
-                                (file-position out end)
+                                (unless cmdline-done?
+                                  (file-position out end))
                                 (begin
                                   ;; write (short) cmdline in the normal position:
                                   (file-position out cmdpos)
                                   (display "!" out)))
-                            (for-each
+                            (unless cmdline-done?
-                             (lambda (s)
+                              (write-cmdline full-cmdline out))
-                               (fprintf out "~a~a~c"
-                                        (integer->integer-bytes 
-                                         (add1 (bytes-length (string->bytes/utf-8 s)) )
-                                         4 #t #f)
-                                        s
-                                        #\000))
-                             full-cmdline)
-                            (display "\0\0\0\0" out)
                             (when long-cmdline?
                               ;; cmdline written at the end;
                               ;; now put forwarding information at the normal cmdline pos
-                              (let ([new-end (file-position out)])
+                              (let ([new-end (or cmdline-end
+                                                 (file-position out))])
                                 (file-position out cmdpos)
                                 (fprintf out "~a...~a~a"
-                                         (if keep-exe? "*" "?")
+                                         (if (and keep-exe? (eq? 'windows (system-type))) "*" "?")
                                          (integer->integer-bytes end 4 #t #f)
                                          (integer->integer-bytes (- new-end end) 4 #t #f)))))
                           (lambda ()

collects/compiler/embed.rkt

@@ -19,7 +19,10 @@
                          (listof string?))
                         ((listof (cons/c symbol? any/c))
                          any/c
-                         symbol?)
+                         symbol?
+                         (or/c #f
+                               path-string?
+                               (listof path-string?)))
                         void?)]
                   [create-embedding-executable
                    (->* (path-string?)

collects/launcher/launcher-unit.rkt

@@ -379,8 +379,12 @@
   (if (not (and (let ([m (assq 'independent? aux)])
                   (and m (cdr m)))))
     ;; Normal launcher:
-    (make-embedding-executable
+    (make-embedding-executable dest (eq? kind 'mred) 
-     dest (eq? kind 'mred) #f null null null flags aux #t variant)
+                               #f null null null flags aux #t variant
+                               (if (let ([a (assq 'relative? aux)])
+                                     (and a (cdr a)))
+                                   #f
+                                   (find-collects-dir)))
     ;; Independent launcher (needed for Setup PLT):
     (begin
       (install-template dest kind "mzstart.exe" "mrstart.exe")
@@ -465,7 +469,11 @@
                                  flags
                                  aux
                                  #t
-                                 variant)))
+                                 variant
+                                 (if (let ([a (assq 'relative? aux)])
+                                       (and a (cdr a)))
+                                     #f
+                                     (find-collects-dir)))))
 
 (define (make-macos-launcher kind variant flags dest aux)
   (install-template dest kind "GoMr" "GoMr")

collects/scribblings/raco/exe-api.scrbl

@@ -286,8 +286,8 @@ is initialized to an empty list and
 @racket[use-collection-link-paths] is set to false to disable the
 use of @tech[#:doc reference-doc]{collection links files}.
 
-If the @racket[#:launcher?] argument is @racket[#t], then no
+If the @racket[#:launcher?] argument is @racket[#t], then
-@racket[module]s should be null, @racket[literal-files] should be
+@racket[lid-list] should be null, @racket[literal-files] should be
 null, @racket[literal-sexp] should be @racket[#f], and the platform
 should be Windows or Mac OS X. The embedding executable is created in
 such a way that @racket[(find-system-path 'exec-file)] produces the
@@ -355,7 +355,11 @@ have been applied as needed to refer to the existing file).}
                                [cmdline (listof string?)]
                                [aux (listof (cons/c symbol? any/c)) null]
                                [launcher? any/c #f]
-                               [variant (one-of/c 'cgc '3m) (system-type 'gc)])
+                               [variant (one-of/c 'cgc '3m) (system-type 'gc)]
+                               [collects-path (or/c #f
+                                                    path-string? 
+                                                    (listof path-string?))
+                                              #f])
          void?]{
 
 Old (keywordless) interface to @racket[create-embedding-executable].}

collects/scribblings/raco/exe.scrbl

@@ -71,6 +71,10 @@ attaches information to the executable based on the auxilliary file's
 suffix; see @racket[extract-aux-from-path] for a list of recognized
 suffixes and meanings.
 
+The @Flag{l} or @DFlag{launcher} flag creates a @tech{launcher}
+instead of a stand-alone executable. See @secref["launcher"] for more
+information on launchers. The @DFlag{lib} has no effect in that case.
+
 @; ----------------------------------------------------------------------
 
 @include-section["exe-api.scrbl"]

collects/scribblings/raco/launcher.scrbl

@@ -10,14 +10,19 @@
 
 @title[#:tag "launcher"]{Installation-Specific Launchers}
 
+A @deftech{launcher} is similar to a stand-alone executable, but a
+launcher is usually smaller and can be created more quickly, because
+it depends permanently on the local Racket installation and the
+program's sources. In the case of Unix, a launcher is simply a shell
+script that runs @exec{racket} or @exec{gracket}. Launchers
+@emph{cannot} be packaged into a distribution using @exec{raco
+distribute}. The @exec{raco exe} command creates a launcher when the
+@Flag{l} or @DFlag{launcher} flag is specified.
+
 @defmodule[launcher/launcher]
 
 The @racketmodname[launcher/launcher] library provides functions for
-creating @defterm{launchers}, which are similar to stand-alone
+creating @tech{launchers}.
-executables, but sometimes smaller because they depend permanently on
-the local Racket installation. In the case of Unix, in particular,
-a launcher is simply a shell script. The @exec{raco exe} command provides no
-direct support for creating launchers.
 
 @section{Creating Launchers}
 
@@ -44,8 +49,8 @@ the following additional associations apply to launchers:
 @itemize[
 
  @item{@racket['independent?] (Windows) --- a boolean; @racket[#t]
-       creates an old-style launcher that is independent of the
+       creates an old-style launcher that work with any
-       MzRacket or GRacket binary, like @exec{setup-plt.exe}. No other
+       Racket or GRacket binary, like @exec{setup-plt.exe}. No other
        @racket[aux] associations are used for an old-style launcher.}
 
  @item{@racket['exe-name] (Mac OS X, @racket['script-3m] or

collects/scribblings/reference/startup.scrbl

@@ -168,12 +168,13 @@ flags:
 
   @item{@FlagFirst{k} @nonterm{n} @nonterm{m} @nonterm{p} : Loads code
         embedded in the executable from file position @nonterm{n} to
-        @nonterm{m} and from @nonterm{m} to @nonterm{p}. The first
+        @nonterm{m} and from @nonterm{m} to @nonterm{p}. (On Mac OS X,
-        range is loaded in every new @tech{place}, and any modules
+        @nonterm{n}, @nonterm{m}, and @nonterm{p} are relative to a
-        declared in that range are considered predefined in the sense
+        @tt{__PLTSCHEME} segment in the executable.) The first range
-        of @racket[module-predefined?]. This option is normally
+        is loaded in every new @tech{place}, and any modules declared
-        embedded in a stand-alone binary that also embeds Racket
+        in that range are considered predefined in the sense of
-        code.}
+        @racket[module-predefined?]. This option is normally embedded
+        in a stand-alone binary that also embeds Racket code.}
 
   @item{@FlagFirst{m} or @DFlagFirst{main} : Evaluates a call to
         @racketidfont{main} as bound in the top-level environment. All

collects/tests/racket/embed.rktl

@@ -6,6 +6,7 @@
 (require compiler/embed
          mzlib/file
 	 mzlib/process
+         launcher
          compiler/distribute)
 
 (define (mk-dest-bin mred?)
@@ -67,12 +68,9 @@
     (test expect with-input-from-file (build-path (find-system-path 'temp-dir) "stdout") 
 	  (lambda () (read-string 5000)))))
 
-(define try-exe 
+(define (try-exe exe expect mred? [dist-hook void] #:dist? [dist? #t] . collects)
-  (case-lambda
-   [(exe expect mred?)
-    (try-exe exe expect mred? void)]
-   [(exe expect mred? dist-hook . collects)
   (try-one-exe exe expect mred?)
+  (when dist?
     ;; Build a distirbution directory, and try that, too:
     (printf " ... from distribution ...\n")
     (when (directory-exists? dist-dir)
@@ -84,7 +82,7 @@
                                  dist-mred-exe
                                  dist-mz-exe))
                  expect mred?)
-    (delete-directory/files dist-dir)]))
+    (delete-directory/files dist-dir)))
 
 (define (base-compile e)
   (parameterize ([current-namespace (make-base-namespace)])
@@ -109,6 +107,13 @@
      `(,(flags "l") ,(string-append "tests/racket/" filename)))
     (try-exe dest expect mred?)
 
+    ;; As a launcher:
+    (prepare dest filename)
+    ((if mred? make-gracket-launcher make-racket-launcher)
+     (list "-l" (string-append "tests/racket/" filename))
+     dest)
+    (try-exe dest expect mred? #:dist? #f)
+
     ;; Try explicit prefix:
     (printf ">>>explicit prefix\n")
     (let ([w/prefix
@@ -250,16 +255,38 @@
      `("-l" "tests/racket/embed-me5.rkt"))
     (try-exe mr-dest "This is 5: #<class:button%>\n" #t)))
 
-;; Try the mzc interface:
+;; Try the raco interface:
 (require setup/dirs
 	 mzlib/file)
 (define mzc (build-path (find-console-bin-dir) (if (eq? 'windows (system-type))
                                                    "mzc.exe"
                                                    "mzc")))
+(define raco (build-path (find-console-bin-dir) (if (eq? 'windows (system-type))
+                                                    "raco.exe"
+                                                    "raco")))
 
 (define (mzc-tests mred?)
   (parameterize ([current-directory (find-system-path 'temp-dir)])
 
+    ;; raco exe
+    (system* raco
+             "exe"
+	     "-o" (path->string (mk-dest mred?))
+	     (if mred? "--gui" "--")
+	     (path->string (build-path (collection-path "tests" "racket") "embed-me1.rkt")))
+    (try-exe (mk-dest mred?) "This is 1\n" mred?)
+
+    ;;raco exe --launcher
+    (system* raco
+             "exe"
+             "--launcher"
+	     "-o" (path->string (mk-dest mred?))
+	     (if mred? "--gui" "--")
+	     (path->string (build-path (collection-path "tests" "racket") "embed-me1.rkt")))
+    (try-exe (mk-dest mred?) "This is 1\n" mred? #:dist? #f)
+
+    ;; the rest use mzc...
+
     (system* mzc 
 	     (if mred? "--gui-exe" "--exe")
 	     (path->string (mk-dest mred?))

src/racket/cmdline.inc

@@ -56,6 +56,12 @@ static int _coldir_offset = 19; /* Skip permanent tag */
 # define XFORM_OK_PLUS +
 #endif
 
+#ifdef OS_X
+# include <mach-o/getsect.h>
+# include <mach-o/dyld.h>
+# include <fcntl.h>
+#endif
+
 #ifdef DOS_FILE_SYSTEM
 # include <Windows.h>
 
@@ -85,6 +91,22 @@ END_XFORM_SKIP;
 # endif
 #endif
 
+#ifdef OS_X
+static long get_segment_offset()
+{
+# ifdef __x86_64__
+  const struct segment_command_64 *seg;
+# else
+  const struct segment_command *seg;
+#endif
+  seg = getsegbyname("__PLTSCHEME");
+  if (seg)
+    return seg->fileoff;
+  else
+    return 0;
+}
+#endif
+
 #ifndef DONT_PARSE_COMMAND_LINE
 static int is_number_arg(const char *s)
 {
@@ -108,11 +130,31 @@ static int is_number_arg(const char *s)
   return 1;
 }
 
+#ifdef OS_X
+char *add_to_str(const char *addr, long amt)
+{
+  long addr_v;
+  char buf[32];
+  addr_v = atoi(addr) + amt;
+  sprintf(buf, "%ld", addr_v);
+  return strdup(buf);
+}
+#endif
+
 static char *make_embedded_load(const char *start, const char *end)
 {
   char *s;
   int slen, elen;
 
+#ifdef OS_X
+  {
+    long fileoff;
+    fileoff = get_segment_offset();
+    start = add_to_str(start, fileoff);
+    end = add_to_str(end, fileoff);
+  }
+#endif
+
   slen = strlen(start);
   elen = strlen(end);
 
@@ -648,6 +690,7 @@ static int run_from_cmd_line(int argc, char *_argv[],
     GC_CAN_IGNORE unsigned char *orig_p;
     char **argv2;
 
+    p = NULL;
 #ifdef DOS_FILE_SYSTEM
     if ((scheme_cmdline_exe_hack[0] == '?')
 	|| (scheme_cmdline_exe_hack[0] == '*')) {
@@ -723,8 +766,33 @@ static int run_from_cmd_line(int argc, char *_argv[],
 		+ 4);
 	}
       }
-    } else
+    }
 #endif
+#ifdef OS_X
+    if (scheme_cmdline_exe_hack[0] == '?') {
+      long fileoff, cmdoff, cmdlen;
+      int fd;
+      fileoff = get_segment_offset();
+
+      p = (unsigned char *)scheme_cmdline_exe_hack + 4;
+      cmdoff = (p[0]
+                + (((long)p[1]) << 8)
+                + (((long)p[2]) << 16)
+                + (((long)p[3]) << 24));
+      cmdlen = (p[4]
+                + (((long)p[5]) << 8)
+                + (((long)p[6]) << 16)
+                + (((long)p[7]) << 24));
+      p = malloc(cmdlen);
+      
+      fd = open(_dyld_get_image_name(0), O_RDONLY);
+      lseek(fd, fileoff + cmdoff, 0);
+      read(fd, p, cmdlen);
+      close(fd);
+    }
+#endif
+     
+    if (!p)
       p = (unsigned char *)scheme_cmdline_exe_hack + 1;
 
     /* Command line is encoded as a sequence of pascal-style strings;