diff options
author | tomsmeding <tom.smeding@gmail.com> | 2017-09-01 18:14:43 +0200 |
---|---|---|
committer | tomsmeding <tom.smeding@gmail.com> | 2017-09-01 18:15:25 +0200 |
commit | 19c70b8eaa1126f1648b009d99092432a5c88059 (patch) | |
tree | bd4171a4d6ef5e8ae2b09e1c84bf3e2346374e97 | |
parent | 3d5d85e00f2a81efb62bb17f8e5db63fe5a49a61 (diff) |
Structs + typedefs
-rw-r--r-- | AST.hs | 80 | ||||
-rw-r--r-- | BuildIR.hs | 49 | ||||
-rw-r--r-- | CodeGen.hs | 124 | ||||
-rw-r--r-- | Defs.hs | 1 | ||||
-rw-r--r-- | Intermediate.hs | 12 | ||||
-rw-r--r-- | Main.hs | 3 | ||||
-rw-r--r-- | Makefile | 2 | ||||
-rw-r--r-- | Optimiser.hs | 51 | ||||
-rw-r--r-- | ProgramParser.hs | 107 | ||||
-rw-r--r-- | ReplaceRefs.hs | 40 | ||||
-rw-r--r-- | TypeCheck.hs | 99 | ||||
-rw-r--r-- | TypeRules.hs | 3 | ||||
-rw-r--r-- | Utils.hs | 3 | ||||
-rw-r--r-- | X64.hs | 6 | ||||
-rw-r--r-- | X64Optimiser.hs | 18 | ||||
-rw-r--r-- | bf.lang | 20 | ||||
-rw-r--r-- | graph.png | bin | 166622 -> 0 bytes | |||
-rw-r--r-- | liblang.asm | 3 | ||||
-rw-r--r-- | struct.lang | 19 |
19 files changed, 472 insertions, 168 deletions
@@ -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) ++ "}" @@ -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 ++ ")" @@ -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]] @@ -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 @@ -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" @@ -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 @@ -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 @@ -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 @@ -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 Binary files differdeleted file mode 100644 index 0356b69..0000000 --- a/graph.png +++ /dev/null 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; +} |