fix: README -> README.md
This commit is contained in:
tmtt
parent
43e68af625
commit
99b0a6292c
756 changed files with 323753 additions and 71 deletions
252
ta6ob/s/front.ss
Normal file
252
ta6ob/s/front.ss
Normal file
|
|
@ -0,0 +1,252 @@
|
|||
;;; front.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(begin
|
||||
(define-who make-parameter
|
||||
(case-lambda
|
||||
[(init guard) (#2%make-parameter init guard)]
|
||||
[(v) (#2%make-parameter v)]))
|
||||
|
||||
(when-feature pthreads
|
||||
(let ()
|
||||
(define allocate-thread-parameter
|
||||
(let ()
|
||||
(define free-list '()) ; list of pairs w/ index as car
|
||||
(define index-guardian (make-guardian))
|
||||
(lambda (initval)
|
||||
(with-tc-mutex
|
||||
(let ([index
|
||||
(or (index-guardian)
|
||||
(and (not (null? free-list))
|
||||
(let ([index (car free-list)])
|
||||
(set! free-list (cdr free-list))
|
||||
index))
|
||||
(let* ([n (vector-length ($tc-field 'parameters ($tc)))]
|
||||
[m (fx* (fx+ n 1) 2)])
|
||||
(for-each
|
||||
(lambda (thread)
|
||||
(let ([tc ($thread-tc thread)])
|
||||
(let ([old ($tc-field 'parameters tc)]
|
||||
[new (make-vector m)])
|
||||
(do ([i (fx- n 1) (fx- i 1)])
|
||||
((fx< i 0))
|
||||
(vector-set! new i (vector-ref old i)))
|
||||
($tc-field 'parameters tc new))))
|
||||
($thread-list))
|
||||
(set! free-list
|
||||
(do ([i (fx- m 1) (fx- i 1)]
|
||||
[ls free-list (cons (list i) ls)])
|
||||
((fx= i n) ls)))
|
||||
(list n)))])
|
||||
(let loop ()
|
||||
(let ([index (index-guardian)])
|
||||
(when index
|
||||
(for-each
|
||||
(lambda (thread)
|
||||
(vector-set!
|
||||
($tc-field 'parameters ($thread-tc thread))
|
||||
(car index)
|
||||
0))
|
||||
($thread-list))
|
||||
(set! free-list (cons index free-list))
|
||||
(loop))))
|
||||
(for-each
|
||||
(lambda (thread)
|
||||
(vector-set!
|
||||
($tc-field 'parameters ($thread-tc thread))
|
||||
(car index)
|
||||
initval))
|
||||
($thread-list))
|
||||
(index-guardian index)
|
||||
index)))))
|
||||
(define set-thread-parameter!
|
||||
(lambda (index value)
|
||||
(with-tc-mutex
|
||||
(vector-set! ($tc-field 'parameters ($tc)) (car index) value))))
|
||||
(set-who! make-thread-parameter
|
||||
(case-lambda
|
||||
[(init guard)
|
||||
(unless (procedure? guard) ($oops who "~s is not a procedure" guard))
|
||||
(let ([index (allocate-thread-parameter (guard init))])
|
||||
(case-lambda
|
||||
[() (vector-ref ($tc-field 'parameters ($tc)) (car index))]
|
||||
[(u) (set-thread-parameter! index (guard u))]))]
|
||||
[(init)
|
||||
(let ([index (allocate-thread-parameter init)])
|
||||
(case-lambda
|
||||
[() (vector-ref ($tc-field 'parameters ($tc)) (car index))]
|
||||
[(u) (set-thread-parameter! index u)]))]))
|
||||
(set! $allocate-thread-parameter allocate-thread-parameter)
|
||||
(set! $set-thread-parameter! set-thread-parameter!))
|
||||
)
|
||||
|
||||
(define case-sensitive ($make-thread-parameter #t (lambda (x) (and x #t))))
|
||||
|
||||
(define compile-interpret-simple ($make-thread-parameter #t (lambda (x) (and x #t))))
|
||||
|
||||
(define generate-interrupt-trap ($make-thread-parameter #t (lambda (x) (and x #t))))
|
||||
|
||||
(define generate-allocation-counts ($make-thread-parameter #f (lambda (x) (and x #t))))
|
||||
|
||||
(define generate-instruction-counts ($make-thread-parameter #f (lambda (x) (and x #t))))
|
||||
|
||||
(define enable-cross-library-optimization ($make-thread-parameter #t (lambda (x) (and x #t))))
|
||||
|
||||
(define machine-type
|
||||
(lambda ()
|
||||
(constant machine-type-name)))
|
||||
|
||||
(define-who $fasl-target ($make-thread-parameter #f))
|
||||
|
||||
;;; package stubs are defined here in case we exclude certain packages
|
||||
(eval-when (compile)
|
||||
(define-syntax package-stub
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ name msg)
|
||||
(identifier? #'name)
|
||||
#'(package-stub (name name) msg)]
|
||||
[(_ (name pub-name) msg)
|
||||
#'(define name (lambda args ($oops 'pub-name msg)))])))
|
||||
|
||||
(define-syntax package-stubs
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ pkg name ...)
|
||||
(with-syntax ([msg (format "~a package is not loaded" (datum pkg))])
|
||||
#'(begin (package-stub name msg) ...))])))
|
||||
)
|
||||
|
||||
(package-stubs cafe
|
||||
waiter-prompt-and-read
|
||||
waiter-write
|
||||
waiter-prompt-string
|
||||
new-cafe)
|
||||
(package-stubs compile
|
||||
($clear-dynamic-closure-counts compile)
|
||||
($c-make-closure compile)
|
||||
($c-make-code compile)
|
||||
compile
|
||||
($compile-backend compile)
|
||||
compile-file
|
||||
($compile-host-library compile)
|
||||
compile-library
|
||||
compile-port
|
||||
compile-program
|
||||
compile-script
|
||||
compile-to-file
|
||||
compile-to-port
|
||||
compile-whole-library
|
||||
compile-whole-program
|
||||
($dynamic-closure-counts compile)
|
||||
($loop-unroll-limit compile)
|
||||
make-boot-file
|
||||
($make-boot-file make-boot-file)
|
||||
make-boot-header
|
||||
($make-boot-header make-boot-header)
|
||||
maybe-compile-file
|
||||
maybe-compile-library
|
||||
maybe-compile-program
|
||||
($np-boot-code compile)
|
||||
($np-compile compile)
|
||||
($np-get-timers compile)
|
||||
($np-last-pass compile)
|
||||
($np-reset-timers! compile)
|
||||
($np-tracer compile)
|
||||
($optimize-closures compile)
|
||||
($track-dynamic-closure-counts compile)
|
||||
($track-static-closure-counts compile))
|
||||
(package-stubs fasl
|
||||
($fasl-bld-graph fasl-write)
|
||||
($fasl-enter fasl-write)
|
||||
($fasl-start fasl-write)
|
||||
($fasl-table fasl-write)
|
||||
($fasl-out fasl-write)
|
||||
($fasl-wrf-graph fasl-write)
|
||||
fasl-write
|
||||
fasl-file)
|
||||
(package-stubs inspect
|
||||
inspect
|
||||
inspect/object)
|
||||
(package-stubs interpret
|
||||
interpret)
|
||||
(package-stubs pretty-print
|
||||
pretty-format
|
||||
pretty-line-length
|
||||
pretty-one-line-limit
|
||||
pretty-initial-indent
|
||||
pretty-standard-indent
|
||||
pretty-maximum-lines
|
||||
pretty-print
|
||||
pretty-file)
|
||||
(package-stubs profile
|
||||
profile-clear
|
||||
profile-dump)
|
||||
(package-stubs sc-expand
|
||||
sc-expand
|
||||
($syntax-dispatch sc-expand)
|
||||
syntax-error
|
||||
literal-identifier=?
|
||||
bound-identifier=?
|
||||
free-identifier=?
|
||||
identifier?
|
||||
generate-temporaries
|
||||
syntax->datum
|
||||
datum->syntax)
|
||||
(package-stubs trace
|
||||
trace-output-port
|
||||
trace-print
|
||||
($trace trace)
|
||||
($untrace untrace)
|
||||
($trace-closure trace))
|
||||
(package-stubs compiler-support
|
||||
$cp0
|
||||
$cpvalid
|
||||
$cpletrec
|
||||
$cpcheck)
|
||||
(package-stubs syntax-support
|
||||
$uncprep)
|
||||
|
||||
(define current-eval
|
||||
($make-thread-parameter
|
||||
(lambda args ($oops 'eval "no current evaluator"))
|
||||
(lambda (x)
|
||||
(unless (procedure? x)
|
||||
($oops 'current-eval "~s is not a procedure" x))
|
||||
x)))
|
||||
|
||||
(define current-expand
|
||||
($make-thread-parameter
|
||||
(lambda args ($oops 'expand "no current expander"))
|
||||
(lambda (x)
|
||||
(unless (procedure? x)
|
||||
($oops 'current-expand "~s is not a procedure" x))
|
||||
x)))
|
||||
|
||||
(define eval
|
||||
(case-lambda
|
||||
[(x) ((current-eval) x)]
|
||||
[(x env-spec) ((current-eval) x env-spec)]))
|
||||
|
||||
(define expand
|
||||
(case-lambda
|
||||
[(x) ((current-expand) x)]
|
||||
[(x env-spec) ((current-expand) x env-spec)]
|
||||
[(x env-spec records?) ((current-expand) x env-spec records?)]
|
||||
[(x env-spec records? compiling-a-file) ((current-expand) x env-spec records? compiling-a-file)]
|
||||
[(x env-spec records? compiling-a-file outfn) ((current-expand) x env-spec records? compiling-a-file outfn)]))
|
||||
|
||||
(define $compiler-is-loaded? #f)
|
||||
)
|
||||
Reference in a new issue