suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

make Chez Scheme bootstrap work as a "cs-bootstrap" package

Browse Source
This commit is contained in:
Matthew Flatt 2019-04-25 10:09:26 -06:00
parent 1624193210
commit 20672cd60a
11 changed files with 140 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -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

7
pkgs/racket-doc/pkg/scribblings/dirs-catalog.scrbl
View File

@ -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.}]}

16
racket/collects/pkg/dirs-catalog.rkt
View File

@ -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)

15
racket/src/cs/bootstrap/config.rkt
View File

@ -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)

19
racket/src/cs/bootstrap/constant.rkt
View File

@ -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

10
racket/src/cs/bootstrap/info.rkt Normal file
View File

@ -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))

29
racket/src/cs/bootstrap/main.rkt Normal file
View File

@ -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)

5
racket/src/cs/bootstrap/make-boot.rkt
View File

@ -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`.

114
racket/src/cs/bootstrap/primdata.rkt
View File

@ -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))))

2
racket/src/cs/bootstrap/r6rs-lang.rkt
View File

@ -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)))))

2
racket/src/thread/future.rkt
View File

@ -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))