Ignore:
Timestamp:
08/01/09 00:31:50 (10 years ago)
Author:
felix winkelmann
Message:

merged prerelease branch r15292 into release branch; synced with manual in wiki

Location:
chicken/branches/release
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/release

  • chicken/branches/release/optimizer.scm

    r13240 r15293  
    3131  compiler-arguments process-command-line perform-lambda-lifting!
    3232  default-standard-bindings default-extended-bindings
    33   foldable-bindings llist-length
     33  foldable-bindings llist-length r-c-s compile-format-string
    3434  installation-home decompose-lambda-list external-to-pointer
    3535  copy-node! variable-visible? mark-variable intrinsic?
     
    5959  topological-sort print-version print-usage initialize-analysis-database
    6060  expand-foreign-callback-lambda default-optimization-passes default-optimization-passes-when-trying-harder
    61   units-used-by-default words-per-flonum rewrite inline-locally
     61  units-used-by-default words-per-flonum rewrite inline-locally compiler-syntax-statistics
    6262  parameter-limit eq-inline-operator optimizable-rest-argument-operators
    6363  membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
     
    300300                                        (kvar (first (node-parameters k)))
    301301                                        (lval (and (not (test kvar 'unknown)) (test kvar 'value)))
    302                                         (eq? '##core#lambda (node-class lval))
     302                                        ((eq? '##core#lambda (node-class lval)))
    303303                                        (llist (third (node-parameters lval)))
    304304                                        ((or (test (car llist) 'unused)
     
    349349                                                   [(test (car vars) 'unused)
    350350                                                    (touch)
    351                                                     (debugging 'o "removed unused parameter to known procedure" (car vars) var)
     351                                                    (debugging
     352                                                     'o "removed unused parameter to known procedure"
     353                                                     (car vars) var)
    352354                                                    (if (expression-has-side-effects? (car args) db)
    353355                                                        (make-node
     
    17901792            (when (debugging 'l "accessibles:") (pretty-print al))
    17911793            (debugging 'p "eliminating liftables by access-lists and non-liftable callees...")
    1792             (let ([ls (eliminate3 (eliminate4 g2))]) ;(eliminate2 g2 al)))])
     1794            (let ([ls (eliminate3 (eliminate4 g2))]) ;(eliminate2 g2 al)))]) - why isn't this used?
    17931795              (debugging 'o "liftable local procedures" (delay (unzip1 ls)))
    17941796              (debugging 'p "gathering extra parameters...")
     
    18011803                (debugging 'p "moving liftables to toplevel...")
    18021804                (reconstruct! ls extra) ) ) ) ) ) ) ) )
     1805
     1806
     1807;;; Compiler macros (that operate in the expansion phase)
     1808
     1809(define compiler-syntax-statistics '())
     1810
     1811(set! ##sys#compiler-syntax-hook
     1812  (lambda (name result)
     1813    (let ((a (alist-ref name compiler-syntax-statistics eq? 0)))
     1814      (set! compiler-syntax-statistics
     1815        (alist-update! name (add1 a) compiler-syntax-statistics)))))
     1816
     1817(define (r-c-s names transformer #!optional (se '()))
     1818  (let ((t (cons (##sys#er-transformer transformer) se)))
     1819    (for-each
     1820     (lambda (name)
     1821       (##sys#put! name '##compiler#compiler-syntax t) )
     1822     (if (symbol? names) (list names) names) ) ) )
     1823
     1824(r-c-s
     1825 '(for-each ##sys#for-each #%for-each)
     1826 (lambda (x r c)
     1827   (let ((%let (r 'let))
     1828         (%if (r 'if))
     1829         (%loop (r 'loop))
     1830         (%lst (r 'lst))
     1831         (%begin (r 'begin))
     1832         (%pair? (r 'pair?)))
     1833     (if (and (memq 'for-each standard-bindings) ; we have to check this because the db (and thus
     1834              (= 3 (length x)))                  ; intrinsic marks) isn't set up yet
     1835         `(,%let ,%loop ((,%lst ,(caddr x)))
     1836                 (,%if (,%pair? ,%lst)
     1837                       (,%begin
     1838                        (,(cadr x) (##sys#slot ,%lst 0))
     1839                        (##core#app ,%loop (##sys#slot ,%lst 1))) ) )
     1840         x)))
     1841 `((pair? . ,(##sys#primitive-alias 'pair?))))
     1842
     1843(r-c-s
     1844 '(o #%o)
     1845 (lambda (x r c)
     1846   (if (and (fx> (length x) 1)
     1847            (memq 'o extended-bindings) )
     1848       (let ((%tmp (r 'tmp)))
     1849         `(,(r 'lambda) (,%tmp) ,(fold-right list %tmp (cdr x))))
     1850       x)))
     1851
     1852(let ((env `((display . ,(##sys#primitive-alias 'display)) ;XXX clean this up
     1853             (write . ,(##sys#primitive-alias 'write))
     1854             (fprintf . ,(##sys#primitive-alias 'fprintf))
     1855             (number->string . ,(##sys#primitive-alias 'number->string))
     1856             (write-char . ,(##sys#primitive-alias 'write-char))
     1857             (open-output-string . ,(##sys#primitive-alias 'open-output-string))
     1858             (get-output-string . ,(##sys#primitive-alias 'get-output-string)) ) ) )
     1859  (r-c-s
     1860   '(sprintf #%sprintf format #%format)
     1861   (lambda (x r c)
     1862     (let* ((out (gensym 'out))
     1863            (code (compile-format-string
     1864                   (if (memq (car x) '(sprintf #%sprintf))
     1865                       'sprintf
     1866                       'format)
     1867                   out
     1868                   x
     1869                   (cdr x)
     1870                   r c)))
     1871       (if code
     1872           `(,(r 'let) ((,out (,(r 'open-output-string))))
     1873             ,code
     1874             (,(r 'get-output-string) ,out))
     1875           x)))
     1876   env)
     1877  (r-c-s
     1878   '(fprintf #%fprintf)
     1879   (lambda (x r c)
     1880     (if (>= (length x) 3)
     1881         (let ((code (compile-format-string
     1882                      'fprintf (cadr x)
     1883                      x (cddr x)
     1884                      r c)))
     1885           (if code
     1886               code
     1887               x))
     1888         x))
     1889   env)
     1890  (r-c-s
     1891   '(printf #%printf)
     1892   (lambda (x r c)
     1893     (let ((code (compile-format-string
     1894                  'printf '##sys#standard-output
     1895                  x (cdr x)
     1896                  r c)))
     1897       (if code
     1898           code
     1899           x)))
     1900   env))
     1901
     1902(define (compile-format-string func out x args r c)
     1903  (call/cc
     1904   (lambda (return)
     1905     (and (>= (length args) 1)
     1906          (memq func extended-bindings) ; s.a.
     1907          (or (string? (car args))
     1908              (and (list? (car args))
     1909                   (c (r 'quote) (caar args))
     1910                   (string? (cadar args))))
     1911          (let ((fstr (if (string? (car args)) (car args) (cadar args)))
     1912                (args (cdr args)))
     1913            (define (fail ret? msg . args)
     1914              (let ((ln (get-line x)))
     1915                (compiler-warning
     1916                 'syntax
     1917                 "(~a) in format string ~s~a, ~?"
     1918                 func fstr
     1919                 (if ln (sprintf " in line ~a" ln) "")
     1920                 msg args) )
     1921              (when ret? (return #f)))
     1922            (let ((code '())
     1923                  (index 0)
     1924                  (len (string-length fstr))
     1925                  (%display (r 'display))
     1926                  (%write (r 'write))
     1927                  (%write-char (r 'write-char))
     1928                  (%out (r 'out))
     1929                  (%fprintf (r 'fprintf))
     1930                  (%let (r 'let))
     1931                  (%number->string (r 'number->string)))
     1932              (define (fetch)
     1933                (let ((c (string-ref fstr index)))
     1934                  (set! index (fx+ index 1))
     1935                  c) )
     1936              (define (next)
     1937                (if (null? args)
     1938                    (fail #t "too few arguments to formatted output procedure")
     1939                    (let ((x (car args)))
     1940                      (set! args (cdr args))
     1941                      x) ) )
     1942              (define (endchunk chunk)
     1943                (when (pair? chunk)
     1944                  (push
     1945                   (if (= 1 (length chunk))
     1946                       `(,%write-char ,(car chunk) ,%out)
     1947                       `(,%display ,(reverse-list->string chunk) ,%out)))))
     1948              (define (push exp)
     1949                (set! code (cons exp code)))
     1950              (let loop ((chunk '()))
     1951                (cond ((>= index len)
     1952                       (unless (null? args)
     1953                         (fail #f "too many arguments to formatted output procedure"))
     1954                       (endchunk chunk)
     1955                       `(,%let ((,%out ,out))
     1956                               ,@(reverse code)))
     1957                      (else
     1958                       (let ((c (fetch)))
     1959                         (if (eq? c #\~)
     1960                             (let ((dchar (fetch)))
     1961                               (endchunk chunk)
     1962                               (case (char-upcase dchar)
     1963                                 ((#\S) (push `(,%write ,(next) ,%out)))
     1964                                 ((#\A) (push `(,%display ,(next) ,%out)))
     1965                                 ((#\C) (push `(,%write-char ,(next) ,%out)))
     1966                                 ((#\B) (push `(,%display (,%number->string ,(next) 2) ,%out)))
     1967                                 ((#\O) (push `(,%display (,%number->string ,(next) 8) ,%out)))
     1968                                 ((#\X) (push `(,%display (,%number->string ,(next) 16) ,%out)))
     1969                                 ((#\!) (push `(##sys#flush-output ,%out)))
     1970                                 ((#\?)
     1971                                  (let* ([fstr (next)]
     1972                                         [lst (next)] )
     1973                                    (push `(##sys#apply ,%fprintf ,%out ,fstr ,lst))))
     1974                                 ((#\~) (push `(,write-char #\~ ,%out)))
     1975                                 ((#\% #\N) (push `(,%write-char #\newline ,%out)))
     1976                                 (else
     1977                                  (if (char-whitespace? dchar)
     1978                                      (let skip ((c (fetch)))
     1979                                        (if (char-whitespace? c)
     1980                                            (skip (fetch))
     1981                                            (set! index (sub1 index))))
     1982                                      (fail #t "illegal format-string character `~c'" dchar) ) ) )
     1983                               (loop '()) )
     1984                             (loop (cons c chunk)))))))))))))
Note: See TracChangeset for help on using the changeset viewer.