Changeset 7167 in project


Ignore:
Timestamp:
12/19/07 08:21:07 (12 years ago)
Author:
felix winkelmann
Message:

merged encoded literals branch

Location:
chicken/trunk
Files:
16 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/README

    r7081 r7167  
    33  (c)2000-2007 Felix L. Winkelmann
    44
    5   version 2.737
     5  version 2.738
    66
    77
     
    8686        To install CHICKEN for a particular PREFIX on a different
    8787        location, set the "DESTDIR" variable in addition to "PREFIX":
    88         It designates the directory where the files are copied
     88        It designates the directory where the files are installed
    8989        into.
    9090
  • chicken/trunk/batch-driver.scm

    r6827 r7167  
    6262  reorganize-recursive-bindings substitution-table simplify-named-call emit-unsafe-marker
    6363  perform-closure-conversion prepare-for-code-generation compiler-source-file create-foreign-stub expand-foreign-lambda*
    64   transform-direct-lambdas! source-filename compressed-literals literal-compression-threshold
     64  transform-direct-lambdas! source-filename
    6565  debugging-chicken bomb check-signature posq stringify symbolify build-lambda-list
    6666  string->c-identifier c-ify-string words check-and-open-input-file close-checked-input-file fold-inner constant?
     
    7272  topological-sort print-version print-usage initialize-analysis-database dump-exported-globals
    7373  default-declarations units-used-by-default words-per-flonum default-debugging-declarations
    74   default-profiling-declarations default-optimization-passes compressed-literals-initializer
     74  default-profiling-declarations default-optimization-passes
    7575  inline-max-size file-requirements use-import-table lookup-exports-file
    7676  foreign-string-result-reserve parameter-limit eq-inline-operator optimizable-rest-argument-operators
     
    130130        [hshrink (memq 'heap-shrinkage options)]
    131131        [kwstyle (memq 'keyword-style options)]
    132         [lcthreshold (memq 'compress-literals options)]
    133132        [uses-units '()]
    134133        [uunit (memq 'unit options)]
     
    262261      (register-feature! 'case-insensitive)
    263262      (case-sensitive #f) )
     263    (when (memq 'compress-literals options)
     264      (compiler-warning 'usage "`the -compress-literals' option is obsolete") )
    264265    (when kwstyle
    265266      (let ([val (option-arg kwstyle)])
     
    268269              [(string=? "suffix" val) (keyword-style #:suffix)]
    269270              [else (quit "invalid argument to `-keyword-style' option")] ) ) )
    270     (when lcthreshold
    271       (let ([t (option-arg lcthreshold)])
    272         (set! literal-compression-threshold
    273           (or (string->number t)
    274               (quit "invalid argument to `-compress-literals' option: ~A" t) ) ) ) )
    275271    (set! verbose-mode verbose)
    276272    (set! ##sys#read-error-with-line-number #t)
     
    456452                                  ',(cdr pl) ) )
    457453                              profile-lambda-list)
    458                          (let ([is (fold (lambda (clf r)
    459                                            `(let ([,(gensym)
    460                                                    (set! ,(car clf)
    461                                                      (##sys#read-from-string ',(cdr clf)))])
    462                                               ,r) )
    463                                          '(##core#undefined)
    464                                          compressed-literals) ] )
    465                            (if compressed-literals-initializer
    466                                `((##core#set! ,compressed-literals-initializer
    467                                               (lambda () ,is) ) )
    468                                (list is) ) )
    469454                         exps0
    470455                         (if (and (not unit-name) (not dynamic))
     
    604589
    605590                              (begin-time)
    606                               (receive (node literals lambdas) (prepare-for-code-generation node3 db)
     591                              (receive (node literals lliterals lambdas)
     592                                  (prepare-for-code-generation node3 db)
    607593                                (end-time "preparation")
    608594
     
    611597                                  (unless quiet
    612598                                    (printf "generating `~A' ...~%" outfile) )
    613                                   (generate-code literals lambdas out filename dynamic db)
     599                                  (generate-code literals lliterals lambdas out filename dynamic db)
    614600                                  (when outfile (close-output-port out)))
    615601                                (end-time "code generation")
  • chicken/trunk/buildversion

    r7080 r7167  
    1 2.737
     12.738
  • chicken/trunk/c-backend.scm

    r7078 r7167  
    5252  current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants
    5353  rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used
    54   mutable-constants
     54  mutable-constants encode-literal
    5555  broken-constant-nodes inline-substitutions-enabled
    5656  direct-call-ids foreign-type-table first-analysis block-variable-literal?
     
    111111;;; Generate target code:
    112112
    113 (define (generate-code literals lambdas out source-file dynamic db)
     113(define (generate-code literals lliterals lambdas out source-file dynamic db)
    114114  (let ()
    115115
     
    140140               (else (bomb "bad immediate")) ) )
    141141
    142             ((##core#literal) (gen "lf[" (first params) #\]))
     142            ((##core#literal)
     143             (let ((lit (first params)))
     144               (if (vector? lit)
     145                   (gen "((C_word)li" (vector-ref lit 0) ")")
     146                   (gen "lf[" (first params) #\])) ) )
    143147
    144148            ((if)
     
    456460               "   http://www.call-with-current-continuation.org" #t
    457461               "   " (+ 1900 year) #\- (pad0 (add1 mon)) #\- (pad0 mday) #\space (pad0 hour) #\: (pad0 min) #t
    458                "   " (chicken-version #t) #t
     462               (string-intersperse
     463                (map (cut string-append "   " <> "\n")
     464                     (string-split (chicken-version #t) "\n") )
     465                "")
    459466               "   command line: ")
    460467          (gen-list compiler-arguments)
     
    485492         used-units)
    486493        (unless (zero? n)
    487           (gen #t #t "static C_TLS C_word lf[" n"];") ) ) )
     494          (gen #t #t "static C_TLS C_word lf[" n "];") )
     495        (do ((i 0 (add1 i))
     496             (llits lliterals (cdr llits)))
     497            ((null? llits))
     498          (let* ((ll (##sys#lambda-info->string (car llits)))
     499                 (llen (string-length ll)))
     500            (gen #t "static C_char C_TLS li" i "[]={C_lihdr("
     501                 (arithmetic-shift llen -16) #\,
     502                 (bitwise-and #xff (arithmetic-shift llen -8)) #\,
     503                 (bitwise-and #xff llen)
     504                 #\))
     505            (do ((n 0 (add1 n)))
     506                ((>= n llen))
     507              (gen #\, (char->integer (string-ref ll n))) )
     508            (gen "};")))))
    488509 
    489510    (define (prototypes)
     
    625646 
    626647    (define (literal-frame)
    627       (do ([i 0 (+ i 1)]
     648      (do ([i 0 (add1 i)]
    628649           [lits literals (cdr lits)] )
    629650          ((null? lits))
    630         (gen-lit (car lits) (sprintf "lf[~s]" i) #t) ) )
     651        (gen-lit (car lits) (sprintf "lf[~s]" i)) ) )
    631652
    632653    (define (bad-literal lit)
     
    643664            [(##sys#immediate? lit) (bad-literal lit)]
    644665            [(##core#inline "C_lambdainfop" lit) 0]
    645             [(##sys#bytevector? lit)
    646              (if (##sys#permanent? lit)
    647                  0
    648                  (+ 2 (words (##sys#size lit))) ) ]
     666            [(##sys#bytevector? lit) (+ 2 (words (##sys#size lit))) ] ; drops "permanent" property!
    649667            [(##sys#generic-structure? lit)
    650668             (let ([n (##sys#size lit)])
     
    655673            [else (bad-literal lit)] ) )
    656674
    657     ;; This is currently not needed but will be handy for optimized literal lists/vector constructors...
    658     #;(define (imm-lit lit)
    659       (cond [(fixnum? lit) (string-append "C_fix(" (number->string lit) ")")]
    660             [(eq? #t lit) "C_SCHEME_TRUE"]
    661             [(eq? #f lit) "C_SCHEME_FALSE"]
    662             [(null? lit) "C_SCHEME_END_OF_LIST"]
    663             [(eq? lit (void)) "C_SCHEME_UNDEFINED"]
    664             [(char? lit) (string-append "C_make_character(" (number->string (char->integer lit)) ")")]
    665             [(eof-object? lit) "C_SCHEME_END_OF_FILE"]
    666             [(and (number? lit) (eq? 'fixnum number-type))
    667              (let ([flit (##sys#flo2fix lit)])
    668                (compiler-warning 'type "coerced inexact literal number `~S' to fixnum `~S'" lit flit)
    669                (string-append "C_fix(" (number->string flit) ")") ) ]
    670             [else #f] ) )
    671 
    672     (define (gen-lit lit to lf)
    673       (cond ((fixnum? lit)
    674              (cond ((big-fixnum? lit)
    675                     (gen #t to "=C_double_to_number(C_flonum(C_heaptop," lit ".0));") )
    676                    ((eq? 'flonum number-type)
    677                     (gen #t to "=C_flonum(C_heaptop," lit ");") )
    678                    (else (gen #t to "=C_fix(" lit ");") ) ) )
     675    (define (gen-lit lit to)
     676      ;; we do simple immediate literals directly to avoid a function call:
     677      (cond ((and (fixnum? lit) (not (big-fixnum? lit)))
     678             (gen #t to "=C_fix(" lit ");") )
    679679            ((block-variable-literal? lit))
    680680            ((eq? lit (void))
    681681             (gen #t to "=C_SCHEME_UNDEFINED;") )
    682             ((number? lit)
    683              (cond [(eq? 'fixnum number-type)
    684                     (let ([flit (##sys#flo2fix lit)])
    685                       (compiler-warning 'type "coerced inexact literal number `~S' to fixnum `~S'" lit flit)
    686                       (gen #t to "=C_fix(" flit ");") ) ]
    687                    [else
    688                     (let ((str (number->string lit)))
    689                       (if (and (> (string-length str) 1) (char-alphabetic? (string-ref str 1))) ; inf or nan?
    690                           (gen #t to "=C_flonum(C_heaptop, C_strtod(\"" lit "\", NULL));")
    691                           (gen #t to "=C_flonum(C_heaptop," lit ");"))) ] ) )
    692682            ((boolean? lit)
    693683             (gen #t to #\= (if lit "C_SCHEME_TRUE" "C_SCHEME_FALSE") #\;) )
    694684            ((char? lit)
    695685             (gen #t to "=C_make_character(" (char->integer lit) ");") )
    696             ((null? lit)
    697              (gen #t to "=C_SCHEME_END_OF_LIST;") )
    698             ((string? lit) (gen-string-like-lit to lit "C_static_string" #t))
    699             ((##core#inline "C_lambdainfop" lit) (gen-string-like-lit to lit "C_static_lambda_info" #t))
    700             ((pair? lit)
    701              (cond ((and (proper-list? lit) (pair? (cdr lit)))
    702                     (do ((len 0 (add1 len))
    703                          (lst lit (cdr lst)) )
    704                         ((null? lst)
    705                          (gen #t to "=C_h_list(" len)
    706                          (do ((k (sub1 len) (sub1 k)))
    707                              ((< k 0) (gen ");" #t "C_drop(" len ");"))
    708                            (gen ",C_pick(" k #\)) ) )
    709                       (gen-lit (car lst) "tmp" #f)
    710                       (gen #t "C_save(tmp);") ) )
    711                    (else
    712                     (gen-lit (car lit) "tmp" #f)
    713                     (gen #t "C_save(tmp);")
    714                     (gen-lit (cdr lit) "tmp" #f)
    715                     (gen #t to "=C_h_pair(C_restore,tmp);") ) ) )
    716             ((vector? lit) (gen-vector-like-lit to lit "C_h_vector"))
    717             ((symbol? lit)
     686            ((symbol? lit)              ; handled slightly specially (see C_h_intern_in)
    718687             (let* ([str (##sys#slot lit 1)]
    719688                    [cstr (c-ify-string str)]
    720689                    [len (##sys#size str)] )
    721690               (gen #t to "=")
    722                (if lf
    723                    (gen "C_h_intern(&" to #\, len #\, cstr ");")
    724                    (gen "C_intern(C_heaptop," len #\, cstr ");") ) ) )
     691               (gen "C_h_intern(&" to #\, len #\, cstr ");") ) )
     692            ((null? lit)
     693             (gen #t to "=C_SCHEME_END_OF_LIST;") )
    725694            ((##sys#immediate? lit) (bad-literal lit))
    726             ((##sys#bytevector? lit)
    727              (if (##sys#permanent? lit)
    728                  (gen-string-like-lit to lit "C_pbytevector" #f)
    729                  (gen-string-like-lit to lit "C_bytevector" #t) ) )
    730             ((##sys#generic-structure? lit) (gen-vector-like-lit to lit "C_h_structure"))
    731             (else (bad-literal lit)) ) )
    732 
    733     (define (gen-string-like-lit to lit conser top)
    734       (let* ([len (##sys#size lit)]
     695            ((##core#inline "C_lambdainfop" lit))
     696            (else
     697             (gen #t to "=C_decode_literal(C_heaptop,")
     698             (gen-string-constant (encode-literal lit))
     699             (gen ");") ) ) )
     700
     701    (define (gen-string-constant str)
     702      (let* ([len (##sys#size str)]
    735703             [ns (fx/ len 80)]
    736704             [srest (modulo len 80)] )
    737         (gen #t to #\= conser #\()
    738         (when top (gen "C_heaptop,"))
    739         (gen len #\,)
    740705        (do ([i ns (sub1 i)]
    741706             [offset 0 (+ offset 80)] )
    742707            ((zero? i)
    743708             (when (or (zero? len) (not (zero? srest)))
    744                (gen (c-ify-string (string-like-substring lit offset len))) )
    745              (gen ");") )
    746           (gen (c-ify-string (string-like-substring lit offset (+ offset 80))) #t) ) ) )
    747  
     709               (gen (c-ify-string (string-like-substring str offset len))) ) )
     710          (gen (c-ify-string (string-like-substring str offset (+ offset 80))) #t) ) ) )
     711 
    748712    (define (string-like-substring s start end)
    749713      (let* ([len (- end start)]
     
    751715        (##sys#copy-bytes s s2 start 0 len)
    752716        s2) )
    753 
    754     (define (gen-vector-like-lit to lit conser)
    755       (let ([len (##sys#size lit)])
    756         (do ([j 0 (+ j 1)]
    757              [n len (- n 1)] )
    758             ((zero? n)
    759              (gen #t to #\= conser #\( len)
    760              (do ([j (- len 1) (- j 1)])
    761                  ((< j 0) (gen ");" #t "C_drop(" len ");"))
    762                (gen ",C_pick(" j #\)) ) )
    763           (gen-lit (##sys#slot lit j) "tmp" #f)
    764           (gen #t "C_save(tmp);") ) ) )
    765717
    766718    (define (procedures)
     
    11421094           (gen #t "/* from " (cleanup rname) " */") )
    11431095         (generate-foreign-callback-header "" stub)
    1144          (gen #\{ #t "C_word x,s=" sizestr ",*a=C_alloc(s);")
    1145          (gen #t "C_callback_adjust_stack(a,s);")
     1096         (gen #\{ #t "C_word x, *a=C_alloc(" sizestr ");")
     1097         (gen #t "C_callback_adjust_stack_limits(a);")
    11461098         (for-each
    11471099          (lambda (v t)
     
    13751327                [else (err)] ) ]
    13761328             [else (err)] ) ) ) ) )
     1329
     1330
     1331;;; Encoded literals as strings, to be decoded by "C_decode_literal()"
     1332;;
     1333;; - everything hardcoded, using the FFI would be the ugly, but safer method.
     1334
     1335(define (encode-literal lit)
     1336  (define getbits
     1337    (foreign-lambda* int ((scheme-object lit))
     1338      "
     1339#ifdef C_SIXTY_FOUR
     1340return((C_header_bits(lit) >> (24 + 32)) & 0xff);
     1341#else
     1342return((C_header_bits(lit) >> 24) & 0xff);
     1343#endif
     1344") )
     1345  (define getsize
     1346    (foreign-lambda* int ((scheme-object lit))
     1347      "return(C_header_size(lit));"))
     1348  (define (encode-size n)
     1349    ;; only handles sizes in the 24-bit range!
     1350    (string (integer->char (bitwise-and #xff (arithmetic-shift n -16)))
     1351            (integer->char (bitwise-and #xff (arithmetic-shift n -8)))
     1352            (integer->char (bitwise-and #xff n))))
     1353  (define (finish str)             ; can be taken out at a later stage
     1354    (string-append (string #\xfe) str))
     1355  (finish
     1356   (cond ((eq? #t lit) "\xff\x06\x01")
     1357         ((eq? #f lit) "\xff\x06\x00")
     1358         ((char? lit) (string-append "\xff\x0a" (encode-size (char->integer lit))))
     1359         ((null? lit) "\xff\x0e")
     1360         ((eof-object? lit) "\xff\x3e")
     1361         ((eq? (void) lit) "\xff\x1e")
     1362         ((and (fixnum? lit) (not (big-fixnum? lit)))
     1363          (string-append
     1364           "\xff\x01"
     1365           (string (integer->char (bitwise-and #xff (arithmetic-shift lit -24)))
     1366                   (integer->char (bitwise-and #xff (arithmetic-shift lit -16)))
     1367                   (integer->char (bitwise-and #xff (arithmetic-shift lit -8)))
     1368                   (integer->char (bitwise-and #xff lit)) ) ) )
     1369         ((number? lit)
     1370          (string-append "\x55" (number->string lit) "\x00") )
     1371         ((symbol? lit)
     1372          (let ((str (##sys#slot lit 1)))
     1373            (string-append
     1374             "\x01"
     1375             (encode-size (string-length str))
     1376             str) ) )
     1377         ((##sys#immediate? lit)
     1378          (bomb "invalid literal - can not encode" lit))
     1379         ((##core#inline "C_byteblockp" lit)
     1380          (##sys#string-append ; relies on the fact that ##sys#string-append doesn't check
     1381           (string-append
     1382            (string (integer->char (getbits lit)))
     1383            (encode-size (getsize lit)) )
     1384           lit) )
     1385         (else
     1386          (let ((len (getsize lit)))
     1387            (string-intersperse
     1388             (cons*
     1389              (string (integer->char (getbits lit)))
     1390              (encode-size len)
     1391              (list-tabulate len (lambda (i) (encode-literal (##sys#slot lit i)))))
     1392             ""))))) )
  • chicken/trunk/c-platform.scm

    r6910 r7167  
    134134  '(debug output-file include-path heap-size stack-size unit uses keyword-style require-extension
    135135          inline-limit profile-name disable-warning emit-exports import
    136     prelude postlude prologue epilogue nursery extend feature compress-literals
     136    prelude postlude prologue epilogue nursery extend feature
     137    compress-literals                   ; DEPRECATED
    137138    heap-growth heap-shrinkage heap-initial-size ffi-define ffi-include-path) )
    138139
  • chicken/trunk/chicken.1

    r6423 r7167  
    5353.B \-check\-syntax
    5454Aborts compilation process after macro-expansion and syntax checks.
    55 
    56 .TP
    57 .B \-compress\-literals\ threshold
    58 Compiles quoted literals that exceed the size
    59 .BI threshold
    60 as strings
    61 and parse the strings at run-time. This reduces the size of the code and
    62 speeds up compile-times of the host C compiler, but has a small run-time
    63 performance penalty. The size of a literal is computed by counting recursively the objects
    64 in the literal, so a vector counts as 1 plus the count of the elements,
    65 a pair counts as the counts of the car and the cdr, respectively.
    66 All other objects count 1.
    6755
    6856.TP
  • chicken/trunk/chicken.h

    r7078 r7167  
    10821082
    10831083#define C_u_i_bit_setp(x, i)            C_mk_bool((C_unfix(x) & (1 << C_unfix(i))) != 0)
     1084
     1085#ifdef C_BIG_ENDIAN
     1086# ifdef C_SIXTY_FOUR
     1087#  define C_lihdr(x, y, z)              ((C_LAMBDA_INFO_TYPE >> 56) & 0xff), \
     1088                                        0, 0, 0, 0, (x), (y), (z)
     1089# else
     1090#  define C_lihdr(x, y, z)              ((C_LAMBDA_INFO_TYPE >> 24) & 0xff), \
     1091                                        (x), (y), (z)
     1092# endif
     1093#else
     1094# ifdef C_SIXTY_FOUR
     1095#  define C_lihdr(x, y, z)              (z), (y), (x), 0, 0, 0, 0, \
     1096                                        ((C_LAMBDA_INFO_TYPE >> 56) & 0xff)
     1097# else
     1098#  define C_lihdr(x, y, z)              (z), (y), (x), \
     1099                                        ((C_LAMBDA_INFO_TYPE >> 24) & 0xff)
     1100# endif
     1101#endif
    10841102
    10851103#define C_end_of_main
     
    15061524#endif
    15071525
     1526C_fctexport C_word C_fcall C_decode_literal(C_word **ptr, C_char *str) C_regparm;
     1527
    15081528/* defined in eval.scm: */
    15091529C_fctexport  void  CHICKEN_get_error_message(char *buf,int bufsize);
  • chicken/trunk/compiler.scm

    r6910 r7167  
    6868; (run-time-macros)
    6969; (export {<name>})
    70 ; (compress-literals [<threshold>])
    7170; (safe-globals)
    7271; (custom-declare (<tag> <name> <filename> <arg> ...) <string> ...)
     
    285284  pprint-expressions-to-file foreign-type-check estimate-foreign-result-size scan-used-variables scan-free-variables
    286285  topological-sort print-version print-usage initialize-analysis-database export-list csc-control-file
    287   estimate-foreign-result-location-size compressed-literals-initializer unused-variables
     286  estimate-foreign-result-location-size unused-variables
    288287  expand-foreign-callback-lambda default-optimization-passes default-optimization-passes-when-trying-harder
    289288  units-used-by-default words-per-flonum disable-stack-overflow-checking
     
    291290  membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
    292291  make-random-name final-foreign-type real-name-table real-name set-real-name! safe-globals-flag
    293   location-pointer-map literal-compression-threshold compressed-literals compressable-literal
     292  location-pointer-map
    294293  lookup-exports-file undefine-shadowed-macros process-lambda-documentation emit-syntax-trace-info
    295294  generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
     
    331330(define-constant real-name-table-size 997)
    332331(define-constant import-table-size 997)
    333 (define-constant default-literal-compression-threshold 50)
    334332(define-constant default-inline-max-size 10)
    335333
     
    361359(define source-filename #f)
    362360(define export-list #f)
    363 (define compressed-literals '())
    364 (define literal-compression-threshold #f)
    365 (define compressed-literals-initializer #f)
    366361(define safe-globals-flag #f)
    367362(define explicit-use-flag #f)
     
    544539                        ((quote)
    545540                         (##sys#check-syntax 'quote x '(quote _))
    546                          (let* ([lit (cadr x)]
    547                                 [cf (and literal-compression-threshold
    548                                          (compressable-literal lit literal-compression-threshold) ) ] )
    549                            (if cf
    550                                (let ([var (gensym 'lf)])
    551                                  (debugging 'o "compressing literal of size" cf)
    552                                  (set! compressed-literals
    553                                    (alist-cons var (write-to-string lit) compressed-literals) )
    554                                  (set! always-bound (cons var always-bound))
    555                                  (set! block-globals (cons var block-globals))
    556                                  var)
    557                                x) ) )
     541                         x)
    558542
    559543                        ((##core#check)
     
    11601144          (set! block-globals (lset-difference eq? block-globals syms))
    11611145          (set! export-list (lset-union eq? syms (or export-list '())))))
    1162        ((compress-literals)
    1163         (set! literal-compression-threshold
    1164           (or (and (pair? (cdr spec)) (number? (cadr spec)) (cadr spec))
    1165               default-literal-compression-threshold) )
    1166         (when (and (list? spec) (= 3 (length spec)))
    1167           (set! compressed-literals-initializer (third spec)) ) )
    11681146       ((emit-exports)
    11691147        (cond ((null? (cdr spec))
     
    20812059(define (prepare-for-code-generation node db)
    20822060  (let ([literals '()]
     2061        [lambda-info-literals '()]
    20832062        [lambdas '()]
    20842063        [temporaries 0]
     
    22942273      (cond [(immediate? x) (immediate-literal x)]
    22952274            [(and (number? x) (inexact? x)
    2296                   (list-index (lambda (y) (and (number? y) (inexact? y) (= x y))) literals) )
     2275                  (list-index (lambda (y) (and (number? y) (inexact? y) (= x y)))
     2276                              literals) )
    22972277             => values]
    2298             [(posq x literals) => values]
     2278            ((##core#inline "C_lambdainfop" x)
     2279             (let ((i (length lambda-info-literals)))
     2280               (set! lambda-info-literals
     2281                 (append lambda-info-literals (list x))) ;*** see below
     2282               (vector i) ) )
     2283            [(posq x literals) => identity]
    22992284            [else (new-literal x)] ) )
    23002285
    23012286    (define (new-literal x)
    23022287      (let ([i (length literals)])
    2303         (set! literals (append literals (list x))) ; could be optimized
     2288        (set! literals (append literals (list x))) ;*** could (should) be optimized
    23042289        i) )
    23052290
     
    23272312      (debugging 'o "fast global references" fastrefs)
    23282313      (debugging 'o "fast global assignments" fastsets)
    2329       (values node2 literals lambdas) ) ) )
     2314      (values node2 literals lambda-info-literals lambdas) ) ) )
  • chicken/trunk/csc.scm

    r7044 r7167  
    183183    -inline-limit -profile-name -disable-warning -import -require-static-extension
    184184    -feature -debug-level -heap-growth -heap-shrinkage -heap-initial-size -emit-exports
    185     -compress-literals) )
     185    -compress-literals) )               ; DEPRECATED
    186186
    187187(define-constant shortcuts
     
    443443    -debug MODES                display debugging output for the given modes
    444444    -compiler PATHNAME          use other compiler than default `chicken'
    445     -compress-literals NUMBER   compile literals above threshold as strings
    446445    -disable-c-syntax-checks    disable syntax checks of C code fragments
    447446    -raw                        do not generate implicit init- and exit code                           
  • chicken/trunk/manual/Declarations

    r5945 r7167  
    7171
    7272
    73 === compress-literals
    74 
    75  [declaration specifier] (compress-literals [THRESHOLD [INITIALIZER]])
    76 
    77 The same as the {{-compress-literals}} compiler option.
    78 The threshold argument defaults to 50. If the optional argument {{INITIALIZER}}
    79 is given, then the literals will not be created at module startup,
    80 but when the procedure with this name will be called.
    81 
    8273=== constant
    8374
  • chicken/trunk/manual/The User's Manual

    r7081 r7167  
    33== The User's Manual
    44
    5 ''(This document describes version 2.737)''
     5''(This document describes version 2.738)''
    66
    77'''CHICKEN is a compiler that translates Scheme source files into C''', which in
  • chicken/trunk/manual/Using the compiler

    r6691 r7167  
    3636
    3737; -check-syntax : Aborts compilation process after macro-expansion and syntax checks.
    38 
    39 ; -compress-literals THRESHOLD : Compiles quoted literals that exceed the size {{THRESHOLD}} as strings and parse the strings at run-time. This reduces the size of the code and speeds up compile-times of the host C compiler, but has a small run-time performance penalty. The size of a literal is computed by counting recursively the objects in the literal, so a vector counts as 1 plus the count of the elements, a pair counts as the counts of the car and the cdr, respectively. All other objects count 1.
    4038
    4139; -debug MODES : Enables one or more compiler debugging modes. {{MODES}} is a string of characters that select debugging information about the compiler that will be printed to standard output.
  • chicken/trunk/rules.make

    r7044 r7167  
    710710        $(LINKER) $(LINKER_OPTIONS) $(LINKER_STATIC_OPTIONS) $(COMPILER_STATIC_OBJECTS) \
    711711          $(LINKER_OUTPUT_OPTION) $@ libchicken$(A) $(LIBRARIES)
    712 $(CSI_STATIC_EXECUTABLE): csi$(O)
     712$(CSI_STATIC_EXECUTABLE): csi$(O) libchicken$(A)
    713713        $(LINKER) $(LINKER_OPTIONS) $(LINKER_STATIC_OPTIONS) $< $(LINKER_OUTPUT_OPTION) \
    714714          $@ libchicken$(A) $(LIBRARIES)
    715 $(CHICKEN_BUG_PROGRAM)$(EXE): chicken-bug$(O) $(PRIMARY_LIBCHICKEN)
     715$(CHICKEN_BUG_PROGRAM)$(EXE): chicken-bug$(O) libchicken$(A)
    716716        $(LINKER) $(LINKER_OPTIONS) $(LINKER_STATIC_OPTIONS) $< $(LINKER_OUTPUT_OPTION) \
    717717          $@ libchicken$(A) $(LIBRARIES)
     
    766766        $(MAKE) NEEDS_RELINKING=no RUNTIME_LINKER_PATH=$(LIBDIR) install
    767767        $(MAKE_WRITABLE_COMMAND) $(CHICKEN_PROGRAM)$(EXE) $(CSI_PROGRAM)$(EXE) \
    768           $(CSC_PROGRAM)$(EXE) $(CHICKEN_PROFILE_PROGRAM)$(EXE) $(CHICKEN_SETUP_PROGRAM)$(EXE)
     768          $(CSC_PROGRAM)$(EXE) $(CHICKEN_PROFILE_PROGRAM)$(EXE)
     769ifndef STATICBUILD
     770        $(MAKE_WRITABLE_COMMAND) $(CHICKEN_SETUP_PROGRAM)$(EXE)
     771endif
    769772else
    770773install: $(TARGETS) install-libs
  • chicken/trunk/runtime.c

    r7078 r7167  
    19431943{
    19441944  /* Intern as usual, but remember slot, if looked up symbol is in nursery.
    1945      also: allocatein static memory. */
     1945     also: allocate in static memory. */
    19461946  int key;
    19471947  C_word s;
     
    89648964  else return C_fix(s);
    89658965}
     8966
     8967
     8968static C_regparm C_uword C_fcall decode_size(C_char **str)
     8969{
     8970  C_uchar **ustr = (C_uchar **)str;
     8971  C_uword size = (*((*ustr)++) & 0xff) << 16; /* always big endian */
     8972
     8973  size |= (*((*ustr)++) & 0xff) << 8;
     8974  size |= (*((*ustr)++) & 0xff);
     8975  return size;
     8976}
     8977
     8978
     8979static C_regparm C_word C_fcall decode_literal2(C_word **ptr, C_char **str)
     8980{
     8981  unsigned long bits = *((*str)++) & 0xff;
     8982  C_word *data, *dptr, val;
     8983  C_uword size;
     8984
     8985  /* vvv this can be taken out at a later stage vvv */
     8986  if(bits != 0xfe)
     8987    panic(C_text("invalid encoded literal format"));
     8988
     8989  bits = *((*str)++) & 0xff;
     8990  /* ^^^ this can be taken out at a later stage ^^^ */
     8991
     8992#ifdef C_SIXTY_FOUR
     8993  bits <<= 24 + 32;
     8994#else
     8995  bits <<= 24;
     8996#endif
     8997
     8998  if(bits == C_HEADER_BITS_MASK) {              /* special/immediate */
     8999    switch(0xff & *((*str)++)) {
     9000    case C_BOOLEAN_BITS:
     9001      val = C_mk_bool(*((*str)++));
     9002      break;
     9003
     9004    case C_CHARACTER_BITS:
     9005      val = C_make_character(decode_size(str));
     9006      break;
     9007
     9008    case C_SCHEME_END_OF_LIST:
     9009    case C_SCHEME_UNDEFINED:
     9010    case C_SCHEME_END_OF_FILE:
     9011      val = (C_word)(*(*str - 1));
     9012      break;
     9013
     9014    case C_FIXNUM_BIT:
     9015      val = *((*str)++) << 24; /* always big endian */
     9016      val |= (*((*str)++) & 0xff) << 16;
     9017      val |= (*((*str)++) & 0xff) << 8;
     9018      val |= (*((*str)++) & 0xff);
     9019      val = C_fix(val);
     9020      break;
     9021
     9022    default:
     9023      panic(C_text("invalid encoded special literal"));
     9024    }
     9025
     9026    return val;
     9027  }
     9028
     9029#ifndef C_SIXTY_FOUR
     9030  if((bits & C_8ALIGN_BIT) != 0) {
     9031    /* Align _data_ on 8-byte boundary: */
     9032    if(aligned8(*ptr)) ++(*ptr);
     9033  }
     9034#endif
     9035
     9036  val = (C_word)(*ptr);
     9037
     9038  if(bits == C_FLONUM_TYPE) {
     9039    *((*ptr)++) = C_FLONUM_TAG;
     9040    data = *ptr;
     9041    *((double *)data) = C_strtod(*str, str);
     9042    ++(*str);                   /* skip terminating '\0' */
     9043    *ptr = (C_word *)((C_word)(*ptr) + sizeof(double));
     9044    return val;
     9045  }
     9046
     9047  if((bits & C_SPECIALBLOCK_BIT) != 0)
     9048    panic(C_text("literals with special bit can not be decoded"));
     9049
     9050  size = decode_size(str);
     9051
     9052  switch(bits) {
     9053  case C_STRING_TYPE:
     9054    /* strings are always allocated statically */
     9055    val = C_static_string(ptr, size, *str);
     9056    *str += size;
     9057    break;
     9058   
     9059  case C_SYMBOL_TYPE:
     9060    val = C_intern(ptr, size, *str);
     9061    *str += size;
     9062    break;
     9063
     9064  case C_LAMBDA_INFO_TYPE:
     9065    /* lambda infos are always allocated statically */
     9066    val = C_static_lambda_info(ptr, size, *str);
     9067    *str += size;
     9068    break;
     9069
     9070  default:
     9071    *((*ptr)++) = C_make_header(bits, size);
     9072    data = *ptr;
     9073
     9074    if((bits & C_BYTEBLOCK_BIT) != 0) {
     9075      C_memcpy(data, *str, size);
     9076      size = C_align(size);
     9077      *str += size;
     9078      *ptr = (C_word *)C_align((C_word)(*ptr) + size);
     9079    }
     9080    else {
     9081      C_word *dptr = *ptr;
     9082      *ptr += size;
     9083
     9084      while(size--) {
     9085        *(dptr++) = decode_literal2(ptr, str);
     9086      }
     9087    }
     9088  }
     9089
     9090  return val;
     9091}
     9092
     9093
     9094C_regparm C_word C_fcall C_decode_literal(C_word **ptr, C_char *str)
     9095{
     9096  return decode_literal2(ptr, &str);
     9097}
  • chicken/trunk/support.scm

    r6910 r7167  
    5959  reorganize-recursive-bindings substitution-table simplify-named-call
    6060  perform-closure-conversion prepare-for-code-generation compiler-source-file create-foreign-stub expand-foreign-lambda*
    61   transform-direct-lambdas! finish-foreign-result compressable-literal csc-control-file
     61  transform-direct-lambdas! finish-foreign-result csc-control-file
    6262  debugging-chicken bomb check-signature posq stringify symbolify build-lambda-list
    6363  string->c-identifier c-ify-string words words->bytes check-and-open-input-file close-checked-input-file fold-inner
     
    264264      (char? x)
    265265      (boolean? x) ) )
    266 
    267 (define (compressable-literal lit t)
    268   (let* ([count 0]
    269          [f (let rec ([x lit])
    270               (set! count (add1 count))
    271               (cond [(or (number? x) (char? x) (string? x) (boolean? x) (null? x) (symbol? x))] ; 1
    272                     [(pair? x)          ; car + cdr
    273                      (set! count (sub1 count))
    274                      (and (rec (car x)) (rec (cdr x))) ]
    275                     [(vector? x) (every rec (vector->list x))] ; 1 + elements
    276                     [else #f] ) ) ] )
    277     (and f (> count t) count) ) )
    278266
    279267(define (basic-literal? x)
     
    13301318
    13311319    -debug MODES                display debugging output for the given modes
    1332     -compress-literals NUMBER   compile literals above threshold as strings
    13331320    -unsafe-libraries           marks the generated file as being linked
    13341321                                with the unsafe runtime system
  • chicken/trunk/version.scm

    r7080 r7167  
    1 (define-constant +build-version+ "2.737")
     1(define-constant +build-version+ "2.738")
Note: See TracChangeset for help on using the changeset viewer.