Compilers for contrarians

[+] Show modules

import System
main = putStrLn "Hello, World!"
import Base
import System
-- Digits of e. See http://miranda.org.uk/examples.
mkdigit n | n <= 9 = chr (n + ord '0')
norm c (d:e:x)
  | e `mod` c + 10 <= c = d + e  `div` c : e' `mod` c : x'
  | otherwise           = d + e' `div` c : e' `mod` c : x'
  where (e':x') = norm (c+1) (e:x)
convert x = mkdigit h:convert t
  where (h:t) = norm 2 (0:map (10*) x)
edigits = "2." ++ convert (repeat 1)
main = putStr $ take 1024 edigits
import Base
import System
primes = sieve [2..]
sieve (p:x) = p : sieve [n | n <- x, n `mod` p /= 0]
main = print $ take 100 $ primes
-- Eight queens puzzle. See http://miranda.org.uk/examples.
import Base
import System
safe q b = and[not $ q==p || abs(q-p)==i|(p,i) <- zip b [1..]]
queens sz = go sz where
  go 0 = [[]]
  go n = [q:b | b <- go (n - 1), q <- [1..sz], safe q b]
main = print $ queens 8
-- King, are you glad you are king?
import Base
import System
main = interact $ unwords . reverse . words
import Base
import System
main = interact $ unwords . sorta . words
sorta [] = []
sorta (x:xt) = sorta (filter (<= x) xt) ++ [x] ++ sorta (filter (> x) xt)
-- https://fivethirtyeight.com/features/can-you-escape-this-enchanted-maze/
import Base
import Map
import System
maze = fromList $ concat $ zipWith row [0..]
  [ "."
  , "IF"
  , " BLUE"
  , "Z ASKS"
  , "AMY EE"
  , "DANCES"
  , " QUEEN"
  , "   Z O"
  , "     O"
  ]
  where
  row r s = concat $ zipWith (cell r) [0..] s
  cell r c x | x /= ' '  = [((r, c), x)]
             | otherwise = []
dirs = [(1, 0), (0, -1), (-1, -1), (-1, 0), (0, 1), (1, 1)]
turn f x = take 2 $ tail $ dropWhile (/= x) $ cycle $ f dirs
data Hex = Hex (Int, Int) (Int, Int) String
step (Hex (x, y) (xd, yd) path) =
  [Hex pos' (xd', yd') (c:path) | (xd', yd') <- next (xd, yd),
    let pos' = (x + xd', y + yd'), member pos' maze]
  where
  c = maze!(x, y)
  next = turn $ if elem c "AEIOUY" then id else reverse

bfs moves = case asum $ won <$> moves of
  Nothing -> bfs $ step =<< moves
  Just soln -> reverse soln
  where
  won (Hex pos _ path)
    | maze!pos == '.' && elem 'M' path = Just path
    | otherwise = Nothing

main = putStrLn $ bfs [Hex (5, 0) (1, 1) ""]
-- Gray code.
import Base
import System
gray 0 = [""]
gray n = ('0':) <$> gray (n - 1) <|> reverse (('1':) <$> gray (n - 1))
main = putStrLn $ unwords $ gray 4
-- Theorem prover based on a Hilbert system.
-- https://crypto.stanford.edu/~blynn/compiler/hilsys.html
import Base
import System
data Term = Var String | Fun String [Term] deriving Eq

data FO = Top | Bot | Atom String [Term]
  | Not FO | FO :/\ FO | FO :\/ FO | FO :==> FO | FO :<=> FO
  | Forall String FO | Exists String FO
  deriving Eq
data Theorem = Theorem FO
instance Show Term where
  showsPrec _ = \case
    Var s -> (s ++)
    Fun s ts -> (s ++) . showParen (not $ null ts)
      (foldr (.) id $ intersperse (", "++) $ map shows ts)

instance Show FO where
  showsPrec p = \case
    Top -> ('1':)
    Bot -> ('0':)
    Atom s ts -> shows $ Fun s ts
    Not x -> ('~':) . showsPrec 4 x
    x :/\ y -> showParen (p > 3) $ showsPrec 3 x . (" /\\ " ++) . showsPrec 3 y
    x :\/ y -> showParen (p > 2) $ showsPrec 2 x . (" \\/ " ++) . showsPrec 2 y
    x :==> y -> showParen (p > 1) $ showsPrec 2 x . (" ==> " ++) . showsPrec 1 y
    x :<=> y -> showParen (p > 1) $ showsPrec 2 x . (" <=> " ++) . showsPrec 1 y
    Forall s x -> showParen (p > 0) $ ("forall " ++) . (s++) . (". "++) . showsPrec 0 x
    Exists s x -> showParen (p > 0) $ ("exists " ++) . (s++) . (". "++) . showsPrec 0 x
