Tenth

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========
+ 
+++++++++++.[-]