Changeset 14529 in project


Ignore:
Timestamp:
05/06/09 00:00:08 (10 years ago)
Author:
felix winkelmann
Message:

more types; scrutiny bugfixes; integrated scrutiny of core libs into build; -types option

Location:
chicken/branches/scrutiny
Files:
11 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/scrutiny/Makefile

    r12937 r14529  
    8181bench:
    8282        $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) bench
     83scrutiny:
     84        $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) scrutiny
    8385endif
  • chicken/branches/scrutiny/batch-driver.scm

    r13965 r14529  
    518518                 ;;;*** hardcoded database file name
    519519                 (load-type-database "types.db")
     520                 (for-each (cut load-type-database <> #f) (collect-options 'types))
    520521                 (begin-time)
    521522                 (set! first-analysis #f)
  • chicken/branches/scrutiny/c-platform.scm

    r13965 r14529  
    129129  '(debug output-file include-path heap-size stack-size unit uses keyword-style require-extension
    130130          inline-limit profile-name disable-warning parenthesis-synonyms
    131     prelude postlude prologue epilogue nursery extend feature
     131    prelude postlude prologue epilogue nursery extend feature types
    132132    emit-import-library emit-inline-file static-extension
    133133    heap-growth heap-shrinkage heap-initial-size ffi-define ffi-include-path) )
  • chicken/branches/scrutiny/csc.scm

    r14296 r14529  
    134134  '(-debug -output-file -heap-size -nursery -stack-size -compiler -unit -uses -keyword-style
    135135    -optimize-level -include-path -database-size -extend -prelude -postlude -prologue -epilogue
    136     -inline-limit -profile-name -disable-warning -emit-inline-file
     136    -inline-limit -profile-name -disable-warning -emit-inline-file -types
    137137    -feature -debug-level -heap-growth -heap-shrinkage -heap-initial-size
    138138    -emit-import-library -static-extension))
     
    333333    -profile-name FILENAME         name of the generated profile information
    334334                                    file
    335     -S  -scrutinize             perform local flow analysis
     335    -S  -scrutinize                perform local flow analysis
     336    -types FILENAME                load additional type database
    336337
    337338  Optimization options:
  • chicken/branches/scrutiny/defaults.make

    r14416 r14529  
    105105INSTALL_PROGRAM ?= xcopy
    106106MAKEDIR_COMMAND ?= -mkdir
     107XHERE ?=
    107108else
    108109INSTALL_PROGRAM ?= install
    109110MAKEDIR_COMMAND ?= mkdir
     111XHERE ?= $(SRCDIR)scripts/xhere
    110112endif
    111113POSTINSTALL_STATIC_LIBRARY ?= true
     
    273275
    274276CHICKEN ?= chicken$(EXE)
     277XCHICKEN ?= $(XHERE) $(CHICKEN)
    275278
    276279# interpreter for scripts
     
    288291CHICKEN_PROGRAM_OPTIONS = $(CHICKEN_OPTIONS) -no-lambda-info -inline -local
    289292CHICKEN_COMPILER_OPTIONS = $(CHICKEN_PROGRAM_OPTIONS) -extend private-namespace.scm
     293CHICKEN_SCRUTINY_OPTIONS = -types $(SRCDIR)types.db -analyze-only -scrutinize
    290294CHICKEN_UNSAFE_OPTIONS = -unsafe -no-lambda-info
    291295CHICKEN_DYNAMIC_OPTIONS = $(CHICKEN_OPTIONS) -feature chicken-compile-shared -dynamic
     
    305309        regex srfi-14 tcp foreign compiler scheme srfi-18 utils csi irregex
    306310IMPORT_LIBRARIES += setup-api setup-download
     311SCRUTINIZED_LIBRARIES = library eval data-structures ports files extras lolevel utils tcp srfi-1 srfi-4 srfi-13 \
     312       srfi-14 srfi-18 srfi-69 $(POSIXFILE) regex scheduler \
     313       profiler stub expand chicken-syntax
    307314
    308315ifdef STATICBUILD
  • chicken/branches/scrutiny/manual/Unit data-structures

    r13965 r14529  
    122122
    123123Returns {{LIST}} with its elements sorted in a random order given by
    124 procedure RANDOM.
     124procedure {{RANDOM}}.
    125125
    126126
  • chicken/branches/scrutiny/manual/Using the compiler

    r13965 r14529  
    180180; -static-extension NAME : similar to {{-require-extension NAME}}, but links extension statically (also applies for an explicit {{(require-extension NAME)}}).
    181181
     182; -types FILENAME : load additional type database from {{FILENAME}}. Type-definitions in {{FILENAME}} will override previous type-definitions.
     183
    182184; -compile-syntax : Makes macros also available at run-time. By default macros are not available at run-time.
    183185
  • chicken/branches/scrutiny/rules.make

    r14294 r14529  
    12471247          $(LIBCHICKEN_SO_FILE) $(LIBUCHICKEN_SO_FILE) $(LIBCHICKENGUI_SO_FILE) \
    12481248          libchicken$(A) libuchicken$(A) libchickengui$(A) libchicken$(SO) $(PROGRAM_IMPORT_LIBRARIES) \
    1249           $(IMPORT_LIBRARIES:=.import.so) $(LIBCHICKEN_IMPORT_LIBRARY) $(LIBUCHICKEN_IMPORT_LIBRARY) $(LIBCHICKENGUI_IMPORT_LIBRARY)  \
     1249          $(IMPORT_LIBRARIES:=.import.so) $(LIBCHICKEN_IMPORT_LIBRARY) $(LIBUCHICKEN_IMPORT_LIBRARY) \
     1250          $(LIBCHICKENGUI_IMPORT_LIBRARY)  \
    12501251          $(MSVC_CHICKEN_EXPORT_FILES) $(CLEAN_MINGW_LIBS) \
    1251           $(CLEAN_MANIFESTS)
     1252          $(CLEAN_MANIFESTS) *.scrutiny[12]
    12521253
    12531254confclean:
     
    13271328        LD_LIBRARY_PATH=$$here DYLD_LIBRARY_PATH=$$here PATH=$$here:$$PATH \
    13281329        $(CSI) -s cscbench.scm $(BENCHMARK_OPTIONS)
     1330
     1331
     1332# scrutiny
     1333
     1334.PHONY: scrutiny
     1335
     1336scrutiny: $(SCRUTINIZED_LIBRARIES:=.scrutiny1) $(COMPILER_OBJECTS_1:=.scrutiny2)
     1337
     1338%.scrutiny1: $(SRCDIR)%.scm
     1339        $(XCHICKEN) $< $(CHICKEN_SCRUTINY_OPTIONS) $(CHICKEN_LIBRARY_OPTIONS)
     1340        touch $@
     1341
     1342%.scrutiny2: $(SRCDIR)%.scm
     1343        $(XCHICKEN) $< $(CHICKEN_SCRUTINY_OPTIONS) $(CHICKEN_COMPILER_OPTIONS)
     1344        touch $@
  • chicken/branches/scrutiny/scrutinizer.scm

    r14525 r14529  
    7373  (printf "[debug] ~?~%" fstr args))
    7474
    75 ;(define-syntax d (syntax-rules () ((_ . _) (void))))
     75(define-syntax d (syntax-rules () ((_ . _) (void))))
    7676
    7777
     
    211211           (case (car t)
    212212             ((or)
    213               (if (= 2 (length t))
    214                   (simplify (second t))
    215                   (let* ((ts (append-map
    216                               (lambda (t)
    217                                 (let ((t (simplify t)))
    218                                   (cond ((and (pair? t) (eq? 'or (car t)))
    219                                          (cdr t))
    220                                         ((eq? 'noreturn t) '())
    221                                         ((eq? t 'undefined) (return 'undefined))
    222                                         (else (list t)))))
    223                               (cdr t)))
    224                          (ts2 (let loop ((ts ts))
    225                                 (cond ((null? ts) '())
    226                                       ((eq? '* (car ts)) (return '*))
    227                                       ((any (cut type<=? (car ts) <>) (cdr ts))
    228                                        (loop (cdr ts)))
    229                                       (else (cons (car ts) (loop (cdr ts))))))))
    230                     (cond ((equal? ts2 (cdr t)) t)
    231                           (else
    232                            (d "  or-simplify: ~a" ts2)
    233                            (simplify `(or ,@(if (any (cut eq? <> '*) ts2) '(*) ts2))))))))
     213              (cond ((= 2 (length t)) (simplify (second t)))
     214                    ((every procedure-type? (cdr t))
     215                     (if (any (cut eq? 'procedure <>) (cdr t))
     216                         'procedure
     217                         (reduce
     218                          (lambda (t pt)
     219                            (let* ((name1 (and (named? t) (cadr t)))
     220                                   (atypes1 (if name1 (third t) (second t)))
     221                                   (rtypes1 (if name1 (cdddr t) (cddr t)))
     222                                   (name2 (and (named? pt) (cadr pt)))
     223                                   (atypes2 (if name1 (third pt) (second pt)))
     224                                   (rtypes2 (if name1 (cdddr pt) (cddr pt))))
     225                              `(procedure
     226                                ,@(if (eq? name1 name2) (list name1) '())
     227                                ,(merge-argument-types atypes1 atypes2)
     228                                ,@(merge-result-types rtypes1 rtypes2))))
     229                          #f
     230                          (cdr t))))
     231                    (else
     232                     (let* ((ts (append-map
     233                                 (lambda (t)
     234                                   (let ((t (simplify t)))
     235                                     (cond ((and (pair? t) (eq? 'or (car t)))
     236                                            (cdr t))
     237                                           ((eq? 'noreturn t) '())
     238                                           ((eq? t 'undefined) (return 'undefined))
     239                                           (else (list t)))))
     240                                 (cdr t)))
     241                            (ts2 (let loop ((ts ts))
     242                                   (cond ((null? ts) '())
     243                                         ((eq? '* (car ts)) (return '*))
     244                                         ((any (cut type<=? (car ts) <>) (cdr ts))
     245                                          (loop (cdr ts)))
     246                                         (else (cons (car ts) (loop (cdr ts))))))))
     247                       (cond ((equal? ts2 (cdr t)) t)
     248                             (else
     249                              (d "  or-simplify: ~a" ts2)
     250                              (simplify `(or ,@(if (any (cut eq? <> '*) ts2) '(*) ts2)))))))) )
    234251             ((procedure)
    235252              (let* ((name (and (named? t) (cadr t)))
     
    247264         (eq? 'procedure (car t))
    248265         (not (or (null? (cadr t)) (pair? (cadr t))))))
     266  (define (merge-argument-types ts1 ts2)
     267    (cond ((null? ts1)
     268           (cond ((null? ts2) '())
     269                 ((memq (car ts2) '(#!rest #!optional)) ts2)
     270                 (else '(#!rest))))
     271          ((eq? '#!rest (car ts1))
     272           (cond ((eq? '#!rest (car ts2))
     273                  `(#!rest
     274                    ,(simplify
     275                      `(or ,(if (pair? (cdr ts1)) (cadr ts1) '*)
     276                           ,(if (pair? (cdr ts2)) (cadr ts2) '*)))))
     277                 (else '(#!rest))))             ;XXX giving up
     278          ((eq? '#!optional (car ts1))
     279           (cond ((eq? '#!optional (car ts2))
     280                  `(#!optional
     281                    ,(simplify `(or ,(cadr ts1) ,(cadr ts2)))
     282                    ,@(merge-argument-types (cddr ts1) (cddr ts2))))
     283                 (else '(#!rest))))     ;XXX
     284          (else (cons (simplify `(or ,(car ts1) ,(car ts2)))
     285                      (merge-argument-types (cdr ts1) (cdr ts2))))))
     286  (define (merge-result-types ts1 ts2)  ;XXX possibly overly conservative
     287    (cond ((null? ts1) ts2)
     288          ((null? ts2) ts1)
     289          (else (cons (simplify `(or ,(car ts1) ,(car ts2)))
     290                      (merge-result-types (cdr ts1) (cdr ts2))))))
    249291  (define (match t1 t2)
    250292    (let ((m (match1 t1 t2)))
     
    446488  (define (procedure-type? t)
    447489    (or (eq? 'procedure t)
    448         (and (pair? t) (eq? 'procedure (car t)))))
     490        (and (pair? t)
     491             (or (eq? 'procedure (car t))
     492                 (and (eq? 'or (car t))
     493                      (every procedure-type? (cdr t)))))))
    449494  (define (procedure-argument-types t n)
    450495    (cond ((or (memq t '(* procedure))
     
    466511                   ((and opt (<= m 0)) '())
    467512                   (else (cons (car at) (loop (cdr at) (sub1 m) opt))))))
    468           (else (bomb "not a procedure type: ~a" t))))
     513          (else (bomb "not a procedure type" t))))
    469514  (define (procedure-result-types t)
    470515    (cond ((or (memq t '(* procedure))
     
    555600  (walk (first (node-subexpressions node)) '() '() #f))
    556601
    557 (define (load-type-database name)
    558   (and-let* ((rp (repository-path))
    559              (dbfile (file-exists? (make-pathname rp name))))
     602(define (load-type-database name #!optional (path (repository-path)))
     603  (and-let* ((dbfile (file-exists? (make-pathname path name))))
    560604    (when verbose-mode
    561605      (printf "loading type database ~a ...~%" dbfile))
    562606    (for-each
    563607     (lambda (e)
    564        (##sys#put! (car e) '##core#type (cadr e)))
     608       (let* ((name (car e))
     609              (old (##sys#get name '##core#type))
     610              (new (cadr e)))
     611         (when (and old (not (equal? old new)))
     612           (compiler-warning
     613            'scrutiny
     614            "type-definition `~a' for toplevel binding `~a' conflicts with previously loaded type `~a'"
     615            name new old))
     616         (##sys#put! name '##core#type new)))
    565617     (read-file dbfile))))
    566618
  • chicken/branches/scrutiny/support.scm

    r13965 r14529  
    12841284                                  append mode
    12851285    -no-lambda-info              omit additional procedure-information
    1286     -scrutinize                 perform local flow analysis
     1286    -scrutinize                  perform local flow analysis
     1287    -types FILENAME              load additional type database
    12871288
    12881289  Optimization options:
  • chicken/branches/scrutiny/types.db

    r14525 r14529  
    245245(char-name (procedure char-name ((or char symbol) #!optional char) *))
    246246(chicken-home (procedure chicken-home () string))
    247 (chicken-version (procedure chicken-version () string))
     247(chicken-version (procedure chicken-version (#!optional *) string))
    248248(command-line-arguments (procedure command-line-arguments () list))
    249249(condition-predicate (procedure condition-predicate (symbol) (procedure ((struct condition)) boolean)))
     
    401401(with-exception-handler (procedure with-exception-handler (procedure procedure) . *))
    402402
     403;; data-structures
     404
     405(->string (procedure ->string (*) string))
     406(alist-ref (procedure alist-ref (* list #!optional (procedure (* *) *) *) *))
     407(alist-update! (procedure alist-update! (* * list #!optional (procedure (* *) *)) *))
     408(always? (procedure always? (#!rest) boolean))
     409(any? (procedure any? (*) boolean))
     410(atom? (procedure atom? (*) boolean))
     411(binary-search (procedure binary-search (vector (procedure (*) *)) *))
     412(butlast (procedure butlast (pair) list))
     413(chop (procedure chop (list number) list))
     414(complement (procedure complement (procedure) procedure))
     415(compose (procedure compose (#!rest procedure) procedure))
     416(compress (procedure compress (list list) list))
     417(conc (procedure conc (#!rest) string))
     418(conjoin (procedure conjoin (#!rest (procedure (*) *)) (procedure (*) *)))
     419(constantly (procedure constantly (#!rest) . *))
     420(disjoin (procedure disjoin (#!rest (procedure (*) *)) (procedure (*) *)))
     421(each (procedure each (#!rest procedure) procedure))
     422(flatten (procedure flatten (pair) list))
     423(flip (procedure flip ((procedure (* *) . *)) procedure))
     424(identity (procedure identity (*) *))
     425(intersperse (procedure intersperse (list *) list))
     426(join (procedure join (list list) list))
     427(left-section (procedure left-section (procedure #!rest) procedure))
     428(list->queue (procedure list->queue (list) (struct queue)))
     429(list-of? (procedure list-of? ((procedure (*) *)) (procedure (list) boolean)))
     430(make-queue (procedure make-queue () (struct queue)))
     431(merge (procedure merge (list list (procedure (* *) *)) list))
     432(merge! (procedure merge! (list list (procedure (* *) *)) list))
     433(never? (procedure never? (#!rest) boolean))
     434(none? (procedure none? (*) boolean))
     435(noop (procedure noop (#!rest) *))
     436(o (procedure o (#!rest (procedure (*) *)) (procedure (*) *)))
     437(project (procedure project (number) procedure))
     438(queue->list (procedure queue->list ((struct queue)) list))
     439(queue-add! (procedure queue-add! ((struct queue) *)) undefined)
     440(queue-empty? (procedure queue-empty? ((struct queue)) boolean))
     441(queue-first (procedure queue-first ((struct queue)) *))
     442(queue-last (procedure queue-last ((struct queue)) *))
     443(queue-push-back! (procedure queue-push-back! ((struct queue) *) undefined))
     444(queue-push-back-list! (procedure queue-push-back-list! ((struct queue) list) undefined))
     445(queue-remove! (procedure queue-remove! ((struct queue)) undefined))
     446(queue? (procedure queue? (*) boolean))
     447(rassoc (procedure rassoc (* list #!optional (procedure (* *) *)) *))
     448(right-section (procedure right-section (procedure #!rest) procedure))
     449(shuffle (procedure shuffle (list (procedure (number) number)) list))
     450(sort (procedure sort ((or list vector) (procedure (* *) *)) (or list vector)))
     451(sort! (procedure sort! ((or list vector) (procedure (* *) *)) undefined))
     452(sorted? (procedure sorted? ((or list vector) (procedure (* *) *)) boolean))
     453(string-chomp (procedure string-chomp (string #!optional string) string))
     454(string-chop (procedure string-chop (string number) list))
     455(string-compare3 (procedure string-compare3 (string string) number))
     456(string-compare3-ci (procedure string-compare3-ci (string string) number))
     457(string-intersperse (procedure string-intersperse (list #!optional string) string))
     458(string-split (procedure string-split (string #!optional string *) list))
     459(string-translate (procedure string-translate (string number #!optional number) string))
     460(string-translate* (procedure string-translate* (string list) string))
     461(substring-ci=? (procedure substring-ci=? (string string #!optional number number number) boolean))
     462(substring-index (procedure substring-index (string string #!optional number) number))
     463(substring-index-ci (procedure substring-index-ci (string string #!optional number) number))
     464(substring=? (procedure substring=? (string string #!optional number number number) boolean))
     465(tail? (procedure tail? (* *) boolean))
     466
    403467#!eof
    404 
    405 ;; data-structures
    406 
    407 (->string (procedure ->string () *))
    408 (alist-ref (procedure alist-ref () *))
    409 (alist-update! (procedure alist-update! () *))
    410 (always? (procedure always? () *))
    411 (any? (procedure any? () *))
    412 (atom? (procedure atom? () *))
    413 (binary-search (procedure binary-search () *))
    414 (butlast (procedure butlast () *))
    415 (chop (procedure chop () *))
    416 (complement (procedure complement () *))
    417 (compose (procedure compose () *))
    418 (compress (procedure compress () *))
    419 (conc (procedure conc () *))
    420 (conjoin (procedure conjoin () *))
    421 (constantly (procedure constantly () *))
    422 (disjoin (procedure disjoin () *))
    423 (each (procedure each () *))
    424 (flatten (procedure flatten () *))
    425 (flip (procedure flip () *))
    426 (identity (procedure identity () *))
    427 (intersperse (procedure intersperse () *))
    428 (join (procedure join () *))
    429 (left-section (procedure left-section () *))
    430 (list->queue (procedure list->queue () *))
    431 (list-of? (procedure list-of? () *))
    432 (make-queue (procedure make-queue () *))
    433 (merge (procedure merge () *))
    434 (merge! (procedure merge! () *))
    435 (never? (procedure never? () *))
    436 (none? (procedure none? () *))
    437 (noop (procedure noop () *))
    438 (o (procedure o () *))
    439 (project (procedure project () *))
    440 (queue->list (procedure queue->list () *))
    441 (queue-add! (procedure queue-add! () *))
    442 (queue-empty? (procedure queue-empty? () *))
    443 (queue-first (procedure queue-first () *))
    444 (queue-last (procedure queue-last () *))
    445 (queue-push-back! (procedure queue-push-back! () *))
    446 (queue-push-back-list! (procedure queue-push-back-list! () *))
    447 (queue-remove! (procedure queue-remove! () *))
    448 (queue? (procedure queue? () *))
    449 (rassoc (procedure rassoc () *))
    450 (right-section (procedure right-section () *))
    451 (shuffle (procedure shuffle () *))
    452 (sort (procedure sort () *))
    453 (sort! (procedure sort! () *))
    454 (sorted? (procedure sorted? () *))
    455 (string-chomp (procedure string-chomp () *))
    456 (string-chop (procedure string-chop () *))
    457 (string-compare3 (procedure string-compare3 () *))
    458 (string-compare3-ci (procedure string-compare3-ci () *))
    459 (string-intersperse (procedure string-intersperse () *))
    460 (string-split (procedure string-split () *))
    461 (string-translate (procedure string-translate () *))
    462 (string-translate* (procedure string-translate* () *))
    463 (substring-ci=? (procedure substring-ci=? () *))
    464 (substring-index (procedure substring-index () *))
    465 (substring-index-ci (procedure substring-index-ci () *))
    466 (substring=? (procedure substring=? () *))
    467 (tail? (procedure tail? () *))
    468468
    469469;; extras
Note: See TracChangeset for help on using the changeset viewer.