chicken-hackers
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Chicken-hackers] [PATCH] add a second lightweight flow-analysis pass


From: Felix
Subject: [Chicken-hackers] [PATCH] add a second lightweight flow-analysis pass
Date: Fri, 12 Oct 2012 19:45:44 +0200 (CEST)

This patch adds another lightweight flow-analysis pass to remove some
unnecessary type checks after normal optimization has taken place.

Even with specialization, inlining (in particular cross-module
inlining) may result in type checks that are in many cases redundant.
For example inlined record accessors compiled in safe mode, and
inlining of code in general (which is done after the normal
flow-analysis pass) will introduce type-checks that specialization
would have (sometimes) removed.

This patch adds a new compiler pass (called "lfa2"), that does a
simplified flow-analysis to identify redundant forms of the form
'(##core#inline "C_i_check_..." ...)'. Type-information is obtained
from constant forms and predicates like '(##core#inline
"C_i_structurep" ...)'. In unsafe mode checks will be removed in
general.

Here an example, found on Andy Wingo's blog. This example fits
well, because the code is relatively idiomatic:

(define-record-type btree
  (make-btree elt left right)
  btree?
  (elt btree-elt)
  (left btree-left)
  (right btree-right))

(define *btree-null* #f)

(define (btree-cons head tail)
  (if (btree? tail)
      (let ((elt (btree-elt tail)))
        (if (< elt head)
            (make-btree elt
                        (btree-left tail)
                        (btree-cons head (btree-right tail)))
            (make-btree elt
                        (btree-cons head (btree-left tail))
                        (btree-right tail))))
      (make-btree head
                  *btree-null*
                  *btree-null*)))

Compiling this with "-lfa2 -O3" ("local" mode and inlining enabled),
all 4 type-checks for the "btree-left"/"btree-right" accessors will be
removed ("tail" is known to be a structure of type "btree"), resulting
in nearly optimal code ("C_i_block_ref/set" will do a range check on
the slot-index to catch struct-type conflicts, but this should be quite
cheap with the fast-block-accessors patch that is currently pending).

This optimization is only enabled with "-O5", in the moment.
If it turns out to be reliable enough, it should be enabled for
optimization levels 1 and above.

There is quite a lot of room for improvement. This is also the place
where unboxing optimization can be implemented, as it works at the
same level and needs only a simple type system.


cheers,
felix
>From ddfdb8ddb6aeb691ec538f5bfc74e362b6626536 Mon Sep 17 00:00:00 2001
From: Felix Winkelmann <address@hidden>
Date: Tue, 9 Oct 2012 03:49:24 -0400
Subject: [PATCH] Add lightweight flow-analysis pass to remove some unnecessary 
type checks after normal optimization has taken place.

Even with specialization, inlining (in particular cross-module
inlining) may result in type checks that are in many cases redundant.
For example inlined record accessors compiled in safe mode, and
inlining of code in general (which is done after the normal
flow-analysis pass) will introduce type-checks that specialization
would have removed.

This patch adds a new compiler pass (called "lfa2"), that does a
simplified flow-analysis to identify redundant forms of the form
'(##core#inline "C_i_check_..." ...)'. Type-information is obtained
from constant forms and predicates like '(##core#inline
"C_i_structurep" ...)'. In unsafe mode checks will generally be
removed.
---
 batch-driver.scm          |   18 +++
 c-platform.scm            |    2 +-
 chicken.h                 |    7 +
 chicken.scm               |   11 +-
 compiler-namespace.scm    |    1 +
 compiler.scm              |    2 +-
 csc.scm                   |    7 +-
 distribution/manifest     |    2 +
 lfa2.scm                  |  360 +++++++++++++++++++++++++++++++++++++++++++++
 manual/Using the compiler |    4 +-
 rules.make                |    2 +-
 support.scm               |    1 +
 12 files changed, 407 insertions(+), 10 deletions(-)
 create mode 100644 lfa2.scm

