1 -- This is free and unencumbered software released into the public domain.
2 --
3 -- Anyone is free to copy, modify, publish, use, compile, sell, or
4 -- distribute this software, either in source code form or as a compiled
5 -- binary, for any purpose, commercial or non-commercial, and by any
6 -- means.
7 --
8 -- In jurisdictions that recognize copyright laws, the author or authors
9 -- of this software dedicate any and all copyright interest in the
10 -- software to the public domain. We make this dedication for the benefit
11 -- of the public at large and to the detriment of our heirs and
12 -- successors. We intend this dedication to be an overt act of
13 -- relinquishment in perpetuity of all present and future rights to this
14 -- software under copyright law.
15 --
16 -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
17 -- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
18 -- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
19 -- IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR
20 -- OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
21 -- ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
22 -- OTHER DEALINGS IN THE SOFTWARE.
23 --
24 -- For more information, please refer to <http://unlicense.org/>
25 
26 module Main where
27 
28 import Text.Printf
29 import System.Environment as E
30 
31 data Token = Plus
32            | Minus
33            | Lesser
34            | Greater
35            | Point
36            | Comma
37            | BracketOpen
38            | BracketClose
39            deriving (Eq, Show)
40 
41 tokenize :: String -> [Token]
42 tokenize (x:xs) =
43   let table = [ ('-', Minus), ('+', Plus)
44               , ('<', Lesser), ('>', Greater)
45               , ('.', Point), (',', Comma)
46               , ('[', BracketOpen), (']', BracketClose) ]
47       token = lookup x table in
48     case token of
49       Just x  -> x:(tokenize xs)
50       Nothing -> tokenize xs
51 tokenize _ = []
52 
53 data Expr = Inc
54           | Dec
55           | ShiftLeft
56           | ShiftRight
57           | Input
58           | Output
59           | Loop [Expr]
60           deriving (Eq, Show)
61 
62 type AST = [Expr]
63 
64 pushexpr expr (y:ys) = (expr:y):ys
65 
66 parser :: [Token] -> [AST] -> Either String AST
67 parser (x:xs) stack =
68   case x of
69     BracketOpen -> parser xs ([]:stack)
70     BracketClose -> case stack of
71                       (y:(z:zs)) -> parser xs $ pushexpr (Loop (reverse y)) (z:zs)
72                       _          -> Left "unexpected end of loop"
73     _ -> parser xs $ pushexpr expr stack
74       where expr = case x of
75                      Plus    -> Inc
76                      Minus   -> Dec
77                      Lesser  -> ShiftLeft
78                      Greater -> ShiftRight
79                      Point   -> Output
80                      Comma   -> Input
81 parser _ [x] = return (reverse x)
82 parser _ _ = Left "unterminated loop"
83 
84 parse toks = parser toks [[]]
85 
86 prologue = "export function w $main() {\n" ++
87            "@start\n" ++
88            "    %.1 =l alloc8 8\n" ++
89            "    storel $tape, %.1"
90 epilogue = "    ret 0\n" ++
91            "}\n" ++
92            "data $tape = align 8 { z 4096 }"
93 
94 -- subset of QBE that I need to convert the AST to
95 data Instruction = StoreW (Int, Int)        -- storew a, b
96                  | StoreL (Int, Int)        -- storel a, b
97                  | LoadW (Int, Int)         -- a =w loadw b
98                  | LoadL (Int, Int)         -- a =w loadl b
99                  | AddW (Int, Int, Int)     -- a =w add b, c
100                  | AddL (Int, Int, Int)     -- a =l add b, c
101                  | SubW (Int, Int, Int)     -- a =w sub b, c
102                  | SubL (Int, Int, Int)     -- a =l sub b, c
103                  | Call0 (Int, String)      -- a =w call $b()
104                  | Call1 (Int, String, Int) -- a =w call $b(w c)
105                  | Jmp (Int)                -- jmp a
106                  | Jnz (Int, Int, Int)      -- jnz a, @loop.b, @loop.c
107                  | Label (Int)              -- @loop.a
108   deriving (Eq)
109 
110 instance Show Instruction where
111   show x =
112     case x of
113       StoreW (a, b)    -> printf "    storew %%.%d, %%.%d" a b
114       StoreL (a, b)    -> printf "    storel %%.%d, %%.%d" a b
115       LoadW (a, b)     -> printf "    %%.%d =w loadw %%.%d" a b
116       LoadL (a, b)     -> printf "    %%.%d =l loadl %%.%d" a b
117       AddW (a, b, c)   -> printf "    %%.%d =w add %%.%d, %d" a b c
118       AddL (a, b, c)   -> printf "    %%.%d =l add %%.%d, %d" a b c
119       SubW (a, b, c)   -> printf "    %%.%d =w sub %%.%d, %d" a b c
120       SubL (a, b, c)   -> printf "    %%.%d =l sub %%.%d, %d" a b c
121       Call0 (a, fn)    -> printf "    %%.%d =w call $%s()" a fn
122       Call1 (a, fn, b) -> printf "    %%.%d =w call $%s(w %%.%d)" a fn b
123       Jmp (a)          -> printf "    jmp @loop.%d" a
124       Jnz (a, b, c)    -> printf "    jnz %%.%d, @loop.%d, @loop.%d" a b c
125       Label (a)        -> printf "@loop.%d" a
126 
127 -- I'm keeping the pointer to the current cell in the "%.1"
128 -- intermediary.  It's always there because qbe allows to
129 --	storel %.X %.1
130 -- even if it's a SSA.
131 cell = 1
132 
133 compile' :: Int -> Int -> [AST] -> [Int] -> [Instruction]
134 compile' n h ((x:xs):ys) trail =
135   case x of
136     Inc -> LoadL(n+1, cell)  :
137            LoadW(n+2, n+1)   :
138            AddW(n+3, n+2, 1) :
139            StoreW(n+3, n+1)  :
140            compile' (n+3) h (xs:ys) trail
141     Dec -> LoadL(n+1, cell)  :
142            LoadW(n+2, n+1)   :
143            SubW(n+3, n+2, 1) :
144            StoreW(n+3, n+1)  :
145            compile' (n+3) h (xs:ys) trail
146     ShiftLeft -> LoadL(n+1, cell)  :
147                  SubL(n+2, n+1, 4) :
148                  StoreL(n+2, cell) :
149                  compile' (n+2) h (xs:ys) trail
150     ShiftRight -> LoadL(n+1, cell)  :
151                   AddL(n+2, n+1, 4) :
152                   StoreL(n+2, cell) :
153                   compile' (n+2) h (xs:ys) trail
154     Input -> Call0(n+1, "getchar") :
155              LoadL(n+2, cell)      :
156              StoreW(n+1, n+2)      :
157              compile' (n+2) h (xs:ys) trail
158     Output -> LoadL(n+1, cell)           :
159               LoadW(n+2, n+1)            :
160               Call1(n+3, "putchar", n+2) :
161               compile' (n+3) h (xs:ys) trail
162     Loop (ast) -> Label(h)           :
163                   LoadL(n+1, cell)   :
164                   LoadW(n+2, n+1)    :
165                   Jnz(n+2, h+1, h+2) :
166                   Label(h+1)         :
167                   compile' (n+3) (h+3) (ast:(xs:ys)) (h:trail)
168 compile' n h ([]:ys) (t:ts) = Jmp(t) : Label(t+2) : compile' n h ys ts
169 compile' _ _ _ _ = []
170 
171 compile ast = compile' 1 1 [ast] []
172 
173 compileProg program = do
174   let t = parse $ tokenize program in
175     case t of
176       Right ast -> do putStrLn prologue
177                       mapM_ print (compile ast)
178                       putStrLn epilogue
179       Left err  -> error err
180 
181 parseArgs [] = getContents
182 parseArgs path = concat `fmap` mapM readFile path
183 
184 main = E.getArgs >>= parseArgs >>= compileProg