aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--AST.hs6
-rw-r--r--BuildIR.hs27
-rw-r--r--CodeGen.hs13
-rw-r--r--Intermediate.hs2
-rw-r--r--Main.hs2
-rw-r--r--Optimiser.hs8
-rw-r--r--ProgramParser.hs19
-rw-r--r--ReplaceRefs.hs1
-rw-r--r--TypeCheck.hs6
-rw-r--r--X64.hs7
-rw-r--r--bf.lang1
-rw-r--r--primes.bf194
12 files changed, 273 insertions, 13 deletions
diff --git a/AST.hs b/AST.hs
index 197edf9..dae2631 100644
--- a/AST.hs
+++ b/AST.hs
@@ -63,6 +63,7 @@ data Literal
| LChar Char
| LVar Name
| LCall Name [Expression]
+ | LStr String
deriving (Show, Eq)
@@ -74,8 +75,8 @@ sizeof (TArr _ _) = 8
instance Pretty Program where
prettyI i (Program vars funcs) =
- concatMap (++ ("\n" ++ indent i)) $
- map (prettyI i) vars ++ map (prettyI i) funcs
+ intercalate ("\n" ++ indent i) (map (prettyI i) vars ++ map (prettyI i) funcs)
+ ++ "\n"
where
indent n = replicate (2*n) ' '
@@ -182,3 +183,4 @@ instance Pretty Literal where
prettyI _ (LVar n) = n
prettyI i (LCall n al) =
n ++ "(" ++ intercalate ", " (map (prettyI i) al) ++ ")"
+ prettyI _ (LStr s) = show s
diff --git a/BuildIR.hs b/BuildIR.hs
index c64adb1..5b12dc2 100644
--- a/BuildIR.hs
+++ b/BuildIR.hs
@@ -24,7 +24,8 @@ data BuildState = BuildState
loopStack :: [Id],
currentBlock :: Id,
errorBlock :: Id,
- blockMap :: Map.Map Id BB }
+ blockMap :: Map.Map Id BB,
+ internedStrings :: [(Name, String)] }
initBuildState :: BuildState
initBuildState = BuildState
@@ -33,7 +34,8 @@ initBuildState = BuildState
loopStack = [],
currentBlock = undefined,
errorBlock = undefined,
- blockMap = Map.empty }
+ blockMap = Map.empty,
+ internedStrings = [] }
newtype BuildM a = BuildM {unBuildM :: StateT BuildState (Except String) a}
deriving (Functor, Applicative, Monad, MonadState BuildState, MonadError String)
@@ -116,6 +118,14 @@ findVar n = do
return $ fmap (\idx -> (idx, fromJust (results !! idx))) $
findIndex isJust results
+internString :: String -> BuildM Ref
+internString str = do
+ i <- genId
+ let n = "__str_cnst_" ++ show i
+ ref <- genTemp (sizeof TInt)
+ addIns $ ILea ref n
+ state $ \s -> (ref, s {internedStrings = internedStrings s ++ [(n, str)]})
+
buildIR :: Program -> Error IRProgram
buildIR (Program vars funcs) =
@@ -123,7 +133,7 @@ buildIR (Program vars funcs) =
where
goDFunc :: DFunc -> BuildM IRFunc
goDFunc (DFunc rt n al bl) = do
- clearBlockMap
+ clearBlockMap
firstid <- newBlock
lastid <- newBlockNoSwitch
makeErrorBlock >>= setErrorBlock
@@ -147,7 +157,12 @@ buildIR (Program vars funcs) =
result = do
withScope $ do
mapM_ (\(DVar t n _) -> scopeInsert n (Global (sizeof t) n) t) vars
- IRProgram vars <$> mapM goDFunc funcs
+ funcs' <- mapM goDFunc funcs
+ ns <- gets internedStrings
+ let strvars = flip map ns $ \(n, str) ->
+ let t = TArr TChar (Just $ fromIntegral $ length str)
+ in DVar t n (ELit (LStr str) (Just t))
+ return $ IRProgram (vars ++ strvars) funcs'
convertBlock :: Block -> Id -> BuildM ()
convertBlock (Block sts) nextnext = do
@@ -250,6 +265,10 @@ convertExpression (ELit (LCall n al) mrt) nextnext = do
return r
setTerm $ IJmp nextnext
return destref
+convertExpression (ELit (LStr s) _) nextnext = do
+ ref <- internString s
+ setTerm $ IJmp nextnext
+ return ref
convertExpression (EBin BOAnd e1 e2 _) nextnext = do
destref <- genTemp (sizeof TInt)
bl2 <- newBlockNoSwitch
diff --git a/CodeGen.hs b/CodeGen.hs
index 9a46af7..8eee371 100644
--- a/CodeGen.hs
+++ b/CodeGen.hs
@@ -5,6 +5,7 @@ module CodeGen(codegen) where
import Control.Monad
import Control.Monad.Except
import Control.Monad.State.Strict
+import Data.Char
import Data.List
import Data.Maybe
import Data.Map.Strict ((!))
@@ -73,6 +74,10 @@ codegen (IRProgram vars funcs) = do
codegenVar :: DVar -> Error String
codegenVar (DVar TInt n (ELit (LInt i) (Just TInt))) = Right $ n ++ ": dq " ++ show i
+codegenVar (DVar (TArr TChar _) n (ELit (LStr s) _)) = Right $
+ n ++ ":\n" ++
+ "\tdq " ++ show (length s + 1) ++ "\n" ++
+ "\tdb " ++ (intercalate ", " $ map show $ map ord s ++ [0])
codegenVar _ = Left "Unsupported global variable declaration"
@@ -196,6 +201,13 @@ codegenIns m (IMov d s)
| otherwise = addIns $ mkmov dm sm
where dm = mkxref d m
sm = mkxref s m
+codegenIns m (ILea d n)
+ | X64.isXMem dm = do
+ addIns $ LEA (xref $ XReg (fromIntegral $ refSize d) RAX) (xref sm)
+ addIns $ mkmov dm (XReg (fromIntegral $ refSize d) RAX)
+ | otherwise = addIns $ LEA (xref dm) (xref sm)
+ where dm = mkxref d m
+ sm = mkxref (Global 8 n) m
codegenIns m (IStore d s) = do
sourcexref <- if X64.isXMem sm
then do
@@ -394,6 +406,7 @@ collectTempRefs bbs =
where
listRefsIns :: IRIns -> [[LA.Access Ref]]
listRefsIns (IMov a b) = [[LA.Read b], [LA.Write a]]
+ listRefsIns (ILea a _) = [[LA.Write a]]
listRefsIns (IStore a b) = [[LA.Read a, LA.Read b]]
listRefsIns (ILoad a b) = [[LA.Read b], [LA.Write a]]
listRefsIns (IAri at a b c)
diff --git a/Intermediate.hs b/Intermediate.hs
index 6cbccda..d2ac549 100644
--- a/Intermediate.hs
+++ b/Intermediate.hs
@@ -23,6 +23,7 @@ data IRFunc = IRFunc (Maybe Type) Name [(Type, Name)] [BB] Id
data IRIns
= IMov Ref Ref
+ | ILea Ref Name
| IStore Ref Ref
| ILoad Ref Ref
| IAri ArithType Ref Ref Ref -- destination, operand 1, operand 2
@@ -99,6 +100,7 @@ instance Pretty IRFunc where
instance Pretty IRIns where
prettyI _ (IMov d s) = "mov " ++ pretty d ++ " <- " ++ pretty s
+ prettyI _ (ILea d s) = "lea " ++ pretty d ++ " <- &[" ++ s ++ "]"
prettyI _ (IStore d s) = "store *" ++ pretty d ++ " <- " ++ pretty s
prettyI _ (ILoad d s) = "load " ++ pretty d ++ " <- *" ++ pretty s
prettyI _ (IAri at d s1 s2) =
diff --git a/Main.hs b/Main.hs
index b8c50e6..fb557e8 100644
--- a/Main.hs
+++ b/Main.hs
@@ -8,6 +8,7 @@ import Debug.Trace
import BuildIR
import CodeGen
import Defs
+import InternStrings
import Optimiser
import Pretty
import ProgramParser
@@ -33,6 +34,7 @@ performCompile source = do
let eres = return source
>>= parseProgram <?> "Parse error"
>>= typeCheck <?> "Type error"
+ -- >>= internStrings <?> "Error interning strings"
>>= buildIR <?> "IR building error"
>>= optimise <?> "Error while optimising"
>>= return . traceShowId
diff --git a/Optimiser.hs b/Optimiser.hs
index 531bc7d..cea0601 100644
--- a/Optimiser.hs
+++ b/Optimiser.hs
@@ -203,6 +203,9 @@ movPush (IRFunc rt name al bbs sid) = IRFunc rt name al (map goBB bbs) sid
| d' == d = if d' == s' then push mov rest term else push (d', s') rest term
| d' == s = IMov d s : push (d', replaceRef d s s') rest term
| otherwise = IMov d' (replaceRef d s s') : push mov rest term
+ push mov@(d, _) (ILea d' n : rest) term
+ | d' == d = ILea d' n : go rest term
+ | otherwise = ILea d' n : push mov rest term
push mov@(d, s) (IResize d' s' : rest) term
| d' == d = IResize d' (replaceRef d s s') : go rest term
| d' == s = IMov d s : IResize d' (replaceRef d s s') : go rest term
@@ -306,6 +309,9 @@ arithPush (IRFunc rt name al allbbs sid) = IRFunc rt name al resbbs sid
propagate ari@(_, d, s1, s2) (Left ins@(IResize md _) : rest)
| d /= md && md /= s1 && md /= s2 = fmap (Left ins :) $ propagate ari rest
| otherwise = (False, Left ins : rest)
+ propagate ari@(_, d, s1, s2) (Left ins@(ILea md _) : rest)
+ | d /= md && md /= s1 && md /= s2 = fmap (Left ins :) $ propagate ari rest
+ | otherwise = (False, Left ins : rest)
propagate ari (Left INop : rest) = propagate ari rest
propagate (at, d, s1, s2) (Right term@(IJcc ct r1 r2 i1 i2) : rest)
| (r1 == d || r2 == d) &&
@@ -389,6 +395,7 @@ removeUnusedInstructions (IRFunc rt name al bbs sid) = IRFunc rt name al (map go
goI :: IRIns -> Maybe IRIns
goI ins@(IMov d _) = pureInstruction d ins
+ goI ins@(ILea d _) = pureInstruction d ins
goI ins@(IStore _ _) = Just ins
goI ins@(ILoad d _) = pureInstruction d ins
goI ins@(IAri _ d _ _) = pureInstruction d ins
@@ -560,6 +567,7 @@ findAllRefsInss inss = uniq $ sort $ concatMap findAllRefsIns inss
findAllRefsIns :: IRIns -> [Ref]
findAllRefsIns (IMov a b) = [a, b]
+findAllRefsIns (ILea a _) = [a]
findAllRefsIns (IStore a b) = [a, b]
findAllRefsIns (ILoad a b) = [a, b]
findAllRefsIns (IAri _ a b c) = [a, b, c]
diff --git a/ProgramParser.hs b/ProgramParser.hs
index 34b5ce7..a71d07e 100644
--- a/ProgramParser.hs
+++ b/ProgramParser.hs
@@ -204,30 +204,39 @@ pENew = do
return $ ENew t e
pLiteral :: Parser Literal
-pLiteral = (LInt <$> pInteger) <|> (LChar <$> pCharLit) <|> pLCall <|> (LVar <$> pName)
+pLiteral =
+ (LInt <$> pInteger) <|> (LChar <$> pCharLit) <|> (LStr <$> pString) <|>
+ pLCall <|> (LVar <$> pName)
pCharLit :: Parser Char
pCharLit = do
void $ char '\''
- c <- pStringChar
+ c <- pStringChar (const False)
void $ char '\''
pWhiteComment
return c
-pStringChar :: Parser Char
-pStringChar =
+pStringChar :: (Char -> Bool) -> Parser Char
+pStringChar avoid =
(char '\\' >> ((char 'n' >> return '\n') <|>
(char 'r' >> return '\r') <|>
(char 't' >> return '\t') <|>
(char '0' >> return '\0') <|>
(char 'x' >> pHexDigit >>= \a -> pHexDigit >>= \b -> return (chr $ 16 * a + b)))) <|>
- anyToken
+ satisfy (not . avoid)
where
pHexDigit :: Parser Int
pHexDigit = (subtract 48 . fromEnum <$> digit)
<|> ((+ (10 - 97)) . ord <$> oneOf "abcdef")
<|> ((+ (10 - 65)) . ord <$> oneOf "ABCDEF")
+pString :: Parser String
+pString = do
+ void $ char '"'
+ s <- many (pStringChar (== '"'))
+ void $ char '"'
+ return s
+
pLCall :: Parser Literal
pLCall = do
n <- try $ pName <* symbol "("
diff --git a/ReplaceRefs.hs b/ReplaceRefs.hs
index f9490ef..6e10c90 100644
--- a/ReplaceRefs.hs
+++ b/ReplaceRefs.hs
@@ -10,6 +10,7 @@ replaceRef = trans
replaceRefsIns :: Ref -> Ref -> IRIns -> IRIns
replaceRefsIns from to (IMov a b) = IMov (trans from to a) (trans from to b)
+replaceRefsIns from to (ILea a n) = ILea (trans from to a) n
replaceRefsIns from to (IStore a b) = IStore (trans from to a) (trans from to b)
replaceRefsIns from to (ILoad a b) = ILoad (trans from to a) (trans from to b)
replaceRefsIns from to (IAri at a b c) = IAri at (trans from to a) (trans from to b) (trans from to c)
diff --git a/TypeCheck.hs b/TypeCheck.hs
index 66affa4..922731d 100644
--- a/TypeCheck.hs
+++ b/TypeCheck.hs
@@ -191,15 +191,17 @@ annotateExpr db (ELit (LCall n as) _) = do
when (length as' /= length ats) $
Left $ "Function '" ++ n ++ "' expected " ++ show (length ats) ++
" arguments but got " ++ show (length as')
- forM_ (zip as' ats) $ \(arg, at) -> do
+ forM_ (zip3 as' ats [1 :: Int ..]) $ \(arg, at, num) -> do
when (isNothing (typeof arg)) $
Left "Use of void value in function argument"
if canCoerce (fromJust $ typeof arg) at
then return ()
- else Left $ "Argument of " ++ n ++ " has type " ++ pretty at ++
+ else Left $ "Argument " ++ show num ++ " of " ++ n ++ " has type " ++ pretty at ++
" but value of type " ++ pretty (fromJust $ typeof arg) ++
" was given"
return $ ELit (LCall n as') mrt
+annotateExpr _ (ELit lit@(LStr s) _) =
+ return $ ELit lit (Just $ TArr TChar (Just $ fromIntegral $ length s))
annotateExpr db (ESubscript arr sub _) = do
arr' <- annotateExpr db arr
sub' <- annotateExpr db sub
diff --git a/X64.hs b/X64.hs
index a577a75..b71012a 100644
--- a/X64.hs
+++ b/X64.hs
@@ -30,6 +30,7 @@ data CondCode = CCA | CCAE | CCB | CCBE | CCC | CCE | CCG | CCGE | CCL | CCLE |
data Ins
= MOV RegMem RegMemImm | MOVi Reg Imm
+ | LEA Reg Mem
| MOVSX Reg RegMem
| ADD RegMem RegMemImm
| SUB RegMem RegMemImm
@@ -84,6 +85,7 @@ verify (Asm funcs) = mapM_ (\(_, inss) -> mapM_ goI inss) funcs
goI :: Ins -> Either String ()
goI (MOV (RegMem a) (RegMemImm b)) = ckRegMem a >> ckRegMemImm b >> ck2mem a b >> ckSizes a b
goI (MOVi (Reg a) (Imm b)) = ckReg a >> ckImm b >> ckSizes64 a b
+ goI (LEA (Reg a) (Mem b)) = ckReg a >> ckMem b >> ckSizes a b
goI (MOVSX (Reg a) (RegMem b)) = ckReg a >> ckRegMem b >> ckMovsx a b
goI (ADD (RegMem a) (RegMemImm b)) = ckRegMem a >> ckRegMemImm b >> ck2mem a b >> ckSizes a b
goI (SUB (RegMem a) (RegMemImm b)) = ckRegMem a >> ckRegMemImm b >> ck2mem a b >> ckSizes a b
@@ -110,6 +112,9 @@ verify (Asm funcs) = mapM_ (\(_, inss) -> mapM_ goI inss) funcs
ckReg (XReg _ _) = return ()
ckReg _ = Left "Argument is not a Reg"
+ ckMem (XMem _ _ _ _ _) = return ()
+ ckMem _ = Left "Argument is not a Mem"
+
ckImm (XImm _) = return ()
ckImm _ = Left "Argument is not an Imm"
@@ -230,6 +235,7 @@ instance Stringifiable CondCode where
instance Stringifiable Ins where
stringify (MOV a b) = "mov " ++ stringify a ++ ", " ++ stringify b
stringify (MOVi a b) = "mov " ++ stringify a ++ ", " ++ stringify b
+ stringify (LEA a b) = "lea " ++ stringify a ++ ", " ++ stringify b
stringify (MOVSX a b@(RegMem bx)) = case compare (xrefGetSize bx) 4 of
EQ -> "movsxd " ++ stringify a ++ ", " ++ stringify b
LT -> "movsx " ++ stringify a ++ ", " ++ stringify b
@@ -287,6 +293,7 @@ isXImm _ = False
xrefMapM :: Monad m => (XRef -> m XRef) -> Ins -> m Ins
xrefMapM f (MOV (RegMem x) (RegMemImm y)) = MOV <$> (RegMem <$> f x) <*> (RegMemImm <$> f y)
xrefMapM f (MOVi (Reg x) (Imm y)) = MOVi <$> (Reg <$> f x) <*> (Imm <$> f y)
+xrefMapM f (LEA (Reg x) (Mem y)) = LEA <$> (Reg <$> f x) <*> (Mem <$> f y)
xrefMapM f (MOVSX (Reg x) (RegMem y)) = MOVSX <$> (Reg <$> f x) <*> (RegMem <$> f y)
xrefMapM f (ADD (RegMem x) (RegMemImm y)) = ADD <$> (RegMem <$> f x) <*> (RegMemImm <$> f y)
xrefMapM f (SUB (RegMem x) (RegMemImm y)) = SUB <$> (RegMem <$> f x) <*> (RegMemImm <$> f y)
diff --git a/bf.lang b/bf.lang
index 6f7426b..c42f73d 100644
--- a/bf.lang
+++ b/bf.lang
@@ -36,6 +36,7 @@ func int[] makejumpmap(char[] src, int srclen) {
i = i + 1;
}
if (stkp != 0) {
+ putstr("Unmatched opening brackets in BF source\n");
exit(1);
}
/*i = 0;
diff --git a/primes.bf b/primes.bf
new file mode 100644
index 0000000..f492705
--- /dev/null
+++ b/primes.bf
@@ -0,0 +1,194 @@
+compute prime numbers
+to use type the max number then push Alt 1 0
+===================================================================
+======================== OUTPUT STRING ============================
+===================================================================
+>++++++++[<++++++++>-]<++++++++++++++++.[-]
+>++++++++++[<++++++++++>-]<++++++++++++++.[-]
+>++++++++++[<++++++++++>-]<+++++.[-]
+>++++++++++[<++++++++++>-]<+++++++++.[-]
+>++++++++++[<++++++++++>-]<+.[-]
+>++++++++++[<++++++++++>-]<+++++++++++++++.[-]
+>+++++[<+++++>-]<+++++++.[-]
+>++++++++++[<++++++++++>-]<+++++++++++++++++.[-]
+>++++++++++[<++++++++++>-]<++++++++++++.[-]
+>+++++[<+++++>-]<+++++++.[-]
+>++++++++++[<++++++++++>-]<++++++++++++++++.[-]
+>++++++++++[<++++++++++>-]<+++++++++++.[-]
+>+++++++[<+++++++>-]<+++++++++.[-]
+>+++++[<+++++>-]<+++++++.[-]
+===================================================================
+======================== INPUT NUMBER ============================
+===================================================================
+[[[ COMMENT
+ + cont=1
+ [
+ - cont=0
+ >,
+ ======SUB10======
+ ----------
+
+ [ not 10
+ <+> cont=1
+ =====SUB38======
+ ----------
+ ----------
+ ----------
+ --------
+ >
+ =====MUL10=======
+ [>+>+<<-]>>[<<+>>-]< dup
+ >>>+++++++++
+ [
+ <<<
+ [>+>+<<-]>>[<<+>>-]< dup
+ [<<+>>-]
+ >>-
+ ]
+ <<<[-]<
+ ======RMOVE1======
+ <
+ [>+<-]
+ ]
+ <
+ ]
+ >>[<<+>>-]<<
+]]]
+++++++++++.[-] OUTPUT A NEWLINE
+- THE INPUT NUMBER (WE DONT HAVE STDIN YET)
+===================================================================
+======================= PROCESS NUMBER ===========================
+===================================================================
+==== ==== ==== ====
+numd numu teid teiu
+==== ==== ==== ====
+>+<-
+[
+ >+
+ ======DUP======
+ [>+>+<<-]>>[<<+>>-]<
+ >+<--
+ >>>>>>>>+<<<<<<<< isprime=1
+ [
+ >+
+ <-
+ =====DUP3=====
+ <[>>>+>+<<<<-]>>>>[<<<<+>>>>-]<<<
+ =====DUP2=====
+ >[>>+>+<<<-]>>>[<<<+>>>-]<<< <
+ >>>
+ ====DIVIDES=======
+ [>+>+<<-]>>[<<+>>-]< DUP i=div
+
+ <<
+ [
+ >>>>>+ bool=1
+ <<<
+ [>+>+<<-]>>[<<+>>-]< DUP
+ [>>[-]<<-] IF i THEN bool=0
+ >>
+ [ IF i=0
+ <<<<
+ [>+>+<<-]>>[<<+>>-]< i=div
+ >>>
+ - bool=0
+ ]
+ <<<
+ - DEC i
+ <<
+ -
+ ]
+
+ +>>[<<[-]>>-]<<
+ >[-]< CLR div
+ =====END DIVIDES====
+ [>>>>>>[-]<<<<<<-] if divides then isprime=0
+ <<
+ >>[-]>[-]<<<
+ ]
+ >>>>>>>>
+ [
+ -
+ <<<<<<<[-]<<
+ [>>+>+<<<-]>>>[<<<+>>>-]<<<
+ >>
+ ===================================================================
+ ======================== OUTPUT NUMBER ===========================
+ ===================================================================
+ [>+<-]>
+
+ [
+ ======DUP======
+ [>+>+<<-]>>[<<+>>-]<
+
+
+ ======MOD10====
+ >+++++++++<
+ [
+ >>>+<< bool= 1
+ [>+>[-]<<-] bool= ten==0
+ >[<+>-] ten = tmp
+ >[<<++++++++++>>-] if ten=0 ten=10
+ <<- dec ten
+ <- dec num
+ ]
+ +++++++++ num=9
+ >[<->-]< dec num by ten
+
+ =======RROT======
+ [>+<-]
+ < [>+<-]
+ < [>+<-]
+ >>>[<<<+>>>-]
+ <
+
+ =======DIV10========
+ >+++++++++<
+ [
+ >>>+<< bool= 1
+ [>+>[-]<<-] bool= ten==0
+ >[<+>-] ten = tmp
+ >[<<++++++++++>>>+<-] if ten=0 ten=10 inc div
+ <<- dec ten
+ <- dec num
+ ]
+ >>>>[<<<<+>>>>-]<<<< copy div to num
+ >[-]< clear ten
+
+ =======INC1=========
+ <+>
+ ]
+
+ <
+ [
+ =======MOVER=========
+ [>+<-]
+
+ =======ADD48========
+ +++++++[<+++++++>-]<->
+
+ =======PUTC=======
+ <.[-]>
+
+ ======MOVEL2========
+ >[<<+>>-]<
+
+ <-
+ ]
+
+ >++++[<++++++++>-]<.[-]
+
+ ===================================================================
+ =========================== END FOR ===============================
+ ===================================================================
+ >>>>>>>
+ ]
+ <<<<<<<<
+ >[-]<
+ [-]
+ <<-
+]
+
+======LF========
+
+++++++++++.[-]