loopbreaker (empty) → 0.1.1.0

raw patch · 13 files changed

+530/−0 lines, 13 filesdep +basedep +containersdep +ghcsetup-changed

Dependencies added: base, containers, ghc, hspec, inspection-testing, loopbreaker, syb

Files

• ChangeLog.md +10/−0
• LICENSE +30/−0
• README.md +44/−0
• Setup.hs +2/−0
• loopbreaker.cabal +71/−0
• src/Loopbreaker.hs +54/−0
• src/Loopbreaker/InlineRecCalls.hs +161/−0
• src/Loopbreaker/Utils.hs +7/−0
• test/DisableFlagSpec.hs +34/−0
• test/InlineRecCallsSpec.hs +64/−0
• test/PragmaDetectionSpec.hs +34/−0
• test/Spec.hs +1/−0
• test/TestUtils.hs +18/−0

@@ -0,0 +1,10 @@+# Changelog for Loopbreaker++## 0.1.1.0+- follow `INLINE` pragmas when adding loopbreakers+- support local declarations (`let` and `where` bindings)++## 0.1.0.0+- initial release++## Unreleased changes

@@ -0,0 +1,30 @@+Copyright Matej Nižník, Sandy Maguire (c) 2019++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Matej Nižník nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,44 @@+# loopbreaker++Performance of libraries like [polysemy](https://github.com/polysemy-research/polysemy)+depends on code being aggresively inlined. Problem is that GHC is not very+keen on inlining self-recursive definitions. Luckily, there's a way we can+trick compiler to do so: by introducing intermediate _loopbreaker_ that simply+calls our original function:+```+fact :: Int -> Int+fact 0 = 1+fact n = n * fact' (n - 1)+{-# INLINE fact #-}++fact' :: Int -> Int+fact' = fact+{-# NOINLINE fact' #-}+```+But because this is ugly boilerplate nobody wants to write, we created GHC+plugin that searches for such recursive definitions and automatically inserts+loopbreakers during compilation.++To quote [isovector](https://github.com/isovector):+> As described in [Writing Custom Optimization Passes](https://reasonablypolymorphic.com/blog/writing-custom-optimizations/),+The `polysemy-plugin` has had support for creating explicit loopbreakers for+self-recursive functions. The result is pretty dramatic code improvements in a+lot of cases when `-O2` is turned on.++> Rather embarrassingly, after publishing that post, it turned out that my+implementation didn't in fact improve optimizations. Sure, it spit out the+correct code, but it was being done too late, and some special analysis passes+had already run. The result: we'd generate loopbreakers, but they wouldn't be+used.++> [TheMatten](https://github.com/TheMatten) took it upon himself to fix this.+There's no trick --- just do the same transformations after renaming, rather+than after typechecking. We realized this plugin is useful outside of+polysemy, so it's been released as a standalone package.++## Usage++Add `-fplugin=Loopbreaker` into your `package.yaml` or specific module. This+will cause the plugin to generate explicit loopbreakers for any self-recursive+functions marked as `INLINE`, which can dramatically improve their+performance. See documentation for more info.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,71 @@+cabal-version: 1.12+name: loopbreaker+version: 0.1.1.0+license: BSD3+license-file: LICENSE+copyright: 2019 Matej Nižník,+           2019 Sandy Maguire+maintainer: matten@tuta.io+author: Matej Nižník,+        Sandy Maguire+homepage: https://github.com/polysemy-research/loopbreaker#readme+bug-reports: https://github.com/polysemy-research/loopbreaker/issues+synopsis: inline self-recursive definitions+description:+    Please see the README file on Github for more info+category: Plugin+build-type: Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+    type: git+    location: https://github.com/polysemy-research/loopbreaker++library+    exposed-modules:+        Loopbreaker+    hs-source-dirs: src+    other-modules:+        Loopbreaker.InlineRecCalls+        Loopbreaker.Utils+        Paths_loopbreaker+    default-language: Haskell2010+    default-extensions: ConstraintKinds FlexibleContexts KindSignatures+                        LambdaCase MultiWayIf NamedFieldPuns OverloadedStrings+                        ScopedTypeVariables TupleSections TypeFamilies UnicodeSyntax+                        ViewPatterns+    ghc-options: -Wall+    build-depends:+        base >=4.7 && <5,+        containers ==0.6.*,+        ghc ==8.6.*,+        syb ==0.7.*++test-suite loopbreaker-test+    type: exitcode-stdio-1.0+    main-is: Spec.hs+    build-tool-depends: hspec-discover:hspec-discover -any+    hs-source-dirs: test+    other-modules:+        DisableFlagSpec+        InlineRecCallsSpec+        PragmaDetectionSpec+        TestUtils+        Paths_loopbreaker+    default-language: Haskell2010+    default-extensions: ConstraintKinds FlexibleContexts KindSignatures+                        LambdaCase MultiWayIf NamedFieldPuns OverloadedStrings+                        ScopedTypeVariables TupleSections TypeFamilies UnicodeSyntax+                        ViewPatterns+    ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+                 -fplugin=Loopbreaker+    build-depends:+        base >=4.7 && <5,+        containers ==0.6.*,+        ghc ==8.6.*,+        hspec >=2.6.1 && <3,+        inspection-testing >=0.4.2.1 && <0.5,+        loopbreaker -any,+        syb ==0.7.*

