persistent-qq weird memory bug

[parsonsmatt]

Before submitting your PR, check that you've:

• Documented new APIs with Haddock markup
• Added @since declarations to the Haddock
• Ran stylish-haskell on any changed files.
• Adhered to the code style (see the .editorconfig file for details)

After submitting your PR:

• Update the Changelog.md file with a link to your PR
• Bumped the version number if there isn't an (unreleased) on the Changelog
• Check that CI passes (or if it fails, for reasons unrelated to your change, like CI timeouts)

persistent-qq memory testing

We had an issue at work where a sqlQQ quasi quoter was using way too much memory.
We switched away from the ^{} and @{} splices for field and column names, and that fixed it.
I decided to try and diagnose it.

First step is getting a "baseline": a memory use from GHC that tells me how much mem we're using.
I built the test with stack build --test --no-run-tests --ghc-options "-O2 +RTS -s -RTS", which gives me a memory output.

A run without any QQ at all is:

When we add a query with a bunch of stuff,

[4 of 5] Compiling CodeGenTest
/home/matt/Projects/persistent/persistent-qq/test/CodeGenTest.hs:(27,17)-(31,10): Splicing expression
    Language.Haskell.TH.Quote.quoteExp
      sqlQQ 
      "\n\  
      \    select ^{Person}.@{PersonName}, ^{Person}.@{PersonAge}, ^{Person}.@{PersonColor}\n\
      \    from ^{Person}\n\
      \    where @{PersonName} = 'asdf'\n\
      \        "
  ======>   
    ((uncurry rawSql . Database.Persist.Sql.Raw.QQ.second concat)
       =<<  
         (fmap
            $ Database.Persist.Sql.Raw.QQ.first
                (Data.Text.pack "
    select " <>))
           (getTableName (error "record" :: Person)
              >>=
                (\ table_afnq
                   -> (fmap $ Database.Persist.Sql.Raw.QQ.first (table_afnq <>))
                        ((fmap $ Database.Persist.Sql.Raw.QQ.first (Data.Text.pack "." <>))
                           (getFieldName PersonName
                              >>=
                                (\ field_afnr
                                   -> (fmap $ Database.Persist.Sql.Raw.QQ.first (field_afnr <>))
                                        ((fmap
                                            $ Database.Persist.Sql.Raw.QQ.first
                                                (Data.Text.pack ", " <>))
                                           (getTableName (error "record" :: Person)
                                              >>=
                                                (\ table_afns
                                                   -> (fmap
                                                         $ Database.Persist.Sql.Raw.QQ.first
                                                             (table_afns <>))
                                                        ((fmap
                                                            $ Database.Persist.Sql.Raw.QQ.first
                                                                (Data.Text.pack "." <>))
                                                           (getFieldName PersonAge
                                                              >>=
                                                                (\ field_afnt
                                                                   -> (fmap
                                                                         $ Database.Persist.Sql.Raw.QQ.first
                                                                             (field_afnt <>))
                                                                        ((fmap
                                                                            $ Database.Persist.Sql.Raw.QQ.first
                                                                                (Data.Text.pack ", "
                                                                                 <>))
                                                                           (getTableName
                                                                              (error "record" ::
                                                                                 Person)
                                                                              >>=
                                                                                (\ table_afnu
                                                                                   -> (fmap
                                                                                         $ Database.Persist.Sql.Raw.QQ.first
                                                                                             (table_afnu
                                                                                              <>))
                                                                                        ((fmap
                                                                                            $ Database.Persist.Sql.Raw.QQ.first
                                                                                                (Data.Text.pack
                                                                                                   "."
                                                                                                 <>))
                                                                                           (getFieldName
                                                                                              PersonColor
                                                                                              >>=
                                                                                                (\ field_afnv
                                                                                                   -> (fmap
                                                                                                         $ Database.Persist.Sql.Raw.QQ.first
                                                                                                             (field_afnv
                                                                                                              <>))
                                                                                                        ((fmap
                                                                                                            $ Database.Persist.Sql.Raw.QQ.first
                                                                                                                (Data.Text.pack
                                                                                                                   "
    from "  
                                                                                                                 <>))
                                                                                                           (getTableName
                                                                                                              (error
                                                                                                                 "record" ::
                                                                                                                 Person)
                                                                                                              >>=
                                                                                                                (\ table_afnw
                                                                                                                   -> (fmap
                                                                                                                         $ Database.Persist.Sql.Raw.QQ.first
                                                                                                                             (table_afnw
                                                                                                                              <>))
                                                                                                                        ((fmap
                                                                                                                            $ Database.Persist.Sql.Raw.QQ.first
                                                                                                                                (Data.Text.pack
                                                                                                                                   "
    where " 
                                                                                                                                 <>))
                                                                                                                           (getFieldName
                                                                                                                              PersonName
                                                                                                                              >>=
                                                                                                                                (\ field_afnx
                                                                                                                                   -> (fmap
                                                                                                                                         $ Database.Persist.Sql.Raw.QQ.first
                                                                                                                                             (field_afnx
                                                                                                                                              <>))
                                                                                                                                        ((fmap
                                                                                                                                            $ Database.Persist.Sql.Raw.QQ.first
                                                                                                                                                (Data.Text.pack
                                                                                                                                                   " = 'asdf'
        "   
                                                                                                                                                 <>))
                                                                                                                                           (return
                                                                                                                                              (mempty, 
                                                                                                                                               [])))))))))))))))))))))))))))
[5 of 5] Compiling Main [CodeGenTest changed]
  10,007,165,480 bytes allocated in the heap
         711,776 bytes copied during GC
     370,058,624 bytes maximum residency (11 sample(s))
       5,720,704 bytes maximum slop
             958 MiB total memory in use (0 MB lost due to fragmentation)
            
                                     Tot time (elapsed)  Avg pause  Max pause
  Gen  0       242 colls,     0 par    1.419s   1.420s     0.0059s    0.0504s
  Gen  1        11 colls,     0 par    0.913s   0.913s     0.0830s    0.3022s
            
  TASKS: 4 (1 bound, 3 peak workers (3 total), using -N1)
            
  SPARKS: 0 (0 converted, 0 overflowed, 0 dud, 0 GC'd, 0 fizzled)
            
  INIT    time    0.001s  (  0.001s elapsed)
  MUT     time    3.356s  (  3.408s elapsed)
  GC      time    2.333s  (  2.333s elapsed)
  EXIT    time    0.002s  (  0.009s elapsed)
  Total   time    5.691s  (  5.750s elapsed)
            
  Alloc rate    2,982,086,791 bytes per MUT second
            
  Productivity  59.0% of total user, 59.3% of total elapsed

958 MiB of use! Dang.

When query0 is changed to pure [], the build looks quite different:

[4 of 5] Compiling CodeGenTest
            
/home/matt/Projects/persistent/persistent-qq/test/CodeGenTest.hs:13:1: warning: [-Wunused-imports]
    The import of ‘Database.Persist.Sql.Raw.QQ’ is redundant
      except perhaps to import instances from ‘Database.Persist.Sql.Raw.QQ’
    To import instances alone, use: import Database.Persist.Sql.Raw.QQ()
   |        
13 | import Database.Persist.Sql.Raw.QQ
   | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
            
/home/matt/Projects/persistent/persistent-qq/test/CodeGenTest.hs:14:1: warning: [-Wunused-imports]
    The import of ‘PersistentTestModels’ is redundant
      except perhaps to import instances from ‘PersistentTestModels’
    To import instances alone, use: import PersistentTestModels()
   |        
14 | import PersistentTestModels
   | ^^^^^^^^^^^^^^^^^^^^^^^^^^^
[5 of 5] Compiling Main [CodeGenTest changed]
     588,052,112 bytes allocated in the heap
         193,664 bytes copied during GC
      71,703,760 bytes maximum residency (7 sample(s))
       3,285,808 bytes maximum slop
             157 MiB total memory in use (0 MB lost due to fragmentation)
            
                                     Tot time (elapsed)  Avg pause  Max pause
  Gen  0        47 colls,     0 par    0.114s   0.114s     0.0024s    0.0081s
  Gen  1         7 colls,     0 par    0.135s   0.135s     0.0193s    0.0483s
            
  TASKS: 4 (1 bound, 3 peak workers (3 total), using -N1)
            
  SPARKS: 0 (0 converted, 0 overflowed, 0 dud, 0 GC'd, 0 fizzled)
            
  INIT    time    0.001s  (  0.001s elapsed)
  MUT     time    0.247s  (  0.258s elapsed)
  GC      time    0.249s  (  0.250s elapsed)
  EXIT    time    0.001s  (  0.002s elapsed)
  Total   time    0.498s  (  0.510s elapsed)
            
  Alloc rate    2,377,421,699 bytes per MUT second
            
  Productivity  49.6% of total user, 50.7% of total elapsed

So, 157mb is probably the "default" or good case.

With a QQ and no splices, we ge tthis:

[4 of 5] Compiling CodeGenTest
/home/matt/Projects/persistent/persistent-qq/test/CodeGenTest.hs:(42,11)-(46,5): Splicing expression
    Language.Haskell.TH.Quote.quoteExp
      sqlQQ 
      "\n\  
      \       select name, age, color\n\
      \       from person\n\
      \       where name = 'asdf'\n\
      \   " 
  ======>   
    ((uncurry rawSql . Database.Persist.Sql.Raw.QQ.second concat)
       =<<  
         (fmap
            $ Database.Persist.Sql.Raw.QQ.first
                (Data.Text.pack
                   "
       select name, age, color
       from person
       where name = 'asdf'
   "        
                 <>))
           (return (mempty, [])))
            
/home/matt/Projects/persistent/persistent-qq/test/CodeGenTest.hs:14:1: warning: [-Wunused-imports]
    The import of ‘PersistentTestModels’ is redundant
      except perhaps to import instances from ‘PersistentTestModels’
    To import instances alone, use: import PersistentTestModels()
   |        
14 | import PersistentTestModels
   | ^^^^^^^^^^^^^^^^^^^^^^^^^^^
[5 of 5] Compiling Main [CodeGenTest changed]
     954,677,312 bytes allocated in the heap
         212,344 bytes copied during GC
      68,107,056 bytes maximum residency (7 sample(s))
       3,228,880 bytes maximum slop
             151 MiB total memory in use (0 MB lost due to fragmentation)
            
                                     Tot time (elapsed)  Avg pause  Max pause
  Gen  0        60 colls,     0 par    0.129s   0.129s     0.0021s    0.0074s
  Gen  1         7 colls,     0 par    0.130s   0.130s     0.0186s    0.0473s
            
  TASKS: 4 (1 bound, 3 peak workers (3 total), using -N1)
            
  SPARKS: 0 (0 converted, 0 overflowed, 0 dud, 0 GC'd, 0 fizzled)
            
  INIT    time    0.001s  (  0.000s elapsed)
  MUT     time    0.438s  (  0.468s elapsed)
  GC      time    0.259s  (  0.259s elapsed)
  EXIT    time    0.001s  (  0.003s elapsed)
  Total   time    0.698s  (  0.730s elapsed)
            
  Alloc rate    2,181,423,583 bytes per MUT second
            
  Productivity  62.7% of total user, 64.0% of total elapsed

151MB. Less than with out any splices! Intriguing.

If we introduce a #{"asdf" :: Text} instead of 'asdf' in the quoter, we don't notice much change:

[4 of 5] Compiling CodeGenTest
/home/matt/Projects/persistent/persistent-qq/test/CodeGenTest.hs:(42,11)-(46,5): Splicing expression
    Language.Haskell.TH.Quote.quoteExp
      sqlQQ 
      "\n\  
      \       select name, age, color\n\
      \       from person\n\
      \       where name = #{\"asdf\" :: Text}\n\
      \   " 
  ======>   
    ((uncurry rawSql . Database.Persist.Sql.Raw.QQ.second concat)
       =<<  
         (fmap
            $ Database.Persist.Sql.Raw.QQ.first
                (Data.Text.pack
                   "
       select name, age, color
       from person
       where name = "
                 <>))
           ((fmap
               $ (Database.Persist.Sql.Raw.QQ.first ("?" <>)
                    . Database.Persist.Sql.Raw.QQ.second
                        ([toPersistValue ("asdf" :: Text)] :)))
              ((fmap
                  $ Database.Persist.Sql.Raw.QQ.first (Data.Text.pack "
   " <>))   
                 (return (mempty, [])))))
            
/home/matt/Projects/persistent/persistent-qq/test/CodeGenTest.hs:14:1: warning: [-Wunused-imports]
    The import of ‘PersistentTestModels’ is redundant
      except perhaps to import instances from ‘PersistentTestModels’
    To import instances alone, use: import PersistentTestModels()
   |        
14 | import PersistentTestModels
   | ^^^^^^^^^^^^^^^^^^^^^^^^^^^
[5 of 5] Compiling Main [CodeGenTest changed]
   1,491,499,680 bytes allocated in the heap
         341,152 bytes copied during GC
      69,747,784 bytes maximum residency (7 sample(s))
       3,296,184 bytes maximum slop
             156 MiB total memory in use (0 MB lost due to fragmentation)
            
                                     Tot time (elapsed)  Avg pause  Max pause
  Gen  0       101 colls,     0 par    0.178s   0.179s     0.0018s    0.0073s
  Gen  1         7 colls,     0 par    0.131s   0.131s     0.0188s    0.0459s
            
  TASKS: 4 (1 bound, 3 peak workers (3 total), using -N1)
            
  SPARKS: 0 (0 converted, 0 overflowed, 0 dud, 0 GC'd, 0 fizzled)
            
  INIT    time    0.001s  (  0.000s elapsed)
  MUT     time    0.615s  (  0.653s elapsed)
  GC      time    0.310s  (  0.310s elapsed)
  EXIT    time    0.001s  (  0.006s elapsed)
  Total   time    0.927s  (  0.970s elapsed)
            
  Alloc rate    2,423,788,925 bytes per MUT second
            
  Productivity  66.4% of total user, 67.3% of total elapsed

156MB, well within ordinary.

Adding a second paramater causes much more memory to be used:

[4 of 5] Compiling CodeGenTest
/home/matt/Projects/persistent/persistent-qq/test/CodeGenTest.hs:(42,11)-(49,5): Splicing expression
    Language.Haskell.TH.Quote.quoteExp
      sqlQQ 
      "\n\  
      \       select name, age, color\n\
      \       from person\n\
      \       where name =\n\
      \           #{\"asdf\" :: Text} +\n\
      \           #{\"asdf\" :: Text} +\n\
      \           + ''\n\
      \   " 
  ======>   
    ((uncurry rawSql . Database.Persist.Sql.Raw.QQ.second concat)
       =<<  
         (fmap
            $ Database.Persist.Sql.Raw.QQ.first
                (Data.Text.pack
                   "
       select name, age, color
       from person
       where name =
           "
                 <>))
           ((fmap
               $ (Database.Persist.Sql.Raw.QQ.first ("?" <>)
                    . Database.Persist.Sql.Raw.QQ.second
                        ([toPersistValue ("asdf" :: Text)] :)))
              ((fmap
                  $ Database.Persist.Sql.Raw.QQ.first
                      (Data.Text.pack " +
           " <>))
                 ((fmap
                     $ (Database.Persist.Sql.Raw.QQ.first ("?" <>)
                          . Database.Persist.Sql.Raw.QQ.second
                              ([toPersistValue ("asdf" :: Text)] :)))
                    ((fmap
                        $ Database.Persist.Sql.Raw.QQ.first
                            (Data.Text.pack " +
           + ''
   " <>))   
                       (return (mempty, [])))))))
            
/home/matt/Projects/persistent/persistent-qq/test/CodeGenTest.hs:14:1: warning: [-Wunused-imports]
    The import of ‘PersistentTestModels’ is redundant
      except perhaps to import instances from ‘PersistentTestModels’
    To import instances alone, use: import PersistentTestModels()
   |        
14 | import PersistentTestModels
   | ^^^^^^^^^^^^^^^^^^^^^^^^^^^
[5 of 5] Compiling Main [CodeGenTest changed]
   1,907,596,728 bytes allocated in the heap
         297,152 bytes copied during GC
     107,619,976 bytes maximum residency (8 sample(s))
       4,766,072 bytes maximum slop
             230 MiB total memory in use (0 MB lost due to fragmentation)
            
                                     Tot time (elapsed)  Avg pause  Max pause
  Gen  0        90 colls,     0 par    0.206s   0.206s     0.0023s    0.0090s
  Gen  1         8 colls,     0 par    0.208s   0.208s     0.0260s    0.0755s
            
  TASKS: 4 (1 bound, 3 peak workers (3 total), using -N1)
            
  SPARKS: 0 (0 converted, 0 overflowed, 0 dud, 0 GC'd, 0 fizzled)
            
  INIT    time    0.001s  (  0.001s elapsed)
  MUT     time    0.775s  (  0.812s elapsed)
  GC      time    0.414s  (  0.414s elapsed)
  EXIT    time    0.002s  (  0.004s elapsed)
  Total   time    1.191s  (  1.230s elapsed)
            
  Alloc rate    2,459,891,542 bytes per MUT second
            
  Productivity  65.1% of total user, 66.0% of total elapsed

230MB! 50MB for a single parameter. A third parameter adds another bunch of space used:

[4 of 5] Compiling CodeGenTest
/home/matt/Projects/persistent/persistent-qq/test/CodeGenTest.hs:(42,11)-(50,5): Splicing expression
    Language.Haskell.TH.Quote.quoteExp
      sqlQQ 
      "\n\  
      \       select name, age, color\n\
      \       from person\n\
      \       where name =\n\
      \           #{\"asdf\" :: Text} +\n\
      \           #{\"asdf\" :: Text} +\n\
      \           #{\"asdf\" :: Text} +\n\
      \           + ''\n\
      \   " 
  ======>   
    ((uncurry rawSql . Database.Persist.Sql.Raw.QQ.second concat)
       =<<  
         (fmap
            $ Database.Persist.Sql.Raw.QQ.first
                (Data.Text.pack
                   "
       select name, age, color
       from person
       where name =
           "
                 <>))
           ((fmap
               $ (Database.Persist.Sql.Raw.QQ.first ("?" <>)
                    . Database.Persist.Sql.Raw.QQ.second
                        ([toPersistValue ("asdf" :: Text)] :)))
              ((fmap
                  $ Database.Persist.Sql.Raw.QQ.first
                      (Data.Text.pack " +
           " <>))
                 ((fmap
                     $ (Database.Persist.Sql.Raw.QQ.first ("?" <>)
                          . Database.Persist.Sql.Raw.QQ.second
                              ([toPersistValue ("asdf" :: Text)] :)))
                    ((fmap
                        $ Database.Persist.Sql.Raw.QQ.first
                            (Data.Text.pack " +
           " <>))
                       ((fmap
                           $ (Database.Persist.Sql.Raw.QQ.first ("?" <>)
                                . Database.Persist.Sql.Raw.QQ.second
                                    ([toPersistValue ("asdf" :: Text)] :)))
                          ((fmap
                              $ Database.Persist.Sql.Raw.QQ.first
                                  (Data.Text.pack " +
           + ''
   " <>))   
                             (return (mempty, [])))))))))
            
/home/matt/Projects/persistent/persistent-qq/test/CodeGenTest.hs:14:1: warning: [-Wunused-imports]
    The import of ‘PersistentTestModels’ is redundant
      except perhaps to import instances from ‘PersistentTestModels’
    To import instances alone, use: import PersistentTestModels()
   |        
14 | import PersistentTestModels
   | ^^^^^^^^^^^^^^^^^^^^^^^^^^^
[5 of 5] Compiling Main [CodeGenTest changed]
Prog   2,280,952,912 bytes allocated in the heap
         280,056 bytes copied during GC
     127,402,232 bytes maximum residency (8 sample(s))
       4,837,128 bytes maximum slop
             270 MiB total memory in use (1 MB lost due to fragmentation)
            
                                     Tot time (elapsed)  Avg pause  Max pause
  Gen  0        84 colls,     0 par    0.233s   0.233s     0.0028s    0.0142s
  Gen  1         8 colls,     0 par    0.226s   0.226s     0.0283s    0.0966s
            
  TASKS: 4 (1 bound, 3 peak workers (3 total), using -N1)
            
  SPARKS: 0 (0 converted, 0 overflowed, 0 dud, 0 GC'd, 0 fizzled)
            
  INIT    time    0.001s  (  0.001s elapsed)
  MUT     time    0.890s  (  0.934s elapsed)
  GC      time    0.459s  (  0.459s elapsed)
  EXIT    time    0.002s  (  0.007s elapsed)
  Total   time    1.351s  (  1.400s elapsed)
            
  Alloc rate    2,562,388,338 bytes per MUT second
            
  Productivity  65.9% of total user, 66.7% of total elapsed

270MiB. So we're looking at 40-50MiB per parameter.

Is it just text? Let's try with an int. Testing with an int gives the same result.

The Template Haskell isn't necessary to trigger anything.

   ((uncurry rawSql . Database.Persist.Sql.Raw.QQ.second concat)
         =<<
           (fmap
              $ Database.Persist.Sql.Raw.QQ.first
                  (Data.Text.pack
                     "\
\         select name, age, color \
\         from person \
\         where age = \
\             "
                   <>))
             ((fmap
                 (\ (str_afnO, vals_afnP)
                    -> (("?" <> str_afnO), ([toPersistValue int] : vals_afnP))))
                ((fmap
                    $ Database.Persist.Sql.Raw.QQ.first
                        (Data.Text.pack " + \
\             " <>))
                   ((fmap
                       (\ (str_afnQ, vals_afnR)
                          -> (("?" <> str_afnQ), ([toPersistValue int] : vals_afnR))))
                      ((fmap
                          $ Database.Persist.Sql.Raw.QQ.first
                              (Data.Text.pack " + \
\             " <>))
                         ((fmap
                             (\ (str_afnS, vals_afnT)
                                -> (("?" <> str_afnS), ([toPersistValue int] : vals_afnT))))
                            ((fmap
                                $ Database.Persist.Sql.Raw.QQ.first
                                    (Data.Text.pack " + \
\                 0 \
\     " <>))
                               (return (mempty, [])))))))))

This does just fine!

Looking at the code, we have a bunch of fmap.
Is that the problem?
What if I combine those fmaps into one?

Well, turns out the fmap count doesn't matter. I inlined a bunch of the functions into a single fmap (f1 . f2 . f3 . f4), with no reduction in compilation time.

I then inlined all those functions and produced a direct lambda. No change.

I then ... changed a big chain of <> into an mconcat and it dropped 100MB.
I replcaed some , in the list with <> to see if the overall <> count was the issue, but it didn't matter until I had mconcat [ a <> b <> c <> d ] at which point it went up a shitload again.

It seems like the inliner is getting really happy with certain combinations of <> for Text. The <> for String doesn't appear to cause any issues at all, and memory use holds prety consistent around 150MB.

Wild.

[parsonsmatt]

Very odd behavior. Gonna try in the work codebase...

[parsonsmatt]

I rewrote the TH in this function to be a bit more concise and use more quotes vs manually splicing TH functions together.

[parsonsmatt]

Building the persistent-qq tests with -O2 locally gives me:

master: stack build --test --no-run-tests persistent-qq  71.53s user 4.77s system 100% cpu 1:16.10 total

branch: stack build --test --no-run-tests persistent-qq  4.88s user 0.78s system 101% cpu 5.593 total

😮 70 second reduction. Wow.

[danbroooks]

This looks awesome 👍 presumably the reduction in compile time in the test suite for persistent carries over to compiling a project that uses persistent? Do you have any numbers to illustrate the impact of this if so?

I'm also wondering (forgive me if you've done this elsewhere and I have missed this) if this kind of thing could be benchmarked and managed in CI or something (or even just reported in the project). It seems to me like these performance things with TH are so easy to creep in unnoticed and are hard to spot just through looking at the code, is there potential here for things to change again and something like this to re-appear?

Unfortunately, I also feel like these kinds of things are hard to test / enforce, in the way that specs or static analysis is for instance.

If there is something we could do here with this I would be happy to help out with implementing something, compile times is a bit of a bugbear of mine so I'm happy to help out with this where I can 😁 I know there is a ticket I opened about the benchmarking not running, potentially that could be resurrected a bit and I try to implement something that would cover this ticket?

Great work anyway @parsonsmatt 👍 this looks like a big win

[parsonsmatt]

We could probably just require -O2 in the test suite. But the project doesn't have anything to track/manage build times over time to ensure they don't get worse.

Our -O2 deployment build took 34 minutes and used 28GB RAM before this patch. We noticed the problem because a particularly large module with dozens of splices would OOM our build box (92GB RAM or something asburd), and the Fix was to remove splices.

With this patch + reverting back to the many-splices that OOMed our build box, we're down to 28 minutes and 24GB of RAM. Huge improvement in resource utilization.