From 2866efd3485b19c98dd858b1db7e09928f0213c6 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 14 Jul 2008 08:48:14 -0400 Subject: [PATCH] logging --- collects/typed-scheme/private/base-env.ss | 9 +-- .../private/constraint-structs.ss | 2 +- collects/typed-scheme/private/tc-app-unit.ss | 56 +++++++++++++++++-- .../typed-scheme/private/tc-lambda-unit.ss | 6 +- .../typed-scheme/private/type-annotation.ss | 8 +-- .../typed-scheme/private/type-contract.ss | 1 + collects/typed-scheme/private/utils.ss | 10 ++-- collects/typed-scheme/typed-scheme.ss | 4 +- 8 files changed, 72 insertions(+), 24 deletions(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 348d36af3c..6c34b14fd4 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -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))] diff --git a/collects/typed-scheme/private/constraint-structs.ss b/collects/typed-scheme/private/constraint-structs.ss index 700baecf95..def84ae0a6 100644 --- a/collects/typed-scheme/private/constraint-structs.ss +++ b/collects/typed-scheme/private/constraint-structs.ss @@ -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 diff --git a/collects/typed-scheme/private/tc-app-unit.ss b/collects/typed-scheme/private/tc-app-unit.ss index b8ce6bbb9d..3aaaab02ef 100644 --- a/collects/typed-scheme/private/tc-app-unit.ss +++ b/collects/typed-scheme/private/tc-app-unit.ss @@ -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))) diff --git a/collects/typed-scheme/private/tc-lambda-unit.ss b/collects/typed-scheme/private/tc-lambda-unit.ss index 72eaad5a96..519be1e1f2 100644 --- a/collects/typed-scheme/private/tc-lambda-unit.ss +++ b/collects/typed-scheme/private/tc-lambda-unit.ss @@ -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) => diff --git a/collects/typed-scheme/private/type-annotation.ss b/collects/typed-scheme/private/type-annotation.ss index ec2140682c..1a72e73bdd 100644 --- a/collects/typed-scheme/private/type-annotation.ss +++ b/collects/typed-scheme/private/type-annotation.ss @@ -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 " diff --git a/collects/typed-scheme/private/type-contract.ss b/collects/typed-scheme/private/type-contract.ss index fed4514fd4..6d15454d15 100644 --- a/collects/typed-scheme/private/type-contract.ss +++ b/collects/typed-scheme/private/type-contract.ss @@ -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))])))) \ No newline at end of file diff --git a/collects/typed-scheme/private/utils.ss b/collects/typed-scheme/private/utils.ss index 5560f16458..d9b8e41a89 100644 --- a/collects/typed-scheme/private/utils.ss +++ b/collects/typed-scheme/private/utils.ss @@ -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))])) diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index 63fc8ba73a..1a0d5023c5 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -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