Revert "Have addModFinalizer expose the local type environment."
authorFacundo Domínguez <facundo.dominguez@tweag.io>
Fri, 6 Jan 2017 18:08:47 +0000 (15:08 -0300)
committerFacundo Domínguez <facundo.dominguez@tweag.io>
Fri, 6 Jan 2017 18:08:47 +0000 (15:08 -0300)
This reverts commit e5d1ed9c8910839e109da59820ca793642961284.

14 files changed:
compiler/coreSyn/CoreLint.hs
compiler/coreSyn/CoreUtils.hs
compiler/deSugar/DsExpr.hs
compiler/main/StaticPtrTable.hs
compiler/main/TidyPgm.hs
compiler/prelude/PrelNames.hs
compiler/simplCore/SetLevels.hs
compiler/simplCore/SimplCore.hs
libraries/base/GHC/StaticPtr/Internal.hs [deleted file]
libraries/base/base.cabal
testsuite/tests/codeGen/should_run/T12622.hs [deleted file]
testsuite/tests/codeGen/should_run/T12622.stdout [deleted file]
testsuite/tests/codeGen/should_run/T12622_A.hs [deleted file]
testsuite/tests/codeGen/should_run/all.T

index fa20070..1eacd73 100644 (file)
@@ -67,6 +67,7 @@ import Control.Monad
 import qualified Control.Monad.Fail as MonadFail
 #endif
 import MonadUtils
+import Data.Function (fix)
 import Data.Maybe
 import Pair
 import qualified GHC.LanguageExtensions as LangExt
@@ -389,12 +390,12 @@ lintCoreBindings dflags pass local_in_scope binds
                       _              -> True
 
     -- See Note [Checking StaticPtrs]
-    check_static_ptrs | not (xopt LangExt.StaticPointers dflags) = AllowAnywhere
-                      | otherwise = case pass of
-                          CoreDoFloatOutwards _ -> AllowAtTopLevel
-                          CoreTidy              -> RejectEverywhere
-                          CorePrep              -> AllowAtTopLevel
-                          _                     -> AllowAnywhere
+    check_static_ptrs = xopt LangExt.StaticPointers dflags &&
+                        case pass of
+                          CoreDoFloatOutwards _ -> True
+                          CoreTidy              -> True
+                          CorePrep              -> True
+                          _                     -> False
 
     binders = bindersOfBinds binds
     (_, dups) = removeDups compare binders
@@ -535,32 +536,28 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
                   | otherwise = return ()
 
 -- | Checks the RHS of top-level bindings. It only differs from 'lintCoreExpr'
--- in that it doesn't reject occurrences of the function 'makeStatic' when they
--- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@.
+-- in that it doesn't reject applications of the data constructor @StaticPtr@
+-- when they appear at the top level.
 --
 -- See Note [Checking StaticPtrs].
 lintRhs :: CoreExpr -> LintM OutType
