1;;; mkheader.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;;; requires cmacros.ss 17(disable-unbound-warning 18 mkscheme.h 19 mkequates.h 20) 21 22(define mkscheme.h) 23(define mkequates.h) 24(let () 25 (define op) 26 (define-syntax pr 27 (syntax-rules () 28 ((_ fmt arg ...) (fprintf op fmt arg ...)))) 29 (define nl 30 (lambda () 31 (newline op))) 32 (define-syntax $ 33 (syntax-rules () 34 ((_ x) (constant x)))) 35 (define-syntax comment 36 (syntax-rules () 37 ((_ fmt arg ...) (pr "/* ~a */~%" (format fmt arg ...))))) 38 (define sanitize 39 (lambda (x) 40 (list->string 41 (fold-right (lambda (x rest) 42 (case x 43 [(#\-) (cons #\_ rest)] 44 [(#\+) (cons #\_ rest)] 45 [(#\?) (cons #\p rest)] 46 [(#\>) rest] 47 [(#\*) (cons #\s rest)] 48 [(#\=) (cons* #\e #\q #\l rest)] 49 [(#\?) (cons #\p rest)] 50 [else (cons x rest)])) 51 '() 52 (string->list (symbol->string x)))))) 53 (define sanitize-type 54 (lambda (x) 55 (list->string 56 (map (lambda (x) 57 (case x 58 [(#\-) #\_] 59 [else x])) 60 (string->list (symbol->string x)))))) 61 (define def 62 (case-lambda 63 [(lhs rhs) (pr "#define ~a ~a~%" lhs rhs)] 64 [(name args rhs) (pr "#define ~a~a ~a~%" name args rhs)])) 65 (define export 66 (lambda (tresult name targs) 67 (pr "EXPORT ~a ~a PROTO(~a);~%" tresult name targs))) 68 (define &ref 69 (lambda (cast x disp) 70 (format "(~aTO_VOIDP((uptr)(~a)~:[+~;-~]~d))" cast x (fx< disp 0) (abs disp)))) 71 (define ref 72 (lambda (cast x disp) 73 (format "(*~a)" (&ref cast x disp)))) 74 (define defref-help 75 (lambda (ref name struct field) 76 (cond 77 [(assq field (getprop struct '*fields* '())) => 78 (lambda (a) 79 (apply 80 (lambda (field type disp len) 81 (putprop (string->symbol (format "~a-~a" struct field)) '*c-ref* (if len 82 (cons name len) 83 name)) 84 (if len 85 (def (format "~s(x,i)" name) 86 (format (if (eq? ref &ref) "(~a+i)" "(~a[i])") 87 (&ref (format "(~a *)" (sanitize-type type)) "x" disp))) 88 (def (format "~s(x)" name) 89 (ref (format "(~a *)" (sanitize-type type)) "x" disp)))) 90 a))] 91 [else ($oops 'defref-help "undefined field ~s-~s" struct field)]))) 92 (define defset-help 93 (lambda (name struct field) 94 (cond 95 [(assq field (getprop struct '*fields* '())) => 96 (lambda (a) 97 (apply 98 (lambda (field type disp len) 99 (unless (eq? type 'ptr) 100 ($oops 'defset-help "non-ptr type ~s" type)) 101 (if len 102 (def (format "~s(x,i,y)" name) 103 (format "DIRTYSET((~a+i),(y))" 104 (&ref "(ptr *)" "x" disp))) 105 (def (format "~s(x,y)" name) 106 (format "DIRTYSET(~a,(y))" 107 (&ref "(ptr *)" "x" disp))))) 108 a))] 109 [else ($oops 'defset-help "undefined field ~s-~s" struct field)]))) 110 (define-syntax defref 111 (syntax-rules () 112 [(_ name struct field) 113 (defref-help ref 'name 'struct 'field)])) 114 (define-syntax definit ; presently same as defref 115 (syntax-rules () 116 [(_ name struct field) 117 (defref name struct field)])) 118 (define-syntax defset 119 (syntax-rules () 120 [(_ name struct field) 121 (defset-help 'name 'struct 'field)])) 122 (define access-help 123 (lambda (arg idx struct field) 124 (cond 125 [(assq field (getprop struct '*fields* '())) => 126 (lambda (a) 127 (apply 128 (lambda (field type disp len) 129 (if (not idx) 130 (if (not len) 131 (ref (format "(~a *)" (sanitize-type type)) arg disp) 132 ($oops 'access "no idx provided for array field ~s-~s" struct field)) 133 (if len 134 (format "(~a[~a])" (&ref (format "(~a *)" (sanitize-type type)) arg disp) idx) 135 ($oops 'access "no idx provided for array field ~s-~s" struct field)))) 136 a))] 137 [else ($oops 'access "undefined field ~s-~s" struct field)]))) 138 (define-syntax access 139 (syntax-rules () 140 [(_ arg struct field) 141 (access-help arg #f 'struct 'field)] 142 [(_ arg idx struct field) 143 (access-help arg idx 'struct 'field)])) 144 (define typep 145 (lambda (x mask tag) 146 (if (= mask (constant byte-constant-mask)) 147 (format "((uptr)(~a)==0x~x)" x tag) 148 (format "(((uptr)(~a)&0x~x)==0x~x)" x mask tag)))) 149 (define deftypep 150 (lambda (name mask tag) 151 (def name "(x)" (typep "x" mask tag)))) 152 (define deftotypep 153 (let ((type-disp (- ($ typemod) ($ type-typed-object)))) 154 (lambda (name mask tag) 155 (def name "(x)" 156 (format "(~a &&\\~% ~a)" 157 (typep "x" ($ mask-typed-object) ($ type-typed-object)) 158 (typep (ref "(ptr *)" "x" type-disp) mask tag)))))) 159 (define scheme-version ; adapted from 7.ss 160 (let ([n (constant scheme-version)]) 161 (if (= (logand n 255) 0) 162 (if (= (logand n 255) 0) 163 (format "~d.~d" 164 (ash n -24) 165 (logand (ash n -16) 255)) 166 (format "~d.~d.~d" 167 (ash n -24) 168 (logand (ash n -16) 255) 169 (logand (ash n -8) 255))) 170 (format "~d.~d.~d.~d" 171 (ash n -24) 172 (logand (ash n -16) 255) 173 (logand (ash n -8) 255) 174 (logand n 255))))) 175 176 (set-who! mkscheme.h 177 (lambda (ofn target-machine) 178 (fluid-let ([op (if (output-port? ofn) 179 ofn 180 (open-output-file ofn 'replace))]) 181 (comment "scheme.h for Chez Scheme Version ~a (~a)" scheme-version target-machine) 182 183 (nl) 184 (comment "Do not edit this file. It is automatically generated and") 185 (comment "specifically tailored to the version of Chez Scheme named") 186 (comment "above. Always be certain that you have the correct scheme.h") 187 (comment "for the version of Chez Scheme you are using.") 188 189 (nl) 190 (comment "Warning: Some macros may evaluate arguments more than once.") 191 192 (constant-case architecture 193 [(pb) 194 (nl) 195 (pr "#ifndef _LARGEFILE64_SOURCE\n") 196 (pr "# define _LARGEFILE64_SOURCE\n") ; needed on some 32-bit platforms before <stdint.h> 197 (pr "#endif\n") 198 (pr "#include <stdint.h>\n")] 199 [else (void)]) 200 201 (nl) (comment "Enable function prototypes by default.") 202 (pr "#ifndef PROTO~%#define PROTO(x) x~%#endif~%") 203 204 (nl) (comment "Specify declaration of exports.") 205 (pr "#ifdef _WIN32~%") 206 (pr "# if __cplusplus~%") 207 (pr "# ifdef SCHEME_IMPORT~%") 208 (pr "# define EXPORT extern \"C\" __declspec (dllimport)~%") 209 (pr "# elif SCHEME_STATIC~%") 210 (pr "# define EXPORT extern \"C\"~%") 211 (pr "# else~%") 212 (pr "# define EXPORT extern \"C\" __declspec (dllexport)~%") 213 (pr "# endif~%") 214 (pr "# else~%") 215 (pr "# ifdef SCHEME_IMPORT~%") 216 (pr "# define EXPORT extern __declspec (dllimport)~%") 217 (pr "# elif SCHEME_STATIC~%") 218 (pr "# define EXPORT extern~%") 219 (pr "# else~%") 220 (pr "# define EXPORT extern __declspec (dllexport)~%") 221 (pr "# endif~%") 222 (pr "# endif~%") 223 (pr "#else~%") 224 (pr "# if __cplusplus~%") 225 (pr "# define EXPORT extern \"C\"~%") 226 (pr "# else~%") 227 (pr "# define EXPORT extern~%") 228 (pr "# endif~%") 229 (pr "#endif~%") 230 231 (nl) (comment "Chez Scheme Version and machine type") 232 (pr "#define VERSION \"~a\"~%" scheme-version) 233 (pr "#define MACHINE_TYPE \"~a\"~%" target-machine) 234 235 (nl) 236 (comment "All Scheme objects are of type ptr. Type iptr and") 237 (comment "uptr are signed and unsigned ints of the same size") 238 (comment "as a ptr") 239 (pr "typedef ~a ptr;~%" (constant typedef-ptr)) 240 (pr "typedef ~a iptr;~%" (constant typedef-iptr)) 241 (pr "typedef ~a uptr;~%" (constant typedef-uptr)) 242 (pr "typedef ptr xptr;~%") 243 244 (nl) 245 (comment "The `uptr` and `ptr` types are the same width, but `ptr`") 246 (comment "can be either an integer type or a pointer type; it may") 247 (comment "be larger than a pointer type.") 248 (comment "Use `TO_VOIDP` to get from the `uptr`/`ptr` world to the") 249 (comment "C pointer worlds, and use `TO_PTR` to go the other way.") 250 (pr "#ifdef PORTABLE_BYTECODE~%") 251 (pr "# define TO_VOIDP(p) ((void *)(intptr_t)(p))~%") 252 (pr "# define TO_PTR(p) ((ptr)(intptr_t)(p))~%") 253 (pr "#else~%") 254 (pr "# define TO_VOIDP(p) ((void *)(p))~%") 255 (pr "# define TO_PTR(p) ((ptr)(p))~%") 256 (pr "#endif~%") 257 258 (nl) 259 (comment "String elements are 32-bit tagged char objects") 260 (pr "typedef ~a string_char;~%" (constant typedef-string-char)) 261 262 (nl) 263 (comment "Bytevector elements are 8-bit unsigned \"octets\"") 264 (pr "typedef unsigned char octet;~%") 265 266 (nl) (comment "Type predicates") 267 (deftypep "Sfixnump" ($ mask-fixnum) ($ type-fixnum)) 268 (deftypep "Scharp" ($ mask-char) ($ type-char)) 269 (deftypep "Snullp" ($ mask-nil) ($ snil)) 270 (deftypep "Seof_objectp" ($ mask-eof) ($ seof)) 271 (deftypep "Sbwp_objectp" ($ mask-bwp) ($ sbwp)) 272 (deftypep "Sbooleanp" ($ mask-boolean) ($ type-boolean)) 273 274 (deftypep "Spairp" ($ mask-pair) ($ type-pair)) 275 (deftypep "Ssymbolp" ($ mask-symbol) ($ type-symbol)) 276 (deftypep "Sprocedurep" ($ mask-closure) ($ type-closure)) 277 (deftypep "Sflonump" ($ mask-flonum) ($ type-flonum)) 278 279 (deftotypep "Svectorp" ($ mask-vector) ($ type-vector)) 280 (deftotypep "Sfxvectorp" ($ mask-fxvector) ($ type-fxvector)) 281 (deftotypep "Sflvectorp" ($ mask-flvector) ($ type-flvector)) 282 (deftotypep "Sbytevectorp" ($ mask-bytevector) ($ type-bytevector)) 283 (deftotypep "Sstringp" ($ mask-string) ($ type-string)) 284 (deftotypep "Sstencil_vectorp" ($ mask-stencil-vector) ($ type-stencil-vector)) 285 (deftotypep "Sbignump" ($ mask-bignum) ($ type-bignum)) 286 (deftotypep "Sboxp" ($ mask-box) ($ type-box)) 287 (deftotypep "Sinexactnump" ($ mask-inexactnum) ($ type-inexactnum)) 288 (deftotypep "Sexactnump" ($ mask-exactnum) ($ type-exactnum)) 289 (deftotypep "Sratnump" ($ mask-ratnum) ($ type-ratnum)) 290 291 (deftotypep "Sinputportp" ($ mask-input-port) ($ type-input-port)) 292 (deftotypep "Soutputportp" ($ mask-output-port) ($ type-output-port)) 293 (deftotypep "Srecordp" ($ mask-record) ($ type-record)) 294 295 (nl) (comment "Accessors") 296 (def "Sfixnum_value(x)" (format "((iptr)(x)/~d)" ($ fixnum-factor))) 297 (def "Schar_value(x)" (format "((string_char)((uptr)(x)>>~d))" ($ char-data-offset))) 298 (def "Sboolean_value(x)" "((x) != Sfalse)") 299 300 (defref Scar pair car) 301 (defref Scdr pair cdr) 302 303 (defref Sflonum_value flonum data) 304 305 (def "Svector_length(x)" 306 (format "((iptr)((uptr)~a>>~d))" 307 (access "x" vector type) 308 ($ vector-length-offset))) 309 (defref Svector_ref vector data) 310 311 (def "Sfxvector_length(x)" 312 (format "((iptr)((uptr)~a>>~d))" 313 (access "x" fxvector type) 314 ($ fxvector-length-offset))) 315 (defref Sfxvector_ref fxvector data) 316 317 (def "Sflvector_length(x)" 318 (format "((iptr)((uptr)~a>>~d))" 319 (access "x" flvector type) 320 ($ flvector-length-offset))) 321 (defref Sflvector_ref flvector data) 322 323 (def "Sbytevector_length(x)" 324 (format "((iptr)((uptr)~a>>~d))" 325 (access "x" bytevector type) 326 ($ bytevector-length-offset))) 327 (defref Sbytevector_u8_ref bytevector data) 328 (comment "Warning: Sbytevector_data(x) returns a pointer into x.") 329 (def "Sbytevector_data(x)" "&Sbytevector_u8_ref(x,0)") 330 331 (def "Sstring_length(x)" 332 (format "((iptr)((uptr)~a>>~d))" 333 (access "x" string type) 334 ($ string-length-offset))) 335 (def "Sstring_ref(x,i)" 336 (format "Schar_value~a" (access "x" "i" string data))) 337 338 (defref Sunbox box ref) 339 340 (def "Sstencil_vector_length(x)" 341 (format "Spopcount(((uptr)~a)>>~d)" 342 (access "x" stencil-vector type) 343 ($ stencil-vector-mask-offset))) 344 (defref Sstencil_vector_ref stencil-vector data) 345 346 (export "iptr" "Sinteger_value" "(ptr)") 347 (def "Sunsigned_value(x)" "(uptr)Sinteger_value(x)") 348 (export (constant typedef-i32) "Sinteger32_value" "(ptr)") 349 (def "Sunsigned32_value(x)" (format "(~a)Sinteger32_value(x)" (constant typedef-u32))) 350 (export (constant typedef-i64) "Sinteger64_value" "(ptr)") 351 (def "Sunsigned64_value(x)" (format "(~a)Sinteger64_value(x)" (constant typedef-u64))) 352 353 (nl) (comment "Mutators") 354 (export "void" "Sset_box" "(ptr, ptr)") 355 (export "void" "Sset_car" "(ptr, ptr)") 356 (export "void" "Sset_cdr" "(ptr, ptr)") 357 (def "Sstring_set(x,i,c)" 358 (format "((void)(~a = (string_char)(uptr)Schar(c)))" 359 (access "x" "i" string data))) 360 (def "Sfxvector_set(x,i,n)" "((void)(Sfxvector_ref(x,i) = (n)))") 361 (def "Sflvector_set(x,i,n)" "((void)(Sflvector_ref(x,i) = (n)))") 362 (def "Sbytevector_u8_set(x,i,n)" "((void)(Sbytevector_u8_ref(x,i) = (n)))") 363 (export "void" "Svector_set" "(ptr, iptr, ptr)") 364 365 (nl) (comment "Constructors") 366 (def "Sfixnum(x)" (format "((ptr)(uptr)((x)*~d))" ($ fixnum-factor))) 367 (def "Schar(x)" 368 (format "((ptr)(uptr)((x)<<~d|0x~x))" 369 ($ char-data-offset) 370 ($ type-char))) 371 (def "Snil" (format "((ptr)0x~x)" ($ snil))) 372 (def "Strue" (format "((ptr)0x~x)" ($ strue))) 373 (def "Sfalse" (format "((ptr)0x~x)" ($ sfalse))) 374 (def "Sboolean(x)" "((x)?Strue:Sfalse)") 375 (def "Sbwp_object" (format "((ptr)0x~x)" ($ sbwp))) 376 (def "Seof_object" (format "((ptr)0x~x)" ($ seof))) 377 (def "Svoid" (format "((ptr)0x~x)" ($ svoid))) 378 379 (export "ptr" "Scons" "(ptr, ptr)") 380 (export "ptr" "Sstring_to_symbol" "(const char *)") 381 (export "ptr" "Ssymbol_to_string" "(ptr)") 382 (export "ptr" "Sflonum" "(double)") 383 (export "ptr" "Smake_vector" "(iptr, ptr)") 384 (export "ptr" "Smake_fxvector" "(iptr, ptr)") 385 (export "ptr" "Smake_flvector" "(iptr, ptr)") 386 (export "ptr" "Smake_bytevector" "(iptr, int)") 387 (export "ptr" "Smake_string" "(iptr, int)") 388 (export "ptr" "Smake_uninitialized_string" "(iptr)") 389 (export "ptr" "Sstring" "(const char *)") 390 (export "ptr" "Sstring_of_length" "(const char *, iptr)") 391 (export "ptr" "Sstring_utf8" "(const char*, iptr)") 392 (export "ptr" "Sbox" "(ptr)") 393 (export "ptr" "Sinteger" "(iptr)") 394 (export "ptr" "Sunsigned" "(uptr)") 395 (export "ptr" "Sinteger32" (format "(~a)" (constant typedef-i32))) 396 (export "ptr" "Sunsigned32" (format "(~a)" (constant typedef-u32))) 397 (export "ptr" "Sinteger64" (format "(~a)" (constant typedef-i64))) 398 (export "ptr" "Sunsigned64" (format "(~a)" (constant typedef-u64))) 399 400 (nl) (comment "Records") 401 (defref Srecord_uniform_ref record data) 402 (export "ptr" "Srecord_type" "(ptr)") 403 (export "ptr" "Srecord_type_parent" "(ptr)") 404 (export "int" "Srecord_type_uniformp" "(ptr)") 405 (export "uptr" "Srecord_type_size" "(ptr)") 406 407 (nl) (comment "Miscellaneous") 408 (export "ptr" "Stop_level_value" "(ptr)") 409 (export "void" "Sset_top_level_value" "(ptr, ptr)") 410 (export "void" "Slock_object" "(ptr)") 411 (export "void" "Sunlock_object" "(ptr)") 412 (export "int" "Slocked_objectp" "(ptr)") 413 (export "void" "Sforeign_symbol" "(const char *, void *)") 414 (export "void" "Sregister_symbol" "(const char *, void *)") 415 416 (nl) (comment "Support for calls into Scheme") 417 (export "ptr" "Scall0" "(ptr)") 418 (export "ptr" "Scall1" "(ptr, ptr)") 419 (export "ptr" "Scall2" "(ptr, ptr, ptr)") 420 (export "ptr" "Scall3" "(ptr, ptr, ptr, ptr)") 421 (export "void" "Sinitframe" "(iptr)") 422 (export "void" "Sput_arg" "(iptr, ptr)") 423 (export "ptr" "Scall" "(ptr, iptr)") 424 (comment "Warning: Sforeign_callable_entry_point(x) returns a pointer into x.") 425 (def "Sforeign_callable_entry_point(x)" 426 (&ref "(void (*) PROTO((void)))" "x" ($ code-data-disp))) 427 (def "Sforeign_callable_code_object(x)" 428 (&ref "(ptr)" "x" (- ($ code-data-disp)))) 429 430 (nl) (comment "Customization support.") 431 (export "const char *" "Skernel_version" "(void)") 432 (export "void" "Sretain_static_relocation" "(void)") 433 (export "void" "Sset_verbose" "(int)") 434 (export "void" "Sscheme_init" "(void (*)(void))") 435 (export "void" "Sregister_boot_file" "(const char *)") 436 (export "void" "Sregister_boot_direct_file" "(const char *)") 437 (export "void" "Sregister_boot_file_fd" "(const char *, int fd)") 438 (export "void" "Sregister_boot_file_fd_region" "(const char *, int fd, iptr offset, iptr len, int close_after)") 439 (export "void" "Sregister_heap_file" "(const char *)") 440 (export "void" "Scompact_heap" "(void)") 441 (export "void" "Ssave_heap" "(const char *, int)") 442 (export "void" "Sbuild_heap" "(const char *, void (*)(void))") 443 (export "void" "Senable_expeditor" "(const char *)") 444 (export "int" "Sscheme_start" "(int, const char *[])") 445 (export "int" "Sscheme_script" "(const char *, int, const char *[])") 446 (export "int" "Sscheme_program" "(const char *, int, const char *[])") 447 (export "void" "Sscheme_deinit" "(void)") 448 (export "void" "Sscheme_register_signal_registerer" "(void (*f)(int))") 449 450 (when-feature pthreads 451 (nl) (comment "Thread support.") 452 (export "int" "Sactivate_thread" "(void)") 453 (export "void" "Sdeactivate_thread" "(void)") 454 (export "int" "Sdestroy_thread" "(void)") 455 ) 456 457 (when-feature windows 458 (nl) (comment "Windows support.") 459 (pr "#include <wchar.h>~%") 460 (export "char *" "Sgetenv" "(const char *)") 461 (export "wchar_t *" "Sutf8_to_wide" "(const char *)") 462 (export "char *" "Swide_to_utf8" "(const wchar_t *)") 463 ) 464 465 (nl) (comment "Features.") 466 (for-each 467 (lambda (x) (pr "#define FEATURE_~@:(~a~)~%" (sanitize x))) 468 (feature-list)) 469 470 (constant-case architecture 471 [(pb) 472 (nl) (comment "C call prototypes.") 473 (pr "#include <stdint.h>\n") 474 (for-each 475 (lambda (proto+id) 476 (let ([proto (car proto+id)]) 477 (define (sym->type s) 478 (case s 479 [(int8) 'int8_t] 480 [(int16) 'int16_t] 481 [(int32) 'int32_t] 482 [(uint32) 'uint32_t] 483 [(int64) 'int64_t] 484 [(uint64) 'uint64_t] 485 [else s])) 486 (define (clean-type s) 487 (case s 488 [(void*) 'voids] 489 [else s])) 490 (pr "typedef ~a (*pb_~a_t)(~a);~%" 491 (sym->type (car proto)) 492 (apply string-append 493 (symbol->string (clean-type (car proto))) 494 (map (lambda (s) (format "_~a" (clean-type s))) 495 (cdr proto))) 496 (if (null? (cdr proto)) 497 "" 498 (apply string-append 499 (symbol->string (sym->type (cadr proto))) 500 (map (lambda (s) (format ", ~a" (sym->type s))) 501 (cddr proto))))))) 502 (reverse (constant pb-prototype-table)))] 503 [else (void)]) 504 505 (nl) (comment "Locking macros.") 506 (constant-case architecture 507 [(x86) 508 (if-feature windows 509 ;; Using compiler intrinsics on 32-bit Windows because the inline 510 ;; assembler does not support anonymous labels, and using named 511 ;; labels leads to label name conflicts if SPINLOCK is used more 512 ;; than once in the same C procedure. 513 (begin 514 (pr "#define INITLOCK(addr) (*((long *) addr) = 0)~%") 515 516 (nl) 517 (pr "#define SPINLOCK(addr) \\~%") 518 (pr "{ \\~%") 519 (pr " while (_InterlockedExchange(addr, 1) != 0) { \\~%") 520 (pr " while(*((long *) addr) != 0); \\~%") 521 (pr " } \\~%") 522 (pr "} while(0) ~%") 523 524 (nl) 525 (pr "#define UNLOCK(addr) (*((long *) addr) = 0)~%") 526 527 (nl) 528 (pr "#define LOCKED_INCR(addr, res) (res = (-1 == _InterlockedExchangeAdd(addr, 1)))~%") 529 530 (nl) 531 (pr "#define LOCKED_DECR(addr, res) (res = (1 == _InterlockedExchangeAdd(addr, -1)))~%")) 532 (begin 533 (pr "#define INITLOCK(addr) \\~%") 534 (pr " __asm__ __volatile__ (\"movl $0, (%0)\"\\~%") 535 (pr " : \\~%") 536 (pr " : \"r\" (addr) \\~%") 537 (pr " : \"memory\")~%") 538 539 (nl) 540 (pr "#define SPINLOCK(addr) \\~%") 541 (pr " __asm__ __volatile__ (\"0:\\n\\t\"\\~%") 542 (pr " \"movl $1, %%eax\\n\\t\"\\~%") 543 (pr " \"xchgl (%0), %%eax\\n\\t\"\\~%") 544 (pr " \"cmpl $0, %%eax\\n\\t\"\\~%") 545 (pr " \"je 2f\\n\\t\"\\~%") 546 (pr " \"1:\\n\\t\"\\~%") 547 (pr " \"pause\\n\\t\"\\~%") 548 (pr " \"cmpl $0, (%0)\\n\\t\"\\~%") 549 (pr " \"je 0b\\n\\t\"\\~%") 550 (pr " \"jmp 1b\\n\\t\"\\~%") 551 (pr " \"2:\"\\~%") 552 (pr " : \\~%") 553 (pr " : \"r\" (addr) \\~%") 554 (pr " : \"eax\", \"flags\", \"memory\")~%") 555 556 (nl) 557 (pr "#define UNLOCK(addr) \\~%") 558 (pr " __asm__ __volatile__ (\"movl $0, (%0)\"\\~%") 559 (pr " : \\~%") 560 (pr " : \"r\" (addr) \\~%") 561 (pr " : \"memory\")~%") 562 563 (nl) 564 (pr "#define LOCKED_INCR(addr, ret) \\~%") 565 (pr " __asm__ __volatile__ (\"lock; incl (%1)\\n\\t\"\\~%") 566 (pr " \"sete %b0\\n\\t\"\\~%") 567 (pr " \"movzx %b0, %0\\n\\t\"\\~%") 568 (pr " : \"=q\" (ret) \\~%") 569 (pr " : \"r\" (addr) \\~%") 570 (pr " : \"flags\", \"memory\")~%") 571 572 (nl) 573 (pr "#define LOCKED_DECR(addr, ret) \\~%") 574 (pr " __asm__ __volatile__ (\"lock; decl (%1)\\n\\t\"\\~%") 575 (pr " \"sete %b0\\n\\t\"\\~%") 576 (pr " \"movzx %b0, %0\\n\\t\"\\~%") 577 (pr " : \"=q\" (ret) \\~%") 578 (pr " : \"r\" (addr) \\~%") 579 (pr " : \"flags\", \"memory\")~%")))] 580 [(x86_64) 581 (if-feature windows 582 ;; Visual C for 64-bit Windows does not support inline assembler, so we are using 583 ;; intrinsics here instead. At /O2, VC seems to produced assembly 584 ;; code similar to our hand-code assembler. 585 ;; Note that using the Acquire or Release version of these functions (or the 586 ;; equivalent _acq or _rel versions of the intrinsics) produces calls to the 587 ;; intrinsic rather than the inlined assembly produced by the intrinsics used here, 588 ;; despite the documentation indicating the Acquire and Release vesions produce 589 ;; better performing code. 590 (begin 591 (pr "#define INITLOCK(addr) (*((long long *) addr) = 0)~%") 592 593 (nl) 594 (pr "#define SPINLOCK(addr) \\~%") 595 (pr "{ \\~%") 596 (pr " while (_InterlockedExchange64(addr, 1) != 0) { \\~%") 597 (pr " while(*((long long *) addr) != 0); \\~%") 598 (pr " } \\~%") 599 (pr "} while(0) ~%") 600 601 (nl) 602 (pr "#define UNLOCK(addr) (*((long long *) addr) = 0)~%") 603 604 (nl) 605 (pr "#define LOCKED_INCR(addr, res) (res = (-1 == _InterlockedExchangeAdd64(addr, 1)))~%") 606 607 (nl) 608 (pr "#define LOCKED_DECR(addr, res) (res = (1 == _InterlockedExchangeAdd64(addr, -1)))~%")) 609 (begin 610 (pr "#define INITLOCK(addr) \\~%") 611 (pr " __asm__ __volatile__ (\"movq $0, (%0)\"\\~%") 612 (pr " : \\~%") 613 (pr " : \"r\" (addr) \\~%") 614 (pr " : \"memory\")~%") 615 616 (nl) 617 (pr "#define SPINLOCK(addr) \\~%") 618 (pr " __asm__ __volatile__ (\"0:\\n\\t\"\\~%") 619 (pr " \"movq $1, %%rax\\n\\t\"\\~%") 620 (pr " \"xchgq (%0), %%rax\\n\\t\"\\~%") 621 (pr " \"cmpq $0, %%rax\\n\\t\"\\~%") 622 (pr " \"je 2f\\n\\t\"\\~%") 623 (pr " \"1:\\n\\t\"\\~%") 624 (pr " \"pause\\n\\t\"\\~%") 625 (pr " \"cmpq $0, (%0)\\n\\t\"\\~%") 626 (pr " \"je 0b\\n\\t\"\\~%") 627 (pr " \"jmp 1b\\n\\t\"\\~%") 628 (pr " \"2:\"\\~%") 629 (pr " : \\~%") 630 (pr " : \"r\" (addr) \\~%") 631 (pr " : \"rax\", \"flags\", \"memory\")~%") 632 633 (nl) 634 (pr "#define UNLOCK(addr) \\~%") 635 (pr " __asm__ __volatile__ (\"movq $0, (%0)\"\\~%") 636 (pr " : \\~%") 637 (pr " : \"r\" (addr) \\~%") 638 (pr " :\"memory\")~%") 639 640 (nl) 641 (pr "#define LOCKED_INCR(addr, ret) \\~%") 642 (pr " __asm__ __volatile__ (\"lock; incq (%1)\\n\\t\"\\~%") 643 (pr " \"sete %b0\\n\\t\"\\~%") 644 (pr " \"movzx %b0, %0\\n\\t\"\\~%") 645 (pr " : \"=q\" (ret) \\~%") 646 (pr " : \"r\" (addr) \\~%") 647 (pr " : \"flags\", \"memory\")~%") 648 649 (nl) 650 (pr "#define LOCKED_DECR(addr, ret) \\~%") 651 (pr " __asm__ __volatile__ (\"lock; decq (%1)\\n\\t\"\\~%") 652 (pr " \"sete %b0\\n\\t\"\\~%") 653 (pr " \"movzx %b0, %0\\n\\t\"\\~%") 654 (pr " : \"=q\" (ret) \\~%") 655 (pr " : \"r\" (addr) \\~%") 656 (pr " : \"flags\", \"memory\")~%")))] 657 [(ppc32) 658 (let ([reg (constant-case machine-type-name 659 [(ppc32osx tppc32osx) ""] 660 [else "%%"])]) 661 (pr "#define INITLOCK(addr) \\~%") 662 (pr " __asm__ __volatile__ (\"li ~ar0, 0\\n\\t\"\\~%" reg) 663 (pr " \"stw ~ar0, 0(%0)\\n\\t\"\\~%" reg) 664 (pr " : \\~%") 665 (pr " : \"b\" (addr)\\~%") 666 (pr " :\"memory\", \"r0\")~%") 667 668 (nl) 669 (pr "#define SPINLOCK(addr) \\~%") 670 (pr " __asm__ __volatile__ (\"0:\\n\\t\"\\~%") ; top: 671 (pr " \"lwarx ~ar0, 0, %0\\n\\t\"\\~%" reg) ; start lock acquisition 672 (pr " \"cmpwi ~ar0, 0\\n\\t\"\\~%" reg) ; see if someone already owns the lock 673 (pr " \"bne 1f\\n\\t\"\\~%") ; if so, go to our try_again loop 674 (pr " \"li ~ar0, 1\\n\\t\"\\~%" reg) ; attempt to store the value 1 675 (pr " \"stwcx. ~ar0, 0, %0\\n\\t\"\\~%" reg); 676 (pr " \"beq 2f\\n\\t\"\\~%") ; if we succeed, we own the lock 677 (pr " \"1:\\n\\t\"\\~%") ; again: 678 (pr " \"isync\\n\\t\"\\~%") ; sync things to pause the processor 679 (pr " \"lwz ~ar0, 0(%0)\\n\\t\"\\~%" reg) ; try a non-reserved load to see if we are likely to succeed 680 (pr " \"cmpwi ~ar0, 0\\n\\t\"\\~%" reg) ; if it is = 0, try to acquire at start 681 (pr " \"beq 0b\\n\\t\"\\~%") ; 682 (pr " \"b 1b\\n\\t\"\\~%") ; othwerise loop through the try again 683 (pr " \"2:\\n\\t\"\\~%") ; done: 684 (pr " : \\~%") 685 (pr " : \"b\" (addr)\\~%") 686 (pr " : \"cc\", \"memory\", \"r0\")~%") 687 688 (nl) 689 (pr "#define UNLOCK(addr) \\~%") 690 (pr " __asm__ __volatile__ (\"li ~ar0, 0\\n\\t\"\\~%" reg) 691 (pr " \"stw ~ar0, 0(%0)\\n\\t\"\\~%" reg) 692 (pr " : \\~%") 693 (pr " : \"b\" (addr)\\~%") 694 (pr " :\"memory\", \"r0\")~%") 695 696 (nl) 697 (pr "#define LOCKED_INCR(addr, ret) \\~%") 698 (pr " __asm__ __volatile__ (\"li %0, 0\\n\\t\"\\~%") 699 (pr " \"0:\\n\\t\"\\~%") 700 (pr " \"lwarx ~ar12, 0, %1\\n\\t\"\\~%" reg) 701 (pr " \"addi ~ar12, ~ar12, 1\\n\\t\"\\~%" reg reg) 702 (pr " \"stwcx. ~ar12, 0, %1\\n\\t\"\\~%" reg) 703 (pr " \"bne 0b\\n\\t\"\\~%") 704 (pr " \"cmpwi ~ar12, 0\\n\\t\"\\~%" reg) 705 (pr " \"bne 1f\\n\\t\"\\~%") 706 (pr " \"li %0, 1\\n\\t\"\\~%") 707 (pr " \"1:\\n\\t\"\\~%") 708 (pr " : \"=&r\" (ret)\\~%") 709 (pr " : \"r\" (addr)\\~%") 710 (pr " : \"cc\", \"memory\", \"r12\")~%") 711 712 (nl) 713 (pr "#define LOCKED_DECR(addr, ret) \\~%") 714 (pr " __asm__ __volatile__ (\"li %0, 0\\n\\t\"\\~%") 715 (pr " \"0:\\n\\t\"\\~%") 716 (pr " \"lwarx ~ar12, 0, %1\\n\\t\"\\~%" reg) 717 (pr " \"addi ~ar12, ~ar12, -1\\n\\t\"\\~%" reg reg) 718 (pr " \"stwcx. ~ar12, 0, %1\\n\\t\"\\~%" reg) 719 (pr " \"bne 0b\\n\\t\"\\~%") 720 (pr " \"cmpwi ~ar12, 0\\n\\t\"\\~%" reg) 721 (pr " \"bne 1f\\n\\t\"\\~%") 722 (pr " \"li %0, 1\\n\\t\"\\~%") 723 (pr " \"1:\\n\\t\"\\~%") 724 (pr " : \"=&r\" (ret)\\~%") 725 (pr " : \"r\" (addr)\\~%") 726 (pr " : \"cc\", \"memory\", \"r12\")~%"))] 727 [(arm32) 728 (pr "#define INITLOCK(addr) \\~%") 729 (pr " __asm__ __volatile__ (\"mov r12, #0\\n\\t\"\\~%") 730 (pr " \"str r12, [%0, #0]\\n\\t\"\\~%") 731 (pr " : \\~%") 732 (pr " : \"r\" (addr)\\~%") 733 (pr " :\"memory\", \"r12\")~%") 734 735 (nl) 736 (pr "#define SPINLOCK(addr) \\~%") 737 (pr " __asm__ __volatile__ (\"0:\\n\\t\"\\~%") 738 (pr " \"ldrex r12, [%0]\\n\\t\"\\~%") 739 (pr " \"cmp r12, #0\\n\\t\"\\~%") 740 (pr " \"bne 1f\\n\\t\"\\~%") 741 (pr " \"mov r12, #1\\n\\t\"\\~%") 742 (pr " \"strex r7, r12, [%0]\\n\\t\"\\~%") 743 (pr " \"cmp r7, #0\\n\\t\"\\~%") 744 (pr " \"beq 2f\\n\\t\"\\~%") 745 (pr " \"1:\\n\\t\"\\~%") 746 (pr " \"ldr r12, [%0, #0]\\n\\t\"\\~%") 747 (pr " \"cmp r12, #0\\n\\t\"\\~%") 748 (pr " \"beq 0b\\n\\t\"\\~%") 749 (pr " \"b 1b\\n\\t\"\\~%") 750 (pr " \"2:\\n\\t\"\\~%") 751 (pr " : \\~%") 752 (pr " : \"r\" (addr)\\~%") 753 (pr " : \"cc\", \"memory\", \"r12\", \"r7\")~%") 754 755 (nl) 756 (pr "#define UNLOCK(addr) \\~%") 757 (pr " __asm__ __volatile__ (\"mov r12, #0\\n\\t\"\\~%") 758 (pr " \"str r12, [%0, #0]\\n\\t\"\\~%") 759 (pr " : \\~%") 760 (pr " : \"r\" (addr)\\~%") 761 (pr " :\"memory\", \"r12\")~%") 762 763 (nl) 764 (pr "#define LOCKED_INCR(addr, ret) \\~%") 765 (pr " __asm__ __volatile__ (\"mov %0, #0\\n\\t\"\\~%") 766 (pr " \"0:\\n\\t\"\\~%") 767 (pr " \"ldrex r12, [%1]\\n\\t\"\\~%") 768 (pr " \"add r12, r12, #1\\n\\t\"\\~%") 769 (pr " \"strex r7, r12, [%1]\\n\\t\"\\~%") 770 (pr " \"cmp r7, #0\\n\\t\"\\~%") 771 (pr " \"bne 0b\\n\\t\"\\~%") 772 (pr " \"cmp r12, #0\\n\\t\"\\~%") 773 (pr " \"it eq\\n\\t\"\\~%") 774 (pr " \"moveq %0, #1\\n\\t\"\\~%") 775 (pr " : \"=&r\" (ret)\\~%") 776 (pr " : \"r\" (addr)\\~%") 777 (pr " : \"cc\", \"memory\", \"r12\", \"r7\")~%") 778 779 (nl) 780 (pr "#define LOCKED_DECR(addr, ret) \\~%") 781 (pr " __asm__ __volatile__ (\"mov %0, #0\\n\\t\"\\~%") 782 (pr " \"0:\\n\\t\"\\~%") 783 (pr " \"ldrex r12, [%1]\\n\\t\"\\~%") 784 (pr " \"sub r12, r12, #1\\n\\t\"\\~%") 785 (pr " \"strex r7, r12, [%1]\\n\\t\"\\~%") 786 (pr " \"cmp r7, #0\\n\\t\"\\~%") 787 (pr " \"bne 0b\\n\\t\"\\~%") 788 (pr " \"cmp r12, #0\\n\\t\"\\~%") 789 (pr " \"it eq\\n\\t\"\\~%") 790 (pr " \"moveq %0, #1\\n\\t\"\\~%") 791 (pr " : \"=&r\" (ret)\\~%") 792 (pr " : \"r\" (addr)\\~%") 793 (pr " : \"cc\", \"memory\", \"r12\", \"r7\")~%")] 794 [(arm64) 795 (pr "#define INITLOCK(addr) \\~%") 796 (pr " __asm__ __volatile__ (\"mov x12, #0\\n\\t\"\\~%") 797 (pr " \"str x12, [%0, #0]\\n\\t\"\\~%") 798 (pr " : \\~%") 799 (pr " : \"r\" (addr)\\~%") 800 (pr " :\"memory\", \"x12\")~%") 801 802 (nl) 803 (pr "#define SPINLOCK(addr) \\~%") 804 (pr " __asm__ __volatile__ (\"0:\\n\\t\"\\~%") 805 (pr " \"ldxr x12, [%0, #0]\\n\\t\"\\~%") 806 (pr " \"cmp x12, #0\\n\\t\"\\~%") 807 (pr " \"bne 1f\\n\\t\"\\~%") 808 (pr " \"mov x12, #1\\n\\t\"\\~%") 809 (pr " \"stxr w7, x12, [%0]\\n\\t\"\\~%") 810 (pr " \"cmp w7, #0\\n\\t\"\\~%") 811 (pr " \"beq 2f\\n\\t\"\\~%") 812 (pr " \"1:\\n\\t\"\\~%") 813 (pr " \"ldr x12, [%0, #0]\\n\\t\"\\~%") 814 (pr " \"cmp x12, #0\\n\\t\"\\~%") 815 (pr " \"beq 0b\\n\\t\"\\~%") 816 (pr " \"b 1b\\n\\t\"\\~%") 817 (pr " \"2:\\n\\t\"\\~%") 818 (pr " : \\~%") 819 (pr " : \"r\" (addr)\\~%") 820 (pr " : \"cc\", \"memory\", \"x12\", \"x7\")~%") 821 822 (nl) 823 (pr "#define UNLOCK(addr) \\~%") 824 (pr " __asm__ __volatile__ (\"mov x12, #0\\n\\t\"\\~%") 825 (pr " \"str x12, [%0, #0]\\n\\t\"\\~%") 826 (pr " : \\~%") 827 (pr " : \"r\" (addr)\\~%") 828 (pr " :\"memory\", \"x12\")~%") 829 830 (nl) 831 (pr "#define LOCKED_INCR(addr, ret) \\~%") 832 (pr " do {\\~%") 833 (pr " long _return_;\\~%") 834 (pr " __asm__ __volatile__ (\"mov %0, #0\\n\\t\"\\~%") 835 (pr " \"0:\\n\\t\"\\~%") 836 (pr " \"ldxr x12, [%1, #0]\\n\\t\"\\~%") 837 (pr " \"add x12, x12, #1\\n\\t\"\\~%") 838 (pr " \"stxr w7, x12, [%1]\\n\\t\"\\~%") 839 (pr " \"cmp w7, #0\\n\\t\"\\~%") 840 (pr " \"bne 0b\\n\\t\"\\~%") 841 (pr " \"cmp x12, #0\\n\\t\"\\~%") 842 (pr " \"bne 1f\\n\\t\"\\~%") 843 (pr " \"mov %0, #1\\n\\t\"\\~%") 844 (pr " \"1:\\n\\t\"\\~%") 845 (pr " : \"=&r\" (_return_)\\~%") 846 (pr " : \"r\" (addr)\\~%") 847 (pr " : \"cc\", \"memory\", \"x12\", \"x7\");\\~%") 848 (pr " ret = _return_;\\~%") 849 (pr " } while (0)~%") 850 851 (nl) 852 (pr "#define LOCKED_DECR(addr, ret) \\~%") 853 (pr " do {\\~%") 854 (pr " long _return_;\\~%") 855 (pr " __asm__ __volatile__ (\"mov %0, #0\\n\\t\"\\~%") 856 (pr " \"0:\\n\\t\"\\~%") 857 (pr " \"ldxr x12, [%1, #0]\\n\\t\"\\~%") 858 (pr " \"sub x12, x12, #1\\n\\t\"\\~%") 859 (pr " \"stxr w7, x12, [%1]\\n\\t\"\\~%") 860 (pr " \"cmp w7, #0\\n\\t\"\\~%") 861 (pr " \"bne 0b\\n\\t\"\\~%") 862 (pr " \"cmp x12, #0\\n\\t\"\\~%") 863 (pr " \"bne 1f\\n\\t\"\\~%") 864 (pr " \"mov %0, #1\\n\\t\"\\~%") 865 (pr " \"1:\\n\\t\"\\~%") 866 (pr " : \"=&r\" (_return_)\\~%") 867 (pr " : \"r\" (addr)\\~%") 868 (pr " : \"cc\", \"memory\", \"x12\", \"x7\");\\~%") 869 (pr " ret = _return_;\\~%") 870 (pr " } while (0)~%")] 871 [(pb) 872 (pr "#define INITLOCK(addr) (*((long *) addr) = 0)~%") 873 (pr "#define SPINLOCK(addr) (*((long *) addr) = 1)~%") 874 (pr "#define UNLOCK(addr) (*((long *) addr) = 0)~%") 875 (pr "#define LOCKED_INCR(addr, res) (res = ((*(uptr*)addr)-- == 1))~%") 876 (pr "#define LOCKED_DECR(addr, res) (res = ((*(uptr*)addr)-- == 1))~%")] 877 [else 878 ($oops who "asm locking code is not yet defined for ~s" (constant architecture))])))) 879 880 (set! mkequates.h 881 (lambda (ofn) 882 (fluid-let ([op (if (output-port? ofn) 883 ofn 884 (open-output-file ofn 'replace))]) 885 (comment "equates.h for Chez Scheme Version ~a" scheme-version) 886 887 (nl) 888 (comment "Do not edit this file. It is automatically generated and") 889 (comment "specifically tailored to the version of Chez Scheme named") 890 (comment "above. Always be certain that you have the correct version") 891 (comment "of this file for the version of Chez Scheme you are using.") 892 893 (nl) 894 (comment "Warning: Some macros may evaluate arguments more than once.") 895 896 (nl) 897 (comment "Integer typedefs") 898 (pr "typedef ~a I8;~%" (constant typedef-i8)) 899 (pr "typedef ~a U8;~%" (constant typedef-u8)) 900 (pr "typedef ~a I16;~%" (constant typedef-i16)) 901 (pr "typedef ~a U16;~%" (constant typedef-u16)) 902 (pr "typedef ~a I32;~%" (constant typedef-i32)) 903 (pr "typedef ~a U32;~%" (constant typedef-u32)) 904 (pr "typedef ~a I64;~%" (constant typedef-i64)) 905 (pr "typedef ~a U64;~%" (constant typedef-u64)) 906 907 (nl) 908 (comment "constants from cmacros.ss") 909 (for-each 910 (lambda (x) 911 (cond 912 [(getprop x '*constant* #f) => 913 (lambda (k) 914 (let ([type (getprop x '*constant-ctype* #f)] 915 [c-name (sanitize x)]) 916 (putprop x '*c-name* c-name) 917 (def c-name 918 (if (or (fixnum? k) (bignum? k)) 919 (if (< k 0) 920 (if (or (not type) (eq? type 'int)) 921 (format "-0x~x" (- k)) 922 (format "(~s)-0x~x" type (- k))) 923 (if (or (not type) (eq? type 'int)) 924 (format "0x~x" k) 925 (format "(~s)0x~x" type k))) 926 (if (not type) 927 (if (eq? k #f) 928 "0" 929 (if (eq? k #t) 930 "1" 931 (format "~s" k))) 932 (format "(~s)~s" type k))))))])) 933 (sort (lambda (x y) 934 (string<? (symbol->string x) (symbol->string y))) 935 (oblist))) 936 (nl) 937 (comment "constants from declare-c-entries") 938 (for-each 939 (lambda (x) 940 (cond 941 [($sgetprop x '*c-entry* #f) => 942 (lambda (k) 943 (def (format "CENTRY_~a" (sanitize x)) k))])) 944 (sort (lambda (x y) 945 (string<? (symbol->string x) (symbol->string y))) 946 (oblist))) 947 948 (nl) 949 (comment "displacements for records") 950 (let () 951 (define print-field-disps 952 (lambda (prefix rtd) 953 (let-values ([(pm mpm flds size) 954 ((let () (include "layout.ss") compute-field-offsets) 955 'mkheader 956 (fx- (constant typemod) (constant type-typed-object)) 957 (cons '(immutable scheme-object rtd) (csv7:record-type-field-decls rtd)))]) 958 (for-each 959 (lambda (fld) 960 (def (format "~a_~a_disp" prefix (sanitize (fld-name fld))) 961 (fld-byte fld))) 962 flds)))) 963 (print-field-disps "eq_hashtable" (let () (include "hashtable-types.ss") (record-type-descriptor eq-ht))) 964 (print-field-disps "symbol_hashtable" (let () (include "hashtable-types.ss") (record-type-descriptor symbol-ht))) 965 (print-field-disps "code_info" (let () (include "types.ss") (record-type-descriptor code-info)))) 966 967 (nl) 968 (comment "predicates") 969 (deftypep "Simmediatep" ($ mask-immediate) ($ type-immediate)) 970 (deftotypep "Sportp" ($ mask-port) ($ type-port)) 971 (deftotypep "Scodep" ($ mask-code) ($ type-code)) 972 973 (nl) 974 (comment "structure accessors") 975 976 (definit INITCAR pair car) 977 (definit INITCDR pair cdr) 978 (defset SETCAR pair car) 979 (defset SETCDR pair cdr) 980 981 (defref BOXTYPE box type) 982 (definit INITBOXREF box ref) 983 (defset SETBOXREF box ref) 984 985 (defref EPHEMERONPREVREF ephemeron prev-ref) 986 (definit INITEPHEMERONPREVREF ephemeron prev-ref) 987 (defref EPHEMERONNEXT ephemeron next) 988 (definit INITEPHEMERONNEXT ephemeron next) 989 990 (defref TLCTYPE tlc type) 991 (defref TLCKEYVAL tlc keyval) 992 (defref TLCHT tlc ht) 993 (defref TLCNEXT tlc next) 994 (definit INITTLCKEYVAL tlc keyval) 995 (definit INITTLCHT tlc ht) 996 (definit INITTLCNEXT tlc next) 997 (defset SETTLCNEXT tlc next) 998 999 (defref PHANTOMTYPE phantom type) 1000 (defref PHANTOMLEN phantom length) 1001 1002 (defref SYMVAL symbol value) 1003 (defref SYMPVAL symbol pvalue) 1004 (defref SYMPLIST symbol plist) 1005 (defref SYMNAME symbol name) 1006 (defref SYMSPLIST symbol splist) 1007 (defref SYMHASH symbol hash) 1008 1009 (definit INITSYMVAL symbol value) 1010 (definit INITSYMPVAL symbol pvalue) 1011 (definit INITSYMPLIST symbol plist) 1012 (definit INITSYMNAME symbol name) 1013 (definit INITSYMSPLIST symbol splist) 1014 (definit INITSYMHASH symbol hash) 1015 1016 (defset SETSYMVAL symbol value) 1017 (defset SETSYMPVAL symbol pvalue) 1018 (defset SETSYMPLIST symbol plist) 1019 (defset SETSYMNAME symbol name) 1020 (defset SETSYMSPLIST symbol splist) 1021 (defset SETSYMHASH symbol hash) 1022 1023 (defref VECTTYPE vector type) 1024 1025 (definit INITVECTIT vector data) 1026 (defset SETVECTIT vector data) 1027 1028 (defref FXVECTOR_TYPE fxvector type) 1029 (defref FXVECTIT fxvector data) 1030 1031 (defref FLVECTOR_TYPE flvector type) 1032 (defref FLVECTIT flvector data) 1033 1034 (defref BYTEVECTOR_TYPE bytevector type) 1035 (defref BVIT bytevector data) 1036 1037 (defref STENVECTTYPE stencil-vector type) 1038 (definit INITSTENVECTIT stencil-vector data) 1039 1040 (defref INEXACTNUM_TYPE inexactnum type) 1041 (defref INEXACTNUM_REAL_PART inexactnum real) 1042 (defref INEXACTNUM_IMAG_PART inexactnum imag) 1043 1044 (defref EXACTNUM_TYPE exactnum type) 1045 (defref EXACTNUM_REAL_PART exactnum real) 1046 (defref EXACTNUM_IMAG_PART exactnum imag) 1047 (defref EXACTNUM_PAD exactnum pad) 1048 1049 (defref RATTYPE ratnum type) 1050 (defref RATNUM ratnum numerator) 1051 (defref RATDEN ratnum denominator) 1052 (defref RATPAD ratnum pad) 1053 1054 (defref CLOSENTRY closure code) 1055 (defref CLOSIT closure data) 1056 1057 (defref FLODAT flonum data) 1058 1059 (defref PORTTYPE port type) 1060 (defref PORTNAME port name) 1061 (defref PORTHANDLER port handler) 1062 (defref PORTINFO port info) 1063 (defref PORTOCNT port ocount) 1064 (defref PORTOLAST port olast) 1065 (defref PORTOBUF port obuffer) 1066 (defref PORTICNT port icount) 1067 (defref PORTILAST port ilast) 1068 (defref PORTIBUF port ibuffer) 1069 1070 (defref STRTYPE string type) 1071 (defref STRIT string data) 1072 1073 (defref BIGTYPE bignum type) 1074 (defref BIGIT bignum data) 1075 1076 (defref CODETYPE code type) 1077 (defref CODELEN code length) 1078 (defref CODERELOC code reloc) 1079 (defref CODENAME code name) 1080 (defref CODEARITYMASK code arity-mask) 1081 (defref CODEFREE code closure-length) 1082 (defref CODEINFO code info) 1083 (defref CODEPINFOS code pinfo*) 1084 (defref CODEIT code data) 1085 1086 (defref RELOCSIZE reloc-table size) 1087 (defref RELOCCODE reloc-table code) 1088 (defref RELOCIT reloc-table data) 1089 1090 (defref CONTCODE continuation code) 1091 (defref CONTSTACK continuation stack) 1092 (defref CONTLENGTH continuation stack-length) 1093 (defref CONTCLENGTH continuation stack-clength) 1094 (defref CONTLINK continuation link) 1095 (defref CONTRET continuation return-address) 1096 (defref CONTWINDERS continuation winders) 1097 (defref CONTATTACHMENTS continuation attachments) 1098 1099 (defref RTDCOUNTSTYPE rtd-counts type) 1100 (defref RTDCOUNTSTIMESTAMP rtd-counts timestamp) 1101 (defref RTDCOUNTSIT rtd-counts data) 1102 1103 (defref RECORDDESCANCESTRY record-type ancestry) 1104 (defref RECORDDESCSIZE record-type size) 1105 (defref RECORDDESCPM record-type pm) 1106 (defref RECORDDESCMPM record-type mpm) 1107 (defref RECORDDESCNAME record-type name) 1108 (defref RECORDDESCFLDS record-type flds) 1109 (defref RECORDDESCFLAGS record-type flags) 1110 (defref RECORDDESCUID record-type uid) 1111 (defref RECORDDESCCOUNTS record-type counts) 1112 1113 (defref RECORDINSTTYPE record type) 1114 (defref RECORDINSTIT record data) 1115 1116 ; derived accessors 1117 (def "CLOSCODE(p)" "((ptr)((uptr)CLOSENTRY(p)-code_data_disp))") 1118 (def "CODEENTRYPOINT(x)" "((ptr)((uptr)(x)+code_data_disp))") 1119 (def "SETCLOSCODE(p,x)" "(CLOSENTRY(p) = CODEENTRYPOINT(x))") 1120 1121 (def "SYMCODE(p)" "((ptr)((uptr)SYMPVAL(p)-code_data_disp))") 1122 (def "INITSYMCODE(p,x)" "(INITSYMPVAL(p) = CODEENTRYPOINT(x))") 1123 (def "SETSYMCODE(p,x)" "SETSYMPVAL(p,CODEENTRYPOINT(x))") 1124 1125 (def "BIGLEN(x)" "((iptr)((uptr)BIGTYPE(x) >> bignum_length_offset))") 1126 (def "BIGSIGN(x)" "((BIGTYPE(x) & mask_bignum_sign) >> bignum_sign_offset)") 1127 (def "SETBIGLENANDSIGN(x,xl,xs)" 1128 "BIGTYPE(x) = (uptr)(xl) << bignum_length_offset | (xs) << bignum_sign_offset | type_bignum") 1129 1130 (def "CLOSLEN(p)" "CODEFREE(CLOSCODE(p))") 1131 1132 (defref GUARDIANOBJ guardian-entry obj) 1133 (defref GUARDIANREP guardian-entry rep) 1134 (defref GUARDIANTCONC guardian-entry tconc) 1135 (defref GUARDIANNEXT guardian-entry next) 1136 (defref GUARDIANORDERED guardian-entry ordered?) 1137 (defref GUARDIANPENDING guardian-entry pending) 1138 1139 (definit INITGUARDIANOBJ guardian-entry obj) 1140 (definit INITGUARDIANREP guardian-entry rep) 1141 (definit INITGUARDIANTCONC guardian-entry tconc) 1142 (definit INITGUARDIANNEXT guardian-entry next) 1143 (definit INITGUARDIANORDERED guardian-entry ordered?) 1144 (definit INITGUARDIANPENDING guardian-entry pending) 1145 1146 (defref FORWARDMARKER forward marker) 1147 (defref FORWARDADDRESS forward address) 1148 1149 (defref CACHEDSTACKSIZE cached-stack size) 1150 (defref CACHEDSTACKLINK cached-stack link) 1151 1152 (defref RPHEADERFRAMESIZE rp-header frame-size) 1153 (defref RPHEADERLIVEMASK rp-header livemask) 1154 (defref RPHEADERTOPLINK rp-header toplink) 1155 1156 (defref RPCOMPACTHEADERMASKANDSIZE rp-compact-header mask+size+mode) 1157 (defref RPCOMPACTHEADERTOPLINK rp-compact-header toplink) 1158 1159 (defref VFASLHEADER_DATA_SIZE vfasl-header data-size) 1160 (defref VFASLHEADER_TABLE_SIZE vfasl-header table-size) 1161 (defref VFASLHEADER_RESULT_OFFSET vfasl-header result-offset) 1162 (defref VFASLHEADER_VSPACE_REL_OFFSETS vfasl-header vspace-rel-offsets) 1163 (defref VFASLHEADER_SYMREF_COUNT vfasl-header symref-count) 1164 (defref VFASLHEADER_RTDREF_COUNT vfasl-header rtdref-count) 1165 (defref VFASLHEADER_SINGLETONREF_COUNT vfasl-header singletonref-count) 1166 1167 (nl) 1168 (comment "machine types") 1169 (pr "#define machine_type_names ") 1170 (pr "{~{\"~a\"~^, ~}}~%" 1171 (let ([v (make-vector (constant machine-type-limit) 'undefined)]) 1172 (for-each (lambda (a) (vector-set! v (car a) (cdr a))) (constant machine-type-alist)) 1173 (vector->list v))) 1174 1175 (nl) 1176 (comment "allocation-space names") 1177 (pr "#define alloc_space_names ") 1178 (pr "~{\"~a\"~^, ~}~%" (constant space-cname-list)) 1179 1180 (nl) 1181 (comment "allocation-space characters") 1182 (pr "#define alloc_space_chars ") 1183 (pr "~{\'~a\'~^, ~}~%" (constant space-char-list)) 1184 1185 (nl) 1186 (comment "threads") 1187 (when-feature pthreads 1188 (pr "#define scheme_feature_pthreads 1~%")) 1189 (defref THREADTYPE thread type) 1190 (defref THREADTC thread tc) 1191 1192 (nl) 1193 (comment "thread-context data") 1194 (let () 1195 (define-syntax alpha 1196 (let () 1197 (define CSAFE 1198 (lambda (sym) 1199 (string->symbol 1200 (list->string 1201 (map char-upcase 1202 (remv #\- (string->list (symbol->string sym)))))))) 1203 (let ([tc-field-list (sort 1204 (lambda (x y) 1205 (string<? (symbol->string x) (symbol->string y))) 1206 tc-field-list)]) 1207 (with-syntax ([(param ...) 1208 (map (lambda (x) (datum->syntax #'* x)) 1209 tc-field-list)] 1210 [(PARAM ...) 1211 (map (lambda (x) (datum->syntax #'* x)) 1212 (map CSAFE tc-field-list))]) 1213 (lambda (x) 1214 #'(begin (defref PARAM tc param) ...)))))) 1215 alpha) 1216 1217 ; get ARGREGS for free from above; prefer ARGREG 1218 (defref ARGREG tc arg-regs) 1219 (defref VIRTREG tc virtual-registers) 1220 1221 (nl) 1222 (comment "library entries we access from C code") 1223 (def "library_nonprocedure_code" 1224 (libspec-index (lookup-libspec nonprocedure-code))) 1225 (def "library_dounderflow" 1226 (libspec-index (lookup-libspec dounderflow))) 1227 (def "library_popcount_slow" 1228 (libspec-index (lookup-libspec popcount-slow))) 1229 (def "library_cpu_features" 1230 (libspec-index (lookup-libspec cpu-features))) 1231 1232 ))) 1233) 1234