Skip to content

Instantly share code, notes, and snippets.

/Main.core

Created October 15, 2014 20:23
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save anonymous/3ba3cfa118e1d05870d4 to your computer and use it in GitHub Desktop.
Save anonymous/3ba3cfa118e1d05870d4 to your computer and use it in GitHub Desktop.
Download ZIP
haskell mystery allocations
Raw
Main.core
==================== Tidy Core ====================
Result size of Tidy Core = {terms: 292, types: 296, coercions: 67}
Rec {
a_r5LY
a_r5LY =
\ @ a2_a3Rd @ b_a3Re pred_a3oZ loc1_a3p0 f_a3p1 on_block_a3p2 ->
tick<throwErrnoIfRetryMayBlock>
\ s_a4HP ->
scc<throwErrnoIfRetryMayBlock>
case (f_a3p1 `cast` ...) s_a4HP of ds1_a4HQ { (# ipv_a4HS, ipv1_a4HT #) ->
case pred_a3oZ ipv1_a4HT of _ {
False -> ds1_a4HQ;
True ->
case {__pkg_ccall base __hscore_get_errno State# RealWorld -> (# State# RealWorld, Int# #)}_a4I1 ipv_a4HS of _ { (# ds_a4I4, ds2_a4I5 #) ->
case narrow32Int# ds2_a4I5 of _ {
__DEFAULT -> throwErrno1 loc1_a3p0 ds_a4I4;
4 -> a_r5LY pred_a3oZ loc1_a3p0 f_a3p1 on_block_a3p2 ds_a4I4;
35 -> case (on_block_a3p2 `cast` ...) ds_a4I4 of _ { (# ipv2_X4Jk, ipv3_X4Jm #) -> a_r5LY pred_a3oZ loc1_a3p0 f_a3p1 on_block_a3p2 ipv2_X4Jk }
}
}
}
}
end Rec }
loc_r5LZ
loc_r5LZ = scc<main> scc<echo> unpackCString# "read"#
lvl_r5M0
lvl_r5M0 =
\ ds_d4qY ->
case ds_d4qY `cast` ... of _ { I64# a2_a51l ->
case a2_a51l of _ {
__DEFAULT -> False;
(-1) -> True
}
}
lvl1_r5M1
lvl1_r5M1 = I32# 0
a1_r5M2
a1_r5M2 =
\ eta_B1 ->
case {__pkg_ccall base rtsSupportsBoundThreads State# RealWorld -> (# State# RealWorld, Int# #)}_a51v realWorld# of _ { (# ds_a51y, ds1_a51z #) ->
case ds1_a51z of _ {
__DEFAULT -> threadWaitRead1 evtRead (lvl1_r5M1 `cast` ...) eta_B1;
0 -> case waitRead# 0 eta_B1 of s'_a55u { __DEFAULT -> (# s'_a55u, () #) }
}
}
lvl2_r5M3
lvl2_r5M3 = scc<main> scc<echo> unpackCString# "write"#
lvl3_r5M4
lvl3_r5M4 = I# 0
main1
main1 =
tick<main>
\ s_a4HP ->
scc<main>
case {__pkg_ccall base malloc Word# -> State# RealWorld -> (# State# RealWorld, Addr# #)}_a5Bp (__word 1) s_a4HP of _ { (# ds_a5Bu, ds1_a5Bv #) ->
case tagToEnum# (eqAddr# ds1_a5Bv __NULL) of _ {
False ->
(scctick<echo>
letrec {
a2_s57x
a2_s57x =
\ s1_a56P ->
case (scctick<readRawBufferPtr>
tick<isNonBlocking>
\ s2_X4Kk ->
case scc<main> scc<echo> scc<readRawBufferPtr> {__pkg_ccall main fdReady Int# -> Int# -> Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)}_d4rq 0 0 0 0 s2_X4Kk
of _ { (# ds2_d4ro, ds3_d4rn #) ->
let {
read_s4G6
read_s4G6 =
let {
a3_s5Kb
a3_s5Kb =
scctick<readRawBufferPtr.safe_read>
tick<readRawBufferPtr.do_read>
\ s3_a55A ->
let {
a4_s56q
a4_s56q =
\ eta_a4Dz ->
case {__pkg_ccall_GC base ghczuwrapperZC21ZCbaseZCSystemziPosixziInternalsZCread Int# -> Addr# -> Word# -> State# RealWorld -> (# State# RealWorld, Int# #)}_a4DK 0 ds1_a5Bv (__word 1) eta_a4Dz
of _ { (# ds9_a4DP, ds10_a4DQ #) ->
(# ds9_a4DP, I64# ds10_a4DQ #)
} } in
scc<readRawBufferPtr.do_read>
case (scctick<throwErrnoIfMinus1RetryMayBlock> a_r5LY lvl_r5M0) loc_r5LZ (a4_s56q `cast` ...) (a1_r5M2 `cast` ...) s3_a55A of _ { (# ipv_a55D, ipv1_a55E #) ->
(# ipv_a55D, case ipv1_a55E `cast` ... of _ { I64# x#_a5zD -> I# x#_a5zD } #)
} } in
let {
a4_s5Kf
a4_s5Kf =
scctick<readRawBufferPtr.unsafe_read>
tick<readRawBufferPtr.do_read>
\ s3_X56c ->
let {
a5_s56l
a5_s56l =
\ eta_a4D1 ->
case {__pkg_ccall base ghczuwrapperZC22ZCbaseZCSystemziPosixziInternalsZCread Int# -> Addr# -> Word# -> State# RealWorld -> (# State# RealWorld, Int# #)}_a4Dc 0 ds1_a5Bv (__word 1) eta_a4D1
of _ { (# ds9_a4Dh, ds10_a4Di #) ->
(# ds9_a4Dh, I64# ds10_a4Di #)
} } in
scc<readRawBufferPtr.do_read>
case (scctick<throwErrnoIfMinus1RetryMayBlock> a_r5LY lvl_r5M0) loc_r5LZ (a5_s56l `cast` ...) (a1_r5M2 `cast` ...) s3_X56c of _ { (# ipv_a55D, ipv1_a55E #) ->
(# ipv_a55D, case ipv1_a55E `cast` ... of _ { I64# x#_a5zD -> I# x#_a5zD } #)
} } in
scctick<readRawBufferPtr.read>
case {__pkg_ccall_GC main rtsSupportsBoundThreads State# RealWorld -> (# State# RealWorld, Int# #)}_d4r9 realWorld# of _ { (# ds4_d4r8, ds5_d4r7 #) ->
case ds5_d4r7 of _ {
__DEFAULT -> a3_s5Kb `cast` ...;
0 -> a4_s5Kf `cast` ...
}
} } in
case scc<main> scc<echo> scc<readRawBufferPtr> narrow32Int# ds3_d4rn of _ {
__DEFAULT -> (read_s4G6 `cast` ...) ds2_d4ro;
(-1) ->
case scc<main> scc<echo> scc<readRawBufferPtr> throwErrno1 loc_r5LZ ds2_d4ro of _ { (# ipv_X4II, ipv1_X4IK #) ->
case ipv1_X4IK `cast` ... of _ { I32# ww1_s5HK ->
case ww1_s5HK of _ {
__DEFAULT -> (read_s4G6 `cast` ...) ipv_X4II;
0 ->
case {__pkg_ccall base rtsSupportsBoundThreads State# RealWorld -> (# State# RealWorld, Int# #)}_a51v realWorld# of _ { (# ds5_a51y, ds6_a51z #) ->
case ds6_a51z of _ {
__DEFAULT -> case threadWaitRead1 evtRead (lvl1_r5M1 `cast` ...) ipv_X4II of _ { (# ipv2_a56S, ipv3_a56T #) -> (read_s4G6 `cast` ...) ipv2_a56S };
0 -> case waitRead# 0 ipv_X4II of s'_a55u { __DEFAULT -> (read_s4G6 `cast` ...) s'_a55u }
}
}
}
}
};
0 ->
case {__pkg_ccall base rtsSupportsBoundThreads State# RealWorld -> (# State# RealWorld, Int# #)}_a51v realWorld# of _ { (# ds4_a51y, ds5_a51z #) ->
case ds5_a51z of _ {
__DEFAULT -> case threadWaitRead1 evtRead (lvl1_r5M1 `cast` ...) ds2_d4ro of _ { (# ipv_a56S, ipv1_a56T #) -> (read_s4G6 `cast` ...) ipv_a56S };
0 -> case waitRead# 0 ds2_d4ro of s'_a55u { __DEFAULT -> (read_s4G6 `cast` ...) s'_a55u }
}
}
}
})
s1_a56P
of _ { (# ipv_X4II, ipv1_X4IK #) ->
case $wa3 lvl2_r5M3 1 0 (Ptr ds1_a5Bv) lvl3_r5M4 (case ipv1_X4IK of _ { I# x#_a4yg -> (W64# (int2Word# x#_a4yg)) `cast` ... }) ipv_X4II of _ { (# ipv2_a56S, ipv3_a56T #) -> a2_s57x ipv2_a56S }
}; } in
a2_s57x)
ds_a5Bu;
True -> case ((ioError mallocBytes2) `cast` ...) ds_a5Bu of wild1_00 { }
}
}
main
main = main1 `cast` ...
main2
main2 = \ eta_X2k -> runMainIO1 (main1 `cast` ...) eta_X2k
main
main = main2 `cast` ...
Raw
Main.hs
{-# LANGUAGE BangPatterns #-}
module Main
( main
) where
import Control.Concurrent
import Control.Monad
import Data.Word
import Foreign.C.Error hiding (throwErrnoIfRetryMayBlock, throwErrnoIfMinus1RetryMayBlock)
import Foreign.C.Types
import Foreign.Marshal.Array
import Foreign.Ptr
import GHC.IO.FD hiding (readRawBufferPtr)
import System.Posix.Internals hiding (FD)
import System.Posix.Types
main :: IO ()
main = do
buf <- mallocArray 1
echo buf
echo :: Ptr Word8 -> IO ()
echo !buf = forever $ do
len <- readRawBufferPtr "read" stdin buf 0 1
writeRawBufferPtr "write" stdout buf 0 (fromIntegral len)
isNonBlocking :: FD -> Bool
isNonBlocking fd = fdIsNonBlocking fd /= 0
readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
readRawBufferPtr loc !fd buf off len
| isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
| otherwise = do r <- throwErrnoIfMinus1 loc
(unsafe_fdReady (fdFD fd) 0 0 0)
if r /= 0
then read
else do threadWaitRead (fromIntegral (fdFD fd)); read
where
do_read call = fromIntegral `fmap`
throwErrnoIfMinus1RetryMayBlock loc call
(threadWaitRead (fromIntegral (fdFD fd)))
read = if threaded then safe_read else unsafe_read
unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)
safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
foreign import ccall unsafe "fdReady"
unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
-- | as 'throwErrnoIfMinus1Retry', but checks for operations that would block.
--
throwErrnoIfMinus1RetryMayBlock :: (Eq a, Num a)
=> String -> IO a -> IO b -> IO a
throwErrnoIfMinus1RetryMayBlock = throwErrnoIfRetryMayBlock (== -1)
-- | as 'throwErrnoIfRetry', but additionally if the operation
-- yields the error code 'eAGAIN' or 'eWOULDBLOCK', an alternative
-- action is executed before retrying.
--
throwErrnoIfRetryMayBlock
:: (a -> Bool) -- ^ predicate to apply to the result value
-- of the 'IO' operation
-> String -- ^ textual description of the location
-> IO a -- ^ the 'IO' operation to be executed
-> IO b -- ^ action to execute before retrying if
-- an immediate retry would block
-> IO a
throwErrnoIfRetryMayBlock pred loc f on_block =
do
res <- f
if pred res
then do
err <- getErrno
if err == eINTR
then throwErrnoIfRetryMayBlock pred loc f on_block
else if err == eWOULDBLOCK || err == eAGAIN
then do _ <- on_block
throwErrnoIfRetryMayBlock pred loc f on_block
else throwErrno loc
else return res
Raw
Main.prof
Wed Oct 15 13:22 2014 Time and Allocation Profiling Report (Final)
wtf +RTS -P -RTS
total time = 1.47 secs (1474 ticks @ 1000 us, 1 processor)
total alloc = 75,208,104 bytes (excludes profiling overheads)
COST CENTRE MODULE %time %alloc ticks bytes
echo Main 49.1 43.2 724 32459624
throwErrnoIfRetryMayBlock Main 22.3 4.5 329 3416656
readRawBufferPtr Main 21.9 11.4 323 8541640
readRawBufferPtr.read Main 2.6 0.0 38 0
readRawBufferPtr.do_read Main 2.3 11.4 34 8541624
throwErrnoIfMinus1RetryMayBlock Main 1.3 20.4 19 15374952
readRawBufferPtr.unsafe_read Main 0.2 9.1 3 6833312
individual inherited
COST CENTRE MODULE no. entries %time %alloc %time %alloc ticks bytes
MAIN MAIN 42 0 0.0 0.0 100.0 100.0 0 2064
main Main 85 0 0.3 0.0 100.0 99.9 4 0
echo Main 86 1 49.1 43.2 99.7 99.9 724 32459624
readRawBufferPtr Main 87 213541 21.9 11.4 50.6 56.8 323 8541640
readRawBufferPtr.unsafe_read Main 90 213541 0.2 9.1 26.1 45.4 3 6833312
readRawBufferPtr.do_read Main 91 213541 2.3 11.4 25.9 36.3 34 8541624
throwErrnoIfMinus1RetryMayBlock Main 92 213541 1.3 20.4 23.6 25.0 19 15374952
throwErrnoIfRetryMayBlock Main 93 213541 22.3 4.5 22.3 4.5 329 3416656
readRawBufferPtr.read Main 89 213541 2.6 0.0 2.6 0.0 38 0
isNonBlocking Main 88 213541 0.0 0.0 0.0 0.0 0 0
CAF Main 83 0 0.0 0.0 0.0 0.0 0 16
main Main 84 1 0.0 0.0 0.0 0.0 0 0
CAF GHC.Conc.Signal 78 0 0.0 0.0 0.0 0.0 0 656
CAF GHC.IO.Encoding 71 0 0.0 0.0 0.0 0.0 0 2768
CAF GHC.IO.Encoding.Iconv 69 0 0.0 0.0 0.0 0.0 0 232
CAF GHC.IO.Handle.FD 62 0 0.0 0.0 0.0 0.0 0 34512
CAF GHC.TopHandler 59 0 0.0 0.0 0.0 0.0 0 48
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment