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