partial commit for new framework

cover/cover.rkt

@@ -25,6 +25,7 @@ information is converted to a usable form by `get-test-coverage`.
          racket/runtime-path
          racket/match
          racket/path
+         racket/syntax
          rackunit/log
          unstable/error
          racket/list
@@ -36,13 +37,15 @@ information is converted to a usable form by `get-test-coverage`.
          "strace.rkt")
 
 ;; An environment has:
-;; a `namespace`, which shall always have `coverage.rkt` and ''#%builtin attached
+;; a `namespace`
 ;; a handler for `current-compile`
-;; a function that will annoate expanded code
+;; a function that will annoate expanded code, given a file name
 ;; a topic for logs to be reiceved on. Must be unique for every environment
-;; a log receiver, for receiving log events about coverage
-;; a hash map to store raw coverage read from the receiver
-(struct environment (namespace compile ann-top receiver topic raw-coverage))
+;; a hash map from srcloc to index
+;; a hash map from filename to vector
+(struct environment (namespace compile ann-top topic
+                               coverage-srcloc-mapping
+                               coverage-vector-mapping))
 ;; A special structure used for communicating information about programs that call `exit`
 ;; `code` is the exit code that `exit` was called with
 (struct an-exit (code))
@@ -53,31 +56,50 @@ information is converted to a usable form by `get-test-coverage`.
 ;; returns true if no tests reported as failed, and no files errored.
 (define (test-files! #:submod [submod-name 'test] #:env [env (current-cover-environment)] . files)
   (parameterize ([current-cover-environment env])
-    (with-intercepted-logging/receiver (cover-receiver (get-raw-coverage-map))
-      (lambda ()
-        (define abs
-          (for/list ([p (in-list files)])
-            (if (list? p)
-                (cons (->absolute (car p)) (cdr p))
-                (->absolute p))))
-        (define abs-names
-          (for/list ([p (in-list abs)])
-            (match p
-              [(cons p _) p]
-              [_ p])))
-        (define cover-load/use-compiled (make-cover-load/use-compiled abs-names))
-        (define tests-failed
-          (parameterize* ([current-load/use-compiled cover-load/use-compiled]
-                          [current-namespace (get-namespace)])
+    (define abs
+      (for/list ([p (in-list files)])
+        (if (list? p)
+            (cons (->absolute (car p)) (cdr p))
+            (->absolute p))))
+    (define abs-names
+      (for/list ([p (in-list abs)])
+        (match p
+          [(cons p _) p]
+          [_ p])))
+    (define cover-load/use-compiled (make-cover-load/use-compiled abs-names))
+    (define tests-failed
+      (parameterize* ([current-load/use-compiled cover-load/use-compiled]
+                      [current-namespace (get-namespace)])
+        (with-cover-loggers
             (for ([f (in-list abs-names)])
               (vprintf "forcing compilation of ~a" f)
               (compile-file f))
-            (for/fold ([tests-failed #f]) ([f (in-list abs)])
-              (define failed? (handle-file f submod-name))
-              (or failed? tests-failed))))
-        (vprintf "ran ~s\n" files)
-        (not tests-failed))
-      (get-receiver))))
+          (for/fold ([tests-failed #f]) ([f (in-list abs)])
+            (define failed? (handle-file f submod-name))
+            (or failed? tests-failed)))))
+    (vprintf "ran ~s\n" files)
+    (not tests-failed)))
+
+(define-syntax-rule (with-cover-loggers e ...)
+  (with-intercepted-logging/receiver
+      (cover-give-file-mapping (format-symbol "~a~a" (get-topic) 'cover-internal-send-vector-mapping))
+    (lambda () e ...)
+    (make-log-receiver
+     (current-logger)
+     'info
+     (format-symbol "~a~a" (get-topic) 'cover-internal-request-vector-mapping))))
+
+;; we dont care what the msg content is, just send the vector back
+(define ((cover-give-file-mapping topic) _)
+  #;
+  (printf "vectormap requested from ~a\n" _)
+  (log-message (current-logger)
+               'info
+               topic
+               ""
+               (get-coverage-vector-mapping))
+  #;
+  (printf "vectormap sent to ~a\n" topic))
 
 ;;; ---------------------- Running Aux ---------------------------------
 
@@ -158,28 +180,50 @@ information is converted to a usable form by `get-test-coverage`.
   ;; define so its named in stack traces
   (define cover-compile
     (lambda (e immediate-eval?)
+      (define file (get-source e))
       (define to-compile
         (cond [(or (compiled-expression? (if (syntax? e) (syntax-e e) e))
-                   (not (eq? reg (namespace-module-registry (current-namespace)))))
+                   (not (eq? reg (namespace-module-registry (current-namespace))))
+                   (not file))
               e]
               [else
-               (define fname
-                 (if (not (syntax? e))
-                     e
-                     (or (syntax-source e)
-                         (syntax->datum e))))
                (vprintf "compiling ~s with coverage annotations in enviornment ~s"
-                        fname
+                        file
                         (get-topic))
-               (let ([x (annotate-top (if (syntax? e) (expand-syntax e) (datum->syntax #f e))
-                                      (namespace-base-phase (current-namespace)))])
-                 (vprintf "current map size is: ~a after compiling ~s\n"
-                          (hash-count (get-raw-coverage-map))
-                          fname)
+               (let ([x ((annotate-top file)
+                         (if (syntax? e) (expand-syntax e) (datum->syntax #f e))
+                         (namespace-base-phase (current-namespace)))])
+                 (vprintf "\ncurrently using ~aGB memory after file ~a\n"
+                          (* 0.000000001 (current-memory-use))
+                          file)
                  x)]))
       (compile to-compile immediate-eval?)))
   cover-compile)
 
+(define (get-source stx)
+  (and (syntax? stx)
+       (let loop ([e stx])
+         (define f (syntax-source e))
+         (define (do-loop)
+           (define next (syntax->list e))
+           (and next
+                (ormap loop next)))
+         (if f
+              (if (path? f)
+                  (path->string f)
+                  f)
+              (do-loop)))))
+
+#;
+(thread
+ (lambda ()
+   (let loop ()
+     (fprintf (current-error-port)
+              "\ncurrently using ~aGB memory in random check\n"
+              (* 0.000000001 (current-memory-use)))
+     (sleep 10)
+     (loop))))
+
 ;;; ---------------------- Environments ---------------------------------
 
 (define (clear-coverage!)
@@ -191,17 +235,16 @@ information is converted to a usable form by `get-test-coverage`.
     ;; we gensym the topic to isolate diverent coverage
     ;; instances from each other
     (define topic (gensym))
-    (define ann (make-annotate-top topic))
+    (define loc-table (make-hash))
+    (define vector-table (make-hash))
+    (define ann (make-annotate-top topic loc-table vector-table))
     (environment
      ns
      (make-cover-compile ns ann)
      ann
-     (make-receiver topic)
      topic
-     (make-hash))))
-
-(define (make-receiver topic)
-  (make-log-receiver (current-logger) 'info topic))
+     loc-table
+     vector-table)))
 
 (define (kernelize-namespace! ns)
   (define cns (current-namespace))
@@ -221,31 +264,33 @@ information is converted to a usable form by `get-test-coverage`.
 (define (get-val access)
   (access (current-cover-environment)))
 
-(define (get-receiver)
-  (get-val environment-receiver))
-
-(define (get-raw-coverage-map)
-  (get-val environment-raw-coverage))
-
 (define (get-topic)
   (get-val environment-topic))
 
+(define (get-coverage-srcloc-mapping)
+  (get-val environment-coverage-srcloc-mapping))
+
+(define (get-coverage-vector-mapping)
+  (get-val environment-coverage-vector-mapping))
+
 (struct coverage-wrapper (map function)
         #:property prop:procedure (struct-field-index function))
 
+(require racket/pretty)
 ;; -> coverage/c
 (define (get-test-coverage [env (current-cover-environment)])
   (parameterize ([current-cover-environment env])
     (vprintf "generating test coverage\n")
-    (define raw-coverage (get-raw-coverage-map))
-    (define r (get-receiver))
-    (define receive (cover-receiver raw-coverage))
 
-    (let loop ()
-      (define v (sync/timeout (lambda () #f) r))
-      (when v
-        (receive v)
-        (loop)))
+    (define vecmap (get-coverage-vector-mapping))
+    (define raw-coverage
+      (for/hash ([(srcloc loc) (in-hash (get-coverage-srcloc-mapping))])
+        (values srcloc
+                (vector-ref
+                 (hash-ref vecmap
+                           (first srcloc))
+                 loc))))
+
 
     ;; filtered : (listof (list boolean srcloc))
     (define filtered (hash-map raw-coverage
@@ -272,15 +317,6 @@ information is converted to a usable form by `get-test-coverage`.
                       (make-covered? coverage key))))
        (f location)))))
 
-(define ((cover-receiver raw-coverage) msg)
-  (match msg
-    [(vector info type data _)
-     (cond [(regexp-match? (regexp-quote logger-init-message) type)
-            (unless (hash-has-key? raw-coverage data)
-              (hash-set! raw-coverage data #f))]
-           [(regexp-match? (regexp-quote logger-covered-message) type)
-            (hash-set! raw-coverage data #t)])]))
-
 (define current-cover-environment
   (make-parameter (make-cover-environment)))
 
@@ -292,19 +328,23 @@ information is converted to a usable form by `get-test-coverage`.
     (list
      "tests/compiled/prog_rkt.zo"
      "tests/compiled/prog_rkt.dep"))
+  (define (df)
+    (for-each (lambda (f) (when (file-exists? f) (delete-file f)))
+              compiled))
   (test-begin
-   (parameterize ([current-cover-environment (make-cover-environment)])
-     (for-each (lambda (f) (when (file-exists? f) (delete-file f)))
-               compiled)
-     (check-false (ormap file-exists? compiled))
-     (check-not-exn
-      (lambda ()
-        (define l/c (make-cover-load/use-compiled (list (->absolute prog.rkt))))
-        (parameterize ([current-load/use-compiled l/c]
-                       [current-compile (get-compile)]
-                       [current-namespace (get-namespace)])
-          (managed-compile-zo prog.rkt))))
-     (check-true (andmap file-exists? compiled)))))
+   (after
+    (parameterize ([current-cover-environment (make-cover-environment)])
+      (with-cover-loggers (df)
+        (check-false (ormap file-exists? compiled))
+        (check-not-exn
+         (lambda ()
+           (define l/c (make-cover-load/use-compiled (list (->absolute prog.rkt))))
+           (parameterize ([current-load/use-compiled l/c]
+                          [current-compile (get-compile)]
+                          [current-namespace (get-namespace)])
+             (managed-compile-zo prog.rkt))))
+        (check-true (andmap file-exists? compiled))))
+    (df))))
 
 ;; tests repl like interactions
 (module+ test
@@ -317,21 +357,22 @@ information is converted to a usable form by `get-test-coverage`.
   (define ns (environment-namespace env))
   (parameterize ([current-cover-environment env]
                  [current-namespace ns])
-    (namespace-require 'racket/base)
-    (test-begin
-     (define file (path->string simple-multi/2.rkt))
-     (define modpath file)
-     (define l/c (make-cover-load/use-compiled (list file)))
-     (parameterize ([current-load/use-compiled l/c]
-                    [current-compile (get-compile)])
-       (namespace-require `(file ,modpath)))
-     (check-equal? (eval `(two)) 10)
-     (define x (get-test-coverage env))
-     (define covered? (curry x file))
-     (for ([_ (in-string (file->string file))]
-           [i (in-naturals 1)])
-       (check-not-exn (thunk (covered? i)))
-       (define c (covered? i))
-       (check-true  (or (eq? c 'covered)
-                        (eq? c 'irrelevant))
-                    (~a i))))))
+    (with-cover-loggers
+        (namespace-require 'racket/base)
+      (test-begin
+       (define file (path->string simple-multi/2.rkt))
+       (define modpath file)
+       (define l/c (make-cover-load/use-compiled (list file)))
+       (parameterize ([current-load/use-compiled l/c]
+                      [current-compile (get-compile)])
+         (namespace-require `(file ,modpath)))
+       (check-equal? (eval `(two)) 10)
+       (define x (get-test-coverage env))
+       (define covered? (curry x file))
+       (for ([_ (in-string (file->string file))]
+             [i (in-naturals 1)])
+         (check-not-exn (thunk (covered? i)))
+         (define c (covered? i))
+         (check-true  (or (eq? c 'covered)
+                          (eq? c 'irrelevant))
+                      (~a i)))))))

cover/strace.rkt

@@ -11,48 +11,17 @@
          "private/file-utils.rkt"
          "private/shared.rkt")
 
-(define (make-annotate-top topic)
+;; symbol [Hash srcloclist index] [Hash pathstring vector]
+;; -> (pathstring -> annotator)
+(define (make-annotate-top topic loc->vecref vecmapping)
   (define log-message-name #'log-message)
   (define current-logger-name #'current-logger)
-
-  ;;  -------- Specific `stacktrace^` Imports --------------
-
-  (define (initialize-test-coverage-point stx)
-    (define srcloc (stx->srcloc stx))
-    (log-message (current-logger)
-                 'info
-                 topic
-                 logger-init-message
-                 srcloc #f))
-
-  (define (test-covered stx)
-    (define loc/stx (stx->srcloc/stx stx))
-    (with-syntax ([current-logger current-logger-name]
-                  [log-message log-message-name]
-                  [loc loc/stx]
-                  [logger-covered-message logger-covered-message])
-      #`(#%plain-app log-message (current-logger)
-                     'info '#,topic
-                     logger-covered-message loc #f)))
-
-
-  ;;  -------- Cover's Specific Annotators --------------
-  (define (make-cover-annotate-top annotate-top)
-    (lambda (stx phase)
-      (define e
-        (cond [(cross-phase-persist? stx)
-               (initialize-test-coverage-point stx)
-               (log-message (current-logger)
-                            'info
-                            topic
-                            logger-covered-message
-                            (stx->srcloc stx)
-                            #f)
-               stx]
-              [(add-cover-require (annotate-clean (annotate-top stx phase)))
-               => expand-syntax]
-              [else stx]))
-      e))
+  (define unsafe-vector-set!-name #'unsafe-vector*-set!)
+  (define unsafe-vector-ref-name #'unsafe-vector*-ref)
+  (define vector-name #'cover-coverage-vector)
+  (define make-log-receiver-name #'make-log-receiver)
+  (define sync-name #'sync)
+  (define hash-ref-name #'hash-ref)
 
   (define (cross-phase-persist? stx)
     (define disarmed (disarm stx))
@@ -63,7 +32,7 @@
       #t]
      [_ #f]))
 
-  (define (add-cover-require expr)
+  (define (add-cover-require expr file)
     (let loop ([expr expr] [top #t])
       (define disarmed (disarm expr))
       (kernel-syntax-case
@@ -72,7 +41,16 @@
         (or (eq? 'module (syntax-e #'m))
             (eq? 'module* (syntax-e #'m)))
         (with-syntax ([log-message log-message-name]
-                      [current-logger current-logger-name])
+                      [current-logger current-logger-name]
+                      [unsafe-vector-set! unsafe-vector-set!-name]
+                      [unsafe-vector-ref unsafe-vector-ref-name]
+                      [vector-name vector-name]
+                      [make-log-receiver make-log-receiver-name]
+                      [sync sync-name]
+                      [file file]
+                      [hash-ref hash-ref-name]
+                      [send-name (format-symbol "~a~a" topic 'cover-internal-send-vector-mapping)]
+                      [req-name (format-symbol "~a~a" topic 'cover-internal-request-vector-mapping)])
           (define lexical? (eq? #f (syntax-e #'lang)))
           (syntax-case (syntax-disarm #'mb inspector) ()
             [(#%module-begin b ...)
@@ -82,7 +60,34 @@
                       (syntax->list #'(b ...))))
                (define/with-syntax (add ...)
                  #'((#%require (rename '#%kernel log-message log-message)
-                               (rename '#%kernel current-logger current-logger))))
+                               (rename '#%kernel current-logger current-logger)
+                               (rename '#%kernel make-log-receiver make-log-receiver)
+                               (rename '#%kernel sync sync)
+                               (rename '#%kernel hash-ref hash-ref)
+                               (only '#%kernel #%app define-values printf)
+                               (rename '#%unsafe unsafe-vector-ref unsafe-vector-ref)
+                               (rename '#%unsafe unsafe-vector-set! unsafe-vector-set!))
+                    (define-values (lgr) (#%app current-logger))
+                    (define-values (rec)
+                      (#%app make-log-receiver
+                             lgr
+                             'info
+                             'send-name))
+                    (define-values (vector-name)
+                      (begin
+                        (#%app log-message
+                               lgr
+                               'info
+                               'req-name
+                               ""
+                               #f)
+                        (#%app
+                         hash-ref
+                         (#%app
+                          unsafe-vector-ref
+                          (#%app sync rec)
+                          2)
+                         file)))))
                (define stx
                  #'(m name lang
                       (#%module-begin add ... body ...)))
@@ -100,6 +105,32 @@
                      (#%variable-reference)))
   (define (disarm stx)
     (syntax-disarm stx inspector))
+
+
+  (lambda (file)
+    (define initialized? (hash-has-key? loc->vecref file))
+    (define count 0)
+
+    (define (make-cover-annotate-top annotate-top)
+    (lambda (stx phase)
+      (define e
+        (cond [(cross-phase-persist? stx)
+               ;; special case: cross-phase-pesistant files
+               ;; are not coverable, but immutable so basically always covered
+               (initialize-test-coverage-point stx)
+               (do-final-init! #t)
+               stx]
+              [else
+               (define top (annotate-top stx phase))
+               (do-final-init!)
+               (define r (add-cover-require (annotate-clean top) file))
+               (or r stx)]))
+      e))
+
+    (define (do-final-init! [value #f])
+      (unless initialized?
+        (hash-set! vecmapping file (make-vector count value))))
+
   ;; in order to write modules to disk the top level needs to
   ;; be a module. so we trust that the module is loaded and trim the expression
   (define (annotate-clean e)
@@ -107,18 +138,34 @@
      e #f
      [(begin e mod)
       (begin
-        (syntax-case #'e (#%plain-app log-message)
-          [(#%plain-app log-message _ _ _ "covered" (_ loc) #f)
-           (log-message (current-logger) 'info topic "covered" (syntax->datum #'loc))])
+        (syntax-case #'e (#%plain-app)
+          [(#%plain-app vector-set vec loc #t)
+           (vector-set! (hash-ref vecmapping file) (syntax-e #'loc) #t)])
         #'mod)]
      [_ e]))
 
+    (define initialize-test-coverage-point
+      (if initialized?
+          void
+          (lambda (stx)
+            (define loc (stx->srcloc stx))
+            (unless (hash-has-key? loc->vecref loc)
+              (hash-set! loc->vecref loc count)
+              (set! count (add1 count))))))
 
-  ;; ---- IN ----
-  (define-values/invoke-unit/infer stacktrace@)
-  (make-cover-annotate-top annotate-top))
+    (define (test-covered stx)
+      (define loc (stx->srcloc stx))
+      (with-syntax ([vector-name vector-name]
+                    [unsafe-vector-set! unsafe-vector-set!-name]
+                    [vecloc (hash-ref loc->vecref loc)])
+        #`(#%plain-app unsafe-vector-set! vector-name vecloc #t)))
+
+    ;; ---- IN ----
+    (define-values/invoke-unit/infer stacktrace@)
+    (make-cover-annotate-top annotate-top)))
 
 
+(require racket/pretty)
 
 
 

cover/tests/do-arg.rkt

@@ -1,4 +1,4 @@
 #lang racket
-(require "../cover.rkt" racket/runtime-path rackunit)
+(require cover racket/runtime-path rackunit)
 (define-runtime-path arg.rkt "arg.rkt")
 (check-true (test-files! (list (path->string arg.rkt) #("a"))))

cover/tests/new-logger.rkt

@@ -0,0 +1,12 @@
+#lang racket
+(require rackunit cover racket/runtime-path)
+(define-runtime-path prog "prog.rkt")
+(test-case
+ "A new non-parented logger should not cause a hang"
+ (define t
+   (thread
+    (lambda ()
+      (parameterize ([current-logger (make-logger)])
+        (test-files! prog)))))
+ (define r (sync/timeout 5 t))
+ (check-not-false (and r (thread-dead? r))))

cover/tests/test-cross-phase-persist.rkt

@@ -5,7 +5,10 @@
  "covering cross-phase-persistent files should enter them into the coverage table"
  (parameterize ([current-cover-environment (make-cover-environment)])
    (test-files! file)
-   (define c (get-test-coverage))
+   (define c #f)
+   (check-not-exn
+    (lambda ()
+      (set! c (get-test-coverage))))
    (check-not-exn
     (lambda ()
       (c (->absolute file) 1)))