~ chicken-core (chicken-5) d6800beb4017c6f07ab511e85543a2d471c26ad6
commit d6800beb4017c6f07ab511e85543a2d471c26ad6
Author: felix <felix@y.(none)>
AuthorDate: Mon Mar 1 14:09:34 2010 +0100
Commit: felix <felix@y.(none)>
CommitDate: Mon Mar 1 14:09:34 2010 +0100
unboxing only effective in unsafe mode; added unboxed rewrites for pointer ops
diff --git a/batch-driver.scm b/batch-driver.scm
index 3f9fdf30..4812bbd4 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -129,9 +129,10 @@
(##sys#hash-table-set!
##sys#line-number-database
(car data2)
- (alist-cons data2 val
- (or (##sys#hash-table-ref ##sys#line-number-database (car data2))
- '() ) ) ) )
+ (alist-cons
+ data2 val
+ (or (##sys#hash-table-ref ##sys#line-number-database (car data2))
+ '() ) ) ) )
data2) )
(define (arg-val str)
@@ -612,7 +613,7 @@
(> (- (cputime) start-time) funny-message-timeout))
(display "(don't worry - still compiling...)\n") )
(print-node "closure-converted" '|9| node2)
- (when unbox
+ (when (and unbox unsafe)
(debugging 'p "performing unboxing")
(begin-time)
(perform-unboxing! node2)
diff --git a/c-platform.scm b/c-platform.scm
index 9de9fd05..cfa2b904 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -146,6 +146,11 @@
u8vector-set! s8vector-set! u16vector-set! s16vector-set! u32vector-set! s32vector-set!
locative-ref locative-set! locative->object locative? global-ref
null-pointer? pointer->object flonum? finite? address->pointer pointer->address
+ pointer+ pointer=?
+ pointer-u8-ref pointer-s8-ref pointer-u16-ref pointer-s16-ref
+ pointer-u32-ref pointer-s32-ref pointer-f32-ref pointer-f64-ref
+ pointer-u8-set! pointer-s8-set! pointer-u16-set! pointer-s16-set!
+ pointer-u32-set! pointer-s32-set! pointer-f32-set! pointer-f64-set!
printf sprintf format) )
(define internal-bindings
@@ -817,6 +822,25 @@
(rewrite 'string 16 #f "C_a_i_string" #t #t) ; the last #t is actually too much, but we don't care
(rewrite 'address->pointer 16 1 "C_a_i_address_to_pointer" #f 2)
(rewrite 'pointer->address 16 1 "C_a_i_pointer_to_address" #f words-per-flonum)
+(rewrite 'pointer+ 16 2 "C_a_i_pointer_inc" #f 2)
+
+(rewrite 'pointer-u8-ref 2 1 "C_u_i_pointer_u8_ref" #f)
+(rewrite 'pointer-s8-ref 2 1 "C_u_i_pointer_s8_ref" #f)
+(rewrite 'pointer-u16-ref 2 1 "C_u_i_pointer_u16_ref" #f)
+(rewrite 'pointer-s16-ref 2 1 "C_u_i_pointer_s16_ref" #f)
+(rewrite 'pointer-u8-set! 2 2 "C_u_i_pointer_u8_set" #f)
+(rewrite 'pointer-s8-set! 2 2 "C_u_i_pointer_s8_set" #f)
+(rewrite 'pointer-u16-set! 2 2 "C_u_i_pointer_u16_set" #f)
+(rewrite 'pointer-s16-set! 2 2 "C_u_i_pointer_s16_set" #f)
+(rewrite 'pointer-u32-set! 2 2 "C_u_i_pointer_u32_set" #f)
+(rewrite 'pointer-s32-set! 2 2 "C_u_i_pointer_s32_set" #f)
+(rewrite 'pointer-f32-set! 2 2 "C_u_i_pointer_f32_set" #f)
+(rewrite 'pointer-f64-set! 2 2 "C_u_i_pointer_f64_set" #f)
+
+(rewrite 'pointer-u32-ref 16 1 "C_a_u_i_pointer_u32_ref" #f words-per-flonum)
+(rewrite 'pointer-s32-ref 16 1 "C_a_u_i_pointer_s32_ref" #f words-per-flonum)
+(rewrite 'pointer-f32-ref 16 1 "C_a_u_i_pointer_f32_ref" #f words-per-flonum)
+(rewrite 'pointer-f64-ref 16 1 "C_a_u_i_pointer_f64_ref" #f words-per-flonum)
(rewrite
'##sys#setslot 8
diff --git a/chicken.h b/chicken.h
index 7d671a97..85ee46b0 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1185,6 +1185,8 @@ extern double trunc(double);
#define C_a_i_flonum(ptr, i, n) C_flonum(ptr, n)
#define C_a_i_data_mpointer(ptr, n, x) C_mpointer(ptr, C_data_pointer(x))
#define C_a_i_mpointer(ptr, n, x) C_mpointer(ptr, (x))
+#define C_a_u_i_pointer_inc(ptr, n, p, i) C_mpointer(ptr, (C_char *)(p) + C_unfix(i))
+#define C_pointer_eqp(x, y) C_mk_bool(C_c_pointer_nn(x) == C_c_pointer_nn(y))
#define C_a_int_to_num(ptr, n, i) C_int_to_num(ptr, i)
#define C_a_unsigned_int_to_num(ptr, n, i) C_unsigned_int_to_num(ptr, i)
#define C_a_double_to_num(ptr, n) C_double_to_number(C_flonum(ptr, n))
@@ -1292,6 +1294,33 @@ extern double trunc(double);
#define C_u_i_bit_setp(x, i) C_mk_bool((C_unfix(x) & (1 << C_unfix(i))) != 0)
+#define C_u_i_pointer_u8_ref(ptr) C_fix(((unsigned char *)C_block_item(ptr, 0)))
+#define C_u_i_pointer_s8_ref(ptr) C_fix(((char *)C_block_item(ptr, 0)))
+#define C_u_i_pointer_u16_ref(ptr) C_fix(((unsigned short *)C_block_item(ptr, 0)))
+#define C_u_i_pointer_s16_ref(ptr) C_fix(((short *)C_block_item(ptr, 0)))
+#define C_a_u_i_pointer_u32_ref(ap, n, ptr) \
+ C_unsigned_int_to_num(ap, *((C_u32 *)C_block_item(ptr, 0)))
+#define C_a_u_i_pointer_s32_ref(ap, n, ptr) \
+ C_int_to_num(ap, *((C_s32 *)C_block_item(ptr, 0)))
+#define C_a_u_i_pointer_f32_ref(ap, n, ptr) C_flonum(ap, *((float *)C_block_item(ptr, 0)))
+#define C_a_u_i_pointer_f64_ref(ap, n, ptr) C_flonum(ap, *((double *)C_block_item(ptr, 0)))
+#define C_u_i_pointer_u8_set(ptr, x) \
+ (*((unsigned char *)C_block_item(ptr, 0)) = C_unfix(x), C_SCHEME_UNDEFINED)
+#define C_u_i_pointer_s8_set(ptr, x) \
+ (*((char *)C_block_item(ptr, 0)) = C_unfix(x), C_SCHEME_UNDEFINED)
+#define C_u_i_pointer_u16_set(ptr, x) \
+ (*((unsigned short *)C_block_item(ptr, 0)) = C_unfix(x), C_SCHEME_UNDEFINED)
+#define C_u_i_pointer_s16_set(ptr, x) \
+ (*((short *)C_block_item(ptr, 0)) = C_unfix(x), C_SCHEME_UNDEFINED)
+#define C_u_i_pointer_u32_set(ptr, x) \
+ (*((C_u32 *)C_block_item(ptr, 0)) = C_num_to_unsigned_int(x), C_SCHEME_UNDEFINED)
+#define C_u_i_pointer_s32_set(ptr, x) \
+ (*((C_s32 *)C_block_item(ptr, 0)) = C_num_to_int(x), C_SCHEME_UNDEFINED)
+#define C_u_i_pointer_f32_set(ptr, x) \
+ (*((float *)C_block_item(ptr, 0)) = C_flonum_magnitude(x), C_SCHEME_UNDEFINED)
+#define C_u_i_pointer_f64_set(ptr, x) \
+ (*((double *)C_block_item(ptr, 0)) = C_flonum_magnitude(x), C_SCHEME_UNDEFINED)
+
#ifdef C_BIG_ENDIAN
# ifdef C_SIXTY_FOUR
# define C_lihdr(x, y, z) ((C_LAMBDA_INFO_TYPE >> 56) & 0xff), \
@@ -1321,6 +1350,26 @@ extern double trunc(double);
#define C_ub_i_flonum_greater_or_equal_p(n1, n2) ((n1) >= (n2))
#define C_ub_i_flonum_less_or_equal_p(n1, n2) ((n1) <= (n2))
+#define C_ub_i_pointer_inc(p, n) ((void *)((unsigned char *)(p) + (n)))
+#define C_ub_i_pointer_eqp(p1, p2) ((p1) == (p2))
+
+#define C_ub_i_pointer_u8_ref(p) (*((unsigned char *)(p)))
+#define C_ub_i_pointer_s8_ref(p) (*((char *)(p)))
+#define C_ub_i_pointer_u16_ref(p) (*((unsigned short *)(p)))
+#define C_ub_i_pointer_s16_ref(p) (*((short *)(p)))
+#define C_ub_i_pointer_u32_ref(p) (*((C_u32 *)(p)))
+#define C_ub_i_pointer_s32_ref(p) (*((C_s32 *)(p)))
+#define C_ub_i_pointer_f32_ref(p) (*((float *)(p)))
+#define C_ub_i_pointer_f64_ref(p) (*((double *)(p)))
+#define C_ub_i_pointer_u8_set(p, n) (*((unsigned char *)(p)) = (n))
+#define C_ub_i_pointer_s8_set(p, n) (*((char *)(p)) = (n))
+#define C_ub_i_pointer_u16_set(p, n) (*((unsigned short *)(p)) = (n))
+#define C_ub_i_pointer_s16_set(p, n) (*((short *)(p)) = (n))
+#define C_ub_i_pointer_u32_set(p, n) (*((C_u32 *)(p)) = (n))
+#define C_ub_i_pointer_s32_set(p, n) (*((C_s32 *)(p)) = (n))
+#define C_ub_i_pointer_f32_set(p, n) (*((float *)(p)) = (n))
+#define C_ub_i_pointer_f64_set(p, n) (*((double *)(p)) = (n))
+
#define C_end_of_main
#ifdef C_PRIVATE_REPOSITORY
diff --git a/lolevel.scm b/lolevel.scm
index 64544d02..2139e6e5 100644
--- a/lolevel.scm
+++ b/lolevel.scm
@@ -45,7 +45,6 @@
#endif
#define C_w2b(x) C_fix(C_wordstobytes(C_unfix(x)))
-#define C_pointer_eqp(x, y) C_mk_bool(C_c_pointer_nn(x) == C_c_pointer_nn(y))
#define C_memmove_o(to, from, n, toff, foff) C_memmove((char *)(to) + (toff), (char *)(from) + (foff), (n))
EOF
) )
@@ -355,54 +354,23 @@ EOF
;;; SRFI-4 number-vector:
-(define pointer-u8-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((unsigned char *)p) = n;"))
-(define pointer-s8-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((char *)p) = n;"))
-(define pointer-u16-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((unsigned short *)p) = n;"))
-(define pointer-s16-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((short *)p) = n;"))
-(define pointer-u32-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((C_u32 *)p) = n;"))
-(define pointer-s32-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((C_s32 *)p) = n;"))
-(define pointer-f32-set! (foreign-lambda* void ([c-pointer p] [double n]) "*((float *)p) = n;"))
-(define pointer-f64-set! (foreign-lambda* void ([c-pointer p] [float n]) "*((double *)p) = n;"))
-
-(define pointer-u8-ref
- (getter-with-setter
- (foreign-lambda* int ([c-pointer p]) "return(*((unsigned char *)p));")
- pointer-u8-set!) )
-
-(define pointer-s8-ref
- (getter-with-setter
- (foreign-lambda* int ([c-pointer p]) "return(*((signed char *)p));")
- pointer-s8-set!) )
-
-(define pointer-u16-ref
- (getter-with-setter
- (foreign-lambda* int ([c-pointer p]) "return(*((unsigned short *)p));")
- pointer-u16-set!) )
-
-(define pointer-s16-ref
- (getter-with-setter
- (foreign-lambda* int ([c-pointer p]) "return(*((short *)p));")
- pointer-s6-set!) )
-
-(define pointer-u32-ref
- (getter-with-setter
- (foreign-lambda* integer ([c-pointer p]) "return(*((C_u32 *)p));")
- pointer-u32-set!) )
-
-(define pointer-s32-ref
- (getter-with-setter
- (foreign-lambda* integer ([c-pointer p]) "return(*((C_s32 *)p));")
- pointer-s32-set!) )
-
-(define pointer-f32-ref
- (getter-with-setter
- (foreign-lambda* float ([c-pointer p]) "return(*((float *)p));")
- pointer-f32-set!) )
-
-(define pointer-f64-ref
- (getter-with-setter
- (foreign-lambda* double ([c-pointer p]) "return(*((double *)p));")
- pointer-f64-set!) )
+(define (pointer-u8-set! p n) (##core#inline "C_u_i_pointer_u8_set" p n))
+(define (pointer-s8-set! p n) (##core#inline "C_u_i_pointer_s8_set" p n))
+(define (pointer-u16-set! p n) (##core#inline "C_u_i_pointer_u16_set" p n))
+(define (pointer-s16-set! p n) (##core#inline "C_u_i_pointer_s16_set" p n))
+(define (pointer-u32-set! p n) (##core#inline "C_u_i_pointer_u32_set" p n))
+(define (pointer-s32-set! p n) (##core#inline "C_u_i_pointer_s32_set" p n))
+(define (pointer-f32-set! p n) (##core#inline "C_u_i_pointer_f32_set" p n))
+(define (pointer-f64-set! p n) (##core#inline "C_u_i_pointer_f64_set" p n))
+
+(define (pointer-u8-ref p) (##core#inline "C_u_i_pointer_u8_ref" p))
+(define (pointer-s8-ref p) (##core#inline "C_u_i_pointer_s8_ref" p))
+(define (pointer-u16-ref p) (##core#inline "C_u_i_pointer_u16_ref" p))
+(define (pointer-s16-ref p) (##core#inline "C_u_i_pointer_s16_ref" p))
+(define (pointer-u32-ref p) (##core#inline_allocate ("C_a_u_i_pointer_u32_ref" 4) p))
+(define (pointer-s32-ref p) (##core#inline_allocate ("C_a_u_i_pointer_s32_ref" 4) p))
+(define (pointer-f32-ref p) (##core#inline_allocate ("C_a_u_i_pointer_f32_ref" 4) p))
+(define (pointer-f64-ref p) (##core#inline_allocate ("C_a_u_i_pointer_f64_ref" 4) p))
;;; Procedures extended with data:
diff --git a/manual/faq b/manual/faq
index beca0597..ec91855c 100644
--- a/manual/faq
+++ b/manual/faq
@@ -463,6 +463,11 @@ The following extended bindings are handled specially:
{{hash-table-ref}}
{{block-set!}} {{number-of-slots}}
{{first}} {{second}} {{third}} {{fourth}} {{null-pointer?}} {{pointer->object}}
+{{pointer+}} {{pointer=?}}
+{{pointer-u8-ref}} {{pointer-s8-ref}} {{pointer-u16-ref}} {{pointer-s16-ref}}
+{{pointer-u32-ref}} {{pointer-s32-ref}} {{pointer-f32-ref}} {{pointer-f64-ref}}
+{{pointer-u8-set!}} {{pointer-s8-set!}} {{pointer-u16-set!}} {{pointer-s16-set!}}
+{{pointer-u32-set!}} {{pointer-s32-set!}} {{pointer-f32-set!}} {{pointer-f64-set!}}
{{make-record-instance}}
{{locative-ref}} {{locative-set!}} {{locative?}} {{locative->object}} {{identity}}
{{cpu-time}} {{error}} {{call/cc}} {{any?}}
diff --git a/support.scm b/support.scm
index 520d26ba..6b7b6d82 100644
--- a/support.scm
+++ b/support.scm
@@ -261,7 +261,9 @@
(if (exn? ex)
(exn-msg ex)
(->string ex) ) )
- (let ([xs (with-input-from-string str (lambda () (unfold eof-object? values (lambda (x) (read)) (read))))])
+ (let ([xs (with-input-from-string
+ str
+ (lambda () (unfold eof-object? values (lambda (x) (read)) (read))))])
(cond [(null? xs) '(##core#undefined)]
[(null? (cdr xs)) (car xs)]
[else `(begin ,@xs)] ) ) ) ) ) )
diff --git a/unboxing.scm b/unboxing.scm
index 67c2f326..28e6a65a 100644
--- a/unboxing.scm
+++ b/unboxing.scm
@@ -35,7 +35,7 @@
(when (##sys#fudge 13)
(printf "[debug] ~?~%" fstr args)) )
-(define-syntax d (syntax-rules () ((_ . _) (void))))
+;(define-syntax d (syntax-rules () ((_ . _) (void))))
(define (perform-unboxing! node)
@@ -47,12 +47,14 @@
(let ((ae '()))
(define (boxed! v) ; 'boxed is sticky
+ (d "boxing ~a" v )
(cond ((assq v e) =>
(lambda (a)
(set-cdr! a #f) ) )
(else (set! e (alist-cons v #f e)))))
(define (unboxed! v t)
+ (d "unboxing ~a -> ~a" v t)
(cond ((assq v e) =>
(lambda (a)
(if (cdr a)
@@ -248,7 +250,7 @@
(let ((subs (node-subexpressions n))
(params (node-parameters n))
(class (node-class n)) )
- ;;(d "walk: (~a) ~a ~a" pass2? class params)
+ (d "walk: (~a) ~a ~a" pass2? class params)
(case class
((##core#undefined
@@ -289,10 +291,9 @@
(any unboxed-value? args))
(let ((alt (first rw))
(atypes (second rw))
- (rtype (third rw))
- (safe? (fourth rw)))
+ (rtype (third rw)))
;; result or arguments are unboxed - rewrite node to alternative
- (when (and (or unsafe safe?) pass2?)
+ (when pass2?
(rewrite!
n alt subs args atypes rtype
(and dest (assq dest e))))
@@ -369,7 +370,7 @@
(for-each (o invalidate (cut walk <> #f #f pass2?)) subs)
#f))))
- ;(d "walk lambda: ~a" id)
+ (d "walk lambda: ~a" id)
(walk body #f #f #f)
(walk body #f #f #t)))
@@ -387,14 +388,8 @@
(begin
(register-unboxed-op #f 'name 'atypes 'rtype 'alt) ...))))
-(define-syntax define-safe-unboxed-ops
- (syntax-rules ()
- ((_ (name atypes rtype alt) ...)
- (begin
- (register-unboxed-op #t 'name 'atypes 'rtype 'alt) ...))))
-
-(define (register-unboxed-op safe? name atypes rtype alt)
- (##sys#put! (symbolify name) '##compiler#unboxed-op (list alt atypes rtype safe?)))
+(define (register-unboxed-op name atypes rtype alt)
+ (##sys#put! (symbolify name) '##compiler#unboxed-op (list alt atypes rtype)))
;; unboxed rewrites
@@ -430,24 +425,22 @@
(C_flonum_lessp (flonum flonum) bool "C_ub_i_flonum_lessp")
(C_flonum_greater_or_equal_p (flonum flonum) bool "C_ub_i_flonum_greater_or_equal_p")
(C_flonum_less_or_equal_p (flonum flonum) bool "C_ub_i_flonum_less_or_equal_p")
- ; address->pointer
- ; pointer->address
- ; pointer+
- ; pointer=?
- ; pointer-u8-ref
- ; pointer-s8-ref
- ; pointer-u16-ref
- ; pointer-s16-ref
- ; pointer-u32-ref
- ; pointer-s32-ref
- ; pointer-f32-ref
- ; pointer-f64-ref
- ; pointer-u8-set!
- ; pointer-s8-set!
- ; pointer-u16-set!
- ; pointer-s16-set!
- ; pointer-u32-set!
- ; pointer-s32-set!
- ; pointer-f32-set!
- ; pointer-f64-set!
+ (C_a_u_i_pointer_inc (pointer fixnum) pointer "C_ub_i_pointer_inc")
+ (C_pointer_eqp (pointer pointer) bool "C_ub_i_pointer_eqp")
+ (C_u_i_pointer_u8_ref (pointer) fixnum "C_ub_i_pointer_u8_ref")
+ (C_u_i_pointer_s8_ref (pointer) fixnum "C_ub_i_pointer_s8_ref")
+ (C_u_i_pointer_u16_ref (pointer) fixnum "C_ub_i_pointer_u16_ref")
+ (C_u_i_pointer_s16_ref (pointer) fixnum "C_ub_i_pointer_s16_ref")
+ (C_u_i_pointer_u32_ref (pointer) fixnum "C_ub_i_pointer_u32_ref")
+ (C_u_i_pointer_s32_ref (pointer) fixnum "C_ub_i_pointer_s32_ref")
+ (C_u_i_pointer_f32_ref (pointer) flonum "C_ub_i_pointer_f32_ref")
+ (C_u_i_pointer_f64_ref (pointer) flonum "C_ub_i_pointer_f64_ref")
+ (C_u_i_pointer_u8_set (pointer fixnum) fixnum "C_ub_i_pointer_u8_ref")
+ (C_u_i_pointer_s8_set (pointer fixnum) fixnum "C_ub_i_pointer_s8_ref")
+ (C_u_i_pointer_u16_set (pointer fixnum) fixnum "C_ub_i_pointer_u16_ref")
+ (C_u_i_pointer_s16_set (pointer fixnum) fixnum "C_ub_i_pointer_s16_ref")
+ (C_u_i_pointer_u32_set (pointer fixnum) fixnum "C_ub_i_pointer_u32_ref")
+ (C_u_i_pointer_s32_set (pointer fixnum) fixnum "C_ub_i_pointer_s32_ref")
+ (C_u_i_pointer_f32_set (pointer flonum) flonum "C_ub_i_pointer_f32_ref")
+ (C_u_i_pointer_f64_set (pointer flonum) flonum "C_ub_i_pointer_f64_ref")
)
Trap