strict-impl-params (empty) → 1.0.0

raw patch · 3 files changed

+119/−0 lines, 3 filesdep +basedep +ghcdep +ghc-prim

Dependencies added: base, ghc, ghc-prim, template-haskell

Files

• LICENSE.txt +18/−0
• StrictImplParams.hs +79/−0
• strict-impl-params.cabal +22/−0

@@ -0,0 +1,18 @@+Copyright 2022 András Kovács++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of+the Software, and to permit persons to whom the Software is furnished to do so,+subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

@@ -0,0 +1,79 @@++{-# language+  LambdaCase,+  Strict,+  TemplateHaskell,+  TupleSections,+  ViewPatterns+  #-}++{-# options_ghc+  -Wincomplete-patterns+  -Wunused-imports+  #-}++module StrictImplParams (plugin) where++import System.Exit+import Data.Foldable++import GHC.Classes+import GHC.Plugins++import qualified Language.Haskell.TH as TH+import qualified GHC.Core.TyCo.Rep   as GHC++plugin :: Plugin+plugin = defaultPlugin {+  installCoreToDos = \_ todo -> pure (CoreDoPluginPass "Strict Implicit Params" pass : todo),+  pluginRecompile  = purePlugin+  }++fromTHName :: TH.Name -> CoreM Name+fromTHName thn = thNameToGhcName thn >>= \case+  Nothing -> do+    errorMsg $ text "Could not resolve TH name" <+> text (show thn)+    liftIO exitFailure+  Just n -> pure n++map' :: (a -> b) -> [a] -> [b]+map' f = foldr' (\a bs -> ((:) $! f a) $! bs) []+{-# inline map' #-}++forceVar :: Var -> CoreExpr -> Type -> CoreExpr+forceVar x u uty = Case (Var x) x uty [Alt DEFAULT [] u]++setNoOccInfo :: Var -> Var+setNoOccInfo x = case idInfo x of+  i -> lazySetIdInfo x (i {occInfo = noOccInfo})++forceType :: Type -> Type+forceType a = case tcView a of+  Just a' -> forceType a'+  _       -> a++pass :: ModGuts -> CoreM ModGuts+pass guts = do+  dflags <- getDynFlags+  ipName <- fromTHName ''GHC.Classes.IP++  let goDef :: [Var] -> CoreExpr -> Type -> CoreExpr+      goDef xs t a = case t of+        Lam x t -> case forceType a of+          GHC.ForAllTy _ a  -> Lam x $! goDef xs t a+          GHC.FunTy _ _ a b+            | Just (getName -> con, _) <- splitTyConApp_maybe a, con == ipName ->+                Lam x $! goDef (((:) $! setNoOccInfo x) xs) t b+            | otherwise ->+                Lam x $! goDef xs t b+          a -> do+            error $ "unexpected lam type: " ++ showSDoc dflags (ppr a)++        t -> foldl' (\acc x -> forceVar x acc a) t xs++  let goBind :: CoreBind -> CoreBind+      goBind = \case+        NonRec b t -> NonRec b $! goDef [] t (varType b)+        Rec defs   -> Rec $! map' (\(b, t) -> (b,) $! goDef [] t (varType b)) defs++  pure $! guts {mg_binds = map' goBind (mg_binds guts)}

@@ -0,0 +1,22 @@+name: strict-impl-params+cabal-version: 1.12+build-type: Simple+version: 1.0.0+synopsis: Plugin for making top-level implicit parameters strict+homepage: https://github.com/AndrasKovacs/ghc-strict-implicit-params+bug-reports: https://github.com/AndrasKovacs/ghc-strict-implicit-params/issues+copyright: 2022 András Kovács+license:        MIT+license-file:   LICENSE.txt+maintainer:     puttamalac@gmail.com+category:       Development+description:    Plugin for making top-level implicit parameters strict++library+  default-language: Haskell2010+  build-depends:+      base >=4.7 && <5+    , ghc >= 9.2.3+    , ghc-prim+    , template-haskell+  exposed-modules: StrictImplParams