Skip to content

Instantly share code, notes, and snippets.

@chrisdone-artificial

chrisdone-artificial/0speeds.txt

Last active January 13, 2025 09:50
Show Gist options
  • Save chrisdone-artificial/e60224ff7dc536b9e4c4c5983ec4148a to your computer and use it in GitHub Desktop.
Save chrisdone-artificial/e60224ff7dc536b9e4c4c5983ec4148a to your computer and use it in GitHub Desktop.
Download ZIP
Raw
0speeds.txt
chris@linux:~/Work/chrisdone-artificial/hell-1$ ghc -main-is main_native -O fib.hs -o fib && ./fib +RTS -s
[1 of 2] Compiling Main ( fib.hs, fib.o ) [Flags changed]
[2 of 2] Linking fib [Objects changed]
832040
50,864 bytes allocated in the heap
3,272 bytes copied during GC
44,328 bytes maximum residency (1 sample(s))
25,304 bytes maximum slop
6 MiB total memory in use (0 MiB lost due to fragmentation)
Tot time (elapsed) Avg pause Max pause
Gen 0 0 colls, 0 par 0.000s 0.000s 0.0000s 0.0000s
Gen 1 1 colls, 0 par 0.000s 0.000s 0.0001s 0.0001s
INIT time 0.000s ( 0.000s elapsed)
MUT time 0.002s ( 0.002s elapsed)
GC time 0.000s ( 0.000s elapsed)
EXIT time 0.000s ( 0.008s elapsed)
Total time 0.003s ( 0.010s elapsed)
%GC time 0.0% (0.0% elapsed)
Alloc rate 23,280,945 bytes per MUT second
Productivity 87.1% of total user, 21.4% of total elapsed
chris@linux:~/Work/chrisdone-artificial/hell-1$ ghc -main-is main_naive -O fib.hs -o fib && ./fib +RTS -s
[1 of 2] Compiling Main ( fib.hs, fib.o ) [Flags changed]
[2 of 2] Linking fib [Objects changed]
832040
215,486,536 bytes allocated in the heap
34,168 bytes copied during GC
60,704 bytes maximum residency (2 sample(s))
29,400 bytes maximum slop
6 MiB total memory in use (0 MiB lost due to fragmentation)
Tot time (elapsed) Avg pause Max pause
Gen 0 50 colls, 0 par 0.000s 0.000s 0.0000s 0.0000s
Gen 1 2 colls, 0 par 0.000s 0.000s 0.0000s 0.0001s
INIT time 0.000s ( 0.000s elapsed)
MUT time 0.044s ( 0.044s elapsed)
GC time 0.001s ( 0.000s elapsed)
EXIT time 0.000s ( 0.005s elapsed)
Total time 0.045s ( 0.050s elapsed)
%GC time 0.0% (0.0% elapsed)
Alloc rate 4,872,293,856 bytes per MUT second
Productivity 98.1% of total user, 88.4% of total elapsed
chris@linux:~/Work/chrisdone-artificial/hell-1$ ghc -main-is main_flat -O fib.hs -o fib && ./fib +RTS -s
[1 of 2] Compiling Main ( fib.hs, fib.o ) [Flags changed]
[2 of 2] Linking fib [Objects changed]
832040
64,752,096 bytes allocated in the heap
13,768 bytes copied during GC
60,256 bytes maximum residency (2 sample(s))
29,400 bytes maximum slop
6 MiB total memory in use (0 MiB lost due to fragmentation)
Tot time (elapsed) Avg pause Max pause
Gen 0 14 colls, 0 par 0.000s 0.000s 0.0000s 0.0000s
Gen 1 2 colls, 0 par 0.000s 0.000s 0.0000s 0.0001s
INIT time 0.000s ( 0.000s elapsed)
MUT time 0.032s ( 0.031s elapsed)
GC time 0.000s ( 0.000s elapsed)
EXIT time 0.000s ( 0.009s elapsed)
Total time 0.032s ( 0.040s elapsed)
%GC time 0.0% (0.0% elapsed)
Alloc rate 2,050,896,309 bytes per MUT second
Productivity 98.3% of total user, 78.0% of total elapsed
chris@linux:~/Work/chrisdone-artificial/hell-1$ ghc -main-is main_pats -O fib.hs -o fib && ./fib +RTS -s
[1 of 2] Compiling Main ( fib.hs, fib.o ) [Flags changed]
[2 of 2] Linking fib [Objects changed]
832040
430,937,048 bytes allocated in the heap
102,112 bytes copied during GC
61,232 bytes maximum residency (2 sample(s))
29,400 bytes maximum slop
6 MiB total memory in use (0 MiB lost due to fragmentation)
Tot time (elapsed) Avg pause Max pause
Gen 0 102 colls, 0 par 0.001s 0.001s 0.0000s 0.0000s
Gen 1 2 colls, 0 par 0.000s 0.000s 0.0000s 0.0001s
INIT time 0.000s ( 0.000s elapsed)
MUT time 0.059s ( 0.059s elapsed)
GC time 0.001s ( 0.001s elapsed)
EXIT time 0.000s ( 0.000s elapsed)
Total time 0.060s ( 0.060s elapsed)
%GC time 0.0% (0.0% elapsed)
Alloc rate 7,301,408,189 bytes per MUT second
Productivity 97.9% of total user, 98.1% of total elapsed
chris@linux:~/Work/chrisdone-artificial/hell-1$ ghc -main-is main_fold -O fib.hs -o fib && ./fib +RTS -s
[1 of 2] Compiling Main ( fib.hs, fib.o ) [Flags changed]
[2 of 2] Linking fib [Objects changed]
832040
430,937,032 bytes allocated in the heap
102,840 bytes copied during GC
61,216 bytes maximum residency (2 sample(s))
29,400 bytes maximum slop
6 MiB total memory in use (0 MiB lost due to fragmentation)
Tot time (elapsed) Avg pause Max pause
Gen 0 102 colls, 0 par 0.001s 0.001s 0.0000s 0.0000s
Gen 1 2 colls, 0 par 0.000s 0.000s 0.0001s 0.0001s
INIT time 0.000s ( 0.000s elapsed)
MUT time 0.063s ( 0.063s elapsed)
GC time 0.001s ( 0.001s elapsed)
EXIT time 0.000s ( 0.007s elapsed)
Total time 0.064s ( 0.070s elapsed)
%GC time 0.0% (0.0% elapsed)
Alloc rate 6,888,811,209 bytes per MUT second
Productivity 97.9% of total user, 89.3% of total elapsed
chris@linux:~/Work/chrisdone-artificial/hell-1$
Raw
bytearray fib.hs
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# language MagicHash, LambdaCase, ViewPatterns, PatternSynonyms #-}
-- | interpreting fib
import GHC.Word
import Data.Word
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Builder as SB
import qualified Data.ByteString as S
import Data.ByteString (ByteString)
import GHC.Int
import GHC.Exts
import GHC.ForeignPtr
import qualified Data.ByteString.Internal as B
import Data.ByteString (ByteString)
import Prelude
data Exp
= Int32 Int32 -- 0
| Add Exp Exp -- 1
| Sub Exp Exp -- 2
| Lt Exp Exp -- 3
| If Exp Exp Exp -- 4
| Stack -- 5
| Recur Exp -- 6
eval :: Int32 -> Exp -> Int32
eval stack expr0 = go expr0
where
go = \case
Int32 i8 -> i8
Add x y -> go x + go y
Sub x y -> go x - go y
Lt x y ->
case compare (go x) (go y) of
EQ -> 0
LT -> 1
GT -> 0
If pred' then' else' ->
if go pred' == 1
then go then'
else go else'
Stack -> stack
Recur arg -> eval (go arg) expr0
fib :: Exp
fib =
If
(Lt n (Int32 2))
n
(Add (Recur (Sub n (Int32 1))) (Recur (Sub n (Int32 2))))
where
n = Stack
repl :: Int32
repl = eval 30 fib
repl' :: Int32
repl' = evl 30 fib''
fib' :: Int32 -> Int32
fib' n = if n < 2 then n else fib' (n-1) + fib' (n-2)
main_native :: IO ()
main_native = print $ fib' 30
main_naive :: IO ()
main_naive = print repl
main_flat :: IO ()
main_flat = print repl'
main_pats :: IO ()
main_pats = print $ eval' 30 fib''
main_fold :: IO ()
main_fold = print $ eval'fold 30 fib''
--------------------------------------------------------------------------------
pattern Add' x y <- (matchAdd -> Just (x,y))
where Add' x y = L.toStrict $ SB.toLazyByteString $
SB.word8 1 <> SB.int64LE (fromIntegral (S.length x))
<> SB.byteString x <> SB.byteString y
{-# inline matchAdd #-}
matchAdd :: ByteString -> Maybe (ByteString, ByteString)
matchAdd bs
| 1 <- headWord8 bs,
len <- headInt64 (S.tail bs) =
let preamble = (1 + 8)
x = S.drop preamble bs
y = S.drop (preamble + fromIntegral len) bs
in Just (x, y)
| otherwise = Nothing
pattern Sub' x y <- (matchSub -> Just (x,y))
where Sub' x y = L.toStrict $ SB.toLazyByteString $
SB.word8 2 <> SB.int64LE (fromIntegral (S.length x))
<> SB.byteString x <> SB.byteString y
{-# inline matchSub #-}
matchSub :: ByteString -> Maybe (ByteString, ByteString)
matchSub bs
| 2 <- headWord8 bs,
len <- headInt64 (S.tail bs) =
let preamble = (1 + 8)
x = S.drop preamble bs
y = S.drop (preamble + fromIntegral len) bs
in Just (x, y)
| otherwise = Nothing
pattern Lt' x y <- (matchLt -> Just (x,y))
where Lt' x y = L.toStrict $ SB.toLazyByteString $
SB.word8 3 <> SB.int64LE (fromIntegral (S.length x))
<> SB.byteString x <> SB.byteString y
{-# inline matchLt #-}
matchLt :: ByteString -> Maybe (ByteString, ByteString)
matchLt bs
| 3 <- headWord8 bs,
len <- headInt64 (S.tail bs) =
let preamble = (1 + 8)
x = S.drop preamble bs
y = S.drop (preamble + fromIntegral len) bs
in Just (x, y)
| otherwise = Nothing
pattern If' x y z <- (matchIf -> Just (x,y,z))
where If' x y z = L.toStrict $ SB.toLazyByteString $
SB.word8 4 <> SB.int64LE (fromIntegral (S.length x))
<> SB.int64LE (fromIntegral (S.length y))
<> SB.byteString x <> SB.byteString y <> SB.byteString z
{-# inline matchIf #-}
matchIf :: ByteString -> Maybe (ByteString, ByteString, ByteString)
matchIf bs
| 4 <- headWord8 bs,
len <- headInt64 (S.tail bs),
len2 <- headInt64 (S.drop (1 + 8) bs) =
let preamble = (1 + 8 + 8)
x = S.take (fromIntegral len) (S.drop preamble bs)
y = S.take (fromIntegral len2) (S.drop (preamble + fromIntegral len) bs)
z = S.drop (preamble + fromIntegral len + fromIntegral len2) bs
in Just (x, y, z)
| otherwise = Nothing
pattern Int32' x <- (matchInt32 -> Just x)
where Int32' x = L.toStrict $ SB.toLazyByteString $ SB.word8 0 <> SB.int32LE x
{-# inline matchInt32 #-}
matchInt32 :: ByteString -> Maybe Int32
matchInt32 bs
| 0 <- headWord8 bs =
let !i32 = headInt32 (S.drop 1 bs)
in Just i32
| otherwise = Nothing
pattern Stack' <- (matchStack -> True)
where Stack' = L.toStrict $ SB.toLazyByteString $ SB.word8 5
{-# inline matchStack #-}
matchStack :: ByteString -> Bool
matchStack bs
| 5 <- headWord8 bs = True
| otherwise = False
pattern Recur' x <- (matchRecur -> Just (x))
where Recur' x = L.toStrict $ SB.toLazyByteString $
SB.word8 6 <>
SB.byteString x
{-# inline matchRecur #-}
matchRecur :: ByteString -> Maybe (ByteString)
matchRecur bs
| 6 <- headWord8 bs =
Just (S.tail bs)
| otherwise = Nothing
--------------------------------------------------------------------------------
{-# inline headInt64 #-}
headInt64 :: ByteString -> Int64
headInt64 (B.PS (ForeignPtr ptr _fpc) (I# off) _len) =
I64# (indexInt64OffAddr# (plusAddr# ptr off) 0#)
{-# inline headInt32 #-}
headInt32 :: ByteString -> Int32
headInt32 (B.PS (ForeignPtr ptr _fpc) (I# off) _len) =
I32# (indexInt32OffAddr# (plusAddr# ptr off) 0#)
{-# inline headWord8 #-}
headWord8 :: ByteString -> Word8
headWord8 (B.PS (ForeignPtr ptr _fpc) (I# off) _len) =
W8# (indexWord8OffAddr# (plusAddr# ptr off) 0#)
evl :: Int32 -> ByteString -> Int32
evl (I32# stack0) (B.PS (ForeignPtr ptr _fpc) (I# off) _len) =
I32# (eval stack0 (plusAddr# ptr off))
where eval :: Int32# -> Addr# -> Int32#
eval stack addr1 = go addr1
where go :: Addr# -> Int32#
go addr# =
case word2Int# (word8ToWord# (indexWord8OffAddr# addr# 0#)) of
0# -> indexInt32OffAddr# (plusAddr# addr# 1#) 0#
1# ->
let !len = indexIntOffAddr# (plusAddr# addr# 1#) 0#
!preamble = 1# +# 8#
!x = plusAddr# addr# preamble -- no take
!y = plusAddr# addr# (preamble +# len)
in plusInt32# (go x) (go y)
2# ->
let !len = indexIntOffAddr# (plusAddr# addr# 1#) 0#
!preamble = 1# +# 8#
!x = plusAddr# addr# preamble -- no take
!y = plusAddr# addr# (preamble +# len)
in subInt32# (go x) (go y)
3# ->
let !len = indexIntOffAddr# (plusAddr# addr# 1#) 0#
!preamble = 1# +# 8#
!x = plusAddr# addr# preamble -- no take
!y = plusAddr# addr# (preamble +# len)
in intToInt32# (ltInt32# (go x) (go y))
4# ->
let !len = indexIntOffAddr# (plusAddr# addr# 1#) 0#
!len2 = indexIntOffAddr# (plusAddr# addr# 9#) 0#
!preamble = 1# +# 8# +# 8#
!x = plusAddr# addr# preamble -- no take
!y = plusAddr# addr# (preamble +# len)
!z = plusAddr# addr# (preamble +# len +# len2)
in case int32ToInt# (go x) of
1# -> go y
_ -> go z
5# ->
stack
6# ->
let !arg = go (plusAddr# addr# 1#)
in eval arg addr1
eval' :: Int32 -> ByteString -> Int32
eval' stack expr0 = go expr0
where
go = \case
Int32' i8 -> i8
Add' x y -> go x + go y
Sub' x y -> go x - go y
Lt' x y ->
case compare (go x) (go y) of
EQ -> 0
LT -> 1
GT -> 0
If' pred' then' else' ->
if go pred' == 1
then go then'
else go else'
Stack' -> stack
Recur' arg -> eval' (go arg) expr0
eval'fold :: Int32 -> ByteString -> Int32
eval'fold stack expr0 = go expr0
where
go e' =
foldExpr
e'
id
(\x y -> go x + go y)
(\x y -> go x - go y)
( \x y -> case compare (go x) (go y) of
EQ -> 0
LT -> 1
GT -> 0
)
( \pred' then' else' ->
if go pred' == 1
then go then'
else go else'
)
stack
(\arg -> eval' (go arg) expr0)
fib'' :: ByteString
fib'' =
If'
(Lt' n (Int32' 2))
n
(Add' (Recur' (Sub' n (Int32' 1))) (Recur' (Sub' n (Int32' 2))))
where
n = Stack'
fibX :: ByteString
fibX =
-- Add' (Int32' 2) (Sub' (Int32' 10) (Int32' 3))
Lt' (Int32' 10) (Int32' 10)
foldExpr
:: ByteString
-> (Int32 -> a) -- int32
-> (ByteString -> ByteString -> a) --add
-> (ByteString -> ByteString -> a) --sub
-> (ByteString -> ByteString -> a) --lt
-> (ByteString -> ByteString -> ByteString -> a) --if
-> a --stack
-> (ByteString -> a) --recur
-> a
foldExpr bs int32 add sub lt if' stack recur =
case S.head bs of
0 -> int32 (headInt32 (S.drop 1 bs))
1 ->
let len = headInt64 (S.tail bs)
preamble = (1 + 8)
x = S.drop preamble bs
y = S.drop (preamble + fromIntegral len) bs
in add x y
2 ->
let len = headInt64 (S.tail bs)
preamble = (1 + 8)
x = S.drop preamble bs
y = S.drop (preamble + fromIntegral len) bs
in sub x y
3 ->
let len = headInt64 (S.tail bs)
preamble = (1 + 8)
x = S.drop preamble bs
y = S.drop (preamble + fromIntegral len) bs
in lt x y
4 ->
let
len = headInt64 (S.tail bs)
len2 = headInt64 (S.drop (1 + 8) bs)
preamble = (1 + 8 + 8)
x = S.take (fromIntegral len) (S.drop preamble bs)
y = S.take (fromIntegral len2) (S.drop (preamble + fromIntegral len) bs)
z = S.drop (preamble + fromIntegral len + fromIntegral len2) bs
in if' x y z
5 -> stack
6 -> recur $ S.tail bs
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment