build.zuo

#lang zuo
(require (rename-in "makefiles/boot.zuo"
                    [boot-file-names boot:boot-file-names]
                    [cross-build-boot boot:cross-build-boot])
         (only-in "s/reboot.zuo"
                  reboot)
         (only-in "s/build.zuo"
                  [targets-at s-targets-at]
                  all-src-names)
         (only-in "c/build.zuo"
                  [targets-at c-targets-at])
         "makefiles/lib.zuo")

(provide-targets targets-at)

;; This is the main entry point to the Chez Scheme build. A build
;; directory's "main.zuo" and a workarea directory's "main.zuo" both
;; call `targets-at` with an `at-dir` that points to the workarea
;; directory.

(define (targets-at at-dir [vars (hash)])
  (define Mf-config (at-dir "Mf-config"))
  (unless (file-exists? Mf-config)
    (error "no \"Mf-config\" - not running from a build directory?"))
  (define config (config-file->hash Mf-config vars))

  (define m (hash-ref config 'm))
  (define mboot (hash-ref config 'mboot m))

  ;; subdirectories where we create a "main.zuo" that bounce to
  ;; "build.zuo" in the source area
  (define bounce-dirs
    '("c" "s" "mats" "examples"))
  (define bounce-files
    (map (lambda (d) (at-dir d "main.zuo")) bounce-dirs))
  (define bounce-scripts
    (map (lambda (d)
           (~a "#lang zuo\n"
               (~s `(define config (config-file->hash (at-source ".." "Mf-config")))) "\n"
               (~s `(build/command-line* (dynamic-require (build-path ((make-at-dir (at-source ".." ".."))
                                                                       (hash-ref config 'srcdir))
                                                                      ,d
                                                                      "build.zuo")
                                                          'targets-at)
                                         at-source))))
         bounce-dirs))

  (define record-from-pb?
    (directory-exists? (at-source "boot" "pb")))

  (define boot-from-pb?
    (and (equal? (hash-ref config 'enableFrompb #f) "yes")
         (not (equal? m "pb"))
         record-from-pb?))

  (define (find-boot-src-dir mboot always-use-here?)
    (let ([here-dir (at-dir ".." "boot" mboot)])
      (if (or always-use-here?
              (directory-exists? here-dir))
          here-dir
          (at-source "boot" mboot))))

  (define boot-src-dir
    (find-boot-src-dir mboot boot-from-pb?))

  (define boot-file-names
    (append
     boot:boot-file-names
     ;; extra boot files from source
     (let ([config-file (build-path boot-src-dir "Mf-config")])
       (if (file-exists? config-file)
           (shell->strings (hash-ref (config-file->hash config-file) 'extraBootFiles ""))
           '()))))

  (define boot-files
    (map (lambda (file) (at-dir "boot" m file)) boot-file-names))

  (define boot-src-files
    (and boot-from-pb?
         (map (lambda (file) (build-path boot-src-dir file))
              boot:boot-file-names)))
  (define pb-files
    (and record-from-pb?
         (let ([pb-dir (find-boot-src-dir "pb" #f)])
           (map (lambda (file) (build-path pb-dir file))
                boot:boot-file-names))))

  (define all-src-files
    (map (lambda (n) (at-source "s" n))
         all-src-names))

  (define via-pb-files
    (and record-from-pb?
         (append pb-files all-src-files)))

  (define clean-links-stamp (at-dir ".no-links"))

  (define (build-kernel-only?)
    (string=? (hash-ref config 'buildKernelOnly "no") "yes"))
  (define (check-not-kernel-only)
    (when (build-kernel-only?)
      (error "target does not apply to a kernel-only configuration")))

  ;; besides `<machine>` argument, accepts `--host-scheme <command>`
  ;; or `--host-workarea <dir>", and recognizes `SCHEME=...` if neither
  ;; flag is provided; also recognizes "--xpatch" before anything else
  ;; to request that "xpatch" is left in an "xc-" directory
  (define (parse-boot-args orig-args default-m-key k)
    (define xpatch?
      (and (pair? orig-args)
           (equal? "--xpatch" (car orig-args))))
    (define args (if xpatch? (cdr orig-args) orig-args))
    (define host-scheme-via-flag
      (and (pair? args)
           (equal? (car args) "--host-scheme")
           (pair? (cdr args))
           (cadr args)))
    (define host-workarea
      (and (not host-scheme-via-flag)
           (pair? args)
           (equal? (car args) "--host-workarea")
           (pair? (cdr args))
           (cadr args)))
    (define host-scheme (or host-scheme-via-flag
                            (and (not host-workarea)
                                 (let ([s (hash-ref config 'SCHEME #f)])
                                   (and (not (equal? s ""))
                                        s)))))
    (define rest-args (if (or host-workarea
                              host-scheme-via-flag)
                          (cddr args)
                          args))
    (unless (<= (length rest-args) 1) (error "expected optional <machine>" args))
    (define xm (if (null? rest-args)
                   (hash-ref config default-m-key m)
                   (car rest-args)))
    (define host-m (if host-scheme
                       (ask-scheme-machine host-scheme)
                       m))
    (k xm host-m host-scheme host-workarea xpatch?))

  ;; Cross-builds for a machine type that is specified as an argument;
  ;; the machine type defaults to the `defaultm` configuration entry, and
  ;; that default is normally useful if the current machine type is "pb"
  (define (cross-build-boot token args ccopts make-targets record-dep?)
    (parse-boot-args
     args
     'defaultm
     (lambda (xm m host-scheme host-workarea xpatch?)
       (unless (or host-scheme host-workarea)
         (check-not-kernel-only))
       (alert (~a "building boot files for " xm " using " m))
       (boot:cross-build-boot token ccopts make-targets xpatch?
                              xm host-scheme host-workarea
                              at-dir config vars m)
       (when record-dep?
         (record-build-success token xm m host-scheme host-workarea)))))

  (define (cross-build-boot/safe+examples token args)
    (cross-build-boot token args (hash 'o "2" 'd "3" 'i "t") '("all" "examples") #t))

  (define (cross-reboot token args)
    (parse-boot-args
     args
     'm
     (lambda (xm m host-scheme host-workarea xpatch?)
       (when xpatch? (error "cannot generate xpatch in reboot mode"))
       (define scheme (or host-scheme
                          (if host-workarea
                              (build-path host-workarea m "bin" m (.exe "scheme"))
                              (.exe "scheme"))))
       (define options (if host-workarea
                           (hash 'env
                                 (cons "SCHEMEHEAPDIRS"
                                       (path->complete-path (build-path host-workarea "boot" m))))
                           (hash)))
       (reboot m xm scheme (hash 'shell-options options
                                 'out-dir (at-dir "..")
                                 'work-dir (at-dir "..")))
       (record-build-success token xm m host-scheme host-workarea))))

  (define (record-build-success token xm m host-scheme host-workarea)
    ;; record success so boot files will not be rebuilt from pb
    (when (and record-from-pb?
               (not (equal? xm "pb")))
      (build-boot-target token xm m host-scheme host-workarea void)))

  ;; used to create a target for "quickboot", or just record dependency for other modes
  ;; of building boot files
  (define (build-boot-target token xm m host-scheme host-workarea thunk)
    (define (at-boot name) (at-dir "../boot" xm name))
    (define (host-boot-files)
      (cond
        [host-workarea
         (map (lambda (file) (build-path host-workarea "boot" m file)) boot-file-names)]
        [host-scheme '()]
        [else boot-files]))
    (build (target (at-boot (car boot-file-names))
                   (lambda (path token)
                     (rule (if record-from-pb?
                               ;; declare dependency on pb instead of host,
                               ;; so we don't rebuild via pb:
                               via-pb-files
                               ;; otherwise, bootquick again if host changes:
                               (append (host-boot-files)
                                       all-src-files))
                           thunk))
                   (hash 'co-outputs (map at-boot (cdr boot-file-names))
                         'precious? #t
                         'db-dir (if record-from-pb?
                                     ;; record dependency with pb
                                     (let ([dir (at-dir "../pb")])
                                       (mkdir-p dir)
                                       dir)
                                     (at-dir "."))))
           token))
  
  (define (run-tests token name [vars vars])
    (check-not-kernel-only)
    (build (find-target name
                        ((dynamic-require (at-source "mats/build.zuo") 'targets-at)
                         (make-at-dir (at-dir "mats"))
                         vars))
           token))

  (define stexlib
    (let ([configured (hash-ref config 'STEXLIB "")]
          [env (assoc "STEXLIB" (hash-ref (runtime-env) 'env))])
      (cond
        [(not (equal? "" configured))
         configured]
        [env
         (cdr env)]
        [else
         (at-source "stex")])))
  (define stex-sources
    (source-tree stexlib))

  (define doc-project-names
    ;; happily, the name of the subdirectory is the same as
    ;; value assigned to `x` in the corresponding makefile
    '("csug" "release_notes"))
  (define doc-install-dir-keys
    ;; in parallel to doc-project-names
    '(InstallCSUG InstallReleaseNotes))
  (define (targets-for-doc name install-dir-key)
    (define doc-dir (at-dir ".." name)) ;; ".." goes out of the workarea
    (define mf-in (at-source "makefiles" (~a "Makefile-" name ".in")))
    (define mf-out (build-path doc-dir "Makefile"))
    (define name-sym (string->symbol name))
    (define (run-make target)
      (check-not-kernel-only)
      (define (->rel-shell pth)
        (string->shell (find-relative-path doc-dir pth)))
      (shell/wait "make"
                  (~a "m=" m)
                  (~a "srcdir=" (->rel-shell (at-source name)))
                  (~a "installdir="
                      (->rel-shell (hash-ref config install-dir-key)))
                  (~a "STEXLIB=" (->rel-shell stexlib))
                  target
                  (hash 'dir doc-dir)))
    `([:target ,mf-out (,mf-in)
               ,(lambda (path token)
                  (mkdir-p doc-dir)
                  (cp mf-in mf-out))]
      [:target ,name-sym (,mf-out
                          ,@(source-tree (at-source name))
                          ,@stex-sources)
               ,(lambda (token . args)
                  (run-make ""))]
      [:target ,(string->symbol (~a "install-" name)) (,name-sym)
               ,(lambda (token . args)
                  (run-make "install"))]))

  (define (check-boot-file-version)
    (define src-ver (source-version))
    (define boot-ver (boot-files-version (at-dir "boot" m)))
    (unless (string-ci=? src-ver boot-ver)
      (error (~a "version " boot-ver " in boot and header files for "
                 m
                 " do not match source version " src-ver "; rebuild boot files"))))

  (define the-targets
    (make-targets
     `(;; Builds the kernel (C code) and boot files (Scheme code):
       [:target build (workarea kernel)
                ,(lambda (token)
                   (unless (build-kernel-only?)
                     (build (find-target "bootstrap" (s-targets-at (make-at-dir (at-dir "s")) vars))
                            token)))]

       ;; Builds just the kernel (C code):
       [:target kernel (workarea)
                ,(lambda (token)
                   (build (find-target "build" (c-targets-at (make-at-dir (at-dir "c")) vars))
                          token))]

       [:target install ()
                ,(lambda (token)
                   (check-not-kernel-only)
                   ((dynamic-require (at-source "makefiles/install.zuo") 'install)
                    at-dir
                    (hash 'DESTDIR (hash-ref config 'DESTDIR ""))))]

       [:target uninstall ()
                ,(lambda (token)
                   (check-not-kernel-only)
                   ((dynamic-require (at-source "makefiles/install.zuo") 'install)
                    at-dir
                    (hash)
                    #t))]

       [:target bintar ()
                ,(lambda (token)
                   ((dynamic-require (at-source "makefiles/bintar.zuo") 'make-bintar)
                    at-dir
                    m))]

       [:target run ()
                ,(lambda (token . args)
                   (cond
                     [(equal? (hash-ref config 'exeSuffix "") ".html")
                      ;; must be an Emscripten build...
                      (shell (build-shell "cd" (string->shell (at-dir "bin" m))
                                          "&& node scheme.js"))]
                     [else
                      (define t (find-target "run" (s-targets-at (make-at-dir (at-dir "s")) vars)))
                      (build (command-target->target t args)
                             token)]))
                :command]

       ;; See `cross-build-boot`: builds cross-compiler in unsafe mode, skips examples,
       ;; only rebuilds if needed
       [:target bootquick ()
                ,(lambda (token . args)
                   (check-not-kernel-only)
                   (parse-boot-args
                    args
                    'defaultm
                    (lambda (xm m host-scheme host-workarea xpatch?)
                      (build-boot-target
                       token xm m host-scheme host-workarea
                       (lambda ()
                         (unless (or host-scheme host-workarea)
                           (build/dep (find-target "kernel" the-targets) token))
                         (cross-build-boot token args (hash) '("all") #f))))))
                :command]

       ;; See `cross-build-boot`: builds cross-compiler in safe mode, includes examples
       [:target boot ()
                ,(lambda (token . args)
                   (cross-build-boot/safe+examples token args))
                :command]

       [:target bootfiles (build)
                ,(lambda (token)
                   (check-not-kernel-only)
                   (for-each (lambda (mach)
                               (cross-build-boot/safe+examples token (list mach)))
                             (unique (append (ls (at-source "boot"))
                                             (ls (at-dir "../boot"))))))]

       [:target reboot ()
                ,(lambda (token . args)
                   (cross-reboot token args))
                :command]

       [:target bootpbchunk ()
                ,(lambda (token . args)
                   (build (command-target->target (find-target "bootpbchunk"
                                                               (s-targets-at (make-at-dir (at-dir "s")) vars))
                                                  args)
                          token))
                :command]

       [:target test-one (build) ,(lambda (token) (run-tests token "test-one"))]
       [:target test-some-fast (build) ,(lambda (token) (run-tests token "test-some-fast"))]
       [:target test-some (build) ,(lambda (token) (run-tests token "test-some"))]
       [:target test (build) ,(lambda (token) (run-tests token "test"))]
       [:target test-more (build) ,(lambda (token) (run-tests token "test-more"))]

       [:target coverage (kernel)
                ,(lambda (token)
                   (check-not-kernel-only)
                   (when (glob-match? "t*" m)
                     (error "coverage doesn't work with threads enabled"))
                   (let ([vars (hash-set vars 'c "t")])
                     (build (find-target "bootstrap" (s-targets-at (make-at-dir (at-dir "s"))
                                                                   (hash-set vars 'p "t")))
                            token)
                     (run-tests token "all" vars)
                     (run-tests token "coverage" vars)))]

       ;; The `reset` target discards the results in "boot" and puts back links to (or copies of)
       ;; to the versions that are used to seed the build
       [:target reset ()
                ,(lambda (token)
                   (for-each (lambda (f) (when (file-exists? f) (rm f))) boot-files)
                   (build (map (lambda (f) (find-target f the-targets)) boot-files)
                          token))]

       ,@(apply append (map targets-for-doc
                            doc-project-names
                            doc-install-dir-keys))
       [:target docs (csug release_notes)
                ,void]
       [:target install-docs (install-csug install-release_notes)
                ,void]


       [:target rpm ()
                ,(lambda (token)
                   (mkdir-p (at-dir "rpm"))
                   (cp/ln (at-source "rpm/Makefile") (at-dir "rpm/Makefile"))
                   (shell/wait (hash-ref config 'MAKE "make")
                               (hash 'dir (at-dir "rpm"))))]

       [:target pkg ()
                ,(lambda (token)
                   (mkdir-p (at-dir "pkg"))
                   (cp/ln (at-source "pkg/Makefile") (at-dir "pkg/Makefile"))
                   (cp/ln (at-source "pkg/rmpkg") (at-dir "pkg/rmpkg"))
                   (shell/wait (hash-ref config 'MAKE "make")
                               (hash 'dir (at-dir "pkg"))))]

       ,@(if (eq? 'windows (system-type))
             `([:target all-dlls (build)
                        ,(lambda (token)
                           (for-each*
                            '("dll" "static")
                            (lambda (runtimeAs)
                              (for-each*
                               '("dll" "exe")
                               (lambda (linkAs)
                                 (fd-write (fd-open-output 'stdout)
                                           (~a "Also buidling variant " runtimeAs " " linkAs "...\n"))
                                 (define var-dir (if (and (equal? runtimeAs (hash-ref config 'runtimeAs #f))
                                                          (equal? linkAs (hash-ref config 'linkAs #f)))
                                                     ;; same configuration as executable, but maybe
                                                     ;; produces a differently named DLL due to 'productAs:
                                                     (at-dir "c")
                                                     (at-dir (~a "c-" runtimeAs "-" linkAs))))
                                 (mkdir-p var-dir)
                                 (build (find-target "lib" (c-targets-at (make-at-dir var-dir)
                                                                         (hash-set* vars
                                                                                    'runtimeAs runtimeAs
                                                                                    'linkAs linkAs
                                                                                    'productAs "dll")))
                                        token))))))])
             '())

       [:target clean ()
                ,(lambda (token)
                   (define keeps '("Mf-config" "main.zuo"))
                   (for-each (lambda (name)
                               (unless (member name keeps)
                                 (rm* (at-dir name))))
                             (ls (at-dir "."))))]

       ;; Internal targets ----------------------------------------

       ;; Builds out an initial workarea, with links to book files
       [:target workarea (,@bounce-files ,@boot-files ,clean-links-stamp)
                ,(lambda (token)
                   (check-boot-file-version))
                :quiet]

       ,@(map (lambda (dir file script)
                `[:target ,file (,(input-data-target 'script script))
                          ,(lambda (path token)
                             (mkdir-p (at-dir dir))
                             (display-to-file script path :truncate))])
              bounce-dirs
              bounce-files
              bounce-scripts)

       ,@(map (lambda (name dest)
                (define src (build-path boot-src-dir name))
                ;; If `dest` doesn't exist, use `src`. If `dest` exists and `src` is newer
                ;; than when `dest` was first created, then use `src` in that case, too.
                ;; Otherwise, leave `dest` alone on the assumption that it's a newer
                ;; version bootstrapped from `src`.
                `[:target ,dest (,src)
                          ,(lambda (dest token)
                             (define orig-sha1-file (~a dest ".orig-hash"))
                             (define src-hash (file-sha256 src token))
                             (unless (and (file-exists? dest)
                                          (file-exists? orig-sha1-file)
                                          (equal? src-hash
                                                  (file->string orig-sha1-file)))
                               (mkdir-p (at-dir "boot" m))
                               (display-to-file src-hash orig-sha1-file :truncate)
                               (cp/ln src dest)))])
              boot-file-names
              boot-files)

       ,@(if boot-from-pb?
             `([:target (,@boot-src-files) (,@via-pb-files)
                        ,(lambda (first-path token)
                           (check-machine-type m)
                           (alert (~a "checking boot files for " m " against pb"))
                           (define pb-dir (at-dir ".." "pb"))
                           (mkdir-p pb-dir)
                           (define cross? #t)
                           (define Mf-config
                             (cond
                               [(string=? (hash-ref config 'crossCompile "no") "yes")
                                (shell/wait (build-raw-path (at-source ".") "configure")
                                            "--nomakefile"
                                            "--pb")
                                (build-path pb-dir "Mf-config")]
                               [else (at-dir "Mf-config")]))
                           (define old-config (map (lambda (s) (string-trim (string-trim s "\r")))
                                                   (string-split (file->string Mf-config) "\n")))
                           (define m-line (~a "m=" m))
                           (define mboot-line (~a "mboot=" mboot))
                           (define new-config (cons "m=pb"
                                                    (filter (lambda (s) (not (or (string=? s m-line)
                                                                                 (string=? s mboot-line))))
                                                            old-config)))
                           (display-to-file (string-join new-config "\n") (build-path pb-dir "Mf-config")
                                            :truncate)
                           (build (command-target->target (find-target "bootquick"
                                                                       (targets-at (make-at-dir pb-dir) vars))
                                                          (list m))
                                  token))
                        :precious])
             '())

       [:target ,clean-links-stamp ()
                ,(lambda (path token)
                   ;; clear out links from old build system that break the new build
                   (clean-links (at-dir))
                   (display-to-file "done" path :truncate))]

       ;; Needed to keep the initial-boot-file info here instead of in "boot"
       [:db-dir ,(at-dir ".")]

       #;(end-make-targets))))

  the-targets)