Changeset 15037 in project

Timestamp:

06/19/09 09:18:41 (10 years ago)

Author:

felix winkelmann

Message:

• warn if transformer returns original form
• new bootstrap tarball
• removed pre-cps pass
• exceptions in module-finalization in compiler doesn't show backtrace

Location:

chicken/trunk

Files:

• batch-driver.scm (modified) (3 diffs)
• bootstrap.tar.gz (modified) (previous)
• chicken.scm (modified) (1 diff)
• compiler.scm (modified) (2 diffs)
• expand.scm (modified) (3 diffs)
• optimizer.scm (modified) (2 diffs)

chicken/trunk/batch-driver.scm

@@ -35 +35 @@
   compiler-arguments process-command-line dump-nodes dump-undefined-globals
   default-standard-bindings default-extended-bindings
-  foldable-bindings dump-defined-globals apply-pre-cps-rewrite-rules!
+  foldable-bindings dump-defined-globals
   compiler-cleanup-hook disabled-warnings local-definitions inline-output-file
   file-io-only undefine-shadowed-macros profiled-procedures
@@ -497 +497 @@
                (compiler-warning 
                 'style
-                "compiling extensions in unsafe mode is bad practice and should be avoided as it may be surprising to an unsuspecting user") )
+                "compiling extensions in unsafe mode is bad practice and should be avoided") )
 
              (set! ##sys#line-number-database line-number-database-2)
@@ -550 +550 @@
                  (print-node "lambda lifted" '|L| node0) 
                  (set! first-analysis #t) )
-
-               #;(begin
-                 (begin-time)
-                 (set! first-analysis #f)
-                 (set! db (analyze 'rewrite node0))
-                 (print-db "analysis" '|0| db 0)
-                 (end-time "pre-analysis (rewrite)")
-                 (begin-time)
-                 (apply-pre-cps-rewrite-rules! node0 db)
-                 (end-time "applying pre-CPS rewrite rules")
-                 (print-node "applied pre-CPS rewrite rules" '|R| node0) 
-                 (set! first-analysis #t) )
-
+               
                (let ((req (concatenate (vector->list file-requirements))))
                  (when (debugging 'M "; requirements:")

chicken/trunk/chicken.scm

@@ -152 +152 @@
                 (if (string? o) o (conc "-" o)) )
                (loop rest) ] ) ) ) )
-  (handle-exceptions ex
-      (begin
-        (print-error-message ex (current-error-port))
-        (exit 1))
-    (apply compile-source-file filename options) )
+  (apply compile-source-file filename options)
   (exit) )

chicken/trunk/compiler.scm

@@ -91 +91 @@
 ;   ##compiler#unused -> BOOL
 ;   ##compiler#foldable -> BOOL
-;   ##compiler#rewrite -> PROCEDURE (see `apply-rewrite-rules!')
 
 ; - Source language:
@@ -815 +814 @@
                                               (cond 
                                                ((null? body)
-                                                (##sys#finalize-module (##sys#current-module))
+                                                (handle-exceptions ex
+                                                    (begin
+                                                      ;; avoid backtrace
+                                                      (print-error-message ex (current-error-port))
+                                                      (exit 1))
+                                                  (##sys#finalize-module (##sys#current-module)))
                                                 (cond ((assq name import-libraries) =>
                                                        (lambda (il)

chicken/trunk/expand.scm

@@ -260 +260 @@
              ex) )
       (let ((exp2 (handler exp se dse)))
+        (when (eq? exp exp2)
+          (##sys#syntax-error-hook
+           (string-append
+            "syntax transformer for `" (symbol->string name)
+            "' returns original form, which would result in non-termination")
+           exp))
         (dd `(,name --> ,exp2))
         exp2)))
@@ -290 +296 @@
                      (##sys#check-syntax 'let body '#(_ 2) #f dse)
                      (let ([bindings (car body)])
-                       (cond [(symbol? bindings)
+                       (cond [(symbol? bindings) ; expand named let
                               (##sys#check-syntax 'let body '(_ #((variable _) 0) . #(_ 1)) #f dse)
                               (let ([bs (cadr body)])
@@ -301 +307 @@
                                  #t) ) ]
                              [else (values exp #f)] ) ) ]
-                    [(and (memq head2 '(set! ##core#set!))
+                    [(and (memq head2 '(set! ##core#set!)) ; "setter" syntax
                           (pair? body)
                           (pair? (car body)) )

chicken/trunk/optimizer.scm

@@ -62 +62 @@
   parameter-limit eq-inline-operator optimizable-rest-argument-operators
   membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
-  make-random-name final-foreign-type inline-max-size simplified-ops apply-pre-cps-rewrite-rules!
+  make-random-name final-foreign-type inline-max-size simplified-ops
   generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
   foreign-argument-conversion foreign-result-conversion foreign-type-convert-argument foreign-type-convert-result)
@@ -1803 +1803 @@
                 (debugging 'p "moving liftables to toplevel...")
                 (reconstruct! ls extra) ) ) ) ) ) ) ) )
-
-
-;;; Apply rewrite-rules to procedure calls
-
-(define (apply-pre-cps-rewrite-rules! node db)
-  (define (walk n)
-    (let ((class (node-class n))
-          (params (node-parameters n))
-          (subs (node-subexpressions n)))
-      (case class
-        ((##core#call)
-         (let* ((opnode (walk (first subs)))
-                (proc (and (eq? '##core#variable (node-class opnode))
-                           (first (node-parameters opnode))) ) 
-                (handler (and proc
-                              (intrinsic? proc) 
-                              (##sys#get proc '##compiler#rewrite) ) ) )
-           (for-each walk (cdr subs))
-           (cond (handler
-                  (let ((info (and (pair? (cdr params))
-                                   (source-info->line (second params)))))
-                    (debugging 'o "applying rule" proc info)
-                    (copy-node! (handler proc (cdr subs) db walk) n)))
-                 (else n))))
-        (else
-         (for-each walk subs)))))
-  (walk node))