You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
253 lines
7.7 KiB
Scheme
253 lines
7.7 KiB
Scheme
;;; 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)
|
|
)
|