1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
{-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving #-}
module Compiler(compile) where
import Control.Monad.State.Strict
import Control.Monad.Writer.Strict
import Data.List
import AST
-- Execution starts in the middle of the tape
tapeLength :: Offset
tapeLength = 60000
newtype LineWriter a = LineWriter {unLineWriter :: WriterT [String] (State Int) a}
deriving (Functor, Applicative, Monad, MonadWriter [String], MonadState Int)
runLineWriter :: LineWriter a -> String
runLineWriter = (++ "\n") . intercalate "\n" . flip evalState 1 . execWriterT . unLineWriter
emit0 :: String -> LineWriter ()
emit0 = tell . pure
emit :: String -> LineWriter ()
emit = tell . pure . ('\t' :)
genId :: LineWriter Int
genId = state $ \i -> (i, i + 1)
compile :: Program -> String
compile (Program inss) = runLineWriter $ do
emit0 prologue
mapM_ compileIns inss
emit0 epilogue
cursor :: String
cursor = "rbx"
compileIns :: Instruction -> LineWriter ()
compileIns (IAdd v off) = emit $ "add byte [" ++ cursor ++ " + " ++ show off ++ "], " ++ show v
compileIns (ISet v off) = emit $ "mov byte [" ++ cursor ++ " + " ++ show off ++ "], " ++ show v
compileIns (IMove from []) = do
emit $ "mov byte [" ++ cursor ++ " + " ++ show from ++ "], 0"
compileIns (IMove from [(o,m)]) = do
emit $ "mov al, [" ++ cursor ++ " + " ++ show from ++ "]"
if m == 1 then return ()
else do
emit $ "mov cl, " ++ show m
emit "mul byte cl"
emit $ "add [" ++ cursor ++ " + " ++ show o ++ "], al"
emit $ "mov byte [" ++ cursor ++ " + " ++ show from ++ "], 0"
compileIns (IMove from tos) = do
emit $ "mov dl, [" ++ cursor ++ " + " ++ show from ++ "]"
emit $ "mov byte [" ++ cursor ++ " + " ++ show from ++ "], 0"
forM_ tos $ \(o,m) -> do
emit "mov al, dl"
if m == 1 then return ()
else do
emit $ "mov cl, " ++ show m
emit "mul byte cl"
emit $ "add [" ++ cursor ++ " + " ++ show o ++ "], al"
compileIns (ISlide off) = emit $ "add " ++ cursor ++ ", " ++ show off
compileIns (ILoop inss off) = do
loopid <- genId
emit $ "cmp byte [" ++ cursor ++ " + " ++ show off ++ "], 0"
emit $ "jz .Laf_" ++ show loopid
emit0 $ ".Lbd_" ++ show loopid ++ ":"
mapM_ compileIns inss
emit $ "cmp byte [" ++ cursor ++ " + " ++ show off ++ "], 0"
emit $ "jnz .Lbd_" ++ show loopid
emit0 $ ".Laf_" ++ show loopid ++ ":"
compileIns (IInput off) = do
emit "call _getchar"
emit $ "mov [" ++ cursor ++ " + " ++ show off ++ "], al"
compileIns (IOutput off) = do
emit "xor edi, edi"
emit $ "mov dil, [" ++ cursor ++ " + " ++ show off ++ "]"
emit "call _putchar"
compileIns IStart = return ()
prologue :: String
prologue =
"global _main"
++ "\nextern _calloc, _free, _putchar, _getchar, _write"
++ "\ndefault rel"
++ "\nsection .text"
++ "\n_main:"
++ "\n\tpush rbp"
++ "\n\tmov rbp, rsp"
++ "\n\tpush rbx"
++ "\n\tsub rsp, 8"
++ "\n\tmov edi, " ++ show tapeLength
++ "\n\tmov esi, 1"
++ "\n\tcall _calloc"
++ "\n\ttest rax, rax"
++ "\n\tjz .allocation_failure"
++ "\n\tlea rbx, [rax + " ++ show (tapeLength `div` 2) ++ "] ; rbx = cursor"
++ "\n\tmov [rsp], rax ; [rsp] = start of tape buffer"
++ "\n"
epilogue :: String
epilogue =
"\n\tmov rdi, [rsp]"
++ "\n\tcall _free"
++ "\n\txor eax, eax"
++ "\n.return:"
++ "\n\tadd rsp, 8"
++ "\n\tpop rbx"
++ "\n\tmov rsp, rbp"
++ "\n\tpop rbp"
++ "\n\tret"
++ "\n.allocation_failure:"
++ "\n\tsub rsp, 32"
++ "\n\tmov rax, 0x697461636f6c6c41 ; \"Allocati\""
++ "\n\tmov rbx, 0x756c696166206e6f ; \"on failu\""
++ "\n\tmov ecx, 0x000a6572 ; \"re\\n\\0\""
++ "\n\tmov [rsp], rax"
++ "\n\tmov [rsp+8], rbx"
++ "\n\tmov [rsp+16], ecx"
++ "\n\tmov edi, 2"
++ "\n\tmov rsi, rsp"
++ "\n\tmov edx, 20"
++ "\n\tcall _write"
++ "\n\tadd rsp, 32"
++ "\n\tmov eax, 1"
++ "\n\tjmp .return"
|
