suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

logging

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2008-07-14 08:48:14 -04:00
parent e92c35d90c
commit 2866efd348
8 changed files with 72 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
collects/typed-scheme/private/base-env.ss
View File

@ -337,15 +337,15 @@
[imag-part (N . -> . N)]
[magnitude (N . -> . N)]
[angle (N . -> . N)]
[numerator (N . -> . N)]
[denominator (N . -> . N)]
[numerator (N . -> . -Integer)]
[denominator (N . -> . -Integer)]
[exact->inexact (N . -> . N)]
[inexact->exact (N . -> . N)]
[make-string
(cl->
[(N) -String]
[(N -Char) -String])]
[arithmetic-shift (N N . -> . N)]
[arithmetic-shift (-Integer -Integer . -> . -Integer)]
[abs (N . -> . N)]
[substring (cl-> [(-String N) -String]
[(-String N N) -String])]
@ -375,7 +375,7 @@
[current-error-port (-Param -Output-Port -Output-Port)]
[current-input-port (-Param -Input-Port -Input-Port)]
[round (N . -> . N)]
[seconds->date (N . -> . (make-Struct 'date #f (list N N N N N N N N B N) #f #f #'date? values))]
[seconds->date (N . -> . (make-Name #'date))]
[current-seconds (-> N)]
[sqrt (-> N N)]
[path->string (-> -Path -String)]
@ -482,6 +482,7 @@
[delete-file (-> -Pathlike -Void)]
[make-namespace (cl->* (-> -Namespace)
(-> (*Un (-val 'empty) (-val 'initial)) -Namespace))]
[make-base-namespace (-> -Namespace)]
[eval (-> -Sexp Univ)]
[exit (-> (Un))]

2
collects/typed-scheme/private/constraint-structs.ss
View File

@ -16,7 +16,7 @@
(define-struct dcon-exact (fixed rest) #:prefab)
;; type : c
;; bound : vars
;; bound : var
(define-struct dcon-dotted (type bound) #:prefab)
;; map : hash mapping variable to dcon or dcon-dotted

56
collects/typed-scheme/private/tc-app-unit.ss
View File

@ -6,7 +6,7 @@
"tc-utils.ss"
"subtype.ss"
"infer.ss"
(only-in "utils.ss" debug in-syntax)
(only-in "utils.ss" debug in-syntax printf/log in-pairs)
"union.ss"
"type-utils.ss"
"type-effect-convenience.ss"
@ -21,6 +21,7 @@
(for-template
"internal-forms.ss" scheme/base
(only-in scheme/private/class-internal make-object do-make-object)))
(require "constraint-structs.ss")
(import tc-expr^ tc-lambda^ tc-dots^)
(export tc-app^)
@ -140,6 +141,13 @@
(stringify (map stringify-domain doms rests drests) "~n\t")
(stringify-domain arg-tys (if (not tail-bound) tail-ty #f) (if tail-bound (cons tail-ty tail-bound) #f)))]))
(define (do-apply-log subst fun arg)
(match* (fun arg)
[('star 'list) (printf/log "Polymorphic apply called with uniform rest arg, list argument\n")]
[('star 'dots) (printf/log "Polymorphic apply called with uniform rest arg, dotted argument\n")]
[('dots 'dots) (printf/log "Polymorphic apply called with non-uniform rest arg, dotted argument\n")])
(log-result subst))
(define (tc/apply f args)
(define f-ty (tc-expr f))
;; produces the first n-1 elements of the list, and the last element
@ -172,6 +180,7 @@
(and tail-ty
(subtype (apply -lst* arg-tys #:tail (make-Listof tail-ty))
(apply -lst* (car doms*) #:tail (make-Listof (car rests*)))))))
(printf/log "Non-poly apply, ... arg\n")
(ret (car rngs*))]
[(and (car rests*)
(let ([tail-ty (with-handlers ([exn:fail? (lambda _ #f)])
@ -179,7 +188,11 @@
(and tail-ty
(subtype (apply -lst* arg-tys #:tail tail-ty)
(apply -lst* (car doms*) #:tail (make-Listof (car rests*)))))))
(ret (car rngs*))]
(printf/log (if (memq (syntax->datum f) '(+ - * / max min))
"Simple arithmetic non-poly apply\n"
"Simple non-poly apply\n"))
(ret (car rngs*))]
[(and (car drests*)
(let-values ([(tail-ty tail-bound)
(with-handlers ([exn:fail? (lambda _ (values #f #f))])
@ -188,6 +201,7 @@
(eq? (cdr (car drests*)) tail-bound)
(subtypes arg-tys (car doms*))
(subtype tail-ty (car (car drests*))))))
(printf/log "Non-poly apply, ... arg\n")
(ret (car rngs*))]
[else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))]
[(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests drests thn-effs els-effs) ..1))))
@ -269,7 +283,9 @@
(car rests*)
(car rngs*)
(fv (car rngs*))))
=> (lambda (substitution) (ret (subst-all substitution (car rngs*))))]
=> (lambda (substitution)
(do-apply-log substitution 'star 'list)
(ret (subst-all substitution (car rngs*))))]
;; actual work, when we have a * function and ... final arg
[(and (car rests*)
tail-bound
@ -282,7 +298,9 @@
(car rests*)
(car rngs*)
(fv (car rngs*))))
=> (lambda (substitution) (ret (subst-all substitution (car rngs*))))]
=> (lambda (substitution)
(do-apply-log substitution 'star 'dots)
(ret (subst-all substitution (car rngs*))))]
;; ... function, ... arg, same bound on ...
[(and (car drests*)
tail-bound
@ -290,7 +308,9 @@
(= (length (car doms*))
(length arg-tys))
(infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*))))
=> (lambda (substitution) (ret (subst-all substitution (car rngs*))))]
=> (lambda (substitution)
(do-apply-log substitution 'dots 'dots)
(ret (subst-all substitution (car rngs*))))]
;; ... function, ... arg, different bound on ...
[(and (car drests*)
tail-bound
@ -304,6 +324,7 @@
(infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*)))))
=> (lambda (substitution)
(define drest-bound (cdr (car drests*)))
(do-apply-log substitution 'dots 'dots)
(ret (substitute-dotted (cadr (assq drest-bound substitution))
tail-bound
drest-bound
@ -317,6 +338,23 @@
[(tc-result: f-ty) (tc-error/expr #:return (ret (Un))
"Type of argument to apply is not a function type: ~n~a" f-ty)]))
(define (log-result subst)
(define (dmap-length d)
(match d
[(struct dcon (fixed rest)) (length fixed)]
[(struct dcon-exact (fixed rest)) (length fixed)]))
(if (list? subst)
(for ([s subst])
(match s
[(list v (list imgs ...) starred)
(printf/log "Instantiated ... variable ~a with ~a types\n" v (length imgs))]
[_ (void)]))
(for* ([(cmap dmap) (in-pairs (cset-maps subst))]
[(k v) (dmap-map dmap)])
(printf/log "Instantiated ... variable ~a with ~a types\n" k (dmap-length v)))))
(define-syntax (handle-clauses stx)
(syntax-case stx ()
[(_ (lsts ... rngs) pred infer t argtypes expected)
@ -326,6 +364,7 @@
#:when (pred vars ... rng))
(let ([substitution (infer vars ... rng)])
(and substitution
(log-result substitution)
(or expected
(ret (subst-all substitution rng))))))
(poly-fail t argtypes))))]))
@ -393,7 +432,10 @@
#:return (ret (Un))
(string-append "No function domains matched in function application:"
(domain-mismatches t doms rests drests argtypes #f #f)))]
[(subtypes/varargs argtypes (car doms*) (car rests*)) (ret (car rngs))]
[(subtypes/varargs argtypes (car doms*) (car rests*))
(when (car rests*)
(printf/log "Simple varargs function application (~a)\n" (syntax->datum f-stx)))
(ret (car rngs))]
[else (loop (cdr doms*) (cdr rngs) (cdr rests*))]))]
;; simple polymorphic functions, no rest arguments
[(tc-result: (and t
@ -411,6 +453,7 @@
;; we want to infer the dotted-var here as well, and we don't use these separately
;; so we can just use "vars" instead of (list fixed-vars ... dotted-var)
(PolyDots: vars (Function: (list (arr: doms rngs rests (and drests #f) thn-effs els-effs) ...))))))
(printf/log "Polymorphic varargs function application (~a)\n" (syntax->datum f-stx))
(handle-clauses (doms rests rngs)
(lambda (dom rest rng) (<= (length dom) (length argtypes)))
(lambda (dom rest rng) (infer/vararg vars argtypes dom rest rng (fv rng) expected))
@ -419,6 +462,7 @@
[(tc-result: (and t (PolyDots:
(and vars (list fixed-vars ... dotted-var))
(Function: (list (arr: doms rngs (and #f rests) (cons dtys dbounds) thn-effs els-effs) ...)))))
(printf/log "Polymorphic ... function application (~a)\n" (syntax->datum f-stx))
(handle-clauses (doms dtys dbounds rngs)
(lambda (dom dty dbound rng) (and (<= (length dom) (length argtypes))
(eq? dotted-var dbound)))

6
collects/typed-scheme/private/tc-lambda-unit.ss
View File

@ -69,7 +69,7 @@
;; otherwise, the simple case
[else (make-arr arg-types t rest-ty drest null null)])]
[t (int-err "bad match - not a tc-result: ~a ~a ~a" t ret-ty (syntax->datum body))])))
(for-each (lambda (a) (printf/log "Lambda Var: ~a~n" (syntax-e a))) arg-list)
#;(for-each (lambda (a) (printf/log "Lambda Var: ~a~n" (syntax-e a))) arg-list)
(when (or (not (= arg-len tys-len))
(and rest (and (not rest-ty)
(not drest))))
@ -114,7 +114,7 @@
[(args ...)
(let* ([arg-list (syntax->list #'(args ...))]
[arg-types (map get-type arg-list)])
(for-each (lambda (a) (printf/log "Lambda Var: ~a~n" (syntax-e a))) arg-list)
#;(for-each (lambda (a) (printf/log "Lambda Var: ~a~n" (syntax-e a))) arg-list)
(with-lexical-env/extend
arg-list arg-types
(match (tc-exprs (syntax->list body))
@ -130,7 +130,7 @@
[(args ... . rest)
(let* ([arg-list (syntax->list #'(args ...))]
[arg-types (map get-type arg-list)])
(for-each (lambda (a) (printf/log "Lambda Var: ~a~n" (syntax-e a))) (cons #'rest arg-list))
#;(for-each (lambda (a) (printf/log "Lambda Var: ~a~n" (syntax-e a))) (cons #'rest arg-list))
(cond
[(dotted? #'rest)
=>

8
collects/typed-scheme/private/type-annotation.ss
View File

@ -30,7 +30,7 @@
;; is let-binding really necessary? - remember to record the bugs!
(define (type-annotation stx #:infer [let-binding #f])
(define (pt prop)
(print-size prop)
#;(print-size prop)
(if (syntax? prop)
(parse-type prop)
(parse-type/id stx prop)))
@ -51,7 +51,7 @@
(define (type-ascription stx)
(define (pt prop)
(print-size prop)
#;(print-size prop)
(if (syntax? prop)
(parse-type prop)
(parse-type/id stx prop)))
@ -103,8 +103,8 @@
"Expression should produce ~a values, but produces ~a values of types ~a"
(length stxs) (length tys) (stringify tys))
(map (lambda (stx ty a)
(cond [a => (lambda (ann) (check-type stx ty ann) (log/extra stx ty ann) ann)]
[else (log/noann stx ty) ty]))
(cond [a => (lambda (ann) (check-type stx ty ann) #;(log/extra stx ty ann) ann)]
[else #;(log/noann stx ty) ty]))
stxs tys anns))]
[ty (tc-error/delayed #:ret (map (lambda _ (Un)) stxs)
"Expression should produce ~a values, but produces one values of type "

1
collects/typed-scheme/private/type-contract.ss
View File

@ -124,5 +124,6 @@
#`syntax?
#`(syntax/c #,(t->c t)))]
[(Value: v) #`(flat-named-contract #,(format "~a" v) (lambda (x) (equal? x '#,v)))]
[(Param: in out) #`(parameter/c #,(t->c out))]
[else
(exit (fail))]))))

10
collects/typed-scheme/private/utils.ss
View File

@ -67,7 +67,7 @@
(define-syntax n (syntax-rules () [(n . pattern) template]))]))
(define log-file (make-parameter #f))
(define-for-syntax logging? #f)
(define-for-syntax logging? #t)
(require (only-in (lib "file.ss") file-name-from-path))
@ -76,9 +76,9 @@
(syntax-case stx ()
[(_ fmt . args)
#'(when (log-file)
(apply fprintf (log-file) (string-append "~a: " fmt)
(file-name-from-path (object-name (log-file)))
args))])
(fprintf (log-file) (string-append "~a: " fmt)
(file-name-from-path (object-name (log-file)))
. args))])
#'(void)))
(define (log-file-name src module-name)
@ -90,7 +90,7 @@
(syntax-case stx ()
[(_ file . body)
(if logging?
#'(parameterize ([log-file (open-output-file file 'truncate/replace)])
#'(parameterize ([log-file (open-output-file file #:exists 'append)])
. body)
#'(begin . body))]))

4
collects/typed-scheme/typed-scheme.ss
View File

@ -40,7 +40,9 @@
(define module-name (syntax-property stx 'enclosing-module-name))
;(printf "BEGIN: ~a~n" (syntax->datum stx))
(with-logging-to-file
(log-file-name (syntax-src stx) module-name)
"/tmp/ts-poly.log"
#;
(log-file-name (syntax-source stx) module-name)
(syntax-case stx ()
[(mb forms ...)
(nest