~ chicken-core (chicken-5) e690a31507c1afebd93d4b056e79e6004b12594e
commit e690a31507c1afebd93d4b056e79e6004b12594e
Merge: 7a3f416c cf5393cd
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon May 9 08:20:01 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Mon May 9 08:20:01 2011 +0200
resolved conflicts
diff --cc compiler.scm
index 16c4f9fa,c02cecf6..c01cf532
--- a/compiler.scm
+++ b/compiler.scm
@@@ -71,8 -71,6 +71,7 @@@
; (unsafe)
; (unused <symbol> ...)
; (uses {<unitname>})
- ; (unsafe-specialized-arithmetic)
+; (specialize)
;
; <type> = fixnum | generic
@@@ -332,12 -330,11 +331,11 @@@
(define standalone-executable #t)
(define local-definitions #f)
(define inline-locally #f)
-(define inline-output-file #f)
-(define do-scrutinize #f)
(define enable-inline-files #f)
(define compiler-syntax-enabled #t)
- (define unchecked-specialized-arithmetic #f)
(define bootstrap-mode #f)
+(define struct-variable-types #f)
+(define enable-specialization #f)
;;; These are here so that the backend can access them:
@@@ -1514,21 -1488,12 +1512,19 @@@
(for-each
(lambda (spec)
(cond ((and (list? spec) (symbol? (car spec)) (= 2 (length spec)))
- (##sys#put! (car spec) '##core#type (cadr spec))
- (##sys#put! (car spec) '##core#declared-type #t))
+ (let ((name (##sys#globalize (car spec) se))
+ (type (##sys#strip-syntax (cadr spec))))
+ (cond ((validate-type type name) =>
+ (lambda (type)
+ (##sys#put! name '##compiler#predicate type)))
+ (else
+ (warning "illegal `predicate' declaration" spec)))))
(else
- (warning "illegal `predicate' declaration" spec))))
- (cdr spec)))
+ (warning "illegal `type' declaration item" spec))))
+ (globalize-all (cdr spec))))
- (else (warning "illegal declaration specifier" spec)) )
+ ((specialize)
+ (set! enable-specialization #t))
- ((unsafe-specialized-arithmetic)
- (set! unchecked-specialized-arithmetic #t))
+ (else (warning "unknown declaration specifier" spec)) )
'(##core#undefined) ) ) )
diff --cc manual/Declarations
index 0bec4e45,a693046e..c6af35d4
--- a/manual/Declarations
+++ b/manual/Declarations
@@@ -356,18 -384,7 +356,7 @@@ are registered as features during compi
knows about them.
- === unsafe-specialized-arithmetic
-
- [declaration specifier] (unsafe-specialized-arithmetic)
-
- Assume specialized arithmetic operations like {{fp+}}, {{fpsin}}, etc.
- are always called with arguments of correct type and perform
- unboxing of intermediate results if possible and if the {{-unboxing}}
- compiler-option has been enabled (done by default on optimization
- levels 2 and higher).
-
-
---
-Previous: [[Modules]]
+Previous: [[Types]]
Next: [[Parameters]]
diff --cc optimizer.scm
index 36a4b737,c3c94561..de01886f
--- a/optimizer.scm
+++ b/optimizer.scm
@@@ -1076,12 -1074,9 +1076,9 @@@
(and inline-substitutions-enabled
(or (not argc) (= rargc argc))
(intrinsic? name)
- (or unsafe
- (if (eq? safe 'specialized)
- unchecked-specialized-arithmetic
- safe))
+ (or unsafe safe)
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list cont
(make-node
'##core#inline_allocate
diff --cc unboxing.scm
index ed6fae4f,40224766..28de35bd
--- a/unboxing.scm
+++ b/unboxing.scm
@@@ -307,159 -255,130 +307,154 @@@
(let ((subs (node-subexpressions n))
(params (node-parameters n))
(class (node-class n)) )
- (d "walk: (~a) ~a ~a" pass2? class params)
- (case class
-
- ((##core#undefined
- ##core#proc
- ##core#global-ref
- ##core#inline_ref
- ##core#inline_loc_ref) #f)
-
- ((##core#lambda ##core#direct_lambda)
- (decompose-lambda-list
- (third params)
- (lambda (vars argc rest)
- (unless pass2?
- (walk-lambda
- (first params)
- (map (cut cons <> #f) vars)
- (first subs)) )
- #f)))
-
- ((##core#variable)
- (let* ((v (first params))
- (a (assq v e)))
- (cond (pass2?
- (when (and a (cdr a))
- (copy-node!
- (make-node '##core#unboxed_ref (list (alias v) (cdr a)) '())
- n)))
- ((not a) #f) ; global
- ((not udest) (boxed! v)))
- a))
-
- ((##core#inline ##core#inline_allocate)
- (let* ((rw1 (##sys#get (symbolify (first params)) '##compiler#unboxed-op))
- (rw (and unsafe rw1))
- (args (map (cut walk <> #f rw pass2?) subs)))
- (cond ((not rw) #f)
- ((or (not pass2?)
- (and dest (unboxed? dest))
- (any unboxed-value? args))
- (let ((alt (first rw))
- (atypes (second rw))
- (rtype (third rw)))
- ;; result or arguments are unboxed - rewrite node to alternative
- (when pass2?
- (rewrite!
- n alt subs args atypes rtype
- (and dest (assq dest e))))
- (cons #f rtype)) )
- (else
- (let ((rtype (third rw)))
- ;; mark argument-vars and dest as unboxed if alternative exists
- (unless pass2?
- (for-each
- (lambda (a)
- (when (and a (car a) (cdr a))
- (unboxed! (car a) (cdr a))))
- args)
- (when dest
- (unboxed! dest rtype)))
- (cons #f rtype))))))
-
- ((let)
- (let* ((v (first params))
- (r1 (walk (first subs) v #t pass2?)))
- (when (and (not pass2?) r1 (cdr r1))
- (unboxed! (first params) (cdr r1)))
- (let ((r (walk (second subs) dest udest pass2?)))
- (when pass2?
- (let ((a (assq v e)))
- (if (and a (cdr a))
- (rebind-unboxed! n (cdr a))
- (straighten-binding! n))) )
- r)))
-
- ((set!)
- (let* ((var (first params))
- (a (assq var e))
- (val (walk (first subs) var (and a (cdr a)) pass2?)))
- (cond (pass2?
- (when (and a (cdr a)) ; may have mutated
- (copy-node!
- (make-node
- '##core#unboxed_set! (list (alias var) (cdr a)) subs)
- n)))
- ((and val (cdr val))
- (unboxed! var (cdr val)))
- (else
- (boxed! var)
- (invalidate val) ) )
- #f))
-
- ((quote) #f)
-
- ((if ##core#cond)
- (invalidate (walk (first subs) #f #f pass2?))
- (straighten-conditional! n)
- (let ((r1 (walk (second subs) dest udest pass2?))
- (r2 (walk (third subs) dest udest pass2?)))
- (merge r1 r2)))
-
- ((##core#switch)
- (invalidate (walk (first subs) #f #f pass2?))
- (do ((clauses (cdr subs) (cddr clauses))
- (r 'none
- (if (eq? r 'none)
- (walk (second clauses) dest udest pass2?)
- (merge r (walk (second clauses) dest udest pass2?)))))
- ((null? (cdr clauses))
- (merge r (walk (car clauses) dest udest pass2?))) ) )
-
- ((##core#call ##core#direct_call)
- (for-each (o invalidate (cut walk <> #f #f pass2?)) subs)
- (when pass2?
- (straighten-call! n))
- #f)
-
- (else
- (for-each (o invalidate (cut walk <> #f #f pass2?)) subs)
- #f))))
-
- (d "walk lambda: ~a" id)
+ (d "walk: (~a) ~a ~a" (if pass2? 2 1) class params)
+ (set! d-depth (add1 d-depth))
+ (let ((result
+ (case class
+
+ ((##core#undefined
+ ##core#proc
+ ##core#global-ref
+ ##core#inline_ref
+ ##core#inline_loc_ref) #f)
+
+ ((##core#lambda ##core#direct_lambda)
+ (decompose-lambda-list
+ (third params)
+ (lambda (vars argc rest)
+ (unless pass2?
+ (walk-lambda
+ (first params)
+ (map (cut cons <> #f) vars)
+ (first subs)) )
+ #f)))
+
+ ((##core#variable)
+ (let* ((v (first params))
+ (a (assq v e)))
+ (cond (pass2?
+ (when (and a (cdr a))
+ (copy-node!
+ (make-node
+ '##core#unboxed_ref
+ (list (alias v) (cdr a))
+ '())
+ n)))
+ ((not a) #f) ; global
+ ((not udest) (boxed! v)))
+ a))
+
+ ((##core#inline ##core#inline_allocate)
+ (let* ((rw1 (##sys#get
+ (symbolify (first params))
+ '##compiler#unboxed-op))
- (rw (and rw1
- (or unsafe
- (and (fourth rw1)
- unchecked-specialized-arithmetic))
- rw1))
++ (rw (and unsafe rw1))
+ (args (map (cut walk <> #f rw pass2?) subs)))
+ ;; rewrite inline operation to unboxed one, if possible
+ (cond ((not rw) #f)
+ ((or (not pass2?)
+ (and dest (unboxed? dest))
+ (any unboxed-value? args))
+ (let ((alt (first rw))
+ (atypes (second rw))
+ (rtype (third rw)))
+ ;; result or arguments are unboxed - rewrite node to alternative
+ (when pass2?
+ (rewrite!
+ n alt subs args atypes rtype
+ (and dest (assq dest e))))
+ (cons #f rtype)) )
+ (else
+ (let ((rtype (third rw)))
+ ;; mark argument-vars and dest as unboxed if alternative exists
+ (unless pass2?
+ (for-each
+ (lambda (a)
+ (when (and a (car a) (cdr a))
+ (unboxed! (car a) (cdr a))))
+ args)
+ (when dest
+ (unboxed! dest rtype)))
+ (cons #f rtype))))))
+
+ ((let)
+ (let* ((v (first params))
+ (r1 (walk (first subs) v #t pass2?)))
+ (when (and (not pass2?) r1 (cdr r1))
+ (unboxed! (first params) (cdr r1)))
+ (let ((r (walk (second subs) dest udest pass2?)))
- (when pass2?
+ (let ((a (assq v e)))
+ (if (and a (cdr a))
+ (rebind-unboxed! n (cdr a))
+ (straighten-binding! n))) )
+ r)))
+
+ ((set!)
+ (let* ((var (first params))
+ (a (assq var e))
+ (val (walk (first subs) var (and a (cdr a)) pass2?)))
+ (cond (pass2?
+ (when (and a (cdr a)) ; may have mutated
+ (copy-node!
+ (make-node
+ '##core#unboxed_set! (list (alias var) (cdr a)) subs)
+ n)))
+ ((and val (cdr val))
+ (unboxed! var (cdr val)))
+ (else
+ (boxed! var)
+ (invalidate val) ) )
+ #f))
+
+ ((quote) #f)
+
+ ((if ##core#cond)
+ (invalidate (walk (first subs) #f #f pass2?))
+ (straighten-conditional! n)
+ (let ((r1 (walk (second subs) dest udest pass2?))
+ (r2 (walk (third subs) dest udest pass2?)))
+ (merge r1 r2)))
+
+ ((##core#switch)
+ (invalidate (walk (first subs) #f #f pass2?))
+ (do ((clauses (cdr subs) (cddr clauses))
+ (r 'none
+ (if (eq? r 'none)
+ (walk (second clauses) dest udest pass2?)
+ (merge r (walk (second clauses) dest udest pass2?)))))
+ ((null? (cdr clauses))
+ (merge r (walk (car clauses) dest udest pass2?))) ) )
+
+ ((##core#call ##core#direct_call)
+ (for-each (o invalidate (cut walk <> #f #f pass2?)) subs)
+ (when pass2?
+ (straighten-call! n))
+ #f)
+
+ (else
+ (for-each (o invalidate (cut walk <> #f #f pass2?)) subs)
+ #f))))
+ (set! d-depth (sub1 d-depth))
+ result)))
+
+ (d "walk lambda: ~a (pass 1)" id)
+ ;; walk once and mark boxed/unboxed variables in environment
(walk body #f #f #f)
+ ;; walk a second time and rewrite
+ (d "walk lambda: ~a (pass 2)" id)
(walk body #f #f #t)))
+
+ ;;XXX Note: lexical references ("##core#ref" nodes) are unboxed
+ ;; repeatedly which is sub-optimal: the unboxed temporaries bound
+ ;; via "##core#let_unboxed" could be re-used in many cases.
+ ;; One possible approach would be an additional "cleanup" pass
+ ;; that replaces
+ ;;
+ ;; (##core#let_unboxed (TU TYPE) X (##core#ref VAR (SLOT)) Y)
+ ;;
+ ;; with
+ ;;
+ ;; (##core#let_unboxed (TU TYPE) (##core#unboxed_ref TU1) Y)
(walk-lambda #f '() node)
(when (and any-rewrites
Trap