release(v0.3): program scope

Author: vorotynsky

HLasm.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           HLasm
-version:        0.2.0.0
+version:        0.3.0.0
 description:    Please see the README on GitHub at <https://github.com/vorotynsky/HLasm#readme>
 homepage:       https://github.com/vorotynsky/HLasm#readme
 bug-reports:    https://github.com/vorotynsky/HLasm/issues

app/Main.hs

@@ -11,7 +11,7 @@ import           HLasm.Parser
 import           HLasm.Scope (semantic)
 import           HLasm.Types (typeCheck)
 import           HLasm.Frame (StackFrame(Root), buildStackFrames)
-import           HLasm.Instructions (instructions, BackEnd(..), runBackend)
+import           HLasm.Instructions (program, BackEnd(..), runBackend)
 import           HLasm.Backend.Nasm
 
 parseAll :: String -> String
@@ -22,8 +22,8 @@ parseAll = get . first show . pipeline
                _        <- typeCheck semantic
                stack    <- Right $ (buildStackFrames Root) parsed
                tree     <- Right $ mzipWith (\(e, v, l) (_, sf) -> (e, v, l, sf)) semantic stack 
-               instructions <- instructions tree
-               runBackend nasm instructions
+               objProg  <- program tree
+               runBackend nasm objProg
 
 main :: IO ()
 main = do

package.yaml

@@ -1,5 +1,5 @@
 name:                HLasm
-version:             0.2.0.0
+version:             0.3.0.0
 github:              "vorotynsky/HLasm"
 license:             GPL-3
 author:              "Vorotynsky Maxim"

src/HLasm/Ast.hs

@@ -3,6 +3,7 @@
 module HLasm.Ast where
 
 import Data.Tree
+import Data.Maybe
 
 data Type = Type
     { typeName :: String
@@ -20,15 +21,6 @@ data CompareType =
     | Less
     deriving (Show, Eq)
 
-data HLValuable = 
-    Variable (VariableName, Type)
-    | Register (VariableName, RegisterName)
-    deriving (Show, Eq)
-
-valuableName :: HLValuable -> VariableName
-valuableName (Variable (name, _)) = name
-valuableName (Register (name, _)) = name
-
 data HLValue = 
     NameValue VariableName
     | IntegerValue Int
@@ -44,8 +36,14 @@ data Condition = Condition (HLValue, CompareType, HLValue)
     deriving (Show, Eq)
 
 data HLElement = 
-    InstructionSet
-    | VariableDeclaration HLValuable
+    Program
+    | InstructionSet
+    | RegisterDeclaration  VariableName RegisterName
+    | VariableDeclaration  VariableName Type
+    | GlobalVarDeclaration VariableName Type HLValue
+    | ConstVarDeclaration  VariableName Type HLValue
+    | FakeVariable         VariableName
+    | FakeFrame            Label
     | Frame (Maybe Label)
     | If Label
     | IfBranch (Maybe Condition)
@@ -57,6 +55,19 @@ data HLElement =
     | AssemblyCall String
     deriving (Show, Eq)
 
+getValuableName :: HLElement -> Maybe VariableName
+getValuableName (VariableDeclaration  name _  ) = Just name
+getValuableName (RegisterDeclaration  name _  ) = Just name
+getValuableName (GlobalVarDeclaration name _ _) = Just name
+getValuableName (ConstVarDeclaration  name _ _) = Just name
+getValuableName _                               = Nothing
+
+isVariable :: HLElement -> Bool
+isVariable = isJust . getValuableName
+
+variableName :: HLElement -> VariableName
+variableName = fromJust . getValuableName
+
 usedVariables :: HLElement -> [VariableName]
 usedVariables (IfBranch (Just (Condition(left, _, right)))) = name left ++ name right
     where name (NameValue name) = [name]

src/HLasm/Backend/Nasm.hs

@@ -2,24 +2,39 @@
 
 module HLasm.Backend.Nasm (nasm) where
 
-import           HLasm.Ast          (CompareType (..))
+import           Data.Char
+
+import           HLasm.Ast          (CompareType (..), Type(..))
+import           HLasm.Error
 import           HLasm.Frame
-import           HLasm.Instructions
+import           HLasm.Instructions hiding (program)
 
 bytes :: Int -> Int
 bytes x = ceiling ((toEnum x) / 8)
 
-choosePtr :: Int -> String
-choosePtr = f . bytes
-    where f 1 = "BYTE"
-          f 2 = "WORD"
-          f 4 = "DWORD"
+data DataType = Byte | Word | Dword
+    deriving (Show, Eq)
+
+uname = fmap toUpper . show
+
+dname Byte  = "DB"
+dname Word  = "DW"
+dname Dword = "DD"
+
+datatype :: Int -> DataType
+datatype = f . bytes
+    where f 1 = Byte
+          f 2 = Word
+          f 4 = Dword
           f n = error ("undefined data size: " ++ show n)
 
+toDatatype :: Type -> DataType
+toDatatype = let size (Type _ (Just s)) = s in datatype . size
+
 target :: Target -> String
 target (NamedTarget name)           = name
 target (Register reg)               = reg
-target (FrameVar (offset, size, _)) = choosePtr size ++ " [ebp-" ++ (show $ bytes (offset + size)) ++ "]"
+target (FrameVar (offset, size, _)) = (uname . datatype) size ++ " [bp-" ++ (show $ bytes (offset + size)) ++ "]"
 target (ConstantTarget const)       = show const
 
 instr2arg :: String -> Target -> Target -> String
@@ -30,7 +45,7 @@ size (Root)           = 0
 size (Fluent _)       = 0
 size (StackFrame _ x) = bytes $ frameSize x
 
-frame f = ["push ebp", "mov ebp, esp", "sub esp, " ++ (show . size $ f)]
+frame f = ["push bp", "mov bp, sp", "sub sp, " ++ (show . size $ f)]
 
 instruction :: Instructions -> [String]
 instruction (PureAsm str)               = [str]
@@ -46,13 +61,26 @@ instruction (Jump lbl (Just Equals))    = ["je " ++ lbl]
 instruction (Jump lbl (Just NotEquals)) = ["jne " ++ lbl]
 instruction (Jump lbl (Just Greater))   = ["jg " ++ lbl]
 instruction (Jump lbl (Just Less))      = ["jl " ++ lbl]
-instruction (Call lbl args size)        = (fmap push . reverse $ args) ++ ["call " ++ lbl, "add esp, " ++ show (bytes size)]
+instruction (Call lbl args size)        = (fmap push . reverse $ args) ++ ["call " ++ lbl, "add sp, " ++ show (bytes size)]
     where push x = "push " ++ (target x)
 
+variable :: Variable -> String
+variable (Variable n t v)= n ++ ": " ++ (dname . toDatatype) t ++ " " ++ show v
+
 join :: String -> [String] -> String
 join s []     = ""
 join s [x]    = x
 join s (x:xs) = x ++ s ++ join s xs
 
+sectionHeader header = Right .  join "\n" . ((:) ("section ." ++ header))
+
+section :: Section -> Result String
+section (Text x)      = sectionHeader "text\n" . concat $ fmap instruction x
+section (Data x)      = sectionHeader "data"          $ fmap variable x
+section (Constants x) = sectionHeader "rodata"        $ fmap variable x
+
+program :: ObjProgram -> Result String
+program (ObjProgram sections) = fmap (join "\n\n") . traverse section $ sections
+
 nasm :: BackEnd
-nasm = BackEnd (\x -> Right . join "\n" . concat $ fmap instruction x)
+nasm = BackEnd program

src/HLasm/Error.hs

@@ -11,14 +11,16 @@ data Error =
     | VariableNotFound VariableName
     | LabelNotFound Label
     | IncompatibleTypes (HLValue, HLValue)
+    | GlobalVariableInFrame VariableName
     deriving (Eq)
 
 type Result a = Either Error a
 
 instance Show Error where
     show (StringError msg) = "error: " ++ msg ++ ".\n"
-    show (VariableNotFound name) = "scope error: variable \'" ++ name ++ "\' not found.\n"
-    show (LabelNotFound label) = "scope error: label \'" ++ label ++ "\' not found.\n"
+    show (VariableNotFound name) = "scope error: a variable \'" ++ name ++ "\' not found.\n"
+    show (LabelNotFound label) = "scope error: a label \'" ++ label ++ "\' not found.\n"
     show (IncompatibleTypes (left, right)) = 
         "type error: incompatible types between \'" ++ show left ++ "\' and \'" ++ show right ++ "\'.\n"
     show (ParseError err) = "parser error, " ++ show err
+    show (GlobalVariableInFrame name) = "error: the global variable \'" ++ name ++ "\' isn't in the global scope.\n"

src/HLasm/Frame.hs

@@ -2,7 +2,7 @@
 
 module HLasm.Frame
 ( VarFrame(..)
-, valueSize
+, stackVarSize
 , frameSize
 , buildFrame
 , buildFrameTree
@@ -16,29 +16,32 @@ import           Data.Tree
 import           HLasm.Ast
 import           HLasm.Scope hiding (Scope(Root))
 
-valueSize :: HLValuable -> Int
-valueSize (Variable (_, t)) = size t
-    where size (Type _ (Just s)) = s
-          {- TODO: add support or refactor in future (on adding errors to compiler) -}
-          size (Type _ Nothing)  = error "Unsupported types without specified size"
-valueSize (Register (_, r)) = undefined
+size (Type _ (Just s)) = s
+{- TODO: add support or refactor in future (on adding errors to compiler) -}
+size (Type _ Nothing)  = error "Unsupported types without specified size"
 
-newtype VarFrame = VarFrame [(HLValuable, Int, Int)]
+stackVarSize :: HLElement -> Int
+stackVarSize (VariableDeclaration  _ t  ) = size t
+stackVarSize (GlobalVarDeclaration _ t _) = size t
+stackVarSize (ConstVarDeclaration  _ t _) = size t
+stackVarSize (RegisterDeclaration  _ r  ) = 0
+
+newtype VarFrame = VarFrame [(HLElement, Int, Int)]
     deriving (Show, Eq) 
 
 empty :: VarFrame
 empty = VarFrame []
 
 frameSize :: VarFrame -> Int
-frameSize = foldr (+) 0 . fmap valueSize . (\(VarFrame xs) -> fmap (\(x,_,_) -> x) xs)
+frameSize = foldr (+) 0 . fmap stackVarSize . (\(VarFrame xs) -> fmap (\(x,_,_) -> x) xs)
 
-buildFrame :: [HLValuable] -> VarFrame
-buildFrame xs = VarFrame $ zipWith (\v o -> (v, o, valueSize v)) xs (fmap (foldl (+) 0) . inits . fmap valueSize $ xs)
+buildFrame :: [HLElement] -> VarFrame
+buildFrame xs = VarFrame $ zipWith (\v o -> (v, o, stackVarSize v)) xs (fmap (foldl (+) 0) . inits . fmap stackVarSize $ xs)
 
-frameVars :: SyntaxTree -> [HLValuable]
+frameVars :: SyntaxTree -> [HLElement]
 frameVars (Node el@(Frame _) [])    = []
 frameVars (Node el@(Frame _) (x:_)) = frameVars x
-    where frameVars (Node (VariableDeclaration val@(Variable _)) xs) = [val] ++ (concatMap frameVars xs)
+    where frameVars (Node val xs) | isVariable val = [val] ++ (concatMap frameVars xs)
           frameVars (Node el@(Frame _) _) = []
           frameVars (Node _ xs) = concatMap frameVars xs
 
@@ -66,5 +69,5 @@ findOffset (StackFrame parent vars) name
     | (any predicate list) = fmap (\(_, o, _) -> o) . find predicate $ list
     | otherwise = fmap (+ frameSize vars) $ findOffset parent name -- -> change last commit
     where list = (\(VarFrame xs) -> xs) vars
-          predicate ((Variable (n, _)), _, _) | n == name = True
+          predicate (el, _, _) | isVariable el && (variableName el) == name = True
           predicate _ = False

src/HLasm/Instructions.hs

@@ -2,10 +2,11 @@
 
 module HLasm.Instructions
 ( Offset(..), Target(..), InstructionSet(..)
-, Instructions(..)
+, Instructions(..), Variable(..)
+, Section(..), ObjProgram(..)
 , BackEnd(..)
 , runBackend
-, instructions
+, program
 ) where
 
 import           Control.Monad.Extra (concatMapM)
@@ -40,16 +41,24 @@ data Instructions =
 
 type InstructionSet = [Instructions]
 
-newtype BackEnd = BackEnd (InstructionSet -> Result String)
+data Variable = Variable VariableName Type HLValue
+
+data Section =
+    Text InstructionSet
+    | Data [Variable]
+    | Constants [Variable]
+
+newtype ObjProgram = ObjProgram [Section]
+
+newtype BackEnd = BackEnd (ObjProgram -> Result String)
 runBackend (BackEnd f) x = f x
 
 
 target :: StackFrame -> VariableData -> Target
-target _ (VariableData (_, VariableDeclaration (HLasm.Ast.Register(_, reg)))) = HLasm.Instructions.Register reg
+target _ (VariableData (_, (RegisterDeclaration _ reg))) = HLasm.Instructions.Register reg
 target frame (VariableData (name, e)) = case findOffset frame name of
-    Just x  -> FrameVar (x, size e, name)
+    Just x  -> FrameVar (x, stackVarSize e, name)
     Nothing -> NamedTarget name
-    where size (VariableDeclaration v) = valueSize v
 
 findTarget :: StackFrame -> [VariableData] -> VariableName -> Target --  was a lot of checks, target garanteed be here.
 findTarget frame xs name = target frame . fromJust . find (\(VariableData (n, _)) -> n == name) $ xs
@@ -61,31 +70,61 @@ valuableTarget (sf, vd) (NameValue name) = findTarget sf vd name
 loop :: Label -> Result (InstructionSet) -> Result (InstructionSet)
 loop lbl i = let begin = lbl ++ "begin" in fmap (\x -> [Label begin] ++ x ++ [Jump begin Nothing, Label (lbl ++ "end")]) $ i
 
+isEmptyInstruction :: HLElement -> Bool
+isEmptyInstruction (FakeVariable _)       = True
+isEmptyInstruction (FakeFrame _)          = True
+isEmptyInstruction (VariableDeclaration _ _) = True
+isEmptyInstruction (RegisterDeclaration _ _) = True
+isEmptyInstruction _                         = False
+
+
 instructions :: Tree (HLElement, [VariableData], [LabelData], StackFrame) -> Result (InstructionSet)
+instructions (Node (el, _, _, _) _) | isEmptyInstruction el = Right []
 instructions (Node ((InstructionSet         ), _, _, _) xs) = concatMapM instructions xs
-instructions (Node ((VariableDeclaration val), _, _, _) _ ) = Right []
 instructions (Node ((While lbl              ), _, _, _) xs) = loop lbl (concatMapM instructions xs)
 instructions (Node ((DoWhile lbl            ), _, _, _) xs) = loop lbl (concatMapM instructions xs)
 instructions (Node ((Break lbl              ), _, _, _) _ ) = Right [Jump (lbl ++ "end") Nothing]
 instructions (Node ((AssemblyCall str       ), _, _, _) _ ) = Right [PureAsm str]
 instructions (Node ((Frame lbl              ), _, _, f) xs) =
     (\body -> [BeginFrame f lbl] ++ body ++ [EndFrame f lbl]) <$> concatMapM instructions xs
 
+instructions (Node ((GlobalVarDeclaration n _ _), _, _, _) _ ) = Left (GlobalVariableInFrame n)
+instructions (Node ((ConstVarDeclaration n _ _), _, _, _) _ )  = Left (GlobalVariableInFrame n)
+
 instructions (Node ((Assignment name (NameValue val)),    d, _, f) _) = Right [Move (findTarget f d name) (findTarget f d val)]
 instructions (Node ((Assignment name (IntegerValue val)), d, _, f) _) = Right [Move (findTarget f d name) (ConstantTarget val)]
 
 instructions (Node ((HLasm.Ast.Call lbl ns  ), d, _, f) _ ) = 
     Right [HLasm.Instructions.Call lbl (fmap (findTarget f d) ns) size]
-    where size = foldl (+) 0 . fmap (\(VariableData (_, (VariableDeclaration d))) -> valueSize d) $ d 
+    where size = foldl (+) 0 . fmap (\(VariableData (_, d)) -> stackVarSize d) $ d
 
 instructions (Node ((If lbl), _, _, _) []) = Right []
 instructions (Node ((If lbl), _, _, _) xs) =
     do (conds, bodies') <- Right $ traverse (uncurry branch) (zip [1..] xs)
        bodies           <- fmap (concat) . sequence $ bodies'
        Right $ conds ++ [Jump (lbl ++ "end") Nothing] ++ bodies ++ [Label (lbl ++ "end")]
-
     where condition lbl pt (Condition (left, cmp, right)) =
               let find = valuableTarget pt in [Compare (find left) (find right), Jump lbl (Just cmp)]
           wrapif i = fmap (\b -> [Label (lbl ++ show i)] ++ b ++ [Jump (lbl ++ "end") Nothing]) . concatMapM instructions
           branch i (Node ((IfBranch (Just cond)), d, _, f) xs) = (condition (lbl ++ show i) (f, d) cond, wrapif i xs)
           branch i (Node ((IfBranch Nothing),     _, _, _) xs) = ([Jump     (lbl ++ show i)    Nothing], wrapif i xs)
+
+
+dataFilter  (Node ((GlobalVarDeclaration n t v), _, _, _) _) = Just $ Variable n t v
+dataFilter  _                                                = Nothing
+constFilter (Node ((ConstVarDeclaration n t v), _, _, _) _)  = Just $ Variable n t v
+constFilter _                                                = Nothing
+
+varSection ctor f xs = Right . ctor . fmap fromJust . filter isJust . fmap f $ xs
+
+filterF :: [(a -> Maybe b)] -> (a -> Bool)
+filterF fs = foldl or (const True) . fmap ((.) (not . isJust)) $ fs
+    where or f g x = f x && g x
+
+program :: Tree (HLElement, [VariableData], [LabelData], StackFrame) -> Result ObjProgram
+program (Node ((Program), _, _, _) xs) = 
+    do text   <- concatMapM instructions . filter (filterF [dataFilter, constFilter]) $ xs
+       dat    <- varSection Data      dataFilter  xs
+       const  <- varSection Constants constFilter xs
+       Right $ ObjProgram [(Text text), dat, const]
+program _ = undefined