I've compiled GHC from HEAD this morning, and it once again broke my OpenGL
binding. After boiling down the example (see attached Foo.hs), it seems that
either Storable itself, constant folding or the strictness analysis is buggy:
[EMAIL PROTECTED]:~> ./Foo
*** main 1
*** main 2
Foo: Prelude.undefined
I suspect that the "undefined" is the one in the default instance of
peekElemOff, but that is just guessing. GHC even goes so far to optimize away
the last putStrLn (see Foo.simpl). :-(
Cheers,
S.
import Foreign
-- Strangely enough, this works if newtype is used...
data Elem a = Elem a
instance Storable a => Storable (Elem a) where
sizeOf ~(Elem r) = 3 * sizeOf r
alignment ~(Elem r) = alignment r
peek ptr = do r <- peekElemOff (castPtr ptr) 0; return (Elem r)
poke ptr (Elem r) = poke (castPtr ptr) r
main :: IO ()
main = do
putStrLn "*** main 1"
allocaBytes 100 $ \buf -> do
poke buf (Elem 12345)
putStrLn "*** main 2"
Elem x <- peekElemOff buf 0
print (x :: Int)
putStrLn "*** main 3"
==================== Tidy Core ====================
Main.lvl :: [GHC.Base.Char]
[GlobalId]
[]
Main.lvl = GHC.Base.unpackCString# "*** main 2"
Main.lvl1 :: [GHC.Base.Char]
[GlobalId]
[]
Main.lvl1 = GHC.Base.unpackCString# "*** main 1"
Main.a :: GHC.Prim.State# GHC.Prim.RealWorld
-> (# GHC.Prim.State# GHC.Prim.RealWorld, () #)
[GlobalId]
[Arity 1
Str: DmdType L]
Main.a =
\ (eta_aJN :: GHC.Prim.State# GHC.Prim.RealWorld) ->
case ((GHC.IO.hPutStr GHC.Handle.stdout Main.lvl1)
`cast` ((GHC.IOBase.:CoIO) ()
:: GHC.IOBase.IO ()
:=:
GHC.Prim.State# GHC.Prim.RealWorld
-> (# GHC.Prim.State# GHC.Prim.RealWorld, () #)))
eta_aJN
of wild_aFw { (# new_s_aFy, a98_aFz #) ->
case GHC.IO.$whPutChar GHC.Handle.stdout '\n' new_s_aFy
of wild1_aID { (# new_s1_aIF, a981_aIG #) ->
case GHC.Prim.newPinnedByteArray# @ GHC.Prim.RealWorld 100 new_s1_aIF
of wild2_aSC { (# s_aSE, mbarr#_aSF #) ->
case GHC.Prim.unsafeFreezeByteArray# @ GHC.Prim.RealWorld mbarr#_aSF s_aSE
of wild11_aSH { (# s1_aSJ, barr#_aSK #) ->
case GHC.Prim.writeIntOffAddr#
@ GHC.Prim.RealWorld (GHC.Prim.byteArrayContents# barr#_aSK) 0 12345
s1_aSJ
of s2_aJd { __DEFAULT ->
case ((GHC.IO.hPutStr GHC.Handle.stdout Main.lvl)
`cast` ((GHC.IOBase.:CoIO) ()
:: GHC.IOBase.IO ()
:=:
GHC.Prim.State# GHC.Prim.RealWorld
-> (# GHC.Prim.State# GHC.Prim.RealWorld, () #)))
s2_aJd
of wild3_XGu { (# new_s2_XGx, a982_XGz #) ->
case GHC.IO.$whPutChar GHC.Handle.stdout '\n' new_s2_XGx
of wild4_XKC { (# new_s3_XKF, a983_XKH #) ->
GHC.Err.undefined
`cast` (CoUnsafe (forall a_az9. a_az9)
(# GHC.Prim.State# GHC.Prim.RealWorld, () #)
:: forall a_az9. a_az9 :=: (# GHC.Prim.State# GHC.Prim.RealWorld,
() #))
}
}
}
}
}
}
}
Main.poke :: GHC.Ptr.Ptr (Main.Elem GHC.Base.Int)
-> Main.Elem GHC.Base.Int
-> GHC.IOBase.IO ()
[GlobalId]
[Arity 3
NoCafRefs
Str: DmdType U(L)U(U(L))L]
Main.poke =
\ (ptr_abO :: GHC.Ptr.Ptr (Main.Elem GHC.Base.Int))
(ds_dxP :: Main.Elem GHC.Base.Int) ->
(\ (eta_sJg :: GHC.Prim.State# GHC.Prim.RealWorld) ->
case ds_dxP of wild_B1 { Main.Elem r_abP ->
case ptr_abO of wild1_ay0 { GHC.Ptr.Ptr addr_ay2 ->
case r_abP of wild2_aJ9 { GHC.Base.I# x_aJb ->
case GHC.Prim.writeIntOffAddr# @ GHC.Prim.RealWorld addr_ay2 0 x_aJb
eta_sJg
of s2_aJd { __DEFAULT ->
(# s2_aJd, GHC.Base.() #)
}
}
}
})
`cast` (sym ((GHC.IOBase.:CoIO) ())
:: GHC.Prim.State# GHC.Prim.RealWorld
-> (# GHC.Prim.State# GHC.Prim.RealWorld, () #)
:=:
GHC.IOBase.IO ())
Main.peek :: GHC.Ptr.Ptr (Main.Elem GHC.Base.Int)
-> GHC.IOBase.IO (Main.Elem GHC.Base.Int)
[GlobalId]
[Arity 2
NoCafRefs
Str: DmdType U(L)L]
Main.peek =
\ (ptr_abK :: GHC.Ptr.Ptr (Main.Elem GHC.Base.Int)) ->
(\ (s_aIC :: GHC.Prim.State# GHC.Prim.RealWorld) ->
case ptr_abK of wild_ay0 { GHC.Ptr.Ptr addr_ay2 ->
case GHC.Prim.readIntOffAddr# @ GHC.Prim.RealWorld addr_ay2 0 s_aIC
of wild2_aIT { (# s2_aIV, x_aIW #) ->
(# s2_aIV, (Main.Elem @ GHC.Base.Int (GHC.Base.I# x_aIW)) #)
}
})
`cast` (sym ((GHC.IOBase.:CoIO) (Main.Elem GHC.Base.Int))
:: GHC.Prim.State# GHC.Prim.RealWorld
-> (# GHC.Prim.State# GHC.Prim.RealWorld, Main.Elem GHC.Base.Int
#)
:=:
GHC.IOBase.IO (Main.Elem GHC.Base.Int))
Main.alignment :: Main.Elem GHC.Base.Int -> GHC.Base.Int
[GlobalId]
[Arity 1
NoCafRefs
Str: DmdType U(A)m]
Main.alignment =
\ (ds_dxK :: Main.Elem GHC.Base.Int) ->
case ds_dxK of wild_B1 { Main.Elem r_abI -> Foreign.Storable.lvl }
Main.lvl2 :: GHC.Base.Int
[GlobalId]
[NoCafRefs]
Main.lvl2 = GHC.Base.I# 24
Main.sizeOf :: Main.Elem GHC.Base.Int -> GHC.Base.Int
[GlobalId]
[Arity 1
NoCafRefs
Str: DmdType U(A)m]
Main.sizeOf =
\ (ds_dxC :: Main.Elem GHC.Base.Int) ->
case ds_dxC of wild_B1 { Main.Elem r_aa8 -> Main.lvl2 }
Main.peekByteOff :: forall b_avX.
GHC.Ptr.Ptr b_avX -> GHC.Base.Int -> GHC.IOBase.IO
(Main.Elem GHC.Base.Int)
[GlobalId]
[Arity 3
NoCafRefs
Str: DmdType U(L)U(L)L]
Main.peekByteOff =
\ (@ b_awy) (ptr_azz :: GHC.Ptr.Ptr b_awy) (off_azA :: GHC.Base.Int) ->
(\ (s_aIC :: GHC.Prim.State# GHC.Prim.RealWorld) ->
case ptr_azz of wild_aJl { GHC.Ptr.Ptr addr_aJn ->
case off_azA of wild1_aJp { GHC.Base.I# d_aJr ->
case GHC.Prim.readIntOffAddr#
@ GHC.Prim.RealWorld (GHC.Prim.plusAddr# addr_aJn d_aJr) 0 s_aIC
of wild2_aIT { (# s2_aIV, x_aIW #) ->
(# s2_aIV, (Main.Elem @ GHC.Base.Int (GHC.Base.I# x_aIW)) #)
}
}
})
`cast` (sym ((GHC.IOBase.:CoIO) (Main.Elem GHC.Base.Int))
:: GHC.Prim.State# GHC.Prim.RealWorld
-> (# GHC.Prim.State# GHC.Prim.RealWorld, Main.Elem GHC.Base.Int
#)
:=:
GHC.IOBase.IO (Main.Elem GHC.Base.Int))
Main.pokeByteOff :: forall b_avZ.
GHC.Ptr.Ptr b_avZ -> GHC.Base.Int -> Main.Elem GHC.Base.Int
-> GHC.IOBase.IO ()
[GlobalId]
[Arity 2
NoCafRefs
Str: DmdType LL]
Main.pokeByteOff =
\ (@ b_awE) (ptr_azh :: GHC.Ptr.Ptr b_awE) (off_azi :: GHC.Base.Int) ->
let {
ptr1_sW1 [Just D(L)] :: GHC.Ptr.Ptr (Main.Elem GHC.Base.Int)
[Str: DmdType]
ptr1_sW1 = GHC.Ptr.plusPtr @ b_awE @ (Main.Elem GHC.Base.Int) ptr_azh
off_azi
} in
\ (ds_dxP :: Main.Elem GHC.Base.Int) ->
(\ (eta_sJg :: GHC.Prim.State# GHC.Prim.RealWorld) ->
case ds_dxP of wild_B1 { Main.Elem r_abP ->
case ptr1_sW1 of wild1_ay0 { GHC.Ptr.Ptr addr_ay2 ->
case r_abP of wild2_aJ9 { GHC.Base.I# x_aJb ->
case GHC.Prim.writeIntOffAddr# @ GHC.Prim.RealWorld addr_ay2 0 x_aJb
eta_sJg
of s2_aJd { __DEFAULT ->
(# s2_aJd, GHC.Base.() #)
}
}
}
})
`cast` (sym ((GHC.IOBase.:CoIO) ())
:: GHC.Prim.State# GHC.Prim.RealWorld
-> (# GHC.Prim.State# GHC.Prim.RealWorld, () #)
:=:
GHC.IOBase.IO ())
Main.$dmpeekElemOff :: GHC.Ptr.Ptr (Main.Elem GHC.Base.Int)
-> GHC.Base.Int
-> GHC.IOBase.IO (Main.Elem GHC.Base.Int)
[GlobalId]
[Arity 3
Str: DmdType U(A)U(A)Ab]
Main.$dmpeekElemOff =
\ (ptr_ayD :: GHC.Ptr.Ptr (Main.Elem GHC.Base.Int)) (off_ayE :: GHC.Base.Int)
->
(\ (eta_sJB :: GHC.Prim.State# GHC.Prim.RealWorld) ->
case ptr_ayD of wild_aJl { GHC.Ptr.Ptr addr_aJn ->
case off_ayE of wild1_ayQ { GHC.Base.I# x_ayS ->
GHC.Err.undefined
`cast` (CoUnsafe (forall a_az9. a_az9)
(# GHC.Prim.State# GHC.Prim.RealWorld, Main.Elem
GHC.Base.Int #)
:: forall a_az9. a_az9
:=:
(# GHC.Prim.State# GHC.Prim.RealWorld, Main.Elem GHC.Base.Int
#))
}
})
`cast` (sym ((GHC.IOBase.:CoIO) (Main.Elem GHC.Base.Int))
:: GHC.Prim.State# GHC.Prim.RealWorld
-> (# GHC.Prim.State# GHC.Prim.RealWorld, Main.Elem GHC.Base.Int
#)
:=:
GHC.IOBase.IO (Main.Elem GHC.Base.Int))
Main.$dmpokeElemOff :: GHC.Ptr.Ptr (Main.Elem GHC.Base.Int)
-> GHC.Base.Int
-> Main.Elem GHC.Base.Int
-> GHC.IOBase.IO ()
[GlobalId]
[Arity 4
NoCafRefs
Str: DmdType U(L)U(L)U(U(L))L]
Main.$dmpokeElemOff =
\ (ptr_ayf :: GHC.Ptr.Ptr (Main.Elem GHC.Base.Int))
(off_ayg :: GHC.Base.Int)
(val_ayh :: Main.Elem GHC.Base.Int) ->
(\ (eta_sTo :: GHC.Prim.State# GHC.Prim.RealWorld) ->
case val_ayh of wild_B1 { Main.Elem r_abP ->
case ptr_ayf of wild1_aJl { GHC.Ptr.Ptr addr_aJn ->
case off_ayg of wild2_ayt { GHC.Base.I# x_ayv ->
case r_abP of wild21_aJ9 { GHC.Base.I# x1_aJb ->
case GHC.Prim.writeIntOffAddr#
@ GHC.Prim.RealWorld
(GHC.Prim.plusAddr# addr_aJn (GHC.Prim.*# x_ayv 24))
0
x1_aJb
eta_sTo
of s2_aJd { __DEFAULT ->
(# s2_aJd, GHC.Base.() #)
}
}
}
}
})
`cast` (sym ((GHC.IOBase.:CoIO) ())
:: GHC.Prim.State# GHC.Prim.RealWorld
-> (# GHC.Prim.State# GHC.Prim.RealWorld, () #)
:=:
GHC.IOBase.IO ())
Main.$dStorable :: Foreign.Storable.Storable (Main.Elem GHC.Base.Int)
[GlobalId]
[Str: DmdType m]
Main.$dStorable =
Foreign.Storable.:DStorable
@ (Main.Elem GHC.Base.Int)
Main.sizeOf
Main.alignment
Main.$dmpeekElemOff
Main.$dmpokeElemOff
Main.peekByteOff
Main.pokeByteOff
Main.peek
Main.poke
Main.main :: GHC.IOBase.IO ()
[GlobalId]
[Arity 1
Str: DmdType L]
Main.main =
Main.a
`cast` (sym ((GHC.IOBase.:CoIO) ())
:: GHC.Prim.State# GHC.Prim.RealWorld
-> (# GHC.Prim.State# GHC.Prim.RealWorld, () #)
:=:
GHC.IOBase.IO ())
Main.$f1 :: forall a_aa6.
(Foreign.Storable.Storable a_aa6) =>
Foreign.Storable.Storable (Main.Elem a_aa6)
[GlobalId]
[Arity 1
Str: DmdType Lm]
Main.$f1 =
__inline_me (\ (@ a_aa6) ($dStorable1_avR :: Foreign.Storable.Storable a_aa6)
->
let {
sizeOf1_sHj :: Main.Elem a_aa6 -> GHC.Base.Int
[Arity 1
Str: DmdType U(L)]
sizeOf1_sHj =
\ (ds_dxC :: Main.Elem a_aa6) ->
case ds_dxC of wild_B1 { Main.Elem r_aa8 ->
GHC.Num.*
@ GHC.Base.Int
GHC.Num.$f6
(GHC.Base.I# 3)
(Foreign.Storable.sizeOf @ a_aa6 $dStorable1_avR r_aa8)
} } in
let {
alignment1_sHk :: Main.Elem a_aa6 -> GHC.Base.Int
[Arity 1
Str: DmdType U(L) {avR->U(ASAAAAAA)}]
alignment1_sHk =
\ (ds_dxK :: Main.Elem a_aa6) ->
case ds_dxK of wild_B1 { Main.Elem r_abI ->
Foreign.Storable.alignment @ a_aa6 $dStorable1_avR r_abI
} } in
let {
peek1_sHl :: GHC.Ptr.Ptr (Main.Elem a_aa6) -> GHC.IOBase.IO
(Main.Elem a_aa6)
[Arity 1
Str: DmdType L]
peek1_sHl =
\ (ptr_abK :: GHC.Ptr.Ptr (Main.Elem a_aa6)) ->
GHC.Base.>>=
@ GHC.IOBase.IO
GHC.IOBase.$f16
@ a_aa6
@ (Main.Elem a_aa6)
(Foreign.Storable.peekElemOff
@ a_aa6
$dStorable1_avR
(GHC.Ptr.castPtr @ (Main.Elem a_aa6) @ a_aa6
ptr_abK)
(GHC.Base.I# 0))
(\ (r_abM :: a_aa6) ->
GHC.Base.return
@ GHC.IOBase.IO
GHC.IOBase.$f16
@ (Main.Elem a_aa6)
(Main.Elem @ a_aa6 r_abM)) } in
let {
poke1_sHm :: GHC.Ptr.Ptr (Main.Elem a_aa6)
-> Main.Elem a_aa6
-> GHC.IOBase.IO ()
[Arity 2
Str: DmdType LU(L) {avR->U(AAAAAAAS)}]
poke1_sHm =
\ (ptr_abO :: GHC.Ptr.Ptr (Main.Elem a_aa6)) (ds_dxP ::
Main.Elem a_aa6) ->
case ds_dxP of wild_B1 { Main.Elem r_abP ->
Foreign.Storable.poke
@ a_aa6
$dStorable1_avR
(GHC.Ptr.castPtr @ (Main.Elem a_aa6) @ a_aa6 ptr_abO)
r_abP
} } in
__letrec {
$dStorable2_sHe :: Foreign.Storable.Storable (Main.Elem
a_aa6)
[Str: DmdType m]
$dStorable2_sHe =
Foreign.Storable.:DStorable
@ (Main.Elem a_aa6)
sizeOf1_sHj
alignment1_sHk
$dmpeekElemOff1_sHg
$dmpokeElemOff1_sHf
peekByteOff1_sHi
pokeByteOff1_sHh
peek1_sHl
poke1_sHm;
peekByteOff1_sHi :: forall b_avX.
GHC.Ptr.Ptr b_avX -> GHC.Base.Int ->
GHC.IOBase.IO (Main.Elem a_aa6)
[Arity 2
Str: DmdType LL {sHe->U(AAAAAAC(S)A)}]
peekByteOff1_sHi =
\ (@ b_awy) ->
Foreign.Storable.$dmpeekByteOff @ (Main.Elem a_aa6)
$dStorable2_sHe @ b_awy;
pokeByteOff1_sHh :: forall b_avZ.
GHC.Ptr.Ptr b_avZ -> GHC.Base.Int ->
Main.Elem a_aa6 -> GHC.IOBase.IO ()
[Arity 2
Str: DmdType LL {sHe->U(AAAAAAAC(S))}]
pokeByteOff1_sHh =
\ (@ b_awE) ->
Foreign.Storable.$dmpokeByteOff @ (Main.Elem a_aa6)
$dStorable2_sHe @ b_awE;
$dmpeekElemOff1_sHg :: GHC.Ptr.Ptr (Main.Elem a_aa6)
-> GHC.Base.Int
-> GHC.IOBase.IO (Main.Elem a_aa6)
[Arity 2
Str: DmdType LL {sHe->U(LAAAC(C(S))AAA)}]
$dmpeekElemOff1_sHg =
Foreign.Storable.$dmpeekElemOff @ (Main.Elem a_aa6)
$dStorable2_sHe;
$dmpokeElemOff1_sHf :: GHC.Ptr.Ptr (Main.Elem a_aa6)
-> GHC.Base.Int
-> Main.Elem a_aa6
-> GHC.IOBase.IO ()
[Arity 3
Str: DmdType LLL {sHe->U(LAAAAC(C(C(S)))AA)}]
$dmpokeElemOff1_sHf =
Foreign.Storable.$dmpokeElemOff @ (Main.Elem a_aa6)
$dStorable2_sHe;
} in $dStorable2_sHe)
:Main.main :: GHC.IOBase.IO ()
[GlobalId]
[Arity 1
Str: DmdType L]
:Main.main =
GHC.TopHandler.runMainIO
@ ()
(Main.a
`cast` (sym ((GHC.IOBase.:CoIO) ())
:: GHC.Prim.State# GHC.Prim.RealWorld
-> (# GHC.Prim.State# GHC.Prim.RealWorld, () #)
:=:
GHC.IOBase.IO ()))
==================== Tidy Core Rules ====================
"SPEC Main.$f1"
__forall {$dStorable1_XIk :: Foreign.Storable.Storable GHC.Base.Int}
Main.$f1 @ GHC.Base.Int $dStorable1_XIk
= Main.$dStorable
