1;;; front.ss
2;;; Copyright 1984-2017 Cisco Systems, Inc.
3;;;
4;;; Licensed under the Apache License, Version 2.0 (the "License");
5;;; you may not use this file except in compliance with the License.
6;;; You may obtain a copy of the License at
7;;;
8;;; http://www.apache.org/licenses/LICENSE-2.0
9;;;
10;;; Unless required by applicable law or agreed to in writing, software
11;;; distributed under the License is distributed on an "AS IS" BASIS,
12;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13;;; See the License for the specific language governing permissions and
14;;; limitations under the License.
15
16(begin
17(define-who make-parameter
18  (case-lambda
19    [(init guard) (#2%make-parameter init guard)]
20    [(v) (#2%make-parameter v)]))
21
22(when-feature pthreads
23(let ()
24  (define allocate-thread-parameter
25    (let ()
26      (define free-list '())  ; list of pairs w/ index as car
27      (define index-guardian (make-guardian))
28      (lambda (initval)
29        (with-tc-mutex
30          (let ([index
31                 (or (index-guardian)
32                     (and (not (null? free-list))
33                          (let ([index (car free-list)])
34                            (set! free-list (cdr free-list))
35                            index))
36                     (let* ([n (vector-length ($tc-field 'parameters ($tc)))]
37                            [m (fx* (fx+ n 1) 2)])
38                       (for-each
39                         (lambda (thread)
40                           (let ([tc ($thread-tc thread)])
41                             (let ([old ($tc-field 'parameters tc)]
42                                   [new (make-vector m)])
43                               (do ([i (fx- n 1) (fx- i 1)])
44                                   ((fx< i 0))
45                                   (vector-set! new i (vector-ref old i)))
46                               ($tc-field 'parameters tc new))))
47                         ($thread-list))
48                       (set! free-list
49                         (do ([i (fx- m 1) (fx- i 1)]
50                              [ls free-list (cons (list i) ls)])
51                             ((fx= i n) ls)))
52                       (list n)))])
53            (let loop ()
54              (let ([index (index-guardian)])
55                (when index
56                  (for-each
57                    (lambda (thread)
58                      (vector-set!
59                        ($tc-field 'parameters ($thread-tc thread))
60                        (car index)
61                        0))
62                    ($thread-list))
63                  (set! free-list (cons index free-list))
64                  (loop))))
65            (for-each
66              (lambda (thread)
67                (vector-set!
68                  ($tc-field 'parameters ($thread-tc thread))
69                  (car index)
70                  initval))
71              ($thread-list))
72            (index-guardian index)
73            index)))))
74  (define set-thread-parameter!
75    (lambda (index value)
76      (with-tc-mutex
77        (vector-set! ($tc-field 'parameters ($tc)) (car index) value))))
78  (set-who! make-thread-parameter
79    (case-lambda
80      [(init guard)
81       (unless (procedure? guard) ($oops who "~s is not a procedure" guard))
82       (let ([index (allocate-thread-parameter (guard init))])
83         (case-lambda
84           [() (vector-ref ($tc-field 'parameters ($tc)) (car index))]
85           [(u) (set-thread-parameter! index (guard u))]))]
86      [(init)
87       (let ([index (allocate-thread-parameter init)])
88         (case-lambda
89           [() (vector-ref ($tc-field 'parameters ($tc)) (car index))]
90           [(u) (set-thread-parameter! index u)]))]))
91  (set! $allocate-thread-parameter allocate-thread-parameter)
92  (set! $set-thread-parameter! set-thread-parameter!))
93)
94
95(define case-sensitive ($make-thread-parameter #t (lambda (x) (and x #t))))
96
97(define compile-interpret-simple ($make-thread-parameter #t (lambda (x) (and x #t))))
98
99(define generate-interrupt-trap ($make-thread-parameter #t (lambda (x) (and x #t))))
100
101(define generate-allocation-counts ($make-thread-parameter #f (lambda (x) (and x #t))))
102
103(define generate-instruction-counts ($make-thread-parameter #f (lambda (x) (and x #t))))
104
105(define enable-cross-library-optimization ($make-thread-parameter #t (lambda (x) (and x #t))))
106
107(define enable-arithmetic-left-associative ($make-thread-parameter #f (lambda (x) (and x #t))))
108
109(define enable-unsafe-application ($make-thread-parameter #f (lambda (x) (and x #t))))
110
111(define enable-unsafe-variable-reference ($make-thread-parameter #f (lambda (x) (and x #t))))
112
113(define-who current-generate-id
114  ($make-thread-parameter
115   (lambda (sym)
116     (unless (symbol? sym) ($oops 'default-generate-id "~s is not a symbol" sym))
117     (gensym (symbol->string sym)))
118   (lambda (p)
119     (unless (procedure? p) ($oops who "~s is not a procedure" p))
120     p)))
121
122(define enable-type-recovery ($make-thread-parameter #t (lambda (x) (and x #t))))
123
124(define enable-error-source-expression ($make-thread-parameter #t (lambda (x) (and x #t))))
125
126(define machine-type
127  (lambda ()
128    (constant machine-type-name)))
129
130(define-who $fasl-target ($make-thread-parameter #f))
131
132;;; package stubs are defined here in case we exclude certain packages
133(eval-when (compile)
134(define-syntax package-stub
135  (lambda (x)
136    (syntax-case x ()
137      [(_ name msg)
138       (identifier? #'name)
139       #'(package-stub (name name) msg)]
140      [(_ (name pub-name) msg)
141       #'(define name (lambda args ($oops 'pub-name msg)))])))
142
143(define-syntax package-stubs
144  (lambda (x)
145    (syntax-case x ()
146      [(_ pkg name ...)
147       (with-syntax ([msg (format "~a package is not loaded" (datum pkg))])
148         #'(begin (package-stub name msg) ...))])))
149)
150
151(package-stubs cafe
152  waiter-prompt-and-read
153  waiter-write
154  waiter-prompt-string
155  new-cafe)
156(package-stubs compile
157  ($clear-dynamic-closure-counts compile)
158  ($c-make-closure compile)
159  ($c-make-code compile)
160  compile
161  ($compile-backend compile)
162  compile-file
163  ($compile-host-library compile)
164  compile-library
165  compile-port
166  compile-program
167  compile-script
168  compile-to-file
169  compile-to-port
170  compile-whole-library
171  compile-whole-program
172  ($dynamic-closure-counts compile)
173  ($lift-closures compile)
174  ($loop-unroll-limit compile)
175  make-boot-file
176  ($make-boot-file make-boot-file)
177  make-boot-header
178  ($make-boot-header make-boot-header)
179  maybe-compile-file
180  maybe-compile-library
181  maybe-compile-program
182  ($np-boot-code compile)
183  ($np-compile compile)
184  ($np-get-timers compile)
185  ($np-last-pass compile)
186  ($np-reset-timers! compile)
187  ($np-tracer compile)
188  ($optimize-closures compile)
189  ($track-dynamic-closure-counts compile)
190  ($track-static-closure-counts compile))
191(package-stubs fasl
192  ($fasl-bld-graph fasl-write)
193  ($fasl-enter fasl-write)
194  ($fasl-start fasl-write)
195  ($fasl-table fasl-write)
196  ($fasl-out fasl-write)
197  ($fasl-wrf-graph fasl-write)
198  fasl-write
199  fasl-file)
200(package-stubs inspect
201  inspect
202  inspect/object)
203(package-stubs interpret
204  interpret)
205(package-stubs pretty-print
206  pretty-format
207  pretty-line-length
208  pretty-one-line-limit
209  pretty-initial-indent
210  pretty-standard-indent
211  pretty-maximum-lines
212  pretty-print
213  pretty-file)
214(package-stubs profile
215  profile-clear
216  profile-dump)
217(package-stubs sc-expand
218  sc-expand
219  ($syntax-dispatch sc-expand)
220  syntax-error
221  literal-identifier=?
222  bound-identifier=?
223  free-identifier=?
224  identifier?
225  generate-temporaries
226  syntax->datum
227  datum->syntax)
228(package-stubs trace
229  trace-output-port
230  trace-print
231  ($trace trace)
232  ($untrace untrace)
233  ($trace-closure trace))
234(package-stubs compiler-support
235  $cp0
236  $cpvalid
237  $cptypes
238  $cpletrec
239  $cpcheck)
240(package-stubs syntax-support
241  $uncprep)
242
243(define current-eval
244  ($make-thread-parameter
245    (lambda args ($oops 'eval "no current evaluator"))
246    (lambda (x)
247       (unless (procedure? x)
248          ($oops 'current-eval "~s is not a procedure" x))
249       x)))
250
251(define current-expand
252  ($make-thread-parameter
253    (lambda args ($oops 'expand "no current expander"))
254    (lambda (x)
255      (unless (procedure? x)
256        ($oops 'current-expand "~s is not a procedure" x))
257      x)))
258
259(define eval
260  (case-lambda
261    [(x) ((current-eval) x)]
262    [(x env-spec) ((current-eval) x env-spec)]))
263
264(define expand
265  (case-lambda
266    [(x) ((current-expand) x)]
267    [(x env-spec) ((current-expand) x env-spec)]
268    [(x env-spec records?) ((current-expand) x env-spec records?)]
269    [(x env-spec records? compiling-a-file) ((current-expand) x env-spec records? compiling-a-file)]
270    [(x env-spec records? compiling-a-file outfn) ((current-expand) x env-spec records? compiling-a-file outfn)]))
271
272(define $compiler-is-loaded? #f)
273)
274