~ chicken-core (chicken-5) c8fce88bd33f406b10fdb1f6783cce36ded456d8
commit c8fce88bd33f406b10fdb1f6783cce36ded456d8
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Sep 8 06:11:35 2010 -0400
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Sep 8 06:11:35 2010 -0400
new declaration unsafe-specialized-arithmetic and unboxing changes
diff --git a/batch-driver.scm b/batch-driver.scm
index 040c6cf3..65923f92 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -602,7 +602,7 @@
(> (- (cputime) start-time) funny-message-timeout))
(display "(don't worry - still compiling...)\n") )
(print-node "closure-converted" '|9| node2)
- (when (and unbox unsafe)
+ (when (and unbox (or unsafe unchecked-specialized-arithmetic))
(debugging 'p "performing unboxing")
(begin-time)
(perform-unboxing! node2)
diff --git a/c-platform.scm b/c-platform.scm
index 7c4fe8dc..147a536a 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -604,7 +604,7 @@
(rewrite 'flonum? 2 1 "C_i_flonump" #t)
(rewrite 'fixnum? 2 1 "C_fixnump" #t)
(rewrite 'finite? 2 1 "C_i_finitep" #f)
-(rewrite 'fpinteger? 2 1 "C_u_i_fpintegerp" #f)
+(rewrite 'fpinteger? 2 1 "C_u_i_fpintegerp" 'specialized)
(rewrite '##sys#pointer? 2 1 "C_anypointerp" #t)
(rewrite 'pointer? 2 1 "C_i_safe_pointerp" #t)
(rewrite '##sys#generic-structure? 2 1 "C_structurep" #t)
@@ -638,15 +638,15 @@
(rewrite 'fx< 2 2 "C_fixnum_lessp" #t)
(rewrite 'fx>= 2 2 "C_fixnum_greater_or_equal_p" #t)
(rewrite 'fx<= 2 2 "C_fixnum_less_or_equal_p" #t)
-(rewrite 'fp= 2 2 "C_flonum_equalp" #f)
-(rewrite 'fp> 2 2 "C_flonum_greaterp" #f)
-(rewrite 'fp< 2 2 "C_flonum_lessp" #f)
-(rewrite 'fp>= 2 2 "C_flonum_greater_or_equal_p" #f)
-(rewrite 'fp<= 2 2 "C_flonum_less_or_equal_p" #f)
+(rewrite 'fp= 2 2 "C_flonum_equalp" 'specialized)
+(rewrite 'fp> 2 2 "C_flonum_greaterp" 'specialized)
+(rewrite 'fp< 2 2 "C_flonum_lessp" 'specialized)
+(rewrite 'fp>= 2 2 "C_flonum_greater_or_equal_p" 'specialized)
+(rewrite 'fp<= 2 2 "C_flonum_less_or_equal_p" 'specialized)
(rewrite 'fxmax 2 2 "C_i_fixnum_max" #t)
(rewrite 'fxmin 2 2 "C_i_fixnum_min" #t)
-(rewrite 'fpmax 2 2 "C_i_flonum_max" #f)
-(rewrite 'fpmin 2 2 "C_i_flonum_min" #f)
+(rewrite 'fpmax 2 2 "C_i_flonum_max" 'specialized)
+(rewrite 'fpmin 2 2 "C_i_flonum_min" 'specialized)
(rewrite 'char-numeric? 2 1 "C_u_i_char_numericp" #t)
(rewrite 'char-alphabetic? 2 1 "C_u_i_char_alphabeticp" #t)
(rewrite 'char-whitespace? 2 1 "C_u_i_char_whitespacep" #t)
@@ -683,11 +683,11 @@
(rewrite 'bitwise-not 22 1 "C_a_i_bitwise_not" #t words-per-flonum "C_fixnum_not")
-(rewrite 'fp+ 16 2 "C_a_i_flonum_plus" #t words-per-flonum)
-(rewrite 'fp- 16 2 "C_a_i_flonum_difference" #t words-per-flonum)
-(rewrite 'fp* 16 2 "C_a_i_flonum_times" #t words-per-flonum)
-(rewrite 'fp/ 16 2 "C_a_i_flonum_quotient" #t words-per-flonum)
-(rewrite 'fpneg 16 1 "C_a_i_flonum_negate" #t words-per-flonum)
+(rewrite 'fp+ 16 2 "C_a_i_flonum_plus" 'specialized words-per-flonum)
+(rewrite 'fp- 16 2 "C_a_i_flonum_difference" 'specialized words-per-flonum)
+(rewrite 'fp* 16 2 "C_a_i_flonum_times" 'specialized words-per-flonum)
+(rewrite 'fp/ 16 2 "C_a_i_flonum_quotient" 'specialized words-per-flonum)
+(rewrite 'fpneg 16 1 "C_a_i_flonum_negate" 'specialized words-per-flonum)
(rewrite 'exp 16 1 "C_a_i_exp" #t words-per-flonum)
(rewrite 'sin 16 1 "C_a_i_sin" #t words-per-flonum)
@@ -824,22 +824,22 @@
(rewrite 'truncate 15 'flonum 'fixnum 'fptruncate #f)
(rewrite 'round 15 'flonum 'fixnum 'fpround #f)
-(rewrite 'fpsin 16 1 "C_a_i_flonum_sin" #f words-per-flonum)
-(rewrite 'fpcos 16 1 "C_a_i_flonum_cos" #f words-per-flonum)
-(rewrite 'fptan 16 1 "C_a_i_flonum_tan" #f words-per-flonum)
-(rewrite 'fpasin 16 1 "C_a_i_flonum_asin" #f words-per-flonum)
-(rewrite 'fpacos 16 1 "C_a_i_flonum_acos" #f words-per-flonum)
-(rewrite 'fpatan 16 1 "C_a_i_flonum_atan" #f words-per-flonum)
-(rewrite 'fpatan2 16 2 "C_a_i_flonum_atan2" #f words-per-flonum)
-(rewrite 'fpexp 16 1 "C_a_i_flonum_exp" #f words-per-flonum)
-(rewrite 'fpexpt 16 2 "C_a_i_flonum_expt" #f words-per-flonum)
-(rewrite 'fplog 16 1 "C_a_i_flonum_log" #f words-per-flonum)
-(rewrite 'fpsqrt 16 1 "C_a_i_flonum_sqrt" #f words-per-flonum)
-(rewrite 'fpabs 16 1 "C_a_i_flonum_abs" #f words-per-flonum)
-(rewrite 'fptruncate 16 1 "C_a_i_flonum_truncate" #f words-per-flonum)
-(rewrite 'fpround 16 1 "C_a_i_flonum_truncate" #f words-per-flonum)
-(rewrite 'fpceiling 16 1 "C_a_i_flonum_truncate" #f words-per-flonum)
-(rewrite 'fpround 16 1 "C_a_i_flonum_truncate" #f words-per-flonum)
+(rewrite 'fpsin 16 1 "C_a_i_flonum_sin" 'specialized words-per-flonum)
+(rewrite 'fpcos 16 1 "C_a_i_flonum_cos" 'specialized words-per-flonum)
+(rewrite 'fptan 16 1 "C_a_i_flonum_tan" 'specialized words-per-flonum)
+(rewrite 'fpasin 16 1 "C_a_i_flonum_asin" 'specialized words-per-flonum)
+(rewrite 'fpacos 16 1 "C_a_i_flonum_acos" 'specialized words-per-flonum)
+(rewrite 'fpatan 16 1 "C_a_i_flonum_atan" 'specialized words-per-flonum)
+(rewrite 'fpatan2 16 2 "C_a_i_flonum_atan2" 'specialized words-per-flonum)
+(rewrite 'fpexp 16 1 "C_a_i_flonum_exp" 'specialized words-per-flonum)
+(rewrite 'fpexpt 16 2 "C_a_i_flonum_expt" 'specialized words-per-flonum)
+(rewrite 'fplog 16 1 "C_a_i_flonum_log" 'specialized words-per-flonum)
+(rewrite 'fpsqrt 16 1 "C_a_i_flonum_sqrt" 'specialized words-per-flonum)
+(rewrite 'fpabs 16 1 "C_a_i_flonum_abs" 'specialized words-per-flonum)
+(rewrite 'fptruncate 16 1 "C_a_i_flonum_truncate" 'specialized words-per-flonum)
+(rewrite 'fpround 16 1 "C_a_i_flonum_truncate" 'specialized words-per-flonum)
+(rewrite 'fpceiling 16 1 "C_a_i_flonum_truncate" 'specialized words-per-flonum)
+(rewrite 'fpround 16 1 "C_a_i_flonum_truncate" 'specialized words-per-flonum)
(rewrite 'cons 16 2 "C_a_i_cons" #t 3)
(rewrite '##sys#cons 16 2 "C_a_i_cons" #t 3)
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index 91c1ecff..b3328011 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -277,6 +277,7 @@
toplevel-scope
transform-direct-lambdas!
tree-copy
+ unchecked-specialized-arithmetic
undefine-shadowed-macros
unique-id
unit-name
diff --git a/compiler.scm b/compiler.scm
index ef70a0db..07a2617e 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -72,7 +72,7 @@
; (unsafe)
; (unused <symbol> ...)
; (uses {<unitname>})
-; (scrutinize)
+; (unsafe-specialized-arithmetic)
;
; <type> = fixnum | generic
@@ -336,6 +336,7 @@
(define do-scrutinize #f)
(define enable-inline-files #f)
(define compiler-syntax-enabled #t)
+(define unchecked-specialized-arithmetic #f)
;;; These are here so that the backend can access them:
@@ -1467,8 +1468,8 @@
(else
(warning "illegal `type' declaration item" spec))))
(globalize-all (cdr spec))))
- ((scrutinize)
- (set! do-scrutinize #t))
+ ((unsafe-specialized-arithmetic)
+ (set! unchecked-specialized-arithmetic #t))
(else (warning "illegal declaration specifier" spec)) )
'(##core#undefined) ) ) )
diff --git a/manual/Declarations b/manual/Declarations
index 621de369..cc172cde 100644
--- a/manual/Declarations
+++ b/manual/Declarations
@@ -263,13 +263,6 @@ that any calls to these variables can always be assumed to be calls to proper
procedures.
-=== scrutinize
-
- [declaration specifier] (scrutinize)
-
-Enables scrutiny. This is equivalent to passing the {{-scrutinize}} option to the compiler.
-
-
=== standard-bindings
[declaration specifier] (standard-bindings SYMBOL ...)
diff --git a/optimizer.scm b/optimizer.scm
index 0b225971..3d6830e2 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -845,6 +845,7 @@
;; (<op> ...) -> (##core#inline <iop> ...)
((2) ; classargs = (<argc> <iop> <safe>)
+ ;; - <safe> by be 'specialized (see rule #16 below)
(and inline-substitutions-enabled
(= (length callargs) (first classargs))
(intrinsic? name)
@@ -1042,14 +1043,20 @@
;; number of arguments plus 1.
;; - if <counted> is given and true and <argc> is between 1-8, append "<count>"
;; to the name of the inline routine.
+ ;; - if <safe> is 'specialized and `unsafe-specialized-arithmetic' is declared,
+ ;; then assume it is safe
(let ((argc (first classargs))
(rargc (length callargs))
+ (safe (third classargs))
(w (fourth classargs))
(counted (and (pair? (cddddr classargs)) (fifth classargs))))
(and inline-substitutions-enabled
(or (not argc) (= rargc argc))
(intrinsic? name)
- (or (third classargs) unsafe)
+ (or unsafe
+ (if (eq? safe 'specialized)
+ unchecked-specialized-arithmetic
+ safe))
(make-node
'##core#call '(#t)
(list cont
diff --git a/unboxing.scm b/unboxing.scm
index 9e4d1dd2..cd5c7370 100644
--- a/unboxing.scm
+++ b/unboxing.scm
@@ -283,7 +283,12 @@
a))
((##core#inline ##core#inline_allocate)
- (let* ((rw (##sys#get (symbolify (first params)) '##compiler#unboxed-op))
+ (let* ((rw1 (##sys#get (symbolify (first params)) '##compiler#unboxed-op))
+ (rw (and rw1
+ (or unsafe
+ (and (fourth rw1)
+ unchecked-specialized-arithmetic))
+ rw1))
(args (map (cut walk <> #f rw pass2?) subs)))
(cond ((not rw) #f)
((or (not pass2?)
@@ -376,7 +381,7 @@
(walk-lambda #f '() node)
(when (and any-rewrites
- (debugging 'x #;'o "unboxed rewrites:")) ;XXX
+ (debugging 'o "unboxed rewrites:"))
(##sys#hash-table-for-each
(lambda (k v)
(printf " ~a\t~a~%" k v) )
@@ -386,19 +391,31 @@
(syntax-rules ()
((_ (name atypes rtype alt) ...)
(begin
- (register-unboxed-op 'name 'atypes 'rtype 'alt) ...))))
+ (register-unboxed-op 'name 'atypes 'rtype 'alt #f) ...))))
-(define (register-unboxed-op name atypes rtype alt)
- (##sys#put! (symbolify name) '##compiler#unboxed-op (list alt atypes rtype)))
+(define-syntax define-unboxed-arithmetic-ops
+ (syntax-rules ()
+ ((_ (name atypes rtype alt) ...)
+ (begin
+ (register-unboxed-op 'name 'atypes 'rtype 'alt #t) ...))))
+
+(define (register-unboxed-op name atypes rtype alt arithmetic)
+ (##sys#put! (symbolify name) '##compiler#unboxed-op (list alt atypes rtype arithmetic)))
;; unboxed rewrites
-(define-unboxed-ops
+(define-unboxed-arithmetic-ops
(C_a_i_flonum_plus (flonum flonum) flonum "C_ub_i_flonum_plus")
(C_a_i_flonum_difference (flonum flonum) flonum "C_ub_i_flonum_difference")
(C_a_i_flonum_times (flonum flonum) flonum "C_ub_i_flonum_times")
(C_a_i_flonum_quotient (flonum flonum) flonum "C_ub_i_flonum_quotient")
+ (C_u_i_fpintegerp (flonum) bool "C_ub_i_fpintegerp")
+ (C_flonum_equalp (flonum flonum) bool "C_ub_i_flonum_equalp")
+ (C_flonum_greaterp (flonum flonum) bool "C_ub_i_flonum_greaterp")
+ (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")
(C_a_i_flonum_sin (flonum) flonum "C_sin")
(C_a_i_flonum_cos (flonum) flonum "C_cos")
(C_a_i_flonum_tan (flonum) flonum "C_tab")
@@ -414,17 +431,13 @@
(C_a_i_flonum_truncate (flonum) flonum "C_trunc")
(C_a_i_flonum_ceiling (flonum) flonum "C_ceil")
(C_a_i_flonum_floor (flonum) flonum "C_floor")
- (C_a_i_flonum_round (flonum) flonum "C_round")
+ (C_a_i_flonum_round (flonum) flonum "C_round"))
+
+(define-unboxed-ops
(C_u_i_f32vector_set (* fixnum flonum) fixnum "C_ub_i_f32vector_set")
(C_u_i_f64vector_set (* fixnum flonum) fixnum "C_ub_i_f64vector_set")
(C_a_i_f32vector_ref (* fixnum) flonum "C_ub_i_f32vector_ref")
(C_a_i_f64vector_ref (* fixnum) flonum "C_ub_i_f64vector_ref")
- (C_u_i_fpintegerp (flonum) bool "C_ub_i_fpintegerp")
- (C_flonum_equalp (flonum flonum) bool "C_ub_i_flonum_equalp")
- (C_flonum_greaterp (flonum flonum) bool "C_ub_i_flonum_greaterp")
- (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")
(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")
@@ -443,5 +456,4 @@
(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")
- (C_null_pointerp (pointer) bool "C_ub_i_null_pointerp")
- )
+ (C_null_pointerp (pointer) bool "C_ub_i_null_pointerp"))
Trap