aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Sil/Compile.icl112
-rw-r--r--Sil/Parse.dcl4
-rw-r--r--Sil/Parse.icl42
-rw-r--r--Sil/Syntax.dcl13
-rw-r--r--Sil/Util.icl49
-rw-r--r--examples/fib.sil15
-rw-r--r--test.sil11
7 files changed, 182 insertions, 64 deletions
diff --git a/Sil/Compile.icl b/Sil/Compile.icl
index 2609f7c..4c0d02d 100644
--- a/Sil/Compile.icl
+++ b/Sil/Compile.icl
@@ -40,21 +40,23 @@ compile prog = case evalRWST (gen prog) () zero of
}
:: CompileState =
- { labels :: ['ABC'.Label]
- , addresses :: 'M'.Map Name Address
- , symbols :: 'M'.Map Name FunctionSymbol
- , returns :: ['ABC'.Assembler]
- , stackoffset :: Int
+ { labels :: ['ABC'.Label]
+ , addresses :: 'M'.Map Name Address
+ , symbols :: 'M'.Map Name FunctionSymbol
+ , returns :: ['ABC'.Assembler]
+ , stackoffset :: Int
+ , storedoffsets :: [Int]
}
instance zero CompileState
where
zero =
- { labels = ["_l" <+ i \\ i <- [0..]]
- , addresses = 'M'.newMap
- , symbols = 'M'.newMap
- , returns = []
- , stackoffset = 0
+ { labels = ["_l" <+ i \\ i <- [0..]]
+ , addresses = 'M'.newMap
+ , symbols = 'M'.newMap
+ , returns = []
+ , stackoffset = 0
+ , storedoffsets = []
}
labels :: CompileState -> ['ABC'.Label]
@@ -84,12 +86,19 @@ peekReturn cs = hd cs.returns
stackoffset :: CompileState -> Int
stackoffset cs = cs.stackoffset
+storeStackOffset :: CompileState -> CompileState
+storeStackOffset cs = {cs & storedoffsets=[cs.stackoffset:cs.storedoffsets]}
+
+restoreStackOffset :: CompileState -> CompileState
+restoreStackOffset cs = {cs & stackoffset=so, storedoffsets=sos}
+where [so:sos] = cs.storedoffsets
+
:: Gen a :== RWST () 'ABC'.Assembler CompileState (MaybeError CompileError) a
-fresh :: Gen 'ABC'.Label
-fresh = gets labels
+fresh :: a -> Gen 'ABC'.Label | toString a
+fresh n = gets labels
>>= \labs -> modify (\cs -> {cs & labels=tl labs})
- *> pure (hd labs)
+ *> pure (n <+ hd labs)
reserveVar :: Int Name -> Gen Int
reserveVar i n = modify (\cs -> {cs & addresses='M'.put n i cs.addresses}) *> pure (i+1)
@@ -130,11 +139,14 @@ where
, 'ABC'.Label f.f_name
] *>
foldM reserveVar locals [a.arg_name \\ a <- reverse f.f_args] *>
- modify (newReturn cleanup) *>
+ modify (newReturn cleanup`) *>
gen f.f_code *>
+ cleanup *>
+ shrinkStack (args - 1) *>
+ tell ['ABC'.Rtn] *>
modify popReturn
where
- cleanup = case f.f_args of
+ cleanup` = case f.f_args of
[] -> [ 'ABC'.Annotation $ 'ABC'.DAnnot 1 []
]
_ -> [ 'ABC'.Comment "Cleanup"
@@ -147,13 +159,15 @@ where
instance gen CodeBlock
where
- gen cb = foldM reserveVar 0 [i.init_name \\ i <- cb.cb_init] *>
+ gen cb =
+ modify storeStackOffset *>
+ foldM reserveVar 0 [i.init_name \\ i <- cb.cb_init] *>
mapM_ gen cb.cb_init *>
modify (addToReturn cleanup`) *>
mapM_ gen cb.cb_content *>
- cleanup *>
- tell ['ABC'.Rtn] *>
- modify (removeFromReturn $ length cleanup`)
+ tell cleanup` *>
+ modify (removeFromReturn $ length cleanup`) *>
+ modify restoreStackOffset
where
cleanup` = case cb.cb_init of
[] -> []
@@ -164,7 +178,7 @@ where
instance gen Initialisation
where
- gen init = comment ("Initialise " <+ init.init_name) *> tell ['ABC'.Create]
+ gen init = comment ("Initialise " <+ init.init_name) *> tell ['ABC'.Create] *> growStack 1
instance gen Statement
where
@@ -176,6 +190,28 @@ where
gen (Return (Just app)) = comment "Return" *> gen app *> cleanup *> tell ['ABC'.Rtn]
gen (Return Nothing) = comment "Return" *> cleanup *> tell ['ABC'.Rtn]
gen (MachineStm s) = tell ['ABC'.Raw s]
+ gen (If c t Nothing) =
+ fresh "ifend" >>= \end ->
+ comment "condition" *>
+ gen c *>
+ toBStack 'ABC'.BT_Bool 1 *>
+ tell [ 'ABC'.JmpFalse end ] *>
+ comment "if-true" *>
+ gen t *>
+ tell [ 'ABC'.Label end ]
+ gen (If c t (Just e)) =
+ fresh "else" >>= \else -> fresh "ifend" >>= \end ->
+ comment "condition" *>
+ gen c *>
+ toBStack 'ABC'.BT_Bool 1 *>
+ tell [ 'ABC'.JmpFalse else ] *>
+ comment "if-true" *>
+ gen t *>
+ tell [ 'ABC'.Jmp end
+ , 'ABC'.Label else ] *>
+ comment "if-false" *>
+ gen e *>
+ tell [ 'ABC'.Label end ]
instance gen Application
where
@@ -197,10 +233,10 @@ where
, 'ABC'.Jsr n
, 'ABC'.Annotation $ 'ABC'.OAnnot 1 []
] *>
- shrinkStack fs.fs_arity
+ shrinkStack (fs.fs_arity - 1)
_ -> liftT $ Error $ UndefinedName n
- gen (BuiltinApp op arg) = gen arg *> gen op *> growStack 1
- gen (BuiltinApp2 e1 op e2) = mapM gen [e1,e2] *> gen op *> growStack 1
+ gen (BuiltinApp op arg) = gen arg *> gen op
+ gen (BuiltinApp2 e1 op e2) = mapM gen [e1,e2] *> gen op
instance gen Op1
where
@@ -217,24 +253,38 @@ where
gen op =
toBStack 'ABC'.BT_Int 2 *>
tell [instr] *>
- BtoAStack 'ABC'.BT_Int
+ BtoAStack rettype
where
instr = case op of
- Add -> 'ABC'.AddI
- Sub -> 'ABC'.SubI
- Mul -> 'ABC'.MulI
- Div -> 'ABC'.DivI
- Rem -> 'ABC'.RemI
+ Add -> 'ABC'.AddI
+ Sub -> 'ABC'.SubI
+ Mul -> 'ABC'.MulI
+ Div -> 'ABC'.DivI
+ Rem -> 'ABC'.RemI
+ Equals -> 'ABC'.EqI
+ LogOr -> 'ABC'.AddI // TODO remove hack
+ LogAnd -> 'ABC'.MulI // TODO remove hack
+ rettype = case op of
+ Equals -> 'ABC'.BT_Bool
+ _ -> 'ABC'.BT_Int
toBStack :: 'ABC'.BasicType Int -> Gen ()
-toBStack t n = tell [push i \\ i <- [0..n-1]] *> tell ['ABC'.Pop_a (n-1)]
+toBStack t n =
+ tell [push i \\ i <- [0..n-1]] *>
+ tell (if (n <> 0) ['ABC'.Pop_a n] []) *>
+ shrinkStack n
where
push = case t of
'ABC'.BT_Bool -> 'ABC'.PushB_a
'ABC'.BT_Int -> 'ABC'.PushI_a
BtoAStack :: 'ABC'.BasicType -> Gen ()
-BtoAStack t = tell [fill 0 0, 'ABC'.Pop_b 1]
+BtoAStack t =
+ tell [ 'ABC'.Create
+ , fill 0 0
+ , 'ABC'.Pop_b 1
+ ] *>
+ growStack 1
where
fill = case t of
'ABC'.BT_Bool -> 'ABC'.FillB_b
diff --git a/Sil/Parse.dcl b/Sil/Parse.dcl
index 6febca5..0d00969 100644
--- a/Sil/Parse.dcl
+++ b/Sil/Parse.dcl
@@ -21,8 +21,12 @@ from Sil.Syntax import :: Program, :: Literal
| TStar //* *
| TSlash //* /
| TPercent //* %
+ | TDoubleEquals //* ==
+ | TDoubleBar //* ||
+ | TDoubleAmpersand //* &&
| TLit Literal //* True; False; integers
| TIf //* if
+ | TElse //* else
| TWhile //* while
| TReturn //* return
| TMachineCode String //* |~ machine code
diff --git a/Sil/Parse.icl b/Sil/Parse.icl
index ec25c1f..092d3da 100644
--- a/Sil/Parse.icl
+++ b/Sil/Parse.icl
@@ -67,6 +67,10 @@ tokenise cs = reverse <$> tks cs []
where
tks :: [Char] [Token] -> MaybeError ParseError [Token]
tks [] t = pure t
+ tks [':':'=':r] t = tks r [TAssign :t]
+ tks ['=':'=':r] t = tks r [TDoubleEquals :t]
+ tks ['|':'|':r] t = tks r [TDoubleBar :t]
+ tks ['&':'&':r] t = tks r [TDoubleAmpersand:t]
tks ['(':r] t = tks r [TParenOpen :t]
tks [')':r] t = tks r [TParenClose:t]
tks ['{':r] t = tks r [TBraceOpen :t]
@@ -79,8 +83,8 @@ where
tks ['*':r] t = tks r [TStar :t]
tks ['/':r] t = tks r [TSlash :t]
tks ['%':r] t = tks r [TPercent :t]
- tks [':':'=':r] t = tks r [TAssign :t]
tks ['i':'f' :s:r] t | isSpace s = tks r [TIf :t]
+ tks ['e':'l':'s':'e' :s:r] t | isSpace s = tks r [TElse :t]
tks ['w':'h':'i':'l':'e' :s:r] t | isSpace s = tks r [TWhile :t]
tks ['r':'e':'t':'u':'r':'n':s:r] t | isSpace s = tks r [TReturn:t]
tks ['T':'r':'u':'e' :s:r] t | isSpace s = tks r [TLit $ BLit True :t]
@@ -137,8 +141,8 @@ statement :: Parser Token Statement
statement = ((declaration
<|> liftM Application application
<|> return
-/* <|> if`
- <|> while*/) <* item TSemicolon) <|> machinecode
+ <|> if`
+ /*<|> while*/) <* item TSemicolon) <|> machinecode
where
declaration :: Parser Token Statement
declaration = liftM2 Declaration name (item TAssign *> application)
@@ -150,22 +154,36 @@ where
machinecode = (\(TMachineCode s) -> MachineStm s) <$> satisfy isMachineCode
where isMachineCode (TMachineCode _) = True; isMachineCode _ = False
+ if` :: Parser Token Statement
+ if` = item TIf *>
+ parenthised application >>= \cond ->
+ braced codeblock >>= \iftrue ->
+ optional (item TElse *> braced codeblock) >>= \iffalse ->
+ pure $ If cond iftrue iffalse
+
application :: Parser Token Application
application
- = leftAssoc
- ( op TPlus Add
- <|> op TMinus Sub
+ = rightAssoc (op TDoubleBar LogOr)
+ $ rightAssoc (op TDoubleAmpersand LogAnd)
+ $ rightAssoc (op TDoubleEquals Equals)
+ $ leftAssoc
+ ( op TPlus Add
+ <|> op TMinus Sub
)
$ leftAssoc
- ( op TStar Mul
- <|> op TSlash Div
- <|> op TPercent Rem
+ ( op TStar Mul
+ <|> op TSlash Div
+ <|> op TPercent Rem
)
$ noInfix
where
op :: Token Op2 -> Parser Token Op2
op token operator = item token *> pure operator
+ rightAssoc :: (Parser Token Op2) (Parser Token Application) -> Parser Token Application
+ rightAssoc opp appp = appp >>= \e1 -> optional (opp >>= \op -> rightAssoc opp appp >>= \e -> pure (op,e))
+ >>= pure o maybe e1 (\(op,e2) -> BuiltinApp2 e1 op e2)
+
leftAssoc :: (Parser Token Op2) (Parser Token Application) -> Parser Token Application
leftAssoc opp appp = appp >>= \e1 -> many (opp >>= \op -> appp >>= \e -> pure (op,e))
>>= foldM (\e (op,e2) -> pure $ BuiltinApp2 e op e2) e1
@@ -202,3 +220,9 @@ where
isLit :: Token -> Bool
isLit (TLit _) = True
isLit _ = False
+
+parenthised :: (Parser Token a) -> Parser Token a
+parenthised p = item TParenOpen *> p <* item TParenClose
+
+braced :: (Parser Token a) -> Parser Token a
+braced p = item TBraceOpen *> p <* item TBraceClose
diff --git a/Sil/Syntax.dcl b/Sil/Syntax.dcl
index d6662ef..6df64a3 100644
--- a/Sil/Syntax.dcl
+++ b/Sil/Syntax.dcl
@@ -47,11 +47,14 @@ from Data.Maybe import :: Maybe
= Neg //* ~
:: Op2
- = Add //* +
- | Sub //* -
- | Mul //* *
- | Div //* /
- | Rem //* %
+ = Add //* +
+ | Sub //* -
+ | Mul //* *
+ | Div //* /
+ | Rem //* %
+ | Equals //* ==
+ | LogOr //* ||
+ | LogAnd //* &&
:: Type
= TBool
diff --git a/Sil/Util.icl b/Sil/Util.icl
index ad7cfac..35b8522 100644
--- a/Sil/Util.icl
+++ b/Sil/Util.icl
@@ -22,6 +22,12 @@ import Sil.Syntax
instance zero PrintState where zero = {indent=0}
+incIndent :: PrintState -> PrintState
+incIndent ps = {ps & indent=inc ps.indent}
+
+decIndent :: PrintState -> PrintState
+decIndent ps = {ps & indent=dec ps.indent}
+
instance toString PrintState where toString st = {'\t' \\ _ <- [1..st.indent]}
instance PrettyPrinter [Token]
@@ -83,14 +89,24 @@ instance PrettyPrinter Initialisation
where
print st init = st <+ init.init_type <+ " " <+ init.init_name <+ ";"
-instance PrettyPrinter Statement where print st stm = st <+ stm <+ ";"
+instance PrettyPrinter Statement
+where
+ print st (If c t Nothing) = st <+ "if (" <+ c <+ ") {\r\n" <+
+ print (incIndent st) t <+ "\r\n" <+ st <+ "}"
+ print st (If c t (Just e)) = st <+ "if (" <+ c <+ ") {\r\n" <+
+ print st` t <+ "\r\n" <+ st <+ "} else {\r\n" <+
+ print st` e <+ "\r\n" <+ st <+ "}"
+ where st` = incIndent st
+ print st stm = st <+ stm
instance toString Statement
where
- toString (Declaration n a) = n <+ " " <+ TAssign <+ " " <+ a
- toString (Application app) = toString app
- toString (Return Nothing) = "return"
- toString (Return (Just a)) = "return " <+ a <+ ""
+ toString (Declaration n a) = n <+ " " <+ TAssign <+ " " <+ a <+ ";"
+ toString (Application app) = toString app <+ ";"
+ toString (Return Nothing) = "return;"
+ toString (Return (Just a)) = "return " <+ a <+ ";"
+ toString (If c t e) = "if (" <+ c <+ ") ..."
+ toString (MachineStm s) = "|~" <+ s
toString _ = "<<unimplemented Statement>>"
instance toString Type
@@ -103,9 +119,26 @@ instance toString Arg where toString arg = arg.arg_type <+ " " <+ arg.arg_name
instance toString Application
where
- toString (Name n) = n
- toString (Literal lit) = toString lit
- toString (App n args) = n <+ "(" <+ printersperse ", " args <+ ")"
+ toString (Name n) = n
+ toString (Literal lit) = toString lit
+ toString (App n args) = n <+ "(" <+ printersperse ", " args <+ ")"
+ toString (BuiltinApp op e) = op <+ "(" <+ e <+ ")"
+ toString (BuiltinApp2 e1 op e2) = "(" <+ e1 <+ ") " <+ op <+ " (" <+ e2 <+ ")"
+
+instance toString Op1
+where
+ toString Neg = "~"
+
+instance toString Op2
+where
+ toString Add = "+"
+ toString Sub = "-"
+ toString Mul = "*"
+ toString Div = "/"
+ toString Rem = "%"
+ toString Equals = "=="
+ toString LogOr = "||"
+ toString LogAnd = "&&"
instance toString Literal
where
diff --git a/examples/fib.sil b/examples/fib.sil
new file mode 100644
index 0000000..b974722
--- /dev/null
+++ b/examples/fib.sil
@@ -0,0 +1,15 @@
+Int fib(Int n) {
+ if (n == 100) {
+ return 100;
+ } else {
+ if (n == 200) {
+ return 100;
+ } else {
+ return fib(n - 100) + fib(n - 200);
+ };
+ };
+}
+
+Int main() {
+ return fib(1000);
+}
diff --git a/test.sil b/test.sil
deleted file mode 100644
index 6493308..0000000
--- a/test.sil
+++ /dev/null
@@ -1,11 +0,0 @@
-Int second(Int x, Int y) {
- Int a, b;
- a := x;
- x := y;
- y := a;
- return y;
-}
-
-Int main () {
- return second(100, 200);
-}
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-12 20:24:30 +0000