Changeset 12151 in project

Timestamp:

10/14/08 10:11:13 (12 years ago)

Author:

felix winkelmann

Message:

inlining (local and global) work

Location:

chicken/branches/cmi

Files:

• Makefile (modified) (1 diff)
• TODO (modified) (1 diff)
• batch-driver.scm (modified) (6 diffs)
• chicken.scm (modified) (1 diff)
• compiler.scm (modified) (12 diffs)
• eval.scm (modified) (3 diffs)
• manual/Declarations (modified) (1 diff)
• manual/Using the compiler (modified) (2 diffs)
• optimizer.scm (modified) (1 diff)
• rules.make (modified) (1 diff)
• support.scm (modified) (6 diffs)
• tweaks.scm (modified) (1 diff)

chicken/branches/cmi/Makefile

@@ -79 +79 @@
 bootstrap:
         $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) bootstrap
+bench:
+        $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) bench
 endif

chicken/branches/cmi/TODO

@@ -41 +41 @@
 *** "-inline-global" slurps *.inline files include-path
 ** remove "custom-declare" + stuff?
-** when inlining, consing arg-list with "list" may make get-keyword possible foldable
+** when inlining, consing arg-list with "list" may make get-keyword possibly foldable
+** refactor inline tests (simple fid, inlinable/contractable, inline prop, size)
 
 * benchmarks

chicken/branches/cmi/batch-driver.scm

@@ -65 +65 @@
   default-declarations units-used-by-default words-per-flonum default-debugging-declarations
   default-profiling-declarations default-optimization-passes
-  inline-max-size file-requirements import-libraries inline-global
+  inline-max-size file-requirements import-libraries inline-globally
   foreign-string-result-reserve parameter-limit eq-inline-operator optimizable-rest-argument-operators
   membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
   chop-separator chop-extension display-real-name-table display-line-number-database explicit-use-flag
   generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
-  do-lambda-lifting compiler-warning export-file-name
+  do-lambda-lifting compiler-warning emit-global-inline-file load-inline-file
   foreign-argument-conversion foreign-result-conversion)
 
