~ chicken-core (chicken-5) ff5ec0968e287aa3d8ae65378fbc806a26cc2523
commit ff5ec0968e287aa3d8ae65378fbc806a26cc2523
Merge: 2d9ddc53 c9a081e9
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Mar 28 09:59:46 2011 -0400
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Mon Mar 28 09:59:46 2011 -0400
resolved conflicts
diff --cc compiler.scm
index efae5b99,34031b56..4d958fa6
--- a/compiler.scm
+++ b/compiler.scm
@@@ -1472,20 -1463,31 +1463,47 @@@
((type)
(for-each
(lambda (spec)
- (cond ((and (list? spec) (symbol? (car spec)) (= 2 (length spec)))
- (##sys#put! (car spec) '##compiler#type (cadr spec))
- (##sys#put! (car spec) '##compiler#declared-type #t))
- (else
- (warning "illegal `type' declaration item" spec))))
- (globalize-all (cdr spec))))
+ (if (not (and (list? spec)
+ (>= (length spec) 2)
+ (symbol? (car spec))))
+ (warning "illegal type declaration" (##sys#strip-syntax spec))
+ (let ((name (##sys#globalize (car spec) se))
+ (type (##sys#strip-syntax (cadr spec))))
- (cond ((validate-type type name)
- ;; HACK: since `:' doesn't have access to the SE, we
- ;; fixup the procedure name if type is a named procedure type
- ;; (We only have access to the SE for ##sys#globalize in here).
- ;; Quote terrible.
- (when (and (pair? type) (eq? 'procedure (car type)) (symbol? (cadr type)))
- (set-car! (cdr type) name))
- (print "mark: " name " -> " type)
- (mark-variable name '##core#type type)
- (mark-variable name '##core#declared-type)
- (when (pair? (cddr spec))
- (mark-variable
- name '##core#specializations
- (##sys#strip-syntax (cddr spec)))))
- (else
- (warning
- "illegal type declaration"
- (##sys#strip-syntax spec)))))))
++ (cond ((validate-type type name) =>
++ (lambda (type)
++ ;; HACK: since `:' doesn't have access to the SE, we
++ ;; fixup the procedure name if type is a named procedure type
++ ;; (We only have access to the SE for ##sys#globalize in here).
++ ;; Quite terrible.
++ (when (and (pair? type)
++ (eq? 'procedure (car type))
++ (symbol? (cadr type)))
++ (set-car! (cdr type) name))
++ (mark-variable name '##core#type type)
++ (mark-variable name '##core#declared-type)
++ (when (pair? (cddr spec))
++ (mark-variable
++ name '##compiler#specializations
++ (##sys#strip-syntax (cddr spec)))))
++ (else
++ (warning
++ "illegal `type' declaration"
++ (##sys#strip-syntax spec))))))))
++ (cdr spec)))
+ ((predicate)
+ (for-each
+ (lambda (spec)
+ (cond ((and (list? spec) (symbol? (car spec)) (= 2 (length spec)))
- (##sys#put! (car spec) '##compiler#predicate (cadr spec)))
++ (let ((name (##sys#globalize (car spec) se))
++ (type (##sys#strip-syntax (cadr spec))))
++ (cond ((validate-type type name) =>
++ (lambda (type)
++ (##sys#put! name '##compiler#predicate type)))
++ (else
++ (warning "illegal `predicate' declaration" spec)))))
+ (else
- (warning "illegal `predicate' declaration item" spec))))
- (globalize-all (cdr spec))))
++ (warning "illegal `predicate' declaration" spec))))
+ (cdr spec)))
((unsafe-specialized-arithmetic)
(set! unchecked-specialized-arithmetic #t))
(else (warning "illegal declaration specifier" spec)) )
diff --cc csc.scm
index f414a02f,b4dda098..16643dd2
--- a/csc.scm
+++ b/csc.scm
@@@ -138,8 -138,7 +138,9 @@@
-no-symbol-escape -no-parentheses-synonyms -r5rs-syntax
-no-argc-checks -no-bound-checks -no-procedure-checks -no-compiler-syntax
-emit-all-import-libraries -setup-mode -unboxing -no-elevation -no-module-registration
- -no-procedure-checks-for-usual-bindings -module -specialize
+ -no-procedure-checks-for-usual-bindings -module
++ -specialize
+ -lambda-lift ; OBSOLETE
-no-procedure-checks-for-toplevel-bindings))
(define-constant complex-options
diff --cc scrutinizer.scm
index df018c19,e70cd013..70015bac
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@@ -54,65 -56,73 +56,126 @@@
; pointer-vector
; RESULTS = *
; | (VAL1 ...)
-
+;
; global symbol properties:
;
- ; ##compiler#type -> <typespec>
- ; ##compiler#declared-type -> <bool>
- ; ##compiler#predicate -> <typespec>
-; ##core#type -> TYPESPEC
-; ##core#declared-type -> BOOL
-; ##core#specializations -> (SPECIALIZATION ...)
++; ##compiler#type -> TYPESPEC
++; ##compiler#declared-type -> BOOL
++; ##compiler#predicate -> TYPESPEC
++; ##compiler#specializations -> (SPECIALIZATION ...)
+ ;
+ ; specialization specifiers:
+ ;
+ ; SPECIALIZATION = ((MVAL ... [#!rest MVAL]) TEMPLATE)
+ ; MVAL = VAL | (not VAL) | (or VAL ...) | (and VAL ...)
+ ; TEMPLATE = #(INDEX [...])
+ ; | INTEGER | SYMBOL | STRING
+ ; | (quote CONSTANT)
+ ; | (TEMPLATE . TEMPLATE)
+ ;
+ ; - (not number) succeeds for fixnum and flonum
+ ; - (not list) succeeds for pair and null
+
(define-constant +fragment-max-length+ 5)
(define-constant +fragment-max-depth+ 3)
++
+(define (scrutinize node db)
+ (let ((blist '()))
+ (define (constant-result lit)
+ (cond ((string? lit) 'string)
+ ((symbol? lit) 'symbol)
+ ((fixnum? lit) 'fixnum)
+ ((flonum? lit) 'float)
+ ((number? lit) 'number) ; in case...
+ ((boolean? lit) 'boolean)
+ ((list? lit) 'list)
+ ((pair? lit) 'pair)
+ ((eof-object? lit) 'eof)
+ ((vector? lit) 'vector)
+ ((and (not (##sys#immediate? lit)) ##sys#generic-structure? lit)
+ `(struct ,(##sys#slot lit 0)))
+ ((null? lit) 'null)
+ ((char? lit) 'char)
+ (else '*)))
+ (define (global-result id loc)
+ (cond ((##sys#get id '##compiler#type) =>
+ (lambda (a)
+ (cond
+ #;((and (get db id 'assigned) ; remove assigned global from type db
+ (not (##sys#get id '##core#declared-type)))
+ (##sys#put! id '##compiler#type #f)
+ '*)
+ ((eq? a 'deprecated)
+ (report
+ loc
+ (sprintf "use of deprecated library procedure `~a'" id) )
+ '(*))
+ ((and (pair? a) (eq? (car a) 'deprecated))
+ (report
+ loc
+ (sprintf
+ "use of deprecated library procedure `~a' - consider using `~a' instead"
+ id (cadr a)))
+ '(*))
+ (else (list a)))))
+ (else '(*))))
+ (define (variable-result id e loc flow)
+ (cond ((find (lambda (b)
+ (and (eq? id (caar b))
+ (memq (cdar b) flow)) )
+ blist)
+ => (o list cdr))
+ ((and (get db id 'assigned)
+ (not (##sys#get id '##core#declared-type)) )
+ '(*))
++=======
+ (define specialization-statistics '())
+
+ (define (scrutinize node db complain specialize)
+ (define (constant-result lit)
+ (cond ((string? lit) 'string)
+ ((symbol? lit) 'symbol)
+ ((fixnum? lit) 'fixnum)
+ ((flonum? lit) 'float)
+ ((number? lit)
+ (case number-type
+ ((fixnum) 'fixnum)
+ ((flonum) 'flonum)
+ (else 'number))) ; in case...
+ ((boolean? lit) 'boolean)
+ ((null? lit) 'null)
+ ((pair? lit) 'pair)
+ ((list? lit) 'list)
+ ((eof-object? lit) 'eof)
+ ((vector? lit) 'vector)
+ ((and (not (##sys#immediate? lit)) ##sys#generic-structure? lit)
+ `(struct ,(##sys#slot lit 0)))
+ ((char? lit) 'char)
+ (else '*)))
+ (define (global-result id loc)
+ (cond ((##sys#get id '##core#type) =>
+ (lambda (a)
+ (cond ((eq? a 'deprecated)
+ (report
+ loc
+ (sprintf "use of deprecated library procedure `~a'" id) )
+ '*)
+ ((and (pair? a) (eq? (car a) 'deprecated))
+ (report
+ loc
+ (sprintf
+ "use of deprecated library procedure `~a' - consider using `~a' instead"
+ id (cadr a)))
+ '*)
+ (else (list a)))))
+ (else '*)))
+ (define (variable-result id e loc)
+ (cond ((and (get db id 'assigned)
+ (not (##sys#get id '##core#declared-type)))
+ '*)
++>>>>>>> specialization
((assq id e) =>
(lambda (a)
(cond ((eq? 'undefined (cdr a))
@@@ -399,11 -409,12 +462,12 @@@
(report
loc
(sprintf "expected ~a a single result, but were given ~a result~a"
- what n (multiples n)))
+ what n (multiples n)))
(first tv))))))
(define (report loc desc)
- (warning
- (conc (location-name loc) desc)))
+ (when complain
+ (warning
+ (conc (location-name loc) desc))))
(define (location-name loc)
(define (lname loc1)
(if loc1
@@@ -431,17 -442,17 +495,17 @@@
(with-output-to-string
(lambda ()
(pp (fragment x))))))
- (define (call-result args e loc x params)
+ (define (call-result node args e loc params)
(define (pname)
(sprintf "~ain procedure call to `~s', "
- (if (and (pair? params) (pair? (cdr params)))
- (let ((n (source-info->line (cadr params))))
- (if n
- (sprintf "~a: " n)
- ""))
- "")
- (fragment x)))
- (d "call-result: ~a" args)
+ (if (and (pair? params) (pair? (cdr params)))
+ (let ((n (source-info->line (cadr params))))
+ (if n
+ (sprintf "~a: " n)
+ ""))
+ "")
+ (fragment (first (node-subexpressions node)))))
- (d "call-result: ~a (~a)" args loc)
++ (d "call-result: ~a " args)
(let* ((ptype (car args))
(nargs (length (cdr args)))
(xptype `(procedure ,(make-list nargs '*) *)))
@@@ -471,10 -483,25 +536,25 @@@
(report
loc
(sprintf
- "~aexpected argument #~a of type `~a', but where given an argument of type `~a'"
- (pname) i (car atypes) (car args)))))
+ "~aexpected argument #~a of type `~a', but was given an argument of type `~a'"
+ (pname) i (car atypes) (car args)))))
(let ((r (procedure-result-types ptype values-rest (cdr args))))
(d " result-types: ~a" r)
+ (when specialize
+ ;;XXX we should check whether this is a standard- or extended bindng
+ (and-let* ((pn (procedure-name ptype))
- (specs (##sys#get pn '##core#specializations)))
++ (specs (##sys#get pn '##compiler#specializations)))
+ (for-each
+ (lambda (spec)
+ (when (match-specialization (car spec) (cdr args))
+ (let ((op (cons pn (car spec))))
+ (cond ((assoc op specialization-statistics) =>
+ (lambda (a) (set-cdr! a (add1 (cdr a)))))
+ (else
+ (set! specialization-statistics
+ (cons (cons op 1) specialization-statistics)))))
+ (specialize-node! node (cadr spec))))
+ specs)))
r))))
(define (procedure-type? t)
(or (eq? 'procedure t)
@@@ -683,7 -669,14 +765,14 @@@
'*))))
(d " -> ~a" results)
results)))
- (walk (first (node-subexpressions node)) '() '() #f #f (list (tag)) #f)))
- (let ((rn (walk (first (node-subexpressions node)) '() '() #f #f)))
++ (let ((rn (walk (first (node-subexpressions node)) '() '() #f #f (list (tag)) #f)))
+ (when (and (pair? specialization-statistics)
+ (debugging 'x "specializations:"))
+ (for-each
+ (lambda (ss)
+ (printf " ~a ~s~%" (cdr ss) (car ss)))
+ specialization-statistics))
+ rn))
(define (load-type-database name #!optional (path (repository-path)))
(and-let* ((dbfile (file-exists? (make-pathname path name))))
@@@ -691,16 -684,129 +780,132 @@@
(printf "loading type database ~a ...~%" dbfile))
(for-each
(lambda (e)
- (let* ((name (car e))
- (old (##sys#get name '##core#type))
- (new (cadr e))
- (specs (and (pair? (cddr e)) (cddr e))))
- (when (and old (not (equal? old new)))
- (##sys#notice
- (sprintf
- "type-definition `~a' for toplevel binding `~a' conflicts with previously loaded type `~a'"
- name new old)))
- (##sys#put! name '##core#type new)
- (when specs
- (##sys#put! name '##core#specializations specs))))
+ (cond ((eq? 'predicate (car e))
+ (##sys#put! (cadr e) '##compiler#predicate (caddr e)))
+ (else
+ (let* ((name (car e))
+ (old (##sys#get name '##compiler#type))
- (new (cadr e)))
++ (new (cadr e))
++ (specs (and (pair? (cddr e)) (cddr e))))
+ (when (and old (not (equal? old new)))
+ (##sys#notice
+ (sprintf
+ "type-definition `~a' for toplevel binding `~a' conflicts with previously loaded type `~a'"
+ name new old)))
- (##sys#put! name '##compiler#type new)))))
++ (##sys#put! name '##compiler#type new)
++ (when specs
++ (##sys#put! name '##compiler#specializations specs))))))
(read-file dbfile))))
+
+ (define (match-specialization typelist atypes)
+ (define (match st t)
+ (cond ((pair? st)
+ (case (car st)
+ ((not)
+ (cond ((and (pair? t) (eq? 'or (car t)))
+ (not (any (cute match (cadr st) <>) (cdr t))))
+ ((eq? '* t) #f)
+ (else (not (match (cadr st) t)))))
+ ((or) (any (cut match <> t) (cdr st)))
+ ((and) (every (cut match <> t) (cdr st)))
+ (else (equal? st t))))
+ ((eq? st '*))
+ ((eq? st 'procedure)
+ (or (eq? t 'procedure)
+ (and (pair? t) (eq? 'procedure (car t)))))
+ ;;XXX match number with fixnum and float?
+ (else (eq? st t))))
+ (let loop ((tl typelist) (atypes atypes))
+ (cond ((null? tl) (null? atypes))
+ ((null? atypes) #f)
+ ((eq? (car tl) '#!rest)
+ (every (cute match (cadr tl) <>) atypes))
+ ((match (car tl) (car atypes)) (loop (cdr tl) (cdr atypes)))
+ (else #f))))
+
+ (define (specialize-node! node template)
+ (let ((args (cdr (node-subexpressions node))))
+ (define (subst x)
+ (cond ((and (vector? x)
+ (= 1 (vector-length x))
+ (integer? (vector-ref x 0)))
+ (list-ref args (sub1 (vector-ref x 0))))
+ ((and (vector? x)
+ (= 2 (vector-length x))
+ (integer? (vector-ref x 0))
+ (eq? '... (vector-ref x 1)))
+ (list-tail args (sub1 (vector-ref x 0))))
+ ((not (pair? x)) x)
+ ((eq? 'quote (car x)) x) ; to handle numeric constants
+ (else (cons (subst (car x)) (subst (cdr x))))))
+ (let ((spec (subst template)))
+ (copy-node! (build-node-graph spec) node))))
+
+ (define (validate-type type name)
+ ;; - returns converted type or #f
+ ;; - also converts "(... -> ...)" types
+ ;; - drops "#!key ..." args by converting to #!rest
+ (define (upto lst p)
+ (let loop ((lst lst))
+ (cond ((eq? lst p) '())
+ (else (cons (car lst) (loop (cdr lst)))))))
+ (define (validate-llist llist)
+ (cond ((null? llist) '())
+ ((symbol? llist) '(#!rest *))
+ ((not (pair? llist)) #f)
+ ((eq? '#!optional (car llist))
+ (cons '#!optional (validate-llist (cdr llist))))
+ ((eq? '#!rest (car llist))
+ (cond ((null? (cdr llist)) '(#!rest *))
+ ((not (pair? (cdr llist))) #f)
+ ((and (pair? (cddr llist))
+ (eq? '#!key (caddr llist)))
+ `(#!rest ,(validate (cadr llist))))
+ (else #f)))
+ ((eq? '#!key (car llist)) '(#!rest *))
+ (else (cons (validate (car llist)) (validate-llist (cdr llist))))))
+ (define (validate t)
+ (cond ((memq t '(* string symbol char number boolean list pair
+ procedure vector null eof undefined port blob
+ pointer locative fixnum float pointer-vector
+ deprecated))
+ t)
+ ((not (pair? t)) t)
+ ((eq? 'or (car t))
+ (and (list? t)
+ (let ((ts (map validate (cdr t))))
+ (and (every identity ts)
+ `(or ,@ts)))))
+ ((eq? 'struct (car t))
+ (and (= 2 (length t))
+ (symbol? (cadr t))
+ t))
+ ((eq? 'procedure (car t))
+ (and (pair? (cdr t))
+ (let* ((name (if (symbol? (cadr t))
+ (cadr t)
+ name))
+ (t2 (if (symbol? (cadr t)) (cddr t) (cdr t))))
+ (and (pair? t2)
+ (list? (car t2))
+ (let ((ts (validate-llist (car t2))))
+ (and ts
+ (every identity ts)
+ (let* ((rt2 (cdr t2))
+ (rt (if (eq? '* rt2)
+ rt2
+ (and (list? rt2)
+ (let ((rts (map validate rt2)))
+ (and (every identity rts)
+ rts))))))
+ (and rt
+ `(procedure
+ ,@(if name (list name) '())
+ ,ts
+ ,@rt)))))))))
+ ((and (pair? (cdr t)) (memq '-> (cdr t))) =>
+ (lambda (p)
+ (validate
+ `(procedure ,(upto t p) ,@(cdr p)))))
+ (else #f)))
+ (validate type))
diff --cc support.scm
index d2fde7af,a56dd850..61d10df9
--- a/support.scm
+++ b/support.scm
@@@ -731,6 -736,24 +736,24 @@@
(loop)))))))
+ ;;; write declared types to file
+
+ (define (emit-type-file filename db)
+ (with-output-to-file filename
+ (lambda ()
+ (print "; GENERATED BY CHICKEN " (chicken-version) " FROM "
+ source-filename "\n")
+ (##sys#hash-table-for-each
+ (lambda (sym plist)
+ (when (variable-visible? sym)
+ (when (variable-mark sym '##core#declared-type)
+ (let ((specs
- (or (variable-mark sym '##core#specializations) '())))
++ (or (variable-mark sym '##compiler#specializations) '())))
+ (pp (cons* sym (variable-mark sym '##core#type) specs))))))
+ db)
+ (print "; END OF FILE"))))
+
+
;;; Match node-structure with pattern:
(define (match-node node pat vars)
Trap