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 data State = State ([AST], [Token]) deriving (Show)
65 
66 initialState tokens = State ([[]], tokens)
67 
68 finalize (State ([x], _)) = Just x
69 finalize _ = Nothing
70 
71 simplexpr :: Expr -> [AST] -> [Token] -> State
72 simplexpr e (x:xs) tokens = State ((x ++ [e]):xs, tokens)
73 
74 translate :: Token -> Expr
75 translate x = case x of
76                 Plus    -> Inc
77                 Minus   -> Dec
78                 Lesser  -> ShiftLeft
79                 Greater -> ShiftRight
80                 Point   -> Output
81                 Comma   -> Input
82 
83 parser :: State -> Maybe State
84 parser (State (stack, (x:xs))) =
85   case x of
86     BracketOpen -> parser $ State ([]:stack, xs)
87     BracketClose -> case stack of
88                       (y:ys) -> parser $ simplexpr (Loop y) (ys) xs
89                       _      -> Nothing
90     _ -> parser $ simplexpr (translate x) stack xs
91 parser state = Just state
92 
93 parse :: [Token] -> Maybe AST
94 parse tokens = parser (initialState tokens) >>= finalize
95 
96 prologue = "export function w $main() {\n" ++
97            "@start\n" ++
98            "    %.1 =l alloc8 8\n" ++
99            "    storel $tape, %.1"
100 epilogue = "    ret 0\n" ++
101            "}\n" ++
102            "data $tape = align 8 { z 4096 }"
103 
104 -- subset of QBE that I need to convert the AST to
105 data Instruction = StoreW (Int, Int)        -- storew a, b
106                  | StoreL (Int, Int)        -- storel a, b
107                  | LoadW (Int, Int)         -- a =w loadw b
108                  | LoadL (Int, Int)         -- a =w loadl b
109                  | AddW (Int, Int, Int)     -- a =w add b, c
110                  | AddL (Int, Int, Int)     -- a =l add b, c
111                  | SubW (Int, Int, Int)     -- a =w sub b, c
112                  | SubL (Int, Int, Int)     -- a =l sub b, c
113                  | Call0 (Int, String)      -- a =w call $b()
114                  | Call1 (Int, String, Int) -- a =w call $b(w c)
115                  | Jmp (Int)                -- jmp a
116                  | Jnz (Int, Int, Int)      -- jnz a, @loop.b, @loop.c
117                  | Label (Int)              -- @loop.a
118   deriving (Eq)
119 
120 instance Show Instruction where
121   show x =
122     case x of
123       StoreW (a, b)    -> printf "    storew %%.%d, %%.%d" a b
124       StoreL (a, b)    -> printf "    storel %%.%d, %%.%d" a b
125       LoadW (a, b)     -> printf "    %%.%d =w loadw %%.%d" a b
126       LoadL (a, b)     -> printf "    %%.%d =l loadl %%.%d" a b
127       AddW (a, b, c)   -> printf "    %%.%d =w add %%.%d, %d" a b c
128       AddL (a, b, c)   -> printf "    %%.%d =l add %%.%d, %d" a b c
129       SubW (a, b, c)   -> printf "    %%.%d =w sub %%.%d, %d" a b c
130       SubL (a, b, c)   -> printf "    %%.%d =l sub %%.%d, %d" a b c
131       Call0 (a, fn)    -> printf "    %%.%d =w call $%s()" a fn
132       Call1 (a, fn, b) -> printf "    %%.%d =w call $%s(w %%.%d)" a fn b
133       Jmp (a)          -> printf "    jmp @loop.%d" a
134       Jnz (a, b, c)    -> printf "    jnz %%.%d, @loop.%d, @loop.%d" a b c
135       Label (a)        -> printf "@loop.%d" a
136 
137 -- I'm keeping the pointer to the current cell in the "%.1"
138 -- intermediary.  It's always there because qbe allows to
139 --	storel %.X %.1
140 -- even if it's a SSA.
141 cell = 1
142 
143 compile' :: Int -> Int -> [AST] -> [[Instruction]] -> [Instruction]
144 compile' n h ((x:xs):ys) trail =
145   case x of
146     Inc -> LoadL(n+1, cell)  :
147            LoadW(n+2, n+1)   :
148            AddW(n+3, n+2, 1) :
149            StoreW(n+3, n+1)  :
150            compile' (n+3) h (xs:ys) trail
151     Dec -> LoadL(n+1, cell)  :
152            LoadW(n+2, n+1)   :
153            SubW(n+3, n+2, 1) :
154            StoreW(n+3, n+1)  :
155            compile' (n+3) h (xs:ys) trail
156     ShiftLeft -> LoadL(n+1, cell)  :
157                  SubL(n+2, n+1, 4) :
158                  StoreL(n+2, cell) :
159                  compile' (n+2) h (xs:ys) trail
160     ShiftRight -> LoadL(n+1, cell)  :
161                   AddL(n+2, n+1, 4) :
162                   StoreL(n+2, cell) :
163                   compile' (n+2) h (xs:ys) trail
164     Input -> Call0(n+1, "getchar") :
165              LoadL(n+2, cell)      :
166              StoreW(n+1, n+2)      :
167              compile' (n+2) h (xs:ys) trail
168     Output -> LoadL(n+1, cell)           :
169               LoadW(n+2, n+1)            :
170               Call1(n+3, "putchar", n+2) :
171               compile' (n+3) h (xs:ys) trail
172     Loop (ast) -> Label(h)           :
173                   LoadL(n+1, cell)   :
174                   LoadW(n+2, n+1)    :
175                   Jnz(n+2, h+1, h+2) :
176                   Label(h+1)         :
177                   compile' (n+3) (h+3) (ast:(xs:ys)) ([Jmp(h), Label(h+2)]:trail)
178 compile' n h ([]:ys) (t:ts) = t ++ (compile' n h ys ts)
179 compile' _ _ _ _ = []
180 
181 compile ast = compile' 1 1 [ast] []
182 
183 compileProg program = do
184   let t = parse $ tokenize program in
185     case t of
186       Just ast -> do putStrLn prologue
187                      mapM_ print (compile ast)
188                      putStrLn epilogue
189       Nothing  -> error "Compilation failed"
190 
191 parseArgs [] = getContents
192 parseArgs path = concat `fmap` mapM readFile path
193 
194 main = E.getArgs >>= parseArgs >>= compileProg