Compiles colors.asm!

app/Main.hs

@@ -1,38 +1,22 @@
 module Main (main) where
 
+import Bin
 import CmdOptions (Options (..), runCmdOptions)
 import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Text.IO qualified as T
 import Expr qualified
 import Path
-import Bin
 
 main :: IO ()
 main = do
-  (Options sourceCodeFile) <- runCmdOptions
-  putStrLn $ "FILEPATH: " <> sourceCodeFile
+  (Options sourceCodePath) <- runCmdOptions
+  putStrLn $ "FILEPATH: " <> sourceCodePath
   assemblyCode <- T.readFile "asm/colors.asm"
-  -- let assemblyCode =
-  --       T.unlines
-  --         [ "start: MOV AX, 1234 ; commment ;; coomeeeent"
-  --         , "; comment          SUB CX, DX"
-  --         , "SUB AX, DX"
-  --         , -- ]
-  --           -- [
-  --           "ORG 100h"
-  --         , "MOV AL, 00000111b   ; AL = 7"
-  --         , "OR  AL, 0           ; just set flags."
-  --         , "JNS label1"
-  --         , -- , "PRINT 'signed.'"
-  --           "JMP exit"
-  --         ]
-
   T.putStrLn assemblyCode
   T.putStrLn $ T.replicate 10 "-"
   mayStatements <- Expr.mainLocal assemblyCode
   case mayStatements of
     Nothing -> T.putStrLn "No results to be written"
     Just statements -> do
-      writeBin statements
-
+      writeBin sourceCodePath statements

asmh.cabal

@@ -58,9 +58,12 @@ library
     bits-show,
     bytestring,
     cereal,
+    containers,
+    filepath,
     megaparsec,
     path,
     text,
+    vector,
 
 executable asmh
   import:
@@ -81,10 +84,12 @@ executable asmh
     bits-show,
     bytestring,
     cereal,
+    filepath,
     githash,
     optparse-applicative,
     path,
     text,
+    vector,
 
 -- opt-env-conf,
 test-suite asmh-test

src/Bin.hs

