Changeset 13167 in project
- Timestamp:
- 02/03/09 05:28:28 (12 years ago)
- Location:
- chicken/trunk
- Files:
-
- 7 edited
Legend:
- Unmodified
- Added
- Removed
-
chicken/trunk/chicken-thread-object-inlines.scm
r13146 r13167 2 2 ;;;; Kon Lovett, Jan '09 3 3 4 ;;;; Provides inlines & macros for thread objects 5 ;;;; MUST be included 6 ;;;; NEEDS "chicken-primitive-inlines" included 4 ; Usage 5 ; 6 ; (include "chicken-primitive-object-inlines") 7 ; (include "chicken-thread-object-inlines") 8 9 ;; Notes 10 ; 11 ; Provides inlines & macros for thread objects. Use of these procedures 12 ; by non-core & non-core-extensions is highly suspect. Many of these routines 13 ; are unsafe. 14 ; 15 ; In fact, any use is suspect ;-) 16 7 17 8 18 ;;; Mutex object helpers: … … 19 29 20 30 (define-inline (%mutex? x) 21 (%structure -instance? x 'mutex) )31 (%structure? x 'mutex) ) 22 32 23 33 (define-inline (%mutex-name mx) … … 28 38 29 39 (define-inline (%mutex-thread-set! mx th) 30 (%structure-s lot-set! mx 2 th) )40 (%structure-set! mx 2 th) ) 31 41 32 42 (define-inline (%mutex-thread-clear! mx) 33 (%structure- immediate-set!mx 2 #f) )43 (%structure-set!/immediate mx 2 #f) ) 34 44 35 45 (define-inline (%mutex-waiters mx) … … 37 47 38 48 (define-inline (%mutex-waiters-set! mx wt) 39 (%structure-slot-set! mx 3 wt) ) 49 (%structure-set! mx 3 wt) ) 50 51 (define-inline (%mutex-waiters-empty? mx) 52 (%null? (%mutex-waiters mx)) ) 53 54 (define-inline (%mutex-waiters-empty! mx) 55 (%structure-set!/immediate mx 3 '()) ) 40 56 41 57 (define-inline (%mutex-waiters-add! mx th) … … 43 59 44 60 (define-inline (%mutex-waiters-delete! mx th) 45 (%mutex-waiters-set! mx (##sys#delq th (%mutex-waiters mx))) ) 46 47 (define-inline (%mutex-waiters-empty? mx) 48 (%null? (%mutex-waiters mx)) ) 49 50 (define-inline (%mutex-waiters-forget! mx) 51 (%structure-immediate-set! mx 3 '()) ) 61 (%mutex-waiters-set! mx (%delq! th (%mutex-waiters mx))) ) 52 62 53 63 (define-inline (%mutex-waiters-pop! mx) … … 61 71 62 72 (define-inline (%mutex-abandoned-set! mx f) 63 (%structure- immediate-set!mx 4 f) )73 (%structure-set!/immediate mx 4 f) ) 64 74 65 75 (define-inline (%mutex-locked? mx) … … 67 77 68 78 (define-inline (%mutex-locked-set! mx f) 69 (%structure- immediate-set!mx 5 f) )79 (%structure-set!/immediate mx 5 f) ) 70 80 71 81 (define-inline (%mutex-specific mx) … … 73 83 74 84 (define-inline (%mutex-specific-set! mx x) 75 (%structure-s lot-set! mx 6 x) )85 (%structure-set! mx 6 x) ) 76 86 77 87 … … 102 112 103 113 (define-inline (%thread? x) 104 (%structure -instance? x 'thread) )114 (%structure? x 'thread) ) 105 115 106 116 (define-inline (%thread-thunk th) … … 108 118 109 119 (define-inline (%thread-thunk-set! th tk) 110 (%structure-s lot-set! th 1 tk) )120 (%structure-set! th 1 tk) ) 111 121 112 122 (define-inline (%thread-results th) … … 114 124 115 125 (define-inline (%thread-results-set! th rs) 116 (%structure-s lot-set! th 2 rs) )126 (%structure-set! th 2 rs) ) 117 127 118 128 (define-inline (%thread-state th) … … 120 130 121 131 (define-inline (%thread-state-set! th st) 122 (%structure-s lot-set! th 3 st) )132 (%structure-set! th 3 st) ) 123 133 124 134 (define-inline (%thread-block-timeout th) … … 126 136 127 137 (define-inline (%thread-block-timeout-set! th to) 128 (%structure- immediate-set!th 4 to) )138 (%structure-set!/immediate th 4 to) ) 129 139 130 140 (define-inline (%thread-block-timeout-clear! th) … … 135 145 136 146 (define-inline (%thread-state-buffer-set! th v) 137 (%structure-s lot-set! th 5 v) )147 (%structure-set! th 5 v) ) 138 148 139 149 (define-inline (%thread-name th) … … 144 154 145 155 (define-inline (%thread-reason-set! th cd) 146 (%structure-s lot-set! th 7 cd) )156 (%structure-set! th 7 cd) ) 147 157 148 158 (define-inline (%thread-mutexes th) … … 150 160 151 161 (define-inline (%thread-mutexes-set! th wt) 152 (%structure-s lot-set! th 8 wx) )162 (%structure-set! th 8 wx) ) 153 163 154 164 (define-inline (%thread-mutexes-empty? th) 155 165 (%null? (%thread-mutexes th)) ) 156 166 157 (define-inline (%thread-mutexes- forget! th)158 (%structure- immediate-set!th 8 '()) )167 (define-inline (%thread-mutexes-empty! th) 168 (%structure-set!/immediate th 8 '()) ) 159 169 160 170 (define-inline (%thread-mutexes-add! th mx) … … 162 172 163 173 (define-inline (%thread-mutexes-delete! th mx) 164 (%thread-mutexes-set! th ( ##sys#delqmx (%thread-mutexes th))) )174 (%thread-mutexes-set! th (%delq! mx (%thread-mutexes th))) ) 165 175 166 176 (define-inline (%thread-quantum th) … … 168 178 169 179 (define-inline (%thread-quantum-set! th qt) 170 (%structure- immediate-set!th 9 qt) )180 (%structure-set!/immediate th 9 qt) ) 171 181 172 182 (define-inline (%thread-specific th) … … 174 184 175 185 (define-inline (%thread-specific-set! th x) 176 (%structure-s lot-set! th 10 x) )186 (%structure-set! th 10 x) ) 177 187 178 188 (define-inline (%thread-block-object th) … … 180 190 181 191 (define-inline (%thread-block-object-set! th x) 182 (%structure-s lot-set! th 11 x) )192 (%structure-set! th 11 x) ) 183 193 184 194 (define-inline (%thread-block-object-clear! th) 185 (%structure- immediate-set!th 11 #f) )195 (%structure-set!/immediate th 11 #f) ) 186 196 187 197 (define-inline (%thread-recipients th) … … 189 199 190 200 (define-inline (%thread-recipients-set! th x) 191 (%structure-slot-set! th 12 x) ) 201 (%structure-set! th 12 x) ) 202 203 (define-inline (%thread-recipients-empty? th) 204 (%null? (%condition-variable-waiters th)) ) 205 206 (define-inline (%thread-recipients-empty! th) 207 (%structure-set!/immediate th 12 '()) ) 192 208 193 209 (define-inline (%thread-recipients-add! th rth) 194 210 (%thread-recipients-set! t (%cons rth (%thread-recipients t))) ) 195 196 (define-inline (%thread-recipients-forget! th)197 (%structure-immediate-set! th 12 '()) )198 211 199 212 (define-inline (%thread-recipients-process! th tk) 200 213 (let ([rs (%thread-recipients t)]) 201 214 (unless (%null? rs) (for-each tk rs) ) ) 202 (thread-recipients- forget! t) )215 (thread-recipients-empty! t) ) 203 216 204 217 (define-inline (%thread-unblocked-by-timeout? th) … … 206 219 207 220 (define-inline (%thread-unblocked-by-timeout-set! th f) 208 (%structure- immediate-set!th 13 f) )221 (%structure-set!/immediate th 13 f) ) 209 222 210 223 … … 219 232 220 233 (define-inline (%condition-variable? x) 221 (%structure -instance? x 'condition-variable) )234 (%structure? x 'condition-variable) ) 222 235 223 236 (define-inline (%condition-variable-name cv) … … 228 241 229 242 (define-inline (%condition-variable-waiters-set! cv x) 230 (%structure-slot-set! cv 2 x) ) 243 (%structure-set! cv 2 x) ) 244 245 (define-inline (%condition-variable-waiters-empty? cv) 246 (%null? (%condition-variable-waiters cv)) ) 247 248 (define-inline (%condition-variable-waiters-empty! cv) 249 (%structure-set!/immediate cv 2 '()) ) 231 250 232 251 (define-inline (%condition-variable-waiters-add! cv th) … … 234 253 235 254 (define-inline (%condition-variable-waiters-delete! cv th) 236 (%condition-variable-waiters-set! cv (##sys#delq th (%condition-variable-waiters cv))) ) 237 238 (define-inline (%condition-variable-waiters-empty? mx) 239 (%null? (%condition-variable-waiters mx)) ) 255 (%condition-variable-waiters-set! cv (%delq! th (%condition-variable-waiters cv))) ) 240 256 241 257 (define-inline (%condition-variable-waiters-pop! mx) … … 245 261 top ) ) 246 262 247 (define-inline (%condition-variable-waiters-clear! cv)248 (%structure-immediate-set! cv 2 '()) )249 250 263 (define-inline (%condition-variable-specific cv) 251 264 (%structure-ref cv 3) ) 252 265 253 266 (define-inline (%condition-variable-specific-set! cv x) 254 (%structure-s lot-set! cv 3 x) )267 (%structure-set! cv 3 x) ) -
chicken/trunk/chicken.h
r13148 r13167 377 377 #define C_FIXNUM_SHIFT 1 378 378 379 /* Character range is that of a UTF-8 codepoint, not representable range */ 379 380 #define C_CHAR_BIT_MASK 0x1fffff 381 #define C_CHAR_SHIFT 8 380 382 381 383 #ifdef C_SIXTY_FOUR … … 464 466 #define C_SIZEOF_PAIR 3 465 467 #define C_SIZEOF_STRING(n) (C_bytestowords(n) + 2) 466 #define C_SIZEOF_SYMBOL 4468 #define C_SIZEOF_SYMBOL 4 467 469 #define C_SIZEOF_INTERNED_SYMBOL(n) (C_SIZEOF_SYMBOL + C_SIZEOF_BUCKET + C_SIZEOF_STRING(n)) 468 470 #ifdef C_DOUBLE_IS_32_BITS 469 # define C_SIZEOF_FLONUM 470 #else 471 # define C_SIZEOF_FLONUM 471 # define C_SIZEOF_FLONUM 2 472 #else 473 # define C_SIZEOF_FLONUM 4 472 474 #endif 473 475 #define C_SIZEOF_POINTER 2 … … 485 487 #define C_SWIG_POINTER_TAG (C_SWIG_POINTER_TYPE | (C_wordstobytes(C_SIZEOF_SWIG_POINTER - 1))) 486 488 #define C_SYMBOL_TAG (C_SYMBOL_TYPE | (C_SIZEOF_SYMBOL - 1)) 487 #define C_FLONUM_TAG (C_FLONUM_TYPE | sizeof(double))489 #define C_FLONUM_TAG (C_FLONUM_TYPE | sizeof(double)) 488 490 489 491 #ifdef C_SIXTY_FOUR … … 787 789 #define C_fix(n) (((C_word)(n) << C_FIXNUM_SHIFT) | C_FIXNUM_BIT) 788 790 #define C_unfix(x) ((x) >> C_FIXNUM_SHIFT) 789 #define C_make_character(c) ((((c) & C_CHAR_BIT_MASK) << 8) | C_CHARACTER_BITS)790 #define C_character_code(x) (((x) >> 8) & C_CHAR_BIT_MASK)791 #define C_make_character(c) ((((c) & C_CHAR_BIT_MASK) << C_CHAR_SHIFT) | C_CHARACTER_BITS) 792 #define C_character_code(x) (((x) >> C_CHAR_SHIFT) & C_CHAR_BIT_MASK) 791 793 #define C_flonum_magnitude(x) (*((double *)(((C_SCHEME_BLOCK *)(x))->data))) 792 794 #define C_c_string(x) ((C_char *)(((C_SCHEME_BLOCK *)(x))->data)) -
chicken/trunk/library.scm
r13150 r13167 2579 2579 2580 2580 (define (##sys#char->utf8-string c) 2581 (let ((i (char->integer c))) 2582 (cond 2583 ((fx<= i #x7F) (string c)) 2584 ((fx<= i #x7FF) 2585 (string (integer->char (fxior #b11000000 (fxshr i 6))) 2586 (integer->char (fxior #b10000000 (fxand i #b111111))))) 2587 ((fx<= i #xFFFF) 2588 (string (integer->char (fxior #b11100000 (fxshr i 12))) 2589 (integer->char (fxior #b10000000 (fxand (fxshr i 6) #b111111))) 2590 (integer->char (fxior #b10000000 (fxand i #b111111))))) 2591 ((fx<= i #x1FFFFF) 2592 (string (integer->char (fxior #b11110000 (fxshr i 18))) 2593 (integer->char (fxior #b10000000 (fxand (fxshr i 12) #b111111))) 2594 (integer->char (fxior #b10000000 (fxand (fxshr i 6) #b111111))) 2595 (integer->char (fxior #b10000000 (fxand i #b111111))))) 2596 (else (error "unicode codepoint out of range:" i))))) 2581 (let ([i (char->integer c)]) 2582 (cond [(fx<= i #x7F) 2583 (string c) ] 2584 [(fx<= i #x7FF) 2585 (string (integer->char (fxior #b11000000 (fxshr i 6))) 2586 (integer->char (fxior #b10000000 (fxand i #b111111)))) ] 2587 [(fx<= i #xFFFF) 2588 (string (integer->char (fxior #b11100000 (fxshr i 12))) 2589 (integer->char (fxior #b10000000 (fxand (fxshr i 6) #b111111))) 2590 (integer->char (fxior #b10000000 (fxand i #b111111)))) ] 2591 [(fx<= i #x1FFFFF) 2592 (string (integer->char (fxior #b11110000 (fxshr i 18))) 2593 (integer->char (fxior #b10000000 (fxand (fxshr i 12) #b111111))) 2594 (integer->char (fxior #b10000000 (fxand (fxshr i 6) #b111111))) 2595 (integer->char (fxior #b10000000 (fxand i #b111111)))) ] 2596 [else 2597 (error "UTF-8 codepoint out of range:" i) ] ) ) ) 2597 2598 2598 2599 (define (##sys#unicode-surrogate? n) 2599 (and (fx<= #xD800 n) (fx<= n #xDFFF)) )2600 (and (fx<= #xD800 n) (fx<= n #xDFFF)) ) 2600 2601 2601 2602 ;; returns #f if the inputs are not a valid surrogate pair (hi followed by lo) … … 2605 2606 (fxior (fxshl (fx+ 1 (fxand (fxshr hi 6) #b11111)) 16) 2606 2607 (fxior (fxshl (fxand hi #b111111) 10) 2607 (fxand lo #b1111111111)))) )2608 (fxand lo #b1111111111)))) ) 2608 2609 2609 2610 ;;; Hooks for user-defined read-syntax: … … 2616 2617 (case char 2617 2618 ;; I put it here, so the SRFI-4 unit can intercept '#f...' 2618 ((#\f #\F) (##sys#read-char-0 port) #f)2619 ((#\t #\T) (##sys#read-char-0 port) #t)2620 (else (##sys#read-error port "invalid sharp-sign read syntax" char) )) )2619 [(#\f #\F) (##sys#read-char-0 port) #f ] 2620 [(#\t #\T) (##sys#read-char-0 port) #t ] 2621 [else (##sys#read-error port "invalid sharp-sign read syntax" char) ] ) ) 2621 2622 2622 2623 -
chicken/trunk/lolevel.scm
r13148 r13167 293 293 "bad argument type - not a pointer or integer" x)] ) ) ) ) 294 294 295 296 ;;; Tagged-pointers: 297 298 (define (tag-pointer ptr tag) 299 (let ([tp (##sys#make-tagged-pointer tag)]) 300 (if (%special-block? ptr) 301 (##core#inline "C_copy_pointer" ptr tp) 302 (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int) 'tag-pointer ptr) ) 303 tp) ) 304 305 (define (tagged-pointer? x #!optional tag) 306 (and (##core#inline "C_blockp" x) (##core#inline "C_taggedpointerp" x) 307 (or (not tag) 308 (equal? tag (##sys#slot x 1)) ) ) ) 309 310 (define (pointer-tag x) 311 (if (%special-block? x) 312 (and (##core#inline "C_taggedpointerp" x) 313 (##sys#slot x 1) ) 314 (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int) 'pointer-tag x) ) ) 315 316 317 ;;; locatives: 318 319 ;; Locative layout: 320 ; 321 ; 0 Object-address + Byte-offset (address) 322 ; 1 Byte-offset (fixnum) 323 ; 2 Type (fixnum) 324 ; 0 vector or pair (C_SLOT_LOCATIVE) 325 ; 1 string (C_CHAR_LOCATIVE) 326 ; 2 u8vector or blob (C_U8_LOCATIVE) 327 ; 3 s8vector (C_S8_LOCATIVE) 328 ; 4 u16vector (C_U16_LOCATIVE) 329 ; 5 s16vector (C_S16_LOCATIVE) 330 ; 6 u32vector (C_U32_LOCATIVE) 331 ; 7 s32vector (C_S32_LOCATIVE) 332 ; 8 f32vector (C_F32_LOCATIVE) 333 ; 9 f64vector (C_F64_LOCATIVE) 334 ; 3 Object or #f, if weak (C_word) 335 336 (define (make-locative obj . index) 337 (##sys#make-locative obj (optional index 0) #f 'make-locative) ) 338 339 (define (make-weak-locative obj . index) 340 (##sys#make-locative obj (optional index 0) #t 'make-weak-locative) ) 341 342 (define (locative-set! x y) (##core#inline "C_i_locative_set" x y)) 343 (define locative-ref (getter-with-setter (##core#primitive "C_locative_ref") locative-set!)) 344 (define (locative->object x) (##core#inline "C_i_locative_to_object" x)) 345 (define (locative? x) (and (##core#inline "C_blockp" x) (##core#inline "C_locativep" x))) 346 347 348 ;;; SRFI-4 number-vector: 349 295 350 (define pointer-u8-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((unsigned char *)p) = n;")) 296 351 (define pointer-s8-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((char *)p) = n;")) … … 341 396 (foreign-lambda* double ([c-pointer p]) "return(*((double *)p));") 342 397 pointer-f64-set!) ) 343 344 345 ;;; Tagged-pointers:346 347 (define (tag-pointer ptr tag)348 (let ([tp (##sys#make-tagged-pointer tag)])349 (if (%special-block? ptr)350 (##core#inline "C_copy_pointer" ptr tp)351 (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int) 'tag-pointer ptr) )352 tp) )353 354 (define (tagged-pointer? x #!optional tag)355 (and (##core#inline "C_blockp" x) (##core#inline "C_taggedpointerp" x)356 (or (not tag)357 (equal? tag (##sys#slot x 1)) ) ) )358 359 (define (pointer-tag x)360 (if (%special-block? x)361 (and (##core#inline "C_taggedpointerp" x)362 (##sys#slot x 1) )363 (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int) 'pointer-tag x) ) )364 365 366 ;;; locatives:367 368 ;; Locative layout:369 ;370 ; 0 Object-address + Byte-offset (address)371 ; 1 Byte-offset (fixnum)372 ; 2 Type (fixnum)373 ; 0 vector or pair (C_SLOT_LOCATIVE)374 ; 1 string (C_CHAR_LOCATIVE)375 ; 2 u8vector (C_U8_LOCATIVE)376 ; 3 s8vector or blob (C_U8_LOCATIVE)377 ; 4 u16vector (C_U16_LOCATIVE)378 ; 5 s16vector (C_S16_LOCATIVE)379 ; 6 u32vector (C_U32_LOCATIVE)380 ; 7 s32vector (C_S32_LOCATIVE)381 ; 8 f32vector (C_F32_LOCATIVE)382 ; 9 f64vector (C_F64_LOCATIVE)383 ; 3 Object or #f, if weak (C_word)384 385 (define (make-locative obj . index)386 (##sys#make-locative obj (optional index 0) #f 'make-locative) )387 388 (define (make-weak-locative obj . index)389 (##sys#make-locative obj (optional index 0) #t 'make-weak-locative) )390 391 (define (locative-set! x y) (##core#inline "C_i_locative_set" x y))392 (define locative-ref (getter-with-setter (##core#primitive "C_locative_ref") locative-set!))393 (define (locative->object x) (##core#inline "C_i_locative_to_object" x))394 (define (locative? x) (and (##core#inline "C_blockp" x) (##core#inline "C_locativep" x)))395 398 396 399 -
chicken/trunk/posixunix.scm
r13093 r13167 28 28 (declare 29 29 (unit posix) 30 (uses scheduler regex extras utils files )30 (uses scheduler regex extras utils files ports) 31 31 (disable-interrupts) 32 32 (usual-integrations) -
chicken/trunk/posixwin.scm
r13135 r13167 66 66 (declare 67 67 (unit posix) 68 (uses scheduler regex extras utils files )68 (uses scheduler regex extras utils files ports) 69 69 (disable-interrupts) 70 70 (usual-integrations) -
chicken/trunk/runtime.c
r13148 r13167 6239 6239 6240 6240 6241 void C_ccall C_call_cc(C_word c, C_word cl , C_word k, C_word cont)6241 void C_ccall C_call_cc(C_word c, C_word closure, C_word k, C_word cont) 6242 6242 { 6243 6243 C_word *a = C_alloc(3), … … 6360 6360 6361 6361 6362 void C_ccall C_call_with_values(C_word c, C_word cl , C_word k, C_word thunk, C_word kont)6362 void C_ccall C_call_with_values(C_word c, C_word closure, C_word k, C_word thunk, C_word kont) 6363 6363 { 6364 6364 C_word *a = C_alloc(4), … … 6380 6380 6381 6381 6382 void C_ccall C_u_call_with_values(C_word c, C_word cl , C_word k, C_word thunk, C_word kont)6382 void C_ccall C_u_call_with_values(C_word c, C_word closure, C_word k, C_word thunk, C_word kont) 6383 6383 { 6384 6384 C_word *a = C_alloc(4), … … 6392 6392 void C_ccall values_continuation(C_word c, C_word closure, C_word arg0, ...) 6393 6393 { 6394 C_word kont = ((C_SCHEME_BLOCK *)closure)->data[ 1 ],6395 k = ((C_SCHEME_BLOCK *)closure)->data[ 2 ],6394 C_word kont = C_u_i_cdr(closure), 6395 k = C_block_item(closure, 2), 6396 6396 n = c, 6397 6397 *ptr; … … 8412 8412 void C_ccall C_register_finalizer(C_word c, C_word closure, C_word k, C_word x, C_word proc) 8413 8413 { 8414 if(C_immediatep(x)) C_kontinue(k, x 8414 if(C_immediatep(x)) C_kontinue(k, x); 8415 8415 8416 8416 C_do_register_finalizer(x, proc);
Note: See TracChangeset
for help on using the changeset viewer.