Desugar static forms to makeStatic calls.
authorFacundo Domínguez <facundo.dominguez@tweag.io>
Mon, 9 Jan 2017 17:29:32 +0000 (14:29 -0300)
committerFacundo Domínguez <facundo.dominguez@tweag.io>
Fri, 13 Jan 2017 20:37:25 +0000 (17:37 -0300)
Summary:
Using makeStatic instead of applications of the StaticPtr data
constructor makes possible linting core when unboxing strict
fields.

Test Plan: ./validate

Reviewers: simonpj, goldfire, austin, bgamari, hvr

Reviewed By: simonpj

Subscribers: RyanGlScott, mboes, thomie

Differential Revision: https://phabricator.haskell.org/D2930

GHC Trac Issues: #12622

16 files changed:
compiler/coreSyn/CoreLint.hs
compiler/coreSyn/CoreUtils.hs
compiler/coreSyn/MkCore.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
compiler/typecheck/TcExpr.hs
libraries/base/GHC/StaticPtr/Internal.hs [new file with mode: 0644]
libraries/base/base.cabal
testsuite/tests/codeGen/should_run/T12622.hs [new file with mode: 0644]
testsuite/tests/codeGen/should_run/T12622.stdout [new file with mode: 0644]
testsuite/tests/codeGen/should_run/T12622_A.hs [new file with mode: 0644]
testsuite/tests/codeGen/should_run/all.T

index 1eacd73..dd86ba5 100644 (file)
@@ -67,7 +67,6 @@ 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
@@ -390,12 +389,12 @@ lintCoreBindings dflags pass local_in_scope binds
                       _              -> True
 
     -- See Note [Checking StaticPtrs]
-    check_static_ptrs = xopt LangExt.StaticPointers dflags &&
-                        case pass of
-                          CoreDoFloatOutwards _ -> True
-                          CoreTidy              -> True
-                          CorePrep              -> True
-                          _                     -> False
+    check_static_ptrs | not (xopt LangExt.StaticPointers dflags) = AllowAnywhere
+                      | otherwise = case pass of
+                          CoreDoFloatOutwards _ -> AllowAtTopLevel
+                          CoreTidy              -> RejectEverywhere
+                          CorePrep              -> AllowAtTopLevel
+                          _                     -> AllowAnywhere
 
     binders = bindersOfBinds binds
     (_, dups) = removeDups compare binders
@@ -536,28 +535,32 @@ 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 applications of the data constructor @StaticPtr@
--- when they appear at the top level.
+-- in that it doesn't reject occurrences of the function 'makeStatic' when they
+-- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@.
 --
 -- See Note [Checking StaticPtrs].
 lintRhs :: CoreExpr -> LintM OutType
--- 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
+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
         -- imitate @lintCoreExpr (Lam ...)@
