aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--AST.hs80
-rw-r--r--BuildIR.hs49
-rw-r--r--CodeGen.hs124
-rw-r--r--Defs.hs1
-rw-r--r--Intermediate.hs12
-rw-r--r--Main.hs3
-rw-r--r--Makefile2
-rw-r--r--Optimiser.hs51
-rw-r--r--ProgramParser.hs107
-rw-r--r--ReplaceRefs.hs40
-rw-r--r--TypeCheck.hs99
-rw-r--r--TypeRules.hs3
-rw-r--r--Utils.hs3
-rw-r--r--X64.hs6
-rw-r--r--X64Optimiser.hs18
-rw-r--r--bf.lang20
-rw-r--r--graph.pngbin166622 -> 0 bytes
-rw-r--r--liblang.asm3
-rw-r--r--struct.lang19
19 files changed, 472 insertions, 168 deletions
diff --git a/AST.hs b/AST.hs
index dae2631..ccad05d 100644
--- a/AST.hs
+++ b/AST.hs
@@ -1,12 +1,17 @@
module AST where
import Data.List
+import Data.Maybe
import Defs
import Pretty
+import Utils
-data Program = Program [DVar] [DFunc]
+data Program = Program [DTypedef] [DVar] [DFunc]
+ deriving (Show, Eq)
+
+data DTypedef = DTypedef Name Type
deriving (Show, Eq)
data DVar = DVar Type Name Expression
@@ -16,8 +21,9 @@ data DFunc = DFunc (Maybe Type) Name [(Type, Name)] Block
deriving (Show, Eq)
data Type
- = TInt | TChar | TArr Type (Maybe Size)
- deriving (Show, Eq)
+ = TInt | TChar | TArr Type (Maybe Size) | TStruct [(Type, Name)]
+ | TName Name
+ deriving (Show, Eq, Ord)
data Block = Block [Statement]
deriving (Show, Eq)
@@ -43,6 +49,7 @@ data Expression
| EUn UnaryOp Expression (Maybe Type)
| ELit Literal (Maybe Type)
| ESubscript Expression Expression (Maybe Type)
+ | EGet Expression Name (Maybe Type)
| ECast Type Expression
| ENew Type Expression
deriving (Show, Eq)
@@ -64,6 +71,7 @@ data Literal
| LVar Name
| LCall Name [Expression]
| LStr String
+ | LStruct [(Name, Expression)]
deriving (Show, Eq)
@@ -71,15 +79,50 @@ sizeof :: Type -> Size
sizeof TInt = 8
sizeof TChar = 1
sizeof (TArr _ _) = 8
+sizeof (TStruct []) = 0
+sizeof st@(TStruct ms) =
+ roundUp (sum (layoutStruct st) + sizeof (fst $ last ms)) (foldl1 lcm $ 8 : map (alignmentof . fst) ms)
+sizeof t@(TName _) = error $ "sizeof on " ++ show t
+
+alignmentof :: Type -> Offset
+alignmentof TInt = 8
+alignmentof TChar = 1
+alignmentof (TArr _ _) = 8
+alignmentof (TStruct []) = 1
+alignmentof (TStruct ((t,_):_)) = alignmentof t
+alignmentof (TName _) = undefined
+
+layoutStruct :: Type -> [Offset]
+layoutStruct (TStruct ms) = go ms 0
+ where
+ go :: [(Type, Name)] -> Offset -> [Offset]
+ go [] _ = []
+ go ((t,_) : rest) start =
+ let o = roundUp start (alignmentof t)
+ in o : go rest (o + sizeof t)
+layoutStruct _ = undefined
+
+offsetInStruct :: Type -> Name -> Offset
+offsetInStruct st@(TStruct ms) name = layoutStruct st !! (fromJust $ findIndex ((==name) . snd) ms)
+offsetInStruct _ _ = undefined
+
+structMemberType :: Type -> Name -> Type
+structMemberType (TStruct ms) name = fst $ fromJust $ find ((==name) . snd) ms
+structMemberType _ _ = undefined
instance Pretty Program where
- prettyI i (Program vars funcs) =
- intercalate ("\n" ++ indent i) (map (prettyI i) vars ++ map (prettyI i) funcs)
+ prettyI i (Program tds vars funcs) =
+ intercalate ("\n" ++ indent i)
+ (map (prettyI i) tds ++ map (prettyI i) vars ++ map (prettyI i) funcs)
++ "\n"
where
indent n = replicate (2*n) ' '
+instance Pretty DTypedef where
+ prettyI i (DTypedef n t) =
+ "type " ++ n ++ " := " ++ prettyI i t ++ ";"
+
instance Pretty DVar where
prettyI i (DVar t n e) =
prettyI i t ++ " " ++ n ++ " := " ++ prettyI i e ++ ";"
@@ -96,6 +139,10 @@ instance Pretty Type where
prettyI _ TChar = "char"
prettyI _ (TArr t Nothing) = pretty t ++ "[]"
prettyI _ (TArr t (Just sz)) = pretty t ++ "[" ++ show sz ++ "]"
+ prettyI _ (TStruct []) = "struct {}"
+ prettyI _ (TStruct ms) =
+ "struct {" ++ intercalate " " [pretty t ++ " " ++ n ++ ";" | (t,n) <- ms] ++ "}"
+ prettyI _ (TName n) = n
instance Pretty Block where
prettyI _ (Block []) = "{}"
@@ -111,8 +158,10 @@ instance Pretty Statement where
prettyI i t ++ " " ++ n ++ " := " ++ prettyI i e ++ ";"
prettyI i (SAs target e) =
prettyI i target ++ " = " ++ prettyI i e ++ ";"
+ prettyI i (SIf c b (Block [])) =
+ "if (" ++ prettyI i c ++ ") " ++ prettyI i b
prettyI i (SIf c b1 b2) =
- "if " ++ prettyI i c ++ " " ++ prettyI i b1 ++ " else " ++ prettyI i b2
+ "if (" ++ prettyI i c ++ ") " ++ prettyI i b1 ++ " else " ++ prettyI i b2
prettyI i (SWhile c b) =
"while " ++ prettyI i c ++ " " ++ prettyI i b
prettyI _ (SBreak 0) =
@@ -138,12 +187,20 @@ instance Pretty Expression where
prettyI i uo ++ "(" ++ prettyI i e ++ ")"
prettyI i (ELit l (Just t)) =
"(" ++ prettyI i (ELit l Nothing) ++ " :: " ++ prettyI i t ++ ")"
- prettyI i (ELit l Nothing) = prettyI i l
+ prettyI i (ELit l Nothing) =
+ prettyI i l
prettyI i (ESubscript a b (Just t)) =
"(" ++ prettyI i (ESubscript a b Nothing) ++ " :: " ++ prettyI i t ++ ")"
- prettyI i (ESubscript a b Nothing) = "(" ++ prettyI i a ++ ")[" ++ prettyI i b ++ "]"
- prettyI i (ECast t e) = prettyI i t ++ "(" ++ prettyI i e ++ ")"
- prettyI i (ENew t e) = "new " ++ prettyI i t ++ "[" ++ prettyI i e ++ "]"
+ prettyI i (ESubscript a b Nothing) =
+ "(" ++ prettyI i a ++ ")[" ++ prettyI i b ++ "]"
+ prettyI i (EGet e n Nothing) =
+ "(" ++ prettyI i e ++ ")." ++ n
+ prettyI i (EGet e n (Just t)) =
+ "(" ++ prettyI i (EGet e n Nothing) ++ " :: " ++ prettyI i t ++ ")"
+ prettyI i (ECast t e) =
+ prettyI i t ++ "(" ++ prettyI i e ++ ")"
+ prettyI i (ENew t e) =
+ "new " ++ prettyI i t ++ "[" ++ prettyI i e ++ "]"
instance Pretty AsExpression where
prettyI i (AEVar n (Just t)) =
@@ -172,7 +229,6 @@ instance Pretty BinaryOp where
prettyI _ BOBitOr = "|"
prettyI _ BOBitXor = "^"
-
instance Pretty UnaryOp where
prettyI _ UONot = "!"
prettyI _ UONeg = "-"
@@ -184,3 +240,5 @@ instance Pretty Literal where
prettyI i (LCall n al) =
n ++ "(" ++ intercalate ", " (map (prettyI i) al) ++ ")"
prettyI _ (LStr s) = show s
+ prettyI i (LStruct ms) =
+ "{" ++ intercalate ", " (map (\(n,e) -> n ++ " = " ++ prettyI i e) ms) ++ "}"
diff --git a/BuildIR.hs b/BuildIR.hs
index 9eb4d62..028c649 100644
--- a/BuildIR.hs
+++ b/BuildIR.hs
@@ -46,6 +46,9 @@ genId = state $ \s -> (nextId s, s {nextId = nextId s + 1})
genTemp :: Size -> BuildM Ref
genTemp sz = liftM (Temp sz) genId
+genStructTemp :: Size -> BuildM Ref
+genStructTemp sz = liftM (StructTemp sz) genId
+
newBlock :: BuildM Id
newBlock = do
i <- genId
@@ -128,7 +131,7 @@ internString str = do
buildIR :: Program -> Error IRProgram
-buildIR (Program vars funcs) =
+buildIR (Program [] vars funcs) =
runExcept $ evalStateT (unBuildM result) initBuildState
where
goDFunc :: DFunc -> BuildM IRFunc
@@ -163,6 +166,7 @@ buildIR (Program vars funcs) =
let t = TArr TChar (Just $ fromIntegral $ length str)
in DVar t n (ELit (LStr str) (Just t))
return $ IRProgram (vars ++ strvars) funcs'
+buildIR _ = undefined
convertBlock :: Block -> Id -> BuildM ()
convertBlock (Block sts) nextnext = do
@@ -269,6 +273,15 @@ convertExpression (ELit (LStr s) _) nextnext = do
ref <- internString s
setTerm $ IJmp nextnext
return ref
+convertExpression (ELit (LStruct ms) stype) nextnext = do
+ ref <- genStructTemp (sizeof $ fromJust stype)
+ forM_ ms $ \(n,e) -> do
+ bl <- newBlockNoSwitch
+ r <- convertExpression e bl
+ switchBlock bl
+ addIns $ ISet ref (offsetInStruct (fromJust stype) n) r
+ setTerm $ IJmp nextnext
+ return ref
convertExpression (EBin BOAnd e1 e2 _) nextnext = do
destref <- genTemp (sizeof TInt)
bl2 <- newBlockNoSwitch
@@ -356,19 +369,35 @@ convertExpression (ESubscript arr sub t) nextnext = do
addIns $ ILoad ref elemptr
setTerm $ IJmp nextnext
return ref
+convertExpression (EGet st n t) nextnext = do
+ let elemsz = sizeof $ fromJust t
+ bl2 <- newBlockNoSwitch
+ stref <- convertExpression st bl2
+ switchBlock bl2
+ let subtype = structMemberType (fromJust $ typeof st) n
+ eref <- case subtype of
+ TStruct _ -> genStructTemp elemsz
+ _ -> genTemp elemsz
+ addIns $ IGet eref stref (offsetInStruct (fromJust $ typeof st) n)
+ setTerm $ IJmp nextnext
+ return eref
convertExpression (ECast dt e) nextnext = do
let typ = case typeof e of
Nothing -> error $ "Cast subject " ++ show e ++ " has Nothing type"
Just t -> t
- when (not $ isIntegralType typ && isIntegralType dt) $
- error $ "convertExpression: unimplemented cast from " ++ pretty typ ++ " to " ++ pretty dt
- ref <- genTemp (sizeof dt)
- bl <- newBlockNoSwitch
- eref <- convertExpression e bl
- switchBlock bl
- addIns $ IResize ref eref
- setTerm $ IJmp nextnext
- return ref
+ if typ == dt
+ then convertExpression e nextnext
+ else do
+ when (not $ isIntegralType typ && isIntegralType dt) $
+ error $ "convertExpression: unimplemented cast from " ++ pretty typ ++
+ " to " ++ pretty dt
+ ref <- genTemp (sizeof dt)
+ bl <- newBlockNoSwitch
+ eref <- convertExpression e bl
+ switchBlock bl
+ addIns $ IResize ref eref
+ setTerm $ IJmp nextnext
+ return ref
convertExpression (ENew t sze) nextnext = do
when (not $ isBasicType t) $
throwError $ "Array element type in 'new' expression is not a basic type (" ++ pretty t ++ ")"
diff --git a/CodeGen.hs b/CodeGen.hs
index bf3e477..450f887 100644
--- a/CodeGen.hs
+++ b/CodeGen.hs
@@ -17,6 +17,7 @@ import Defs
import Intermediate
import qualified LifetimeAnalysis as LA
import RegAlloc
+import ReplaceRefs
import Utils
import X64 (Register(..), CondCode(..), XRef(..), Ins(..), xref)
import qualified X64 as X64
@@ -95,12 +96,16 @@ codegenFunc (IRFunc _ name al bbs sid) = do
aliascandidates = findAliasCandidates bbs :: [(Ref, Ref)]
gpRegs = [R8, R9, R10, R11, R12, R13, R14, R15]
+ -- gpRegs = [R8]
allocation = regalloc lifespans gpRegs aliascandidates :: Map.Map Ref (Allocation Register)
spillrefs = map fst $ filter (isAllocMem . snd) $ Map.toList allocation
(spilloffsets, spillsz) = initLast $ scanl (+) 0 $ map refSize spillrefs
spilloffsetmap = Map.fromList $ zip spillrefs spilloffsets
+ structrefs = filter isStructTemp $ findAllRefsBBList bbs
+ structspace = sum $ map refSize structrefs
+
usedregs = uniq $ sort $ catMaybes $ flip map (Map.toList allocation) $ \(_, a) -> case a of
AllocReg reg -> Just reg
AllocMem -> Nothing
@@ -110,31 +115,52 @@ codegenFunc (IRFunc _ name al bbs sid) = do
traceM $ "ALLOCATION: " ++ show allocation
let nsaves = length usedregs
- alignoff = if odd nsaves then 8 else 0
+ framesize' = 8 {- ret addr -} + 8 {- rbp -} + 8 * nsaves +
+ fromIntegral structspace + fromIntegral spillsz
+ alignoff = roundUp framesize' 16 - framesize'
+ framesize = framesize' + alignoff
allocationXref = flip Map.mapWithKey allocation $ \ref alloc -> case alloc of
AllocReg reg -> XReg (fromIntegral $ refSize ref) reg
AllocMem -> XMem (fromIntegral $ refSize ref)
(Just RSP) (0, RAX) Nothing
(fromIntegral $ spilloffsetmap ! ref)
- allocmap = foldl inserter allocationXref (zip al [0::Int ..])
+ allocmap' = fst $ foldl arginserter (allocationXref, 0) al
+ where
+ arginserter (m, off) (t, n) =
+ (Map.insert (Argument (sizeof t) n)
+ (XMem (fromIntegral $ sizeof t)
+ (Just RSP) (0, RAX) Nothing
+ (fromIntegral framesize + off))
+ m,
+ off + fromIntegral (sizeof t))
+
+ allocmap = fst $ foldl structinserter (allocmap', spillsz) structrefs
where
- inserter m ((t, n), i) =
- let offset = fromIntegral spillsz + alignoff + 8 * nsaves +
- 8 {- rbp -} + 8 {- ret addr -} + 8 * i
- in Map.insert (Argument (sizeof t) n)
- (XMem (fromIntegral $ sizeof t)
- (Just RSP) (0, RAX) Nothing
- (fromIntegral offset))
- m
+ structinserter (m, off) temp@(StructTemp sz _) =
+ (Map.insert temp
+ (XMem (fromIntegral sz)
+ (Just RSP) (0, RAX) Nothing
+ (fromIntegral off))
+ m,
+ off + sz)
+ structinserter _ _ = undefined
+
+ traceM $ "nsaves = " ++ show nsaves
+ traceM $ "structspace = " ++ show structspace
+ traceM $ "spillsz = " ++ show spillsz
+ traceM $ "framesize' = " ++ show framesize'
+ traceM $ "alignoff = " ++ show alignoff
+ traceM $ "framesize = " ++ show framesize
newLabel name
addIns $ PUSH (xref $ XReg 8 RBP)
addIns $ MOV (xref $ XReg 8 RBP) (xref $ XReg 8 RSP)
forM_ usedregs $ \reg -> addIns $ PUSH (xref $ XReg 8 reg)
- when (odd $ length usedregs) $ addIns $ SUB (xref $ XReg 8 RSP) (xref $ XImm 8)
- when (spillsz /= 0) $ addIns $ SUB (xref $ XReg 8 RSP) (xref $ XImm $ fromIntegral spillsz)
+ let stackspill = spillsz + structspace + fromIntegral alignoff
+ when (stackspill /= 0) $
+ addIns $ SUB (xref $ XReg 8 RSP) (xref $ XImm $ fromIntegral stackspill)
setRegsToRestore usedregs
- setSpillSize spillsz
+ setSpillSize stackspill
let ([startbb], rest) = partition (\(BB i _ _) -> i == sid) bbs
codegenBB allocmap startbb
@@ -192,6 +218,20 @@ mkmov a@(XMem _ _ _ _ _) b@(XImm v) | v < 2 ^ (32 :: Int) = MOV (xref a) (xref b
mkmov a b = CALL $ "Invalid mkmov: " ++ show a ++ "; " ++ show b
-- mkmov a b = error $ "Invalid mkmov: " ++ show a ++ "; " ++ show b
+emitmemcpy :: XRef -> XRef -> CGMonad ()
+emitmemcpy dst@(XMem sz _ _ _ _) src@(XMem sz2 _ _ _ _)
+ | sz /= sz2 = error $ "Inconsistent sizes in emitmemcpy: " ++ show dst ++ "; " ++ show src
+ | sz `elem` [1, 2, 4, 8] = do
+ addIns $ mkmov (XReg sz RAX) src
+ addIns $ mkmov dst (XReg sz RAX)
+ | sz > 8 = do
+ addIns $ mkmov (XReg 8 RAX) (X64.xrefSetSize 8 src)
+ addIns $ mkmov (X64.xrefSetSize 8 dst) (XReg 8 RAX)
+ emitmemcpy (X64.offsetXMem 8 $ X64.xrefSetSize (sz - 8) dst)
+ (X64.offsetXMem 8 $ X64.xrefSetSize (sz - 8) src)
+ | otherwise = error $ "Invalid size in emitmemcpy: " ++ show dst ++ "; " ++ show src
+emitmemcpy _ _ = undefined
+
mkcmp :: XRef -> XRef -> X64.Ins
mkcmp a b@(XImm _) = CMPi (xref a) (xref b)
mkcmp a b = CMP (xref a) (xref b)
@@ -244,6 +284,24 @@ codegenIns m (ILoad d s) = do
where dm = mkxref d m
sm = mkxref s m
sz = fromIntegral $ refSize d
+codegenIns m (ISet d off s)
+ | X64.isXMem sm = do
+ addIns $ mkmov (XReg sz RAX) sm
+ addIns $ mkmov dm (XReg sz RAX)
+ | otherwise = do
+ addIns $ mkmov dm sm
+ where dm = X64.xrefSetSize sz $ X64.offsetXMem (fromIntegral off) $ mkxref d m
+ sm = mkxref s m
+ sz = fromIntegral $ refSize s
+codegenIns m (IGet d s off)
+ | X64.isXMem dm = do
+ addIns $ mkmov (XReg sz RAX) sm
+ addIns $ mkmov dm (XReg sz RAX)
+ | otherwise = do
+ addIns $ mkmov dm sm
+ where dm = mkxref d m
+ sm = X64.xrefSetSize sz $ X64.offsetXMem (fromIntegral off) $ mkxref s m
+ sz = fromIntegral $ refSize d
codegenIns m (IAri AMul d s1 s2) = do
let sz = fromIntegral $ refSize d
addIns $ mkmov (XReg sz RAX) (mkxref s1 m)
@@ -275,7 +333,7 @@ codegenIns m (IAri at d s1 s2) = case arithTypeToCondCode at of
addIns $ SETCC cc (xref $ X64.xrefSetSize 1 dm)
addIns $ AND (xref $ X64.xrefSetSize 4 dm) (xref $ XImm 0xff)
Nothing -> do
- (_, s1m', s2', s2m') <-
+ (s1', s1m', s2', s2m') <-
if dm == s2m
then if dm == s1m
then return (s1, s1m, s2, s2m)
@@ -289,27 +347,35 @@ codegenIns m (IAri at d s1 s2) = case arithTypeToCondCode at of
addIns $ mkmov (XReg (fromIntegral $ refSize s2') RAX) s2m'
return $ XReg (fromIntegral $ refSize s2') RAX
else return s2m'
- when (dm /= s1m') $ addIns $ mkmov dm s1m'
+ when (dm /= s1m') $ if X64.isXMem dm && X64.isXMem s1m'
+ then do
+ addIns $ mkmov (XReg (fromIntegral $ refSize s1') RBX) s1m'
+ addIns $ mkmov dm (XReg (fromIntegral $ refSize s1') RBX)
+ else do
+ addIns $ mkmov dm s1m'
addIns $ fromJust (arithTypeToIns at) dm arg2
where dm = mkxref d m
s1m = mkxref s1 m
s2m = mkxref s2 m
codegenIns m (ICall n rs) = do
- when (odd $ length rs) $ addIns $ SUB (xref $ XReg 8 RSP) (xref $ XImm 8)
- forM_ (zip (reverse rs) [1::Int ..]) $ \(r, i) ->
+ let sizes = map (flip roundUp 8 . refSize) rs
+ offsets = init $ scanl (+) 0 $ reverse sizes
+ totalsize = sum sizes
+ alignment = roundUp totalsize 16 - totalsize
+ forM_ (zip rs offsets) $ \(r, off) ->
let sz = fromIntegral $ refSize r
- src = (mkxref r m)
- dst = (XMem sz (Just RSP) (0, RAX) Nothing (fromIntegral $ (-8) * i))
- in if X64.isXMem (mkxref r m)
+ src = mkxref r m
+ dst = XMem sz (Just RSP) (0, RAX) Nothing (fromIntegral $ off - alignment - totalsize)
+ in if X64.isXMem src
then do
- addIns $ mkmov (XReg sz RAX) src
- addIns $ mkmov dst (XReg sz RAX)
- else do
- addIns $ mkmov dst src
- when (length rs > 0) $ addIns $ SUB (xref $ XReg 8 RSP) (xref $ XImm (fromIntegral $ 8 * length rs))
+ traceM $ "call stuff with dst = " ++ show dst ++ ", src = " ++ show src
+ emitmemcpy dst src
+ else addIns $ mkmov dst src
+ when (alignment /= 0) $ addIns $ SUB (xref $ XReg 8 RSP) (xref $ XImm $ fromIntegral alignment)
+ when (length rs > 0) $ addIns $ SUB (xref $ XReg 8 RSP) (xref $ XImm $ fromIntegral totalsize)
addIns $ CALL n
- when (length rs > 0) $ addIns $ ADD (xref $ XReg 8 RSP) (xref $ XImm (fromIntegral $ 8 * length rs))
- when (odd $ length rs) $ addIns $ ADD (xref $ XReg 8 RSP) (xref $ XImm 8)
+ when (length rs > 0) $ addIns $ ADD (xref $ XReg 8 RSP) (xref $ XImm $ fromIntegral totalsize)
+ when (alignment /= 0) $ addIns $ ADD (xref $ XReg 8 RSP) (xref $ XImm $ fromIntegral alignment)
codegenIns m (ICallr d n rs) = do
codegenIns m (ICall n rs)
addIns $ mkmov (mkxref d m) (XReg (fromIntegral $ refSize d) RAX)
@@ -386,7 +452,6 @@ codegenTerm _ IRet = do
spillsz <- gets spillSize
when (spillsz /= 0) $ addIns $ ADD (xref $ XReg 8 RSP) (xref $ XImm $ fromIntegral spillsz)
usedregs <- gets regsToRestore
- when (odd $ length usedregs) $ addIns $ ADD (xref $ XReg 8 RSP) (xref $ XImm 8)
forM_ (reverse usedregs) $ \reg -> addIns $ POP (xref $ XReg 8 reg)
addIns $ mkmov (XReg 8 RSP) (XReg 8 RBP)
addIns $ POP (xref $ XReg 8 RBP)
@@ -396,7 +461,6 @@ codegenTerm m (IRetr r) = do
spillsz <- gets spillSize
when (spillsz /= 0) $ addIns $ ADD (xref $ XReg 8 RSP) (xref $ XImm $ fromIntegral spillsz)
usedregs <- gets regsToRestore
- when (odd $ length usedregs) $ addIns $ ADD (xref $ XReg 8 RSP) (xref $ XImm 8)
forM_ (reverse usedregs) $ \reg -> addIns $ POP (xref $ XReg 8 reg)
addIns $ mkmov (XReg 8 RSP) (XReg 8 RBP)
addIns $ POP (xref $ XReg 8 RBP)
@@ -417,6 +481,8 @@ collectTempRefs bbs =
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 (ISet a _ b) = [[LA.Read b, LA.Write a]]
+ listRefsIns (IGet a b _) = [[LA.Read b, LA.Write a]]
listRefsIns (IAri at a b c)
-- if not commutative, we don't want to have to xchg the operands
| isCommutative at = [[LA.Read b, LA.Read c], [LA.Write a]]
diff --git a/Defs.hs b/Defs.hs
index 4203a82..057fc22 100644
--- a/Defs.hs
+++ b/Defs.hs
@@ -6,5 +6,6 @@ import Data.Int
type Name = String
type Id = Int
type Size = Integer
+type Offset = Integer
type Value = Int64
type Error = Either String
diff --git a/Intermediate.hs b/Intermediate.hs
index d2ac549..dde941d 100644
--- a/Intermediate.hs
+++ b/Intermediate.hs
@@ -12,7 +12,7 @@ import Pretty
data BB = BB Id [IRIns] IRTerm
deriving (Show, Eq)
-data Ref = Temp Size Int | Argument Size Name | Global Size Name | Constant Size Value
+data Ref = Temp Size Int | StructTemp Size Int | Argument Size Name | Global Size Name | Constant Size Value
deriving (Show, Eq, Ord)
data IRProgram = IRProgram [DVar] [IRFunc]
@@ -26,6 +26,8 @@ data IRIns
| ILea Ref Name
| IStore Ref Ref
| ILoad Ref Ref
+ | ISet Ref Offset Ref
+ | IGet Ref Ref Offset
| IAri ArithType Ref Ref Ref -- destination, operand 1, operand 2
| ICall Name [Ref]
| ICallr Ref Name [Ref]
@@ -66,6 +68,7 @@ instance Pretty BB where
instance Pretty Ref where
prettyI _ (Temp sz k) = "t" ++ show k ++ pretty_sizeSuffix sz
+ prettyI _ (StructTemp sz k) = "s" ++ show k ++ "{" ++ show sz ++ "}"
prettyI _ (Argument sz n) = "a" ++ n ++ pretty_sizeSuffix sz
prettyI _ (Global sz n) = "g" ++ n ++ pretty_sizeSuffix sz
prettyI _ (Constant sz n) = show n ++ pretty_sizeSuffix sz
@@ -103,6 +106,8 @@ instance Pretty IRIns where
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 _ (ISet d off s) = "set " ++ pretty d ++ ".[" ++ show off ++ "] <- " ++ pretty s
+ prettyI _ (IGet d s off) = "get " ++ pretty d ++ " <- " ++ pretty s ++ ".[" ++ show off ++ "]"
prettyI _ (IAri at d s1 s2) =
pretty at ++ " " ++ pretty d ++ " <- " ++ pretty s1 ++ ", " ++ pretty s2
prettyI _ (ICall n al) =
@@ -156,10 +161,15 @@ blockIdOf (BB bid _ _) = bid
refSize :: Ref -> Size
refSize (Temp sz _) = sz
+refSize (StructTemp sz _) = sz
refSize (Argument sz _) = sz
refSize (Global sz _) = sz
refSize (Constant sz _) = sz
+isStructTemp :: Ref -> Bool
+isStructTemp (StructTemp _ _) = True
+isStructTemp _ = False
+
isConstant :: Ref -> Bool
isConstant (Constant _ _) = True
isConstant _ = False
diff --git a/Main.hs b/Main.hs
index b8c50e6..a31c79d 100644
--- a/Main.hs
+++ b/Main.hs
@@ -32,10 +32,11 @@ performCompile :: String -> IO ()
performCompile source = do
let eres = return source
>>= parseProgram <?> "Parse error"
+ >>= return . tracePrettyId
>>= typeCheck <?> "Type error"
>>= buildIR <?> "IR building error"
>>= optimise <?> "Error while optimising"
- >>= return . traceShowId
+ -- >>= return . traceShowId
>>= verify <?> "Verify error"
>>= return . tracePrettyId
>>= codegen <?> "Codegen error"
diff --git a/Makefile b/Makefile
index 0d7bf09..5602120 100644
--- a/Makefile
+++ b/Makefile
@@ -1,5 +1,5 @@
RUNFLAGS =
-GHCFLAGS = -Wall -Widentities -Wno-unused-imports -odir obj -hidir obj -j2
+GHCFLAGS = -Wall -Widentities -Wno-unused-imports -odir obj -hidir obj -j4
ifneq ($(PROFILE),)
RUNFLAGS += +RTS -xc
GHCFLAGS += -prof -fprof-auto
diff --git a/Optimiser.hs b/Optimiser.hs
index cea0601..408bd24 100644
--- a/Optimiser.hs
+++ b/Optimiser.hs
@@ -149,7 +149,7 @@ identityOps (IRFunc rt name al bbs sid) = IRFunc rt name al (map go bbs) sid
constantPropagate :: FuncOptimisation
constantPropagate (IRFunc rt name al bbs sid) = IRFunc rt name al bbs' sid
where
- alltemps = findAllTemps' bbs
+ alltemps = findAllTempsBBList bbs
consttemps = catMaybes $ flip map alltemps $ \ref ->
let locs = findMutations' bbs ref
loc = head locs
@@ -214,6 +214,14 @@ movPush (IRFunc rt name al bbs sid) = IRFunc rt name al (map goBB bbs) sid
| d' == d = ILoad d' (replaceRef d s s') : go rest term
| d' == s = IMov d s : ILoad d' (replaceRef d s s') : go rest term
| otherwise = ILoad d' (replaceRef d s s') : push mov rest term
+ push mov@(d, s) (ISet d' n' s' : rest) term
+ | d' == d = ISet d' n' (replaceRef d s s') : go rest term
+ | d' == s = IMov d s : ISet d' n' s' : go rest term
+ | otherwise = ISet d' n' (replaceRef d s s') : push mov rest term
+ push mov@(d, s) (IGet d' s' n' : rest) term
+ | d' == d = IGet d' (replaceRef d s s') n' : go rest term
+ | d' == s = IMov d s : IGet d' s' n' : go rest term
+ | otherwise = IGet d' (replaceRef d s s') n' : push mov rest term
push mov@(d, s) (IAri at d' s1' s2' : rest) term
| d' == d = IAri at d' (replaceRef d s s1') (replaceRef d s s2') : go rest term
| d' == s = IMov d s : IAri at d' (replaceRef d s s1') (replaceRef d s s2') : go rest term
@@ -294,6 +302,12 @@ arithPush (IRFunc rt name al allbbs sid) = IRFunc rt name al resbbs sid
propagate ari@(_, d, s1, s2) (Left ins@(ILoad 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@(ISet 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@(IGet md _ _) : rest)
+ | d /= md && md /= s1 && md /= s2 = fmap (Left ins :) $ propagate ari rest
+ | otherwise = (False, Left ins : rest)
propagate ari@(at, d, s1, s2) (Left ins@(IAri mat md ms1 ms2) : rest)
| d /= md && (at, s1, s2) == (mat, ms1, ms2) = fmap (Left (IMov md d) :) $ propagate ari rest
| d /= md && md /= s1 && md /= s2 = fmap (Left ins :) $ propagate ari rest
@@ -398,6 +412,8 @@ removeUnusedInstructions (IRFunc rt name al bbs sid) = IRFunc rt name al (map go
goI ins@(ILea d _) = pureInstruction d ins
goI ins@(IStore _ _) = Just ins
goI ins@(ILoad d _) = pureInstruction d ins
+ goI ins@(ISet _ _ _) = Just ins
+ goI ins@(IGet d _ _) = pureInstruction d ins
goI ins@(IAri _ d _ _) = pureInstruction d ins
goI ins@(ICall _ _) = Just ins
goI ins@(ICallr _ _ _) = Just ins
@@ -559,39 +575,10 @@ findMentions' bbs ref =
-- findMentionsIns' :: [BB] -> Ref -> [IRIns]
-- findMentionsIns' bbs ref = concatMap (flip findMentionsIns ref) bbs
-findAllRefs :: BB -> [Ref]
-findAllRefs (BB _ inss _) = findAllRefsInss inss
-
-findAllRefsInss :: [IRIns] -> [Ref]
-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]
-findAllRefsIns (ICall _ al) = al
-findAllRefsIns (ICallr a _ al) = a : al
-findAllRefsIns (IResize a b) = [a, b]
-findAllRefsIns IDebugger = []
-findAllRefsIns INop = []
-
-findAllRefsTerm :: IRTerm -> [Ref]
-findAllRefsTerm (IJcc _ a b _ _) = [a, b]
-findAllRefsTerm (IJmp _) = []
-findAllRefsTerm IRet = []
-findAllRefsTerm (IRetr a) = [a]
-findAllRefsTerm IUnreachable = []
-findAllRefsTerm ITermNone = undefined
-
--- findAllRefs' :: [BB] -> [Ref]
--- findAllRefs' = uniq . sort . concatMap findAllRefs
-
findAllTemps :: BB -> [Ref]
findAllTemps bb = flip filter (findAllRefs bb) $ \ref -> case ref of
(Temp _ _) -> True
_ -> False
-findAllTemps' :: [BB] -> [Ref]
-findAllTemps' = concatMap findAllTemps
+findAllTempsBBList :: [BB] -> [Ref]
+findAllTempsBBList = concatMap findAllTemps
diff --git a/ProgramParser.hs b/ProgramParser.hs
index a71d07e..411e063 100644
--- a/ProgramParser.hs
+++ b/ProgramParser.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE TupleSections #-}
+
module ProgramParser(parseProgram) where
import Control.Monad
@@ -19,20 +21,32 @@ parseProgram s = case parse pProgram "" s of
Right p -> Right p
pProgram :: Parser Program
-pProgram = do
- pWhiteComment
- decls <- many pDecl
- eof
- return $ Program (lefts decls) (rights decls)
-
-pDecl :: Parser (Either DVar DFunc)
-pDecl = (Right <$> pDFunc) <|> (Left <$> pDVar)
+pProgram = between pWhiteComment eof go
+ where
+ go :: Parser Program
+ go = (pDTypedef >>= \d -> addTypedef d <$> go) <|>
+ (pDFunc >>= \d -> addFunc d <$> go) <|>
+ (pDVar >>= \d -> addVar d <$> go) <|>
+ return (Program [] [] [])
+
+ addTypedef d (Program a b c) = Program (d:a) b c
+ addVar d (Program a b c) = Program a (d:b) c
+ addFunc d (Program a b c) = Program a b (d:c)
+
+pDTypedef :: Parser DTypedef
+pDTypedef = do
+ symbol "type"
+ n <- pName
+ symbol ":="
+ t <- pType
+ symbol ";"
+ return $ DTypedef n t
pDFunc :: Parser DFunc
pDFunc = do
symbol "func"
- rt <- (Just <$> pType) <|> return Nothing
- n <- pName
+ (rt,n) <- (try $ pType >>= \t -> (Just t,) <$> pName) <|>
+ ((Nothing,) <$> pName)
symbol "("
args <- sepBy pTypeAndName (symbol ",")
symbol ")"
@@ -41,8 +55,7 @@ pDFunc = do
pDVar :: Parser DVar
pDVar = do
- t <- pType
- n <- pName
+ (t,n) <- try pTypeAndName
symbol ":="
e <- pExpression
symbol ";"
@@ -52,16 +65,27 @@ pTypeAndName :: Parser (Type, Name)
pTypeAndName = (,) <$> pType <*> pName
pType :: Parser Type
-pType = do
- t <- pBasicType
- (do
- symbol "["
- msz <- optionMaybe pInteger
- symbol "]"
- return $ TArr t msz) <|> return t
+pType = (flip label "type") $
+ pStruct <|> do
+ t <- pBasicType
+ (do
+ symbol "["
+ msz <- optionMaybe pInteger
+ symbol "]"
+ return $ TArr t msz) <|> return t
+
+pStruct :: Parser Type
+pStruct = do
+ symbol "struct"
+ symbol "{"
+ ms <- many $ pTypeAndName <* symbol ";"
+ symbol "}"
+ return $ TStruct ms
pBasicType :: Parser Type
-pBasicType = (symbol "int" >> return TInt) <|> (symbol "char" >> return TChar)
+pBasicType = (symbol "int" >> return TInt) <|>
+ (symbol "char" >> return TChar) <|>
+ (TName <$> pName)
pBlock :: Parser Block
pBlock = do
@@ -134,7 +158,7 @@ pSExpr = do
return $ SExpr e
pExpression :: Parser Expression
-pExpression = E.buildExpressionParser optable litparser
+pExpression = E.buildExpressionParser optable litparser <?> "expression"
where
optable =
[[E.Infix (symbol "**" >> return (mkEBin BOPow)) E.AssocRight],
@@ -163,11 +187,14 @@ pExpression = E.buildExpressionParser optable litparser
litparser :: Parser Expression
litparser = do
- pops <- many pPrefixOp
- e <- pParenExpr <|> pENew <|> pCastExpr <|> (mkELit <$> pLiteral)
- subs <- many $ between (symbol "[") (symbol "]") pExpression
- let e' = foldl (\ex sub -> ESubscript ex sub Nothing) e subs
- e'' = foldl (\ex pop -> EUn pop ex Nothing) e' pops
+ preops <- many pPrefixOp
+ e <- pParenExpr <|> pENew <|> (mkELit <$> pLiteral)
+ postops <- many pPostfixOp
+ let e' = foldl (\ex op -> case op of
+ Left sub -> ESubscript ex sub Nothing
+ Right n -> EGet ex n Nothing)
+ e postops
+ e'' = foldl (\ex pop -> EUn pop ex Nothing) e' preops
return e''
pAsExpression :: Parser AsExpression
@@ -180,6 +207,12 @@ pPrefixOp :: Parser UnaryOp
pPrefixOp = (symbol "!" >> return UONot) <|>
(symbol "-" >> return UONeg)
+-- Left: subscript; Right: dot-index
+pPostfixOp :: Parser (Either Expression Name)
+pPostfixOp =
+ (Left <$> between (symbol "[") (symbol "]") pExpression) <|>
+ (Right <$> (symbol "." >> pName))
+
pParenExpr :: Parser Expression
pParenExpr = do
symbol "("
@@ -187,13 +220,6 @@ pParenExpr = do
symbol ")"
return e
-pCastExpr :: Parser Expression
-pCastExpr = do
- t <- try $ pType <* symbol "("
- e <- pExpression
- symbol ")"
- return $ ECast t e
-
pENew :: Parser Expression
pENew = do
symbol "new"
@@ -206,7 +232,7 @@ pENew = do
pLiteral :: Parser Literal
pLiteral =
(LInt <$> pInteger) <|> (LChar <$> pCharLit) <|> (LStr <$> pString) <|>
- pLCall <|> (LVar <$> pName)
+ pLStruct <|> pLCall <|> (LVar <$> pName)
pCharLit :: Parser Char
pCharLit = do
@@ -237,6 +263,13 @@ pString = do
void $ char '"'
return s
+pLStruct :: Parser Literal
+pLStruct = do
+ symbol "{"
+ ms <- sepBy (pName >>= \n -> symbol "=" >> pExpression >>= \e -> return (n,e)) (symbol ",")
+ symbol "}"
+ return $ LStruct ms
+
pLCall :: Parser Literal
pLCall = do
n <- try $ pName <* symbol "("
@@ -310,9 +343,3 @@ pBlockComment = do
void $ sepEndBy (manyTill anyToken (lookAhead $ try (string "/*") <|> try (string "*/")))
pBlockComment
void $ string "*/"
-
-lefts :: [Either a b] -> [a]
-lefts = foldr (\e l -> either (:l) (const l) e) []
-
-rights :: [Either a b] -> [b]
-rights = foldr (\e l -> either (const l) (:l) e) []
diff --git a/ReplaceRefs.hs b/ReplaceRefs.hs
index 6e10c90..5886937 100644
--- a/ReplaceRefs.hs
+++ b/ReplaceRefs.hs
@@ -1,8 +1,12 @@
module ReplaceRefs
- (replaceRef, replaceRefsIns, replaceRefsTerm, replaceRefsBB, replaceRefsBBList)
+ (replaceRef, replaceRefsIns, replaceRefsTerm, replaceRefsBB, replaceRefsBBList,
+ findAllRefs, findAllRefsInss, findAllRefsIns, findAllRefsTerm, findAllRefsBBList)
where
+import Data.List
+
import Intermediate
+import Utils
replaceRef :: Ref -> Ref -> Ref -> Ref
@@ -13,6 +17,8 @@ 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 (ISet a n b) = ISet (trans from to a) n (trans from to b)
+replaceRefsIns from to (IGet a b n) = IGet (trans from to a) (trans from to b) n
replaceRefsIns from to (IAri at a b c) = IAri at (trans from to a) (trans from to b) (trans from to c)
replaceRefsIns from to (ICall n al) = ICall n (map (trans from to) al)
replaceRefsIns from to (ICallr a n al) = ICallr (trans from to a) n (map (trans from to) al)
@@ -40,3 +46,35 @@ trans :: Ref -> Ref -> Ref -> Ref
trans from to ref
| ref == from = to
| otherwise = ref
+
+
+findAllRefs :: BB -> [Ref]
+findAllRefs (BB _ inss _) = findAllRefsInss inss
+
+findAllRefsInss :: [IRIns] -> [Ref]
+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 (ISet a _ b) = [a, b]
+findAllRefsIns (IGet a b _) = [a, b]
+findAllRefsIns (IAri _ a b c) = [a, b, c]
+findAllRefsIns (ICall _ al) = al
+findAllRefsIns (ICallr a _ al) = a : al
+findAllRefsIns (IResize a b) = [a, b]
+findAllRefsIns IDebugger = []
+findAllRefsIns INop = []
+
+findAllRefsTerm :: IRTerm -> [Ref]
+findAllRefsTerm (IJcc _ a b _ _) = [a, b]
+findAllRefsTerm (IJmp _) = []
+findAllRefsTerm IRet = []
+findAllRefsTerm (IRetr a) = [a]
+findAllRefsTerm IUnreachable = []
+findAllRefsTerm ITermNone = undefined
+
+findAllRefsBBList :: [BB] -> [Ref]
+findAllRefsBBList = uniq . sort . concatMap findAllRefs
diff --git a/TypeCheck.hs b/TypeCheck.hs
index 922731d..2b05df1 100644
--- a/TypeCheck.hs
+++ b/TypeCheck.hs
@@ -1,6 +1,9 @@
+{-# LANGUAGE TupleSections #-}
+
module TypeCheck(typeCheck) where
import Control.Monad
+import Data.List
import Data.Maybe
import qualified Data.Map.Strict as Map
@@ -10,7 +13,7 @@ import Pretty
import TypeRules
-data DBItem = DBVar Type | DBFunc (Maybe Type) [Type]
+data DBItem = DBVar Type | DBFunc (Maybe Type) [Type] | DBType Type
type TypeDB = [Map.Map Name DBItem]
@@ -34,56 +37,79 @@ emptyDB = [Map.fromList
("putint", DBFunc Nothing [TInt]),
("getc", DBFunc (Just TInt) []),
("exit", DBFunc Nothing [TInt]),
- ("_builtin_malloc", DBFunc (Just $ TArr TChar Nothing) [TInt])]]
+ ("_builtin_malloc", DBFunc (Just $ TArr TChar Nothing) [TInt]),
+ ("char", DBType TChar),
+ ("int", DBType TInt)]]
withScope :: TypeDB -> (TypeDB -> a) -> a
withScope db f = f (Map.empty : db)
typeCheck :: Program -> Error Program
-typeCheck (Program vars funcs) = do
- db <- foldM registerDVar emptyDB vars
- >>= \db' -> foldM registerDFunc db' funcs
+typeCheck (Program tdefs vars funcs) = do
+ -- case topologicalSort
+ db <- foldM registerDTypedef emptyDB tdefs
+ >>= (\db' -> foldM registerDTypedefResolve db' tdefs)
+ >>= (\db' -> foldM registerDVar db' vars)
+ >>= (\db' -> foldM registerDFunc db' funcs)
vars' <- mapM (annotateDVar db) vars
funcs' <- mapM (annotateDFunc db) funcs
- return $ Program vars' funcs'
+ return $ Program [] vars' funcs'
+
+
+registerDTypedef :: TypeDB -> DTypedef -> Error TypeDB
+registerDTypedef db (DTypedef n t) = case dbFind db n of
+ Nothing -> return $ dbSet db n (DBType t)
+ Just _ -> Left $ "Duplicate top-level name '" ++ n ++ "'"
+registerDTypedefResolve :: TypeDB -> DTypedef -> Error TypeDB
+registerDTypedefResolve db (DTypedef n t) = do
+ t' <- resolveType db t
+ return $ dbSet db n (DBType t')
registerDVar :: TypeDB -> DVar -> Error TypeDB
registerDVar db (DVar t n _) = case dbFind db n of
- Nothing -> return $ dbSet db n (DBVar t)
+ Nothing -> do
+ t' <- resolveType db t
+ return $ dbSet db n (DBVar t')
Just _ -> Left $ "Duplicate top-level name '" ++ n ++ "'"
registerDFunc :: TypeDB -> DFunc -> Error TypeDB
registerDFunc db (DFunc rt n al _) = case dbFind db n of
- Nothing -> return $ dbSet db n (DBFunc rt (map fst al))
+ Nothing -> do
+ rt' <- sequence $ fmap (resolveType db) rt
+ al' <- forM al $ \(at,an) -> (,an) <$> resolveType db at
+ return $ dbSet db n (DBFunc rt' (map fst al'))
Just _ -> Left $ "Duplicate top-level name '" ++ n ++ "'"
annotateDVar :: TypeDB -> DVar -> Error DVar
annotateDVar db (DVar toptype name expr) = do
+ toptype' <- resolveType db toptype
expr' <- annotateExpr db expr
when (isNothing (typeof expr')) $
Left $ "Cannot assign void value in global declaration of " ++ name
let typ = fromJust $ typeof expr'
- if canCoerce typ toptype
- then return $ DVar toptype name expr'
+ if canCoerce typ toptype'
+ then return $ DVar toptype' name expr'
else Left $ "Cannot assign a value of type " ++ pretty typ ++
- " to a variable of type " ++ pretty toptype
+ " to a variable of type " ++ pretty toptype'
data State = State {stDfunc :: DFunc, stLoopDepth :: Int}
deriving Show
annotateDFunc :: TypeDB -> DFunc -> Error DFunc
annotateDFunc db dfunc@(DFunc rettype name arglist block) = do
- when (name == "main" && rettype /= Just TInt) $
+ rettype' <- sequence $ fmap (resolveType db) rettype
+ arglist' <- forM arglist $ \(at,an) -> (,an) <$> resolveType db at
+ when (name == "main" && rettype' /= Just TInt) $
Left $ "Function 'main' should return an int"
- let db' = foldl registerArg db arglist
+ db' <- foldM registerArg db arglist'
block' <- annotateBlock (State dfunc 0) db' block
- return $ DFunc rettype name arglist block'
+ return $ DFunc rettype' name arglist' block'
where
- registerArg :: TypeDB -> (Type, Name) -> TypeDB
- registerArg db' (t, n) = dbSet db' n (DBVar t)
+ registerArg :: TypeDB -> (Type, Name) -> Error TypeDB
+ registerArg db' (t, n) = dbSet db' n . DBVar <$> resolveType db' t
annotateBlock :: State -> TypeDB -> Block -> Error Block
annotateBlock state db (Block sts) =
@@ -93,16 +119,17 @@ annotateBlock state db (Block sts) =
annotateStatement :: State -> TypeDB -> Statement -> Error (TypeDB, Statement)
annotateStatement _ db (SDecl toptype name expr) = do
+ toptype' <- resolveType db toptype
expr' <- annotateExpr db expr
when (isNothing (typeof expr')) $
Left $ "Cannot assign void value in declaration of " ++ name
when (isJust (dbFindTop db name)) $
Left $ "Duplicate declaration of variable " ++ name
let typ = fromJust $ typeof expr'
- if canCoerce typ toptype
- then return $ (dbSet db name (DBVar toptype), SDecl toptype name expr')
+ if canCoerce typ toptype'
+ then return $ (dbSet db name (DBVar toptype'), SDecl toptype' name expr')
else Left $ "Cannot assign a value of type " ++ pretty typ ++
- " to a variable of type " ++ pretty toptype
+ " to a variable of type " ++ pretty toptype'
annotateStatement _ db (SAs ae expr) = do
ae' <- annotateAsExpr db ae
expr' <- annotateExpr db expr
@@ -182,6 +209,7 @@ annotateExpr db (ELit lit@(LVar n) _) = case dbFind db n of
Nothing -> Left $ "Use of undeclared variable " ++ n ++ " in expression"
Just (DBVar t) -> return $ ELit lit (Just t)
Just (DBFunc _ _) -> Left $ "Cannot use function " ++ n ++ " in expression"
+ Just (DBType _) -> Left $ "Cannot use type " ++ n ++ " as value in expression"
annotateExpr db (ELit (LCall n as) _) = do
as' <- mapM (annotateExpr db) as
case dbFind db n of
@@ -200,17 +228,38 @@ annotateExpr db (ELit (LCall n as) _) = do
" but value of type " ++ pretty (fromJust $ typeof arg) ++
" was given"
return $ ELit (LCall n as') mrt
+ Just (DBType t) -> case as of
+ [a] -> annotateExpr db (ECast t a)
+ _ -> Left $ "Cannot call type " ++ pretty t ++ " as function with " ++
+ show (length as) ++ " arguments"
annotateExpr _ (ELit lit@(LStr s) _) =
return $ ELit lit (Just $ TArr TChar (Just $ fromIntegral $ length s))
+annotateExpr db (ELit (LStruct ms) _) = do
+ ms' <- forM ms $ \(n,e) -> (n,) <$> annotateExpr db e
+ types <- forM ms' $ \(n,e) -> case typeof e of
+ Nothing -> Left $ "Use of void value in struct literal item '" ++ n ++ "'"
+ Just t -> return t
+ return $ ELit (LStruct ms') (Just $ TStruct $ zip types (map fst ms'))
annotateExpr db (ESubscript arr sub _) = do
arr' <- annotateExpr db arr
sub' <- annotateExpr db sub
+ when (isNothing (typeof sub')) $
+ Left $ "Use of void value as subscripted expression"
let subtyp = fromJust (typeof sub')
when (subtyp /= TInt) $
Left $ "Type of array subscript should be int, but is " ++ pretty subtyp
case fromJust (typeof arr') of
TArr et _ -> return $ ESubscript arr' sub' (Just et)
_ -> Left $ "Subscripted expression is not an array: " ++ pretty arr
+annotateExpr db (EGet st n _) = do
+ st' <- annotateExpr db st
+ case typeof st' of
+ Nothing -> Left $ "Use of void value as dot-indexed expression"
+ Just stt@(TStruct ms) -> case find ((==n) . snd) ms of
+ Nothing -> Left $ "Struct of type " ++ pretty stt ++
+ " has no member named '" ++ n ++ "'"
+ Just (t, _) -> return $ EGet st' n (Just t)
+ Just stt -> Left $ "Use of non-struct type " ++ pretty stt ++ " as dot-indexed expression"
annotateExpr db (ECast t e) = do
e' <- annotateExpr db e
let typ = fromJust (typeof e')
@@ -232,6 +281,7 @@ annotateAsExpr db (AEVar n _) = case dbFind db n of
Nothing -> Left $ "Use of undeclared variable " ++ n ++ " in assignment expression"
Just (DBVar t) -> return $ AEVar n (Just t)
Just (DBFunc _ _) -> Left $ "Cannot use function " ++ n ++ " in assignment expression"
+ Just (DBType _) -> Left $ "Cannot use type " ++ n ++ " as variable in assignment expression"
annotateAsExpr db (AESubscript ae expr _) = do
ae' <- annotateAsExpr db ae
expr' <- annotateExpr db expr
@@ -243,3 +293,14 @@ annotateAsExpr db (AESubscript ae expr _) = do
TArr t _ -> return $ AESubscript ae' expr' (Just t)
t -> Left $ "Indexed expression '" ++ pretty ae ++ "' has non-array type " ++ pretty t ++
" in assignment expression"
+
+
+resolveType :: TypeDB -> Type -> Error Type
+resolveType _ TInt = return TInt
+resolveType _ TChar = return TChar
+resolveType db (TArr t sz) = liftM (\t' -> TArr t' sz) $ resolveType db t
+resolveType db (TStruct ms) = TStruct <$> mapM (\(t,n) -> liftM (,n) $ resolveType db t) ms
+resolveType db (TName n) = case dbFind db n of
+ Nothing -> Left $ "Type name '" ++ n ++ "' not defined"
+ Just (DBType t) -> return t
+ Just _ -> Left $ "Name '" ++ n ++ "' used as type is not a type"
diff --git a/TypeRules.hs b/TypeRules.hs
index 2bafe63..b73daf2 100644
--- a/TypeRules.hs
+++ b/TypeRules.hs
@@ -1,5 +1,7 @@
module TypeRules where
+import Data.List
+
import AST
@@ -53,6 +55,7 @@ instance TypeOf Expression where
typeof (EUn _ _ mt) = mt
typeof (ELit _ mt) = mt
typeof (ESubscript _ _ mt) = mt
+ typeof (EGet _ _ mt) = mt
typeof (ECast t _) = Just t
typeof (ENew t _) = Just $ TArr t Nothing
diff --git a/Utils.hs b/Utils.hs
index 60f8ff5..51eecf8 100644
--- a/Utils.hs
+++ b/Utils.hs
@@ -11,3 +11,6 @@ uniq l = l
contains :: Eq a => [a] -> a -> Bool
contains l v = isJust $ find (== v) l
+
+roundUp :: Integral a => a -> a -> a
+roundUp n sz = (n + sz - 1) `div` sz * sz
diff --git a/X64.hs b/X64.hs
index 26c35dd..0cbf4fc 100644
--- a/X64.hs
+++ b/X64.hs
@@ -190,7 +190,7 @@ instance Stringifiable XRef where
szword 2 = "word"
szword 4 = "dword"
szword 8 = "qword"
- szword _ = undefined
+ szword s = error $ "Invalid (szword " ++ show s ++ ") in stringify XMem"
stringify (XImm imm) = show imm
@@ -283,6 +283,10 @@ xrefSetSize sz (XReg _ r) = XReg sz r
xrefSetSize sz (XMem _ a b c d) = XMem sz a b c d
xrefSetSize _ x@(XImm _) = x
+offsetXMem :: Offset -> XRef -> XRef
+offsetXMem off (XMem sz mr tup lbl o) = XMem sz mr tup lbl (o + off)
+offsetXMem _ _ = undefined
+
isXReg :: XRef -> Bool
isXReg (XReg _ _) = True
isXReg _ = False
diff --git a/X64Optimiser.hs b/X64Optimiser.hs
index 195389f..206529f 100644
--- a/X64Optimiser.hs
+++ b/X64Optimiser.hs
@@ -3,7 +3,7 @@ module X64Optimiser(x64Optimise) where
import Data.List
import Data.Maybe
-import Defs
+import Defs hiding (Offset)
import X64
@@ -88,17 +88,21 @@ optDoubleAdd (name, inss) = (name, go inss)
where
go :: [Ins] -> [Ins]
go [] = []
- go (add@(ADD (RegMem xreg@(XReg _ xregReg)) (RegMemImm (XImm _))) : rest) =
+ go (add@(ADD (RegMem xreg@(XReg _ xregReg)) (RegMemImm (XImm _))) : rest) = start xreg xregReg add rest
+ go (sub@(SUB (RegMem xreg@(XReg _ xregReg)) (RegMemImm (XImm _))) : rest) = start xreg xregReg sub rest
+ go (ins : rest) = ins : go rest
+
+ start :: XRef -> Register -> Ins -> [Ins] -> [Ins]
+ start xreg xregReg addsub rest =
let midx = flip findIndex rest $ \ins -> case ins of
ADD (RegMem xreg2@(XReg _ _)) (RegMemImm (XImm _)) | xreg == xreg2 -> True
SUB (RegMem xreg2@(XReg _ _)) (RegMemImm (XImm _)) | xreg == xreg2 -> True
_ -> False
in case midx of
- Nothing -> add : go rest
+ Nothing -> addsub : go rest
Just idx -> if all (canSkip xregReg) (take idx rest)
- then go $ merge add (rest !! idx) : take idx rest ++ drop (idx + 1) rest
- else add : go rest
- go (ins : rest) = ins : go rest
+ then go $ merge addsub (rest !! idx) : take idx rest ++ drop (idx + 1) rest
+ else addsub : go rest
canSkip :: Register -> Ins -> Bool
canSkip _ (CALL _) = False
@@ -121,7 +125,7 @@ optDoubleAdd (name, inss) = (name, go inss)
dst1 = destOf ins1
dst2 = destOf ins2
in if dst1 == dst2
- then ADD (RegMem dst1) (RegMemImm $ XImm $ e1 + e2)
+ then (if e1 + e2 < 0 then SUB else ADD) (RegMem dst1) (RegMemImm $ XImm $ abs $ e1 + e2)
else undefined
effectOf :: Ins -> Offset
diff --git a/bf.lang b/bf.lang
index c42f73d..0ce6389 100644
--- a/bf.lang
+++ b/bf.lang
@@ -1,3 +1,5 @@
+type byte := char;
+
func putstr(char[] str) {
int i := 0;
while (str[i] != '\0') {
@@ -6,16 +8,6 @@ func putstr(char[] str) {
}
}
-func int strlen(char[] str) {
- int i := 0;
- char c := str[i];
- while (c != '\0') {
- i = i + 1;
- c = str[i];
- }
- return i;
-}
-
func int[] makejumpmap(char[] src, int srclen) {
int[] jm := new int[srclen];
int[] stack := new int[srclen];
@@ -51,18 +43,18 @@ func int[] makejumpmap(char[] src, int srclen) {
func interpret(char[] src, int srclen) {
int[] jm := makejumpmap(src, srclen);
- char[] mem := new char[4088];
+ byte[] mem := new char[4088];
int ip := 0;
int memp := 0;
while (src[ip] != '\0') {
// putint(ip); putc('\n');
char c := src[ip];
- if (c == '+') {mem[memp] = mem[memp] + char(1);}
- if (c == '-') {mem[memp] = mem[memp] - char(1);}
+ if (c == '+') {mem[memp] = mem[memp] + byte(1);}
+ if (c == '-') {mem[memp] = mem[memp] - byte(1);}
if (c == '>') {memp = memp + 1;}
if (c == '<') {memp = memp - 1;}
if (c == '.') {putc(mem[memp]);}
- if (c == ',') {mem[memp] = char(getc());}
+ if (c == ',') {mem[memp] = byte(getc());}
if (c == '[') {
if (mem[memp] == '\0') {
ip = jm[ip];
diff --git a/graph.png b/graph.png
deleted file mode 100644
index 0356b69..0000000
--- a/graph.png
+++ /dev/null
Binary files differ
diff --git a/liblang.asm b/liblang.asm
index 9cd905c..8502d55 100644
--- a/liblang.asm
+++ b/liblang.asm
@@ -158,7 +158,8 @@ getc:
syscall
cmp rax, 1
jne .fail
- mov rax, [rsp]
+ xor eax, eax
+ mov al, [rsp]
.finish:
pop r11
pop rcx
diff --git a/struct.lang b/struct.lang
new file mode 100644
index 0000000..3297939
--- /dev/null
+++ b/struct.lang
@@ -0,0 +1,19 @@
+type S := struct {
+ int x;
+ char y;
+};
+
+func f(int iets1, S s, int iets2) {
+ putint(s.x); putc(s.y); putc('\n');
+ putint(iets1); putc(' '); putint(iets2); putc('\n');
+}
+
+func int main() {
+ int a := getc();
+ int b := getc();
+ getc(); // newline
+ S ding := {x = 2*a, y = 'a'};
+ // return ding.x;
+ f(123, ding, 456);
+ return int(ding.y) + a + b;
+}
generated by cgit v1.2.3-70-g09d2 (git 2.47.0) at 2024-11-22 08:14:38 +0100