[Git][ghc/ghc][wip/osa1/lfinfo] Cross-module LambdaFormInfo passing
Ömer Sinan Ağacan
gitlab at gitlab.haskell.org
Wed Mar 25 09:11:20 UTC 2020
Ömer Sinan Ağacan pushed to branch wip/osa1/lfinfo at Glasgow Haskell Compiler / GHC
Commits:
9f7e4c71 by Ömer Sinan Ağacan at 2020-03-25T12:11:02+03:00
Cross-module LambdaFormInfo passing
- Store LambdaFormInfos of exported Ids in interface files
- Use them in importing modules
- - - - -
28 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/Types.hs
- compiler/basicTypes/Id.hs
- compiler/basicTypes/IdInfo.hs
- compiler/ghc.cabal.in
- compiler/main/UpdateCafInfos.hs → compiler/main/UpdateIdInfos.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
=====================================
@@ -34,13 +34,14 @@ module GHC.CoreToIface
, toIfaceIdDetails
, toIfaceIdInfo
, toIfUnfolding
- , toIfaceOneShot
, toIfaceTickish
, toIfaceBind
, toIfaceAlt
, toIfaceCon
, toIfaceApp
, toIfaceVar
+ -- * Other stuff
+ , toIfaceLFInfo
) where
#include "HsVersions.h"
@@ -49,6 +50,7 @@ import GhcPrelude
import GHC.Iface.Syntax
import GHC.Core.DataCon
+import GHC.StgToCmm.Types
import Id
import IdInfo
import GHC.Core
@@ -74,6 +76,8 @@ import Demand ( isTopSig )
import Cpr ( topCprSig )
import Data.Maybe ( catMaybes )
+import Data.Word
+import Data.Bits
{- Note [Avoiding space leaks in toIface*]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -616,6 +620,43 @@ toIfaceVar v
where name = idName v
+---------------------
+toIfaceLFInfo :: LambdaFormInfo -> IfaceLFInfo
+toIfaceLFInfo lfi = case lfi of
+ LFReEntrant _ _ arity _ _ ->
+ IfLFReEntrant arity
+ LFThunk _ _ updatable sfi mb_fun ->
+ IfLFThunk updatable (toIfaceStandardFormInfo sfi) mb_fun
+ LFCon dc ->
+ IfLFCon (dataConName dc)
+ LFUnknown mb_fun ->
+ IfLFUnknown mb_fun
+ LFUnlifted ->
+ IfLFUnlifted
+ LFLetNoEscape ->
+ panic "toIfaceLFInfo: LFLetNoEscape"
+
+toIfaceStandardFormInfo :: StandardFormInfo -> IfaceStandardFormInfo
+toIfaceStandardFormInfo NonStandardThunk = IfStandardFormInfo 1
+toIfaceStandardFormInfo sf =
+ IfStandardFormInfo $!
+ tag sf .|. encodeField (field sf)
+ where
+ tag SelectorThunk{} = 0
+ tag ApThunk{} = setBit 0 1
+ tag NonStandardThunk = panic "toIfaceStandardFormInfo: NonStandardThunk"
+
+ field (SelectorThunk n) = n
+ field (ApThunk n) = n
+ field NonStandardThunk = panic "toIfaceStandardFormInfo: NonStandardThunk"
+
+ 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
=====================================
@@ -69,8 +69,8 @@ import FileCleanup
import Ar
import Bag ( unitBag )
import FastString ( mkFastString )
-import GHC.Iface.Make ( mkFullIface )
-import UpdateCafInfos ( updateModDetailsCafInfos )
+import GHC.Iface.Make ( mkFullIface )
+import UpdateIdInfos ( updateModDetailsIdInfos )
import Exception
import System.Directory
@@ -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))
- let final_mod_details = {-# SCC updateModDetailsCafInfos #-}
- updateModDetailsCafInfos iface_dflags caf_infos mod_details
+ final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface (Just (caf_infos, lf_infos)))
+ let final_mod_details = {-# SCC updateModDetailsIdInfos #-}
+ updateModDetailsIdInfos 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,74 @@ data IfaceIdDetails
| IfRecSelId (Either IfaceTyCon IfaceDecl) Bool
| IfDFunId
+-- | Iface type for LambdaFormInfo. Fields not relevant for imported Ids are
+-- omitted in this type.
+data IfaceLFInfo
+ = IfLFReEntrant !RepArity
+ | IfLFThunk !Bool !IfaceStandardFormInfo !Bool
+ | IfLFCon !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 arity) =
+ text "LFReEntrant" <+> ppr arity
+
+ ppr (IfLFThunk updatable sfi mb_fun) =
+ text "LFThunk" <+> ppr (updatable, tcStandardFormInfo sfi, mb_fun)
+
+ 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
+ put_ bh (IfLFReEntrant arity) = do
+ putByte bh 0
+ put_ bh arity
+ put_ bh (IfLFThunk updatable sfi mb_fun) = do
+ putByte bh 1
+ put_ bh updatable
+ put_ bh sfi
+ put_ bh mb_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
+ 1 -> IfLFThunk <$> 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 +1469,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 +1930,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 +2230,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 +2243,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 +2575,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,7 @@ import TcTypeNats(typeNatCoAxiomRules)
import GHC.Iface.Syntax
import GHC.Iface.Load
import GHC.Iface.Env
+import GHC.StgToCmm.Types
import BuildTyCl
import TcRnMonad
import TcType
@@ -1465,8 +1467,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 +1487,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)
@@ -1498,6 +1502,23 @@ tcJoinInfo :: IfaceJoinInfo -> Maybe JoinArity
tcJoinInfo (IfaceJoinPoint ar) = Just ar
tcJoinInfo IfaceNotJoinPoint = Nothing
+tcLFInfo :: IfaceLFInfo -> IfL LambdaFormInfo
+tcLFInfo lfi = case lfi of
+ IfLFReEntrant rep_arity ->
+ return (LFReEntrant TopLevel NoOneShotInfo rep_arity True ArgUnknown)
+
+ IfLFThunk updatable sfi mb_fun ->
+ return (LFThunk TopLevel True updatable (tcStandardFormInfo sfi) mb_fun)
+
+ IfLFUnlifted ->
+ return LFUnlifted
+
+ IfLFCon con_name ->
+ LFCon <$!> tcIfaceDataCon con_name
+
+ 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 +1607,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
@@ -545,10 +520,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
@@ -59,7 +63,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 +106,18 @@ codeGen dflags this_mod data_tycons
mapM_ (cg . cgDataCon) (tyConDataCons tycon)
; mapM_ do_tycon data_tycons
+
+ ; cg_id_infos <- cgs_binds <$> liftIO (readIORef cgref)
+
+ ; let extractInfo info = (name, lf)
+ where
+ !id = cg_id info
+ !name = idName id
+ !lf = cg_lf info
+
+ ; let !generatedInfo = mkNameEnv (Prelude.map extractInfo (eltsUFM cg_id_infos))
+
+ ; return generatedInfo
}
---------------------------------------------------------------
=====================================
compiler/GHC/StgToCmm/Closure.hs
=====================================
@@ -70,6 +70,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,77 +189,6 @@ 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
------------------------------------------------------
@@ -327,18 +257,22 @@ mkApLFInfo id upd_flag arity
-------------
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
+mkLFImported id =
+ case idLFInfo_maybe id of
+ Just lf_info ->
+ lf_info
+ Nothing
+ | 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 ArgUnknown
+
+ | otherwise
+ -> mkLFArgument id -- Not sure of exact arity
where
arity = idFunRepArity id
=====================================
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_maybe,
idOneShotInfo, idStateHackOneShotInfo,
idOccInfo,
isNeverLevPolyId,
@@ -105,6 +105,7 @@ module Id (
setIdSpecialisation,
setIdCafInfo,
setIdOccInfo, zapIdOccInfo,
+ setIdLFInfo,
setIdDemandInfo,
setIdStrictness,
@@ -731,6 +732,15 @@ idCafInfo id = cafInfo (idInfo id)
setIdCafInfo :: Id -> CafInfo -> Id
setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id
+ ---------------------------------
+ -- Lambda form 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
=====================================
@@ -229,7 +229,7 @@ Library
SrcLoc
UniqSupply
Unique
- UpdateCafInfos
+ UpdateIdInfos
Var
VarEnv
VarSet
@@ -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 → compiler/main/UpdateIdInfos.hs
=====================================
@@ -1,7 +1,7 @@
{-# LANGUAGE CPP, BangPatterns, Strict, RecordWildCards #-}
-module UpdateCafInfos
- ( updateModDetailsCafInfos
+module UpdateIdInfos
+ ( updateModDetailsIdInfos
) where
import GhcPrelude
@@ -17,22 +17,23 @@ import NameSet
import Util
import Var
import Outputable
+import GHC.StgToCmm.Types (ModuleLFInfos)
#include "HsVersions.h"
--- | Update CafInfos of all occurences (in rules, unfoldings, class instances)
-updateModDetailsCafInfos
+-- | Update CafInfos and LFInfos of all occurences (in rules, unfoldings, class instances)
+updateModDetailsIdInfos
:: 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
+updateModDetailsIdInfos dflags _ _ mod_details
| gopt Opt_OmitInterfacePragmas dflags
= mod_details
-updateModDetailsCafInfos _ non_cafs mod_details =
- {- pprTrace "updateModDetailsCafInfos" (text "non_cafs:" <+> ppr non_cafs) $ -}
+updateModDetailsIdInfos _ non_cafs lf_infos mod_details =
let
ModDetails{ md_types = type_env -- for unfoldings
, md_insts = insts
@@ -40,11 +41,11 @@ 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
- !rules' = strictMap (updateRuleCafInfos type_env') rules
+ !insts' = strictMap (updateInstIdInfos type_env' non_cafs lf_infos) insts
+ !rules' = strictMap (updateRuleIdInfos type_env') rules
in
mod_details{ md_types = type_env'
, md_insts = insts'
@@ -55,28 +56,28 @@ updateModDetailsCafInfos _ non_cafs mod_details =
-- Rules
--------------------------------------------------------------------------------
-updateRuleCafInfos :: TypeEnv -> CoreRule -> CoreRule
-updateRuleCafInfos _ rule at BuiltinRule{} = rule
-updateRuleCafInfos type_env Rule{ .. } = Rule { ru_rhs = updateGlobalIds type_env ru_rhs, .. }
+updateRuleIdInfos :: TypeEnv -> CoreRule -> CoreRule
+updateRuleIdInfos _ rule at BuiltinRule{} = rule
+updateRuleIdInfos type_env Rule{ .. } = Rule { ru_rhs = updateGlobalIds type_env ru_rhs, .. }
--------------------------------------------------------------------------------
-- Instances
--------------------------------------------------------------------------------
-updateInstCafInfos :: TypeEnv -> NameSet -> ClsInst -> ClsInst
-updateInstCafInfos type_env non_cafs =
- updateClsInstDFun (updateIdUnfolding type_env . updateIdCafInfo non_cafs)
+updateInstIdInfos :: TypeEnv -> NameSet -> ModuleLFInfos -> ClsInst -> ClsInst
+updateInstIdInfos type_env non_cafs lf_infos =
+ updateClsInstDFun (updateIdUnfolding type_env . updateIdInfo 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 (updateIdInfo non_cafs lf_infos id))
-updateTyThingCafInfos _ _ other = other -- AConLike, ATyCon, ACoAxiom
+updateTyThingCafInfos _ _ _ other = other -- AConLike, ATyCon, ACoAxiom
--------------------------------------------------------------------------------
-- Unfoldings
@@ -95,13 +96,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
+updateIdInfo :: NameSet -> ModuleLFInfos -> Id -> Id
+updateIdInfo 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 -4; done
$(RM) -f T4201.list
# This one looped as a result of bogus specialisation
=====================================
testsuite/tests/simplCore/should_compile/T4201.stdout
=====================================
@@ -1,3 +1,4 @@
- [HasNoCafRefs, Arity: 1, Strictness: <S,1*H>, CPR: m1,
+ [HasNoCafRefs, LambdaFormInfo: LFReEntrant 1, 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/9f7e4c7193ce2122bd3ff5532ad284a7c8041605
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9f7e4c7193ce2122bd3ff5532ad284a7c8041605
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/20200325/559d8b44/attachment-0001.html>
More information about the ghc-commits
mailing list