[Git][ghc/ghc][wip/osa1/lfinfo] Cross-module LambdaFormInfo passing
Ömer Sinan Ağacan
gitlab at gitlab.haskell.org
Thu Mar 19 08:06:40 UTC 2020
Ömer Sinan Ağacan pushed to branch wip/osa1/lfinfo at Glasgow Haskell Compiler / GHC
Commits:
481dfb8f by Ömer Sinan Ağacan at 2020-03-19T08:06:11Z
Cross-module LambdaFormInfo passing
- Store LambdaFormInfos of exported Ids in interface files
- Use them in importing modules
- - - - -
29 changed files:
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Driver/Hooks.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Runtime/Heap/Layout.hs
- compiler/GHC/StgToCmm.hs
- compiler/GHC/StgToCmm/Closure.hs
- compiler/GHC/StgToCmm/Env.hs
- + compiler/GHC/StgToCmm/Types.hs
- compiler/basicTypes/Id.hs
- compiler/basicTypes/IdInfo.hs
- compiler/ghc.cabal.in
- compiler/main/UpdateCafInfos.hs
- testsuite/tests/codeGen/should_compile/Makefile
- + testsuite/tests/codeGen/should_compile/cg009/A.hs
- + testsuite/tests/codeGen/should_compile/cg009/Main.hs
- + testsuite/tests/codeGen/should_compile/cg009/Makefile
- + testsuite/tests/codeGen/should_compile/cg009/all.T
- + testsuite/tests/codeGen/should_compile/cg010/A.hs
- + testsuite/tests/codeGen/should_compile/cg010/Main.hs
- + testsuite/tests/codeGen/should_compile/cg010/Makefile
- + testsuite/tests/codeGen/should_compile/cg010/all.T
- + testsuite/tests/codeGen/should_compile/cg010/cg010.stdout
- testsuite/tests/simplCore/should_compile/Makefile
- testsuite/tests/simplCore/should_compile/T4201.stdout
Changes:
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -41,6 +41,8 @@ module GHC.CoreToIface
, toIfaceCon
, toIfaceApp
, toIfaceVar
+ -- * Other stuff
+ , toIfaceLFInfo
) where
#include "HsVersions.h"
@@ -49,6 +51,7 @@ import GhcPrelude
import GHC.Iface.Syntax
import GHC.Core.DataCon
+import GHC.StgToCmm.Types
import Id
import IdInfo
import GHC.Core
@@ -74,6 +77,8 @@ import Demand ( isTopSig )
import Cpr ( topCprSig )
import Data.Maybe ( catMaybes )
+import Data.Word
+import Data.Bits
{- Note [Avoiding space leaks in toIface*]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -534,7 +539,7 @@ toIfaceExpr (Var v) = toIfaceVar v
toIfaceExpr (Lit l) = IfaceLit l
toIfaceExpr (Type ty) = IfaceType (toIfaceType ty)
toIfaceExpr (Coercion co) = IfaceCo (toIfaceCoercion co)
-toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x, toIfaceOneShot x) (toIfaceExpr b)
+toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x, toIdIfaceOneShot x) (toIfaceExpr b)
toIfaceExpr (App f a) = toIfaceApp f [a]
toIfaceExpr (Case s x ty as)
| null as = IfaceECase (toIfaceExpr s) (toIfaceType ty)
@@ -545,12 +550,16 @@ toIfaceExpr (Tick t e)
| Just t' <- toIfaceTickish t = IfaceTick t' (toIfaceExpr e)
| otherwise = toIfaceExpr e
-toIfaceOneShot :: Id -> IfaceOneShot
-toIfaceOneShot id | isId id
- , OneShotLam <- oneShotInfo (idInfo id)
- = IfaceOneShot
- | otherwise
- = IfaceNoOneShot
+toIdIfaceOneShot :: Id -> IfaceOneShot
+toIdIfaceOneShot id
+ | isId id
+ = toIfaceOneShot (oneShotInfo (idInfo id))
+ | otherwise
+ = IfaceNoOneShot
+
+toIfaceOneShot :: OneShotInfo -> IfaceOneShot
+toIfaceOneShot OneShotLam = IfaceOneShot
+toIfaceOneShot NoOneShotInfo = IfaceNoOneShot
---------------------
toIfaceTickish :: Tickish Id -> Maybe IfaceTickish
@@ -616,6 +625,41 @@ toIfaceVar v
where name = idName v
+---------------------
+toIfaceLFInfo :: LambdaFormInfo -> IfaceLFInfo
+toIfaceLFInfo (LFReEntrant TopLevel oneshot rep fvs_flag _argdesc) =
+ IfLFReEntrant (toIfaceOneShot oneshot) rep fvs_flag
+toIfaceLFInfo (LFThunk TopLevel hasfv updateable sfi m_function) =
+ -- Assert that arity fits in 14 bits
+ ASSERT(fromEnum hasfv <= 1 && fromEnum updateable <= 1 && fromEnum m_function <= 1)
+ IfLFThunk hasfv updateable (toIfaceStandardFormInfo sfi) m_function
+toIfaceLFInfo LFUnlifted = IfLFUnlifted
+toIfaceLFInfo (LFCon con) = IfLFCon (dataConName con)
+-- All other cases are not possible at the top level.
+toIfaceLFInfo lf = pprPanic "Invalid IfaceLFInfo conversion:"
+ (ppr lf <+> text "should not be exported")
+
+toIfaceStandardFormInfo :: StandardFormInfo -> IfaceStandardFormInfo
+toIfaceStandardFormInfo NonStandardThunk = IfStandardFormInfo 1
+toIfaceStandardFormInfo sf =
+ IfStandardFormInfo $!
+ tag sf .|. encodeField (field sf)
+ where
+ tag SelectorThunk{} = 0
+ tag ApThunk{} = 2 -- == setBit 0 1
+ tag _ = panic "Impossible"
+
+ field (SelectorThunk n) = n
+ field (ApThunk n) = n
+ field _ = panic "Impossible"
+
+ encodeField n =
+ let wn = fromIntegral n :: Word
+ shifted = wn `unsafeShiftL` 2
+ in ASSERT(shifted > 0 && shifted < fromIntegral (maxBound :: Word16))
+ (fromIntegral shifted :: Word16)
+
+
{- Note [Inlining and hs-boot files]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this example (#10083, #12789):
=====================================
compiler/GHC/Driver/Hooks.hs
=====================================
@@ -55,6 +55,7 @@ import GHC.Stg.Syntax
import Stream
import GHC.Cmm
import GHC.Hs.Extension
+import GHC.StgToCmm.Types (ModuleLFInfos)
import Data.Maybe
@@ -109,7 +110,7 @@ data Hooks = Hooks
-> IO (Maybe HValue))
, createIservProcessHook :: Maybe (CreateProcess -> IO ProcessHandle)
, stgToCmmHook :: Maybe (DynFlags -> Module -> [TyCon] -> CollectedCCs
- -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ())
+ -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ModuleLFInfos)
, cmmToRawCmmHook :: forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a
-> IO (Stream IO RawCmmGroup a))
}
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -162,6 +162,7 @@ import Bag
import Exception
import qualified Stream
import Stream (Stream)
+import GHC.StgToCmm.Types (ModuleLFInfos)
import Util
@@ -176,6 +177,7 @@ import qualified Data.Set as S
import Data.Set (Set)
import Data.Functor
import Control.DeepSeq (force)
+import Data.Bifunctor (first)
import GHC.Iface.Ext.Ast ( mkHieFile )
import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module )
@@ -1392,7 +1394,7 @@ hscWriteIface dflags iface no_change mod_location = do
-- | Compile to hard-code.
hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath
- -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], NameSet)
+ -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], NameSet, ModuleLFInfos)
-- ^ @Just f@ <=> _stub.c is f
hscGenHardCode hsc_env cgguts location output_filename = do
let CgGuts{ -- This is the last use of the ModGuts in a compilation.
@@ -1451,11 +1453,11 @@ hscGenHardCode hsc_env cgguts location output_filename = do
return a
rawcmms1 = Stream.mapM dump rawcmms0
- (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, caf_infos)
+ (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, (caf_infos, lf_infos))
<- {-# SCC "codeOutput" #-}
codeOutput dflags this_mod output_filename location
foreign_stubs foreign_files dependencies rawcmms1
- return (output_filename, stub_c_exists, foreign_fps, caf_infos)
+ return (output_filename, stub_c_exists, foreign_fps, caf_infos, lf_infos)
hscInteractive :: HscEnv
@@ -1549,7 +1551,7 @@ doCodeGen :: HscEnv -> Module -> [TyCon]
-> CollectedCCs
-> [StgTopBinding]
-> HpcInfo
- -> IO (Stream IO CmmGroupSRTs NameSet)
+ -> IO (Stream IO CmmGroupSRTs (NameSet, ModuleLFInfos))
-- 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.
@@ -1561,7 +1563,7 @@ doCodeGen hsc_env this_mod data_tycons
dumpIfSet_dyn dflags Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings stg_binds_w_fvs)
- let cmm_stream :: Stream IO CmmGroup ()
+ let cmm_stream :: Stream IO CmmGroup ModuleLFInfos
-- See Note [Forcing of stg_binds]
cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-}
lookupHook stgToCmmHook StgToCmm.codeGen dflags dflags this_mod data_tycons
@@ -1580,10 +1582,11 @@ doCodeGen hsc_env this_mod data_tycons
ppr_stream1 = Stream.mapM dump1 cmm_stream
+ pipeline_stream :: Stream IO CmmGroupSRTs (NameSet, ModuleLFInfos)
pipeline_stream =
{-# SCC "cmmPipeline" #-}
- Stream.mapAccumL (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1
- <&> (srtMapNonCAFs . moduleSRTMap)
+ Stream.mapAccumL_ (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1
+ <&> (first (srtMapNonCAFs . moduleSRTMap))
dump2 a = do
unless (null a) $
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -1192,12 +1192,12 @@ runPhase (HscOut src_flavour mod_name result) _ dflags = do
PipeState{hsc_env=hsc_env'} <- getPipeState
- (outputFilename, mStub, foreign_files, caf_infos) <- liftIO $
+ (outputFilename, mStub, foreign_files, caf_infos, lf_infos) <- liftIO $
hscGenHardCode hsc_env' cgguts mod_location output_fn
- final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface (Just caf_infos))
+ final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface (Just (caf_infos, lf_infos)))
let final_mod_details = {-# SCC updateModDetailsCafInfos #-}
- updateModDetailsCafInfos iface_dflags caf_infos mod_details
+ updateModDetailsCafInfos iface_dflags caf_infos lf_infos mod_details
setIface final_iface final_mod_details
-- See Note [Writing interface files]
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -38,6 +38,7 @@ import GHC.Core.Coercion.Axiom
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.Type
+import GHC.StgToCmm.Types (ModuleLFInfos)
import TcType
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv
@@ -100,13 +101,13 @@ mkPartialIface hsc_env mod_details
-- | Fully instantiate a interface
-- Adds fingerprints and potentially code generator produced information.
-mkFullIface :: HscEnv -> PartialModIface -> Maybe NameSet -> IO ModIface
-mkFullIface hsc_env partial_iface mb_non_cafs = do
+mkFullIface :: HscEnv -> PartialModIface -> Maybe (NameSet, ModuleLFInfos) -> IO ModIface
+mkFullIface hsc_env partial_iface mb_id_infos = do
let decls
| gopt Opt_OmitInterfacePragmas (hsc_dflags hsc_env)
= mi_decls partial_iface
| otherwise
- = updateDeclCafInfos (mi_decls partial_iface) mb_non_cafs
+ = updateDecl (mi_decls partial_iface) mb_id_infos
full_iface <-
{-# SCC "addFingerprints" #-}
@@ -117,15 +118,23 @@ mkFullIface hsc_env partial_iface mb_non_cafs = do
return full_iface
-updateDeclCafInfos :: [IfaceDecl] -> Maybe NameSet -> [IfaceDecl]
-updateDeclCafInfos decls Nothing = decls
-updateDeclCafInfos decls (Just non_cafs) = map update_decl decls
+updateDecl :: [IfaceDecl] -> Maybe (NameSet, ModuleLFInfos) -> [IfaceDecl]
+updateDecl decls Nothing = decls
+updateDecl decls (Just (non_cafs, lf_infos)) = map update_decl decls
where
+ update_decl (IfaceId nm ty details infos)
+ | let not_caffy = elemNameSet nm non_cafs
+ , let mb_lf_info = lookupNameEnv lf_infos nm
+ , WARN( isNothing mb_lf_info, text "Name without LFInfo:" <+> ppr nm ) True
+ -- Only allocate a new IfaceId if we're going to update the infos
+ , isJust mb_lf_info || not_caffy
+ = IfaceId nm ty details $
+ (if not_caffy then (HsNoCafRefs :) else id)
+ (case mb_lf_info of
+ Nothing -> infos
+ Just lf_info -> HsLFInfo (toIfaceLFInfo lf_info) : infos)
+
update_decl decl
- | IfaceId nm ty details infos <- decl
- , elemNameSet nm non_cafs
- = IfaceId nm ty details (HsNoCafRefs : infos)
- | otherwise
= decl
-- | Make an interface from the results of typechecking only. Useful
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -22,6 +22,8 @@ module GHC.Iface.Syntax (
IfaceAxBranch(..),
IfaceTyConParent(..),
IfaceCompleteMatch(..),
+ IfaceLFInfo(..),
+ IfaceStandardFormInfo(..),
-- * Binding names
IfaceTopBndr,
@@ -30,6 +32,7 @@ module GHC.Iface.Syntax (
-- Misc
ifaceDeclImplicitBndrs, visibleIfConDecls,
ifaceDeclFingerprints,
+ tcStandardFormInfo,
-- Free Names
freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,
@@ -72,10 +75,13 @@ import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..))
import Lexeme (isLexSym)
import TysWiredIn ( constraintKindTyConName )
import Util (seqList)
+import GHC.StgToCmm.Types
import Control.Monad
import System.IO.Unsafe
import Control.DeepSeq
+import Data.Word
+import Data.Bits
infixl 3 &&&
@@ -114,7 +120,8 @@ data IfaceDecl
= IfaceId { ifName :: IfaceTopBndr,
ifType :: IfaceType,
ifIdDetails :: IfaceIdDetails,
- ifIdInfo :: IfaceIdInfo }
+ ifIdInfo :: IfaceIdInfo
+ }
| IfaceData { ifName :: IfaceTopBndr, -- Type constructor
ifBinders :: [IfaceTyConBinder],
@@ -348,6 +355,7 @@ data IfaceInfoItem
IfaceUnfolding -- See Note [Expose recursive functions]
| HsNoCafRefs
| HsLevity -- Present <=> never levity polymorphic
+ | HsLFInfo IfaceLFInfo
-- NB: Specialisations and rules come in separately and are
-- only later attached to the Id. Partial reason: some are orphans.
@@ -379,6 +387,71 @@ data IfaceIdDetails
| IfRecSelId (Either IfaceTyCon IfaceDecl) Bool
| IfDFunId
+-- Lambda form info
+data IfaceLFInfo
+ = IfLFReEntrant !IfaceOneShot !RepArity !Bool
+ | IfLFThunk !Bool !Bool !IfaceStandardFormInfo !Bool
+ | IfLFCon -- A saturated constructor application
+ !Name -- The constructor Name
+ | IfLFUnknown !Bool
+ | IfLFUnlifted
+
+tcStandardFormInfo :: IfaceStandardFormInfo -> StandardFormInfo
+tcStandardFormInfo (IfStandardFormInfo w)
+ | testBit w 0 = NonStandardThunk
+ | otherwise = con field
+ where
+ field = fromIntegral (w `unsafeShiftR` 2)
+ con
+ | testBit w 1 = ApThunk
+ | otherwise = SelectorThunk
+
+instance Outputable IfaceLFInfo where
+ ppr (IfLFReEntrant oneshot rep fvs_flag) =
+ text "LFReEntrant" <+> ppr (oneshot, rep, fvs_flag)
+ ppr (IfLFThunk fvs_flag upd_flag sfi fun_flag) =
+ text "LFThunk" <+> ppr (fvs_flag, upd_flag, fun_flag) <+> ppr (tcStandardFormInfo sfi)
+ ppr (IfLFCon con) = text "LFCon" <> brackets (ppr con)
+ ppr IfLFUnlifted = text "LFUnlifted"
+ ppr (IfLFUnknown fun_flag) = text "LFUnknown" <+> ppr fun_flag
+
+newtype IfaceStandardFormInfo = IfStandardFormInfo Word16
+
+instance Binary IfaceStandardFormInfo where
+ put_ bh (IfStandardFormInfo w) = put_ bh (w :: Word16)
+ get bh = IfStandardFormInfo <$> (get bh :: IO Word16)
+
+instance Binary IfaceLFInfo where
+ -- TODO: We could pack the bytes somewhat
+ put_ bh (IfLFReEntrant oneshot rep fvs_flag) = do
+ putByte bh 0
+ put_ bh oneshot
+ put_ bh rep
+ put_ bh fvs_flag
+ put_ bh (IfLFThunk top_lvl no_fvs std_form maybe_fun) = do
+ putByte bh 1
+ put_ bh top_lvl
+ put_ bh no_fvs
+ put_ bh std_form
+ put_ bh maybe_fun
+ put_ bh (IfLFCon con_name) = do
+ putByte bh 2
+ put_ bh con_name
+ put_ bh (IfLFUnknown fun_flag) = do
+ putByte bh 3
+ put_ bh fun_flag
+ put_ bh IfLFUnlifted =
+ putByte bh 4
+ get bh = do
+ tag <- getByte bh
+ case tag of
+ 0 -> IfLFReEntrant <$> get bh <*> get bh <*> get bh
+ 1 -> IfLFThunk <$> get bh <*> get bh <*> get bh <*> get bh
+ 2 -> IfLFCon <$> get bh
+ 3 -> IfLFUnknown <$> get bh
+ 4 -> pure IfLFUnlifted
+ _ -> panic "Invalid byte"
+
{-
Note [Versioning of instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1393,6 +1466,7 @@ instance Outputable IfaceInfoItem where
ppr (HsCpr cpr) = text "CPR:" <+> ppr cpr
ppr HsNoCafRefs = text "HasNoCafRefs"
ppr HsLevity = text "Never levity-polymorphic"
+ ppr (HsLFInfo lf_info) = text "LambdaFormInfo:" <+> ppr lf_info
instance Outputable IfaceJoinInfo where
ppr IfaceNotJoinPoint = empty
@@ -1853,7 +1927,7 @@ instance Binary IfaceDecl where
get bh = do
h <- getByte bh
case h of
- 0 -> do name <- get bh
+ 0 -> do name <- get bh
~(ty, details, idinfo) <- lazyGet bh
-- See Note [Lazy deserialization of IfaceId]
return (IfaceId name ty details idinfo)
@@ -2153,6 +2227,8 @@ instance Binary IfaceInfoItem where
put_ bh HsNoCafRefs = putByte bh 4
put_ bh HsLevity = putByte bh 5
put_ bh (HsCpr cpr) = putByte bh 6 >> put_ bh cpr
+ put_ bh (HsLFInfo lf_info) = putByte bh 7 >> put_ bh lf_info
+
get bh = do
h <- getByte bh
case h of
@@ -2164,7 +2240,8 @@ instance Binary IfaceInfoItem where
3 -> liftM HsInline $ get bh
4 -> return HsNoCafRefs
5 -> return HsLevity
- _ -> HsCpr <$> get bh
+ 6 -> HsCpr <$> get bh
+ _ -> HsLFInfo <$> get bh
instance Binary IfaceUnfolding where
put_ bh (IfCoreUnfold s e) = do
@@ -2495,6 +2572,7 @@ instance NFData IfaceInfoItem where
HsNoCafRefs -> ()
HsLevity -> ()
HsCpr cpr -> cpr `seq` ()
+ HsLFInfo lf_info -> lf_info `seq` () -- TODO: seq further?
instance NFData IfaceUnfolding where
rnf = \case
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -122,6 +122,9 @@ data IfaceOneShot -- See Note [Preserve OneShotInfo] in CoreTicy
= IfaceNoOneShot -- and Note [The oneShot function] in MkId
| IfaceOneShot
+instance Outputable IfaceOneShot where
+ ppr IfaceNoOneShot = text "NoOneShotInfo"
+ ppr IfaceOneShot = text "OneShot"
{-
%************************************************************************
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -19,7 +19,8 @@ module GHC.IfaceToCore (
tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
tcIfaceAnnotations, tcIfaceCompleteSigs,
tcIfaceExpr, -- Desired by HERMIT (#7683)
- tcIfaceGlobal
+ tcIfaceGlobal,
+ tcIfaceOneShot
) where
#include "HsVersions.h"
@@ -30,6 +31,9 @@ import TcTypeNats(typeNatCoAxiomRules)
import GHC.Iface.Syntax
import GHC.Iface.Load
import GHC.Iface.Env
+import GHC.StgToCmm.Types
+import GHC.StgToCmm.Closure
+import GHC.Types.RepType
import BuildTyCl
import TcRnMonad
import TcType
@@ -641,7 +645,7 @@ tc_iface_decl _ ignore_prags (IfaceId {ifName = name, ifType = iface_type,
= do { ty <- tcIfaceType iface_type
; details <- tcIdDetails ty details
; info <- tcIdInfo ignore_prags TopLevel name ty info
- ; return (AnId (mkGlobalId details name ty info)) }
+ ; return (AnId (addIdLFInfo (mkGlobalId details name ty info))) }
tc_iface_decl _ _ (IfaceData {ifName = tc_name,
ifCType = cType,
@@ -1340,7 +1344,8 @@ tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body)
; ty' <- tcIfaceType ty
; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
NotTopLevel name ty' info
- ; let id = mkLocalIdWithInfo name ty' id_info
+ ; let id = addIdLFInfo $
+ mkLocalIdWithInfo name ty' id_info
`asJoinId_maybe` tcJoinInfo ji
; rhs' <- tcIfaceExpr rhs
; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
@@ -1361,7 +1366,7 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
= do { rhs' <- tcIfaceExpr rhs
; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
NotTopLevel (idName id) (idType id) info
- ; return (setIdInfo id id_info, rhs') }
+ ; return (addIdLFInfo (setIdInfo id id_info), rhs') }
tcIfaceExpr (IfaceTick tickish expr) = do
expr' <- tcIfaceExpr expr
@@ -1465,8 +1470,7 @@ tcIdInfo ignore_prags toplvl name ty info = do
let init_info | if_boot lcl_env = vanillaIdInfo `setUnfoldingInfo` BootUnfolding
| otherwise = vanillaIdInfo
- let needed = needed_prags info
- foldlM tcPrag init_info needed
+ foldlM tcPrag init_info (needed_prags info)
where
needed_prags :: [IfaceInfoItem] -> [IfaceInfoItem]
needed_prags items
@@ -1486,6 +1490,9 @@ tcIdInfo ignore_prags toplvl name ty info = do
tcPrag info (HsCpr cpr) = return (info `setCprInfo` cpr)
tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag)
tcPrag info HsLevity = return (info `setNeverLevPoly` ty)
+ tcPrag info (HsLFInfo lf_info) = do
+ lf_info <- tcLFInfo lf_info
+ return (info `setLFInfo` lf_info)
-- The next two are lazy, so they don't transitively suck stuff in
tcPrag info (HsUnfold lb if_unf)
@@ -1494,10 +1501,54 @@ tcIdInfo ignore_prags toplvl name ty info = do
| otherwise = info
; return (info1 `setUnfoldingInfo` unf) }
+addIdLFInfo :: Id -> Id
+addIdLFInfo id = case idLFInfo_maybe id of
+ Nothing -> setIdLFInfo id (mkLFImported (idDetails id) (idInfo id) (idType id))
+ Just _ -> id
+
+-- Make a LambdaFormInfo for the Ids without a LFInfo in the iface file
+mkLFImported :: IdDetails -> IdInfo -> Type -> LambdaFormInfo
+mkLFImported details info ty
+ | DataConWorkId con <- details
+ , isNullaryRepDataCon con
+ = LFCon con -- An imported nullary constructor
+ -- We assume that the constructor is evaluated so that
+ -- the id really does point directly to the constructor
+
+ | arity > 0
+ = LFReEntrant TopLevel noOneShotInfo arity True ArgUnknown
+
+ | isUnliftedType ty
+ = LFUnlifted
+
+ | mightBeAFunction ty
+ = LFUnknown True
+
+ | otherwise
+ = LFUnknown False
+ where
+ arity = countFunRepArgs (arityInfo info) ty
+
tcJoinInfo :: IfaceJoinInfo -> Maybe JoinArity
tcJoinInfo (IfaceJoinPoint ar) = Just ar
tcJoinInfo IfaceNotJoinPoint = Nothing
+tcLFInfo :: IfaceLFInfo -> IfL LambdaFormInfo
+tcLFInfo (IfLFReEntrant oneshot rep fvs_flag) =
+ return (LFReEntrant TopLevel (tcIfaceOneShot oneshot) rep fvs_flag ArgUnknown)
+
+tcLFInfo (IfLFThunk fvs_flag upd_flag sfi fun_flag ) = do
+ return (LFThunk TopLevel fvs_flag upd_flag (tcStandardFormInfo sfi) fun_flag)
+
+tcLFInfo IfLFUnlifted = return LFUnlifted
+
+tcLFInfo (IfLFCon con_name) =
+ forkM (text "Loading LFCon constructor:" <+> ppr con_name) $ do
+ LFCon <$!> {-# SCC tcIfaceDataCon #-} tcIfaceDataCon con_name
+
+tcLFInfo (IfLFUnknown fun_flag) =
+ return (LFUnknown fun_flag)
+
tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)
= do { dflags <- getDynFlags
@@ -1586,6 +1637,10 @@ tcPragExpr is_compulsory toplvl name expr
-- It's OK to use nonDetEltsUFM here because we immediately forget
-- the ordering by creating a set
+tcIfaceOneShot :: IfaceOneShot -> OneShotInfo
+tcIfaceOneShot IfaceNoOneShot = NoOneShotInfo
+tcIfaceOneShot IfaceOneShot = OneShotLam
+
{-
************************************************************************
* *
=====================================
compiler/GHC/Runtime/Heap/Layout.hs
=====================================
@@ -51,6 +51,7 @@ import GHC.Driver.Session
import Outputable
import GHC.Platform
import FastString
+import GHC.StgToCmm.Types
import Data.Word
import Data.Bits
@@ -64,9 +65,6 @@ import Data.ByteString (ByteString)
************************************************************************
-}
--- | Word offset, or word count
-type WordOff = Int
-
-- | Byte offset, or byte count
type ByteOff = Int
@@ -196,29 +194,6 @@ type ConstrDescription = ByteString -- result of dataConIdentity
type FunArity = Int
type SelectorOffset = Int
--------------------------
--- We represent liveness bitmaps as a Bitmap (whose internal
--- representation really is a bitmap). These are pinned onto case return
--- vectors to indicate the state of the stack for the garbage collector.
---
--- In the compiled program, liveness bitmaps that fit inside a single
--- word (StgWord) are stored as a single word, while larger bitmaps are
--- stored as a pointer to an array of words.
-
-type Liveness = [Bool] -- One Bool per word; True <=> non-ptr or dead
- -- False <=> ptr
-
--------------------------
--- An ArgDescr describes the argument pattern of a function
-
-data ArgDescr
- = ArgSpec -- Fits one of the standard patterns
- !Int -- RTS type identifier ARG_P, ARG_N, ...
-
- | ArgGen -- General case
- Liveness -- Details about the arguments
-
-
-----------------------------------------------------------------------------
-- Construction
@@ -540,10 +515,6 @@ instance Outputable SMRep where
ppr (RTSRep ty rep) = text "tag:" <> ppr ty <+> ppr rep
-instance Outputable ArgDescr where
- ppr (ArgSpec n) = text "ArgSpec" <+> ppr n
- ppr (ArgGen ls) = text "ArgGen" <+> ppr ls
-
pprTypeInfo :: ClosureTypeInfo -> SDoc
pprTypeInfo (Constr tag descr)
= text "Con" <+>
=====================================
compiler/GHC/StgToCmm.hs
=====================================
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE BangPatterns #-}
-----------------------------------------------------------------------------
--
@@ -25,6 +26,7 @@ import GHC.StgToCmm.Utils
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Hpc
import GHC.StgToCmm.Ticky
+import GHC.StgToCmm.Types (ModuleLFInfos)
import GHC.Cmm
import GHC.Cmm.CLabel
@@ -45,6 +47,8 @@ import Outputable
import Stream
import BasicTypes
import VarSet ( isEmptyDVarSet )
+import UniqFM
+import NameEnv
import OrdList
import GHC.Cmm.Graph
@@ -52,6 +56,7 @@ import GHC.Cmm.Graph
import Data.IORef
import Control.Monad (when,void)
import Util
+import Data.Maybe
codeGen :: DynFlags
-> Module
@@ -59,7 +64,8 @@ codeGen :: DynFlags
-> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
-> [CgStgTopBinding] -- Bindings to convert
-> HpcInfo
- -> Stream IO CmmGroup () -- Output as a stream, so codegen can
+ -> Stream IO CmmGroup ModuleLFInfos
+ -- Output as a stream, so codegen can
-- be interleaved with output
codeGen dflags this_mod data_tycons
@@ -101,6 +107,20 @@ codeGen dflags this_mod data_tycons
mapM_ (cg . cgDataCon) (tyConDataCons tycon)
; mapM_ do_tycon data_tycons
+
+ ; cg_id_infos <- cgs_binds <$> liftIO (readIORef cgref)
+
+ -- Only external names are actually visible to codeGen. So they are the
+ -- only ones we care about.
+ ; let extractInfo info = lf `seq` Just (name,lf)
+ where
+ id = cg_id info
+ !name = idName id
+ lf = cg_lf info
+
+ ; let !generatedInfo = mkNameEnv (mapMaybe extractInfo (eltsUFM cg_id_infos))
+
+ ; return $! generatedInfo
}
---------------------------------------------------------------
=====================================
compiler/GHC/StgToCmm/Closure.hs
=====================================
@@ -24,7 +24,7 @@ module GHC.StgToCmm.Closure (
LambdaFormInfo, -- Abstract
StandardFormInfo, -- ...ditto...
mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,
- mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
+ mkApLFInfo, mkLFArgument, mkLFLetNoEscape,
mkLFStringLit,
lfDynTag,
isLFThunk, isLFReEntrant, lfUpdatable,
@@ -51,6 +51,7 @@ module GHC.StgToCmm.Closure (
closureUpdReqd, closureSingleEntry,
closureReEntrant, closureFunInfo,
isToplevClosure,
+ mightBeAFunction,
blackHoleOnEntry, -- Needs LambdaFormInfo and SMRep
isStaticClosure, -- Needs SMPre
@@ -70,6 +71,7 @@ import GHC.Stg.Syntax
import GHC.Runtime.Heap.Layout
import GHC.Cmm
import GHC.Cmm.Ppr.Expr() -- For Outputable instances
+import GHC.StgToCmm.Types
import CostCentre
import GHC.Cmm.BlockId
@@ -188,86 +190,15 @@ addArgReps = map (\arg -> let arg' = fromNonVoid arg
argPrimRep :: StgArg -> PrimRep
argPrimRep arg = typePrimRep1 (stgArgType arg)
-
------------------------------------------------------------------------------
--- LambdaFormInfo
------------------------------------------------------------------------------
-
--- Information about an identifier, from the code generator's point of
--- view. Every identifier is bound to a LambdaFormInfo in the
--- environment, which gives the code generator enough info to be able to
--- tail call or return that identifier.
-
-data LambdaFormInfo
- = LFReEntrant -- Reentrant closure (a function)
- TopLevelFlag -- True if top level
- OneShotInfo
- !RepArity -- Arity. Invariant: always > 0
- !Bool -- True <=> no fvs
- ArgDescr -- Argument descriptor (should really be in ClosureInfo)
-
- | LFThunk -- Thunk (zero arity)
- TopLevelFlag
- !Bool -- True <=> no free vars
- !Bool -- True <=> updatable (i.e., *not* single-entry)
- StandardFormInfo
- !Bool -- True <=> *might* be a function type
-
- | LFCon -- A saturated constructor application
- DataCon -- The constructor
-
- | LFUnknown -- Used for function arguments and imported things.
- -- We know nothing about this closure.
- -- Treat like updatable "LFThunk"...
- -- Imported things which we *do* know something about use
- -- one of the other LF constructors (eg LFReEntrant for
- -- known functions)
- !Bool -- True <=> *might* be a function type
- -- The False case is good when we want to enter it,
- -- because then we know the entry code will do
- -- For a function, the entry code is the fast entry point
-
- | LFUnlifted -- A value of unboxed type;
- -- always a value, needs evaluation
-
- | LFLetNoEscape -- See LetNoEscape module for precise description
-
-
--------------------------
--- StandardFormInfo tells whether this thunk has one of
--- a small number of standard forms
-
-data StandardFormInfo
- = NonStandardThunk
- -- The usual case: not of the standard forms
-
- | SelectorThunk
- -- A SelectorThunk is of form
- -- case x of
- -- con a1,..,an -> ak
- -- and the constructor is from a single-constr type.
- WordOff -- 0-origin offset of ak within the "goods" of
- -- constructor (Recall that the a1,...,an may be laid
- -- out in the heap in a non-obvious order.)
-
- | ApThunk
- -- An ApThunk is of form
- -- x1 ... xn
- -- The code for the thunk just pushes x2..xn on the stack and enters x1.
- -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
- -- in the RTS to save space.
- RepArity -- Arity, n
-
-
------------------------------------------------------
-- Building LambdaFormInfo
------------------------------------------------------
mkLFArgument :: Id -> LambdaFormInfo
mkLFArgument id
- | isUnliftedType ty = LFUnlifted
- | might_be_a_function ty = LFUnknown True
- | otherwise = LFUnknown False
+ | isUnliftedType ty = LFUnlifted
+ | mightBeAFunction ty = LFUnknown True
+ | otherwise = LFUnknown False
where
ty = idType id
@@ -295,13 +226,13 @@ mkLFThunk thunk_ty top fvs upd_flag
LFThunk top (null fvs)
(isUpdatable upd_flag)
NonStandardThunk
- (might_be_a_function thunk_ty)
+ (mightBeAFunction thunk_ty)
--------------
-might_be_a_function :: Type -> Bool
+mightBeAFunction :: Type -> Bool
-- Return False only if we are *sure* it's a data type
-- Look through newtypes etc as much as poss
-might_be_a_function ty
+mightBeAFunction ty
| [LiftedRep] <- typePrimRep ty
, Just tc <- tyConAppTyCon_maybe (unwrapType ty)
, isDataTyCon tc
@@ -317,30 +248,13 @@ mkConLFInfo con = LFCon con
mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo
mkSelectorLFInfo id offset updatable
= LFThunk NotTopLevel False updatable (SelectorThunk offset)
- (might_be_a_function (idType id))
+ (mightBeAFunction (idType id))
-------------
mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo
mkApLFInfo id upd_flag arity
= LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
- (might_be_a_function (idType id))
-
--------------
-mkLFImported :: Id -> LambdaFormInfo
-mkLFImported id
- | Just con <- isDataConWorkId_maybe id
- , isNullaryRepDataCon con
- = LFCon con -- An imported nullary constructor
- -- We assume that the constructor is evaluated so that
- -- the id really does point directly to the constructor
-
- | arity > 0
- = LFReEntrant TopLevel noOneShotInfo arity True (panic "arg_descr")
-
- | otherwise
- = mkLFArgument id -- Not sure of exact arity
- where
- arity = idFunRepArity id
+ (mightBeAFunction (idType id))
-------------
mkLFStringLit :: LambdaFormInfo
=====================================
compiler/GHC/StgToCmm/Env.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, MultiWayIf #-}
-----------------------------------------------------------------------------
--
@@ -30,6 +30,7 @@ import GHC.Core.TyCon
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Closure
+import GHC.StgToCmm.Types
import GHC.Cmm.CLabel
@@ -47,6 +48,8 @@ import TysPrim
import UniqFM
import Util
import VarEnv
+import GHC.Core.DataCon
+import BasicTypes
-------------------------------------
-- Manipulating CgIdInfo
@@ -143,6 +146,27 @@ getCgIdInfo id
cgLookupPanic id -- Bug
}}}
+mkLFImported :: Id -> LambdaFormInfo
+mkLFImported id =
+ case idLFInfo_maybe id of
+ Just lf_info ->
+ lf_info
+ Nothing ->
+ WARN( True, text "mkLFImported: Id with unknown LFInfo: " <+> ppr id )
+ if | Just con <- isDataConWorkId_maybe id
+ , isNullaryRepDataCon con
+ -> LFCon con -- An imported nullary constructor
+ -- We assume that the constructor is evaluated so that
+ -- the id really does point directly to the constructor
+
+ | arity > 0
+ -> LFReEntrant TopLevel noOneShotInfo arity True (panic "arg_descr")
+
+ | otherwise
+ -> mkLFArgument id -- Not sure of exact arity
+ where
+ arity = idFunRepArity id
+
cgLookupPanic :: Id -> FCode a
cgLookupPanic id
= do local_binds <- getBinds
=====================================
compiler/GHC/StgToCmm/Types.hs
=====================================
@@ -0,0 +1,157 @@
+{-# LANGUAGE CPP #-}
+
+module GHC.StgToCmm.Types
+ ( WordOff
+ , LambdaFormInfo (..)
+ , ModuleLFInfos
+ , Liveness
+ , ArgDescr (..)
+ , StandardFormInfo (..)
+ ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import BasicTypes
+import GHC.Core.DataCon
+import NameEnv
+import Outputable
+
+-- | Word offset, or word count
+type WordOff = Int
+
+--------------------------------------------------------------------------------
+-- LambdaFormInfo
+--------------------------------------------------------------------------------
+
+-- | Maps names in the current module to their LambdaFormInfos
+type ModuleLFInfos = NameEnv LambdaFormInfo
+
+-- Information about an identifier, from the code generator's point of view.
+-- Every identifier is bound to a LambdaFormInfo in the environment, which gives
+-- the code generator enough info to be able to tail call or return that
+-- identifier.
+
+data LambdaFormInfo
+ = LFReEntrant -- Reentrant closure (a function)
+ TopLevelFlag -- True if top level
+ OneShotInfo
+ !RepArity -- Arity. Invariant: always > 0
+ !Bool -- True <=> no fvs
+ ArgDescr -- Argument descriptor (should really be in ClosureInfo)
+
+ | LFThunk -- Thunk (zero arity)
+ TopLevelFlag
+ !Bool -- True <=> no free vars
+ !Bool -- True <=> updatable (i.e., *not* single-entry)
+ StandardFormInfo
+ !Bool -- True <=> *might* be a function type
+
+ | LFCon -- A saturated constructor application
+ DataCon -- The constructor
+
+ | LFUnknown -- Used for function arguments and imported things.
+ -- We know nothing about this closure.
+ -- Treat like updatable "LFThunk"...
+ -- Imported things which we *do* know something about use
+ -- one of the other LF constructors (eg LFReEntrant for
+ -- known functions)
+ !Bool -- True <=> *might* be a function type
+ -- The False case is good when we want to enter it,
+ -- because then we know the entry code will do
+ -- For a function, the entry code is the fast entry point
+
+ | LFUnlifted -- A value of unboxed type;
+ -- always a value, needs evaluation
+
+ | LFLetNoEscape -- See LetNoEscape module for precise description
+
+instance Outputable LambdaFormInfo where
+ ppr (LFReEntrant top oneshot rep fvs argdesc) =
+ text "LFReEntrant" <> brackets (ppr top <+> ppr oneshot <+>
+ ppr rep <+> pprFvs fvs <+> ppr argdesc)
+ ppr (LFThunk top hasfv updateable sfi m_function) =
+ text "LFThunk" <> brackets (ppr top <+> pprFvs hasfv <+> pprUpdateable updateable <+>
+ ppr sfi <+> pprFuncFlag m_function)
+ ppr (LFCon con) = text "LFCon" <> brackets (ppr con)
+ ppr (LFUnknown m_func) =
+ text "LFUnknown" <> brackets (pprFuncFlag m_func)
+ ppr LFUnlifted = text "LFUnlifted"
+ ppr LFLetNoEscape = text "LFLetNoEscape"
+
+pprFvs :: Bool -> SDoc
+pprFvs True = text "no-fvs"
+pprFvs False = text "fvs"
+
+pprFuncFlag :: Bool -> SDoc
+pprFuncFlag True = text "mFunc"
+pprFuncFlag False = text "value"
+
+pprUpdateable :: Bool -> SDoc
+pprUpdateable True = text "updateable"
+pprUpdateable False = text "oneshot"
+
+--------------------------------------------------------------------------------
+
+-- | We represent liveness bitmaps as a Bitmap (whose internal representation
+-- really is a bitmap). These are pinned onto case return vectors to indicate
+-- the state of the stack for the garbage collector.
+--
+-- In the compiled program, liveness bitmaps that fit inside a single word
+-- (StgWord) are stored as a single word, while larger bitmaps are stored as a
+-- pointer to an array of words.
+
+type Liveness = [Bool] -- One Bool per word; True <=> non-ptr or dead
+ -- False <=> ptr
+
+--------------------------------------------------------------------------------
+-- | An ArgDescr describes the argument pattern of a function
+
+data ArgDescr
+ = ArgSpec -- Fits one of the standard patterns
+ !Int -- RTS type identifier ARG_P, ARG_N, ...
+
+ | ArgGen -- General case
+ Liveness -- Details about the arguments
+
+ | ArgUnknown -- For imported binds.
+ -- Invariant: Never Unknown for binds of the module
+ -- we are compiling.
+ deriving (Eq)
+
+instance Outputable ArgDescr where
+ ppr (ArgSpec n) = text "ArgSpec" <+> ppr n
+ ppr (ArgGen ls) = text "ArgGen" <+> ppr ls
+ ppr ArgUnknown = text "ArgUnknown"
+
+--------------------------------------------------------------------------------
+-- | StandardFormInfo tells whether this thunk has one of a small number of
+-- standard forms
+
+data StandardFormInfo
+ = NonStandardThunk
+ -- The usual case: not of the standard forms
+
+ | SelectorThunk
+ -- A SelectorThunk is of form
+ -- case x of
+ -- con a1,..,an -> ak
+ -- and the constructor is from a single-constr type.
+ WordOff -- 0-origin offset of ak within the "goods" of
+ -- constructor (Recall that the a1,...,an may be laid
+ -- out in the heap in a non-obvious order.)
+
+ | ApThunk
+ -- An ApThunk is of form
+ -- x1 ... xn
+ -- The code for the thunk just pushes x2..xn on the stack and enters x1.
+ -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
+ -- in the RTS to save space.
+ RepArity -- Arity, n
+ deriving (Eq)
+
+instance Outputable StandardFormInfo where
+ ppr NonStandardThunk = text "RegThunk"
+ ppr (SelectorThunk w) = text "SelThunk:" <> ppr w
+ ppr (ApThunk n) = text "ApThunk:" <> ppr n
=====================================
compiler/basicTypes/Id.hs
=====================================
@@ -92,7 +92,7 @@ module Id (
idCallArity, idFunRepArity,
idUnfolding, realIdUnfolding,
idSpecialisation, idCoreRules, idHasRules,
- idCafInfo,
+ idCafInfo, idLFInfo, idLFInfo_maybe,
idOneShotInfo, idStateHackOneShotInfo,
idOccInfo,
isNeverLevPolyId,
@@ -105,6 +105,7 @@ module Id (
setIdSpecialisation,
setIdCafInfo,
setIdOccInfo, zapIdOccInfo,
+ setIdLFInfo,
setIdDemandInfo,
setIdStrictness,
@@ -731,6 +732,19 @@ idCafInfo id = cafInfo (idInfo id)
setIdCafInfo :: Id -> CafInfo -> Id
setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id
+ ---------------------------------
+ -- Lambda form info
+idLFInfo :: HasCallStack => Id -> LambdaFormInfo
+idLFInfo id = case lfInfo (idInfo id) of
+ Nothing -> pprPanic "idLFInfo" (text "LFInfo not available for Id" <+> ppr id)
+ Just lf_info -> lf_info
+
+idLFInfo_maybe :: Id -> Maybe LambdaFormInfo
+idLFInfo_maybe = lfInfo . idInfo
+
+setIdLFInfo :: Id -> LambdaFormInfo -> Id
+setIdLFInfo id lf = modifyIdInfo (`setLFInfo` lf) id
+
---------------------------------
-- Occurrence INFO
idOccInfo :: Id -> OccInfo
=====================================
compiler/basicTypes/IdInfo.hs
=====================================
@@ -74,6 +74,10 @@ module IdInfo (
ppCafInfo, mayHaveCafRefs,
cafInfo, setCafInfo,
+ -- ** The LambdaFormInfo type
+ LambdaFormInfo(..),
+ lfInfo, setLFInfo,
+
-- ** Tick-box Info
TickBoxOp(..), TickBoxId,
@@ -104,6 +108,8 @@ import Demand
import Cpr
import Util
+import GHC.StgToCmm.Types (LambdaFormInfo (..))
+
-- infixl so you can say (id `set` a `set` b)
infixl 1 `setRuleInfo`,
`setArityInfo`,
@@ -270,8 +276,9 @@ data IdInfo
-- ^ How this is called. This is the number of arguments to which a
-- binding can be eta-expanded without losing any sharing.
-- n <=> all calls have at least n arguments
- levityInfo :: LevityInfo
+ levityInfo :: LevityInfo,
-- ^ when applied, will this Id ever have a levity-polymorphic type?
+ lfInfo :: !(Maybe LambdaFormInfo)
}
-- Setters
@@ -294,13 +301,18 @@ setUnfoldingInfo info uf
setArityInfo :: IdInfo -> ArityInfo -> IdInfo
setArityInfo info ar = info { arityInfo = ar }
+
setCallArityInfo :: IdInfo -> ArityInfo -> IdInfo
setCallArityInfo info ar = info { callArityInfo = ar }
+
setCafInfo :: IdInfo -> CafInfo -> IdInfo
-setCafInfo info caf = info { cafInfo = caf }
+setCafInfo info caf = info { cafInfo = caf }
+
+setLFInfo :: IdInfo -> LambdaFormInfo -> IdInfo
+setLFInfo info lf = info { lfInfo = Just lf }
setOneShotInfo :: IdInfo -> OneShotInfo -> IdInfo
-setOneShotInfo info lb = {-lb `seq`-} info { oneShotInfo = lb }
+setOneShotInfo info lb = {-lb `seq`-} info { oneShotInfo = lb }
setDemandInfo :: IdInfo -> Demand -> IdInfo
setDemandInfo info dd = dd `seq` info { demandInfo = dd }
@@ -326,7 +338,8 @@ vanillaIdInfo
strictnessInfo = nopSig,
cprInfo = topCprSig,
callArityInfo = unknownArity,
- levityInfo = NoLevityInfo
+ levityInfo = NoLevityInfo,
+ lfInfo = Nothing
}
-- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references
=====================================
compiler/ghc.cabal.in
=====================================
@@ -298,6 +298,7 @@ Library
GHC.StgToCmm.Ticky
GHC.StgToCmm.Utils
GHC.StgToCmm.ExtCode
+ GHC.StgToCmm.Types
GHC.Runtime.Heap.Layout
GHC.Core.Arity
GHC.Core.FVs
=====================================
compiler/main/UpdateCafInfos.hs
=====================================
@@ -17,6 +17,7 @@ import NameSet
import Util
import Var
import Outputable
+import GHC.StgToCmm.Types (ModuleLFInfos)
#include "HsVersions.h"
@@ -24,14 +25,15 @@ import Outputable
updateModDetailsCafInfos
:: DynFlags
-> NameSet -- ^ Non-CAFFY names in the module. Names not in this set are CAFFY.
+ -> ModuleLFInfos
-> ModDetails -- ^ ModDetails to update
-> ModDetails
-updateModDetailsCafInfos dflags _ mod_details
+updateModDetailsCafInfos dflags _ _ mod_details
| gopt Opt_OmitInterfacePragmas dflags
= mod_details
-updateModDetailsCafInfos _ non_cafs mod_details =
+updateModDetailsCafInfos _ non_cafs lf_infos mod_details =
{- pprTrace "updateModDetailsCafInfos" (text "non_cafs:" <+> ppr non_cafs) $ -}
let
ModDetails{ md_types = type_env -- for unfoldings
@@ -40,10 +42,10 @@ updateModDetailsCafInfos _ non_cafs mod_details =
} = mod_details
-- type TypeEnv = NameEnv TyThing
- ~type_env' = mapNameEnv (updateTyThingCafInfos type_env' non_cafs) type_env
+ ~type_env' = mapNameEnv (updateTyThingCafInfos type_env' non_cafs lf_infos) type_env
-- Not strict!
- !insts' = strictMap (updateInstCafInfos type_env' non_cafs) insts
+ !insts' = strictMap (updateInstCafInfos type_env' non_cafs lf_infos) insts
!rules' = strictMap (updateRuleCafInfos type_env') rules
in
mod_details{ md_types = type_env'
@@ -63,20 +65,20 @@ updateRuleCafInfos type_env Rule{ .. } = Rule { ru_rhs = updateGlobalIds type_en
-- Instances
--------------------------------------------------------------------------------
-updateInstCafInfos :: TypeEnv -> NameSet -> ClsInst -> ClsInst
-updateInstCafInfos type_env non_cafs =
- updateClsInstDFun (updateIdUnfolding type_env . updateIdCafInfo non_cafs)
+updateInstCafInfos :: TypeEnv -> NameSet -> ModuleLFInfos -> ClsInst -> ClsInst
+updateInstCafInfos type_env non_cafs lf_infos =
+ updateClsInstDFun (updateIdUnfolding type_env . updateIdCafInfo non_cafs lf_infos)
--------------------------------------------------------------------------------
-- TyThings
--------------------------------------------------------------------------------
-updateTyThingCafInfos :: TypeEnv -> NameSet -> TyThing -> TyThing
+updateTyThingCafInfos :: TypeEnv -> NameSet -> ModuleLFInfos -> TyThing -> TyThing
-updateTyThingCafInfos type_env non_cafs (AnId id) =
- AnId (updateIdUnfolding type_env (updateIdCafInfo non_cafs id))
+updateTyThingCafInfos type_env non_cafs lf_infos (AnId id) =
+ AnId (updateIdUnfolding type_env (updateIdCafInfo non_cafs lf_infos id))
-updateTyThingCafInfos _ _ other = other -- AConLike, ATyCon, ACoAxiom
+updateTyThingCafInfos _ _ _ other = other -- AConLike, ATyCon, ACoAxiom
--------------------------------------------------------------------------------
-- Unfoldings
@@ -95,13 +97,18 @@ updateIdUnfolding type_env id =
-- Expressions
--------------------------------------------------------------------------------
-updateIdCafInfo :: NameSet -> Id -> Id
-updateIdCafInfo non_cafs id
- | idName id `elemNameSet` non_cafs
- = -- pprTrace "updateIdCafInfo" (text "Marking" <+> ppr id <+> parens (ppr (idName id)) <+> text "as non-CAFFY") $
- id `setIdCafInfo` NoCafRefs
- | otherwise
- = id
+updateIdCafInfo :: NameSet -> ModuleLFInfos -> Id -> Id
+updateIdCafInfo non_cafs lf_infos id =
+ let
+ not_caffy = elemNameSet (idName id) non_cafs
+ mb_lf_info = lookupNameEnv lf_infos (idName id)
+
+ id1 = if not_caffy then setIdCafInfo id NoCafRefs else id
+ id2 = case mb_lf_info of
+ Nothing -> id1
+ Just lf_info -> setIdLFInfo id1 lf_info
+ in
+ id2
--------------------------------------------------------------------------------
=====================================
testsuite/tests/codeGen/should_compile/Makefile
=====================================
@@ -64,10 +64,10 @@ T17648:
# NoCafRefs) to the interface files.
'$(TEST_HC)' $(TEST_HC_OPTS) -dno-typeable-binds -O T17648.hs -v0
'$(TEST_HC)' --show-iface T17648.hi | tr -d '\n' | \
- grep -F 'f :: T GHC.Types.Int -> () [HasNoCafRefs, Arity' >/dev/null
+ grep -F 'f :: T GHC.Types.Int -> () [HasNoCafRefs, LambdaFormInfo' >/dev/null
# Second compilation with -fcatch-bottoms, f should be CAFFY
'$(TEST_HC)' $(TEST_HC_OPTS) -dno-typeable-binds -O \
-fcatch-bottoms T17648.hs -v0 -fforce-recomp
'$(TEST_HC)' --show-iface T17648.hi | tr -d '\n' | \
- grep -F 'f :: T GHC.Types.Int -> () [Arity: 1, Strictness' >/dev/null
+ grep -F 'f :: T GHC.Types.Int -> () [LambdaFormInfo' >/dev/null
=====================================
testsuite/tests/codeGen/should_compile/cg009/A.hs
=====================================
@@ -0,0 +1,5 @@
+module A where
+
+newtype A = A Int
+
+val = A 42
=====================================
testsuite/tests/codeGen/should_compile/cg009/Main.hs
=====================================
@@ -0,0 +1,7 @@
+module Main where
+
+import A
+
+main = return ()
+
+a = val
=====================================
testsuite/tests/codeGen/should_compile/cg009/Makefile
=====================================
@@ -0,0 +1,9 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+# Make sure the LFInfo for an exported, but not directly used newtype
+# constructors does not trip up the compiler.
+cg009:
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c -O A.hs -fforce-recomp
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c -O0 Main.hs -fforce-recomp
=====================================
testsuite/tests/codeGen/should_compile/cg009/all.T
=====================================
@@ -0,0 +1 @@
+test('cg009', [extra_files(['A.hs','Main.hs'])], makefile_test, ['cg009'])
=====================================
testsuite/tests/codeGen/should_compile/cg010/A.hs
=====================================
@@ -0,0 +1,4 @@
+module A where
+
+{-# NOINLINE val #-}
+val = Just 42
=====================================
testsuite/tests/codeGen/should_compile/cg010/Main.hs
=====================================
@@ -0,0 +1,8 @@
+module Main where
+
+import A
+
+main = return ()
+
+a = val
+
=====================================
testsuite/tests/codeGen/should_compile/cg010/Makefile
=====================================
@@ -0,0 +1,9 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+# Make sure LFInfo causes the imported reference to val to get tagged.
+cg010:
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c -O A.hs -fforce-recomp
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c -O Main.hs -fforce-recomp -ddump-cmm -ddump-to-file
+ grep "A.val_closure+2" Main.dump-cmm
=====================================
testsuite/tests/codeGen/should_compile/cg010/all.T
=====================================
@@ -0,0 +1 @@
+test('cg010', [extra_files(['A.hs','Main.hs'])], makefile_test, ['cg010'])
=====================================
testsuite/tests/codeGen/should_compile/cg010/cg010.stdout
=====================================
@@ -0,0 +1 @@
+ const A.val_closure+2;
=====================================
testsuite/tests/simplCore/should_compile/Makefile
=====================================
@@ -102,7 +102,7 @@ T4201:
'$(TEST_HC)' $(TEST_HC_OPTS) -c -O T4201.hs
'$(TEST_HC)' $(TEST_HC_OPTS) --show-iface T4201.hi > T4201.list
# poor man idea about how to replace GNU grep -B2 "Sym" invocation with pure POSIX tools
- for i in `grep -n "Sym" T4201.list |cut -d ':' -f -1`; do head -$$i T4201.list | tail -3 ; done
+ for i in `grep -n "Sym" T4201.list | cut -d ':' -f -1`; do head -$$i T4201.list | tail -5; done
$(RM) -f T4201.list
# This one looped as a result of bogus specialisation
=====================================
testsuite/tests/simplCore/should_compile/T4201.stdout
=====================================
@@ -1,3 +1,5 @@
- [HasNoCafRefs, Arity: 1, Strictness: <S,1*H>, CPR: m1,
+ [HasNoCafRefs,
+ LambdaFormInfo: LFReEntrant (NoOneShotInfo, 1, True), Arity: 1,
+ Strictness: <S,1*H>, CPR: m1,
Unfolding: InlineRule (0, True, True)
bof `cast` (Sym (N:Foo[0]) ->_R <T>_R)]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/481dfb8f795d396d764e05012ef6ea6345e22bb7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/481dfb8f795d396d764e05012ef6ea6345e22bb7
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/20200319/03dd54f3/attachment-0001.html>
More information about the ghc-commits
mailing list