From 20672cd60a3a4625a248400dc6a16f047c9bda64 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 25 Apr 2019 10:09:26 -0600 Subject: [PATCH] make Chez Scheme bootstrap work as a "cs-bootstrap" package --- Makefile | 2 +- .../pkg/scribblings/dirs-catalog.scrbl | 7 +- racket/collects/pkg/dirs-catalog.rkt | 16 +-- racket/src/cs/bootstrap/config.rkt | 15 ++- racket/src/cs/bootstrap/constant.rkt | 19 +-- racket/src/cs/bootstrap/info.rkt | 10 ++ racket/src/cs/bootstrap/main.rkt | 29 +++++ racket/src/cs/bootstrap/make-boot.rkt | 5 + racket/src/cs/bootstrap/primdata.rkt | 114 +++++++++--------- racket/src/cs/bootstrap/r6rs-lang.rkt | 2 +- racket/src/thread/future.rkt | 2 +- 11 files changed, 140 insertions(+), 81 deletions(-) create mode 100644 racket/src/cs/bootstrap/info.rkt create mode 100644 racket/src/cs/bootstrap/main.rkt diff --git a/Makefile b/Makefile index 85ec676965..4654490c22 100644 --- a/Makefile +++ b/Makefile @@ -658,7 +658,7 @@ PKGS_CATALOG = -U -G build/config -l- pkg/dirs-catalog --link --check-metadata - PKGS_CONFIG = -U -G build/config racket/src/pkgs-config.rkt pkgs-catalog: - $(RUN_RACKET) $(PKGS_CATALOG) racket/share/pkgs-catalog pkgs racket/src/expander + $(RUN_RACKET) $(PKGS_CATALOG) racket/share/pkgs-catalog pkgs racket/src/expander racket/src/cs/bootstrap $(RUN_RACKET) $(PKGS_CONFIG) "$(DEFAULT_SRC_CATALOG)" "$(SRC_CATALOG)" $(RUN_RACKET) racket/src/pkgs-check.rkt racket/share/pkgs-catalog diff --git a/pkgs/racket-doc/pkg/scribblings/dirs-catalog.scrbl b/pkgs/racket-doc/pkg/scribblings/dirs-catalog.scrbl index 69c2e5f5da..5e836f8d74 100644 --- a/pkgs/racket-doc/pkg/scribblings/dirs-catalog.scrbl +++ b/pkgs/racket-doc/pkg/scribblings/dirs-catalog.scrbl @@ -62,4 +62,9 @@ and @racket[pkg-desc] definition in each package's @filepath{info.rkt} file. If either definition is missing and @racket[check-metadata?] is true, an error is reported. -@history[#:changed "6.90.0.4" @elem{Added the @racket[#:immediate] argument.}]} +If a package's @filepath{info.rkt} file defines @racket[pkg-name], +then the defined name is used as the package's name instead of the +package directory's name. + +@history[#:changed "6.90.0.4" @elem{Added the @racket[#:immediate] argument.} + #:changed "7.3.0.2" @elem{Added support for @racket[pkg-name] to name a package.}]} diff --git a/racket/collects/pkg/dirs-catalog.rkt b/racket/collects/pkg/dirs-catalog.rkt index 08af41f790..db65760fcc 100644 --- a/racket/collects/pkg/dirs-catalog.rkt +++ b/racket/collects/pkg/dirs-catalog.rkt @@ -55,6 +55,13 @@ (status-printf "Finding packages\n") + (define metadata-ns (make-base-namespace)) + (define (get-pkg-info pkg-dir) + (get-info/full pkg-dir + #:namespace metadata-ns + #:bootstrap? #t)) + + ;; Recur through directory tree, and treat each directory ;; that has an "info.rkt" file as a package (and don't recur ;; further into the package) @@ -67,7 +74,8 @@ (define (check-path src-f f) (cond [(file-exists? (build-path src-f "info.rkt")) - (define f-name (path->string f)) + (define f-name (or ((get-pkg-info src-f) 'pkg-name (lambda _ #f)) + (path->string f))) (when (hash-ref found f-name #f) (error 'pack-local "found package ~a multiple times: ~a and ~a" @@ -93,12 +101,6 @@ (status-printf " Uncataloging package ~a\n" (path->string l)) (delete-directory/files (build-path catalog-path "pkg" l)))))) - (define metadata-ns (make-base-namespace)) - (define (get-pkg-info pkg-dir) - (get-info/full pkg-dir - #:namespace metadata-ns - #:bootstrap? #t)) - (define missing-desc null) (define missing-authors null) diff --git a/racket/src/cs/bootstrap/config.rkt b/racket/src/cs/bootstrap/config.rkt index d479015174..7a969017ed 100644 --- a/racket/src/cs/bootstrap/config.rkt +++ b/racket/src/cs/bootstrap/config.rkt @@ -8,10 +8,11 @@ (define ht (get-place-table)) (define scheme-dir (or (hash-ref ht 'make-boot-scheme-dir #f) - (simplify-path - (path->complete-path - (or (getenv "SCHEME_SRC") - (error "set `SCHEME_SRC` environment variable")))))) + (let ([scheme-dir + (getenv "SCHEME_SRC")]) + (and scheme-dir + (simplify-path + (path->complete-path scheme-dir)))))) (hash-set! ht 'make-boot-scheme-dir scheme-dir) (define target-machine (or (hash-ref ht 'make-boot-targate-machine #f) @@ -24,8 +25,10 @@ "ta6nt" "ti3nt")] [else - (error "set `MACH` environment variable")]))) - + (case (path->string (system-library-subpath #f)) + [("x86_64-linux") "ta6le"] + [("i386-linux") "ti3le"] + [else #f])]))) (hash-set! ht 'make-boot-targate-machine target-machine) (define optimize-level-init 3) diff --git a/racket/src/cs/bootstrap/constant.rkt b/racket/src/cs/bootstrap/constant.rkt index ee46fc5bde..566d0cdd6f 100644 --- a/racket/src/cs/bootstrap/constant.rkt +++ b/racket/src/cs/bootstrap/constant.rkt @@ -31,20 +31,21 @@ [_ (void)]) (loop))))) -(call-with-input-file - (build-path scheme-dir "s" (string-append target-machine ".def")) - read-constants) - -(call-with-input-file - (build-path scheme-dir "s" "cmacros.ss") - read-constants) +(when scheme-dir + (call-with-input-file + (build-path scheme-dir "s" (string-append target-machine ".def")) + read-constants) + + (call-with-input-file + (build-path scheme-dir "s" "cmacros.ss") + read-constants)) (define-syntax-rule (define-constant id ...) (begin (provide id ...) - (define id (hash-ref ht 'id)) ...)) + (define id (hash-ref ht 'id #f)) ...)) -(hash-set! ht 'ptr-bytes (/ (hash-ref ht 'ptr-bits) 8)) +(hash-set! ht 'ptr-bytes (/ (hash-ref ht 'ptr-bits 64) 8)) (define-constant ptr-bytes diff --git a/racket/src/cs/bootstrap/info.rkt b/racket/src/cs/bootstrap/info.rkt new file mode 100644 index 0000000000..716bade2e6 --- /dev/null +++ b/racket/src/cs/bootstrap/info.rkt @@ -0,0 +1,10 @@ +#lang info + +(define collection "cs-bootstrap") +(define pkg-name "cs-bootstrap") ; for `create-dirs-catalog` + +(define deps '("base")) + +(define pkg-desc "Creates Chez Scheme boot files from source") + +(define pkg-authors '(mflatt)) diff --git a/racket/src/cs/bootstrap/main.rkt b/racket/src/cs/bootstrap/main.rkt new file mode 100644 index 0000000000..6a855668b2 --- /dev/null +++ b/racket/src/cs/bootstrap/main.rkt @@ -0,0 +1,29 @@ +#lang racket/base +(require racket/cmdline + racket/runtime-path) + +;; Wrapper around "make-boot.rkt" to make it work in a more normal way +;; with command-line arguments, instead of environment variables. + +(define scheme-src #f) +(define mach #f) + +(command-line + #:once-each + [("--scheme-src") dir "Select the directory (defaults to current directory)" + (set! scheme-src dir)] + [("--machine") machine "Select the machine type (defaults to inferred)" + (set! mach machine)]) + +(unless scheme-src + (printf "Assuming current directory has Chez Scheme sources\n") + (flush-output)) + +(void (putenv "SCHEME_SRC" (or scheme-src "."))) +(when mach + (void (putenv "MACH" mach))) + +;; Dynamic, so that environment variables are visible to +;; compile-time instantiation of `make-boot`: +(define-runtime-module-path make-boot "make-boot.rkt") +(dynamic-require make-boot #f) diff --git a/racket/src/cs/bootstrap/make-boot.rkt b/racket/src/cs/bootstrap/make-boot.rkt index 5ad15555e2..907193a02c 100644 --- a/racket/src/cs/bootstrap/make-boot.rkt +++ b/racket/src/cs/bootstrap/make-boot.rkt @@ -16,6 +16,11 @@ ;; Set `SCHEME_SRC` and `MACH` to specify the ChezScheme source ;; directory and the target machine. +(unless scheme-dir + (error "set `SCHEME_SRC` environment variable")) +(unless target-machine + (error "set `MACH` environment variable")) + ;; Writes ".boot" and ".h" files to a "boot" subdirectory of ;; `SCHEME_SRC`. diff --git a/racket/src/cs/bootstrap/primdata.rkt b/racket/src/cs/bootstrap/primdata.rkt index 0a98208207..f1cc739854 100644 --- a/racket/src/cs/bootstrap/primdata.rkt +++ b/racket/src/cs/bootstrap/primdata.rkt @@ -12,65 +12,69 @@ ;; Returns flags->bits for prim flags, `primvec` function, and `get-priminfo` function (define (get-primdata $sputprop scheme-dir) (define flags->bits + (cond + [scheme-dir + (call-with-input-file* + (build-path scheme-dir "s/cmacros.ss") + (lambda (i) + (let loop () + (define l (parameterize ([current-readtable scheme-readtable]) + (read i))) + (match l + [`(define-flags prim-mask ,specs ...) + (define bits + (for/fold ([bits #hasheq()]) ([spec (in-list specs)]) + (define (get-val v) + (if (number? v) v (hash-ref bits v))) + (match spec + [`(,name (or ,vals ...)) + (hash-set bits name (apply bitwise-ior (map get-val vals)))] + [`(,name ,val) + (hash-set bits name (get-val val))]))) + (lambda (flags) + (apply bitwise-ior (for/list ([flag (in-list flags)]) + (hash-ref bits flag))))] + [_ (loop)]))))] + [else #hasheq()])) + (define priminfos (make-hasheq)) + (when scheme-dir (call-with-input-file* - (build-path scheme-dir "s/cmacros.ss") + (build-path scheme-dir "s/primdata.ss") (lambda (i) (let loop () - (define l (parameterize ([current-readtable scheme-readtable]) + (define l (parameterize ([current-readtable #f]) (read i))) - (match l - [`(define-flags prim-mask ,specs ...) - (define bits - (for/fold ([bits #hasheq()]) ([spec (in-list specs)]) - (define (get-val v) - (if (number? v) v (hash-ref bits v))) - (match spec - [`(,name (or ,vals ...)) - (hash-set bits name (apply bitwise-ior (map get-val vals)))] - [`(,name ,val) - (hash-set bits name (get-val val))]))) - (lambda (flags) - (apply bitwise-ior (for/list ([flag (in-list flags)]) - (hash-ref bits flag))))] - [_ (loop)]))))) - (define priminfos (make-hasheq)) - (call-with-input-file* - (build-path scheme-dir "s/primdata.ss") - (lambda (i) - (let loop () - (define l (parameterize ([current-readtable #f]) - (read i))) - (unless (eof-object? l) - (match l - [`(,def-sym-flags - ([libraries ,libs ...] [flags ,group-flags ...]) - ,clauses ...) - (for ([clause (in-list clauses)]) - (match clause - [`(,id ,specs ...) - (define-values (flags sigs) - (for/fold ([flags group-flags] [sigs null]) ([spec (in-list specs)]) - (match spec - [`[sig ,sigs ...] (values flags sigs )] - [`[flags ,flags ...] (values (append flags group-flags) sigs)] - [`[feature ,features ...] (values flags sigs)]))) - (define plain-id (if (pair? id) - (string->symbol (format "~a~a" - (car id) - (cadr id))) - id)) - (define flag-bits (flags->bits flags)) - (define pr (primref plain-id flag-bits (map sig->interface sigs) sigs)) - (register-symbols plain-id) - ($sputprop plain-id '*prim2* pr) - ($sputprop plain-id '*prim3* pr) - ($sputprop plain-id '*flags* flag-bits) - (hash-set! priminfos plain-id (priminfo (if (pair? id) (cadr id) id) - libs - flag-bits - sigs - (map sig->interface sigs)))]))]) - (loop))))) + (unless (eof-object? l) + (match l + [`(,def-sym-flags + ([libraries ,libs ...] [flags ,group-flags ...]) + ,clauses ...) + (for ([clause (in-list clauses)]) + (match clause + [`(,id ,specs ...) + (define-values (flags sigs) + (for/fold ([flags group-flags] [sigs null]) ([spec (in-list specs)]) + (match spec + [`[sig ,sigs ...] (values flags sigs )] + [`[flags ,flags ...] (values (append flags group-flags) sigs)] + [`[feature ,features ...] (values flags sigs)]))) + (define plain-id (if (pair? id) + (string->symbol (format "~a~a" + (car id) + (cadr id))) + id)) + (define flag-bits (flags->bits flags)) + (define pr (primref plain-id flag-bits (map sig->interface sigs) sigs)) + (register-symbols plain-id) + ($sputprop plain-id '*prim2* pr) + ($sputprop plain-id '*prim3* pr) + ($sputprop plain-id '*flags* flag-bits) + (hash-set! priminfos plain-id (priminfo (if (pair? id) (cadr id) id) + libs + flag-bits + sigs + (map sig->interface sigs)))]))]) + (loop)))))) (values flags->bits (lambda () (list->vector (hash-keys priminfos))) (lambda (sym) (hash-ref priminfos sym #f)))) diff --git a/racket/src/cs/bootstrap/r6rs-lang.rkt b/racket/src/cs/bootstrap/r6rs-lang.rkt index dd047730c1..f80b026a4a 100644 --- a/racket/src/cs/bootstrap/r6rs-lang.rkt +++ b/racket/src/cs/bootstrap/r6rs-lang.rkt @@ -760,7 +760,7 @@ (define (set-car! p v) (unsafe-set-mcar! p v)) (define (set-cdr! p v) (unsafe-set-mcdr! p v)) -(define (fixnum-width) fixnum-bits) +(define (fixnum-width) (or fixnum-bits 63)) (define low-fixnum (- (expt 2 (sub1 (fixnum-width))))) (define high-fixnum (sub1 (expt 2 (sub1 (fixnum-width))))) diff --git a/racket/src/thread/future.rkt b/racket/src/thread/future.rkt index ab24f1210d..d2d1327de6 100644 --- a/racket/src/thread/future.rkt +++ b/racket/src/thread/future.rkt @@ -333,7 +333,7 @@ (void)) (define (expire future worker) - (lambda (new-eng) + (lambda (new-eng timeout?) (set-future*-engine! future new-eng) (cond [(positive? (current-atomic))