summaryrefslogtreecommitdiff
path: root/compiler/GHC/Iface
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Iface')
-rw-r--r--compiler/GHC/Iface/Binary.hs16
-rw-r--r--compiler/GHC/Iface/Env.hs8
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs12
-rw-r--r--compiler/GHC/Iface/Ext/Binary.hs12
-rw-r--r--compiler/GHC/Iface/Ext/Debug.hs6
-rw-r--r--compiler/GHC/Iface/Ext/Types.hs10
-rw-r--r--compiler/GHC/Iface/Ext/Utils.hs8
-rw-r--r--compiler/GHC/Iface/Load.hs18
-rw-r--r--compiler/GHC/Iface/Load.hs-boot2
-rw-r--r--compiler/GHC/Iface/Make.hs14
-rw-r--r--compiler/GHC/Iface/Recomp.hs20
-rw-r--r--compiler/GHC/Iface/Recomp/Binary.hs10
-rw-r--r--compiler/GHC/Iface/Recomp/Flags.hs10
-rw-r--r--compiler/GHC/Iface/Rename.hs12
-rw-r--r--compiler/GHC/Iface/Syntax.hs14
-rw-r--r--compiler/GHC/Iface/Tidy.hs14
-rw-r--r--compiler/GHC/Iface/Tidy/StaticPtrTable.hs294
-rw-r--r--compiler/GHC/Iface/Type.hs12
-rw-r--r--compiler/GHC/Iface/UpdateCafInfos.hs148
19 files changed, 541 insertions, 99 deletions
diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs
index 2e1953ade7..3e00e8694d 100644
--- a/compiler/GHC/Iface/Binary.hs
+++ b/compiler/GHC/Iface/Binary.hs
@@ -33,7 +33,7 @@ module GHC.Iface.Binary (
#include "HsVersions.h"
-import GhcPrelude
+import GHC.Prelude
import GHC.Tc.Utils.Monad
import GHC.Builtin.Utils ( isKnownKeyName, lookupKnownKeyName )
@@ -44,18 +44,18 @@ import GHC.Types.Name
import GHC.Driver.Session
import GHC.Types.Unique.FM
import GHC.Types.Unique.Supply
-import Panic
-import Binary
+import GHC.Utils.Panic
+import GHC.Utils.Binary as Binary
import GHC.Types.SrcLoc
-import ErrUtils
-import FastMutInt
+import GHC.Utils.Error
+import GHC.Data.FastMutInt
import GHC.Types.Unique
-import Outputable
+import GHC.Utils.Outputable
import GHC.Types.Name.Cache
import GHC.Platform
-import FastString
+import GHC.Data.FastString
import GHC.Settings.Constants
-import Util
+import GHC.Utils.Misc
import Data.Array
import Data.Array.ST
diff --git a/compiler/GHC/Iface/Env.hs b/compiler/GHC/Iface/Env.hs
index 72cff8b8d7..75b93605be 100644
--- a/compiler/GHC/Iface/Env.hs
+++ b/compiler/GHC/Iface/Env.hs
@@ -22,7 +22,7 @@ module GHC.Iface.Env (
#include "HsVersions.h"
-import GhcPrelude
+import GHC.Prelude
import GHC.Tc.Utils.Monad
import GHC.Driver.Types
@@ -31,14 +31,14 @@ import GHC.Types.Var
import GHC.Types.Name
import GHC.Types.Avail
import GHC.Types.Module
-import FastString
-import FastStringEnv
+import GHC.Data.FastString
+import GHC.Data.FastString.Env
import GHC.Iface.Type
import GHC.Types.Name.Cache
import GHC.Types.Unique.Supply
import GHC.Types.SrcLoc
-import Outputable
+import GHC.Utils.Outputable
import Data.List ( partition )
{-
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 15edfd7bb6..f35cf8f2f0 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -17,12 +17,12 @@ Main functions for .hie file generation
module GHC.Iface.Ext.Ast ( mkHieFile, mkHieFileWithSource, getCompressedAsts) where
-import GhcPrelude
+import GHC.Prelude
import GHC.Types.Avail ( Avails )
-import Bag ( Bag, bagToList )
+import GHC.Data.Bag ( Bag, bagToList )
import GHC.Types.Basic
-import BooleanFormula
+import GHC.Data.BooleanFormula
import GHC.Core.Class ( FunDep )
import GHC.Core.Utils ( exprType )
import GHC.Core.ConLike ( conLikeName )
@@ -31,7 +31,7 @@ import GHC.Types.FieldLabel
import GHC.Hs
import GHC.Driver.Types
import GHC.Types.Module ( ModuleName, ml_hs_file )
-import MonadUtils ( concatMapM, liftIO )
+import GHC.Utils.Monad ( concatMapM, liftIO )
import GHC.Types.Name ( Name, nameSrcSpan, setNameLoc )
import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv )
import GHC.Types.SrcLoc
@@ -41,8 +41,8 @@ import GHC.Builtin.Types ( mkListTy, mkSumTy )
import GHC.Types.Var ( Id, Var, setVarName, varName, varType )
import GHC.Tc.Types
import GHC.Iface.Make ( mkIfaceExports )
-import Panic
-import Maybes
+import GHC.Utils.Panic
+import GHC.Data.Maybe
import GHC.Iface.Ext.Types
import GHC.Iface.Ext.Utils
diff --git a/compiler/GHC/Iface/Ext/Binary.hs b/compiler/GHC/Iface/Ext/Binary.hs
index a90234c60f..0077c23ee4 100644
--- a/compiler/GHC/Iface/Ext/Binary.hs
+++ b/compiler/GHC/Iface/Ext/Binary.hs
@@ -18,21 +18,21 @@ where
import GHC.Settings.Utils ( maybeRead )
import Config ( cProjectVersion )
-import GhcPrelude
-import Binary
+import GHC.Prelude
+import GHC.Utils.Binary
import GHC.Iface.Binary ( getDictFastString )
-import FastMutInt
-import FastString ( FastString )
+import GHC.Data.FastMutInt
+import GHC.Data.FastString ( FastString )
import GHC.Types.Module ( Module )
import GHC.Types.Name
import GHC.Types.Name.Cache
-import Outputable
+import GHC.Utils.Outputable
import GHC.Builtin.Utils
import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Unique.Supply ( takeUniqFromSupply )
import GHC.Types.Unique
import GHC.Types.Unique.FM
-import Util
+import GHC.Utils.Misc
import qualified Data.Array as A
import Data.IORef
diff --git a/compiler/GHC/Iface/Ext/Debug.hs b/compiler/GHC/Iface/Ext/Debug.hs
index 292668fe23..bb0c827627 100644
--- a/compiler/GHC/Iface/Ext/Debug.hs
+++ b/compiler/GHC/Iface/Ext/Debug.hs
@@ -7,12 +7,12 @@ Functions to validate and check .hie file ASTs generated by GHC.
module GHC.Iface.Ext.Debug where
-import GhcPrelude
+import GHC.Prelude
import GHC.Types.SrcLoc
import GHC.Types.Module
-import FastString
-import Outputable
+import GHC.Data.FastString
+import GHC.Utils.Outputable
import GHC.Iface.Ext.Types
import GHC.Iface.Ext.Binary
diff --git a/compiler/GHC/Iface/Ext/Types.hs b/compiler/GHC/Iface/Ext/Types.hs
index edd6540e80..88cb9c2042 100644
--- a/compiler/GHC/Iface/Ext/Types.hs
+++ b/compiler/GHC/Iface/Ext/Types.hs
@@ -12,18 +12,18 @@ For more information see https://gitlab.haskell.org/ghc/ghc/wikis/hie-files
{-# LANGUAGE OverloadedStrings #-}
module GHC.Iface.Ext.Types where
-import GhcPrelude
+import GHC.Prelude
import Config
-import Binary
-import FastString ( FastString )
+import GHC.Utils.Binary
+import GHC.Data.FastString ( FastString )
import GHC.Iface.Type
import GHC.Types.Module ( ModuleName, Module )
import GHC.Types.Name ( Name )
-import Outputable hiding ( (<>) )
+import GHC.Utils.Outputable hiding ( (<>) )
import GHC.Types.SrcLoc ( RealSrcSpan )
import GHC.Types.Avail
-import qualified Outputable as O ( (<>) )
+import qualified GHC.Utils.Outputable as O ( (<>) )
import qualified Data.Array as A
import qualified Data.Map as M
diff --git a/compiler/GHC/Iface/Ext/Utils.hs b/compiler/GHC/Iface/Ext/Utils.hs
index bbbe1084f1..3b9bb2b4aa 100644
--- a/compiler/GHC/Iface/Ext/Utils.hs
+++ b/compiler/GHC/Iface/Ext/Utils.hs
@@ -4,14 +4,14 @@
{-# LANGUAGE FlexibleInstances #-}
module GHC.Iface.Ext.Utils where
-import GhcPrelude
+import GHC.Prelude
import GHC.Core.Map
-import GHC.Driver.Session ( DynFlags )
-import FastString ( FastString, mkFastString )
+import GHC.Driver.Session ( DynFlags )
+import GHC.Data.FastString ( FastString, mkFastString )
import GHC.Iface.Type
import GHC.Types.Name hiding (varName)
-import Outputable ( renderWithStyle, ppr, defaultUserStyle, initSDocContext )
+import GHC.Utils.Outputable ( renderWithStyle, ppr, defaultUserStyle, initSDocContext )
import GHC.Types.SrcLoc
import GHC.CoreToIface
import GHC.Core.TyCon
diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs
index 5fca78c67c..0068441ee3 100644
--- a/compiler/GHC/Iface/Load.hs
+++ b/compiler/GHC/Iface/Load.hs
@@ -34,7 +34,7 @@ module GHC.Iface.Load (
#include "HsVersions.h"
-import GhcPrelude
+import GHC.Prelude
import {-# SOURCE #-} GHC.IfaceToCore
( tcIfaceDecl, tcIfaceRules, tcIfaceInst, tcIfaceFamInst
@@ -48,7 +48,7 @@ import GHC.Driver.Types
import GHC.Types.Basic hiding (SuccessFlag(..))
import GHC.Tc.Utils.Monad
-import Binary ( BinData(..) )
+import GHC.Utils.Binary ( BinData(..) )
import GHC.Settings.Constants
import GHC.Builtin.Names
import GHC.Builtin.Utils
@@ -64,17 +64,17 @@ import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Avail
import GHC.Types.Module
-import Maybes
-import ErrUtils
+import GHC.Data.Maybe
+import GHC.Utils.Error
import GHC.Driver.Finder
import GHC.Types.Unique.FM
import GHC.Types.SrcLoc
-import Outputable
+import GHC.Utils.Outputable as Outputable
import GHC.Iface.Binary
-import Panic
-import Util
-import FastString
-import Fingerprint
+import GHC.Utils.Panic
+import GHC.Utils.Misc
+import GHC.Data.FastString
+import GHC.Utils.Fingerprint
import GHC.Driver.Hooks
import GHC.Types.FieldLabel
import GHC.Iface.Rename
diff --git a/compiler/GHC/Iface/Load.hs-boot b/compiler/GHC/Iface/Load.hs-boot
index 51270ccb33..7e7d235bb7 100644
--- a/compiler/GHC/Iface/Load.hs-boot
+++ b/compiler/GHC/Iface/Load.hs-boot
@@ -3,6 +3,6 @@ module GHC.Iface.Load where
import GHC.Types.Module (Module)
import GHC.Tc.Utils.Monad (IfM)
import GHC.Driver.Types (ModIface)
-import Outputable (SDoc)
+import GHC.Utils.Outputable (SDoc)
loadSysInterface :: SDoc -> Module -> IfM lcl ModIface
diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs
index ef9e77b44d..6ffce05405 100644
--- a/compiler/GHC/Iface/Make.hs
+++ b/compiler/GHC/Iface/Make.hs
@@ -21,7 +21,7 @@ where
#include "HsVersions.h"
-import GhcPrelude
+import GHC.Prelude
import GHC.Iface.Syntax
import GHC.Iface.Recomp
@@ -53,12 +53,12 @@ import GHC.Types.Name.Reader
import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Types.Module
-import ErrUtils
-import Outputable
-import GHC.Types.Basic hiding ( SuccessFlag(..) )
-import Util hiding ( eqListBy )
-import FastString
-import Maybes
+import GHC.Utils.Error
+import GHC.Utils.Outputable
+import GHC.Types.Basic hiding ( SuccessFlag(..) )
+import GHC.Utils.Misc hiding ( eqListBy )
+import GHC.Data.FastString
+import GHC.Data.Maybe
import GHC.HsToCore.Docs
import Data.Function
diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs
index 57809a6d59..430f7b4207 100644
--- a/compiler/GHC/Iface/Recomp.hs
+++ b/compiler/GHC/Iface/Recomp.hs
@@ -12,7 +12,7 @@ where
#include "HsVersions.h"
-import GhcPrelude
+import GHC.Prelude
import GHC.Iface.Syntax
import GHC.Iface.Recomp.Binary
@@ -29,16 +29,16 @@ import GHC.Driver.Session
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Module
-import ErrUtils
-import Digraph
+import GHC.Utils.Error
+import GHC.Data.Graph.Directed
import GHC.Types.SrcLoc
-import Outputable
+import GHC.Utils.Outputable as Outputable
import GHC.Types.Unique
-import Util hiding ( eqListBy )
-import Maybes
-import Binary
-import Fingerprint
-import Exception
+import GHC.Utils.Misc hiding ( eqListBy )
+import GHC.Data.Maybe
+import GHC.Utils.Binary
+import GHC.Utils.Fingerprint
+import GHC.Utils.Exception
import GHC.Types.Unique.Set
import GHC.Driver.Packages
@@ -766,7 +766,7 @@ addFingerprints hsc_env iface0
-- used to construct the edges and
-- stronglyConnCompFromEdgedVertices is deterministic
-- even with non-deterministic order of edges as
- -- explained in Note [Deterministic SCC] in Digraph.
+ -- explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed.
where getParent :: OccName -> OccName
getParent occ = lookupOccEnv parent_map occ `orElse` occ
diff --git a/compiler/GHC/Iface/Recomp/Binary.hs b/compiler/GHC/Iface/Recomp/Binary.hs
index 55742b55eb..c07b5d7d16 100644
--- a/compiler/GHC/Iface/Recomp/Binary.hs
+++ b/compiler/GHC/Iface/Recomp/Binary.hs
@@ -10,13 +10,13 @@ module GHC.Iface.Recomp.Binary
#include "HsVersions.h"
-import GhcPrelude
+import GHC.Prelude
-import Fingerprint
-import Binary
+import GHC.Utils.Fingerprint
+import GHC.Utils.Binary
import GHC.Types.Name
-import PlainPanic
-import Util
+import GHC.Utils.Panic.Plain
+import GHC.Utils.Misc
fingerprintBinMem :: BinHandle -> IO Fingerprint
fingerprintBinMem bh = withBinBuffer bh f
diff --git a/compiler/GHC/Iface/Recomp/Flags.hs b/compiler/GHC/Iface/Recomp/Flags.hs
index ff5b23b709..66b6b9f15f 100644
--- a/compiler/GHC/Iface/Recomp/Flags.hs
+++ b/compiler/GHC/Iface/Recomp/Flags.hs
@@ -8,18 +8,18 @@ module GHC.Iface.Recomp.Flags (
, fingerprintHpcFlags
) where
-import GhcPrelude
+import GHC.Prelude
-import Binary
+import GHC.Utils.Binary
import GHC.Driver.Session
import GHC.Driver.Types
import GHC.Types.Module
import GHC.Types.Name
-import Fingerprint
+import GHC.Utils.Fingerprint
import GHC.Iface.Recomp.Binary
--- import Outputable
+-- import GHC.Utils.Outputable
-import qualified EnumSet
+import GHC.Data.EnumSet as EnumSet
import System.FilePath (normalise)
-- | Produce a fingerprint of a @DynFlags@ value. We only base
diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs
index 6bceb1effb..dbe847b5f4 100644
--- a/compiler/GHC/Iface/Rename.hs
+++ b/compiler/GHC/Iface/Rename.hs
@@ -17,10 +17,10 @@ module GHC.Iface.Rename (
#include "HsVersions.h"
-import GhcPrelude
+import GHC.Prelude
import GHC.Types.SrcLoc
-import Outputable
+import GHC.Utils.Outputable
import GHC.Driver.Types
import GHC.Types.Module
import GHC.Types.Unique.FM
@@ -28,12 +28,12 @@ import GHC.Types.Avail
import GHC.Iface.Syntax
import GHC.Types.FieldLabel
import GHC.Types.Var
-import ErrUtils
+import GHC.Utils.Error
import GHC.Types.Name
import GHC.Tc.Utils.Monad
-import Util
-import Fingerprint
+import GHC.Utils.Misc
+import GHC.Utils.Fingerprint
import GHC.Types.Basic
-- a bit vexing
@@ -42,7 +42,7 @@ import GHC.Driver.Session
import qualified Data.Traversable as T
-import Bag
+import GHC.Data.Bag
import Data.IORef
import GHC.Types.Name.Shape
import GHC.Iface.Env
diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs
index 3c707bc348..9db82731d8 100644
--- a/compiler/GHC/Iface/Syntax.hs
+++ b/compiler/GHC/Iface/Syntax.hs
@@ -42,7 +42,7 @@ module GHC.Iface.Syntax (
#include "HsVersions.h"
-import GhcPrelude
+import GHC.Prelude
import GHC.Iface.Type
import GHC.Iface.Recomp.Binary
@@ -59,19 +59,19 @@ import GHC.Types.Literal
import GHC.Types.ForeignCall
import GHC.Types.Annotations( AnnPayload, AnnTarget )
import GHC.Types.Basic
-import Outputable
+import GHC.Utils.Outputable as Outputable
import GHC.Types.Module
import GHC.Types.SrcLoc
-import Fingerprint
-import Binary
-import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue )
+import GHC.Utils.Fingerprint
+import GHC.Utils.Binary
+import GHC.Data.BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue )
import GHC.Types.Var( VarBndr(..), binderVar )
import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag )
-import Util( dropList, filterByList, notNull, unzipWith, debugIsOn )
+import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith, debugIsOn )
import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..))
import GHC.Utils.Lexeme (isLexSym)
import GHC.Builtin.Types ( constraintKindTyConName )
-import Util (seqList)
+import GHC.Utils.Misc (seqList)
import Control.Monad
import System.IO.Unsafe
diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs
index 3fc645e278..e3c3c0b01c 100644
--- a/compiler/GHC/Iface/Tidy.hs
+++ b/compiler/GHC/Iface/Tidy.hs
@@ -14,7 +14,7 @@ module GHC.Iface.Tidy (
#include "HsVersions.h"
-import GhcPrelude
+import GHC.Prelude
import GHC.Tc.Types
import GHC.Driver.Session
@@ -30,7 +30,7 @@ import GHC.Core.Rules
import GHC.Core.PatSyn
import GHC.Core.ConLike
import GHC.Core.Arity ( exprArity, exprBotStrictness_maybe )
-import StaticPtrTable
+import GHC.Iface.Tidy.StaticPtrTable
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Var
@@ -54,11 +54,11 @@ import GHC.Core.TyCon
import GHC.Core.Class
import GHC.Types.Module
import GHC.Driver.Types
-import Maybes
+import GHC.Data.Maybe
import GHC.Types.Unique.Supply
-import Outputable
-import Util( filterOut )
-import qualified ErrUtils as Err
+import GHC.Utils.Outputable
+import GHC.Utils.Misc( filterOut )
+import qualified GHC.Utils.Error as Err
import Control.Monad
import Data.Function
@@ -378,7 +378,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
; (tidy_env, tidy_binds)
<- tidyTopBinds hsc_env unfold_env tidy_occ_env trimmed_binds
- -- See Note [Grand plan for static forms] in StaticPtrTable.
+ -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
; (spt_entries, tidy_binds') <-
sptCreateStaticBinds hsc_env mod tidy_binds
; let { spt_init_code = sptModuleInitCode mod spt_entries
diff --git a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs
new file mode 100644
index 0000000000..09125a4b53
--- /dev/null
+++ b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs
@@ -0,0 +1,294 @@
+-- | Code generation for the Static Pointer Table
+--
+-- (c) 2014 I/O Tweag
+--
+-- Each module that uses 'static' keyword declares an initialization function of
+-- the form hs_spt_init_<module>() which is emitted into the _stub.c file and
+-- annotated with __attribute__((constructor)) so that it gets executed at
+-- startup time.
+--
+-- The function's purpose is to call hs_spt_insert to insert the static
+-- pointers of this module in the hashtable of the RTS, and it looks something
+-- like this:
+--
+-- > static void hs_hpc_init_Main(void) __attribute__((constructor));
+-- > static void hs_hpc_init_Main(void) {
+-- >
+-- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL};
+-- > extern StgPtr Main_r2wb_closure;
+-- > hs_spt_insert(k0, &Main_r2wb_closure);
+-- >
+-- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};
+-- > extern StgPtr Main_r2wc_closure;
+-- > hs_spt_insert(k1, &Main_r2wc_closure);
+-- >
+-- > }
+--
+-- where the constants are fingerprints produced from the static forms.
+--
+-- The linker must find the definitions matching the @extern StgPtr <name>@
+-- declarations. For this to work, the identifiers of static pointers need to be
+-- exported. This is done in GHC.Core.Opt.SetLevels.newLvlVar.
+--
+-- There is also a finalization function for the time when the module is
+-- unloaded.
+--
+-- > static void hs_hpc_fini_Main(void) __attribute__((destructor));
+-- > static void hs_hpc_fini_Main(void) {
+-- >
+-- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL};
+-- > hs_spt_remove(k0);
+-- >
+-- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};
+-- > hs_spt_remove(k1);
+-- >
+-- > }
+--
+
+{-# LANGUAGE ViewPatterns, TupleSections #-}
+module GHC.Iface.Tidy.StaticPtrTable
+ ( sptCreateStaticBinds
+ , sptModuleInitCode
+ ) where
+
+{- Note [Grand plan for static forms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Static forms go through the compilation phases as follows.
+Here is a running example:
+
+ f x = let k = map toUpper
+ in ...(static k)...
+
+* The renamer looks for out-of-scope names in the body of the static
+ form, as always. If all names are in scope, the free variables of the
+ body are stored in AST at the location of the static form.
+
+* The typechecker verifies that all free variables occurring in the
+ static form are floatable to top level (see Note [Meaning of
+ IdBindingInfo] in GHC.Tc.Types). In our example, 'k' is floatable.
+ Even though it is bound in a nested let, we are fine.
+
+* The desugarer replaces the static form with an application of the
+ function 'makeStatic' (defined in module GHC.StaticPtr.Internal of
+ base). So we get
+
+ f x = let k = map toUpper
+ in ...fromStaticPtr (makeStatic location k)...
+
+* The simplifier runs the FloatOut pass which moves the calls to 'makeStatic'
+ to the top level. Thus the FloatOut pass is always executed, even when
+ optimizations are disabled. So we get
+
+ k = map toUpper
+ static_ptr = makeStatic location k
+ f x = ...fromStaticPtr static_ptr...
+
+ The FloatOut pass is careful to produce an /exported/ Id for a floated
+ 'makeStatic' call, so the binding is not removed or inlined by the
+ simplifier.
+ E.g. the code for `f` above might look like
+
+ static_ptr = makeStatic location k
+ f x = ...(case static_ptr of ...)...
+
+ which might be simplified to
+
+ f x = ...(case makeStatic location k of ...)...
+
+ BUT the top-level binding for static_ptr must remain, so that it can be
+ collected to populate the Static Pointer Table.
+
+ Making the binding exported also has a necessary effect during the
+ CoreTidy pass.
+
+* The CoreTidy pass replaces all bindings of the form
+
+ b = /\ ... -> makeStatic location value
+
+ with
+
+ b = /\ ... -> StaticPtr key (StaticPtrInfo "pkg key" "module" location) value
+
+ where a distinct key is generated for each binding.
+
+* If we are compiling to object code we insert a C stub (generated by
+ sptModuleInitCode) into the final object which runs when the module is loaded,
+ inserting the static forms defined by the module into the RTS's static pointer
+ table.
+
+* If we are compiling for the byte-code interpreter, we instead explicitly add
+ the SPT entries (recorded in CgGuts' cg_spt_entries field) to the interpreter
+ process' SPT table using the addSptEntry interpreter message. This happens
+ in upsweep after we have compiled the module (see GHC.Driver.Make.upsweep').
+-}
+
+import GHC.Prelude
+
+import GHC.Cmm.CLabel
+import GHC.Core
+import GHC.Core.Utils (collectMakeStaticArgs)
+import GHC.Core.DataCon
+import GHC.Driver.Session
+import GHC.Driver.Types
+import GHC.Types.Id
+import GHC.Core.Make (mkStringExprFSWith)
+import GHC.Types.Module
+import GHC.Types.Name
+import GHC.Utils.Outputable as Outputable
+import GHC.Platform
+import GHC.Builtin.Names
+import GHC.Tc.Utils.Env (lookupGlobal)
+import GHC.Core.Type
+
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.State
+import Data.List
+import Data.Maybe
+import GHC.Fingerprint
+import qualified GHC.LanguageExtensions as LangExt
+
+-- | Replaces all bindings of the form
+--
+-- > b = /\ ... -> makeStatic location value
+--
+-- with
+--
+-- > b = /\ ... ->
+-- > StaticPtr key (StaticPtrInfo "pkg key" "module" location) value
+--
+-- where a distinct key is generated for each binding.
+--
+-- It also yields the C stub that inserts these bindings into the static
+-- pointer table.
+sptCreateStaticBinds :: HscEnv -> Module -> CoreProgram
+ -> IO ([SptEntry], CoreProgram)
+sptCreateStaticBinds hsc_env this_mod binds
+ | not (xopt LangExt.StaticPointers dflags) =
+ return ([], binds)
+ | otherwise = do
+ -- Make sure the required interface files are loaded.
+ _ <- lookupGlobal hsc_env unpackCStringName
+ (fps, binds') <- evalStateT (go [] [] binds) 0
+ return (fps, binds')
+ where
+ go fps bs xs = case xs of
+ [] -> return (reverse fps, reverse bs)
+ bnd : xs' -> do
+ (fps', bnd') <- replaceStaticBind bnd
+ go (reverse fps' ++ fps) (bnd' : bs) xs'
+
+ dflags = hsc_dflags hsc_env
+ platform = targetPlatform dflags
+
+ -- Generates keys and replaces 'makeStatic' with 'StaticPtr'.
+ --
+ -- The 'Int' state is used to produce a different key for each binding.
+ replaceStaticBind :: CoreBind
+ -> StateT Int IO ([SptEntry], CoreBind)
+ replaceStaticBind (NonRec b e) = do (mfp, (b', e')) <- replaceStatic b e
+ return (maybeToList mfp, NonRec b' e')
+ replaceStaticBind (Rec rbs) = do
+ (mfps, rbs') <- unzip <$> mapM (uncurry replaceStatic) rbs
+ return (catMaybes mfps, Rec rbs')
+
+ replaceStatic :: Id -> CoreExpr
+ -> StateT Int IO (Maybe SptEntry, (Id, CoreExpr))
+ replaceStatic b e@(collectTyBinders -> (tvs, e0)) =
+ case collectMakeStaticArgs e0 of
+ Nothing -> return (Nothing, (b, e))
+ Just (_, t, info, arg) -> do
+ (fp, e') <- mkStaticBind t info arg
+ return (Just (SptEntry b fp), (b, foldr Lam e' tvs))
+
+ mkStaticBind :: Type -> CoreExpr -> CoreExpr
+ -> StateT Int IO (Fingerprint, CoreExpr)
+ mkStaticBind t srcLoc e = do
+ i <- get
+ put (i + 1)
+ staticPtrInfoDataCon <-
+ lift $ lookupDataConHscEnv staticPtrInfoDataConName
+ let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i
+ info <- mkConApp staticPtrInfoDataCon <$>
+ (++[srcLoc]) <$>
+ mapM (mkStringExprFSWith (lift . lookupIdHscEnv))
+ [ unitIdFS $ moduleUnitId this_mod
+ , moduleNameFS $ moduleName this_mod
+ ]
+
+ -- The module interface of GHC.StaticPtr should be loaded at least
+ -- when looking up 'fromStatic' during type-checking.
+ staticPtrDataCon <- lift $ lookupDataConHscEnv staticPtrDataConName
+ return (fp, mkConApp staticPtrDataCon
+ [ Type t
+ , mkWord64LitWordRep platform w0
+ , mkWord64LitWordRep platform w1
+ , info
+ , e ])
+
+ mkStaticPtrFingerprint :: Int -> Fingerprint
+ mkStaticPtrFingerprint n = fingerprintString $ intercalate ":"
+ [ unitIdString $ moduleUnitId this_mod
+ , moduleNameString $ moduleName this_mod
+ , show n
+ ]
+
+ -- Choose either 'Word64#' or 'Word#' to represent the arguments of the
+ -- 'Fingerprint' data constructor.
+ mkWord64LitWordRep platform =
+ case platformWordSize platform of
+ PW4 -> mkWord64LitWord64
+ PW8 -> mkWordLit platform . toInteger
+
+ lookupIdHscEnv :: Name -> IO Id
+ lookupIdHscEnv n = lookupTypeHscEnv hsc_env n >>=
+ maybe (getError n) (return . tyThingId)
+
+ lookupDataConHscEnv :: Name -> IO DataCon
+ lookupDataConHscEnv n = lookupTypeHscEnv hsc_env n >>=
+ maybe (getError n) (return . tyThingDataCon)
+
+ getError n = pprPanic "sptCreateStaticBinds.get: not found" $
+ text "Couldn't find" <+> ppr n
+
+-- | @sptModuleInitCode module fps@ is a C stub to insert the static entries
+-- of @module@ into the static pointer table.
+--
+-- @fps@ is a list associating each binding corresponding to a static entry with
+-- its fingerprint.
+sptModuleInitCode :: Module -> [SptEntry] -> SDoc
+sptModuleInitCode _ [] = Outputable.empty
+sptModuleInitCode this_mod entries = vcat
+ [ text "static void hs_spt_init_" <> ppr this_mod
+ <> text "(void) __attribute__((constructor));"
+ , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)"
+ , braces $ vcat $
+ [ text "static StgWord64 k" <> int i <> text "[2] = "
+ <> pprFingerprint fp <> semi
+ $$ text "extern StgPtr "
+ <> (ppr $ mkClosureLabel (idName n) (idCafInfo n)) <> semi
+ $$ text "hs_spt_insert" <> parens
+ (hcat $ punctuate comma
+ [ char 'k' <> int i
+ , char '&' <> ppr (mkClosureLabel (idName n) (idCafInfo n))
+ ]
+ )
+ <> semi
+ | (i, SptEntry n fp) <- zip [0..] entries
+ ]
+ , text "static void hs_spt_fini_" <> ppr this_mod
+ <> text "(void) __attribute__((destructor));"
+ , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)"
+ , braces $ vcat $
+ [ text "StgWord64 k" <> int i <> text "[2] = "
+ <> pprFingerprint fp <> semi
+ $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi
+ | (i, (SptEntry _ fp)) <- zip [0..] entries
+ ]
+ ]
+ where
+ pprFingerprint :: Fingerprint -> SDoc
+ pprFingerprint (Fingerprint w1 w2) =
+ braces $ hcat $ punctuate comma
+ [ integer (fromIntegral w1) <> text "ULL"
+ , integer (fromIntegral w2) <> text "ULL"
+ ]
diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs
index 6aedf0fd4c..5c2172f96f 100644
--- a/compiler/GHC/Iface/Type.hs
+++ b/compiler/GHC/Iface/Type.hs
@@ -60,7 +60,7 @@ module GHC.Iface.Type (
#include "HsVersions.h"
-import GhcPrelude
+import GHC.Prelude
import {-# SOURCE #-} GHC.Builtin.Types
( coercibleTyCon, heqTyCon
@@ -73,11 +73,11 @@ import GHC.Types.Var
import GHC.Builtin.Names
import GHC.Types.Name
import GHC.Types.Basic
-import Binary
-import Outputable
-import FastString
-import FastStringEnv
-import Util
+import GHC.Utils.Binary
+import GHC.Utils.Outputable
+import GHC.Data.FastString
+import GHC.Data.FastString.Env
+import GHC.Utils.Misc
import Data.Maybe( isJust )
import qualified Data.Semigroup as Semi
diff --git a/compiler/GHC/Iface/UpdateCafInfos.hs b/compiler/GHC/Iface/UpdateCafInfos.hs
new file mode 100644
index 0000000000..befb95c6ef
--- /dev/null
+++ b/compiler/GHC/Iface/UpdateCafInfos.hs
@@ -0,0 +1,148 @@
+{-# LANGUAGE CPP, BangPatterns, Strict, RecordWildCards #-}
+
+module GHC.Iface.UpdateCafInfos
+ ( updateModDetailsCafInfos
+ ) where
+
+import GHC.Prelude
+
+import GHC.Core
+import GHC.Driver.Session
+import GHC.Driver.Types
+import GHC.Types.Id
+import GHC.Types.Id.Info
+import GHC.Core.InstEnv
+import GHC.Types.Name.Env
+import GHC.Types.Name.Set
+import GHC.Utils.Misc
+import GHC.Types.Var
+import GHC.Utils.Outputable
+
+#include "HsVersions.h"
+
+-- | Update CafInfos of all occurences (in rules, unfoldings, class instances)
+updateModDetailsCafInfos
+ :: DynFlags
+ -> NameSet -- ^ Non-CAFFY names in the module. Names not in this set are CAFFY.
+ -> ModDetails -- ^ ModDetails to update
+ -> ModDetails
+
+updateModDetailsCafInfos dflags _ mod_details
+ | gopt Opt_OmitInterfacePragmas dflags
+ = mod_details
+
+updateModDetailsCafInfos _ non_cafs mod_details =
+ {- pprTrace "updateModDetailsCafInfos" (text "non_cafs:" <+> ppr non_cafs) $ -}
+ let
+ ModDetails{ md_types = type_env -- for unfoldings
+ , md_insts = insts
+ , md_rules = rules
+ } = mod_details
+
+ -- type TypeEnv = NameEnv TyThing
+ ~type_env' = mapNameEnv (updateTyThingCafInfos type_env' non_cafs) type_env
+ -- Not strict!
+
+ !insts' = strictMap (updateInstCafInfos type_env' non_cafs) insts
+ !rules' = strictMap (updateRuleCafInfos type_env') rules
+ in
+ mod_details{ md_types = type_env'
+ , md_insts = insts'
+ , md_rules = rules'
+ }
+
+--------------------------------------------------------------------------------
+-- Rules
+--------------------------------------------------------------------------------
+
+updateRuleCafInfos :: TypeEnv -> CoreRule -> CoreRule
+updateRuleCafInfos _ rule@BuiltinRule{} = rule
+updateRuleCafInfos 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)
+
+--------------------------------------------------------------------------------
+-- TyThings
+--------------------------------------------------------------------------------
+
+updateTyThingCafInfos :: TypeEnv -> NameSet -> TyThing -> TyThing
+
+updateTyThingCafInfos type_env non_cafs (AnId id) =
+ AnId (updateIdUnfolding type_env (updateIdCafInfo non_cafs id))
+
+updateTyThingCafInfos _ _ other = other -- AConLike, ATyCon, ACoAxiom
+
+--------------------------------------------------------------------------------
+-- Unfoldings
+--------------------------------------------------------------------------------
+
+updateIdUnfolding :: TypeEnv -> Id -> Id
+updateIdUnfolding type_env id =
+ case idUnfolding id of
+ CoreUnfolding{ .. } ->
+ setIdUnfolding id CoreUnfolding{ uf_tmpl = updateGlobalIds type_env uf_tmpl, .. }
+ DFunUnfolding{ .. } ->
+ setIdUnfolding id DFunUnfolding{ df_args = map (updateGlobalIds type_env) df_args, .. }
+ _ -> 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
+
+--------------------------------------------------------------------------------
+
+updateGlobalIds :: NameEnv TyThing -> CoreExpr -> CoreExpr
+-- Update occurrences of GlobalIds as directed by 'env'
+-- The 'env' maps a GlobalId to a version with accurate CAF info
+-- (and in due course perhaps other back-end-related info)
+updateGlobalIds env e = go env e
+ where
+ go_id :: NameEnv TyThing -> Id -> Id
+ go_id env var =
+ case lookupNameEnv env (varName var) of
+ Nothing -> var
+ Just (AnId id) -> id
+ Just other -> pprPanic "GHC.Iface.UpdateCafInfos.updateGlobalIds" $
+ text "Found a non-Id for Id Name" <+> ppr (varName var) $$
+ nest 4 (text "Id:" <+> ppr var $$
+ text "TyThing:" <+> ppr other)
+
+ go :: NameEnv TyThing -> CoreExpr -> CoreExpr
+ go env (Var v) = Var (go_id env v)
+ go _ e@Lit{} = e
+ go env (App e1 e2) = App (go env e1) (go env e2)
+ go env (Lam b e) = assertNotInNameEnv env [b] (Lam b (go env e))
+ go env (Let bs e) = Let (go_binds env bs) (go env e)
+ go env (Case e b ty alts) =
+ assertNotInNameEnv env [b] (Case (go env e) b ty (map go_alt alts))
+ where
+ go_alt (k,bs,e) = assertNotInNameEnv env bs (k, bs, go env e)
+ go env (Cast e c) = Cast (go env e) c
+ go env (Tick t e) = Tick t (go env e)
+ go _ e@Type{} = e
+ go _ e@Coercion{} = e
+
+ go_binds :: NameEnv TyThing -> CoreBind -> CoreBind
+ go_binds env (NonRec b e) =
+ assertNotInNameEnv env [b] (NonRec b (go env e))
+ go_binds env (Rec prs) =
+ assertNotInNameEnv env (map fst prs) (Rec (mapSnd (go env) prs))
+
+-- In `updateGlobaLIds` Names of local binders should not shadow Name of
+-- globals. This assertion is to check that.
+assertNotInNameEnv :: NameEnv a -> [Id] -> b -> b
+assertNotInNameEnv env ids x = ASSERT(not (any (\id -> elemNameEnv (idName id) env) ids)) x
View Lorry Controller Status