[Git][ghc/ghc][wip/andreask/infer_exprs] 2 commits: Stg.InferTags.Rewrite - Avoid some thunks.

[Andreas Klebinger (@AndreasK)]

Andreas Klebinger pushed to branch wip/andreask/infer_exprs at Glasgow Haskell Compiler / GHC


Commits:
d8166f9e by Andreas Klebinger at 2022-08-12T17:44:22+02:00
Stg.InferTags.Rewrite - Avoid some thunks.

- - - - -
0e4e4ac7 by Andreas Klebinger at 2022-08-12T17:44:41+02:00
Fix testsuite

- - - - -


2 changed files:

- compiler/GHC/Stg/InferTags/Rewrite.hs
- testsuite/tests/simplStg/should_compile/all.T


Changes:

=====================================
compiler/GHC/Stg/InferTags/Rewrite.hs
=====================================
@@ -128,7 +128,7 @@ getMap :: RM (UniqFM Id TagSig)
 getMap = RM $ ((\(fst,_,_,_) -> fst) <$> get)
 
 setMap :: (UniqFM Id TagSig) -> RM ()
-setMap m = RM $ do
+setMap !m = RM $ do
     (_,us,mod,lcls) <- get
     put (m, us,mod,lcls)
 
@@ -139,7 +139,7 @@ getFVs :: RM IdSet
 getFVs = RM $ ((\(_,_,_,lcls) -> lcls) <$> get)
 
 setFVs :: IdSet -> RM ()
-setFVs fvs = RM $ do
+setFVs !fvs = RM $ do
     (tag_map,us,mod,_lcls) <- get
     put (tag_map, us,mod,fvs)
 
@@ -195,9 +195,9 @@ withBinders NotTopLevel sigs cont = do
 withClosureLcls :: DIdSet -> RM a -> RM a
 withClosureLcls fvs act = do
     old_fvs <- getFVs
-    let fvs' = nonDetStrictFoldDVarSet (flip extendVarSet) old_fvs fvs
+    let !fvs' = nonDetStrictFoldDVarSet (flip extendVarSet) old_fvs fvs
     setFVs fvs'
-    r <- act
+    !r <- act
     setFVs old_fvs
     return r
 
@@ -206,9 +206,9 @@ withClosureLcls fvs act = do
 withLcl :: Id -> RM a -> RM a
 withLcl fv act = do
     old_fvs <- getFVs
-    let fvs' = extendVarSet old_fvs fv
+    let !fvs' = extendVarSet old_fvs fv
     setFVs fvs'
-    r <- act
+    !r <- act
     setFVs old_fvs
     return r
 
@@ -222,7 +222,7 @@ isTagged v = do
             | otherwise -> do -- Local binding
                 !s <- getMap
                 let !sig = lookupWithDefaultUFM s (pprPanic "unknown Id:" (ppr v)) v
-                return $ case sig of
+                return $! case sig of
                     TagSig info ->
                         case info of
                             TagDunno -> False
@@ -234,7 +234,7 @@ isTagged v = do
             , isNullaryRepDataCon con
             -> return True
             | Just lf_info <- idLFInfo_maybe v
-            -> return $
+            -> return $!
                 -- Can we treat the thing as tagged based on it's LFInfo?
                 case lf_info of
                     -- Function, applied not entered.
@@ -353,7 +353,7 @@ rewriteArg  (lit at StgLitArg{}) = return lit
 
 rewriteId :: Id -> RM Id
 rewriteId v = do
-    is_tagged <- isTagged v
+    !is_tagged <- isTagged v
     if is_tagged then return $! setIdTagSig v (TagSig TagProper)
                  else return v
 


=====================================
testsuite/tests/simplStg/should_compile/all.T
=====================================
@@ -12,4 +12,3 @@ setTestOpts(f)
 test('T13588', [ grep_errmsg('case') ] , compile, ['-dverbose-stg2stg -fno-worker-wrapper'])
 test('T19717', normal, compile, ['-ddump-stg-final -dsuppress-uniques -dno-typeable-binds'])
 test('inferTags002', [ only_ways(['optasm']), grep_errmsg('(stg\_ap\_0)', [1])], compile, ['-ddump-cmm -dsuppress-uniques -dno-typeable-binds -O'])
-test('inferTags002', [ grep_errmsg('(stg_ap_0)', [1])], compile, ['-ddump-cmm -dsuppress-uniques -dno-typeable-binds -O'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b0a70269bf0a9e8959c3a3984dc966555cd84729...0e4e4ac7938b02dfe13ca478245308875c963865

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b0a70269bf0a9e8959c3a3984dc966555cd84729...0e4e4ac7938b02dfe13ca478245308875c963865
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220812/a366805d/attachment-0001.html>