~ chicken-core (chicken-5) f0724916bbbc8a61675c00cc8e6b188039fbd211
commit f0724916bbbc8a61675c00cc8e6b188039fbd211
Author: felix <bunny351@gmail.com>
AuthorDate: Wed Jun 9 14:26:48 2010 +0200
Commit: felix <bunny351@gmail.com>
CommitDate: Wed Jun 9 14:26:48 2010 +0200
elimination of unused results for procedures declared pure/constant - needs more testing (but already found some unused code)
diff --git a/c-platform.scm b/c-platform.scm
index f44504ca..110f9c1a 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -204,6 +204,31 @@
(lset-union eq? default-standard-bindings default-extended-bindings)
non-foldable-bindings) )
+(for-each
+ (cut mark-variable <> '##compiler#pure 'standard)
+ '(not boolean? eq? eqv? equal? pair? null? list? zero?
+ char? eof-object? symbol? number? complex? real? integer? rational? string?
+ procedure?))
+
+(for-each
+ (cut mark-variable <> '##compiler#pure 'extended)
+ '(fx+ fx- fx* fx/ fxmod
+ fx= fx> fx< fx>= fx<= fixnum? fxneg fxmax fxmin identity
+ fxand fxnot fxior fxxor fxshr fxshl fxodd? fxeven?
+ void not-pair? atom? any? u8vector? s8vector? u16vector? s16vector?
+ u32vector? s32vector? f32vector? f64vector?
+ locative? get-keyword) )
+
+(for-each
+ (cut mark-variable <> '##compiler#pure '#t)
+ '(##sys#slot ##sys#block-ref ##sys#size ##sys#byte
+ ##sys#pointer? ##sys#generic-structure? ##sys#fits-in-int? ##sys#fits-in-unsigned-int? ##sys#flonum-in-fixnum-range?
+ ##sys#fudge ##sys#immediate?
+ ##sys#bytevector? ##sys#pair?
+ ##sys#eq? ##sys#list? ##sys#vector? ##sys#eqv? ##sys#get-keyword
+ ##sys#void
+ ##sys#permanent?))
+
;;; Rewriting-definitions for this platform:
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index 7fde0db8..86280062 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -59,7 +59,6 @@
compiler-syntax-enabled
compiler-syntax-statistics
compute-database-statistics
- constant-declarations
constant-table
constant?
constants-used
diff --git a/compiler.scm b/compiler.scm
index 29a12b8e..5cbdc8d9 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -89,6 +89,7 @@
; ##compiler#profile -> BOOL
; ##compiler#unused -> BOOL
; ##compiler#foldable -> BOOL
+; ##compiler#pure -> 'standard | 'extended | BOOL
; - Source language:
;
@@ -324,7 +325,6 @@
(define inline-max-size default-inline-max-size)
(define emit-closure-info #t)
(define undefine-shadowed-macros #t)
-(define constant-declarations '())
(define profiled-procedures #f)
(define import-libraries '())
(define all-import-libraries #f)
@@ -1394,7 +1394,7 @@
((constant)
(let ((syms (cdr spec)))
(if (every symbol? syms)
- (set! constant-declarations (append syms constant-declarations))
+ (for-each (cut mark-variable <> '##compiler#pure #t) syms)
(quit "invalid arguments to `constant' declaration: ~S" spec)) ) )
((emit-import-library)
(set! import-libraries
@@ -2550,10 +2550,6 @@
(make-node '##core#setlocal (list i) (list (walk val e here boxes)) ) ) )
(else
(let* ([cval (node-class val)]
- [safe (not (or no-bound-checks
- unsafe
- (variable-mark var '##compiler#always-bound)
- (intrinsic? var)))]
[blockvar (not (variable-visible? var))]
[immf (or (and (eq? cval 'quote) (immediate? (first (node-parameters val))))
(eq? '##core#undefined cval) ) ] )
diff --git a/library.scm b/library.scm
index 90151124..53964c4d 100644
--- a/library.scm
+++ b/library.scm
@@ -1915,8 +1915,8 @@ EOF
(##sys#pathname-resolution
name
(lambda (name)
- (and-let* ((info (##sys#file-info (##sys#platform-fixup-pathname name))))
- (eq? 1 (vector-ref info 4))
+ (and-let* ((info (##sys#file-info (##sys#platform-fixup-pathname name)))
+ ((eq? 1 (vector-ref info 4))))
name))
#:exists?) )
@@ -3234,8 +3234,7 @@ EOF
(string-append (symbol->string x) "-") ) )
(string-append (str sv) (str st) (str bp) (##sys#symbol->string mt)) ) )
(if full
- (let ((rev (##sys#fudge 38))
- (spec (string-append
+ (let ((spec (string-append
(if (##sys#fudge 3) " 64bit" "")
(if (##sys#fudge 15) " symbolgc" "")
(if (##sys#fudge 40) " manyargs" "")
@@ -3360,7 +3359,6 @@ EOF
(lambda (info)
(let ((more1 (##sys#slot info 1))
(more2 (##sys#slot info 2))
- (t (##sys#slot info 3)))
(##sys#print "\n\t" #f port)
(##sys#print (##sys#slot info 0) #f port)
(##sys#print "\t\t" #f port)
@@ -4141,8 +4139,7 @@ EOF
(lambda (state)
(unless working
(set! working #t)
- (let* ([n (##sys#size ##sys#pending-finalizers)]
- [c (##sys#slot ##sys#pending-finalizers 0)] )
+ (let* ((c (##sys#slot ##sys#pending-finalizers 0)) )
(when (##sys#fudge 13)
(print "[debug] running " c " finalizers (" (##sys#fudge 26) " live, "
(##sys#fudge 27) " allocated) ..."))
diff --git a/optimizer.scm b/optimizer.scm
index 4e52ebd2..8ad7a2ba 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -276,7 +276,7 @@
(or (test var 'value)
(test var 'local-value)))]
[args (cdr subs)] )
- (cond [(test var 'contractable)
+ (cond ((test var 'contractable)
(let* ([lparams (node-parameters lval)]
[llist (third lparams)] )
(check-signature var args llist)
@@ -285,24 +285,32 @@
(for-each (cut put! db <> 'inline-target #t) fids)
(walk
(inline-lambda-bindings llist args (first (node-subexpressions lval)) #f db)
- fids) ) ]
- [(memq var constant-declarations)
- (or (and-let* ((k (car args))
- ((eq? '##core#variable (node-class k)))
- (kvar (first (node-parameters k)))
- (lval (and (not (test kvar 'unknown)) (test kvar 'value)))
- ((eq? '##core#lambda (node-class lval)))
- (llist (third (node-parameters lval)))
- ((or (test (car llist) 'unused)
- (and (not (test (car llist) 'references))
- (not (test (car llist) 'assigned)))))
- ((not (any (cut expression-has-side-effects? <> db) (cdr args) ))))
- (debugging 'x "removed call to constant procedure with unused result" var)
- (make-node
- '##core#call '(#t)
- (list k (make-node '##core#undefined '() '())) ) )
- (walk-generic n class params subs fids)) ]
- [(and lval
+ fids) ) )
+ ((variable-mark var '##compiler#pure) =>
+ (lambda (pb)
+ (or (and-let* ((k (car args))
+ ((or (eq? #t pb)
+ (let ((im (variable-mark var '##compiler#intrinsic)))
+ (or (eq? im 'internal) (eq? im pb)))))
+ ((eq? '##core#variable (node-class k)))
+ (kvar (first (node-parameters k)))
+ (lval (and (not (test kvar 'unknown)) (test kvar 'value)))
+ ((eq? '##core#lambda (node-class lval)))
+ (llist (third (node-parameters lval)))
+ ((or (test (car llist) 'unused)
+ (and (not (test (car llist) 'references))
+ (not (test (car llist) 'assigned)))))
+ ((not (any (cut expression-has-side-effects? <> db) (cdr args) ))))
+ (debugging
+ 'o
+ "removed call to pure procedure with unused result"
+ (or (source-info->string (and (pair? (cdr params)) (second params)))
+ var))
+ (make-node
+ '##core#call '(#t)
+ (list k (make-node '##core#undefined '() '())) ) )
+ (walk-generic n class params subs fids)) ) )
+ ((and lval
(eq? '##core#lambda (node-class lval)))
(let* ([lparams (node-parameters lval)]
[llist (third lparams)] )
@@ -311,7 +319,7 @@
(lambda (vars argc rest)
(let ((ifid (first lparams))
(external (node? (variable-mark var '##compiler#inline-global))))
- (cond [(and inline-locally
+ (cond ((and inline-locally
(test var 'inlinable)
(not (test ifid 'inline-target)) ; inlinable procedure has changed
(case (variable-mark var '##compiler#inline)
@@ -322,7 +330,7 @@
(debugging
'i
(if external
- "global inlining"
+ "global inlining"
"inlining")
var ifid (fourth lparams))
(for-each (cut put! db <> 'inline-target #t) fids)
@@ -331,8 +339,8 @@
(touch)
(walk
(inline-lambda-bindings llist args (first (node-subexpressions lval)) #t db)
- fids) ]
- [(test ifid 'has-unused-parameters)
+ fids) )
+ ((test ifid 'has-unused-parameters)
(if (< (length args) argc) ; Expression was already optimized (should this happen?)
(walk-generic n class params subs fids)
(let loop ((vars vars) (argc argc) (args args) (used '()))
@@ -357,8 +365,8 @@
[else (loop (cdr vars)
(sub1 argc)
(cdr args)
- (cons (car args) used) ) ] ) ) ) ]
- [(and (test ifid 'explicit-rest)
+ (cons (car args) used) ) ] ) ) ) )
+ ((and (test ifid 'explicit-rest)
(not (memq n rest-consers)) ) ; make sure we haven't inlined rest-list already
(let ([n (llist-length llist)])
(if (< (length args) n)
@@ -381,9 +389,9 @@
(list "C_a_i_list" (* 3 (length rargs)))
rargs) ) ) ) ) ) ) ] )
(set! rest-consers (cons n2 rest-consers))
- n2) ) ) ) ) ]
- [else (walk-generic n class params subs fids)] ) ) ) ) ) ]
- [else (walk-generic n class params subs fids)] ) ) ]
+ n2) ) ) ) ) )
+ (else (walk-generic n class params subs fids)) ) ) ) ) ) )
+ (else (walk-generic n class params subs fids)) ) ) ]
[(##core#lambda)
(if (first params)
(walk-generic n class params subs fids)
Trap