-lintRhs rhs = fmap lf_check_static_ptrs getLintFlags >>= go
-  where
-    -- Allow occurrences of 'makeStatic' at the top-level but produce errors
-    -- otherwise.
-    go AllowAtTopLevel
-      | (binders0, rhs') <- collectTyBinders rhs
-      , Just (fun, t, info, e) <- collectMakeStaticArgs rhs'
-      = foldr
+-- Allow applications of the data constructor @StaticPtr@ at the top
+-- but produce errors otherwise.
+lintRhs rhs
+    | (binders0, rhs') <- collectTyBinders rhs
+    , Just (fun, args) <- collectStaticPtrSatArgs rhs'
+    = flip fix binders0 $ \loopBinders binders -> case binders of
         -- imitate @lintCoreExpr (Lam ...)@
-        (\var loopBinders ->
-          addLoc (LambdaBodyOf var) $
-            lintBinder var $ \var' ->
-              do { body_ty <- loopBinders
-                 ; return $ mkLamType var' body_ty }
-        )
+        var : vars -> addLoc (LambdaBodyOf var) $
+                      lintBinder var $ \var' ->
+                      do { body_ty <- loopBinders vars
+                         ; return $ mkLamType var' body_ty }
         -- imitate @lintCoreExpr (App ...)@
-        (do fun_ty <- lintCoreExpr fun
-            addLoc (AnExpr rhs') $ lintCoreArgs fun_ty [Type t, info, e]
-        )
-        binders0
-    go _ = lintCoreExpr rhs
+        [] -> do
+          fun_ty <- lintCoreExpr fun
+          addLoc (AnExpr rhs') $ lintCoreArgs fun_ty args
+-- Rejects applications of the data constructor @StaticPtr@ if it finds any.
+lintRhs rhs = lintCoreExpr rhs
 
 lintIdUnfolding :: Id -> Type -> Unfolding -> LintM ()
 lintIdUnfolding bndr bndr_ty (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
@@ -676,10 +673,11 @@ lintCoreExpr e@(App _ _)
          -- Check for a nested occurrence of the StaticPtr constructor.
          -- See Note [Checking StaticPtrs].
          case fun of
-           Var b | lf_check_static_ptrs lf /= AllowAnywhere
-                 , idName b == makeStaticName
+           Var b | lf_check_static_ptrs lf
+                 , Just con <- isDataConId_maybe b
+                 , dataConName con == staticPtrDataConName
                  -> do
-              failWithL $ text "Found makeStatic nested in an expression: " <+>
+              failWithL $ text "Found StaticPtr nested in an expression: " <+>
                           ppr e
            _     -> go
   where
@@ -1611,24 +1609,13 @@ data LintEnv
 data LintFlags
   = LF { lf_check_global_ids           :: Bool -- See Note [Checking for global Ids]
        , lf_check_inline_loop_breakers :: Bool -- See Note [Checking for INLINE loop breakers]
-       , lf_check_static_ptrs          :: StaticPtrCheck
-                                             -- ^ See Note [Checking StaticPtrs]
+       , lf_check_static_ptrs          :: Bool -- See Note [Checking StaticPtrs]
     }
 
--- See Note [Checking StaticPtrs]
-data StaticPtrCheck
-    = AllowAnywhere
-        -- ^ Allow 'makeStatic' to occur anywhere.
-    | AllowAtTopLevel
-        -- ^ Allow 'makeStatic' calls at the top-level only.
-    | RejectEverywhere
-        -- ^ Reject any 'makeStatic' occurrence.
-  deriving Eq
-
 defaultLintFlags :: LintFlags
 defaultLintFlags = LF { lf_check_global_ids = False
                       , lf_check_inline_loop_breakers = True
-                      , lf_check_static_ptrs = AllowAnywhere
+                      , lf_check_static_ptrs = False
                       }
 
 newtype LintM a =
@@ -1648,17 +1635,30 @@ Note [Checking StaticPtrs]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 See SimplCore Note [Grand plan for static forms] for an overview.
 
-Every occurrence of the function 'makeStatic' should be moved to the
-top level by the FloatOut pass.  It's vital that we don't have nested
-'makeStatic' occurrences after CorePrep, because we populate the Static
+Every occurrence of the data constructor @StaticPtr@ should be moved
+to the top level by the FloatOut pass.  It's vital that we don't have
+nested StaticPtr uses after CorePrep, because we populate the Static
 Pointer Table from the top-level bindings. See SimplCore Note [Grand
 plan for static forms].
 
 The linter checks that no occurrence is left behind, nested within an
-expression. The check is enabled only after the FloatOut, CorePrep,
-and CoreTidy passes and only if the module uses the StaticPointers
-language extension. Checking more often doesn't help since the condition
-doesn't hold until after the first FloatOut pass.
+expression. The check is enabled only:
+
+* After the FloatOut, CorePrep, and CoreTidy passes.
+  We could check more often, but the condition doesn't hold until
+  after the first FloatOut pass.
+
+* When the module uses the StaticPointers language extension. This is
+  a little hack.  This optimization arose from the need to compile
+  GHC.StaticPtr, which otherwise would be rejected because of the
+  following binding for the StaticPtr data constructor itself:
+
+    StaticPtr = \a b1 b2 b3 b4 -> StaticPtr a b1 b2 b3 b4
+
+  which contains an application of `StaticPtr` nested within the
+  lambda abstractions.  This binding is injected by CorePrep.
+
+  Note that GHC.StaticPtr is itself compiled without -XStaticPointers.
 
 Note [Type substitution]
 ~~~~~~~~~~~~~~~~~~~~~~~~
index 44d3dc6..c611e0b 100644 (file)
@@ -48,13 +48,13 @@ module CoreUtils (
         stripTicksE, stripTicksT,
 
         -- * StaticPtr
-        collectMakeStaticArgs
+        collectStaticPtrSatArgs
     ) where
 
 #include "HsVersions.h"
 
 import CoreSyn
-import PrelNames ( makeStaticName )
+import PrelNames ( staticPtrDataConName )
 import PprCore
 import CoreFVs( exprFreeVars )
 import Var
@@ -2217,13 +2217,16 @@ isEmptyTy ty
 *****************************************************
 -}
 
--- | @collectMakeStaticArgs (makeStatic t info e)@ yields
--- @Just (makeStatic, t, info, e)@.
+-- | @collectStaticPtrSatArgs e@ yields @Just (s, args)@ when @e = s args@
+-- and @s = StaticPtr@ and the application of @StaticPtr@ is saturated.
 --
--- Returns @Nothing@ for every other expression.
-collectMakeStaticArgs
-  :: CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr)
-collectMakeStaticArgs e
-    | (fun@(Var b), [Type t, info, arg], _) <- collectArgsTicks (const True) e
-    , idName b == makeStaticName = Just (fun, t, info, arg)
-collectMakeStaticArgs _          = Nothing
+-- Yields @Nothing@ otherwise.
+collectStaticPtrSatArgs :: Expr b -> Maybe (Expr b, [Arg b])
+collectStaticPtrSatArgs e
+    | (fun@(Var b), args, _) <- collectArgsTicks (const True) e
+    , Just con <- isDataConId_maybe b
+    , dataConName con == staticPtrDataConName
+    , length args == 5
+    = Just (fun, args)
+collectStaticPtrSatArgs _
+    = Nothing
index 9c0c175..214cb0b 100644 (file)
@@ -27,6 +27,7 @@ import FamInstEnv( topNormaliseType )
 import DsMeta
 import HsSyn
 
+import Platform
 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
 --     needs to see source types
 import TcType
@@ -55,7 +56,11 @@ import Bag
 import Outputable
 import PatSyn
 
+import Data.List        ( intercalate )
+import Data.IORef       ( atomicModifyIORef' )
+
 import Control.Monad
+import GHC.Fingerprint
 
 {-
 ************************************************************************
@@ -418,17 +423,24 @@ dsExpr (PArrSeq _ _)
 Static Pointers
 ~~~~~~~~~~~~~~~
 
-See Note [Grand plan for static forms] in SimplCore for an overview.
-
     g = ... static f ...
 ==>
-    g = ... makeStatic (StaticPtrInfo "pkg key" "module" loc) f ...
+    g = ... StaticPtr
+              w0 w1
+              (StaticPtrInfo "current pkg key" "current module" "N")
+              f
+        ...
+
+Where we obtain w0 and w1 from
+
+   Fingerprint w0 w1 = fingerprintString "pkgKey:module:N"
 -}
 
 dsExpr (HsStatic _ expr@(L loc _)) = do
     expr_ds <- dsLExpr expr
     let ty = exprType expr_ds
-    makeStaticId <- dsLookupGlobalId makeStaticName
+    staticPtrInfoDataCon <- dsLookupDataCon staticPtrInfoDataConName
+    staticPtrDataCon     <- dsLookupDataCon staticPtrDataConName
 
     dflags <- getDynFlags
     let (line, col) = case loc of
@@ -440,18 +452,48 @@ dsExpr (HsStatic _ expr@(L loc _)) = do
                      [ Type intTy              , Type intTy
                      , mkIntExprInt dflags line, mkIntExprInt dflags col
                      ]
-
     this_mod <- getModule
-    staticPtrInfoDataCon <- dsLookupDataCon staticPtrInfoDataConName
     info <- mkConApp staticPtrInfoDataCon <$>
             (++[srcLoc]) <$>
             mapM mkStringExprFS
                  [ unitIdFS $ moduleUnitId this_mod
                  , moduleNameFS $ moduleName this_mod
                  ]
-
+    Fingerprint w0 w1 <- mkStaticPtrFingerprint this_mod
     putSrcSpanDs loc $ return $
-      mkCoreApps (Var makeStaticId) [ Type ty, info, expr_ds ]
+      mkConApp staticPtrDataCon [ Type ty
+                                , mkWord64LitWordRep dflags w0
+                                , mkWord64LitWordRep dflags w1
+                                , info
+                                , expr_ds
+                                ]
+
+  where
+    -- | Choose either 'Word64#' or 'Word#' to represent the arguments of the
+    -- 'Fingerprint' data constructor.
+    mkWord64LitWordRep dflags
+      | platformWordSize (targetPlatform dflags) < 8 = mkWord64LitWord64
+      | otherwise = mkWordLit dflags . toInteger
+
+    mkStaticPtrFingerprint :: Module -> DsM Fingerprint
+    mkStaticPtrFingerprint this_mod = do
+      n <- mkGenPerModuleNum this_mod
+      return $ fingerprintString $ intercalate ":"
+        [ unitIdString $ moduleUnitId this_mod
+        , moduleNameString $ moduleName this_mod
+        , show n
+        ]
+
+    mkGenPerModuleNum :: Module -> DsM Int
+    mkGenPerModuleNum this_mod = do
+      dflags <- getDynFlags
+      let -- Note [Generating fresh names for ccall wrapper]
+          -- in compiler/typecheck/TcEnv.hs
+          wrapperRef = nextWrapperNum dflags
+      wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env ->
+        let num = lookupWithDefaultModuleEnv mod_env 0 this_mod
+         in (extendModuleEnv mod_env this_mod (num + 1), num)
+      return wrapperNum
 
 {-
 \noindent
index 694c874..9ec970f 100644 (file)
 --
 
 {-# LANGUAGE ViewPatterns #-}
-module StaticPtrTable (sptCreateStaticBinds) where
+module StaticPtrTable (sptModuleInitCode) where
 
--- See SimplCore Note [Grand plan for static forms] for an overview.
+-- See SimplCore Note [Grand plan for static forms]
 
 import CLabel
 import CoreSyn
-import CoreUtils (collectMakeStaticArgs)
 import DataCon
-import DynFlags
-import HscTypes
 import Id
+import Literal
 import Module
-import Name
 import Outputable
-import Platform
 import PrelNames
-import Type
 
-import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.State
-import Data.List
 import Data.Maybe
 import GHC.Fingerprint
 
--- | Replaces all bindings of the form
+-- | @sptModuleInitCode module binds@ is a C stub to insert the static entries
+-- found in @binds@ of @module@ into the static pointer table.
 --
--- > b = /\ ... -> makeStatic info value
+-- A bind is considered a static entry if it is an application of the
+-- data constructor @StaticPtr@.
 --
---  with
---
--- > b = /\ ... -> StaticPtr key info 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 (SDoc, CoreProgram)
-sptCreateStaticBinds hsc_env this_mod binds = do
-    (fps, binds') <- evalStateT (go [] [] binds) 0
-    return (sptModuleInitCode this_mod fps, binds')
+sptModuleInitCode :: Module -> CoreProgram -> SDoc
+sptModuleInitCode this_mod binds =
+    sptInitCode $ catMaybes
+                $ map (\(b, e) -> ((,) b) <$> staticPtrFp e)
+                $ flattenBinds 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'
-
-    -- 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 ([(Id, Fingerprint)], 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 (Id, Fingerprint), (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 (b, fp), (b, foldr Lam e' tvs))
-
-    mkStaticBind :: Type -> CoreExpr -> CoreExpr
-                 -> StateT Int IO (Fingerprint, CoreExpr)
-    mkStaticBind t info e = do
-      i <- get
-      put (i + 1)
-      let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i
-          dflags = hsc_dflags hsc_env
+    staticPtrFp :: CoreExpr -> Maybe Fingerprint
+    staticPtrFp (collectTyBinders -> (_, e))
+      | (Var v, _ : Lit lit0 : Lit lit1 : _) <- collectArgs e
+      , Just con <- isDataConId_maybe v
+      , dataConName con == staticPtrDataConName
+      , Just w0 <- fromPlatformWord64Rep lit0
+      , Just w1 <- fromPlatformWord64Rep lit1
+      = Just $ Fingerprint (fromInteger w0) (fromInteger w1)
+    staticPtrFp _ = Nothing
 
-      staticPtrDataCon <- lift $ lookupDataCon staticPtrDataConName
-      return (fp, mkConApp staticPtrDataCon
-                               [ Type t
-                               , mkWord64LitWordRep dflags w0
-                               , mkWord64LitWordRep dflags w1
-                               , info
-                               , e ])
+    fromPlatformWord64Rep (MachWord w)   = Just w
+    fromPlatformWord64Rep (MachWord64 w) = Just w
+    fromPlatformWord64Rep _              = Nothing
 
-    mkStaticPtrFingerprint :: Int -> Fingerprint
-    mkStaticPtrFingerprint n = fingerprintString $ intercalate ":"
-        [ unitIdString $ moduleUnitId this_mod
-        , moduleNameString $ moduleName this_mod
-        , show n
-        ]
+    sptInitCode :: [(Id, Fingerprint)] -> SDoc
+    sptInitCode [] = Outputable.empty
+    sptInitCode 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, (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, (_, fp)) <- zip [0..] entries
+          ]
+      ]
 
-    -- Choose either 'Word64#' or 'Word#' to represent the arguments of the
-    -- 'Fingerprint' data constructor.
-    mkWord64LitWordRep dflags
-      | platformWordSize (targetPlatform dflags) < 8 = mkWord64LitWord64
-      | otherwise = mkWordLit dflags . toInteger
-
-    lookupDataCon :: Name -> IO DataCon
-    lookupDataCon 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 -> [(Id, Fingerprint)] -> 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, (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, (_, fp)) <- zip [0..] entries
-        ]
-    ]
-  where
     pprFingerprint :: Fingerprint -> SDoc
     pprFingerprint (Fingerprint w1 w2) =
       braces $ hcat $ punctuate comma
index dc7813b..52137a4 100644 (file)
@@ -20,7 +20,7 @@ import CoreFVs
 import CoreTidy
 import CoreMonad
 import CorePrep
-import CoreUtils        (rhsIsStatic)
+import CoreUtils        (rhsIsStatic, collectStaticPtrSatArgs)
 import CoreStats        (coreBindsStats, CoreStats(..))
 import CoreLint
 import Literal
@@ -373,12 +373,12 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
               ; type_env2    = extendTypeEnvWithPatSyns tidy_patsyns type_env1
 
               ; tidy_type_env = tidyTypeEnv omit_prags type_env2
-              }
-            -- See SimplCore Note [Grand plan for static forms]
-        ; (spt_init_code, tidy_binds') <-
-             sptCreateStaticBinds hsc_env mod tidy_binds
-        ; let { -- See Note [Injecting implicit bindings]
-                all_tidy_binds = implicit_binds ++ tidy_binds'
+
+              -- See Note [Injecting implicit bindings]
+              ; all_tidy_binds = implicit_binds ++ tidy_binds
+
+              -- See SimplCore Note [Grand plan for static forms]
+              ; spt_init_code = sptModuleInitCode mod all_tidy_binds
 
               -- Get the TyCons to generate code for.  Careful!  We must use
               -- the untidied TypeEnv here, because we need
@@ -638,19 +638,27 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_
   -- same list every time this module is compiled), in contrast to the
   -- bindings, which are ordered non-deterministically.
   init_work_list = zip init_ext_ids init_ext_ids
-  init_ext_ids   = sortBy (compare `on` getOccName) $ filter is_external binders
+  init_ext_ids   = sortBy (compare `on` getOccName) $
+                   map fst $ filter is_external flatten_binds
 
   -- An Id should be external if either (a) it is exported,
   -- (b) it appears in the RHS of a local rule for an imported Id, or
-  -- (c) it is the vectorised version of an imported Id.
+  -- (c) it is the vectorised version of an imported Id, or
+  -- (d) it is a static pointer (see notes in StaticPtrTable.hs).
   -- See Note [Which rules to expose]
-  is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars
-                 || id `elemVarSet` vect_var_vs
+  is_external (id, e) = isExportedId id || id `elemVarSet` rule_rhs_vars
+                      || id `elemVarSet` vect_var_vs
+                      || isStaticPtrApp e
+
+  isStaticPtrApp :: CoreExpr -> Bool
+  isStaticPtrApp (collectTyBinders -> (_, e)) =
+    isJust $ collectStaticPtrSatArgs e
 
   rule_rhs_vars  = mapUnionVarSet ruleRhsFreeVars imp_id_rules
   vect_var_vs    = mkVarSet [var_v | (var, var_v) <- eltsUDFM vect_vars, isGlobalId var]
 
-  binders          = map fst $ flattenBinds binds
+  flatten_binds    = flattenBinds binds
+  binders          = map fst flatten_binds
   implicit_binders = bindersOfBinds implicit_binds
   binder_set       = mkVarSet binders
 
index e7ad536..41c9e36 100644 (file)
@@ -383,7 +383,6 @@ basicKnownKeyNames
         , ghciIoClassName, ghciStepIoMName
 
         -- StaticPtr
-        , makeStaticName
         , staticPtrTyConName
         , staticPtrDataConName, staticPtrInfoDataConName
         , fromStaticPtrName
@@ -522,9 +521,6 @@ gHC_STACK_TYPES = mkBaseModule (fsLit "GHC.Stack.Types")
 gHC_STATICPTR :: Module
 gHC_STATICPTR = mkBaseModule (fsLit "GHC.StaticPtr")
 
-gHC_STATICPTR_INTERNAL :: Module
-gHC_STATICPTR_INTERNAL = mkBaseModule (fsLit "GHC.StaticPtr.Internal")
-
 gHC_FINGERPRINT_TYPE :: Module
 gHC_FINGERPRINT_TYPE = mkBaseModule (fsLit "GHC.Fingerprint.Type")
 
@@ -1390,10 +1386,6 @@ frontendPluginTyConName :: Name
 frontendPluginTyConName = tcQual pLUGINS (fsLit "FrontendPlugin") frontendPluginTyConKey
 
 -- Static pointers
-makeStaticName :: Name
-makeStaticName =
-    varQual gHC_STATICPTR_INTERNAL (fsLit "makeStatic") makeStaticKey
-
 staticPtrInfoTyConName :: Name
 staticPtrInfoTyConName =
     tcQual gHC_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoTyConKey
@@ -2228,9 +2220,6 @@ pushCallStackKey  = mkPreludeMiscIdUnique 518
 fromStaticPtrClassOpKey :: Unique
 fromStaticPtrClassOpKey = mkPreludeMiscIdUnique 519
 
-makeStaticKey :: Unique
-makeStaticKey = mkPreludeMiscIdUnique 520
-
 {-
 ************************************************************************
 *                                                                      *
index 284bc4a..ff78015 100644 (file)
@@ -66,7 +66,7 @@ import CoreSyn
 import CoreMonad        ( FloatOutSwitches(..) )
 import CoreUtils        ( exprType
                         , exprOkForSpeculation
-                        , collectMakeStaticArgs
+                        , collectStaticPtrSatArgs
                         )
 import CoreArity        ( exprBotStrictness_maybe )
 import CoreFVs          -- all of it
@@ -1187,7 +1187,7 @@ newLvlVar lvld_rhs
 
     mk_id uniq rhs_ty
       -- See Note [Grand plan for static forms] in SimplCore.
-      | isJust $ collectMakeStaticArgs $ snd $
+      | isJust $ collectStaticPtrSatArgs $ snd $
         collectTyBinders de_tagged_rhs
       = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))
                             rhs_ty
index f049046..8e9a9c6 100644 (file)
@@ -1044,50 +1044,37 @@ Here is a running example:
   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
+  data constructor 'StaticPtr' (defined in module GHC.StaticPtr of
   base).  So we get
 
    f x = let k = map toUpper
-         in ...(makeStatic (StaticPtrInfo "pkg" "module" location) k)...
+         in ...(StaticPtr <fingerprint> 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
+* The simplifier runs the FloatOut pass which moves the applications
+  of 'StaticPtr' 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 info k
+   static_ptr = StaticPtr <fingerprint> k
    f x = ...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.
+  'StaticPtr', so the binding is not removed by the simplifier (see #12207).
   E.g. the code for `f` above might look like
 
-    static_ptr = makeStatic info k
-    f x = ...(case static_ptr of ...)...
+    static_ptr = StaticPtr <fingerprint> k
+    f x = ...(staticKey static_ptr)...
 
-  which might be simplified to
+  which might correctly be simplified to
 
-    f x = ...(case makeStatic info k of ...)...
+    f x = ...<fingerprint>...
 
   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 info value
-
-  with
-
-  b = /\ ... -> StaticPtr key info value
-
-  where a distinct key is generated for each binding.
-
-  We produce also a C function which inserts all these bindings in the static
-  pointer table (see the call to StaticPtrTable.sptCreateStaticBinds in
-  TidyPgm). As the Ids of floated static pointers are exported, they can be
-  linked with the C function.
+* The CoreTidy pass produces a C function which inserts all the
+  floated 'StaticPtr' in the static pointer table (see the call to
+  StaticPtrTable.sptModuleInitCode in TidyPgm). CoreTidy pass also
+  exports the Ids of floated 'StaticPtr's so they can be linked with
+  the C function.
 -}
diff --git a/libraries/base/GHC/StaticPtr/Internal.hs b/libraries/base/GHC/StaticPtr/Internal.hs
deleted file mode 100644 (file)
index e75dfe8..0000000
+++ /dev/null
@@ -1,24 +0,0 @@
--- |
--- Module      :  GHC.StaticPtr
--- Copyright   :  (C) 2016 I/O Tweag
--- License     :  see libraries/base/LICENSE
---
--- Maintainer  :  cvs-ghc@haskell.org
--- Stability   :  internal
--- Portability :  non-portable (GHC Extensions)
---
--- Internal definitions not to be used by the user of StaticPtr's.
-
--- By ignoring interface pragmas, we drop the stricness annotations
--- of 'error', which otherwise biase GHC to conclude that any code
--- using the static form would fail.
-{-# OPTIONS_GHC -fignore-interface-pragmas #-}
-module GHC.StaticPtr.Internal (makeStatic) where
-
-import GHC.StaticPtr(StaticPtr, StaticPtrInfo(..))
-
-{-# NOINLINE makeStatic #-}
-makeStatic :: StaticPtrInfo -> a -> StaticPtr a
-makeStatic (StaticPtrInfo pkg m (line, col)) _ =
-    error $ "makeStatic: Unresolved static form at " ++ pkg ++ ":" ++ m ++ ":"
-            ++ show line ++ ":" ++ show col
index a4f0c7d..22df434 100644 (file)
@@ -312,7 +312,6 @@ Library
         Data.Functor.Utils
         Data.OldList
         Foreign.ForeignPtr.Imp
-        GHC.StaticPtr.Internal
         System.Environment.ExecutablePath
         System.CPUTime.Utils
 
diff --git a/testsuite/tests/codeGen/should_run/T12622.hs b/testsuite/tests/codeGen/should_run/T12622.hs
deleted file mode 100644 (file)
index 81e5b04..0000000
+++ /dev/null
@@ -1,19 +0,0 @@
--- Test that static pointers still work when the users try
--- to unpack StaticPtr fields.
-{-# LANGUAGE StaticPointers #-}
-{-# LANGUAGE LambdaCase #-}
-
-import GHC.StaticPtr
-import T12622_A
-
-g = True
-
-main :: IO ()
-main = do
-  let T s = sg :: T (Bool -> Bool)
-  lookupKey s >>= \f -> print (f True)
-
-lookupKey :: StaticPtr a -> IO a
-lookupKey p = unsafeLookupStaticPtr (staticKey p) >>= \case
-  Just p -> return $ deRefStaticPtr p
-  Nothing -> error $ "couldn't find " ++ show (staticPtrInfo p)
diff --git a/testsuite/tests/codeGen/should_run/T12622.stdout b/testsuite/tests/codeGen/should_run/T12622.stdout
deleted file mode 100644 (file)
index 0ca9514..0000000
+++ /dev/null
@@ -1 +0,0 @@
-True
diff --git a/testsuite/tests/codeGen/should_run/T12622_A.hs b/testsuite/tests/codeGen/should_run/T12622_A.hs
deleted file mode 100644 (file)
index 6c85cc5..0000000
+++ /dev/null
@@ -1,15 +0,0 @@
--- A.hs
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE StaticPointers #-}
-module T12622_A where
-
-import Data.Typeable
-import GHC.StaticPtr
-
-g :: a -> Bool
-g _ = True
-
-data T a = T {-# UNPACK #-} !(StaticPtr a)
-
-sg :: Typeable a => T (a -> Bool)
-sg = T (static g)
index 5059cb4..3b02579 100644 (file)
@@ -146,7 +146,6 @@ test('PopCnt', omit_ways(['ghci']), multi_compile_and_run,
                  ['PopCnt', [('PopCnt_cmm.cmm', '')], ''])
 test('T12059', normal, compile_and_run, [''])
 test('T12433', normal, compile_and_run, [''])
-test('T12622', normal, multimod_compile_and_run, ['T12622', '-O'])
 test('T12757', normal, compile_and_run, [''])
 test('T12855', normal, compile_and_run, [''])
 test('T9577', [ unless(arch('x86_64') or arch('i386'),skip),