Тут будет много букв, я морально готовился месяц, поэтому за объем заранее извиняйте. Сразу скажу - на ассемблерах я не писатель, и цель треда - не обсуждение дизайнерских решений, а производительность монад. Суть всплывёт ближе к концу (я надеюсь).
Представим, что мы моделируем некий процессор, у которого есть простой набор инструкций. С инструкций и начнем:
data Register = R1 | R2 | R3 | R4 | R5 | R6
deriving (Show)
data Operator = ADD | SUB | MUL | DIV
| LESS | EQUAL | AND | OR | NOT
| MOV
| JMT | JMF | JMP
| PRN | NOP
deriving (Show)
class OperandClass a where
toOperand :: a -> Operand
instance OperandClass Register where
toOperand = R
instance OperandClass Operand where
toOperand = id
instance OperandClass () where
toOperand _ = N
data Operand = R !Register | V !Double | I !Int | N
deriving (Show)
type Instruction = (Operator, Operand, Operand)
Иными словами, всё очень просто: инструкция - это кортеж оператора и операндов, операндом могут быть регистр, значение, или ничего.
Чтобы кодить на нашем псевдоассемблере, потребуется таки простенький компилятор. Цель его - записать все инструкции в списочек.
-- | Monad for programming instructions
type ASM a = State [Instruction] a
compile :: ASM a -> [Instruction]
compile c = execState c []
op :: (OperandClass s, OperandClass d) => Operator -> s -> d -> ASM ()
op cmd src dst = modify $ \s -> s ++ [(cmd, toOperand src, toOperand dst)]
pos :: ASM Int
pos = liftM length get
nop :: ASM Int
nop = do { p <- pos; op NOP () (); return p}
putOp :: (OperandClass s, OperandClass d) => Int -> Operator -> s -> d -> ASM ()
putOp p cmd src dst = do
let instr = (cmd, toOperand src, toOperand dst)
(before,after) <- liftM (splitAt p) get
put $ before ++ instr : tail after
Тут, опять же, ничего сложного. Для наглядности, немного забегая вперед, приведу пример кода на этом «ассемблере». Данный код считает квадратный корень заданного числа методом Герона с заданным приближением (числом шагов):
-- | Heron's method to calculate square root
-- Inputs: r1 - value to calculate square root from
-- r2 - number of iterations
-- Outputs: r6 - output value
heron :: ASM ()
heron = do
op MOV (V 1) R5
op MOV (V 0) R3
iterStart <- pos
op MOV R3 R4
op EQUAL R2 R4
ifFalse <- nop
op MOV R1 R6
op DIV R5 R6
op ADD R5 R6
op MUL (V 0.5) R6
op MOV R6 R5
op ADD (V 1) R3
op JMP (I iterStart) ()
loopEnd <- pos
putOp ifFalse JMT R4 (I loopEnd)
op PRN R6 ()
Надеюсь, тут становится ясна необходимость в действиях pos, nop, и putOp, описанных ранее - их суть в расстановке меток и замене пустышек на инструкции, привязанные к меткам. Не самое элегантное, но, как по мне, вполне решение для организации циклических конструкций.
Идём дальше. Чтобы это всё выполнять, нужна ещё одна монада:
-- | Monad for executing instructions
data Registers = Registers
{ r1 :: !Double
, r2 :: !Double
, r3 :: !Double
, r4 :: !Double
, r5 :: !Double
, r6 :: !Double
} deriving (Show)
initialRs :: Registers
{-# INLINE initialRs #-}
initialRs = Registers
{ r1 = 0
, r2 = 0
, r3 = 0
, r4 = 0
, r5 = 0
, r6 = 0
}
type CPU a = StateT Registers IO a
execute ::Registers -> [Instruction] -> IO Registers
execute rs code = execStateT (exec code) rs
where
{-# INLINE exec #-}
exec ((JMP, I pos, _ ):is) = {-# SCC "JMP" #-} exec $! drop pos code
exec ((JMF, reg, I pos):is) = {-# SCC "JMF" #-} readVal reg >>= \v ->
exec $! if toBool v
then is
else drop pos code
exec ((JMT, reg, I pos):is) = {-# SCC "JMT" #-} readVal reg >>= \v ->
exec $! if toBool v
then drop pos code
else is
exec ((ins, src, dst):is) = {-# SCC "OP" #-} execOP ins src dst >> exec is
exec [] = return ()
execOP :: Operator -> Operand -> Operand -> CPU ()
{-# INLINE execOP #-}
execOP ADD src dst = {-# SCC "ADD" #-} arith ADD src dst
execOP SUB src dst = {-# SCC "SUB" #-} arith SUB src dst
execOP MUL src dst = {-# SCC "MUL" #-} arith MUL src dst
execOP DIV src dst = {-# SCC "DIV" #-} arith DIV src dst
execOP LESS src dst = {-# SCC "LESS" #-} logic LESS src dst
execOP EQUAL src dst = {-# SCC "EQUAL" #-} logic EQUAL src dst
execOP AND src dst = {-# SCC "AND" #-} logic AND src dst
execOP OR src dst = {-# SCC "OR" #-} logic OR src dst
execOP NOT src dst = {-# SCC "NOT" #-} logic NOT src dst
execOP MOV src dst = {-# SCC "MOV" #-} readVal src >>= \v -> putVal dst $! v
execOP PRN src _ = {-# SCC "PRN" #-} readVal src >>= \v -> liftIO $ print v
arith :: Operator -> Operand -> Operand -> CPU ()
{-# INLINE arith #-}
arith op src dst = do
v1 <- readVal src
v2 <- readVal dst
case op of
ADD -> putVal dst $! v2 + v1
SUB -> putVal dst $! v2 - v1
MUL -> putVal dst $! v2 * v1
DIV -> putVal dst $! v2 / v1
logic :: Operator -> Operand -> Operand -> CPU ()
{-# INLINE logic #-}
logic op src dst = do
v1 <- readVal src
v2 <- readVal dst
case op of
LESS -> putVal dst $! fromBool $ v2 < v1
EQUAL -> putVal dst $! fromBool $ v2 == v1
AND -> putVal dst $! fromBool $ toBool v1 && toBool v2
OR -> putVal dst $! fromBool $ toBool v1 && toBool v2
NOT -> putVal dst $! fromBool . not . toBool $ v1
fromBool :: Bool -> Double
{-# INLINE fromBool #-}
fromBool True = 1
fromBool False = 0
toBool :: Double -> Bool
{-# INLINE toBool #-}
toBool 0 = False
toBool _ = True
readVal :: Operand -> CPU Double
{-# INLINE readVal #-}
readVal (R R1) = gets r1
readVal (R R2) = gets r2
readVal (R R3) = gets r3
readVal (R R4) = gets r4
readVal (R R5) = gets r5
readVal (R R6) = gets r6
readVal (V v) = return v
putVal :: Operand -> Double -> CPU ()
{-# INLINE putVal #-}
putVal (R R1) v = modify $ \s -> s { r1 = v }
putVal (R R2) v = modify $ \s -> s { r2 = v }
putVal (R R3) v = modify $ \s -> s { r3 = v }
putVal (R R4) v = modify $ \s -> s { r4 = v }
putVal (R R5) v = modify $ \s -> s { r5 = v }
putVal (R R6) v = modify $ \s -> s { r6 = v }
Тут кода уже побольше, но, опять же, ничего сложного - мы просто проходимся по списку инструкций и интерпретируем каждую, выполняя соответствующие действия. Состояние нашего игрушечного процессора - шесть дабловых регистров.
Вот и всё!
Полная версия кода доступна на Гитхабе.
С файликом, загруженным в ghci, можно поиграться, например, так:
let h = compile heron
execute (initialRs {r1 = 25, r2 = 4}) h
5.015247601944898 Registers {r1 = 25.0, r2 = 4.0, r3 = 4.0, r4 = 1.0, r5 = 5.015247601944898, r6 = 5.015247601944898}
Но самое важное для меня в данной ситуации - это время, за которое наш компьютер посчитает 10 000 корней. Входные данные и скрипт для запуска есть в репозитории:
$ ghc --make -O3 Asm.hs $ ./measure.sh
Судя по результатам профайлера, основное время мы таки проводим в нашем процессоре:
COST CENTRE MODULE %time %alloc
OP Main 33.6 34.2
PRN Main 21.4 23.0
READ Main 16.4 12.8
MOV Main 8.8 13.2
ADD Main 5.4 6.7
DIV Main 3.3 3.7
EQUAL Main 3.1 3.4
MUL Main 2.7 3.0
JMT Main 2.3 0.0
JMP Main 1.9 0.0
individual inherited
COST CENTRE MODULE no. entries %time %alloc %time %alloc
MAIN MAIN 52 0 0.7 0.0 100.0 100.0
JMT Main 113 200000 2.3 0.0 80.7 85.4
OP Main 114 1610000 32.8 33.3 78.3 85.4
PRN Main 121 10000 21.4 23.0 21.4 23.0
EQUAL Main 120 200000 2.7 3.2 2.7 3.2
JMP Main 119 200000 1.9 0.0 1.9 0.0
MUL Main 118 200000 2.7 3.0 2.7 3.0
ADD Main 117 400000 5.4 6.7 5.4 6.7
DIV Main 116 200000 3.3 3.7 3.3 3.7
MOV Main 115 600000 8.2 12.6 8.2 12.6
EQUAL Main 111 0 0.4 0.2 0.4 0.2
MOV Main 108 0 0.6 0.6 0.6 0.6
OP Main 106 40000 0.8 0.9 0.8 0.9
JMT Main 112 10000 0.0 0.0 0.0 0.0
EQUAL Main 110 10000 0.0 0.0 0.0 0.0
MOV Main 107 30000 0.0 0.0 0.0 0.0
ITER Main 105 10000 0.4 0.1 0.4 0.1
READ Main 104 1 16.4 12.8 16.4 12.8
CAF Main 103 0 0.0 0.0 0.0 0.0
READ Main 109 0 0.0 0.0 0.0 0.0
Т.о., исполнение собственно операций (кроме ввода-вывода) занимает около 70% всего времени.
Внимание, суть!. Интересно, как зависит время выполнения от способа организации (или, если хотите, реализации) главной монады в тесте - CPU. Самое простое для начала - попробовать готовые реализации.
Мои результаты:
- 0.37с - для монады
CPU, реализованной поверх пакетаtransformers - 0.39c - для
mtl - 0.42c - для
contstuff
ХаскельВики рекомендует путь джедаев - ручной анроллинг стэков трансформеров и(ли) переход на CPS. Переход на CPS - вообще вещь легендарная, в иных историях успеха оно ускоряет код раз так в 4-8. Проверим:
newtype CPU a = CPU { runCPU :: forall r. Registers -> (a -> Registers -> IO r) -> IO r }
instance Monad CPU where
return = retCPU
(>>=) = bindCPU
instance MonadIO CPU where
liftIO = lioCPU
retCPU :: a -> CPU a
{-# INLINE retCPU #-}
retCPU x = CPU $ \s k -> k x s
bindCPU :: CPU a -> (a -> CPU b) -> CPU b
{-# INLINE bindCPU #-}
bindCPU (CPU m) f = CPU $ \s0 k -> m s0 $ \a s1 -> runCPU (f a) s1 k
lioCPU :: IO a -> CPU a
{-# INLINE lioCPU #-}
lioCPU f = CPU $ \s k -> f >>= \x -> k x s
get :: CPU Registers
{-# INLINE get #-}
get = CPU $ \s k -> k s s
gets :: (Registers -> a) -> CPU a
{-# INLINE gets #-}
gets f = get >>= \s -> return $! f s
put :: Registers -> CPU ()
{-# INLINE put #-}
put s = CPU $ \_ k -> k () s
modify :: (Registers -> Registers) -> CPU ()
{-# INLINE modify #-}
modify f = get >>= \s -> let s' = f s in put $! s'
Хотите верьте, хотите нет - такой вариант показал результат в 0.41c. Я в печали.
При ручном анроллинге (без CPS):
newtype CPU a = CPU { runCPU :: Registers -> IO (Registers, a) }
instance Monad CPU where
return = retCPU
(>>=) = bindCPU
instance MonadIO CPU where
liftIO f = CPU $ \s -> f >>= \x -> return (s, x)
retCPU :: a -> CPU a
{-# INLINE retCPU #-}
retCPU x = CPU $ \s -> return (s, x)
bindCPU :: CPU a -> (a -> CPU b) -> CPU b
{-# INLINE bindCPU #-}
bindCPU m f = CPU $ \s -> do (s', a) <- runCPU m s
runCPU (f a) s'
get :: CPU Registers
{-# INLINE get #-}
get = CPU $ \s -> return $! (s, s)
gets :: (Registers -> a) -> CPU a
{-# INLINE gets #-}
gets f = get >>= \s -> return $! f s
put :: Registers -> CPU ()
{-# INLINE put #-}
put s = CPU $ \_ -> return (s, ())
modify :: (Registers -> Registers) -> CPU ()
{-# INLINE modify #-}
modify f = get >>= \s -> let s' = f s in put $! s'
...всё несколько лучше, удалось получить 0.34с, но это всё равно не тот прирост, который я ожидал.
Данные эксперименты и опыт коллег, которые-делали-почти-то-же-самое-и-у-них-получилось, наталкивают на мысли, что что-то где-то пошло не так. Поэтому мой вопрос светлейшим умам форума сего - как воспроизвести те впечатляющие результаты с анроллингом и CPS? Какую деталь я мог упустить?
Для вашего удобства, весь код в его текущем состоянии выложен на Гитхабе, каждый вариант в своей ветке.
Простите ещё раз за такую простыню и неровный почерк. Всем любви!
