Changeset 15117 in project for chicken

Timestamp:

06/30/09 10:18:43 (10 years ago)

Author:

felix winkelmann

Message:

added -no-compiler-syntax; compiler syntax used by optimizer respects standard-/extended-bindings decl

Location:

chicken/trunk

Files:

• batch-driver.scm (modified) (3 diffs)
• c-platform.scm (modified) (2 diffs)
• compiler.scm (modified) (10 diffs)
• csc.scm (modified) (2 diffs)
• expand.scm (modified) (1 diff)
• optimizer.scm (modified) (2 diffs)
• support.scm (modified) (2 diffs)

chicken/trunk/batch-driver.scm

@@ -53 +53 @@
   reorganize-recursive-bindings substitution-table simplify-named-call emit-unsafe-marker
   perform-closure-conversion prepare-for-code-generation compiler-source-file create-foreign-stub expand-foreign-lambda*
-  transform-direct-lambdas! source-filename standalone-executable
+  transform-direct-lambdas! source-filename standalone-executable compiler-syntax-enabled
   debugging-chicken bomb check-signature posq stringify symbolify build-lambda-list
   string->c-identifier c-ify-string words check-and-open-input-file close-checked-input-file fold-inner constant?
@@ -241 +241 @@
     (when (memq 'no-lambda-info options)
       (set! emit-closure-info #f) )
+    (when (memq 'no-compiler-syntax options)
+      (set! compiler-syntax-enabled #f))
     (when (memq 'local options)
       (set! local-definitions #t))
@@ -526 +528 @@
 
                (print-node "initial node tree" '|T| node0)
+               (initialize-analysis-database)
 
                (when do-scrutinize

chicken/trunk/c-platform.scm

@@ -125 +125 @@
     emit-external-prototypes-first release local inline-global
     analyze-only dynamic scrutinize no-argc-checks no-procedure-checks
-    no-bound-checks no-procedure-checks-for-usual-bindings
+    no-bound-checks no-procedure-checks-for-usual-bindings no-compiler-syntax
     no-parentheses-synonyms no-symbol-escape r5rs-syntax) )
 
@@ -179 +179 @@
     u8vector-set! s8vector-set! u16vector-set! s16vector-set! u32vector-set! s32vector-set!
     locative-ref locative-set! locative->object locative? global-ref
-    null-pointer? pointer->object flonum? finite?) )
+    null-pointer? pointer->object flonum? finite?
+    printf sprintf format) )
 
 (define internal-bindings

chicken/trunk/compiler.scm

@@ -293 +293 @@
   pprint-expressions-to-file foreign-type-check estimate-foreign-result-size scan-used-variables scan-free-variables
   topological-sort print-version print-usage initialize-analysis-database csc-control-file
-  estimate-foreign-result-location-size inline-output-file
+  estimate-foreign-result-location-size inline-output-file compiler-syntax-enabled
   expand-foreign-callback-lambda default-optimization-passes default-optimization-passes-when-trying-harder
   units-used-by-default words-per-flonum disable-stack-overflow-checking
@@ -382 +382 @@
 (define do-scrutinize #f)
 (define enable-inline-files #f)
+(define compiler-syntax-enabled #t)
 
 
@@ -550 +551 @@
              (let* ((name0 (lookup (car x) se))
                     (name (or (and (symbol? name0) (##sys#get name0 '##core#primitive)) name0))
-                    (xexpanded (##sys#expand x se #t)))
+                    (xexpanded (##sys#expand x se compiler-syntax-enabled)))
                (cond ((not (eq? x xexpanded))
                       (walk xexpanded e se dest))
@@ -641 +642 @@
                                      (list alias (walk (cadr b) e se (car b))) )
                                    aliases bindings)
-                             ,(walk (##sys#canonicalize-body (cddr x) se2 #t)
+                             ,(walk (##sys#canonicalize-body (cddr x) se2 compiler-syntax-enabled)
                                     (append aliases e)
                                     se2 dest) ) ) )
@@ -674 +675 @@
                               (let* ((aliases (map gensym vars))
                                      (se2 (append (map cons vars aliases) se))
-                                     (body0 (##sys#canonicalize-body obody se2 #t))
+                                     (body0 (##sys#canonicalize-body obody se2 compiler-syntax-enabled))
                                      (body (walk body0 (append aliases e) se2 #f))
                                      (llist2 
@@ -718 +719 @@
                                      se) ) )
                            (walk
-                            (##sys#canonicalize-body (cddr x) se2 #t)
+                            (##sys#canonicalize-body (cddr x) se2 compiler-syntax-enabled)
                             e se2
                             dest) ) )
@@ -737 +738 @@
                            ms)
                           (walk
-                           (##sys#canonicalize-body (cddr x) se2 #t)
+                           (##sys#canonicalize-body (cddr x) se2 compiler-syntax-enabled)
                            e se2 dest)))
                                
@@ -803 +804 @@
                               (lambda ()
                                 (walk 
-                                 (##sys#canonicalize-body (cddr x) se #t)
+                                 (##sys#canonicalize-body (cddr x) se compiler-syntax-enabled)
                                  e se dest) )
                               (lambda ()
@@ -908 +909 @@
                                [body 
                                 (walk 
-                                 (##sys#canonicalize-body obody se2 #t)
+                                 (##sys#canonicalize-body obody se2 compiler-syntax-enabled)
                                  (append aliases e) 
                                  se2 #f) ] )
@@ -1913 +1914 @@
                  (any (lambda (id2) (contains? id2 other-ids)) clist) ) ) ) )
 
-    ;; Initialize database:
-    (initialize-analysis-database db)
-
     ;; Walk toplevel expression-node:
     (debugging 'p "analysis traversal phase...")

chicken/trunk/csc.scm

@@ -130 +130 @@
     -analyze-only -keep-shadowed-macros -inline-global -ignore-repository
     -no-symbol-escape -no-parentheses-synonyms -r5rs-syntax
-    -no-argc-checks -no-bound-checks -no-procedure-checks
+    -no-argc-checks -no-bound-checks -no-procedure-checks -no-compiler-syntax
     -no-procedure-checks-for-usual-bindings))
 
@@ -315 +315 @@
     -j -emit-import-library MODULE write compile-time module information into
                                     separate file
+    -no-compiler-syntax            disable expansion of compiler-macros
 
   Translation options:

chicken/trunk/expand.scm

@@ -56 +56 @@
 
 (begin
-  (define-syntax dd (syntax-rules () ((_ . _) (void))))
+  #;(define-syntax dd (syntax-rules () ((_ . _) (void))))
   (define-syntax dm (syntax-rules () ((_ . _) (void))))
-  (define-syntax dc (syntax-rules () ((_ . _) (void)))) )
+  #;(define-syntax dc (syntax-rules () ((_ . _) (void)))) )
 
 

chicken/trunk/optimizer.scm

@@ -1831 +1831 @@
          (%begin (r 'begin))
          (%pair? (r 'pair?)))
-     (if (= 3 (length x))
+     (if (and (memq 'for-each standard-bindings) ; we have to check this because the db (and thus 
+              (= 3 (length x)))                  ; intrinsic marks) isn't set up yet
          `(,%let ,%loop ((,%lst ,(caddr x)))
                  (,%if (,%pair? ,%lst)
@@ -1891 +1892 @@
    (lambda (return)
      (and (>= (length args) 1)
+          (memq func extended-bindings) ; s.a.
           (or (string? (car args))
               (and (list? (car args))

chicken/trunk/support.scm

@@ -338 +338 @@
 (define initialize-analysis-database
   (let ((initial #t))
-    (lambda (db)
+    (lambda ()
       (when initial
         (for-each
-         (lambda (s) 
+         (lambda (s)
            (mark-variable s '##compiler#intrinsic 'standard)
            (when (memq s foldable-bindings)
@@ -1270 +1270 @@
     -emit-import-library MODULE  write compile-time module information into
                                   separate file
+    -no-compiler-syntax          disable expansion of compiler-macros
 
   Translation options: