#14430: lintUnfolding does not allow unfoldings to jump to enclosing join points
-------------------------------------+-------------------------------------
Reporter: nomeata | Owner: (none)
Type: bug | Status: new
Priority: normal | Milestone:
Component: Compiler | Version: 8.3
Keywords: | Operating System: Unknown/Multiple
Architecture: | Type of failure: None/Unknown
Unknown/Multiple |
Test Case: | Blocked By:
Blocking: | Related Tickets:
Differential Rev(s): | Wiki Page:
-------------------------------------+-------------------------------------
I am not sure why this does not show up in HEAD but it does show up in my
loopification branch. It does look like a bug in GHC to me.
With loopification, I get the following code in the interface of
`Foreign.C.String`:
{{{
d5fd65f7834390bebd0e80edc7b8f627
withCAStringLen1 ::
String
-> (CStringLen -> IO a)
-> State# RealWorld
-> (# State# RealWorld, a #)
{- Arity: 3, HasNoCafRefs,
Strictness: ,
Unfolding: (\ @ a
(str :: String)
(f :: CStringLen -> IO a)
(eta :: State# RealWorld) ->
case lenAcc @ Char str newCAString2 of wild { I# x ->
case newAlignedPinnedByteArray#
@ RealWorld
x
1#
eta of ds2 { (#,#) ipv ipv1 ->
case unsafeFreezeByteArray#
@ RealWorld
ipv1
ipv of ds3 { (#,#) ipv2 ipv3 ->
let {
ptr :: Addr# = byteArrayContents# ipv3
} in
let {
$j :: State# RealWorld -> () -> (# State# RealWorld, a
#)
{- Arity: 2, Strictness: , Inline:
[0],
Unfolding: InlineRule (2, True, False)
(\ (w :: State# RealWorld) (w1
:: ()) ->
case (f (Ptr @ CChar ptr,
wild)) `cast` (N:IO[0] <a>_R)
w of ds4 { (#,#) ipv4
ipv5 ->
case touch#
@ 'UnliftedRep
@ ByteArray#
ipv3
ipv4 of s4 { DEFAULT
->
(# s4, ipv5 #) } }) -}
= \ (w :: State# RealWorld)[OneShot] (w1 ::
())[OneShot] ->
case (f (Ptr @ CChar ptr, wild)) `cast` (N:IO[0]
<a>_R)
w of ds4 { (#,#) ipv4 ipv5 ->
case touch#
@ 'UnliftedRep
@ ByteArray#
ipv3
ipv4 of s4 { DEFAULT ->
(# s4, ipv5 #) } }
} in
let {
go :: [Char]
-> Int -> State# RealWorld -> (# State#
RealWorld, a #)
{- Arity: 3, Strictness:
,
Inline: [~],
Unfolding: InlineRule (3, True, False)
(\ (ds :: [Char])[OneShot]
(n :: Int)[OneShot]
(eta1 :: State#
RealWorld)[OneShot] ->
letrec {
go :: [Char]
-> Int
-> State# RealWorld
-> (# State#
RealWorld, a #)
{- Arity: 3 -}
= \ (ds1 :: [Char])
(n1 :: Int)
(eta2 :: State#
RealWorld) ->
case ds1 of wild1 {
[] -> case n1 of n2 {
I# ipv4 -> $j eta2 () }
: c cs
-> case n1 of wild2 {
I# i ->
case c of wild3 { C#
c# ->
case
writeInt8OffAddr#
@ RealWorld
ptr
i
(narrow8Int#
(ord# c#))
eta2 of s2 {
DEFAULT ->
go cs (I# (+# i 1#))
s2 } } } }
} in
go ds n eta1) -}
= \ (ds :: [Char])[OneShot]
(n :: Int)[OneShot]
(eta1 :: State# RealWorld)[OneShot] ->
case n of ww { I# ww1 ->
let {
exit :: State# RealWorld -> (# State# RealWorld, a
#)
{- Arity: 1, Strictness: -}
= \ (w :: State# RealWorld)[OneShot] ->
case (f (Ptr @ CChar ptr, wild)) `cast` (N:IO[0]
<a>_R)
w of ds4 { (#,#) ipv4 ipv5 ->
case touch#
@ 'UnliftedRep
@ ByteArray#
ipv3
ipv4 of s4 { DEFAULT ->
(# s4, ipv5 #) } }
} in
letrec {
$wgo :: [Char]
-> Int# -> State# RealWorld -> (# State#
RealWorld, a #)
{- Arity: 3, Strictness:
, Inline: [0] -}
= \ (w :: [Char]) (ww2 :: Int#) (w1 :: State#
RealWorld) ->
case w of wild1 {
[] -> exit w1
: c cs
-> case c of wild2 { C# c# ->
case writeInt8OffAddr#
@ RealWorld
ptr
ww2
(narrow8Int# (ord# c#))
w1 of s2 { DEFAULT ->
$wgo cs (+# ww2 1#) s2 } } }
} in
$wgo ds ww1 eta1 }
} in
go str newCAString2 ipv2 } } }) -}
}}}
Note how `go` references `j` not only in its RHS, but also in its
unfolding.
When loading this interface, I get this error:
{{{
HC [stage 1] libraries/base/dist-install/build/System/Posix/Internals.o
ghc-stage1: panic! (the 'impossible' happened)
(GHC version 8.3.20171101 for x86_64-unknown-linux):
Iface Lint failure
In interface for Foreign.C.String
Unfolding of go_a6h7
<no location info>: warning:
In the expression: jump $j_a6gX eta2_a6hS ()
Invalid occurrence of a join variable: $j_a6gX
The binder is either not a join point, or not valid here
go_a6h7 = \ (ds_a6hM [OS=OneShot] :: [Char])
(n_a6hN [OS=OneShot] :: Int)
(eta1_a6hO [OS=OneShot] :: State# RealWorld) ->
joinrec {
go_a6hP
:: [Char]
-> Int -> State# RealWorld -> (# State# RealWorld,
a_a6gD #)
[LclId[JoinId(3)], Arity=3]
go_a6hP (ds1_a6hQ :: [Char])
(n1_a6hR :: Int)
(eta2_a6hS :: State# RealWorld)
= case ds1_a6hQ of wild1_a6hT {
[] ->
case n1_a6hR of n2_a6hW { I# ipv4_a6hY ->
jump $j_a6gX eta2_a6hS ()
};
: c_a6i1 cs_a6i2 ->
case n1_a6hR of wild2_a6i4 { I# i_a6i6 ->
case c_a6i1 of wild3_a6i8 { C# c#_a6ia ->
case writeInt8OffAddr#
@ RealWorld ptr_a6gT i_a6i6 (narrow8Int#
(ord# c#_a6ia)) eta2_a6hS
of s2_a6ic
{ __DEFAULT ->
jump go_a6hP cs_a6i2 (I# (+# i_a6i6 1#)) s2_a6ic
}
}
}
}; } in
jump go_a6hP ds_a6hM n_a6hN eta1_a6hO
Iface expr = \ (ds :: [Char])[OneShot]
(n :: Int)[OneShot]
(eta1 :: State# RealWorld)[OneShot] ->
letrec {
go :: [Char]
-> Int -> State# RealWorld -> (# State# RealWorld,
a #)
{- Arity: 3 -}
= \ (ds1 :: [Char]) (n1 :: Int) (eta2 :: State#
RealWorld) ->
case ds1 of wild1 {
[] -> case n1 of n2 { I# ipv4 -> $j eta2 () }
: c cs
-> case n1 of wild2 { I# i ->
case c of wild3 { C# c# ->
case writeInt8OffAddr#
@ RealWorld
ptr
i
(narrow8Int# (ord# c#))
eta2 of s2 { DEFAULT ->
go cs (I# (+# i 1#)) s2 } } } }
} in
go ds n eta1
Call stack:
CallStack (from HasCallStack):
callStackDoc, called at compiler/utils/Outputable.hs:1147:37 in
ghc:Outputable
pprPanic, called at compiler/iface/TcIface.hs:1664:33 in
ghc:TcIface
}}}
When reading the code in `tcPragExpr` I see that it lints the unfolding of
`go` using `lintUnfolding`, which initializes the `LintM` with an empty
`le_joins`. But when linting `go`, the join `j` is valid, even in the
unfolding, isn't it?
Unless of course I just don’t see the problem with the above unfolding,
and am barking up the wrong tree.
Anyways, either there is a problem in how we lint the unfoldings, or there
is a secret invariant that I violated with my patch
--
Ticket URL:
GHC
The Glasgow Haskell Compiler
