Changeset 12088 in project

Timestamp:

10/01/08 16:24:10 (12 years ago)

Author:

felix winkelmann

Message:

fixes in inl.scm

Location:

chicken/trunk

Files:

• TODO (modified) (3 diffs)
• batch-driver.scm (modified) (1 diff)
• compiler.scm (modified) (3 diffs)
• misc/inl.scm (modified) (2 diffs)

chicken/trunk/TODO

@@ -1 @@
-TODO for macro/module system                                    -*- Outline -*-
-
-* trunk merge
-  12020 was last
+TODO for trunk                                          -*- Outline -*-
 
 * macros
@@ -33 +30 @@
     compile-/expansion-time), when import is #t and o import lib
     exists.
+
+* compiler
+** self-recursion optimization
+   what MacScheme called "benchmark-mode" (assume self-calls are recursion)
+*** needs declaration or option, >= -O2
+** cross-module inlining
+*** emit <sourcefile>.inline file with "-inline-global" (?)
+*** "-inline-global" slurps *.inline files include-path (?)
+** compiler syntax
+*** hygienic macro-expansion with "escape" option (expand orig. form normally)
 
 * tests
@@ -74 +81 @@
 *** reimport of imported id
 *** unused defs?
-
-* eggs
-** sassy: convert to proper module
-** port javahack, fmt, fps

chicken/trunk/batch-driver.scm

