[Haskell-cafe] evaluating CAFs at compile time

[Evan Laforge]

On Sat, Jan 18, 2014 at 4:25 PM, Carter Schonwald
<carter.schonwald at gmail.com> wrote:
> evan, could you share a minimal example of the code that illustrates your
> problem? It may be that theres
> a) an alternative way to write it that that gives the perf characteristics
> you want
> b) it could be a good example for future ghc optimization efforts
> c) other

Sure.  As you might guess, there are lots of dependencies, but you
don't have to care about them.  A Patch has a bunch of fields, but the
key part is Score.Attributes, which is a newtype over Set Text.  All
the attrs_* functions are just the obvious wrappers around set
operations.  'strip_attr' tries to remove redundant attributes, but
can only do so if that doesn't cause it to collide with an existing
attribute set (which means it wasn't redundant after all).  You'll
notice it's naively implemented, since it does a linear search through
all the other attributes.  Given 41 instruments, 12 attrs to strip,
and a typical instrument having 285 attrs, that winds up being
something like 41 * 12 * 285^2, and takes about 0.39 CPU seconds to
force with NFData.  I appended a less naive version that replaces the
linear search with a Set and it's faster (0.19, presumably ^2 becomes
(* log 285)), but is uglier.  So I did find an alternative way, but
it's still fairly expensive, and it would be nice to be able to write
the slow but pretty version and pay the cost at compile time.  All the
attributes data is coming from another module which is basically 1855
lines of CAFs.  I could apply the attribute stripping by hand to that,
but it would be error-prone and ugly and lots of work... that's the
machine's job!

patches :: [MidiInst.Patch]
patches =
    [add_code hmap (make_patch inst category)
        | ((inst, hmap), category) <- instruments]
    where
    add_code hmap patch = (patch, code)
        where code = MidiInst.note_calls (note_calls hmap patch)

make_patch :: VslInst.Instrument -> Text -> Instrument.Patch
make_patch inst category =
    instrument_patch category (second strip (make_instrument inst))
    where strip = uncurry zip . first strip_attrs . unzip

strip_attrs :: [Score.Attributes] -> [Score.Attributes]
strip_attrs attrs = foldr strip_attr attrs strip
    where
    strip = reverse
        [ VslInst.sus, VslInst.vib, VslInst.perf, VslInst.fast, VslInst.fa
        , VslInst.norm, VslInst.na, VslInst.legato, VslInst.v1, VslInst.art
        , VslInst.med, VslInst.short
        ]

-- | Strip the given attr, but only if it wouldn't cause clashes.
strip_attr :: Score.Attributes -> [Score.Attributes] -> [Score.Attributes]
strip_attr attr all_attrs = map (strip_redundant attr) all_attrs
    where
    strip_redundant attr attrs
        | stripped `elem` all_attrs = attrs
        | otherwise = stripped
        where stripped = Score.attrs_diff attrs attr

-- optimized version, applied via mapAccumL to thread the Set through each call:
strip_attr :: Score.Attributes -> (Set.Set Score.Attributes, [Score.Attributes])
    -> (Set.Set Score.Attributes, [Score.Attributes])
strip_attr attr (all_attrs_set, all_attrs)
    | any (`Score.attrs_contain` attr) all_attrs =
        List.mapAccumL strip_redundant all_attrs_set all_attrs
    | otherwise = (all_attrs_set, all_attrs)
    where
    strip_redundant attrs_set attrs
        | Set.member stripped attrs_set = (attrs_set, attrs)
        | otherwise = (Set.insert stripped attrs_set, stripped)
        where stripped = Score.attrs_diff attrs attr