[Git][ghc/ghc][wip/andreask/infer_bottom] TagAnalysis: Treat all bottom ids as tagged during analysis.

[Andreas Klebinger (@AndreasK)]

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


Commits:
8c0346bf by Andreas Klebinger at 2024-05-14T23:48:12+02:00
TagAnalysis: Treat all bottom ids as tagged during analysis.

Ticket #24806 showed that we also need to treat dead end thunks as
tagged during the analysis.

- - - - -


2 changed files:

- compiler/GHC/Stg/InferTags.hs
- compiler/GHC/Stg/InferTags/Rewrite.hs


Changes:

=====================================
compiler/GHC/Stg/InferTags.hs
=====================================
@@ -301,13 +301,14 @@ inferTagExpr env (StgApp fun args)
     (info, StgApp fun args)
   where
     !fun_arity = idArity fun
-    info | fun_arity == 0 -- Unknown arity => Thunk or unknown call
-         = TagDunno
-
+    info
          | isDeadEndId fun
          , fun_arity == length args -- Implies we will simply call the function.
          = TagTagged -- See Note [Bottom functions are TagTagged]
 
+         | fun_arity == 0 -- Unknown arity => Thunk or unknown call
+         = TagDunno
+
          | Just (TagSig res_info) <- tagSigInfo (idInfo fun)
          , fun_arity == length args  -- Saturated
          = res_info
@@ -500,6 +501,11 @@ it safely any tag sig we like.
 So we give it TagTagged, as it allows the combined tag sig of the case expression
 to be the combination of all non-bottoming branches.
 
+NB: After the analysis is done we go back to treating bottoming functions as
+untagged to ensure they are evaluated as expected in code like:
+
+  case bottom_id of { ...}
+
 -}
 
 -----------------------------


=====================================
compiler/GHC/Stg/InferTags/Rewrite.hs
=====================================
@@ -241,7 +241,10 @@ indicates a bug in the tag inference implementation.
 For this reason we assert that we are running in interactive mode if a lookup fails.
 -}
 isTagged :: Id -> RM Bool
-isTagged v = do
+isTagged v
+    -- See Note [Bottom functions are TagTagged]
+    | isDeadEndId v = pure False
+    | otherwise = do
     this_mod <- getMod
     -- See Note [Tag inference for interactive contexts]
     let lookupDefault v = assertPpr (isInteractiveModule this_mod)
@@ -315,18 +318,21 @@ rewriteTop (StgTopLifted bind)   = do
 
 -- For top level binds, the wrapper is guaranteed to be `id`
 rewriteBinds :: TopLevelFlag -> InferStgBinding -> RM (TgStgBinding)
-rewriteBinds _top_flag (StgNonRec v rhs) = do
+rewriteBinds top_flag bind = case bind of
+    (StgNonRec v rhs) -> do
         (!rhs) <-  rewriteRhs v rhs
         return $! (StgNonRec (fst v) rhs)
-rewriteBinds top_flag b@(StgRec binds) =
-    -- Bring sigs of binds into scope for all rhss
-    withBind top_flag b $ do
-        (rhss) <- mapM (uncurry rewriteRhs) binds
-        return $! (mkRec rhss)
-        where
-            mkRec :: [TgStgRhs] -> TgStgBinding
-            mkRec rhss = StgRec (zip (map (fst . fst) binds) rhss)
-
+    b@(StgRec binds) ->
+        -- Bring sigs of binds into scope for all rhss
+        withBind top_flag b $ do
+            (rhss) <- mapM (uncurry rewriteRhs) binds
+            return $! (mkRec rhss)
+            where
+                mkRec :: [TgStgRhs] -> TgStgBinding
+                mkRec rhss = StgRec (zip (map (fst . fst) binds) rhss)
+    where
+        idFromTgId (id,sig)
+            | isDeadEndId =
 -- Rewrite a RHS
 rewriteRhs :: (Id,TagSig) -> InferStgRhs
            -> RM (TgStgRhs)



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8c0346bf2eba1747609e0eab43d541e3b9f21627

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8c0346bf2eba1747609e0eab43d541e3b9f21627
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/20240514/32e13466/attachment-0001.html>