Changeset 13911 in project


Ignore:
Timestamp:
03/25/09 00:25:01 (11 years ago)
Author:
felix winkelmann
Message:

scrutiny work

Location:
chicken/branches/scrutiny
Files:
7 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/scrutiny/batch-driver.scm

    r13755 r13911  
    513513                 (end-time "pre-analysis")
    514514                 (begin-time)
     515                 (debugging 'p "performing scrutiny")
    515516                 (scrutinize node0 db)
    516517                 (end-time "scrutiny")
  • chicken/branches/scrutiny/chicken.scm

    r12937 r13911  
    2727
    2828(declare
    29   (uses chicken-syntax srfi-1 srfi-4 utils files support compiler optimizer driver
     29  (uses chicken-syntax srfi-1 srfi-4 utils files support compiler optimizer scrutinizer driver
    3030        platform backend srfi-69)
    3131  (run-time-macros) )                   ;*** later: compile-syntax
  • chicken/branches/scrutiny/compiler.scm

    r13138 r13911  
    6969; (safe-globals)
    7070; (separate)
     71; (type (<symbol> <typespec>) ...)
    7172; (unit <unitname>)
    7273; (unsafe)
     
    14621463             (cut mark-variable <> '##compiler#inline-global 'yes)
    14631464             (stripa (cdr spec)))))
     1465       ((type)
     1466        (for-each
     1467         (lambda (spec)
     1468           (cond ((and (list? spec) (symbol? (car spec)) (= 2 (length spec)))
     1469                  (##sys#put! (car spec) '##core#type (cadr spec))
     1470                  (##sys#put! (car spec) '##core#declared-type #t))
     1471                 (else
     1472                  (compiler-warning 'syntax "illegal `type' declaration item `~s'" spec))))
     1473         (cdr spec)))
    14641474       (else (compiler-warning 'syntax "illegal declaration specifier `~s'" spec)) )
    14651475     '(##core#undefined) ) ) )
  • chicken/branches/scrutiny/defaults.make

    r13191 r13911  
    287287# Scheme compiler flags
    288288
    289 CHICKEN_OPTIONS = \
    290         -no-trace -optimize-level 2 \
    291         -include-path . -include-path $(SRCDIR)
     289#CHICKEN_OPTIONS = -no-trace -optimize-level 2 -optimize-level 2 -include-path . -include-path $(SRCDIR)
     290CHICKEN_OPTIONS = -optimize-level 2 -optimize-level 2 -include-path . -include-path $(SRCDIR)
    292291ifdef DEBUGBUILD
    293292CHICKEN_OPTIONS += -feature debugbuild
  • chicken/branches/scrutiny/rules.make

    r13782 r13911  
    12011201optimizer.c: $(SRCDIR)optimizer.scm $(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
    12021202        $(CHICKEN) $< $(CHICKEN_COMPILER_OPTIONS) -output-file $@
    1203 scrutinizer.c: $(SRCDIR)scrutinzer.scm $(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
     1203scrutinizer.c: $(SRCDIR)scrutinizer.scm $(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
    12041204        $(CHICKEN) $< $(CHICKEN_COMPILER_OPTIONS) -output-file $@
    12051205batch-driver.c: $(SRCDIR)batch-driver.scm $(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
  • chicken/branches/scrutiny/scrutinizer.scm

    r13782 r13911  
    6464  generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
    6565  foreign-argument-conversion foreign-result-conversion foreign-type-convert-argument foreign-type-convert-result
    66 
    6766  scrutinize load-type-database)
    6867
    6968
    7069(include "tweaks")
     70
     71
     72(define-syntax d
     73  (syntax-rules ()
     74    ((_ fstr args ...)
     75     (printf "[debug] ~?~%" fstr (list args ...)))))
    7176
    7277
     
    8388;   RESULTS = *
    8489;           | (VAL1 ...)
     90
     91; global symbol properties:
     92;
     93;   ##core#type           ->  <typespec>
     94;   ##core#declared-type  ->  <bool>
    8595
    8696(define (scrutinize node db)
     
    102112    (cond ((##sys#get id '##core#type) =>
    103113           (lambda (a)
    104              (cond ((get db id 'assigned)
     114             (cond ((and (get db id 'assigned)
     115                         (not (##sys#get id '##core#declared-type)))
    105116                    (##sys#put! id '##core#type #f)
    106117                    '*)
    107                    (else (list (cdr a))))))
     118                   (else (list a)))))
    108119          (else '*)))
    109120  (define (variable-result id e)
    110     (cond ((get db id 'assigned) '*)
     121    (cond ((and (get db id 'assigned)
     122                (not (##sys#get id '##core#declared-type)) )
     123           '*)
    111124          ((assq id e) =>
    112125           (lambda (a) (list (cdr a))))
    113           (else (global-result id e))))
     126          (else (global-result id))))
    114127  (define (always-true t loc)
    115128    (let ((f (cond ((and (pair? t) (eq? 'or (car t)))
    116                     (every always-true (cdr t)))
     129                    (every (cut always-true <> loc) (cdr t)))
    117130                   ((memq t '(* boolean undefined)) #f)
    118131                   (else #t))))
     
    163176               (map typename results))))))
    164177  (define (report loc expected given what #!optional desc)
    165     (warning "~a: in ~a~a, ~a~a"
    166              (location-name loc) (or desc "") what
    167              (if expected
    168                  (sprintf "expected ~a" expected)
    169                  "")
    170              (sprintf ", but where given ~a" given)))
     178    (compiler-warning
     179     'scrutiny
     180     "~a~a~a~a"
     181     (location-name loc) (or desc "")
     182     (if expected
     183         (sprintf "expected ~a~a~a" what (and what " ") expected)
     184         "")
     185     (sprintf ", but where given ~a" given)))
     186  (define (location-name loc)
     187    (cond ((not loc) "(at toplevel) ")
     188          ((null? (cdr loc))
     189           (conc "(in toplevel procedure `" (car loc) "') "))
     190          (else
     191           (string-append
     192            "("
     193            (let rec ((loc loc))
     194              (if (null? (cdr loc))
     195                  (conc "in toplevel procedure `" (car loc) "') ")
     196                  (conc
     197                   "in `" (car loc) "',"
     198                   (rec (cdr loc)))))))))
    171199  (define (simplify t)
     200    (let ((t2 (simplify1 t)))
     201      (d "simplify: ~a -> ~a" t t2)
     202      t2))
     203  (define (simplify1 t)
    172204    (if (pair? t)
    173205        (case (car t)
     
    182214                                  (list t))))
    183215                          (cdr t))))
    184                  (simplify `(or ,@(if (any (cut eq? <> '*) ts) '(*))) ts))))
     216                 (simplify `(or ,@(if (any (cut eq? <> '*) ts) '(*) ts))))))
    185217          ((procedure)
    186218           (let ((name (and (not (list? (cadr t))) (cadr t))))
     
    192224        t))
    193225  (define (match t1 t2)
     226    (let ((m (match1 t1 t2)))
     227      (d "match ~a <-> ~a -> ~a" t1 t2 m)
     228      m))
     229  (define (match1 t1 t2)
    194230    (or (eq? t1 t2)
    195231        (eq? t1 '*)
     
    197233        (and (eq? 'procedure t1) (and (pair? t2) (eq? 'procedure (car t2)))
    198234             (eq? 'procedure t2) (and (pair? t1) (eq? 'procedure (car t1))) )
    199         (and (not (pair? t1)) (not (pair? t2))
     235        (and (pair? t1) (pair? t2)
    200236             (or (and (eq? (car t1) 'or)
    201237                      (any (cut match <> t2)))
    202238                 (and (eq? (car t2) 'or)
    203239                      (any (cut match <> t2)))
    204                  (and (eq? (car t1) (car t2))
    205                       (and (eq? 'procedure (car t1))
    206                            (let ((args1 (if (pair? (cadr t1)) (cdddr t1) (cddr t1)))
    207                                  (args2 (if (pair? (cadr t2)) (cdddr t2) (cddr t2)))
    208                                  (results1 (if (pair? (cadr t2)) (cdddr t2) (cddr t2)))
    209                                  (results2 (if (pair? (cadr t2)) (cdddr t2) (cddr t2))) )
    210                              (match-args args1 args2)
    211                              (= (length results1) (length results2))
    212                              (every match (take results1 results2))))
    213                       (and (eq? 'struct (car t1))
    214                            (equal? t1 t2)))
    215                  (bomb "cannot match types: ~a + ~a" t1 t2)))))
     240                 (or (eq? (car t1) (car t2))
     241                     (and (eq? 'procedure (car t1))
     242                          (let ((args1 (if (pair? (second t1)) (second t1) (third t1)))
     243                                (args2 (if (pair? (second t2)) (second t2) (third t2)))
     244                                (results1 (if (pair? (second t2)) (cdddr t2) (cddr t2)))
     245                                (results2 (if (pair? (second t2)) (cdddr t2) (cddr t2))) )
     246                            (and (match-args args1 args2)
     247                                 (= (length results1) (length results2))
     248                                 (every match results1 results2))))
     249                     (and (eq? 'struct (car t1))
     250                          (equal? t1 t2)))))))
    216251  (define (match-args args1 args2)
    217252    (define (match-rest rtype args)
    218253      (let-values (((head tail) (break (cut eq? '#!rest <>) args)))
    219         (and (every (cut match-type rtype <>) head)
    220              (match-type
     254        (and (every (cut match rtype <>) head) ; match required args
     255             (match
    221256              rtype
    222257              (if (and (pair? tail) (pair? (cdr tail)))
     
    235270            ((match (car args1) (car args2)) (loop (cdr args1) (cdr args2)))
    236271            (else #f))))
    237   (define (check expected given loc what #!optional desc)
     272  (define (check expected given loc what #!optional desc)
     273    (d "check: ~a <-> ~a (~a)" expected given loc)
    238274    (if (match expected given)
    239275        given
     
    242278    (if (= n 1) "" "s"))
    243279  (define (single tv loc)
    244     (let ((n (length tv)))
    245       (cond ((= 1 n) (car tv))
    246             ((zero? n)
    247              (report loc "a single result" "zero results" #f)
    248              'void)
    249             (else
    250              (report loc "a single result" (sprintf "~a result~a" n (multiples n)) #f)
    251              (first tv)))))
     280    (if (eq? '* tv)
     281        '*
     282        (let ((n (length tv)))
     283          (cond ((= 1 n) (car tv))
     284                ((zero? n)
     285                 (report loc "a single result" "zero results" #f)
     286                 'void)
     287                (else
     288                 (report loc "a single result" (sprintf "~a result~a" n (multiples n)) #f)
     289                 (first tv))))))
    252290  (define (call-result args e loc)
     291    (d "call-result: ~a (~a)" args loc)
    253292    (let ((ptype (car args))
    254293          (nargs (length (cdr args))))
    255294      (check
    256        `(procedure ,(make-list (length (sub1 args)) '*) '*)
     295       `(procedure ,(make-list nargs '*) *)
    257296       ptype
    258        loc "a procedure")
     297       loc "a procedure of type")
    259298      (let ((atypes (procedure-argument-types ptype (length (cdr args)))))
     299        (d "  argument-types: ~a" atypes)
    260300        (unless (= (length atypes) nargs)
    261301          (report
     
    266306        (for-each
    267307         (lambda (arg argt)
    268            (check argt arg loc "argument") )
     308           (check argt arg loc "a procedure argument of type") )
    269309         atypes
    270310         (cdr args))
    271         (procedure-result-type ptype))))
     311        (let ((r (procedure-result-type ptype)))
     312          (d  "  result-type: ~a" r)
     313          r))))
    272314  (define (procedure-argument-types t n)
    273315    (cond ((or (memq t '(* procedure))
     
    276318          ((eq? 'procedure (car t))
    277319           (let loop ((at (if (or (string? (second t)) (symbol? (second t)))
    278                               (second t)
    279                               (third t)))
     320                              (third t)
     321                              (second t)))
    280322                      (m n))
    281323             (cond ((null? at) '())
    282324                   ((eq? '#!rest (car at))
    283325                    (if (pair? (cdr at))
    284                         (cadr at)
     326                        (make-list m (cadr at))
    285327                        (make-list m '*)))
    286328                   (else (cons (car at) (loop (cdr at) (sub1 m)))))))
     
    304346          (params (node-parameters n))
    305347          (class (node-class n)) )
    306       (case class
    307         ((quote) (constant-result (first params)))
    308         ((##core#undefined) '(undefined))
    309         ((##core#proc) '(procedure))
    310         ((##core#global-ref) (global-result (first params) loc))
    311         ((##core#variable) (variable-result (first params) e loc))
    312         ((if) (let ((rt (single (walk (first subs) e loc dest) loc)))
    313                 (when (always-true rt)
    314                   (report loc #f rt "`if'" "condition is always true"))
    315                (simplify `(or ,(walk (second subs) e loc dest)
    316                               ,(walk (third subs) e loc dest)))))
    317         ((let)
    318          (let ((t (single (walk (first subs) e loc (first params)) loc)))
    319            (walk (second subs) (alist-cons (first params) t e) loc dest)))
    320         ((##core#lambda)
    321          (decompose-lambda-list
    322           (third params)
    323           (lambda (vars argc rest)
    324             '((procedure
    325                ,@(if dest (list dest) '())
    326                ,(append (make-list argc '*) (if rest '(#!rest) '()))
    327                ,@(walk (first subs)
    328                        (if rest
    329                            (alist-cons
    330                             rest 'list
    331                             (append (map (lambda (v) (cons v '*))
    332                                          (if rest (butlast vars) vars))
    333                                     e)))
    334                        (cons dest loc)
    335                        #f))))))
    336         ((set!)
    337          (let ((rt (single (walk (first subs) e loc (first params)) loc)))
    338            '(undefined)))
    339         ((##core#primitive ##core#inline_ref) '*)
    340         ((##core#call)
    341          (let ((args (map (cut walk <> e loc #f) subs)))
    342            (call-result args e loc)))
    343         ((##core#switch ##core#cond)
    344          (bomb "unexpected node class: ~a" class))
    345         (else
    346          (for-each (lambda (n) (walk n e loc #f)) subs)
    347          '*))))
     348      (d "walk: ~a ~a (loc: ~a, dest: ~a)" class params loc dest)
     349      (let ((results
     350             (case class
     351               ((quote) (list (constant-result (first params))))
     352               ((##core#undefined) '(undefined))
     353               ((##core#proc) '(procedure))
     354               ((##core#global-ref) (global-result (first params)))
     355               ((##core#variable) (variable-result (first params) e))
     356               ((if) (let ((rt (single (walk (first subs) e loc dest) loc)))
     357                       (when (always-true rt loc)
     358                         (report loc #f rt "`if'" "condition is always true"))
     359                       (simplify `(or ,(walk (second subs) e loc dest)
     360                                      ,(walk (third subs) e loc dest)))))
     361               ((let)
     362                (let ((t (single (walk (first subs) e loc (first params)) loc)))
     363                  (walk (second subs) (alist-cons (first params) t e) loc dest)))
     364               ((##core#lambda)
     365                (decompose-lambda-list
     366                 (third params)
     367                 (lambda (vars argc rest)
     368                   '((procedure
     369                      ,@(if dest (list dest) '())
     370                      ,(append (make-list argc '*) (if rest '(#!rest) '()))
     371                      ,@(walk (first subs)
     372                              (if rest
     373                                  (alist-cons
     374                                   rest 'list
     375                                   (append (map (lambda (v) (cons v '*))
     376                                                (if rest (butlast vars) vars))
     377                                           e)))
     378                              (cons dest loc)
     379                              #f))))))
     380               ((set!)
     381                (let ((rt (single (walk (first subs) e loc (first params)) loc)))
     382                  '(undefined)))
     383               ((##core#primitive ##core#inline_ref) '*)
     384               ((##core#call)
     385                (let ((args (map (lambda (n) (single (walk n e loc #f) loc)) subs)))
     386                  (call-result args e loc)))
     387               ((##core#switch ##core#cond)
     388                (bomb "unexpected node class: ~a" class))
     389               (else
     390                (for-each (lambda (n) (walk n e loc #f)) subs)
     391                '*))))
     392        (d "  -> ~a" results)
     393        results)))
    348394  (walk node '() #f #f))
    349395
     
    351397  (and-let* ((rp (repository-path))
    352398             (dbfile (file-exists? (make-pathname rp name))))
    353     (dribble "loading type database ~a ..." dbfile)
     399    (when verbose-mode
     400      (printf "loading type database ~a ...~%" dbfile))
    354401    (for-each
    355402     (lambda (e)
  • chicken/branches/scrutiny/support.scm

    r13755 r13911  
    15211521  (and-let* ((rp (repository-path))
    15221522             (dbfile (file-exists? (make-pathname rp name))))
    1523     (dribble "loading identifier database ~a ..." dbfile)
     1523    (when verbose-mode
     1524      (printf "loading identifier database ~a ...~%" dbfile))
    15241525    (for-each
    15251526     (lambda (e)
Note: See TracChangeset for help on using the changeset viewer.