-        var : vars -> addLoc (LambdaBodyOf var) $
-                      lintBinder var $ \var' ->
-                      do { body_ty <- loopBinders vars
-                         ; return $ mkLamType var' body_ty }
+        (\var loopBinders ->
+          addLoc (LambdaBodyOf var) $
+            lintBinder var $ \var' ->
+              do { body_ty <- loopBinders
+                 ; return $ mkLamType var' body_ty }
+        )
         -- imitate @lintCoreExpr (App ...)@
-        [] -> 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
+        (do fun_ty <- lintCoreExpr fun
+            addLoc (AnExpr rhs') $ lintCoreArgs fun_ty [Type t, info, e]
+        )
+        binders0
+    go _ = lintCoreExpr rhs
 
 lintIdUnfolding :: Id -> Type -> Unfolding -> LintM ()
 lintIdUnfolding bndr bndr_ty (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
@@ -673,11 +676,10 @@ 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
-                 , Just con <- isDataConId_maybe b
-                 , dataConName con == staticPtrDataConName
+           Var b | lf_check_static_ptrs lf /= AllowAnywhere
+                 , idName b == makeStaticName
                  -> do
-              failWithL $ text "Found StaticPtr nested in an expression: " <+>
+              failWithL $ text "Found makeStatic nested in an expression: " <+>
                           ppr e
            _     -> go
   where
@@ -1609,13 +1611,24 @@ 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          :: Bool -- See Note [Checking StaticPtrs]
+       , lf_check_static_ptrs          :: StaticPtrCheck
+                                             -- ^ 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 = False
+                      , lf_check_static_ptrs = AllowAnywhere
                       }
 
 newtype LintM a =
@@ -1633,32 +1646,19 @@ top-level ones. See Note [Exported LocalIds] and Trac #9857.
 
 Note [Checking StaticPtrs]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
-See SimplCore Note [Grand plan for static forms] for an overview.
+See Note [Grand plan for static forms] in StaticPtrTable for an overview.
 
-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
+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
 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.
-  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.
+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.
 
 Note [Type substitution]
 ~~~~~~~~~~~~~~~~~~~~~~~~
index 8acd534..9616e8d 100644 (file)
@@ -48,13 +48,13 @@ module CoreUtils (
         stripTicksE, stripTicksT,
 
         -- * StaticPtr
-        collectStaticPtrSatArgs
+        collectMakeStaticArgs
     ) where
 
 #include "HsVersions.h"
 
 import CoreSyn
-import PrelNames ( staticPtrDataConName )
+import PrelNames ( makeStaticName )
 import PprCore
 import CoreFVs( exprFreeVars )
 import Var
@@ -2215,16 +2215,13 @@ isEmptyTy ty
 *****************************************************
 -}
 
--- | @collectStaticPtrSatArgs e@ yields @Just (s, args)@ when @e = s args@
--- and @s = StaticPtr@ and the application of @StaticPtr@ is saturated.
+-- | @collectMakeStaticArgs (makeStatic t srcLoc e)@ yields
+-- @Just (makeStatic, t, srcLoc, e)@.
 --
--- 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
+-- Returns @Nothing@ for every other expression.
+collectMakeStaticArgs
+  :: CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr)
+collectMakeStaticArgs e
+    | (fun@(Var b), [Type t, loc, arg], _) <- collectArgsTicks (const True) e
+    , idName b == makeStaticName = Just (fun, t, loc, arg)
+collectMakeStaticArgs _          = Nothing
index 77027fc..f28e1e9 100644 (file)
@@ -14,7 +14,7 @@ module MkCore (
         mkIntExpr, mkIntExprInt,
         mkIntegerExpr,
         mkFloatExpr, mkDoubleExpr,
-        mkCharExpr, mkStringExpr, mkStringExprFS,
+        mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith,
 
         -- * Floats
         FloatBind(..), wrapFloat,
@@ -270,16 +270,19 @@ mkStringExprFS :: MonadThings m => FastString -> m CoreExpr  -- Result :: String
 
 mkStringExpr str = mkStringExprFS (mkFastString str)
 
-mkStringExprFS str
+mkStringExprFS = mkStringExprFSWith lookupId
+
+mkStringExprFSWith :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr
+mkStringExprFSWith lookupM str
   | nullFS str
   = return (mkNilExpr charTy)
 
   | all safeChar chars
-  = do unpack_id <- lookupId unpackCStringName
+  = do unpack_id <- lookupM unpackCStringName
        return (App (Var unpack_id) lit)
 
   | otherwise
-  = do unpack_utf8_id <- lookupId unpackCStringUtf8Name
+  = do unpack_utf8_id <- lookupM unpackCStringUtf8Name
        return (App (Var unpack_utf8_id) lit)
 
   where
index 214cb0b..48aaacc 100644 (file)
@@ -27,7 +27,6 @@ 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
@@ -56,11 +55,7 @@ import Bag
 import Outputable
 import PatSyn
 
-import Data.List        ( intercalate )
-import Data.IORef       ( atomicModifyIORef' )
-
 import Control.Monad
-import GHC.Fingerprint
 
 {-
 ************************************************************************
@@ -423,24 +418,17 @@ dsExpr (PArrSeq _ _)
 Static Pointers
 ~~~~~~~~~~~~~~~
 
+See Note [Grand plan for static forms] in StaticPtrTable for an overview.
+
     g = ... static 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"
+    g = ... makeStatic loc f ...
 -}
 
 dsExpr (HsStatic _ expr@(L loc _)) = do
     expr_ds <- dsLExpr expr
     let ty = exprType expr_ds
-    staticPtrInfoDataCon <- dsLookupDataCon staticPtrInfoDataConName
-    staticPtrDataCon     <- dsLookupDataCon staticPtrDataConName
+    makeStaticId <- dsLookupGlobalId makeStaticName
 
     dflags <- getDynFlags
     let (line, col) = case loc of
@@ -452,48 +440,9 @@ dsExpr (HsStatic _ expr@(L loc _)) = do
                      [ Type intTy              , Type intTy
                      , mkIntExprInt dflags line, mkIntExprInt dflags col
                      ]
-    this_mod <- getModule
-    info <- mkConApp staticPtrInfoDataCon <$>
-            (++[srcLoc]) <$>
-            mapM mkStringExprFS
-                 [ unitIdFS $ moduleUnitId this_mod
-                 , moduleNameFS $ moduleName this_mod
-                 ]
-    Fingerprint w0 w1 <- mkStaticPtrFingerprint this_mod
-    putSrcSpanDs loc $ return $
-      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
+    putSrcSpanDs loc $ return $
+      mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ]
 
 {-
 \noindent
index 9ec970f..7a836e6 100644 (file)
@@ -28,7 +28,7 @@
 --
 -- 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 TidyPgm.chooseExternalIds.
+-- exported. This is done in SetLevels.newLvlVar.
 --
 -- There is also a finalization function for the time when the module is
 -- unloaded.
 --
 
 {-# LANGUAGE ViewPatterns #-}
-module StaticPtrTable (sptModuleInitCode) where
+module StaticPtrTable (sptCreateStaticBinds) where
 
--- See SimplCore Note [Grand plan for static forms]
+{- 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 closed (see Note [Bindings with closed types] in
+  TcRnTypes).  In our example, 'k' is closed, even though it is bound
+  in a nested let, we are fine.
+
+  The typechecker also surrounds the static form with a call to
+  `GHC.StaticPtr.fromStaticPtr`.
+
+   f x = let k = map toUpper
+         in ...fromStaticPtr (static k)...
+
+* 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.
+
+  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.
+-}
 
 import CLabel
 import CoreSyn
+import CoreUtils (collectMakeStaticArgs)
 import DataCon
+import DynFlags
+import HscTypes
 import Id
-import Literal
+import MkCore (mkStringExprFSWith)
 import Module
+import Name
 import Outputable
+import Platform
 import PrelNames
+import TcEnv (lookupGlobal)
+import 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
 
--- | @sptModuleInitCode module binds@ is a C stub to insert the static entries
--- found in @binds@ of @module@ into the static pointer table.
+-- | Replaces all bindings of the form
+--
+-- > b = /\ ... -> makeStatic location value
+--
+--  with
+--
+-- > b = /\ ... ->
+-- >   StaticPtr key (StaticPtrInfo "pkg key" "module" location) value
 --
--- A bind is considered a static entry if it is an application of the
--- data constructor @StaticPtr@.
+--  where a distinct key is generated for each binding.
 --
-sptModuleInitCode :: Module -> CoreProgram -> SDoc
-sptModuleInitCode this_mod binds =
-    sptInitCode $ catMaybes
-                $ map (\(b, e) -> ((,) b) <$> staticPtrFp e)
-                $ flattenBinds binds
+-- 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
+    | not (xopt LangExt.StaticPointers dflags) =
+      return (Outputable.empty, binds)
+    | otherwise = do
+      -- Make sure the required interface files are loaded.
+      _ <- lookupGlobal hsc_env unpackCStringName
+      (fps, binds') <- evalStateT (go [] [] binds) 0
+      return (sptModuleInitCode this_mod fps, binds')
   where
-    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
-
-    fromPlatformWord64Rep (MachWord w)   = Just w
-    fromPlatformWord64Rep (MachWord64 w) = Just w
-    fromPlatformWord64Rep _              = Nothing
-
-    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
-          ]
-      ]
+    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
+
+    -- 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 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 dflags w0
+                               , mkWord64LitWordRep dflags 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 dflags
+      | platformWordSize (targetPlatform dflags) < 8 = mkWord64LitWord64
+      | otherwise = mkWordLit dflags . 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 -> [(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 52137a4..cdf2aac 100644 (file)
@@ -20,7 +20,7 @@ import CoreFVs
 import CoreTidy
 import CoreMonad
 import CorePrep
-import CoreUtils        (rhsIsStatic, collectStaticPtrSatArgs)
+import CoreUtils        (rhsIsStatic)
 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 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
+              }
+          -- See Note [Grand plan for static forms] in StaticPtrTable.
+        ; (spt_init_code, tidy_binds') <-
+             sptCreateStaticBinds hsc_env mod tidy_binds
+        ; let { -- See Note [Injecting implicit bindings]
+                all_tidy_binds = implicit_binds ++ tidy_binds'
 
               -- Get the TyCons to generate code for.  Careful!  We must use
               -- the untidied TypeEnv here, because we need
@@ -638,27 +638,19 @@ 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) $
-                   map fst $ filter is_external flatten_binds
+  init_ext_ids   = sortBy (compare `on` getOccName) $ filter is_external binders
 
   -- 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, or
-  -- (d) it is a static pointer (see notes in StaticPtrTable.hs).
+  -- (c) it is the vectorised version of an imported Id.
   -- See Note [Which rules to expose]
-  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
+  is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars
+                 || id `elemVarSet` vect_var_vs
 
   rule_rhs_vars  = mapUnionVarSet ruleRhsFreeVars imp_id_rules
   vect_var_vs    = mkVarSet [var_v | (var, var_v) <- eltsUDFM vect_vars, isGlobalId var]
 
-  flatten_binds    = flattenBinds binds
-  binders          = map fst flatten_binds
+  binders          = map fst $ flattenBinds binds
   implicit_binders = bindersOfBinds implicit_binds
   binder_set       = mkVarSet binders
 
index 41c9e36..e7ad536 100644 (file)
@@ -383,6 +383,7 @@ basicKnownKeyNames
         , ghciIoClassName, ghciStepIoMName
 
         -- StaticPtr
+        , makeStaticName
         , staticPtrTyConName
         , staticPtrDataConName, staticPtrInfoDataConName
         , fromStaticPtrName
@@ -521,6 +522,9 @@ 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")
 
@@ -1386,6 +1390,10 @@ 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
@@ -2220,6 +2228,9 @@ pushCallStackKey  = mkPreludeMiscIdUnique 518
 fromStaticPtrClassOpKey :: Unique
 fromStaticPtrClassOpKey = mkPreludeMiscIdUnique 519
 
+makeStaticKey :: Unique
+makeStaticKey = mkPreludeMiscIdUnique 520
+
 {-
 ************************************************************************
 *                                                                      *
index ff78015..06ff71e 100644 (file)
@@ -66,7 +66,7 @@ import CoreSyn
 import CoreMonad        ( FloatOutSwitches(..) )
 import CoreUtils        ( exprType
                         , exprOkForSpeculation
-                        , collectStaticPtrSatArgs
+                        , collectMakeStaticArgs
                         )
 import CoreArity        ( exprBotStrictness_maybe )
 import CoreFVs          -- all of it
@@ -1186,8 +1186,8 @@ newLvlVar lvld_rhs
     rhs_ty        = exprType de_tagged_rhs
 
     mk_id uniq rhs_ty
-      -- See Note [Grand plan for static forms] in SimplCore.
-      | isJust $ collectStaticPtrSatArgs $ snd $
+      -- See Note [Grand plan for static forms] in StaticPtrTable.
+      | isJust $ collectMakeStaticArgs $ snd $
         collectTyBinders de_tagged_rhs
       = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))
                             rhs_ty
index 8e9a9c6..304dc5a 100644 (file)
@@ -205,7 +205,7 @@ getCoreToDo dflags
                            ))
 
     -- Static forms are moved to the top level with the FloatOut pass.
-    -- See Note [Grand plan for static forms].
+    -- See Note [Grand plan for static forms] in StaticPtrTable.
     static_ptrs_float_outwards =
       runWhen static_ptrs $ CoreDoFloatOutwards FloatOutSwitches
         { floatOutLambdas   = Just 0
@@ -267,7 +267,8 @@ getCoreToDo dflags
                 -- the simplifier.
         else
            -- Even with full laziness turned off, we still need to float static
-           -- forms to the top level. See Note [Grand plan for static forms].
+           -- forms to the top level. See Note [Grand plan for static forms] in
+           -- StaticPtrTable.
            static_ptrs_float_outwards,
 
         simpl_phases,
@@ -1024,57 +1025,3 @@ transferIdInfo exported_id local_id
                                (ruleInfo local_info)
         -- Remember to set the function-name field of the
         -- rules as we transfer them from one function to another
-
-
-{- 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 closed (see Note [Bindings with closed types] in
-  TcRnTypes).  In our example, 'k' is closed, even though it is bound
-  in a nested let, we are fine.
-
-* The desugarer replaces the static form with an application of the
-  data constructor 'StaticPtr' (defined in module GHC.StaticPtr of
-  base).  So we get
-
-   f x = let k = map toUpper
-         in ...(StaticPtr <fingerprint> k)...
-
-* 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 = StaticPtr <fingerprint> k
-   f x = ...static_ptr...
-
-  The FloatOut pass is careful to produce an /exported/ Id for a floated
-  'StaticPtr', so the binding is not removed by the simplifier (see #12207).
-  E.g. the code for `f` above might look like
-
-    static_ptr = StaticPtr <fingerprint> k
-    f x = ...(staticKey static_ptr)...
-
-  which might correctly be simplified to
-
-    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.
-
-* 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.
--}
index aa1dc34..71fe070 100644 (file)
@@ -581,6 +581,7 @@ tcExpr (HsProc pat cmd) res_ty
         ; return $ mkHsWrapCo coi (HsProc pat' cmd') }
 
 -- Typechecks the static form and wraps it with a call to 'fromStaticPtr'.
+-- See Note [Grand plan for static forms] in StaticPtrTable for an overview.
 tcExpr (HsStatic fvs expr) res_ty
   = do  { res_ty          <- expTypeToType res_ty
         ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty
diff --git a/libraries/base/GHC/StaticPtr/Internal.hs b/libraries/base/GHC/StaticPtr/Internal.hs
new file mode 100644 (file)
index 0000000..6605f39
--- /dev/null
@@ -0,0 +1,27 @@
+-- |
+-- 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 needed for compiling static forms.
+--
+
+-- By omitting interface pragmas, we drop the strictness annotations
+-- which otherwise would bias GHC to conclude that any code using
+-- the static form would fail.
+{-# OPTIONS_GHC -fomit-interface-pragmas #-}
+module GHC.StaticPtr.Internal (makeStatic) where
+
+import GHC.StaticPtr(StaticPtr)
+
+-- 'makeStatic' should never be called by the user.
+-- See Note [Grand plan for static forms] in StaticPtrTable.
+
+makeStatic :: (Int, Int) -> a -> StaticPtr a
+makeStatic (line, col) _ =
+    error $ "GHC bug - makeStatic: Unresolved static form at line "
+            ++ show line ++ ", column " ++ show col ++ "."
index 22df434..a4f0c7d 100644 (file)
@@ -312,6 +312,7 @@ 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
new file mode 100644 (file)
index 0000000..81e5b04
--- /dev/null
@@ -0,0 +1,19 @@
+-- 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
new file mode 100644 (file)
index 0000000..0ca9514
--- /dev/null
@@ -0,0 +1 @@
+True
diff --git a/testsuite/tests/codeGen/should_run/T12622_A.hs b/testsuite/tests/codeGen/should_run/T12622_A.hs
new file mode 100644 (file)
index 0000000..6c85cc5
--- /dev/null
@@ -0,0 +1,15 @@
+-- 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 3b02579..5059cb4 100644 (file)
@@ -146,6 +146,7 @@ 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),