strict-impl-params 1.1.0 → 1.1.1
raw patch · 2 files changed
+85/−56 lines, 2 filesdep −ghc-primdep −template-haskelldep ~ghcPVP ok
version bump matches the API change (PVP)
Dependencies removed: ghc-prim, template-haskell
Dependency ranges changed: ghc
API changes (from Hackage documentation)
Files
- StrictImplParams.hs +82/−51
- strict-impl-params.cabal +3/−5
StrictImplParams.hs view
@@ -1,27 +1,15 @@ -{-# language- LambdaCase,- Strict,- TemplateHaskell,- TupleSections,- ViewPatterns- #-}--{-# options_ghc- -Wincomplete-patterns- -Wunused-imports- #-}+{-# language LambdaCase, Strict, TupleSections, CPP #-}+{-# options_ghc -Wincomplete-patterns -Wunused-imports #-} module StrictImplParams (plugin) where -import System.Exit import Data.Foldable--import GHC.Classes+import Data.Maybe+import GHC.Core.Predicate import GHC.Plugins -import qualified Language.Haskell.TH as TH-import qualified GHC.Core.TyCo.Rep as GHC+import qualified GHC.Core.TyCo.Rep as GHC plugin :: Plugin plugin = defaultPlugin {@@ -29,51 +17,94 @@ 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+{-# inline ($$!) #-}+($$!) :: (a -> b) -> a -> b+f $$! x = f x+infixl 8 $$! +{-# inline ($$~) #-}+($$~) :: (a -> b) -> a -> b+f $$~ ~x = f x+infixl 8 $$~+ map' :: (a -> b) -> [a] -> [b]-map' f = foldr' (\a bs -> ((:) $! f a) $! bs) []+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]+#if __GLASGOW_HASKELL__ <= 904+manyType :: Mult+manyType = Many+#else+manyType :: Mult+manyType = ManyTy+#endif -setNoOccInfo :: Var -> Var-setNoOccInfo x = case idInfo x of- i -> lazySetIdInfo x (i {occInfo = noOccInfo})+#if __GLASGOW_HASKELL__ <= 906+coreFullView :: Type -> Type+coreFullView a = case coreView a of+ Just a -> coreFullView a+ _ -> a -forceType :: Type -> Type-forceType a = case coreView a of- Just a' -> forceType a'- _ -> a+isImplicitParamTy :: Type -> Bool+isImplicitParamTy ty = isJust $ isIPPred_maybe ty+#else+isImplicitParamTy :: Type -> Bool+isImplicitParamTy ty = isJust $ do+ (cls, tys) <- getClassPredTys_maybe ty+ isIPPred_maybe cls tys+#endif +-- | Force var, continue with CoreExpr body that has Type type.+forceVar :: Var -> CoreExpr -> Type -> CoreExpr+forceVar x body bodyTy =+ mkWildCase (Var x) (GHC.Scaled manyType (varType x)) bodyTy [Alt DEFAULT [] body]+ 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 dbg :: Outputable a => a -> String+ dbg x = showSDoc dflags (ppr x) 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+ goBind b = let - pure $! guts {mg_binds = map' goBind (mg_binds guts)}+ go :: [Var] -> CoreExpr -> Type -> CoreExpr+ go vars t a = case t of+ Lam x t -> case coreFullView a of+ GHC.ForAllTy _ a -> Lam x $! go vars t a+ GHC.FunTy _ _ a b | isImplicitParamTy a -> Lam x $! go (x:vars) t b+ | otherwise -> Lam x $! go vars t b+ _ -> error $ "unexpected type for lambda expression: " ++ dbg a+ t ->+ foldl' (\acc x -> forceVar x acc a) (goExpr t) vars++ in case b of+ NonRec b t -> NonRec b $! go [] t (varType b)+ Rec defs -> Rec $! map' (\(b, t) -> (b,) $! go [] t (varType b)) defs++ goExpr :: CoreExpr -> CoreExpr+ goExpr t = case t of+ Var{} -> t+ Lit{} -> t+ App t u -> App $$! goExpr t $$! goExpr u+ Case t scr bodyty alts -> Case $$! goExpr t $$! scr $$! bodyty $$! map' goAlt alts+ Cast t coe -> Cast $$! goExpr t $$~ coe+ Tick tck t -> Tick tck $$! goExpr t+ Type{} -> t+ Coercion{} -> t++ -- Note: the bound var of a free-standing lambda+ -- does not get forced!+ Lam x t -> Lam x $! goExpr t++ -- Neither does an implicit let binder!+ -- In both cases the issue is that we don't know the type+ -- of the expr body and I don't like the idea of recomputing it!+ Let b t -> Let $$! goBind b $$! goExpr t++ goAlt :: Alt CoreBndr -> Alt CoreBndr+ goAlt (Alt con bs body) = Alt con bs $! goExpr body++ let mg_binds' = map' goBind (mg_binds guts)+ pure $! guts {mg_binds = mg_binds'}
strict-impl-params.cabal view
@@ -1,8 +1,8 @@ name: strict-impl-params cabal-version: 1.12 build-type: Simple-version: 1.1.0-synopsis: Plugin for making top-level implicit parameters strict+version: 1.1.1+synopsis: Plugin for making 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@@ -15,7 +15,5 @@ default-language: Haskell2010 build-depends: base >=4.7 && <5- , ghc >= 9.2.3 && < 9.14- , ghc-prim < 0.14- , template-haskell < 2.24+ , ghc >= 9.2.3 && < 9.16 exposed-modules: StrictImplParams