@@ -361 +361 @@
       (printf "debugging info: ~A~%~!"
               (if emit-trace-info
-                  "stacktrace"
+                  "calltrace"
                   "none") ) )
     (when profile

chicken/trunk/compiler.scm

@@ -35 +35 @@
 ; - Declaration specifiers:
 ;
-; (unit <unitname>)
-; (uses {<unitname>})
+; ([not] extended-bindings {<name>})
+; ([not] inline {<var>})
+; ([not] interrupts-enabled)
+; ([not] safe)
 ; ([not] standard-bindings {<name>})
 ; ([not] usual-integrations {<name>})
-; ([not] extended-bindings (<name>})
 ; ([number-type] <type>)
+; (always-bound {<name>})
+; (block)
+; (block-global {<name>})
+; (bound-to-procedure {<var>})
+; (c-options {<opt>})
+; (compile-syntax)
+; (custom-declare (<tag> <name> <filename> <arg> ...) <string> ...)
+; (disable-interrupts)
+; (disable-warning <class> ...)
+; (emit-import-library {<module> | (<module> <filename>)})
+; (export {<name>})
 ; (fixnum-arithmetic)
-; (unsafe)
-; ([not] safe)
-; ([not] interrupts-enabled)
+; (foreign-declare {<string>})
+; (hide {<name>})
+; (import <symbol-or-string> ...)
+; (inline-limit <limit>)
+; (keep-shadowed-macros)
+; (lambda-lift)
+; (link-options {<opt>})
+; (no-argc-checks)
 ; (no-bound-checks)
-; (no-argc-checks)
 ; (no-procedure-checks)
 ; (no-procedure-checks-for-usual-bindings)
-; (block-global {<name>})
-; (lambda-lift)
-; (hide {<name>})
-; (disable-interrupts)
-; (disable-warning <class> ...)
-; (always-bound {<name>})
-; (foreign-declare {<string>})
-; (block)
+; (post-process <string> ...)
+; (profile <symbol> ...)
+; (safe-globals)
 ; (separate)
-; (compile-syntax)
-; (run-time-macros)       DEPRECATED
-; (export {<name>})
-; (safe-globals)
-; (custom-declare (<tag> <name> <filename> <arg> ...) <string> ...)
-; (data <tag1> <exp1> ...)
-; (post-process <string> ...)
-; (keep-shadowed-macros)
-; (import <symbol-or-string> ...)
+; (unit <unitname>)
+; (unsafe)
 ; (unused <symbol> ...)
-; (profile <symbol> ...)
+; (uses {<unitname>})
 ;
 ;   <type> = fixnum | generic
@@ -1351 +1355 @@
                 (set! unsafe #t)]
                [else (compiler-warning 'syntax "illegal declaration specifier `~s'" id)]))]))
-       ((run-time-macros compile-syntax) ;*** run-time-macros is DEPRECATED
+       ((compile-syntax)
         (set! ##sys#enable-runtime-macros #t))
        ((block-global hide) 
@@ -1742 +1746 @@
                   (walk (car subs) (append localenv env) vars id #f)
                   (set! toplevel-scope tl)
+                  ;; decorate ##core#call node with size
                   (set-car! (cdddr (node-parameters n)) (- current-program-size size0)) ) ) ) ) )
           

chicken/trunk/misc/inl.scm

@@ -2 +2 @@
 
 
-(define (node->sexpr n #!optional (port (current-output-port)))
+(define (node->sexpr n)
   (let walk ((n n))
     `(,(node-class n)
@@ -13 +13 @@
     (define (exported? var)
       (and (##compiler#get db var 'global)
+           (not (##compiler#get db var 'standard-binding))
+           (not (##compiler#get db var 'extended-binding))
            (or (memq var ##compiler#export-list)
                (not (memq var ##compiler#block-globals)))))
-    (define (walk n e le dest)
+    (define (walk n e le k dest)
       (let ((params (node-parameters n))
             (subs (node-subexpressions n)))
+        ;(pp `(WALK: ,(node-class n) ,e ,le))
         (case (node-class n)
           ((##core#variable) 
            (let ((var (car params)))
              (cond ((memq var e) #t)
-                   ((memq var le) 1)    ; references lexical
+                   ((memq var le) 1)    ; references lexical variable
                    ((exported? var) #t)
                    (else #f))))
           ((let)
-           (and (walk (car subs) e le #f)
-                (walk (cadr subs) (cons (car params) e) le dest)))
+           (let* ((r (walk (car subs) e le k #f))
+                  (r2 (walk (cadr subs) (cons (car params) e) le k dest)))
+             (cond ((eq? r 1) (and r2 1))
+                   (r r2)
+                   (else #f))))
           ((##core#lambda)
            (##compiler#decompose-lambda-list
             (third params)
             (lambda (vars argc rest)
-              (cond ((walk (car subs) vars e #f) =>
-                     (lambda (r)
-                       ;; if lambda doesn't refer to outer lexicals, collect
-                       (when (and dest (not (eq? 1 r)))
-                         (set! collected (alist-cons dest n collected)))
-                       #t))
-                    (else #f)))))
+              (let ((k (and (pair? vars) (car vars))))
+                (cond ((walk (car subs) vars (append e le) k #f) =>
+                       (lambda (r)
+                         ;; if lambda doesn't refer to outer lexicals, collect
+                         (when (and dest
+                                    (not (eq? 1 r))
+                                    (not (memq dest ##compiler#not-inline-list))
+                                    (or (memq dest ##compiler#not-inline-list)
+                                        (<= (fourth params) ##compiler#inline-max-size)))
+                           (set! collected (alist-cons dest n collected)))
+                         #t))
+                      (else #f))))))
           ((set!)
            (let ((var (car params)))
-             (walk (car subs) e le (and (exported? var) var))))
+             (walk (car subs) e le k (and (exported? var) var))))
           ((##core#callunit) #f)
+          ((##core#call)
+           ;; only allow continuation-calls (i.e. returns) and self-recursion
+           (and (eq? '##core#variable (node-class (car subs)))
+                (let ((var (car (node-parameters (car subs)))))
+                  (or (eq? var k)
+                      (eq? var dest)))
+                (every (cut walk <> e le k #f) subs)))
           ((if)
-           (and (walk (first subs) e le #f)
-                (walk (second subs) e le dest)
-                (walk (third subs) e le dest)))
-          (else (every (cut walk <> e le #f) subs)))))
-    (walk node '() '() #f)
+           (and (walk (first subs) e le k #f)
+                (walk (second subs) e le k dest)
+                (walk (third subs) e le k dest)))
+          (else (every (cut walk <> e le k #f) subs)))))
+    (walk node '() '() #f #f)
     (for-each 
      (lambda (p)