occurs s t = s == t || case t of
  Var _ -> False
  Fun _ args -> any (occurs s) args
isFree t = \case
  Top -> False
  Bot -> False
  Atom _ ts -> any (occurs t) ts
  Not x -> isFree t x
  x :/\ y -> isFree t x || isFree t y
  x :\/ y -> isFree t x || isFree t y
  x :==> y -> isFree t x || isFree t y
  x :<=> y -> isFree t x || isFree t y
  Forall v x -> not (occurs (Var v) t) && isFree t x
  Exists v x -> not (occurs (Var v) t) && isFree t x
s =: t = Atom "=" [s, t]
ponens (Theorem (p :==> q)) (Theorem p') | p == p' = Theorem q
gen x (Theorem t) = Theorem $ Forall x t
axiomK p q        = Theorem $ p :==> (q :==> p)
axiomS p q r      = Theorem $ (p :==> (q :==> r)) :==> ((p :==> q) :==> (p :==> r))
axiomLEM p        = Theorem $ ((p :==> Bot) :==> Bot) :==> p
axiomAllImp x p q = Theorem $ Forall x (p :==> q) :==> (Forall x p :==> Forall x q)
axiomImpAll x p | isFree (Var x) p = Theorem $ p :==> Forall x p
axiomExEq x t | occurs (Var x) t = Theorem $ Exists x $ Var x =: t
axiomRefl t       = Theorem $ t =: t
axiomFunCong  f ls rs = Theorem $ foldr (:==>) (Fun f ls =: Fun f rs) $ zipWith (=:) ls rs
axiomPredCong p ls rs = Theorem $ foldr (:==>) (Atom p ls :==> Atom p rs) $ zipWith (=:) ls rs
axiomIffImp1 p q = Theorem $ (p :<=> q) :==> (p :==> q)
axiomIffImp2 p q = Theorem $ (p :<=> q) :==> (q :==> p)
axiomImpIff p q  = Theorem $ (p :==> q) :==> ((q :==> p) :==> (p :<=> q))
axiomTrue        = Theorem $ Top :<=> (Bot :==> Bot)
axiomNot p       = Theorem $ Not p :<=> (p :==> Bot)
axiomAnd p q     = Theorem $ (p :/\ q) :<=> ((p :==> (q :==> Bot)) :==> Bot)
axiomOr p q      = Theorem $ (p :\/ q) :<=> Not (Not p :/\ Not q)
axiomExists x p  = Theorem $ Exists x p :<=> Not (Forall x $ Not p)
-- |-  p ==> p
impRefl p = ponens (ponens
  (axiomS p (p :==> p) p)
  (axiomK p $ p :==> p))
  (axiomK p p)

-- |- p ==> p ==> q  /  |- p ==> q
impDedup th@(Theorem (p :==> (_ :==> q))) = ponens (ponens (axiomS p p q) th) (impRefl p)

-- |- q  /  |- p ==> q
addAssum p th@(Theorem f) = ponens (axiomK f p) th

-- |- q ==> r  /  |- (p ==> q) ==> (p ==> r)
impAddAssum p th@(Theorem (q :==> r)) = ponens (axiomS p q r) (addAssum p th)

-- |- p ==> q  |- q ==> r  /  |- p ==> r
impTrans th1@(Theorem (p :==> _)) th2 = ponens (impAddAssum p th2) th1

-- |- p ==> r  /  |- p ==> q ==> r
impInsert q th@(Theorem (p :==> r)) = impTrans th (axiomK r q)

-- |- p ==> q ==> r  /  |- q ==> p ==> r
impSwap th@(Theorem (p :==> (q :==> r))) = impTrans (axiomK q p) $ ponens (axiomS p q r) th

-- |- (q ==> r) ==> (p ==> q) ==> (p ==> r)
impTransTh p q r = impTrans (axiomK (q :==> r) p) (axiomS p q r)

-- |- p ==> q  /  |- (p ==> r) ==> (q ==> r)
impAddConcl r th@(Theorem (p :==> q)) = ponens (impSwap (impTransTh p q r)) th

-- |- (p ==> q ==> r) ==> (q ==> p ==> r)
impSwapTh p q r = impTrans (axiomS p q r) $ impAddConcl (p :==> r) $ axiomK q p

-- |- (p ==> q ==> r) ==> (s ==> t ==> u)  /  |- (q ==> p ==> r) ==> (t ==> s ==> u)
impSwap2 th@(Theorem ((p :==> (q :==> r)) :==> (s :==> (t :==> u))))
  = impTrans (impSwapTh q p r) (impTrans th (impSwapTh s t u))

-- |- p ==> q ==> r  |- p ==> q  /  |- p ==> r
rightMP ith th = impDedup (impTrans th (impSwap ith))

-- |- p <=> q  /  |- p ==> q
iffImp1 th@(Theorem (p :<=> q)) = ponens (axiomIffImp1 p q) th

-- |- p <=> q  /  |- q ==> p
iffImp2 th@(Theorem (p :<=> q)) = ponens (axiomIffImp2 p q) th

-- |- p ==> q  |- q ==> p  /  |- p <=> q
impAntisym th1@(Theorem (p :==> q)) th2 = ponens (ponens (axiomImpIff p q) th1) th2

-- |- p ==> (q ==> 0) ==> 0  /  |- p ==> q
rightDoubleNeg th@(Theorem (p :==> ((_ :==> Bot) :==> Bot))) = impTrans th $ axiomLEM p

-- |- 0 ==> p
exFalso p = rightDoubleNeg $ axiomK Bot (p :==> Bot)

-- |- 1
truth = ponens (iffImp2 axiomTrue) (impRefl Bot)

-- |- s = t ==> t = s
eqSym s t = let
  rth = axiomRefl s
  f th = ponens (impSwap th) rth
  in f $ f $ axiomPredCong "=" [s, s] [t, s]

-- |- s = t ==> t = u ==> s = u
eqTrans s t u = let
  th1 = axiomPredCong "=" [t, u] [s, u]
  th2 = ponens (impSwap th1) (axiomRefl u)
  in impTrans (eqSym s t) th2

examples =
  [ axiomOr (Atom "x" []) (Atom "y" [])
  , impTransTh (Atom "Foo" []) (Atom "Bar" []) (Atom "Baz" [])
  , eqSym (Var "a") (Var "b")
  , eqTrans (Var "x") (Var "y") (Var "z")
  ]

concl (Theorem t) = t
main = mapM_ (putStr . flip shows "\n" . concl) examples
-- Based on https://sametwice.com/4_line_mandelbrot.
import Base
import System
prec :: Int
prec = 16384
infixl 7 #
x # y = x * y `div` prec
sqAdd (x, y) (a, b) = (a#a - b#b + x, 2*(a#b) + y)
norm (x, y) = x#x + y#y
douady p = null . dropWhile (\z -> norm z < 4*prec) . take 30 $ iterate (sqAdd p) (0, 0)
main = putStr $ unlines
  [[if douady (616*x - 2*prec, 1502*y - 18022)
    then '*' else ' ' | x <- [0..79]] | y <- [0..23]]
-- https://crypto.stanford.edu/~blynn/haskell/enigma.html
import Base
import System
wI   = ("EKMFLGDQVZNTOWYHXUSPAIBRCJ", "Q")
wII  = ("AJDKSIRUXBLHWTMCQGZNPYFVOE", "E")
wIII = ("BDFHJLCPRTXVZNYEIWGAKMUSQO", "V")
wIV  = ("ESOVPZJAYQUIRHXLNFTGKDCMWB", "J")
wV   = ("VZBRGITYUPSDNHLXAWMJQOFECK", "Z")
ukwA = "EJMZALYXVBWFCRQUONTSPIKHGD"
ukwB = "YRUHQSLDPXNGOKMIEBFZCWVJAT"
ukwC = "FVPJIAOYEDRZXWGCTKUQSBNMHL"

abc = ['A'..'Z']
abc2 = abc ++ abc
sub p x   = maybe x id $ lookup x $ zip abc p
unsub p x = maybe x id $ lookup x $ zip p abc
shift k   = sub   $ dropWhile (/= k) $ abc2
unshift k = unsub $ dropWhile (/= k) $ abc2
conjugateSub p k = unshift k . sub p . shift k
rotorSubs gs = zipWith conjugateSub (fst <$> rotors) gs
rotors = [wI, wII, wIII]
zap gs = unsub p . sub ukwB . sub p where
  p = foldr1 (.) (rotorSubs gs) <$> abc
turn gs@[_, g2, g3] = zipWith (bool id $ shift 'B') bs gs where
  [_, n2, n3] = snd <$> rotors
  bs = [g2 `elem` n2, g2 `elem` n2 || g3 `elem` n3, True]
enigma grundstellung = zipWith zap $ tail $ iterate turn grundstellung
main = interact $ enigma "AAA"
-- SHA-256.
--
-- To make this more fun, we compute the algorithm's constants ourselves.
-- They are the first 32 bits of the fractional parts of the square roots
-- and cube roots of primes and hence are nothing-up-my-sleeve numbers.
module Main where
import Base
import System

-- Fixed-point arithmetic with scaling 1/2^40.
-- We break the ring laws but get away with it.
denom = 2^40
data Fixie = Fixie Integer deriving Eq
instance Ring Fixie where
  Fixie a + Fixie b = Fixie (a + b)
  Fixie a - Fixie b = Fixie (a - b)
  Fixie a * Fixie b = Fixie (a * b `div` denom)
  fromInteger = Fixie . (denom *)

properFraction (Fixie f) = (q, Fixie $ f - q) where q = div f denom
truncate (Fixie f) = div f denom
instance Field Fixie where
  recip (Fixie f) = Fixie $ denom*denom `div` f

-- Square roots and cube roots via Newton-Raphson.
-- In theory, the lowest bits may be wrong since we approach the root from one
-- side, but everything turns out fine for our constants.
newton f f' = iterate $ \x -> x - f x / f' x
agree (a:t@(b:_)) = if a == b then a else agree t
fracBits n = (`mod` 2^n) . agree . map (truncate . (2^n*))

primes = sieve [2..] where sieve (p:t) = p : sieve [n | n <- t, n `mod` p /= 0]
rt2 n = newton (\x -> x^2 - n) (\x -> 2*x)   1
rt3 n = newton (\x -> x^3 - n) (\x -> 3*x^2) 1

initHash :: [Word]
initHash = fromIntegral . fracBits 32 . rt2 . fromIntegral <$> take 8  primes
roundKs  :: [Word]
roundKs  = fromIntegral . fracBits 32 . rt3 . fromIntegral <$> take 64 primes

-- Swiped from `Data.List.Split`.
chunksOf i ls = map (take i) (go ls) where
  go [] = []
  go l  = l : go (drop i l)

-- Big-endian conversions and hex dumping for 32-bit words.
be4 n = [div n (256^k) `mod` 256 | k <- reverse [0..3]]
unbe4 cs = sum $ zipWith (*) cs $ (256^) <$> reverse [0..3]
hexdigit n = chr $ n + (if n <= 9 then ord '0' else ord 'a' - 10)
hex32 n = [hexdigit $ fromIntegral $ div n (16^k) `mod` 16 | k <- reverse [0..7]]

-- SHA-256, at last.
sha256 s = concatMap hex32 $ foldl chunky initHash $ chunksOf 16 ws where
  l = length s
  pad = 128 : replicate (4 + mod (-9 - l) 64) 0 ++ be4 (fromIntegral l * 8)
  ws = map unbe4 $ chunksOf 4 $ map (fromIntegral . fromEnum) s ++ pad

chunky h c = zipWith (+) h $ foldl hashRound h $ zipWith (+) roundKs w where
  w = c ++ foldr1 (zipWith (+)) [w, s0, drop 9 w, s1] where
    s0 = foldr1 (zipWith xor) $ map (<$> tail w) [ror 7, ror 18, shr 3]
    s1 = foldr1 (zipWith xor) $ map (<$> drop 14 w) [ror 17, ror 19, shr 10]
    shr = flip shiftR
    ror = flip rotateR

hashRound [a,b,c,d,e,f,g,h] kw = [t1 + t2, a, b, c, d + t1, e, f, g] where
  s1 = foldr1 xor $ map (rotateR e) [6, 11, 25]
  ch = (e .&. f) `xor` (complement e .&. g)
  t1 = h + s1 + ch + kw
  s0 = foldr1 xor $ map (rotateR a) [2, 13, 22]
  maj = (a .&. b) `xor` (a .&. c) `xor` (b .&. c)
  t2 = s0 + maj

main = interact sha256
-- https://keccak.team/keccak_specs_summary.html
-- https://en.wikipedia.org/wiki/SHA-3
--
-- This is the hash function used by Ethereum.
-- To get the SHA-3 256 standard hash, in the `pad` function,
-- change 0x81 to 0x86 and 0x01 to 0x06.
import Base
import System

-- Swiped from `Data.List.Split`.
chunksOf i ls = map (take i) (go ls) where
  go [] = []
  go l  = l : go (drop i l)

-- We lack the instance needed for the fancier `drop n <> take n`.
drta n xs = drop n xs <> take n xs
onHead f (h:t) = (f h:t)

kRound :: [[Word64]] -> Word64 -> [[Word64]]
kRound a rc = onHead (onHead $ xor rc) chi where
  c = foldr1 (zipWith xor) a
  d = zipWith xor (drta 4 c) (map (`rotateL` 1) $ drta 1 c)
  theta = map (zipWith xor d) a
  b = [[rotateL ((theta!!i)!!x) $ rotCon x i | i <- [0..4], let x = (3*j+i) `mod` 5] | j <- [0..4]]
  chi = zipWith (zipWith xor) b $ zipWith (zipWith (.&.)) (map (map complement . drta 1) b) $ map (drta 2) b

rotCon 0 0 = 0
rotCon x y = t `mod` 64 where
  Just t = lookup (x, y) hay
  hay = zip (iterate go (1, 0)) tri
  go (x, y) = (y, (3*y + 2*x) `mod` 5)
  tri = 1 : zipWith (+) tri [2..]

rcs :: [Word64]
rcs = take 24 $ go $ iterate lfsr 1 where
  go xs = sum (zipWith setOdd as [0..]) : go bs where
    (as, bs) = splitAt 7 xs
  setOdd n m = if mod n 2 == 1 then 2^(2^m - 1) else 0

lfsr :: Int -> Int
lfsr n
  | n < 128   = 2*n
  | otherwise = xor 0x71 $ 2*(n - 128)

keccak256 s = concatMap bytes $ take 4 $ head final where
  final = foldl go blank $ map fives $ chunksOf 17 $ word64s $ pad s
  go a b = foldl kRound (zipWith (zipWith xor) a b) rcs
  bytes n = take 8 $ chr . fromIntegral . (`mod` 256) <$> iterate (`div` 256) n

fives = iterate (drop 5) . (++ repeat 0)
blank = replicate 5 $ replicate 5 0
pad s = (s++) $ if n == 1 then ['\x81'] else '\x01':replicate (n - 2) '\x00' ++ ['\x80'] where
  n = 136 - mod (length s) 136

word64s :: String -> [Word64]
word64s [] = []
word64s xs = foldr go 0 <$> chunksOf 8 xs where
  go d acc = fromIntegral (fromEnum d) + 256*acc

hex c = (hexit q:) . (hexit r:) where (q, r) = divMod (ord c) 16
hexit c = chr $ c + (if c < 10 then 48 else 87)
xxd = concatMap (`hex` "")
main = interact $ xxd . keccak256

The above compiles a Haskell program to a WebAssembly binary [download it!], then runs it on the given input. Several language features are missing.

Best of the worst

In 2000, I took the Comprehensive Exams given by the Stanford University Computer Science department. In the Compilers exam, I got the top score…​of those who failed.

It didn’t matter because I scraped through the Databases exam instead. But how could I fail Compilers? I had sailed through my undergrad compilers course, and written a few toy compilers for fun. I resolved to one day unravel the mystery.

Since then, I have sporadically read about various compiler topics. Did my younger self deserve to fail? Maybe. There were certainly gaps in that guy’s knowledge (which are only a shade narrower now). On the other hand, there are equally alarming gaps in my textbooks, so maybe I shouldn’t have failed.

Or maybe I’m still bitter about that exam. In any case, here is a dilettante’s guide to writing compilers while thumbing your nose at the establishment.

(I also flunked AI, Networks, and Numerical Analysis. After reading John L. Gustafson, The End of Error: Unum Computing, I’m glad I’m not an expert on the stuff they asked in that Numerical Analysis exam. But that’s a topic for another day.)

See also


Ben Lynn blynn@cs.stanford.edu 💡