diff --git a/batch-driver.scm b/batch-driver.scm
index 062bb6b..099548e 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -91,6 +91,7 @@
        (a-only (memq 'analyze-only options))
        (dynamic (memq 'dynamic options))
        (do-scrutinize (memq 'scrutinize options))
+       (do-lfa2 (memq 'lfa2 options))
        (dumpnodes #f)
        (start-time #f)
        (upap #f)
@@ -437,6 +438,7 @@
             (set! ##sys#explicit-library-modules
               (append ##sys#explicit-library-modules uses-units))
             (set! forms (cons `(declare (uses ,@uses-units)) forms)) )
+          ;; Canonicalize s-expressions
           (let* ((exps0 (map canonicalize-expression
                              (let ((forms (append initforms forms)))
                                (if wrap-module
@@ -493,6 +495,7 @@
 
             (when (memq 'check-syntax options) (exit))
 
+            ;; User-defined pass (s-expressions)
             (let ([proc (user-pass)])
               (when proc
                 (dribble "User pass...")
@@ -500,6 +503,7 @@
                 (set! exps (map proc exps))
                 (end-time "user pass") ) )
 
+            ;; Convert s-expressions to node tree
             (let ((node0 (make-node
                           'lambda '(())
                           (list (build-node-graph
@@ -531,6 +535,7 @@
                        (dribble "Loading inline file ~a ..." ilf)
                        (load-inline-file ilf) )
                      ifs)))
+                ;; Perform scrutiny and optionally specialization
                 (when (or do-scrutinize enable-specialization)
                   ;;XXX hardcoded database file name
                   (unless (memq 'ignore-repository options)
@@ -561,10 +566,12 @@
               (set! ##sys#line-number-database #f)
               (set! constant-table #f)
               (set! inline-table #f)
+              ;; Analyze toplevel assignments
               (unless unsafe
                 (scan-toplevel-assignments (first (node-subexpressions 
node0))) )
 
               (begin-time)
+              ;; Convert to CPS
               (let ([node1 (perform-cps-conversion node0)])
                 (end-time "cps conversion")
                 (print-node "cps" '|3| node1)
@@ -576,6 +583,7 @@
                            (l/d #f)
                            (l/d-done #f))
                   (begin-time)
+                  ;; Analyze node tree for optimization
                   (let ([db (analyze 'opt node2 i progress)])
                     (when first-analysis
                       (when (memq 'u debugging-chicken)
@@ -595,6 +603,7 @@
                     (when (memq 's debugging-chicken) 
                       (print-program-statistics db))
 
+                    ;; Optimize (once)
                     (cond (progress
                            (debugging 'p "optimization pass" i)
                            (begin-time)
@@ -630,6 +639,12 @@
                                     (loop (add1 i) node2 #f #f l/d-done)) ) ) )
                           
                           (else
+                           ;; Secondary flow-analysis
+                           (when do-lfa2
+                             (begin-time)
+                             (debugging 'p "doing lfa2")
+                             (perform-secondary-flow-analysis node2 db)
+                             (end-time "secondary flow analysis"))
                            (print-node "optimized" '|7| node2)
                            ;; inlining into a file with interrupts enabled 
would
                            ;; change semantics
@@ -638,6 +653,7 @@
                                (dribble "generating global inline file `~a' 
..." f)
                                (emit-global-inline-file f db) ) )
                            (begin-time)
+                           ;; Closure conversion
                            (set! node2 (perform-closure-conversion node2 db))
                            (end-time "closure conversion")
                            (print-db "final-analysis" '|8| db i)
@@ -647,11 +663,13 @@
                            (print-node "closure-converted" '|9| node2)
                            (when a-only (exit 0))
                            (begin-time)
+                           ;; Preparation
                            (receive 
                             (node literals lliterals lambda-table)
                             (prepare-for-code-generation node2 db)
                             (end-time "preparation")
                             (begin-time)
+                            ;; Code generation
                             (let ((out (if outfile (open-output-file outfile) 
(current-output-port))) )
                               (dribble "generating `~A' ..." outfile)
                               (generate-code literals lliterals lambda-table 
out filename dynamic db)
diff --git a/c-platform.scm b/c-platform.scm
index c64db6c..04a4879 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -91,7 +91,7 @@
     no-procedure-checks-for-toplevel-bindings module
     no-bound-checks no-procedure-checks-for-usual-bindings no-compiler-syntax
     no-parentheses-synonyms no-symbol-escape r5rs-syntax 
emit-all-import-libraries
-    strict-types clustering
+    strict-types clustering lfa2
     setup-mode no-module-registration) )
 
 (define valid-compiler-options-with-argument
diff --git a/chicken.h b/chicken.h
index 4ee1e53..a946d0c 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1504,6 +1504,13 @@ extern double trunc(double);
 
 #define C_a_i_current_milliseconds(ptr, c, dummy) C_flonum(ptr, 
C_milliseconds())
 
+#define C_i_noop1(dummy)               ((dummy), C_SCHEME_UNDEFINED)
+#define C_i_noop2(dummy1, dummy2)      ((dummy1), (dummy2), C_SCHEME_UNDEFINED)
+#define C_i_noop3(dummy1, dummy2, dummy3)  ((dummy1), (dummy2), (dummy3), 
C_SCHEME_UNDEFINED)
+#define C_i_true1(dummy)               ((dummy), C_SCHEME_TRUE)
+#define C_i_true2(dummy1, dummy2)      ((dummy1), (dummy2), C_SCHEME_TRUE)
+#define C_i_true3(dummy1, dummy2, dummy3)  ((dummy1), (dummy2), (dummy3), 
C_SCHEME_TRUE)
+
 
 /* Variables: */
 
diff --git a/chicken.scm b/chicken.scm
index cc5e83d..c158210 100644
--- a/chicken.scm
+++ b/chicken.scm
@@ -28,7 +28,7 @@
 (declare
   (uses chicken-syntax chicken-ffi-syntax 
        srfi-1 srfi-4 utils files extras data-structures support
-       compiler optimizer compiler-syntax scrutinizer driver platform backend 
+       compiler optimizer lfa2 compiler-syntax scrutinizer driver platform 
backend 
        srfi-69))
 
 
@@ -82,12 +82,16 @@
                    (set! options
                      (cons* 'no-compiler-syntax 'no-usual-integrations 
options)) )
                   ((1)
-                   (set! options (cons 'optimize-leaf-routines options)) )
+                   (set! options
+                     (cons* 'optimize-leaf-routines
+                            ;XXX 'lfa2 
+                            options)) )
                   ((2)
                    (set! options 
                      (cons* 'optimize-leaf-routines
                             'inline
                             ;XXX 'clustering
+                            ;XXX 'lfa2
                             options)) ) 
                   ((3)
                    (set! options
@@ -96,6 +100,7 @@
                             'inline-global
                             'local
                             ;XXX 'clustering
+                            ;XXX 'lfa2
                             'specialize
                             options) ) )
                   ((4)
@@ -105,6 +110,7 @@
                             'inline-global
                             'specialize
                             ;XXX 'clustering
+                            ;XXX 'lfa2
                             'local 'unsafe
                             options) ) )
                   (else
@@ -122,6 +128,7 @@
                               'inline
                               'inline-global
                               'clustering
+                              'lfa2
                               options) ) ) ) )
                 (loop (cdr rest)) ) )
              ((eq? 'debug-level o)
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index ca873c9..6930206 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -223,6 +223,7 @@
  perform-high-level-optimizations
  perform-inlining!
  perform-pre-optimization!
+ perform-secondary-flow-analysis
  posv
  posq
  postponed-initforms
diff --git a/compiler.scm b/compiler.scm
index 64624bd..c99260e 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -1910,7 +1910,7 @@
                  ;; decorate ##core#call node with size
                  (set-car! (cdddr (node-parameters n)) (- current-program-size 
size0)) ) ) ) ) )
          
-         ((set! ##core#set!) 
+         ((set! ##core#set!)           ;XXX ##core#set! still used?
           (let* ((var (first params))
                  (val (car subs)) )
             (when (and first-analysis (not bootstrap-mode))
diff --git a/csc.scm b/csc.scm
index b0a94b4..df951db 100644
--- a/csc.scm
+++ b/csc.scm
@@ -144,7 +144,7 @@
     -no-argc-checks -no-bound-checks -no-procedure-checks -no-compiler-syntax
     -emit-all-import-libraries -setup-mode -no-elevation 
-no-module-registration
     -no-procedure-checks-for-usual-bindings -module
-    -specialize -strict-types -clustering
+    -specialize -strict-types -clustering -lfa2
     -no-procedure-checks-for-toplevel-bindings))
 
 (define-constant complex-options
@@ -182,7 +182,6 @@
 ;;; Variables:
 
 (define scheme-files '())
-(define generated-scheme-files '())
 (define c-files '())
 (define rc-files '())
 (define generated-c-files '())
@@ -405,6 +404,7 @@ Usage: #{csc} FILENAME | OPTION ...
     -strict-types                  assume variable do not change their type
     -clustering                    combine groups of local procedures into 
dispatch
                                      loop
+    -lfa2                          perform additional lightweight 
flow-analysis pass
 
   Configuration options:
 
@@ -829,8 +829,7 @@ EOF
         " ") )
        (set! c-files (append (list fc) c-files))
        (set! generated-c-files (append (list fc) generated-c-files))))
-   scheme-files)
-  (unless keep-files (for-each $delete-file generated-scheme-files)) )
+   scheme-files))
 
 
 ;;; Compile all C/C++  and .rc files:
diff --git a/distribution/manifest b/distribution/manifest
index 9f63422..0f31254 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -78,6 +78,8 @@ scrutinizer.scm
 irregex.scm
 irregex-core.scm
 irregex-utils.scm
+lfa2.c
+lfa2.scm
 posixunix.scm
 posixwin.scm
 posix-common.scm
diff --git a/lfa2.scm b/lfa2.scm
new file mode 100644
index 0000000..97e4101
--- /dev/null
+++ b/lfa2.scm
@@ -0,0 +1,360 @@
+;;;; lfa2.scm - a lightweight "secondary" flow analysis
+;
+; Copyright (c) 2012, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without 
modification, are permitted provided that the following
+; conditions are met:
+;
+;   Redistributions of source code must retain the above copyright notice, 
this list of conditions and the following
+;     disclaimer. 
+;   Redistributions in binary form must reproduce the above copyright notice, 
this list of conditions and the following
+;     disclaimer in the documentation and/or other materials provided with the 
distribution. 
+;   Neither the name of the author nor the names of its contributors may be 
used to endorse or promote
+;     products derived from this software without specific prior written 
permission. 
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 
AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 
OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 
COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 
EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 
SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 
CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 
(INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF 
ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+;; This pass does a lightweight flow-analysis on value types, mostly
+;; to handle the case where user code performs a type-check followed
+;; by inlined accessors (for example when using record structures).
+;; Specialization takes place before inlining, so even though we have
+;; the type-information, later inlining will still keep the code for
+;; checking argument types.
+
+
+(declare
+  (unit lfa2)
+  (hide d-depth lfa2-debug d dd +type-check-map+ +predicate-map+))
+
+
+(include "compiler-namespace")
+(include "tweaks")
+
+
+(define d-depth 0)
+(define lfa2-debug #t)
+
+(define (d fstr . args)
+  (when (and scrutiny-debug (##sys#fudge 13))
+    (printf "[debug|~a] ~a~?~%" d-depth (make-string d-depth #\space) fstr 
args)) )
+
+(define dd d)
+
+(define-syntax d (syntax-rules () ((_ . _) (void))))
+(define-syntax dd (syntax-rules () ((_ . _) (void))))
+
+
+;;; Maps checks to types
+
+(define +type-check-map+
+  '(("C_i_check_closure" procedure)
+    ("C_i_check_exact" fixnum)
+    ("C_i_check_inexact" flonum)
+    ("C_i_check_number" fixnum flonum number)
+    ("C_i_check_string" string)
+    ("C_i_check_bytevector" blob)
+    ("C_i_check_symbol" symbol)
+    ("C_i_check_list" null pair list)
+    ("C_i_check_pair" pair)
+    ("C_i_check_locative" locative)
+    ("C_i_check_boolean" boolean)
+    ("C_i_check_vector" vector)
+    ("C_i_check_structure" *struct*)   ; special case
+    ("C_i_check_char" char)
+    ("C_i_check_closure_2" procedure)
+    ("C_i_check_exact_2" fixnum)
+    ("C_i_check_inexact_2" flonum)
+    ("C_i_check_number_2" fixnum flonum number)
+    ("C_i_check_string_2" string)
+    ("C_i_check_bytevector_2" blob)
+    ("C_i_check_symbol_2" symbol)
+    ("C_i_check_list_2" null pair list)
+    ("C_i_check_pair_2" pair)
+    ("C_i_check_locative_2" locative)
+    ("C_i_check_boolean_2" boolean)
+    ("C_i_check_vector_2" vector)
+    ("C_i_check_structure_2" *struct*) ; special case
+    ("C_i_check_char_2" char)))
+
+
+;; Maps predicates to types
+ 
+(define +predicate-map+
+  '(("C_i_closurep" procedure)
+    ("C_fixnump" fixnum)
+    ("C_i_flonump" flonum)
+    ("C_i_numberp" number)
+    ("C_stringp" string)
+    ("C_bytevectorp" blob)
+    ("C_i_symbolp" symbol)
+    ("C_i_listp" list)
+    ("C_i_pairp" pair)
+    ("C_locativep" locative)
+    ("C_booleanp" boolean)
+    ("C_i_vectorp" vector)
+    ("C_structurep" struct)
+    ("C_i_structurep" *struct*)                ; special case
+    ("C_charp" char)
+    ("C_i_portp" port)
+    ("C_i_nullp" null)))
+
+
+;; Maps constructors to types
+
+(define +constructor-map+
+  '(("C_a_i_record1" *struct*)         ; special case
+    ("C_a_i_record2" *struct*)
+    ("C_a_i_record3" *struct*)
+    ("C_a_i_record4" *struct*)
+    ("C_a_i_record5" *struct*)
+    ("C_a_i_record6" *struct*)
+    ("C_a_i_record7" *struct*)
+    ("C_a_i_record8" *struct*)
+    ("C_a_i_record" *struct*)
+    ("C_a_i_string" string)
+    ("C_a_i_port" port)
+    ("C_a_i_vector1" vector)
+    ("C_a_i_vector2" vector)
+    ("C_a_i_vector3" vector)
+    ("C_a_i_vector4" vector)
+    ("C_a_i_vector5" vector)
+    ("C_a_i_vector6" vector)
+    ("C_a_i_vector7" vector)
+    ("C_a_i_vector8" vector)
+    ("C_a_pair" pair)
+    ("C_a_i_bytevector" blob)
+    ("C_a_i_make_locative" locative)
+    ("C_a_i_vector" vector)
+    ("C_a_i_list1" pair)
+    ("C_a_i_list2" pair)
+    ("C_a_i_list3" pair)
+    ("C_a_i_list4" pair)
+    ("C_a_i_list5" pair)
+    ("C_a_i_list6" pair)
+    ("C_a_i_list7" pair)
+    ("C_a_i_list8" pair)
+    ("C_a_i_cons" pair)
+    ("C_a_i_flonum" flonum)
+    ("C_a_i_fix_to_flo" flonum)
+    ;;XXX there are endless more - is it worth it?
+    ))
+
+
+;;; Walk nodes and perform simplified type-analysis
+
+(define (perform-secondary-flow-analysis node db)
+  (let ((stats '()))
+
+    (define (constant-result lit) 
+      ;; a simplified variant of the one in scrutinizer.scm
+      (cond ((string? lit) 'string)
+           ((symbol? lit) 'symbol)
+           ((fixnum? lit) 'fixnum)
+           ((flonum? lit) 'float)
+           ((number? lit) 
+            (case number-type 
+              ((fixnum) 'fixnum)
+              ((flonum) 'flonum)
+              (else 'number)))
+           ((boolean? lit) 'boolean)
+           ((null? lit) 'null)
+           ((list? lit) 'list)
+           ((pair? lit) 'pair)
+           ((eof-object? lit) 'eof)
+           ((vector? lit) 'vector)
+           ((and (not (##sys#immediate? lit)) (##sys#generic-structure? lit))
+            `(struct ,(##sys#slot lit 0)))
+           ((char? lit) 'char)
+           (else '*)))
+
+    (define (report elim)
+      (cond ((assoc elim stats) =>
+            (lambda (a) (set-cdr! a (add1 (cdr a)))))
+           (else (set! stats (alist-cons elim 1 stats)))))
+ 
+    (define (assigned? var)
+      (get db var 'assigned))
+
+    (define (droppable? n)
+      (or (memq (node-class n) 
+               '(quote ##core#undefined ##core#primitive ##core#lambda))
+         (and (eq? '##core#variable (node-class n))
+              (let ((var (first (node-parameters n))))
+                (or (not (get db var 'global))
+                    (variable-mark var '##compiler#always-bound))))))
+
+    (define (drop! n)
+      (node-class-set! n '##core#undefined)
+      (node-parameters-set! n '())
+      (node-subexpressions-set! n '()))
+
+    (define (extinguish! node rpl)     ; replace ##core#inline call
+      (report (first (node-parameters node)))
+      (let ((subs (node-subexpressions node))
+           (alldropped #t))
+       (for-each
+        (lambda (sn)
+          (if (droppable? sn)
+              (drop! sn)
+              (set! alldropped #f)))
+        subs)
+       (if alldropped
+           (drop! node)
+           (node-parameters-set!
+            node
+            (list
+             (string-append
+              rpl
+              (case (length (node-subexpressions node))
+                ((1) "1")
+                ((2) "2")
+                ((3) "3")
+                (else (bomb "bad number of arguments to extinguished 
##core#inline")))))))))
+
+    (define (vartype v te ae)
+      (cond ((assq v te) => cdr)
+           (else
+            (let loop ((ae ae))
+              (cond ((null? ae) '*)
+                    ((and (eq? v (cdar ae)) 
+                          (assq (caar ae) te) )
+                     => cdr)
+                    (else (loop (cdr ae))))))))
+
+    (define (walk n te ae)
+      (let ((class (node-class n))
+           (params (node-parameters n))
+           (subs (node-subexpressions n)))
+       (case class
+         ((##core#variable)
+          (vartype (first params) te ae))
+         ((if ##core#cond) 
+          (let ((tr (walk (first subs) te ae)))
+            (cond ((and (pair? tr) (eq? 'boolean (car tr)))
+                   (walk (second subs)
+                         (append (second tr) te)
+                         ae)
+                   (walk (third subs)
+                         (append (third tr) te)
+                         ae))
+                  (else
+                   (walk (second subs) te ae)
+                   (walk (third subs) te ae)))))
+         ((quote) (constant-result (first params)))
+         ((let)
+          (let* ((val (first subs))
+                 (var (first params))
+                 (r (walk val te ae)))
+            (walk (second subs)
+                  (if (assigned? var) 
+                      te
+                      (alist-cons var r te))
+                  (if (and (eq? '##core#variable (node-class val))
+                           (not (assigned? var))
+                           (not (assigned? (first (node-parameters val)))))
+                      (let ((var2 (first (node-parameters val))))
+                        (alist-cons var var2 (alist-cons var2 var ae)))
+                      ae))))
+         ((##core#lambda ##core#direct_lambda)
+          ;; fresh env and we don't bother to create entries in the environment
+          ;; for the llist-bound variables (missing implies type '*)
+          ;;XXX (but we could treat the first arg in non-CPS lambdas as 
procedure...)
+          (walk (first subs) '() '())
+          'procedure)
+         ((set! ##core#set!)          ;XXX is ##core#set! still used?
+          (walk (first subs) te ae)
+          'undefined)
+         ((##core#undefined) 'undefined)
+         ((##core#primitive) 'procedure)
+         ((##core#inline ##core#inline_allocate)
+          (for-each (cut walk <> te ae) subs)
+          (cond ((assoc (first params) +type-check-map+) =>
+                 (lambda (a)
+                   (let ((r1 (walk (first subs) te ae)))
+                     (cond (unsafe
+                            (extinguish! n "C_i_noop"))
+                           ((eq? '*struct* (cadr a))
+                            ;; handle known structure type
+                            (when (and (pair? r1)
+                                       (eq? 'struct (first r1))
+                                       (eq? 'quote (node-class (second subs))))
+                              (let ((st (first (node-parameters (second 
subs)))))
+                                (when (and (symbol? st)
+                                           (eq? st (second r1)))
+                                  (extinguish! n "C_i_noop")))))
+                           ((and (pair? r1) (eq? 'boolean (car r1)))
+                            (when (memq 'boolean (cdr a))
+                              (extinguish! n "C_i_noop")))
+                           ;; handle other types
+                           ((member r1 (cdr a))
+                            (extinguish! n "C_i_noop")))
+                     '*)))
+                ((assoc (first params) +predicate-map+) =>
+                 (lambda (a)
+                   (let ((arg (first subs)))
+                     (if (eq? '##core#variable (node-class arg))
+                         `(boolean
+                           ((,(first (node-parameters arg)) 
+                             .
+                             ,(if (eq? '*struct* (cadr a))
+                                  (if (eq? 'quote (node-class (second subs)))
+                                      (let ((st (first
+                                                 (node-parameters
+                                                  (second subs)))))
+                                        (if (symbol? st)
+                                            `(struct ,st)
+                                            'struct))
+                                      'struct)
+                                  (cadr a))))
+                           ())
+                         (let ((r1 (walk (first subs) te ae)))
+                           (cond ((eq? '*struct* (cadr a))
+                                  ;; known structure type
+                                  (when (and (pair? r1)
+                                             (eq? 'struct (first r1))
+                                             (eq? 'quote (node-class (second 
subs))))
+                                    (let ((st (first 
+                                               (node-parameters (second 
subs)))))
+                                      (when (and (symbol? st)
+                                                 (eq? st (second r1)))
+                                        (extinguish! n "C_i_true")))))
+                                 ((and (pair? r1) (eq? 'boolean (car r1)))
+                                  (when (memq 'boolean (cdr a))
+                                    (extinguish! n "C_i_true")))
+                                 ;; other types
+                                 ((member r1 (cdr a))
+                                  (extinguish! n "C_i_true")))
+                           'boolean)))))
+                ((assoc (first params) +constructor-map+) =>
+                 (lambda (a)
+                   (let ((arg1 (first subs)))
+                     (if (and (eq? '*struct* (cadr a))
+                              (eq? 'quote (node-class arg1)))
+                         (let ((tag (first (node-parameters arg1))))
+                           (if (symbol? tag)
+                               `(struct ,tag)
+                               'struct))
+                         (cadr a)))))))
+         (else 
+          (for-each (cut walk <> te ae) subs)
+          '*))))
+
+    (walk node '() '())
+    (when (pair? stats)
+      (with-debugging-output
+       '(x o)
+       (lambda ()
+        (print "eliminated type checks:")
+        (for-each 
+         (lambda (ss) (printf "  ~a:\t~a~%" (car ss) (cdr ss)))
+         stats))))))
diff --git a/manual/Using the compiler b/manual/Using the compiler
index 568a262..a1a0ff7 100644
--- a/manual/Using the compiler 
+++ b/manual/Using the compiler 
@@ -88,6 +88,8 @@ the source text should be read from standard input.
 
 ; -local : Assume toplevel variables defined in the current compilation unit 
are not externally modified. This gives the compiler more opportunities for 
inlining. Note that this may result in counter-intuitive and non-standard 
behaviour: an asssignment to an exported toplevel variable executed in a 
different compilation unit or in evaluated code will possibly not be seen by 
code executing in the current compilation unit.
 
+; -lfa2 : Does an additional lightweight flow-analysis pass on the fully 
optimized program to remove more type checks.
+
 ; -module : wraps the compiled code in an implicit module named {{main}}, 
importing the {{scheme}} and {{chicken}} modules.
 
 ; -no-argc-checks : disable argument count checks
@@ -126,7 +128,7 @@ the source text should be read from standard input.
      -optimize-level 2          is equivalent to -optimize-leaf-routines 
-inline
      -optimize-level 3          is equivalent to -optimize-leaf-routines 
-local -inline -inline-global -specialize
      -optimize-level 4          is equivalent to -optimize-leaf-routines 
-local -inline -inline-global -specialize -unsafe
-     -optimize-level 5          is equivalent to -optimize-leaf-routines 
-block -inline -inline-global -specialize -unsafe -disable-interrupts -no-trace 
-no-lambda-info
+     -optimize-level 5          is equivalent to -optimize-leaf-routines 
-block -inline -inline-global -specialize -unsafe -disable-interrupts -no-trace 
-no-lambda-info -clustering -lfa2
 
 ; -output-file FILENAME : Specifies the pathname of the generated C file. 
Default is {{FILENAME.c}}.
 
diff --git a/rules.make b/rules.make
index 29bc2bf..c467b88 100644
--- a/rules.make
+++ b/rules.make
@@ -44,7 +44,7 @@ LIBCHICKEN_SHARED_OBJECTS = $(LIBCHICKEN_OBJECTS_1:=$(O))
 LIBCHICKEN_STATIC_OBJECTS = $(LIBCHICKEN_OBJECTS_1:=-static$(O))
 
 COMPILER_OBJECTS_1 = \
-       chicken batch-driver compiler optimizer compiler-syntax scrutinizer 
support \
+       chicken batch-driver compiler optimizer lfa2 compiler-syntax 
scrutinizer support \
        c-platform c-backend
 COMPILER_OBJECTS        = $(COMPILER_OBJECTS_1:=$(O))
 COMPILER_STATIC_OBJECTS = $(COMPILER_OBJECTS_1:=-static$(O))
diff --git a/support.scm b/support.scm
index 7fab02b..9c4cedc 100644
--- a/support.scm
+++ b/support.scm
@@ -1705,6 +1705,7 @@ Usage: chicken FILENAME OPTION ...
     -strict-types                assume variable do not change their type
     -clustering                  combine groups of local procedures into 
dispatch
                                    loop
+    -lfa2                        perform additional lightweight flow-analysis 
pass
 
   Configuration options:
 
-- 
1.7.0.4


reply via email to

[Prev in Thread] Current Thread [Next in Thread]