@@ -239 +239 @@
       (set! local-definitions #t))
     (when (memq 'inline-global options)
-      (set! inline-global #t))
+      (set! inline-globally #t))
     (set! disabled-warnings (map string->symbol (collect-options 'disable-warning)))
     (when (memq 'no-warnings options) 
@@ -497 +497 @@
                  (end-time "user pass") ) )
 
+             (let ((req (concatenate (vector->list file-requirements))))
+               (when (debugging 'M "; requirements:")
+                 (pp req))
+               (when inline-globally
+                 (for-each
+                  (lambda (id)
+                    (and-let* ((ifile (##sys#resolve-include-filename 
+                                       (make-pathname #f (symbol->string id) "inline")
+                                       #f #t)))
+                      (when verbose
+                        (print "Loading inline file " ifile " ...")
+                        (load-inline-file ifile))))
+                  (map cdr req))))
+
              (let* ([node0 (make-node
                             'lambda '(())
@@ -502 +516 @@
                                    (canonicalize-begin-body exps) ) ) ) ] 
                     [proc (user-pass-2)] )
-               (when (debugging 'M "; requirements:")
-                 (pretty-print (concatenate (vector->list file-requirements))))
                (when proc
                  (when verbose (printf "Secondary user pass...~%"))
@@ -558 +570 @@
 
                             (begin-time)
-                            (receive (node2 progress-flag) (perform-high-level-optimizations node2 db)
+                            (receive (node2 progress-flag)
+                                (perform-high-level-optimizations node2 db)
                               (end-time "optimization")
                               (print-node "optimized-iteration" '|5| node2)
@@ -580 +593 @@
                             (print-node "optimized" '|7| node2)
 
+                            (when inline-globally
+                              (let ((f (pathname-replace-extension source-filename "inline")))
+                                (when verbose
+                                  (printf "Generating global inline file ~a ...~%" f))
+                                (emit-global-inline-file f db) ) )
+
                             (begin-time)
                             (let ([node3 (perform-closure-conversion node2 db)])

chicken/branches/cmi/chicken.scm

@@ -124 +124 @@
                    [(3)
                     (set! options
-                      (cons* 'optimize-leaf-routines 'local options) ) ]
+                      (cons* 'optimize-leaf-routines 'local 'inline options) ) ]
                    [(4)
                     (set! options
-                      (cons* 'optimize-leaf-routines 'local 'unsafe options) ) ]
+                      (cons* 'optimize-leaf-routines 'local 'inline 'unsafe options) ) ]
                    [else (compiler-warning 'usage "invalid optimization level ~S - ignored" (car rest))] )
                  (loop (cdr rest)) ) ]

chicken/branches/cmi/compiler.scm

@@ -42 +42 @@
 ; ([not] usual-integrations {<name>})
 ; (local {<name> ...})
+; ([not] inline-global {<name>})
 ; ([number-type] <type>)
 ; (always-bound {<name>})
@@ -86 +87 @@
 ;   ##compiler#intrinsic -> #f | 'standard | 'extended
 ;   ##compiler#inline -> 'no | 'yes
+;   ##compiler#inline-global -> 'yes | 'no | <node>
 ;   ##compiler#profile -> BOOL
 
@@ -232 +234 @@
 ;   o-r/access-count -> <n>                  Contains number of references as arguments of optimizable rest operators
 ;   constant -> <boolean>                    If true: variable has fixed value
+;   hidden-refs -> <boolean>                 If true: procedure that refers to hidden global variables
 ; 
 ; <lambda-id>:
@@ -306 +309 @@
   membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
   make-random-name final-foreign-type real-name-table real-name set-real-name! safe-globals-flag
-  location-pointer-map literal-rewrite-hook inline-global
+  location-pointer-map literal-rewrite-hook inline-globally
   local-definitions export-variable variable-mark intrinsic?
   undefine-shadowed-macros process-lambda-documentation emit-syntax-trace-info
@@ -377 +380 @@
 (define standalone-executable #t)
 (define local-definitions #f)
-(define inline-global #f)
+(define inline-globally #f)
 
 
@@ -603 +606 @@
                            (apply ##sys#require ids)
                            (##sys#hash-table-update! 
-                            file-requirements 'syntax-requirements (cut lset-union eq? <> ids)
+                            file-requirements 'dynamic/syntax 
+                            (cut lset-union eq? <> ids)
                             (lambda () ids) )
                            '(##core#undefined) ) )
@@ -1259 +1263 @@
           (apply register-feature! us)
           (when (pair? us)
-            (##sys#hash-table-update! file-requirements 'uses (cut lset-union eq? us <>) (lambda () us))
+            (##sys#hash-table-update! 
+             file-requirements 'static
+             (cut lset-union eq? us <>) 
+             (lambda () us))
             (let ((units (map (lambda (u) (string->c-identifier (stringify u))) us)))
               (set! used-units (append used-units units)) ) ) ) )
@@ -1266 +1273 @@
         (let* ([u (strip (cadr spec))]
                [un (string->c-identifier (stringify u))] )
-          (##sys#hash-table-set! file-requirements 'unit u)
           (when (and unit-name (not (string=? unit-name un)))
             (compiler-warning 'usage "unit was already given a name (new name is ignored)") )
@@ -1366 +1372 @@
                     (set! standard-bindings (lset-difference eq? default-standard-bindings syms))
                     (set! extended-bindings (lset-difference eq? default-extended-bindings syms)) ) ] ) ]
+          ((inline-global)
+           (if (null? (cddr spec))
+               (set! inline-globally #f)
+               (for-each
+                (cut mark-variable <> '##compiler#inline-global 'no)
+                (stripa (cddr spec)))))
           [else
            (check-decl spec 1 1)
@@ -1434 +1446 @@
                 (stripa (cdr spec))))))
        ((inline-global)
-        (set! inline-global #t))
+        (if (null? (cdr spec))
+            (set! inline-globally #t)
+            (for-each
+             (cut mark-variable <> '##compiler#inline-global 'yes)
+             (stripa (cdr spec)))))
        (else (compiler-warning 'syntax "illegal declaration specifier `~s'" spec)) )
      '(##core#undefined) ) ) )
@@ -1931 +1947 @@
                   (when (and (eq? '##core#lambda (node-class value))
                              (or (not (second valparams))
-                                 (every (lambda (v) (get db v 'global)) (scan-free-variables value)) ) )
+                                 (every 
+                                  (lambda (v) (get db v 'global))
+                                  (nth-value 0 (scan-free-variables value)) ) ) )
                     (if (and (= 1 nreferences) (= 1 ncall-sites))
                         (quick-put! plist 'contractable #t)
@@ -1938 +1956 @@
                 ;; Make 'inlinable, if it is declared local and has a value
                 (let ((valparams (node-parameters local-value)))
-                  (when (and (eq? '##core#lambda (node-class local-value))
-                             (or (not (second valparams))
-                                 (every (lambda (v) (get db v 'global)) (scan-free-variables local-value)) ) )
-                    (quick-put! plist 'inlinable #t) ) ) ) )
+                  (when (eq? '##core#lambda (node-class local-value))
+                    (let-values (((vars hvars) (scan-free-variables local-value)))
+                      (when (and (get db sym 'global)
+                                 (pair? hvars))
+                        (quick-put! plist 'hidden-refs #t))
+                      (when (or (not (second valparams))
+                                (every 
+                                 (lambda (v) (get db v 'global)) 
+                                 vars))
+                        (quick-put! plist 'inlinable #t) ) ) ) ) )
+               ((variable-mark sym '##compiler#inline) =>
+                (lambda (n)
+                  (when (and (node? n)
+                             inline-globally
+                             (not (eq? 'no (variable-mark sym '##compiler#inline-global))))
+                    (let ((lparams (node-parameters n)))
+                      (put! db (first lparams) 'simple)
+                      (quick-put! plist 'inlinable #t)
+                      (quick-put! plist 'local-value n))))))
 
          ;; Make 'collapsable, if it has a known constant value which is either collapsable or is only

chicken/branches/cmi/eval.scm

@@ -1185 +1185 @@
   (let ((vector->list vector->list))
     (lambda (id comp? imp?)
-      (define (add-req id)
+      (define (add-req id syntax?)
         (when comp?
-          (##sys#hash-table-update!             ; assumes compiler has extras available - will break in the interpreter
+          (##sys#hash-table-update! ; assumes compiler has extras available - will break in the interpreter
            ##compiler#file-requirements
-           'syntax-requirements
+           (if syntax? 'dynamic/syntax 'dynamic)
            (cut lset-adjoin eq? <> id) 
            (lambda () (list id)))))
@@ -1229 +1229 @@
                         (let ((s (assq 'syntax info))
                               (rr (assq 'require-at-runtime info)) )
-                          (when s (add-req id))
+                          (when s (add-req id #t))
                           (values 
                            (impform
@@ -1243 +1243 @@
                            #t) ) )
                        (else
-                        (add-req id)
+                        (add-req id #f)
                         (values
                          (impform

chicken/branches/cmi/manual/Declarations

@@ -142 +142 @@
 
 
+=== inline-global
+
+  [declaration specifier] (inline-global)
+  [declaration specifier] (not inline-global)
+  [declaration specifier] (inline-global IDENTIFIER ...)
+  [declaration specifier] (not inline-global IDENTIFIER ...)
+
+Declare that then given toplevel procedures (or all) are subject to
+cross-module inlining. Potentially inlinable procedures in the current
+compilation unit will be written to an external
+{{<source-filename>.inline}} file in the current directory. Globally
+inlinable procedures from other compilation units referred to via
+{{(declare (uses ...))}} or {{require-extension}} are loaded from
+{{.inline}} files (if available in the current include path) and inlined
+in the current compilation unit.
+
+
 === inline-limit
 

chicken/branches/cmi/manual/Using the compiler

@@ -120 +120 @@
 ; -inline : Enable procedure inlining for known procedures of a size below the threshold (which can be set through the {{-inline-limit}} option).
 
+; -inline-global : Enable cross-module inlining.
+
 ; -inline-limit THRESHOLD : Sets the maximum size of a potentially inlinable procedure. The default threshold is {{10}}.
 
@@ -146 +148 @@
      -optimize-level 1          is equivalent to -optimize-leaf-routines
      -optimize-level 2          is currently the same as -optimize-level 1
-     -optimize-level 3          is equivalent to -optimize-leaf-routines -local
-     -optimize-level 4          is equivalent to -optimize-leaf-routines -local -unsafe
+     -optimize-level 3          is equivalent to -optimize-leaf-routines -local -inline
+     -optimize-level 4          is equivalent to -optimize-leaf-routines -local -inline -unsafe
 
 ; -output-file FILENAME : Specifies the pathname of the generated C file. Default is {{FILENAME.c}}.

chicken/branches/cmi/optimizer.scm

@@ -319 +319 @@
                             (lambda (vars argc rest)
                               (let ([fid (first lparams)])
-                                #;(pp `(INLINE: ,var ,fid ,(test fid 'simple)
-                                              ,(test var 'inlinable)
-                                              ,(variable-mark var '##compiler#inline)))
                                 (cond [(and (test fid 'simple)
                                             (test var 'inlinable)

chicken/branches/cmi/rules.make

@@ -1386 +1386 @@
           srfi-1.c srfi-4.c srfi-13.c srfi-14.c srfi-18.c srfi-69.c posixunix.c posixwin.c regex.c \
           scheduler.c profiler.c stub.c expand.c $(COMPILER_OBJECTS_1:=.c)
+
+
+# benchmarking
+
+.PHONY: bench
+
+bench:
+        here=`pwd`; cd $(SRCDIR)benchmark; \
+        LD_LIBRARY_PATH=$$here DYLD_LIBRARY_PATH=$$here \
+        $$here/csi -s $(SRCDIR)cscbench.scm $(BENCHMARK_OPTIONS)

chicken/branches/cmi/support.scm

@@ -54 +54 @@
   debugging-chicken bomb check-signature posq stringify symbolify build-lambda-list
   string->c-identifier c-ify-string words words->bytes check-and-open-input-file close-checked-input-file fold-inner
-  constant? basic-literal? source-info->string mark-variable
+  constant? basic-literal? source-info->string mark-variable load-inline-file
   collapsable-literal? immediate? canonicalize-begin-body string->expr get get-all
   put! collect! count! get-line get-line-2 find-lambda-container display-analysis-database varnode qnode 
@@ -69 +69 @@
   foreign-argument-conversion foreign-result-conversion final-foreign-type debugging block-globals
   constant-declarations process-lambda-documentation big-fixnum?
-  export-dump-hook intrinsic?
+  export-dump-hook intrinsic? node->sexpr emit-global-inline-file inline-max-size
   make-random-name foreign-type-convert-result foreign-type-convert-argument process-custom-declaration)
 
@@ -667 +667 @@
       ,(node-parameters n)
       ,@(map walk (node-subexpressions n)))))
+
+(define (emit-global-inline-file filename db)
+  (let ((lst '()))
+    (with-output-to-file filename
+      (lambda ()
+        (print "; GENERATED BY CHICKEN " (chicken-version) "\n")
+        (##sys#hash-table-for-each
+         (lambda (sym plist)
+           (and-let* ((val (assq 'local-value plist))
+                      ((let ((val (assq 'value plist)))
+                         (or (not val)
+                             (not (eq? 'unknown (cdr val))))))
+                      ((assq 'inlinable plist))
+                      (lparams (node-parameters (cdr val)))
+                      ((get db (first lparams) 'simple)) 
+                      ((not (get db sym 'hidden-refs)))
+                      ((not (eq? (variable-mark sym '##compiler#inline-global) 'no)))
+                      ((case (variable-mark sym '##compiler#inline)
+                         ((yes) #t)
+                         ((no) #f)
+                         (else 
+                          (< (fourth lparams) inline-max-size) ) ) ) )
+             (set! lst (cons sym lst))
+             (pp (list sym (node->sexpr (cdr val))))
+             (newline)))
+         db)
+        (print "; END OF FILE")))
+    (when (and (pair? lst)
+               (debugging 'i "the following procedures can be globally inlined:"))
+      (for-each (cut print "  " <>) lst))))
+
+(define (load-inline-file fname)
+  (with-input-from-file fname
+    (lambda ()
+      (let loop ()
+        (let ((x (read)))
+          (unless (eof-object? x)
+            (mark-variable 
+             (car x) '##compiler#inline-global 
+             (apply make-node (cadr x)))
+            (loop)))))))
 
 
@@ -1055 +1096 @@
 
 (define (scan-free-variables node)
-  (let ((vars '()))
+  (let ((vars '())
+        (hvars '()))
 
     (define (walk n e)
@@ -1064 +1106 @@
           ((##core#variable) 
            (let ((var (first params)))
-             (unless (memq var e) (set! vars (lset-adjoin eq? vars var))) ) )
+             (unless (memq var e)
+               (set! vars (lset-adjoin eq? vars var))
+               (unless (variable-visible? var) 
+                 (set! hvars (lset-adjoin eq? hvars var))))))
           ((set!)
            (let ((var (first params)))
@@ -1083 +1128 @@
 
     (walk node '())
-    vars) )
+    (values vars hvars) ) )
 
 

chicken/branches/cmi/tweaks.scm

@@ -43 +43 @@
 
 
+(define-inline (node? x) (##sys#structure? x 'node))
 (define-inline (make-node c p s) (##sys#make-structure 'node c p s))
 (define-inline (node-class n) (##sys#slot n 1))