@@ -0,0 +1,54 @@+-- | To use plugin, you can:+--+-- * Either enable the plugin globally in your project configuration's+-- @ghc-options@ field (@package.yaml@ or @\<name\>.cabal@):+--+-- @+-- # package.yaml+-- ...+--+-- ghc-options:+-- - -fplugin=Loopbreaker+--+-- ...+-- @+--+-- * Or alternatively, just enable the plugin in specific modules that may+-- benefit from it's use:+--+-- @+-- -- \<name\>.hs+--+-- {-\# OPTIONS_GHC -fplugin=Loopbreaker \#-}+--+-- ...+-- @+--+-- If you decide to enable it globally, you can selectively disable it in+-- specific modules using @disable@ option:+--+-- @+-- {-\# OPTIONS_GHC -fplugin-opt=Loopbreaker:disable \#-}+--+-- ...+-- @+--+-- Now, in modules where the plugin is enabled, any self-recursive functions+-- marked as @INLINE@ may have their performance greatly improved.++-- TODO(Matej): update docs when loopbreakers for local definitions get added++module Loopbreaker (plugin) where++import GhcPlugins++import Loopbreaker.Utils+import Loopbreaker.InlineRecCalls (action)+++------------------------------------------------------------------------------+plugin :: Plugin+plugin = defaultPlugin+  { pluginRecompile     = purePlugin+  , renamedResultAction = \opts -> traverse (action opts) .: (,)+  }

@@ -0,0 +1,161 @@+{-# LANGUAGE TemplateHaskell #-}++module Loopbreaker.InlineRecCalls (action) where++import           Control.Arrow hiding ((<+>))+import           Data.Generics+import           Data.Kind+import           Data.Map (Map)+import qualified Data.Map as M+import           Data.Maybe+import           Data.Set (Set)+import qualified Data.Set as S++import Bag+import ErrUtils+import GhcPlugins hiding ((<>), debugTraceMsg)+import HsSyn+import MonadUtils+++------------------------------------------------------------------------------+type MonadInline m = ((MonadUnique m, MonadIO m, HasDynFlags m) :: Constraint)++------------------------------------------------------------------------------+-- | Forces compiler to inline functions by creating loopbreaker with NOINLINE+-- pragma, changing recursive calls to use it and by adding INLINE pragma to+-- the original function.+action :: MonadInline m+       => [CommandLineOption] -> HsGroup GhcRn -> m (HsGroup GhcRn)+action opts group@HsGroup{ hs_valds } = do+  let shouldDisable = "disable" `elem` opts++  dyn_flags <- getDynFlags++  if not shouldDisable && optLevel dyn_flags > 0+    then do+      liftIO $ showPass dyn_flags "Break loops"+      valds' <- inlineRecCalls hs_valds+      pure group{ hs_valds = valds' }+    else+      pure group++action _ _ = error "Loopbreaker.InlineRecCalls.action: expected renamed group"++------------------------------------------------------------------------------+inlineRecCalls :: MonadInline m => HsValBinds GhcRn -> m (HsValBinds GhcRn)+inlineRecCalls (XValBindsLR (NValBinds binds sigs)) = do+  let (types, inlined) = typesFromSigs &&& inlinedFromSigs $ unLoc <$> sigs++  (binds', extra_sigs) <- second concat . unzip+                      <$> traverse (inlineRecCall types inlined) binds++  pure $ XValBindsLR $ NValBinds binds' $ sigs ++ extra_sigs++-- TODO: should we throw an error here instead?+inlineRecCalls val_binds = pure val_binds++------------------------------------------------------------------------------+typesFromSigs :: Ord (IdP p) => [Sig p] -> Map (IdP p) (LHsSigWcType p)+typesFromSigs = M.fromList . concatMap sigToTups where+  sigToTups (TypeSig _ names type_) = (,type_) . unLoc <$> names+  sigToTups _                       = []++------------------------------------------------------------------------------+inlinedFromSigs :: Ord (IdP p) => [Sig p] -> Set (IdP p)+inlinedFromSigs = S.fromList . catMaybes . map nameIfInlineSig where+  nameIfInlineSig (InlineSig _ (L _ name) pragma)+    | isInlinePragma pragma = Just name+  nameIfInlineSig _ = Nothing++------------------------------------------------------------------------------+-- | Inserts loopbreaker to recursive binding group of single binding and+-- emits necessary signatures.+inlineRecCall+  :: MonadInline m+  => Map Name (LHsSigWcType GhcRn)  -- ^ types of bindings+  -> Set Name                       -- ^ 'Loopbreaker' annotations+  -> (RecFlag, LHsBinds GhcRn)      -- ^ binding being inlined+  -> m ((RecFlag, LHsBinds GhcRn), [LSig GhcRn])+inlineRecCall types inlined (Recursive, binds)+  | (bagToList -> [L fun_loc fun_bind])           <- binds+  , FunBind{ fun_id = L _ fun_name, fun_matches } <- fun_bind+  , S.member fun_name inlined+  = do+  dyn_flags <- getDynFlags+  liftIO $ debugTraceMsg dyn_flags 2 $ text "Loopbreaker:" <+> ppr fun_name++  (loopb_name, loopb_decl) <- loopbreaker fun_name++  fun_matches' <- everywhereM ( fmap (replaceVarNamesT fun_name loopb_name)+                              . inlineLocalRecCallsM+                              ) fun_matches++  let m_loopb_sig = loopbreakerSig loopb_name <$> M.lookup fun_name types++  pure+    ( ( Recursive+      , listToBag+          [ L fun_loc fun_bind{ fun_matches = fun_matches' }+          , loopb_decl+          ]+      )+      -- If the original function didn't have type signature specified, we+      -- shouldn't have to have either+    , inlineSig noInlinePragma loopb_name : maybeToList m_loopb_sig+    )+-- We ignore mutually recursive and other bindings+inlineRecCall _ _ binds = pure (binds, [])++------------------------------------------------------------------------------+-- | Creates loopbreaker and it's name from name of the original function.+loopbreaker :: MonadUnique m => Name -> m (Name, LHsBind GhcRn)+loopbreaker fun_name =+  (id &&& loopbreakerDecl fun_name) <$> loopbreakerName fun_name++------------------------------------------------------------------------------+loopbreakerName :: MonadUnique m => Name -> m Name+loopbreakerName (occName -> occNameFS -> orig_fs) =+  flip mkSystemVarName (orig_fs <> "__Loopbreaker") <$> getUniqueM++------------------------------------------------------------------------------+loopbreakerDecl :: Name -> Name -> LHsBind GhcRn+loopbreakerDecl fun_name loopb_name =+  noLoc $ mkTopFunBind Generated (noLoc loopb_name)+    [ mkSimpleMatch (mkPrefixFunRhs $ noLoc loopb_name) [] $+        nlHsVar fun_name+    ]++------------------------------------------------------------------------------+-- | Creates loopbreaker type signature from type of original function.+loopbreakerSig :: Name -> LHsSigWcType GhcRn -> LSig GhcRn+loopbreakerSig loopb_name fun_type =+  noLoc $ TypeSig NoExt [noLoc loopb_name] fun_type++------------------------------------------------------------------------------+inlineSig :: (XInlineSig p ~ NoExt) => InlinePragma -> IdP p -> LSig p+inlineSig how name = noLoc $ InlineSig NoExt (noLoc name) how++------------------------------------------------------------------------------+-- | Contrary to 'neverInlinePragma', this has behaviour of 'NOINLINE' pragma.+noInlinePragma :: InlinePragma+noInlinePragma = defaultInlinePragma+  { inl_inline = NoInline+  , inl_act    = NeverActive+  }++------------------------------------------------------------------------------+-- | Transformation that applies loopbreakers to local bindings.+inlineLocalRecCallsM :: (MonadInline m, Typeable a) => a -> m a+inlineLocalRecCallsM = mkM $ \case+  (HsValBinds NoExt binds :: HsLocalBinds GhcRn)+    -> HsValBinds NoExt <$> inlineRecCalls binds+  e -> pure e++------------------------------------------------------------------------------+-- | Transformation that replaces every name in variable expression.+replaceVarNamesT :: Typeable a => Name -> Name -> a -> a+replaceVarNamesT from to = mkT $ \case+  HsVar NoExt (L loc name) :: HsExpr GhcRn+    | name == from -> HsVar NoExt $ L loc to+  e -> e

@@ -0,0 +1,7 @@+module Loopbreaker.Utils+  ( (.:)+  ) where+++(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d+(.:) = (.).(.)

@@ -0,0 +1,34 @@+{-# OPTIONS_GHC -O2 -fplugin-opt=Loopbreaker:disable #-}++{-# LANGUAGE TemplateHaskell #-}++module DisableFlagSpec (spec) where++import TestUtils+++------------------------------------------------------------------------------+spec :: Spec+spec = describe "plugin" $ do+  it "should respect disable flag" $ do+    shouldFail $(inspectTest $ 'recursiveDefault === 'mutual)+    shouldFail $(inspectTest $ 'recursiveOn      === 'mutual)++------------------------------------------------------------------------------+recursiveDefault :: Int -> Int+recursiveDefault 0 = 1+recursiveDefault n = n * recursiveDefault (n - 1)++recursiveOn :: Int -> Int+recursiveOn 0 = 1+recursiveOn n = n * recursiveOn (n - 1)+{-# INLINE recursiveOn #-}++mutual :: Int -> Int+mutual 0 = 1+mutual n = n * mutual' (n - 1)+{-# INLINE mutual #-}++mutual' :: Int -> Int+mutual' = mutual+{-# NOINLINE mutual' #-}

@@ -0,0 +1,64 @@+{-# OPTIONS_GHC -O2 #-}++{-# LANGUAGE TemplateHaskell #-}++module InlineRecCallsSpec (spec) where++import TestUtils+++------------------------------------------------------------------------------+-- TODO: more tests+spec :: Spec+spec = describe "plugin" $ do+  it "should explicitly break recursion in global bindings" $ do+    shouldSucceed $(inspectTest $ 'recursive === 'mutual)+  -- TODO: implementation as Core pass to resolve this+  -- it "should work without signatures" $ do+  --   shouldSucceed $(inspectTest $ 'recursiveNoSig === 'mutual)+  it "should explicitly break recursion in where bindings" $ do+    shouldSucceed $(inspectTest $ 'localRecursiveWhere === 'localMutual)+  it "should explicitly break recursion in let bindings" $ do+    shouldSucceed $(inspectTest $ 'localRecursiveLet === 'localMutual)++------------------------------------------------------------------------------+recursive :: Int -> Int+recursive 0 = 1+recursive n = n * recursive (n - 1)+{-# INLINE recursive #-}++-- recursiveNoSig 0 = (1 :: Int)+-- recursiveNoSig n = n * recursiveNoSig (n - 1)+-- {-# INLINE recursiveNoSig #-}++mutual :: Int -> Int+mutual 0 = 1+mutual n = n * mutual' (n - 1)+{-# INLINE mutual #-}++mutual' :: Int -> Int+mutual' = mutual+{-# NOINLINE mutual' #-}++localRecursiveWhere :: Int -> Int+localRecursiveWhere = local where+  local 0 = 1+  local n = n * local (n - 1)+  {-# INLINE local #-}++localRecursiveLet :: Int -> Int+localRecursiveLet = let+  local 0 = 1+  local n = n * local (n - 1)+  {-# INLINE local #-}+ in+  local++localMutual :: Int -> Int+localMutual = local where+  local 0 = 1+  local n = n * local' (n - 1)+  {-# INLINE local #-}++  local' = local+  {-# NOINLINE local' #-}

@@ -0,0 +1,34 @@+{-# OPTIONS_GHC -O2 #-}++{-# LANGUAGE TemplateHaskell #-}++module PragmaDetectionSpec (spec) where++import TestUtils+++------------------------------------------------------------------------------+spec :: Spec+spec = describe "plugin" $ do+  it "should respect INLINE pragma" $ do+    shouldFail    $(inspectTest $ 'recursiveDefault === 'mutual)+    shouldSucceed $(inspectTest $ 'recursiveOn      === 'mutual)++------------------------------------------------------------------------------+recursiveDefault :: Int -> Int+recursiveDefault 0 = 1+recursiveDefault n = n * recursiveDefault (n - 1)++recursiveOn :: Int -> Int+recursiveOn 0 = 1+recursiveOn n = n * recursiveOn (n - 1)+{-# INLINE recursiveOn #-}++mutual :: Int -> Int+mutual 0 = 1+mutual n = n * mutual' (n - 1)+{-# INLINE mutual #-}++mutual' :: Int -> Int+mutual' = mutual+{-# NOINLINE mutual' #-}

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

@@ -0,0 +1,18 @@+module TestUtils+  ( module U+  , shouldSucceed+  , shouldFail+  ) where++import Test.Hspec      as U+import Test.Inspection as U+++------------------------------------------------------------------------------+shouldSucceed :: Result -> Expectation+shouldSucceed r = r `shouldSatisfy` \case Success{} -> True+                                          Failure e -> error e++shouldFail :: Result -> Expectation+shouldFail r = r `shouldSatisfy` \case Success m -> error m+                                       Failure{} -> True