~ chicken-core (chicken-5) d1217287c0b508e4495093b0114c37ca3c64e6c4
commit d1217287c0b508e4495093b0114c37ca3c64e6c4
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Jan 27 21:16:08 2011 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Thu Jan 27 21:16:08 2011 +0100
changed argument-ref syntax for specializations; spec.s for fp-ops; works; happy
diff --git a/compiler-syntax.scm b/compiler-syntax.scm
index eec4f7e6..9d199ccc 100644
--- a/compiler-syntax.scm
+++ b/compiler-syntax.scm
@@ -185,9 +185,9 @@
(define (fail ret? msg . args)
(let ((ln (get-line x)))
(warning
- (sprintf "`~a', in format string ~s~a, ~?"
+ (sprintf "~a`~a', in format string ~s, ~?"
+ (if ln (sprintf "(~a) " ln) "")
func fstr
- (if ln (sprintf "(~a)" ln) "")
msg args) ))
(when ret? (return #f)))
(let ((code '())
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 31206f6b..71613ad4 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -26,7 +26,7 @@
(declare
(unit scrutinizer)
- (hide match-specialization specialize-node!))
+ (hide match-specialization specialize-node! specialization-statistics))
(include "compiler-namespace")
@@ -67,7 +67,8 @@
;
; SPECIALIZATION = ((MVAL ... [#!rest MVAL]) TEMPLATE)
; MVAL = VAL | (not VAL) | (or VAL ...)
-; TEMPLATE = INTEGER | SYMBOL | STRING
+; TEMPLATE = #(INDEX)
+; | INTEGER | SYMBOL | STRING
; | (quote CONSTANT)
; | (TEMPLATE . TEMPLATE)
@@ -75,6 +76,8 @@
(define-constant +fragment-max-length+ 5)
(define-constant +fragment-max-depth+ 3)
+(define specialization-statistics '())
+
(define (scrutinize node db complain specialize)
(define (constant-result lit)
(cond ((string? lit) 'string)
@@ -492,7 +495,12 @@
(for-each
(lambda (spec)
(when (match-specialization (car spec) (cdr args))
- (debugging 'x "specializing call" (cons pn (car spec)))
+ (let ((op (cons pn (car spec))))
+ (cond ((assoc op specialization-statistics) =>
+ (lambda (a) (set-cdr! a (add1 (cdr a)))))
+ (else
+ (set! specialization-statistics
+ (cons (cons op 1) specialization-statistics)))))
(specialize-node! node (cadr spec))))
specs)))
r))))
@@ -662,7 +670,13 @@
'*))))
(d " -> ~a" results)
results)))
- (walk (first (node-subexpressions node)) '() '() #f #f))
+ (let ((rn (walk (first (node-subexpressions node)) '() '() #f #f)))
+ (when (debugging 'x "specializations:")
+ (for-each
+ (lambda (ss)
+ (printf " ~a ~s~%" (cdr ss) (car ss)))
+ specialization-statistics))
+ rn))
(define (load-type-database name #!optional (path (repository-path)))
(and-let* ((dbfile (file-exists? (make-pathname path name))))
@@ -703,7 +717,10 @@
(define (specialize-node! node template)
(let ((args (cdr (node-subexpressions node))))
(define (subst x)
- (cond ((integer? x) (list-ref args (sub1 x)))
+ (cond ((and (vector? x)
+ (= 1 (vector-length x))
+ (integer? (vector-ref x 0)))
+ (list-ref args (sub1 (vector-ref x 0))))
((not (pair? x)) x)
((eq? 'quote (car x)) x) ; to handle numeric constants
(else (cons (subst (car x)) (subst (cdr x))))))
diff --git a/types.db b/types.db
index fe9f16dc..9d291514 100644
--- a/types.db
+++ b/types.db
@@ -26,7 +26,8 @@
;; scheme
-(not (procedure not (*) boolean))
+(not (procedure not (*) boolean)
+ ((not boolean) #t))
(boolean? (procedure boolean (*) boolean))
(eq? (procedure eq? (* *) boolean))
(eqv? (procedure eqv? (* *) boolean))
@@ -84,7 +85,8 @@
(symbol->string (procedure symbol->string (symbol) string))
(string->symbol (procedure string->symbol (string) symbol))
(number? (procedure number? (*) boolean))
-(integer? (procedure integer? (*) boolean))
+(integer? (procedure integer? (*) boolean)
+ ((float) (fpinteger? #(1))))
(exact? (procedure exact? (*) boolean))
(real? (procedure real? (*) boolean))
(complex? (procedure complex? (*) boolean))
@@ -95,40 +97,67 @@
(even? (procedure even? (number) boolean))
(positive? (procedure positive? (number) boolean))
(negative? (procedure negative? (number) boolean))
-(max (procedure max (#!rest number) number))
-(min (procedure min (#!rest number) number))
+(max (procedure max (#!rest number) number)
+ ((float float) (fpmax #(1) #(2))))
+(min (procedure min (#!rest number) number)
+ ((float float) (fpmin #(1) #(2))))
(+ (procedure + (#!rest number) number)
- ((float float) (fp+ 1 2)))
-(- (procedure - (number #!rest number) number))
-(* (procedure * (#!rest number) number))
-(/ (procedure / (number #!rest number) number))
-(= (procedure = (#!rest number) boolean))
-(> (procedure > (#!rest number) boolean))
-(< (procedure < (#!rest number) boolean))
-(>= (procedure >= (#!rest number) boolean))
-(<= (procedure <= (#!rest number) boolean))
+ ((float float) (fp+ #(1) #(2))))
+(- (procedure - (number #!rest number) number)
+ ((float float) (fp- #(1) #(2)))
+ ((float) (fpneg #(1))))
+(* (procedure * (#!rest number) number)
+ ((float float) (fp* #(1) #(2))))
+(/ (procedure / (number #!rest number) number)
+ ((float float) (fp/ #(1) #(2))))
+(= (procedure = (#!rest number) boolean)
+ ((float float) (fp= #(1) #(2))))
+(> (procedure > (#!rest number) boolean)
+ ((float float) (fp> #(1) #(2))))
+(< (procedure < (#!rest number) boolean)
+ ((float float) (fp< #(1) #(2))))
+(>= (procedure >= (#!rest number) boolean)
+ ((float float) (fp>= #(1) #(2))))
+(<= (procedure <= (#!rest number) boolean)
+ ((float float) (fp<0 #(1) #(2))))
(quotient (procedure quotient (number number) number))
(remainder (procedure remainder (number number) number))
(modulo (procedure modulo (number number) number))
(gcd (procedure gcd (#!rest number) number))
(lcm (procedure lcm (#!rest number) number))
-(abs (procedure abs (number) number))
-(floor (procedure floor (number) number))
-(ceiling (procedure ceiling (number) number))
-(truncate (procedure truncate (number) number))
-(round (procedure round (number) number))
+(abs (procedure abs (number) number)
+ ((float) (fpabs #(1))))
+(floor (procedure floor (number) number)
+ ((float) (fpfloor #(1))))
+(ceiling (procedure ceiling (number) number)
+ ((float) (fpceiling #(1))))
+(truncate (procedure truncate (number) number)
+ ((float) (fptruncate #(1))))
+(round (procedure round (number) number)
+ ((float) (fpround #(1))))
(exact->inexact (procedure exact->inexact (number) number))
(inexact->exact (procedure inexact->exact (number) number))
-(exp (procedure exp (number) float))
-(log (procedure log (number) float))
-(expt (procedure expt (number number) number))
-(sqrt (procedure sqrt (number) float))
-(sin (procedure sin (number) float))
-(cos (procedure cos (number) float))
-(tan (procedure tan (number) float))
-(asin (procedure asin (number) float))
-(acos (procedure acos (number) float))
-(atan (procedure atan (number #!optional number) float))
+(exp (procedure exp (number) float)
+ ((float) (fpexp #(1))))
+(log (procedure log (number) float)
+ ((float) (fplog #(1))))
+(expt (procedure expt (number number) number)
+ ((float) (fpexpt #(1))))
+(sqrt (procedure sqrt (number) float)
+ ((float) (fpsqrt #(1))))
+(sin (procedure sin (number) float)
+ ((float) (fpsin #(1))))
+(cos (procedure cos (number) float)
+ ((float) (fpcos #(1))))
+(tan (procedure tan (number) float)
+ ((float) (fptab #(1))))
+(asin (procedure asin (number) float)
+ ((float) (fpasin #(1))))
+(acos (procedure acos (number) float)
+ ((float) (fpacos #(1))))
+(atan (procedure atan (number #!optional number) float)
+ ((float) (fpatan #(1)))
+ ((float float) (fpatan2 #(1) #(2))))
(number->string (procedure number->string (number #!optional number) string))
(string->number (procedure string->number (string #!optional number) (or number boolean)))
(char? (procedure char? (*) boolean))
Trap