Changeset 15234 in project

Timestamp:

07/17/09 20:59:08 (10 years ago)

Author:

felix winkelmann

Message:

compiler-syntax based optimization of "o"; extended bindings weren't properly handled with regard to constant-folding; lambdas in operator position are now correctly handled and optimized (after expansion of procedure-call form)

Location:

chicken/trunk

Files:

• compiler.scm (modified) (2 diffs)
• optimizer.scm (modified) (1 diff)
• support.scm (modified) (1 diff)

chicken/trunk/compiler.scm

@@ -913 +913 @@
                                  se2 #f) ] )
                           (set-real-names! aliases vars)
-                          `(lambda ,aliases ,body) ) )
+                          `(##core#lambda ,aliases ,body) ) )
 
                         ((set! ##core#set!) 
@@ -1251 +1251 @@
            (mapwalk x e se) )
 
-          ((and (pair? (car x))
-                (symbol? (caar x))
-                (memq (or (lookup (caar x) se) (caar x)) '(lambda ##core#lambda)))
-           (let ([lexp (car x)]
-                 [args (cdr x)] )
-             (emit-syntax-trace-info x #f)
-             (##sys#check-syntax 'lambda lexp '(_ lambda-list . #(_ 1)) #f se)
-             (let ([llist (cadr lexp)])
-               (if (and (proper-list? llist) (= (llist-length llist) (length args)))
-                   (walk `(##core#let
-                           ,(map list llist args) ,@(cddr lexp)) 
-                         e se dest)
-                   (let ((var (gensym 't)))
-                     (walk
-                      `(##core#let
-                        ((,var ,(car x)))
-                        (,var ,@(cdr x)) )
-                      e se dest) ) ) ) ) )
-          
           (else
            (emit-syntax-trace-info x #f)
-           (mapwalk x e se)) ) )
+           (let ((x (mapwalk x e se)))
+             (if (and (pair? (car x))
+                      (symbol? (caar x))
+                      (memq (or (lookup (caar x) se) (caar x)) '(lambda ##core#lambda)))
+                 (let ((lexp (car x))
+                       (args (cdr x)) )
+                   (##sys#check-syntax 'lambda lexp '(_ lambda-list . #(_ 1)) #f se)
+                   (let ((llist (cadr lexp)))
+                     (if (and (proper-list? llist) (= (llist-length llist) (length args)))
+                         `(let ,(map list llist args) ,@(cddr lexp)) 
+                         (let ((var (gensym 't)))
+                           `(let ((,var ,(car x)))
+                             (,var ,@(cdr x)) ) ) ) ) ) 
+                 x))) ) )
   
   (define (mapwalk xs e se)

chicken/trunk/optimizer.scm

@@ -1822 +1822 @@
      (if (symbol? names) (list names) names) ) ) )
 
+(r-c-s
+ '(o #%o)
+ (lambda (x r c)
+   (if (fx> (length x) 1)
+       (let ((%tmp (r 'tmp)))
+         `(,(r 'lambda) (,%tmp) ,(fold-right list %tmp (cdr x))))
+       x)))
+
 (r-c-s 
  '(for-each ##sys#for-each #%for-each)

chicken/trunk/support.scm

@@ -348 +348 @@
         (for-each
          (lambda (s)
-           (mark-variable s '##compiler#intrinsic 'extended))
+           (mark-variable s '##compiler#intrinsic 'extended)
+           (when (memq s foldable-bindings)
+             (mark-variable s '##compiler#foldable #t)))
          extended-bindings)
         (for-each