@@ -1,39 +1,133 @@
-module Bin where
+{-# LANGUAGE OverloadedRecordDot #-}
 
+module Bin (writeBin) where
+
+import Data.ByteString (ByteString)
 import Data.ByteString qualified as B
+import Data.Map (Map)
+import Data.Map qualified as M
 import Data.Serialize.Put
 import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Text.IO qualified as T
+import Data.Vector (Vector)
+import Data.Vector qualified as V
 import Data.Word
+import Debug.Trace
 import Expr
+import System.FilePath
+
+type Location = Int
+
+data ProgramInfo
+  = ProgramInfo
+  { directives :: Vector Directive
+  , labels :: Map Label Location
+  , instructions :: Vector Instruction
+  }
+  deriving (Eq, Show)
+
+getInstOffset :: Instruction -> Int
+getInstOffset = \case
+  MOV (RegOp AX) (ImmOp _ew) -> 3
+  MOV (RegOp BX) (ImmOp _ew) -> 3
+  MOV (RegOp CX) (ImmOp _ew) -> 3
+  MOV (RegOp AH) (ImmOp _ew) -> 2
+  MOV (RegOp AL) (ImmOp _ew) -> 2
+  MOV (RegOp BH) (ImmOp _ew) -> 2
+  MOV (RegOp BL) (ImmOp _ew) -> 2
+  MOV (RegOp DH) (ImmOp _ew) -> 2
+  MOV (RegOp DL) (ImmOp _ew) -> 2
+  INT _word -> 2
+  JMP _label -> 2
+  JE _label -> 2
+  INC (RegOp _) -> 2
+  CMP (RegOp DH) (ImmOp _ew) -> 3
+  CMP (RegOp DL) (ImmOp _ew) -> 3
+  RET -> 1
+  x -> error $ "Instruction unimplemented: " <> show x
+
+trans :: Map Label Location -> Location -> Instruction -> Put
+trans labelMap instrLoc = \case
+  MOV (RegOp AX) (ImmOp ew) -> putWord8 0xb8 >> treatAsW16 ew
+  MOV (RegOp BX) (ImmOp ew) -> putWord8 0xbb >> treatAsW16 ew
+  MOV (RegOp CX) (ImmOp ew) -> putWord8 0xb9 >> treatAsW16 ew
+  -- MOV (RegOp DX) (ImmOp ew) -> putWord8 >> putEitherW ew
+  MOV (RegOp AH) (ImmOp ew) -> putWord8 0xb4 >> putAsW8 ew
+  MOV (RegOp AL) (ImmOp ew) -> putWord8 0xb0 >> putAsW8 ew
+  MOV (RegOp BH) (ImmOp ew) -> putWord8 0xb7 >> putAsW8 ew
+  MOV (RegOp BL) (ImmOp ew) -> putWord8 0xb3 >> putAsW8 ew
+  MOV (RegOp DH) (ImmOp ew) -> putWord8 0xb6 >> putAsW8 ew
+  MOV (RegOp DL) (ImmOp ew) -> putWord8 0xb2 >> putAsW8 ew
+  -- ADD operand1 operand2 -> undefined
+  -- SUB operand1 operand2 -> undefined
+  -- OR operand1 operand2 -> undefined
+  INT word -> putWord8 0xcd >> putWord8 word
+  JMP label ->
+    putWord8 0xeb
+      >> putWord8 (getOffset (checkLabel label) instrLoc)
+  JE label ->
+    putWord8 0x74
+      >> putWord8 (getOffset (checkLabel label) instrLoc)
+  -- JNS label -> undefined
+  INC (RegOp DH) -> putWord8 0xfe >> putWord8 0xc6
+  INC (RegOp BL) -> putWord8 0xfe >> putWord8 0xc3
+  INC (RegOp DL) -> putWord8 0xfe >> putWord8 0xc2
+  CMP (RegOp DH) (ImmOp ew) -> putWord8 0x80 >> putWord8 0xfe >> putAsW8 ew
+  CMP (RegOp DL) (ImmOp ew) -> putWord8 0x80 >> putWord8 0xfa >> putAsW8 ew
+  RET -> putWord8 0xc3
+  x -> error $ "Instruction unimplemented: " <> show x
+  where
+    getOffset :: Location -> Location -> Word8
+    getOffset locationOfLabelDeclaration locationOfCurrJumpInstr =
+      fromIntegral $
+        locationOfLabelDeclaration - locationOfCurrJumpInstr
+
+    checkLabel :: Label -> Location
+    checkLabel label = case M.lookup label labelMap of
+      Nothing -> error $ concat ["Label '", T.unpack label, "' not found'"]
+      Just v -> v
+    {-# INLINE putEitherW #-}
+    putEitherW :: Either Word8 Word16 -> Put
+    putEitherW = \case
+      Left w -> putWord8 w
+      Right w -> putWord16le w
+
+    putAsW8 :: Either Word8 Word16 -> Put =
+      putWord8 . either id fromIntegral
+    treatAsW16 :: Either Word8 Word16 -> Put =
+      putWord16le . either fromIntegral id
+
+firstPass :: [Statement] -> ProgramInfo
+firstPass ls = traceShowId $ go ls 0 (ProgramInfo mempty mempty mempty)
+  where
+    go :: [Statement] -> Int -> ProgramInfo -> ProgramInfo
+    go [] offset accum = accum
+    go (x : xs) offset acc = case x of
+      Ins newInstr ->
+        let newOffset = offset + getInstOffset newInstr
+         in go xs newOffset $ acc {instructions = V.snoc acc.instructions newInstr}
+      Dir newDir -> go xs offset $ acc {directives = V.snoc acc.directives newDir}
+      Lab newLabel ->
+        case xs of
+          (Ins _ : _) ->
+            let newInstrPos = offset
+             in go xs offset $ acc {labels = M.insert newLabel newInstrPos acc.labels}
+          _ -> error "there must be a label after an instruction"
 
--- serialize :: [Statement] -> ByteString
--- serialize =
-
-trans :: Instruction -> Put
-trans = \case
-  MOV (RegOp AX) (ImmOp (Right w16)) -> do
-    putWord8 0xb8 >> putWord16le w16
-  ADD operand1 operand2 -> undefined
-  SUB operand1 operand2 -> undefined
-  OR operand1 operand2 -> undefined
-  INT word -> undefined
-  JNS label -> undefined
-  JMP label -> undefined
-  INC operand -> undefined
-  CMP operand1 operand2 -> undefined
-  JE label -> undefined
-
-writeBin :: [Statement] -> IO ()
-writeBin instr = do
-  B.writeFile "test.com" test
-  T.putStrLn "Output written to test.com"
+secondPass :: ProgramInfo -> ByteString
+secondPass = runPut . go 0
   where
-    -- bs = undefined
-    bs = undefined
+    go offset p = case V.uncons p.instructions of
+      Just (nextInstruction, rest) -> do
+        let nextInstructionIndex = offset + getInstOffset nextInstruction
+        trans p.labels nextInstructionIndex nextInstruction
+        go nextInstructionIndex (p {instructions = rest})
+      Nothing -> pure ()
 
-    test =
-      runPut $
-        trans $
-          MOV (RegOp AX) (ImmOp (Right 3))
+writeBin :: FilePath -> [Statement] -> IO ()
+writeBin originalFileName instr = do
+  let newFileName = takeBaseName originalFileName <> ".com"
+  let binaryFile = secondPass $ firstPass instr
+  B.writeFile newFileName binaryFile
+  T.putStrLn $ "Output written to " <> T.pack newFileName

src/Expr.hs

@@ -18,11 +18,6 @@ import Prelude hiding (take)
 
 type Parser = Parsec Void Text
 
-data ProgramInfo = ProgramInfo
-  { directives :: [Directive]
-  , instructions :: [(String, Instruction)]
-  }
-
 data Register
   = -- | (16 bit) the accumulator register (divided into AH / AL).
     AX
@@ -86,14 +81,14 @@ data Instruction
   | INC Operand
   | CMP Operand Operand
   | JE Label
+  | RET
   deriving (Show, Eq)
 
 data Directive
   = ORG Word16
   | DB (Either (Text, [Word8]) [Word8])
   | END
   | NAME Text
-  | RET
   deriving (Show, Eq)
 
 -- Parser for registers
@@ -241,6 +236,7 @@ parseInstruction =
       , INC <$> (L.symbol' hspace1 "inc" *> parseOperand)
       , binaryP CMP "cmp"
       , JE <$> (L.symbol' hspace1 "je" *> parseVarOrLabelName)
+      , RET <$ L.symbol' hspace "ret"
       ]
   where
     binaryP constr txt =
@@ -256,7 +252,6 @@ parseDirective =
     , NAME
         <$> ( L.symbol' hspace1 "name" *> between "\"" "\"" (takeWhileP Nothing isAlphaNum)
             )
-    , RET <$ L.symbol' space1 "ret"
     , parseDBdirective
     ]
   where
@@ -307,11 +302,10 @@ parseAssembly =
 mainLocal :: Text -> IO (Maybe [Statement])
 mainLocal assemblyCode = do
   case parseAssembly assemblyCode of
-    -- case parseOnly parseLine assemblyCode of
     Left err -> do
       putStrLn "Error: "
       putStrLn $ errorBundlePretty err
       pure Nothing
-    Right instructions -> do
-      traverse_ print instructions
-      pure $ Just instructions
+    Right statements -> do
+      traverse_ print statements
+      pure $ Just statements