Skip to content

Instantly share code, notes, and snippets.

@noughtmare
noughtmare / murmurHash3_x64_128.hs
Last active March 14, 2024 00:19
Murmur3 x64 128 hash
{-# LANGUAGE MagicHash #-}
import GHC.Exts
import Foreign
import GHC.Word
import Control.Arrow ((>>>))
rotl64 :: Word64 -> Int -> Word64
rotl64 (W64# x#) (I# i#) = W64# ((x# `uncheckedShiftL64#` i#) `or64#` (x# `uncheckedShiftRL64#` (64# -# i#)))
@noughtmare
noughtmare / 1brc.hs
Last active March 14, 2024 11:36
1brc solution based on @Bodigrim's solution, but with linearly probed primitive hash table
#!/usr/bin/env cabal
{- cabal:
build-depends: base >= 4.19, bytestring, primitive >= 0.9, mmap
default-language: GHC2021
ghc-options: -Wall -O2 -fllvm
-}
{-# LANGUAGE ExtendedLiterals #-}
{-# LANGUAGE MagicHash, UnboxedTuples, UnliftedDatatypes #-}
import Data.ByteString (ByteString)
@noughtmare
noughtmare / AbstractMachine.hs
Created December 18, 2023 21:26
Sestoft Lazy Abstract Machine
import qualified Data.Map.Strict as Map
data Exp = Var String | Lam String Exp | App Exp String | Let String Exp Exp
| Con String [String] | Case Exp (Map.Map String ([String], Exp))
deriving Show
data State = State Heap Control Environment Stack deriving Show
data Heap = Heap !Int !(Map.Map String (Exp, Environment)) deriving Show
type Control = Exp
@noughtmare
noughtmare / StrictUntil.hs
Created November 8, 2023 23:07
Why no strict until'?
import Prelude hiding (until)
import Test.Tasty.Bench
{-# NOINLINE until #-}
until :: (a -> Bool) -> (a -> a) -> a -> a
until p f = go
where
go x | p x = x
| otherwise = go (f x)
@noughtmare
noughtmare / FastEffects.hs
Last active November 8, 2023 22:42
The fastest effect system approaches translate operations into a fast concrete monad like IO or State.
{-# LANGUAGE UnboxedTuples #-}
import Control.Monad
import Test.Tasty.Bench
import Data.IORef
{-# NOINLINE countdownIO #-}
countdownIO :: IO Integer -> (Integer -> IO ()) -> IO Integer
countdownIO get put = go where
go = do
@noughtmare
noughtmare / CFG.hs
Created August 14, 2023 21:01
Exteremely naive CFG parser
import Data.List qualified as List
import Test.Tasty.Bench.Fit (fit, mkFitConfig)
data CFG = CFG String [(String, [Symbol])]
data Symbol = T Char | NT String
splits :: String -> [(String, String)]
splits [] = [([], [])]
splits (x : xs) = ([], x : xs) : map (\(y, z) -> (x : y, z)) (splits xs)
these 30 derivations will be built:
/nix/store/8bp2iihry7scnlnsw240v71ydh70agg7-bash-5.1-p16.drv
/nix/store/fdsax0a1p3wqnnwb4gsxzr1y55yhgc77-binutils-2.39.drv
/nix/store/sr0jdc6c0cj5chrgzbvvsci9w64scns0-libxcrypt-4.4.30.drv
/nix/store/4jjh8kxnbk60x84nz6wzfsnyp2fgdp64-perl-5.36.0.drv
/nix/store/s8srp5k52fbgn168b8nlmdrndsyc76v6-perl5.36.0-gettext-1.07.drv
/nix/store/v8f4lwzmcgiwk0680aa2z1cd8c7zmhrl-help2man-1.49.2.drv
/nix/store/z0har4q95p7pagbd3755qi5ans8zihn0-libtool-2.4.7.drv
/nix/store/76n41vykcagiza65nv8kcy4xvr9yzif1-hook.drv
/nix/store/ipfm2lrrbdj9w6vl2j4w0qj9p9jp73zm-acl-2.3.1.drv
@noughtmare
noughtmare / LeftRecursiveRecognizers.hs
Last active May 24, 2023 15:00
Parser combinator-style recognizers which allow for left-recursion.
{-# LANGUAGE PatternSynonyms #-}
import Control.Monad.State
import Data.Foldable (traverse_)
type Id = String
newtype Parser = Parser { alts :: [P] }
data P = T Char Parser | NT Id Parser Parser | Success
success :: Parser
@noughtmare
noughtmare / FinalFreeEffects.hs
Created April 28, 2023 12:28
Alternative record-based/final implementation of effects using a free monad
{-# LANGUAGE QuantifiedConstraints #-}
{-# OPTIONS_GHC -Wall #-}
import Control.Arrow ((>>>))
import Control.Monad
data Free f a = Pure a | Free (f (Free f a))
deriving instance Functor f => Functor (Free f)
instance Functor f => Applicative (Free f) where
@noughtmare
noughtmare / TypeLevelScopeSafety.hs
Created April 23, 2023 10:27
Scope safe lambda calculus using type level programming in Haskell
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedLabels #-}
import GHC.TypeLits
import Data.Kind
import GHC.OverloadedLabels
import Data.Function ((&))