[Git][ghc/ghc][wip/T16846] 3 commits: testsuite: Add test for #16846
Ben Gamari
gitlab at gitlab.haskell.org
Fri Jun 21 20:36:10 UTC 2019
Ben Gamari pushed to branch wip/T16846 at Glasgow Haskell Compiler / GHC
Commits:
dec62d91 by Ben Gamari at 2019-06-21T20:33:49Z
testsuite: Add test for #16846
- - - - -
8b4b44bf by Ben Gamari at 2019-06-21T20:33:49Z
CoreToStg: Enable CAFfyness checking with -dstg-lint
The debugging involved in finding #16846 wouldn't have been necessary
had the consistentCafInfo check been enabled. However, :wq
- - - - -
0ccd5609 by Ben Gamari at 2019-06-21T20:33:49Z
Don't eta-expand unsaturated primops
Previously, as described in Note [Primop wrappers], `hasNoBinding` would
return False in the case of `PrimOpId`s. This would cause the
- - - - -
9 changed files:
- compiler/basicTypes/Id.hs
- compiler/basicTypes/Unique.hs
- compiler/prelude/PrelInfo.hs
- compiler/prelude/PrelNames.hs
- compiler/prelude/PrimOp.hs
- compiler/stgSyn/CoreToStg.hs
- + testsuite/tests/codeGen/should_run/T16846.hs
- + testsuite/tests/codeGen/should_run/T16846.stderr
- testsuite/tests/codeGen/should_run/all.T
Changes:
=====================================
compiler/basicTypes/Id.hs
=====================================
@@ -524,9 +524,13 @@ hasNoBinding :: Id -> Bool
-- Data constructor workers used to be things of this kind, but
-- they aren't any more. Instead, we inject a binding for
-- them at the CorePrep stage.
+--
+-- 'PrimOpId's also used to be of this kind. See Note [Primop wrappers]
+-- for the history of this.
+--
-- EXCEPT: unboxed tuples, which definitely have no binding
hasNoBinding id = case Var.idDetails id of
- PrimOpId _ -> True -- See Note [Primop wrappers]
+ PrimOpId _ -> False -- See Note [Primop wrappers]
FCallId _ -> True
DataConWorkId dc -> isUnboxedTupleCon dc || isUnboxedSumCon dc
_ -> isCompulsoryUnfolding (idUnfolding id)
@@ -573,13 +577,21 @@ simple way to fix #14561.
Note [Primop wrappers]
~~~~~~~~~~~~~~~~~~~~~~
-Currently hasNoBinding claims that PrimOpIds don't have a curried
-function definition. But actually they do, in GHC.PrimopWrappers,
-which is auto-generated from prelude/primops.txt.pp. So actually, hasNoBinding
-could return 'False' for PrimOpIds.
-
-But we'd need to add something in CoreToStg to swizzle any unsaturated
-applications of GHC.Prim.plusInt# to GHC.PrimopWrappers.plusInt#.
+Previously hasNoBinding would claim that PrimOpIds didn't have a curried
+function definition. This caused quite some trouble as we would be forced to
+eta expand unsaturated primop applications very late in the Core pipeline. Not
+only would this produce unnecessary thunks, but it would also result in nasty
+inconsistencies in CAFfy-ness determinations (see #16846).
+
+However, it was quite unnecessary for hasNoBinding to claim this; primops in
+fact *do* have curried definitions which are found in GHC.PrimopWrappers, which
+is auto-generated from prelude/primops.txt.pp.
+
+We now take advantage of these curried definitions by letting hasNoBinding
+claim that PrimOpIds have a curried definition and then rewrite any unsaturated
+PrimOpId applications that we find during CoreToStg as applications of the
+associated wrapper (e.g. `GHC.Prim.plusInt# 3#` will get rewritten to
+`GHC.PrimopWrappers.plusInt# 3#`).`
Nota Bene: GHC.PrimopWrappers is needed *regardless*, because it's
used by GHCi, which does not implement primops direct at all.
=====================================
compiler/basicTypes/Unique.hs
=====================================
@@ -46,7 +46,7 @@ module Unique (
-- now all the built-in Uniques (and functions to make them)
-- [the Oh-So-Wonderful Haskell module system wins again...]
mkAlphaTyVarUnique,
- mkPrimOpIdUnique,
+ mkPrimOpIdUnique, mkPrimOpWrapperUnique,
mkPreludeMiscIdUnique, mkPreludeDataConUnique,
mkPreludeTyConUnique, mkPreludeClassUnique,
mkCoVarUnique,
@@ -368,6 +368,8 @@ mkPreludeClassUnique :: Int -> Unique
mkPreludeTyConUnique :: Int -> Unique
mkPreludeDataConUnique :: Arity -> Unique
mkPrimOpIdUnique :: Int -> Unique
+-- See Note [Primop wrappers].
+mkPrimOpWrapperUnique :: Int -> Unique
mkPreludeMiscIdUnique :: Int -> Unique
mkCoVarUnique :: Int -> Unique
@@ -405,7 +407,8 @@ dataConWorkerUnique u = incrUnique u
dataConTyRepNameUnique u = stepUnique u 2
--------------------------------------------------
-mkPrimOpIdUnique op = mkUnique '9' op
+mkPrimOpIdUnique op = mkUnique '9' (2*op)
+mkPrimOpWrapperUnique op = mkUnique '9' (2*op+1)
mkPreludeMiscIdUnique i = mkUnique '0' i
-- The "tyvar uniques" print specially nicely: a, b, c, etc.
=====================================
compiler/prelude/PrelInfo.hs
=====================================
@@ -131,6 +131,7 @@ knownKeyNames
, map idName wiredInIds
, map (idName . primOpId) allThePrimOps
+ , map (idName . primOpWrapperId) allThePrimOps
, basicKnownKeyNames
, templateHaskellNames
]
=====================================
compiler/prelude/PrelNames.hs
=====================================
@@ -498,7 +498,8 @@ pRELUDE :: Module
pRELUDE = mkBaseModule_ pRELUDE_NAME
gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
- gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING,
+ gHC_CLASSES, gHC_PRIMOPWRAPPERS,
+ gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING,
gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE, gHC_INTEGER_TYPE, gHC_NATURAL,
gHC_LIST, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING,
dATA_FOLDABLE, dATA_TRAVERSABLE,
@@ -516,6 +517,7 @@ gHC_TYPES = mkPrimModule (fsLit "GHC.Types")
gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic")
gHC_CSTRING = mkPrimModule (fsLit "GHC.CString")
gHC_CLASSES = mkPrimModule (fsLit "GHC.Classes")
+gHC_PRIMOPWRAPPERS = mkPrimModule (fsLit "GHC.PrimopWrappers")
gHC_BASE = mkBaseModule (fsLit "GHC.Base")
gHC_ENUM = mkBaseModule (fsLit "GHC.Enum")
=====================================
compiler/prelude/PrimOp.hs
=====================================
@@ -13,6 +13,7 @@ module PrimOp (
PrimOp(..), PrimOpVecCat(..), allThePrimOps,
primOpType, primOpSig,
primOpTag, maxPrimOpTag, primOpOcc,
+ primOpWrapperId,
tagToEnumKey,
@@ -34,14 +35,18 @@ import TysWiredIn
import CmmType
import Demand
-import OccName ( OccName, pprOccName, mkVarOccFS )
+import Id ( Id, mkVanillaGlobalWithInfo )
+import IdInfo ( vanillaIdInfo, setCafInfo, CafInfo(NoCafRefs) )
+import Name
+import PrelNames ( gHC_PRIMOPWRAPPERS )
import TyCon ( TyCon, isPrimTyCon, PrimRep(..) )
import Type
import RepType ( typePrimRep1, tyConPrimRep1 )
import BasicTypes ( Arity, Fixity(..), FixityDirection(..), Boxity(..),
SourceText(..) )
+import SrcLoc ( wiredInSrcSpan )
import ForeignCall ( CLabelString )
-import Unique ( Unique, mkPrimOpIdUnique )
+import Unique ( Unique, mkPrimOpIdUnique, mkPrimOpWrapperUnique )
import Outputable
import FastString
import Module ( UnitId )
@@ -572,6 +577,15 @@ primOpOcc op = case primOpInfo op of
Compare occ _ -> occ
GenPrimOp occ _ _ _ -> occ
+-- | Returns the 'Id' of the wrapper associated with the given 'PrimOp'.
+primOpWrapperId :: PrimOp -> Id
+primOpWrapperId op = mkVanillaGlobalWithInfo name ty info
+ where
+ info = setCafInfo vanillaIdInfo NoCafRefs
+ name = mkExternalName uniq gHC_PRIMOPWRAPPERS (primOpOcc op) wiredInSrcSpan
+ uniq = mkPrimOpWrapperUnique (primOpTag op)
+ ty = primOpType op
+
isComparisonPrimOp :: PrimOp -> Bool
isComparisonPrimOp op = case primOpInfo op of
Compare {} -> True
=====================================
compiler/stgSyn/CoreToStg.hs
=====================================
@@ -45,7 +45,7 @@ import Util
import DynFlags
import ForeignCall
import Demand ( isUsedOnce )
-import PrimOp ( PrimCall(..) )
+import PrimOp ( PrimCall(..), primOpWrapperId )
import SrcLoc ( mkGeneralSrcSpan )
import Data.List.NonEmpty (nonEmpty, toList)
@@ -268,7 +268,7 @@ coreTopBindToStg dflags this_mod env ccs (NonRec id rhs)
bind = StgTopLifted $ StgNonRec id stg_rhs
in
- ASSERT2(consistentCafInfo id bind, ppr id )
+ assertConsistentCaInfo dflags id bind (ppr bind)
-- NB: previously the assertion printed 'rhs' and 'bind'
-- as well as 'id', but that led to a black hole
-- where printing the assertion error tripped the
@@ -296,9 +296,14 @@ coreTopBindToStg dflags this_mod env ccs (Rec pairs)
bind = StgTopLifted $ StgRec (zip binders stg_rhss)
in
- ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
+ assertConsistentCaInfo dflags (head binders) bind (ppr binders)
(env', ccs', bind)
+assertConsistentCaInfo :: DynFlags -> Id -> StgTopBinding -> SDoc -> a -> a
+assertConsistentCaInfo dflags id bind err_doc result
+ | gopt Opt_DoStgLinting dflags || debugIsOn
+ , not $ consistentCafInfo id bind = pprPanic "assertConsistentCaInfo" err_doc
+ | otherwise = result
-- Assertion helper: this checks that the CafInfo on the Id matches
-- what CoreToStg has figured out about the binding's SRT. The
@@ -528,8 +533,12 @@ coreToStgApp _ f args ticks = do
(dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty)))
-- Some primitive operator that might be implemented as a library call.
- PrimOpId op -> ASSERT( saturated )
- StgOpApp (StgPrimOp op) args' res_ty
+ -- As described in Note [Primop wrappers] we turn unsaturated
+ -- primop applications into applications of the primop's
+ -- wrapper here.
+ PrimOpId op
+ | saturated -> StgOpApp (StgPrimOp op) args' res_ty
+ | otherwise -> StgApp (primOpWrapperId op) args'
-- A call to some primitive Cmm function.
FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True)
=====================================
testsuite/tests/codeGen/should_run/T16846.hs
=====================================
@@ -0,0 +1,37 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ExistentialQuantification #-}
+module Main (main) where
+
+import Control.Concurrent.STM
+
+data Free f a = Pure a | Free (f (Free f a))
+
+data SuspendF a
+ = forall r. StepSTM (STM r)
+ | forall r. StepIO (IO r)
+
+effect :: STM a -> Free SuspendF a
+effect a = Free $ StepSTM a
+
+io :: IO a -> Free SuspendF a
+io a = Free $ StepIO a
+
+comb :: [Free SuspendF a] -> Free SuspendF a
+comb vs = io $ do
+ _ <- mapM go vs
+ undefined
+
+go :: Free SuspendF a -> IO (STM ())
+go (Free (StepIO a)) = a >>= \_ -> go $ Pure undefined
+go (Free (StepSTM a)) = pure $ a >>= \_ -> pure ()
+go (Pure _) = pure $ pure ()
+
+runWidget :: Free SuspendF a -> IO a
+runWidget w = case w of
+ Free (StepIO io) -> do
+ _ <- io
+ undefined
+
+-- Uncommenting this hid the original bug.
+--main :: IO ()
+main = runWidget $ comb $ replicate 10000000 (effect retry)
=====================================
testsuite/tests/codeGen/should_run/T16846.stderr
=====================================
@@ -0,0 +1,4 @@
+T16846: Prelude.undefined
+CallStack (from HasCallStack):
+ error, called at libraries/base/GHC/Err.hs:80:14 in base:GHC.Err
+ undefined, called at T16846.hs:22:3 in main:Main
=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -197,3 +197,4 @@ test('T15892',
compile_and_run, ['-O'])
test('T16617', normal, compile_and_run, [''])
test('T16449_2', exit_code(0), compile_and_run, [''])
+test('T16846', [only_ways(['optasm']), exit_code(1)], compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/c9acc317a9bab0ab39b35f81267ae27e725b4be2...0ccd5609e5a4ec6371928e8b94bff9976f819375
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/c9acc317a9bab0ab39b35f81267ae27e725b4be2...0ccd5609e5a4ec6371928e8b94bff9976f819375
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20190621/0e351c69/attachment-0001.html>
More information about the ghc-commits
mailing list