[Git][ghc/ghc][wip/andreask/ghci-tag-nullary] 2 commits: Add test
Andreas Klebinger (@AndreasK)
gitlab at gitlab.haskell.org
Tue Aug 16 11:18:10 UTC 2022
Andreas Klebinger pushed to branch wip/andreask/ghci-tag-nullary at Glasgow Haskell Compiler / GHC
Commits:
9007eb90 by Andreas Klebinger at 2022-08-16T11:58:02+02:00
Add test
- - - - -
08648849 by Andreas Klebinger at 2022-08-16T13:17:51+02:00
Always run tag inference, including for byteCodeGen
- - - - -
11 changed files:
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Stg/InferTags.hs
- compiler/GHC/Stg/InferTags/TagSig.hs
- compiler/GHC/Stg/Pipeline.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToCmm/Types.hs
- testsuite/tests/simplStg/should_run/Makefile
- + testsuite/tests/simplStg/should_run/T22042.hs
- + testsuite/tests/simplStg/should_run/T22042.stdout
- + testsuite/tests/simplStg/should_run/T22042a.hs
- testsuite/tests/simplStg/should_run/all.T
Changes:
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -186,7 +186,7 @@ import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Zonk ( ZonkFlexi (DefaultFlexi) )
import GHC.Stg.Syntax
-import GHC.Stg.Pipeline ( stg2stg )
+import GHC.Stg.Pipeline ( stg2stg, StgCgInfos )
import GHC.Stg.InferTags
import GHC.Builtin.Utils
@@ -268,6 +268,8 @@ import Data.Functor
import Control.DeepSeq (force)
import Data.Bifunctor (first)
import Data.List.NonEmpty (NonEmpty ((:|)))
+import GHC.Stg.InferTags.TagSig (seqTagSig)
+import GHC.Types.Unique.FM
{- **********************************************************************
@@ -1719,11 +1721,16 @@ hscGenHardCode hsc_env cgguts location output_filename = do
this_mod location late_cc_binds data_tycons
----------------- Convert to STG ------------------
- (stg_binds, denv, (caf_ccs, caf_cc_stacks))
+ (stg_binds, denv, (caf_ccs, caf_cc_stacks), stg_cg_infos)
<- {-# SCC "CoreToStg" #-}
withTiming logger
(text "CoreToStg"<+>brackets (ppr this_mod))
- (\(a, b, (c,d)) -> a `seqList` b `seq` c `seqList` d `seqList` ())
+ (\(a, b, (c,d), tag_env) ->
+ a `seqList`
+ b `seq`
+ c `seqList`
+ d `seqList`
+ (seqEltsUFM (seqTagSig) tag_env))
(myCoreToStg logger dflags (hsc_IC hsc_env) False this_mod location prepd_binds)
let cost_centre_info =
@@ -1766,7 +1773,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
<- {-# SCC "codeOutput" #-}
codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) this_mod output_filename location
foreign_stubs foreign_files dependencies rawcmms1
- return (output_filename, stub_c_exists, foreign_fps, Just cg_infos)
+ return (output_filename, stub_c_exists, foreign_fps, Just cg_infos{ cgTagSigs = stg_cg_infos})
hscInteractive :: HscEnv
@@ -1801,7 +1808,9 @@ hscInteractive hsc_env cgguts location = do
(initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env))
this_mod location core_binds data_tycons
- (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)
+ -- The stg cg info only provides a runtime benfit, but is not requires so we just
+ -- omit it here
+ (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks, _ignore_stg_cg_infos)
<- {-# SCC "CoreToStg" #-}
myCoreToStg logger dflags (hsc_IC hsc_env) True this_mod location prepd_binds
----------------- Generate byte code ------------------
@@ -1906,13 +1915,13 @@ doCodeGen hsc_env this_mod denv data_tycons
hooks = hsc_hooks hsc_env
tmpfs = hsc_tmpfs hsc_env
platform = targetPlatform dflags
-
+ stg_ppr_opts = (initStgPprOpts dflags)
-- Do tag inference on optimized STG
(!stg_post_infer,export_tag_info) <-
- {-# SCC "StgTagFields" #-} inferTags dflags logger this_mod stg_binds_w_fvs
+ {-# SCC "StgTagFields" #-} inferTags stg_ppr_opts logger this_mod stg_binds_w_fvs
putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG
- (pprGenStgTopBindings (initStgPprOpts dflags) stg_post_infer)
+ (pprGenStgTopBindings stg_ppr_opts stg_post_infer)
let stg_to_cmm dflags mod = case stgToCmmHook hooks of
Nothing -> StgToCmm.codeGen logger tmpfs (initStgToCmmConfig dflags mod)
@@ -1960,7 +1969,8 @@ myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext
-> IO ( Id
, [CgStgTopBinding]
, InfoTableProvMap
- , CollectedCCs )
+ , CollectedCCs
+ , StgCgInfos )
myCoreToStgExpr logger dflags ictxt for_bytecode this_mod ml prepd_expr = do
{- Create a temporary binding (just because myCoreToStg needs a
binding for the stg2stg step) -}
@@ -1968,7 +1978,7 @@ myCoreToStgExpr logger dflags ictxt for_bytecode this_mod ml prepd_expr = do
(mkPseudoUniqueE 0)
Many
(exprType prepd_expr)
- (stg_binds, prov_map, collected_ccs) <-
+ (stg_binds, prov_map, collected_ccs, stg_cg_infos) <-
myCoreToStg logger
dflags
ictxt
@@ -1976,20 +1986,21 @@ myCoreToStgExpr logger dflags ictxt for_bytecode this_mod ml prepd_expr = do
this_mod
ml
[NonRec bco_tmp_id prepd_expr]
- return (bco_tmp_id, stg_binds, prov_map, collected_ccs)
+ return (bco_tmp_id, stg_binds, prov_map, collected_ccs, stg_cg_infos)
myCoreToStg :: Logger -> DynFlags -> InteractiveContext
-> Bool
-> Module -> ModLocation -> CoreProgram
-> IO ( [CgStgTopBinding] -- output program
, InfoTableProvMap
- , CollectedCCs ) -- CAF cost centre info (declared and used)
+ , CollectedCCs -- CAF cost centre info (declared and used)
+ , StgCgInfos )
myCoreToStg logger dflags ictxt for_bytecode this_mod ml prepd_binds = do
let (stg_binds, denv, cost_centre_info)
= {-# SCC "Core2Stg" #-}
coreToStg dflags this_mod ml prepd_binds
- stg_binds_with_fvs
+ (stg_binds_with_fvs,stg_cg_info)
<- {-# SCC "Stg2Stg" #-}
stg2stg logger (interactiveInScope ictxt) (initStgPipelineOpts dflags for_bytecode)
this_mod stg_binds
@@ -1997,7 +2008,7 @@ myCoreToStg logger dflags ictxt for_bytecode this_mod ml prepd_binds = do
putDumpFileMaybe logger Opt_D_dump_stg_cg "CodeGenInput STG:" FormatSTG
(pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_with_fvs)
- return (stg_binds_with_fvs, denv, cost_centre_info)
+ return (stg_binds_with_fvs, denv, cost_centre_info, stg_cg_info)
{- **********************************************************************
%* *
@@ -2148,7 +2159,7 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
(initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env))
this_mod iNTERACTIVELoc core_binds data_tycons
- (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)
+ (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks, _stg_cg_info)
<- {-# SCC "CoreToStg" #-}
liftIO $ myCoreToStg (hsc_logger hsc_env)
(hsc_dflags hsc_env)
@@ -2385,7 +2396,7 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr
ml_hie_file = panic "hscCompileCoreExpr':ml_hie_file" }
; let ictxt = hsc_IC hsc_env
- ; (binding_id, stg_expr, _, _) <-
+ ; (binding_id, stg_expr, _, _, _stg_cg_info) <-
myCoreToStgExpr logger
dflags
ictxt
=====================================
compiler/GHC/Stg/InferTags.hs
=====================================
@@ -27,7 +27,6 @@ import GHC.Stg.InferTags.Types
import GHC.Stg.InferTags.Rewrite (rewriteTopBinds)
import Data.Maybe
import GHC.Types.Name.Env (mkNameEnv, NameEnv)
-import GHC.Driver.Config.Stg.Ppr
import GHC.Driver.Session
import GHC.Utils.Logger
import qualified GHC.Unit.Types
@@ -221,13 +220,13 @@ the output of itself.
-- -- Note we produce a 'Stream' of CmmGroups, so that the
-- -- backend can be run incrementally. Otherwise it generates all
-- -- the C-- up front, which has a significant space cost.
-inferTags :: DynFlags -> Logger -> (GHC.Unit.Types.Module) -> [CgStgTopBinding] -> IO ([TgStgTopBinding], NameEnv TagSig)
-inferTags dflags logger this_mod stg_binds = do
+inferTags :: StgPprOpts -> Logger -> (GHC.Unit.Types.Module) -> [CgStgTopBinding] -> IO ([TgStgTopBinding], NameEnv TagSig)
+inferTags ppr_opts logger this_mod stg_binds = do
-- Annotate binders with tag information.
let (!stg_binds_w_tags) = {-# SCC "StgTagFields" #-}
inferTagsAnal stg_binds
- putDumpFileMaybe logger Opt_D_dump_stg_tags "CodeGenAnal STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_tags)
+ putDumpFileMaybe logger Opt_D_dump_stg_tags "CodeGenAnal STG:" FormatSTG (pprGenStgTopBindings ppr_opts stg_binds_w_tags)
let export_tag_info = collectExportInfo stg_binds_w_tags
=====================================
compiler/GHC/Stg/InferTags/TagSig.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-}
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
@@ -16,6 +17,7 @@ import GHC.Types.Var
import GHC.Utils.Outputable
import GHC.Utils.Binary
import GHC.Utils.Panic.Plain
+import Data.Coerce
data TagInfo
= TagDunno -- We don't know anything about the tag.
@@ -64,3 +66,12 @@ isTaggedSig :: TagSig -> Bool
isTaggedSig (TagSig TagProper) = True
isTaggedSig (TagSig TagTagged) = True
isTaggedSig _ = False
+
+seqTagSig :: TagSig -> ()
+seqTagSig = coerce seqTagInfo
+
+seqTagInfo :: TagInfo -> ()
+seqTagInfo TagTagged = ()
+seqTagInfo TagDunno = ()
+seqTagInfo TagProper = ()
+seqTagInfo (TagTuple tis) = foldl' (\_unit sig -> seqTagSig (coerce sig)) () tis
\ No newline at end of file
=====================================
compiler/GHC/Stg/Pipeline.hs
=====================================
@@ -13,6 +13,7 @@ module GHC.Stg.Pipeline
( StgPipelineOpts (..)
, StgToDo (..)
, stg2stg
+ , StgCgInfos
) where
import GHC.Prelude
@@ -39,6 +40,9 @@ import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import GHC.Settings (Platform)
+import GHC.Stg.InferTags (inferTags)
+import GHC.Types.Name.Env (NameEnv)
+import GHC.Stg.InferTags.TagSig (TagSig)
data StgPipelineOpts = StgPipelineOpts
{ stgPipeline_phases :: ![StgToDo]
@@ -52,6 +56,10 @@ data StgPipelineOpts = StgPipelineOpts
newtype StgM a = StgM { _unStgM :: ReaderT Char IO a }
deriving (Functor, Applicative, Monad, MonadIO)
+-- | Information to be exposed in interface files which is produced
+-- by the stg2stg pass.
+type StgCgInfos = NameEnv TagSig
+
instance MonadUnique StgM where
getUniqueSupplyM = StgM $ do { mask <- ask
; liftIO $! mkSplitUniqSupply mask}
@@ -66,7 +74,7 @@ stg2stg :: Logger
-> StgPipelineOpts
-> Module -- ^ module being compiled
-> [StgTopBinding] -- ^ input program
- -> IO [CgStgTopBinding] -- output program
+ -> IO ([CgStgTopBinding], StgCgInfos) -- output program
stg2stg logger extra_vars opts this_mod binds
= do { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds
; showPass logger "Stg2Stg"
@@ -85,7 +93,7 @@ stg2stg logger extra_vars opts this_mod binds
-- This pass will also augment each closure with non-global free variables
-- annotations (which is used by code generator to compute offsets into closures)
; let binds_sorted_with_fvs = depSortWithAnnotStgPgm this_mod binds'
- ; return binds_sorted_with_fvs
+ ; inferTags (stgPipeline_pprOpts opts) logger this_mod binds_sorted_with_fvs
}
where
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -1670,17 +1670,20 @@ pushAtom d p (StgVarArg var)
Just ptr -> pushAtom d p $ StgLitArg $ mkLitWord platform $
fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr
Nothing
+ -- PUSH_G doesn't tag constructors. So we use PACK here
+ -- if we are dealing with nullary constructor.
| Just con <- isDataConWorkId_maybe var
-> do
- let sz = idSizeCon platform var
massert (sz == wordSize platform)
massert (isNullaryRepDataCon con)
return (unitOL (PACK con 0), sz)
| otherwise
-> do
- let sz = idSizeCon platform var
+ let
massert (sz == wordSize platform)
return (unitOL (PUSH_G (getName var)), sz)
+ where
+ !sz = idSizeCon platform var
pushAtom _ _ (StgLitArg lit) = pushLiteral True lit
=====================================
compiler/GHC/StgToCmm/Types.hs
=====================================
@@ -94,6 +94,7 @@ data CgInfos = CgInfos
, cgIPEStub :: !CStub
-- ^ The C stub which is used for IPE information
, cgTagSigs :: !(NameEnv TagSig)
+ -- ^ Tag sigs. These are produced by stg2stg hence why they end up in CgInfos.
}
--------------------------------------------------------------------------------
=====================================
testsuite/tests/simplStg/should_run/Makefile
=====================================
@@ -1,3 +1,12 @@
TOP=../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
+
+T22042: T22042_clean
+ "$(TEST_HC)" $(TEST_HC_OPTS) -O T22042a.hs -dynamic -dtag-inference-checks -c
+ "$(TEST_HC)" $(TEST_HC_OPTS) -e ":main" T22042.hs T22042a.o
+
+T22042_clean:
+ rm -f T22042a.o T22042a.hi
+
+.PHONY: T22042 T22042_clean
=====================================
testsuite/tests/simplStg/should_run/T22042.hs
=====================================
@@ -0,0 +1,6 @@
+module Main where
+
+import T22042a
+
+main = do
+ putStrLn (foo $ SC A B C)
\ No newline at end of file
=====================================
testsuite/tests/simplStg/should_run/T22042.stdout
=====================================
@@ -0,0 +1 @@
+ABC
=====================================
testsuite/tests/simplStg/should_run/T22042a.hs
=====================================
@@ -0,0 +1,10 @@
+module T22042a where
+
+data A = A | AA deriving Show
+data B = B | AB deriving Show
+data C = C | AC deriving Show
+
+data SC = SC !A !B !C
+
+foo :: SC -> String
+foo (SC a b c) = show a ++ show b ++ show c
\ No newline at end of file
=====================================
testsuite/tests/simplStg/should_run/all.T
=====================================
@@ -19,3 +19,4 @@ test('T13536a',
[''])
test('inferTags001', normal, multimod_compile_and_run, ['inferTags001', 'inferTags001_a'])
+test('T22042', [extra_files(['T22042a.hs']),only_ways('normal')], makefile_test, ['T22042'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bd6c05478b0eb1d1a974e5bc00bbcd233ee6f58e...08648849359218f1d6943b920b1f27fa690d4de9
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bd6c05478b0eb1d1a974e5bc00bbcd233ee6f58e...08648849359218f1d6943b920b1f27fa690d4de9
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/20220816/dd87a37a/attachment-0001.html>
More information about the ghc-commits
mailing list