Changeset 12612 in project


Ignore:
Timestamp:
11/27/08 15:40:05 (11 years ago)
Author:
felix winkelmann
Message:

applied changes (untested)

Location:
chicken/branches/lazy-gensyms
Files:
9 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/lazy-gensyms/TODO

    r12610 r12612  
    127127    process-command-line                1    0.000    0.000    0.000
    128128
     129   possible optimizations:
     130
     131   - disable bound and procedure checks in expand.scm
     132   - unsafe module-accessors
     133   - highly bummed "lookup" (with inlined p-list accessor)
     134   - lazy gensyms (a la Chez)
     135
    129136** modules
    130137*** `require-extension' fails in interpreter when extension is .so without import library
     
    138145* tasks
    139146
    140 ** NEWS
    141 *** document changes between now and last time, this was updated
    142     (4.0.0x2 doesn't appear, for example)
     147** library
     148*** check all uses of gensym (omit prefix, if possible; use ##sys#gensym)
    143149
    144150** branches
  • chicken/branches/lazy-gensyms/c-backend.scm

    r12546 r12612  
    690690             (gen #t to "=C_make_character(" (char->integer lit) ");") )
    691691            ((symbol? lit)              ; handled slightly specially (see C_h_intern_in)
    692              (let* ([str (##sys#slot lit 1)]
     692             (let* ([str (##sys#symbol-name lit)]
    693693                    [cstr (c-ify-string str)]
    694694                    [len (##sys#size str)] )
     
    13951395          (string-append "\x55" (number->string lit) "\x00") )
    13961396         ((symbol? lit)
    1397           (let ((str (##sys#slot lit 1)))
     1397          (let ((str (##sys#symbol-name lit)))
    13981398            (string-append
    13991399             "\x01"
  • chicken/branches/lazy-gensyms/csi.scm

    r12559 r12612  
    637637            [(symbol? x)
    638638             (unless (##sys#symbol-has-toplevel-binding? x) (display "unbound " out))
    639              (when (and (symbol? x) (fx= 0 (##sys#byte (##sys#slot x 1) 0)))
    640                (display "keyword " out) )
    641              (fprintf out "~asymbol with name ~S~%"
    642                       (if (##sys#interned-symbol? x) "" "uninterned ")
    643                       (##sys#symbol->string x))
    644              (let ((plist (##sys#slot x 2)))
    645                (unless (null? plist)
    646                  (display "  \nproperties:\n\n" out)
    647                  (do ((plist plist (cddr plist)))
    648                      ((null? plist))
    649                    (fprintf out "  ~s\t" (car plist))
    650                    (##sys#with-print-length-limit
    651                     1000
    652                     (lambda ()
    653                       (write (cadr plist) out) ) )
    654                    (newline out) ) ) ) ]
     639             (let ((name (##sys#slot x 1)))
     640               (cond ((fixnum? name)
     641                      (fprintf out "uninstantiated uninterned gensym ~a~%" name))
     642                     (else
     643                      (when (fx= 0 (##sys#byte name 0))
     644                        (display "keyword " out) ) )
     645                     (fprintf out "~asymbol with name ~S~%"
     646                              (if (##sys#interned-symbol? x) "" "uninterned ")
     647                              (##sys#symbol->string x)))
     648               (let ((plist (##sys#slot x 2)))
     649                 (unless (null? plist)
     650                   (display "  \nproperties:\n\n" out)
     651                   (do ((plist plist (cddr plist)))
     652                       ((null? plist))
     653                     (fprintf out "  ~s\t" (car plist))
     654                     (##sys#with-print-length-limit
     655                      1000
     656                      (lambda ()
     657                        (write (cadr plist) out) ) )
     658                     (newline out) ) ) ) ) ]
    655659            [(list? x) (descseq "list" length list-ref 0)]
    656660            [(pair? x) (fprintf out "pair with car ~S and cdr ~S~%" (car x) (cdr x))]
  • chicken/branches/lazy-gensyms/eval.scm

    r12559 r12612  
    157157          (##core#inline "C_fixnum_modulo" cache-h n)
    158158          (begin
    159               (set! cache-s s)
    160               (set! cache-h (##core#inline "C_hash_string" (##sys#slot s 1)))
    161               (##core#inline "C_fixnum_modulo" cache-h n))))))
     159            (set! cache-s s)
     160            (set! cache-h
     161              (let ((sn (##sys#slot s 1)))
     162                (##core#inline "C_hash_string" sn)))
     163            (##core#inline "C_fixnum_modulo" cache-h n))))))
    162164
    163165(define (##sys#hash-table-ref ht key)
     
    186188    (do ((i 0 (fx+ i 1)))
    187189        ((fx>= i len))
    188       (##sys#for-each (lambda (bucket)
    189                    (p (##sys#slot bucket 0)
    190                       (##sys#slot bucket 1) ) )
    191                  (##sys#slot ht i) ) ) ) )
     190      (for-each
     191       (lambda (bucket)
     192         (p (##sys#slot bucket 0)
     193            (##sys#slot bucket 1) ) )
     194       (##sys#slot ht i) ) ) ) )
    192195
    193196(define ##sys#hash-table-location
     
    10061009        [display display] )
    10071010    (lambda (uname lib)
    1008       (let ([id (##sys#->feature-id uname)])
     1011      (let ((id (##sys#->feature-id uname))
     1012            (sname (##sys#symbol->string uname)))
    10091013        (or (memq id ##sys#features)
    10101014            (let ([libs
    10111015                   (if lib
    10121016                       (##sys#list lib)
    1013                        (cons (##sys#string-append (##sys#slot uname 1) ##sys#load-library-extension)
     1017                       (cons (##sys#string-append
     1018                              sname
     1019                              ##sys#load-library-extension)
    10141020                             (dynamic-load-libraries) ) ) ]
    10151021                  [top
     
    10171023                    (string-append
    10181024                     "C_"
    1019                      (##sys#string->c-identifier (##sys#slot uname 1))
     1025                     (##sys#string->c-identifier sname)
    10201026                     "_toplevel") ) ] )
    10211027              (when (load-verbose)
     
    13051311   (define (->string x)
    13061312     (cond ((string? x) x)
    1307            ((symbol? x) (##sys#slot x 1))
     1313           ((symbol? x) (##sys#symbol->string x 1))
    13081314           ((number? x) (##sys#number->string x))
    13091315           (else (error "invalid extension version" x)) ) )
  • chicken/branches/lazy-gensyms/expand.scm

    r12609 r12612  
    7474(define (macro-alias var se)
    7575  (if (or (##sys#qualified-symbol? var)
    76           (let* ((str (##sys#slot var 1))
    77                  (len (##sys#size str)))
    78             (and (fx> len 0)
    79                  (char=? #\# (##core#inline "C_subchar" str 0)))))
     76          (let ((str (##sys#slot var 1)))
     77            (and (not (fixnum? str))
     78                 (let ((len (##sys#size str)))
     79                   (and (fx> len 0)             ;*** what would happen if we remove this?
     80                        (char=? #\# (##core#inline "C_subchar" str 0)))))))
    8081      var
    8182      (let* ((alias (gensym var))
     
    251252  (##sys#string->symbol
    252253   (string-append
    253     (##sys#slot prefix 1)
     254    (##sys#slot prefix 1)               ;*** must be symbol with name!
    254255    "#"
    255     (##sys#slot sym 1) ) ) )
     256    (##sys#symbol-name sym) ) ) )
    256257
    257258(define (##sys#alias-global-hook sym assign)
     
    317318    (lambda (llist0 body errh se)
    318319      (define (err msg) (errh msg llist0))
    319       (define (->keyword s) (string->keyword (##sys#slot s 1)))
     320      (define (->keyword s) (string->keyword (##sys#symbol-name s)))
    320321      (let ([rvar #f]
    321322            [hasrest #f]
     
    15121513                          (let ((palias
    15131514                                 (##sys#string->symbol
    1514                                   (##sys#string-append "#%" (##sys#slot ve 1)))))
     1515                                  (##sys#string-append "#%" (##sys#symbol-name ve)))))
    15151516                            (##sys#put! palias '##core#primitive ve)
    15161517                            (cons ve palias))
  • chicken/branches/lazy-gensyms/extras.scm

    r12595 r12612  
    390390                                        (cond [(char-name obj)
    391391                                               => (lambda (cn)
    392                                                     (out (##sys#slot cn 1) col) ) ]
     392                                                    (out (##sys#symbol-name cn) col) ) ]
    393393                                              [(fx< code 32)
    394394                                               (out "x" col)
  • chicken/branches/lazy-gensyms/library.scm

    r12331 r12612  
    11041104  (##sys#intern-symbol str) )
    11051105
     1106(define (##sys#symbol-name sym)
     1107  (let ((n (##sys#slot sym 1)))
     1108    (if (fixnum? n)
     1109        (let ((n (##sys#string-append
     1110                  (or (##sys#get (##sys#slot sym 2) '##core#gensym-prefix)
     1111                      "g")
     1112                  (##sys#number->string n))))
     1113          (##sys#setslot sym 1 n)
     1114          n)
     1115        n)))
     1116
    11061117(define ##sys#symbol->string)
    11071118(define ##sys#symbol->qualified-string)
     
    11191130  (set! ##sys#symbol->string
    11201131    (lambda (s)
    1121       (let* ([str (##sys#slot s 1)]
     1132      (let* ([str (##sys#symbol-name s)]
    11221133             [len (##sys#size str)]
    11231134             [i (split str len)] )
     
    11261137  (set! ##sys#symbol->qualified-string
    11271138    (lambda (s)
    1128       (let* ([str (##sys#slot s 1)]
     1139      (let* ([str (##sys#symbol-name s)]
    11291140             [len (##sys#size str)]
    11301141             [i (split str len)] )
     
    11351146  (set! ##sys#qualified-symbol-prefix
    11361147    (lambda (s)
    1137       (let* ([str (##sys#slot s 1)]
     1148      (let* ([str (##sys#symbol-name s)]
    11381149             [len (##sys#size str)]
    11391150             [i (split str len)] )
     
    11411152
    11421153(define (##sys#qualified-symbol? s)
    1143   (let ((str (##sys#slot s 1)))
     1154  (let ((str (##sys#symbol-name s)))
    11441155    (and (fx> (##sys#size str) 0)
    11451156         (fx<= (##sys#byte str 0) namespace-max-id-len))))
     
    11681179      (##sys#make-symbol (string-copy str)) ) ) )
    11691180
    1170 (define gensym
    1171   (let ([counter -1])
    1172     (lambda str-or-sym
    1173       (let ([err (lambda (prefix) (##sys#signal-hook #:type-error 'gensym "argument is not a string or symbol" prefix))])
    1174         (set! counter (fx+ counter 1))
    1175         (##sys#make-symbol
    1176          (##sys#string-append
    1177           (if (eq? str-or-sym '())
    1178               "g"
    1179               (let ([prefix (car str-or-sym)])
    1180                 (or (and (##core#inline "C_blockp" prefix)
    1181                          (cond [(##core#inline "C_stringp" prefix) prefix]
    1182                                [(##core#inline "C_symbolp" prefix) (##sys#symbol->string prefix)]
    1183                                [else (err prefix)] ) )
    1184                     (err prefix) ) ) )
    1185           (##sys#number->string counter) ) ) ) ) ) )
     1181(define ##sys#gensym)
     1182(define gensym)
     1183
     1184(let ([counter -1])
     1185  (set! gensym
     1186    (lambda (#!optional prefix)
     1187      (if (not prefix)
     1188          (##sys#gensym)
     1189          (let ([err (lambda (prefix) (##sys#signal-hook #:type-error 'gensym "argument is not a string or symbol" prefix))])
     1190            (set! counter (fx+ counter 1))
     1191            (let ((sym (##sys#make-symbol counter)))
     1192              (##sys#setslot
     1193               sym 2
     1194               (list '##core#gensym-prefix
     1195                     (or (and (##core#inline "C_blockp" prefix)
     1196                              (cond [(##core#inline "C_stringp" prefix) prefix]
     1197                                    [(##core#inline "C_symbolp" prefix)
     1198                                     (let ((n2 (##sys#slot prefix 1)))
     1199                                       (if (fixnum? n2)
     1200                                           "g"
     1201                                           prefix)) ]
     1202                                    [else (err prefix)] )  )
     1203                         (err prefix) ) ) )
     1204              sym)))))
     1205  (set! ##sys#gensym
     1206    (lambda ()                          ; fast gensym with lazily created name
     1207      (set! counter (fx+ counter 1))    ; (see ##sys#symbol-name)
     1208      (##sys#make-symbol counter))))
    11861209
    11871210
     
    11891212
    11901213(define (keyword? x)
    1191   (and (symbol? x) (fx= 0 (##sys#byte (##sys#slot x 1) 0))) )
     1214  (and (symbol? x)
     1215       (let ((name (##sys#slot x 1)))
     1216         (and (not (fixnum? name))
     1217              (fx= 0 (##sys#byte (##sys#slot x 1) 0))) )))
    11921218
    11931219(define string->keyword
     
    28502876                ((##core#inline "C_forwardedp" x) (outstr port "#<invalid forwarded object>"))
    28512877                ((##core#inline "C_symbolp" x)
    2852                  (cond [(fx= 0 (##sys#byte (##sys#slot x 1) 0))
     2878                 (cond [(fx= 0 (##sys#byte (##sys#symbol-name x) 0))
    28532879                        (let ([str (##sys#symbol->string x)])
    28542880                          (case ksp
     
    28622888                             (outstr port "#:")
    28632889                             (outstr port str) ] ) ) ]
    2864                        [(memq x '(#!optional #!key #!rest)) (outstr port (##sys#slot x 1))]
     2890                       [(memq x '(#!optional #!key #!rest)) (outstr port (##sys#symbol-name x))]
    28652891                       [else
    28662892                        (let ([str (##sys#symbol->qualified-string x)])
     
    44644490        (let ([prefix
    44654491               (and prefix
    4466                     (cond [(symbol? prefix) (##sys#slot prefix 1)]
     4492                    (cond [(symbol? prefix) (##sys#symbol-name prefix)]
    44674493                          [(string? prefix) prefix]
    44684494                          [else (##sys#signal-hook #:type-error "bad argument type - invalid prefix" prefix)] ) ) ] )
    4469           (let ([nsp (##sys#find-symbol-table (##sys#make-c-string (##sys#slot ns 1)))])
     4495          (let ([nsp (##sys#find-symbol-table (##sys#make-c-string (##sys#symbol-name ns)))])
    44704496            (define (copy s str)
    44714497              (let ([s2 (##sys#intern-symbol
     
    45024528(define (##sys#namespace-ref ns sym . default)
    45034529  (let ([s (##sys#find-symbol
    4504             (cond [(symbol? sym) (##sys#slot sym 1)]
     4530            (cond [(symbol? sym) (##sys#symbol-name sym)]
    45054531                  [(string? sym) sym]
    45064532                  [else (##sys#signal-hook #:type-error "bad argument type - not a valid import name" sym)] )
    4507             (##sys#find-symbol-table (##sys#make-c-string (##sys#slot ns 1))) ) ] )
     4533            (##sys#find-symbol-table (##sys#make-c-string (##sys#symvbol-name ns))) ) ] )
    45084534    (cond [s (##core#inline "C_retrieve" s)]
    45094535          [(pair? default) (car default)]
  • chicken/branches/lazy-gensyms/lolevel.scm

    r10788 r12612  
    323323  (let copy ([x x])
    324324    (cond [(not (##core#inline "C_blockp" x)) x]
    325           [(symbol? x) (##sys#intern-symbol (##sys#slot x 1))]
     325          [(symbol? x) (##sys#intern-symbol (##sys#symbol-name x))]
    326326          [else
    327327            (let* ([n (##sys#size x)]
     
    432432
    433433(define object-size
    434     (lambda (x)
    435       (let ([tab (##sys#make-vector evict-table-size '())])
    436         (let evict ([x x])
    437           (cond [(not (##core#inline "C_blockp" x)) 0]
    438                 [(##sys#hash-table-ref tab x) 0]
    439                 [else
    440                 (let* ([n (##sys#size x)]
    441                         [bytes
    442                         (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
    443                               (##core#inline "C_bytes" 1) ) ] )
    444                    (##sys#hash-table-set! tab x #t)
    445                    (unless (##core#inline "C_byteblockp" x)
    446                      (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x))
    447                                 1
    448                                 0)
    449                              (fx+ i 1) ] )
    450                         ((fx>= i n))
    451                        (set! bytes (fx+ (evict (##sys#slot x i)) bytes)) ) )
    452                    bytes) ] ) ) ) ) )
     434  (lambda (x)
     435    (let ([tab (##sys#make-vector evict-table-size '())])
     436      (let evict ([x x])
     437        (cond [(not (##core#inline "C_blockp" x)) 0]
     438              [(##sys#hash-table-ref tab x) 0]
     439              [else
     440              (let* ([n (##sys#size x)]
     441                      [bytes
     442                      (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
     443                            (##core#inline "C_bytes" 1) ) ] )
     444                 (##sys#hash-table-set! tab x #t)
     445                 (unless (##core#inline "C_byteblockp" x)
     446                   (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x))
     447                              1
     448                              0)
     449                           (fx+ i 1) ] )
     450                      ((fx>= i n))
     451                     (set! bytes (fx+ (evict (##sys#slot x i)) bytes)) ) )
     452                 bytes) ] ) ) ) ) )
    453453
    454454(define object-unevict
    455     (lambda (x #!optional (full #f))
    456       (define (err x)
    457         (##sys#signal-hook #:type-error 'object-unevict "can not copy object" x) )
    458       (let ([tab (##sys#make-vector evict-table-size '())])
    459         (let copy ([x x])
    460           (cond [(not (##core#inline "C_blockp" x)) x]
    461                 [(not (##core#inline "C_permanentp" x)) x]
    462                 [(##sys#hash-table-ref tab x)]
    463                 [(##core#inline "C_byteblockp" x)
    464                 (if full
    465                      (let ([y (##core#inline "C_copy_block" x (##sys#make-string (##sys#size x)))])
    466                        (##sys#hash-table-set! tab x y)
    467                        y)
    468                      x) ]
    469                 [(symbol? x)
    470                  (let ([y (##sys#intern-symbol (##sys#slot x 1))])
    471                    (##sys#hash-table-set! tab x y)
    472                    y) ]
    473                 [else
    474                 (let* ([words (##sys#size x)]
    475                         [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
    476                    (##sys#hash-table-set! tab x y)
    477                    (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
    478                        ((fx>= i words))
    479                      (##sys#setslot y i (copy (##sys#slot y i))) )
    480                    y) ] ) ) ) ) )
     455  (lambda (x #!optional (full #f))
     456    (define (err x)
     457      (##sys#signal-hook #:type-error 'object-unevict "can not copy object" x) )
     458    (let ([tab (##sys#make-vector evict-table-size '())])
     459      (let copy ([x x])
     460        (cond [(not (##core#inline "C_blockp" x)) x]
     461              [(not (##core#inline "C_permanentp" x)) x]
     462              [(##sys#hash-table-ref tab x)]
     463              [(##core#inline "C_byteblockp" x)
     464              (if full
     465                   (let ([y (##core#inline "C_copy_block" x (##sys#make-string (##sys#size x)))])
     466                     (##sys#hash-table-set! tab x y)
     467                     y)
     468                   x) ]
     469              [(symbol? x)
     470               (let ([y (##sys#intern-symbol (##sys#symbol-name x))])
     471                 (##sys#hash-table-set! tab x y)
     472                 y) ]
     473              [else
     474              (let* ([words (##sys#size x)]
     475                      [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
     476                 (##sys#hash-table-set! tab x y)
     477                 (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
     478                     ((fx>= i words))
     479                   (##sys#setslot y i (copy (##sys#slot y i))) )
     480                 y) ] ) ) ) ) )
    481481
    482482
  • chicken/branches/lazy-gensyms/srfi-69.scm

    r12262 r12612  
    196196
    197197(define-inline (%symbol-hash obj)
    198   (%string-hash (##sys#slot obj 1)) )
     198  (%string-hash (##sys#symbol-name obj)) )
    199199
    200200(define (symbol-hash obj #!optional (bound hash-default-bound))
     
    216216
    217217(define-inline (%keyword-hash obj)
    218   (%string-hash (##sys#slot obj 1)) )
     218  (%string-hash (##sys#symbol-name obj)) )
    219219
    220220(define (keyword-hash obj #!optional (bound hash-default-bound))
Note: See TracChangeset for help on using the changeset viewer.