racket / typed-racket

Typed Racket
Other
527 stars 104 forks source link

Contracts that TR generates for `Parameter` may cause some programs to be very slow. #1241

Open NoahStoryM opened 2 years ago

NoahStoryM commented 2 years ago

I found this problem while testing typed/sicp-pict (https://github.com/sicp-lang/sicp/pull/38).

In sicp-pict/main.rkt, I have added contracts to current-bm and current-dc:

(provide (contract-out [current-bm (parameter/c (or/c #f (is-a?/c bitmap%)))]
                       [current-dc (parameter/c (or/c #f (is-a?/c bitmap-dc%)))]))

What version of Racket are you using?

v8.5 [cs]

What program did you run?

I have no idea how to simplify this test case, so I'll just post the code:

#lang typed/racket

(require typed/racket/draw typed/sicp-pict)

(define unit-frame (frame (vect 0. 0.) (vect 1. 0.) (vect 0. 1.)))

(: apply-painter (-> Painter Frame [#:width Positive-Integer] [#:height Positive-Integer] (Instance Bitmap%)))
(define (apply-painter painter frame #:width [width 200] #:height [height 200])
  (define-values (bm dc) (make-painter-bitmap width height))
  (begin0 bm
    (parameterize ([current-bm bm]
                   [current-dc dc])
      (send dc scale 0.99 0.99) ; make the entire unit square visible
      (painter frame))))

(: make-painter-bitmap (-> Positive-Integer Positive-Integer (Values (Instance Bitmap%) (Instance Bitmap-DC%))))
(define (make-painter-bitmap width height)
  (define bm (make-bitmap width height))
  (define dc (new bitmap-dc% [bitmap bm]))
  (send dc set-pen black-pen)
  (send dc set-brush black-brush)
  ; (send dc set-smoothing 'smoothed)
  (define w (* 1. width))
  (define h (* 1. height))
  ; Map unit square to screen coordinates - also flip y-axis
  ; Initial Matrix (Logical to Device coordinates)
  (send dc set-initial-matrix
        ;            xx xy yx  yy       x0 y0
        (ann (vector w  0. 0. (* -1. h) 0. h)
             (Mutable-Vector Real Real Real Real Real Real)))
  (values bm dc))

(: grid (-> Real Real (Listof (List (List Real Real) (List Real Real))) Painter))
(define (grid w h segs)
  (: make (-> Real Real Vect))
  (define (make x y) (vect (/ x (* 1.0 w)) (/ y (* 1.0 h))))
  (: ->segment (-> (List (List Real Real) (List Real Real)) Segment))
  (define (->segment l)
    (match l [(list    (list x1 y1) (list x2 y2))
              (segment (make x1 y1) (make x2 y2))]))
  (segments->painter (map ->segment segs)))

(define P (grid 16 16
                 '[(( 4  4) ( 6  0)) (( 0  3) ( 3  4)) (( 3  4) ( 0  8))
                   (( 0  8) ( 0  3)) (( 4  5) ( 7  6)) (( 7  6) ( 4 10))
                   (( 4 10) ( 4  5)) ((11  0) (10  4)) ((10  4) ( 8  8))
                   (( 8  8) ( 4 13)) (( 4 13) ( 0 16)) ((11  0) (14  2))
                   ((14  2) (16  2)) ((10  4) (13  5)) ((13  5) (16  4))
                   (( 9  6) (12  7)) ((12  7) (16  6)) (( 8  8) (12  9))
                   ((12  9) (16  8)) (( 8 12) (16 10)) (( 0 16) ( 6 15))
                   (( 6 15) ( 8 16)) (( 8 16) (12 12)) ((12 12) (16 12))
                   ((10 16) (12 14)) ((12 14) (16 13)) ((12 16) (13 15))
                   ((13 15) (16 14)) ((14 16) (16 15)) ((16  0) (16  8))
                   ((16 12) (16 16))]))

(define Q (grid 16 16
                 '[(( 2  0) ( 4  5)) (( 4  5) ( 4  7)) (( 4  0) ( 6  5))
                   (( 6  5) ( 6  7)) (( 6  0) ( 8  5)) (( 8  5) ( 8  8))
                   (( 8  0) (10  6)) ((10  6) (10  9)) ((10  0) (14 11))
                   ((12  0) (13  4)) ((13  4) (16  8)) ((16  8) (15 10))
                   ((15 10) (16 16)) ((16 16) (12 10)) ((12 10) ( 6  7))
                   (( 6  7) ( 4  7)) (( 4  7) ( 0  8)) ((13  0) (16  6))
                   ((14  0) (16  4)) ((15  0) (16  2)) (( 0 10) ( 7 11))
                   (( 9 12) (10 10)) ((10 10) (12 12)) ((12 12) ( 9 12))
                   (( 8 15) ( 9 13)) (( 9 13) (11 15)) ((11 15) ( 8 15))
                   (( 0 12) ( 3 13)) (( 3 13) ( 7 15)) (( 7 15) ( 8 16))
                   (( 2 16) ( 3 13)) (( 4 16) ( 5 14)) (( 6 16) ( 7 15))
                   (( 0  0) ( 8  0)) ((12  0) (16  0))]))

(define R (grid 16 16
                 '[(( 0 12) ( 1 14)) (( 0  8) ( 2 12)) (( 0  4) ( 5 10))
                   (( 0  0) ( 8  8)) (( 1  1) ( 4  0)) (( 2  2) ( 8  0))
                   (( 3  3) ( 8  2)) (( 8  2) (12  0)) (( 5  5) (12  3))
                   ((12  3) (16  0)) (( 0 16) ( 2 12)) (( 2 12) ( 8  8))
                   (( 8  8) (14  6)) ((14  6) (16  4)) (( 6 16) (11 10))
                   ((11 10) (16  6)) ((11 16) (12 12)) ((12 12) (16  8))
                   ((12 12) (16 16)) ((13 13) (16 10)) ((14 14) (16 12))
                   ((15 15) (16 14))]))

(define S (grid 16 16
                 '[(( 0  0) ( 4  2)) (( 4  2) ( 8  2)) (( 8  2) (16  0))
                   (( 0  4) ( 2  1)) (( 0  6) ( 7  4)) (( 0  8) ( 8  6))
                   (( 0 10) ( 7  8)) (( 0 12) ( 7 10)) (( 0 14) ( 7 13))
                   (( 8 16) ( 7 13)) (( 7 13) ( 7  8)) (( 7  8) ( 8  6))
                   (( 8  6) (10  4)) ((10  4) (16  0)) ((10 16) (11 10))
                   ((10  6) (12  4)) ((12  4) (12  7)) ((12  7) (10  6))
                   ((13  7) (15  5)) ((15  5) (15  8)) ((15  8) (13  7))
                   ((12 16) (13 13)) ((13 13) (15  9)) ((15  9) (16  8))
                   ((13 13) (16 14)) ((14 11) (16 12)) ((15  9) (16 10))]))

(: escher (-> Painter))
(define (escher)
  ; combinators
  (: quartet (-> Painter Painter Painter Painter Painter))
  (define (quartet p1 p2 p3 p4)
    (above (beside p1 p2)
           (beside p3 p4)))
  (: nonet (-> Painter Painter Painter Painter Painter Painter Painter Painter Painter Painter))
  (define (nonet p1 p2 p3 p4 p5 p6 p7 p8 p9)
    (above3 (beside3 p1 p2 p3)
            (beside3 p4 p5 p6)
            (beside3 p7 p8 p9)))
  (: cycle (-> Painter Painter))
  (define (cycle p1)
    (quartet      p1  (rot (rot (rot p1)))
             (rot p1)      (rot (rot p1))))
  (define rot     rotate90)
  (define b       blank)
  (define-values (p q r s) (values P Q R S))
  (define t       (quartet p q r s))
  (define side1   (quartet b b (rot t) t))
  (define side2   (quartet side1 side1 (rot t) t))
  (define u       (cycle (rot q)))
  (define corner1 (quartet b b b u))
  (define corner2 (quartet corner1 side1 (rot side1) u))
  (define corner  (nonet corner2      side2    side2
                         (rot side2)      u  (rot t)
                         (rot side2) (rot t)      q))
  (define square-limit (cycle corner))
  square-limit)

(: draw (-> Painter String 'png Any))
(define draw
  (λ (painter file-name file-type)
    (send (apply-painter painter unit-frame #:width 400 #:height 400)
          save-file file-name file-type)))

(displayln "start")
(time (draw (escher) "escher.png" 'png))

What should have happened?

If I add type to current-dc via unsafe-require/typed/provide in typed/sicp-pict/main.rkt:

(unsafe-require/typed/provide "../../sicp-pict/main.rkt"
  [current-bm (Parameter (Option (Instance Bitmap%)))]
  [current-dc (Parameter (Option (Instance Bitmap-DC%)))])

the program runs fine:

start
cpu time: 312 real time: 313 gc time: 23
#t

What happened?

If I use require/typed/provide:

(require/typed/provide "../../sicp-pict/main.rkt"
  [current-bm (Parameter (Option (Instance Bitmap%)))]
  [current-dc (Parameter (Option (Instance Bitmap-DC%)))])

the program runs very slowly:

start
cpu time: 4140288 real time: 4147561 gc time: 573
#t
samth commented 2 years ago

I'm confused by what you write at the beginning/in the title. Are you running into performance problems with using parameter/c, or with typed/untyped interop using the Parameter type, or both?

And if you can reproduce this without Typed Racket, just using contracts, that would be helpful for debugging.

NoahStoryM commented 2 years ago

I'm confused by what you write at the beginning/in the title. Are you running into performance problems with using parameter/c, or with typed/untyped interop using the Parameter type, or both?

The performance problem appeared after I added a type to a variable which is attached to parameter/c:

#lang typed/racket

(module untyped racket/base
  (provide (contract-out [current-bm (parameter/c (or/c #f (is-a?/c bitmap%)))]
                         [current-dc (parameter/c (or/c #f (is-a?/c bitmap-dc%)))]))

  (define current-bm (make-parameter #f))
  (define current-dc (make-parameter #f)))

(require/typed 'untyped
  ;; It causes the program to be very slow.
  [current-bm (Parameter (Option (Instance Bitmap%)))]
  [current-dc (Parameter (Option (Instance Bitmap-DC%)))])

#;(unsafe-require/typed 'untyped
    ;; It works fine.
    [current-bm (Parameter (Option (Instance Bitmap%)))]
    [current-dc (Parameter (Option (Instance Bitmap-DC%)))])

;;; Program
(: apply-painter ...)
...

And if you can reproduce this without Typed Racket, just using contracts, that would be helpful for debugging.

I think the problem seems to be due to parameter/c, but I don't know exactly why.

samth commented 2 years ago

Ah, so it's the combination of parameter/c in the untyped code and the contract generated by Typed Racket that makes things slow?

If that's the case, then two uses of parameter/c should produce the same slowdown.

rfindler commented 2 years ago

One thing that jumps out at me here is that the types are very large with lots of checks that're going to be generated by them; so it might not be parameter/c specifically but just a large extra number of contract checks that're being generated by the bitmap and bitmap-dc contracts.

samth commented 2 years ago

Where can I get typed/sicp-pict so that I can run the code?

samth commented 2 years ago

Also, the code provided in this issue doesn't actually run -- it has a bunch of missing requires, various syntax errors. Do you have the version of the code you ran?

NoahStoryM commented 2 years ago

If that's the case, then two uses of parameter/c should produce the same slowdown.

You're right, I tried to use cast and it also made the program slow:

#lang typed/racket
(require typed/racket/draw typed/sicp-pict)

(let ([current-bm (cast current-bm (Parameter (Option (Instance Bitmap%))))]
      [current-dc (cast current-dc (Parameter (Option (Instance Bitmap-DC%))))])
  ;;; Program ... 
  )

Where can I get typed/sicp-pict so that I can run the code?

I'm trying to add typed version to sicp-pict: https://github.com/NoahStoryM/sicp/tree/typed

samth commented 2 years ago

Ok, I don't think this has anything to do with parameter/c. If I change (parameter/c ...) in sicp/sicp-pict/main.rkt to any/c, the program is still slow. So the problem is just with the contract that Typed Racket generates for (Parameter (Option (Instance Bitmap%))) etc.

samth commented 2 years ago

Further investigation suggests that it's the current-dc contract that is very slow. Having a contract on current-bm doesn't impose much overhead (which is unsurprising, it isn't used much in the actual library).

samth commented 2 years ago

Further investigation:

  1. Running the program with the info log level prints an almost-endless stream of collapsible-value-bailout: arrow: can't prove single-return-value, suggesting that some contract internal things are happening in a loop.
  2. Almost always, when I kill it, it's in the loop on line 1390 of racket/private/contract/class-c-old.rkt, and usually in the object/c-stronger function. I tried making object/c-stronger always produce #f, but that didn't seem to have much impact.
  3. Then I tried removing that loop entirely, so that the contract system no longer does the check (it just uses all-new-ctcs etc without checking). That was a huge performance improvement, down to about 10x slower than the uncontracted version (@NoahStoryM's results were about 10000x slower).

I think the next question is for @rfindler, which is why is that code running so often, and can it be made faster/skipped.

rfindler commented 2 years ago

Hi @samth can you please share what you did to make the code run? Apparently you figured out something that I cannot.

samth commented 2 years ago

I just used the branch referenced by @NoahStoryM above.

rfindler commented 2 years ago

I see. Thanks.

Looks like the O(n^2) in that code finally bit us. This diff is an improvement:

diff --git a/racket/collects/racket/private/class-c-old.rkt b/racket/collects/racket/private/class-c-old.rkt
index d60fc12fe6..80cf301b55 100644
--- a/racket/collects/racket/private/class-c-old.rkt
+++ b/racket/collects/racket/private/class-c-old.rkt
@@ -1384,6 +1384,15 @@
                 (contract? y)
                 (contract-stronger? x y)))

+         (define (ormap-first-few f lst)
+           (let loop ([lst lst]
+                      [n 5])
+           (cond
+             [(null? lst) #f]
+             [(zero? n) #f]
+             [else (or (f (car lst))
+                       (loop (cdr lst) (- n 1)))])))
+
          (define-values (reverse-without-redundant-ctcs
                          reverse-without-redundant-projs
                          dropped-something?)
@@ -1399,8 +1408,8 @@
                                           (cons this-proj prior-projs)
                                           dropped-something?)]
                [else
-                (if (and (ormap (λ (x) (stronger? x this-ctc)) prior-ctcs)
-                         (ormap (λ (x) (stronger? this-ctc x)) next-ctcs))
+                (if (and (ormap-first-few (λ (x) (stronger? x this-ctc)) prior-ctcs)
+                         (ormap-first-few (λ (x) (stronger? this-ctc x)) next-ctcs))
                     (loop prior-ctcs prior-projs
                           (car next-ctcs) (cdr next-ctcs) (car next-projs) (cdr next-projs)
                           #t)
rfindler commented 2 years ago

On second thought, I think the real problem is this definition

(define (case->-stronger? this that) #f)

:) I'll try looking into that to see if improving it fixes the problem.

rfindler commented 2 years ago

The commit I pushed a few minutes ago seems to improve the performance of the example a good amount.

samth commented 2 years ago

Just to understand the current situation, the O(n^2) behavior is still there, but now much less likely to be a problem because many fewer elements are in the list now. Is that right?

rfindler commented 2 years ago

That's right. In fact, I think that if the list ever goes beyond a constant length for TR-generated contracts, then that's a bug somewhere -- I'm not 100% confident of that fact, but it feels reasonable to me that we cannot get very many non-unique contracts stacking up with TR and repeating the same ones'll get discarded.

There are ways to break this assumption if you can write your own contracts, however.

Ideas on what would be better?

samth commented 2 years ago

That makes sense. Maybe I should put a log statement in there for when it gets over 5.

rfindler commented 2 years ago

That sounds like a good idea! Here's one way to do it; I would have pushed it already but I'm unsure what's the best logger to log it to:

diff --git a/racket/collects/racket/private/class-c-old.rkt b/racket/collects/racket/private/class-c-old.rkt
index d60fc12fe6..929d7c4a69 100644
--- a/racket/collects/racket/private/class-c-old.rkt
+++ b/racket/collects/racket/private/class-c-old.rkt
@@ -1393,20 +1393,26 @@
                       [next-ctcs (cdr all-new-ctcs)]
                       [this-proj (car all-new-projs)]
                       [next-projs (cdr all-new-projs)]
-                      [dropped-something? #f])
+                      [dropped-something? #f]
+                      [n 0])
              (cond
-               [(null? next-ctcs) (values (cons this-ctc prior-ctcs)
-                                          (cons this-proj prior-projs)
-                                          dropped-something?)]
+               [(null? next-ctcs)
+                (when (n . > . 10)
+                  (log-something ...))
+                (values (cons this-ctc prior-ctcs)
+                        (cons this-proj prior-projs)
+                        dropped-something?)]
                [else
                 (if (and (ormap (λ (x) (stronger? x this-ctc)) prior-ctcs)
                          (ormap (λ (x) (stronger? this-ctc x)) next-ctcs))
                     (loop prior-ctcs prior-projs
                           (car next-ctcs) (cdr next-ctcs) (car next-projs) (cdr next-projs)
-                          #t)
+                          #t
+                          (+ n 1))
                     (loop (cons this-ctc prior-ctcs) (cons this-proj prior-projs)
                           (car next-ctcs) (cdr next-ctcs) (car next-projs) (cdr next-projs)
-                          dropped-something?))])))
+                          dropped-something?
+                          (+ n 1)))])))

          (define unwrapped-class
            (if (has-impersonator-prop:instanceof/c-unwrapped-class? val)
rfindler commented 2 years ago

I see that there are places where the logger racket/contract is used for generic "something might be missing that matter for performance" log messages, so I followed that (even though, technically, this isn't in racket/contract).