From 1a77298f64292866d247550f8696b549eb0aff11 Mon Sep 17 00:00:00 2001 From: Gergo ERDI Date: Thu, 31 Aug 2023 21:13:56 +0800 Subject: [PATCH 1/4] Avoid spurious warning if `Prelude` already re-exports `(<$>)` --- src/Z80/Assembler.hs | 5 +++++ src/Z80/Operations.hs | 3 +++ 2 files changed, 8 insertions(+) diff --git a/src/Z80/Assembler.hs b/src/Z80/Assembler.hs index 8d2e2e9..03db445 100644 --- a/src/Z80/Assembler.hs +++ b/src/Z80/Assembler.hs @@ -1,5 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Z80.Assembler @@ -25,8 +28,10 @@ import Data.ByteString (ByteString) import Control.Monad.RWS import Data.Maybe +#if !MIN_VERSION_base(4,8,0) import Control.Applicative import Data.Traversable (traverse) +#endif import Prelude import Z80.Operands diff --git a/src/Z80/Operations.hs b/src/Z80/Operations.hs index 01542a9..372e281 100644 --- a/src/Z80/Operations.hs +++ b/src/Z80/Operations.hs @@ -3,6 +3,7 @@ {-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Z80.Operations @@ -107,7 +108,9 @@ import Data.Word import Z80.Assembler import Z80.Operands +#if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) +#endif import Control.Monad ((>=>)) import Prelude hiding (and, or) From 6d6faebd03a12d6ae54e186d6b118aefdc1c48c0 Mon Sep 17 00:00:00 2001 From: Gergo ERDI Date: Thu, 31 Aug 2023 21:14:28 +0800 Subject: [PATCH 2/4] GHC 9.4 compatibility --- src/Z80/Operations.hs | 1 + z80.cabal | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Z80/Operations.hs b/src/Z80/Operations.hs index 372e281..4d6af08 100644 --- a/src/Z80/Operations.hs +++ b/src/Z80/Operations.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE UndecidableInstances #-} diff --git a/z80.cabal b/z80.cabal index 7a2b064..2d3a3f5 100644 --- a/z80.cabal +++ b/z80.cabal @@ -19,7 +19,7 @@ library Z80.Operands, Z80.Operands.LowerCase, Z80.Macros - build-depends: base >=4.7 && <4.9, + build-depends: base >=4.7, bytestring, mtl hs-source-dirs: src From 9ff6d5e9e1a24dbd2799211144f1fd49538ce659 Mon Sep 17 00:00:00 2001 From: Gergo ERDI Date: Sun, 3 Sep 2023 17:06:54 +0200 Subject: [PATCH 3/4] `db @[Word8]` should be lazy in the content of the bytes --- src/Z80/Assembler.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Z80/Assembler.hs b/src/Z80/Assembler.hs index 03db445..b135f82 100644 --- a/src/Z80/Assembler.hs +++ b/src/Z80/Assembler.hs @@ -67,7 +67,12 @@ class Bytes a where instance Bytes ByteString where defb = defByteString instance (b ~ Word8) => Bytes [b] where - defb = defByteString . BS.pack + defb bs = Z80 $ do + tell $ BS.pack bs + modify (incrementLoc . fromIntegral $ length bs) + -- The new location has to be computed lazily in the actual + -- content of the bytes, so that we can emit byte values + -- referring to later labels. db :: Bytes a => a -> Z80ASM db = defb From 04e904fcc13ad96e0eb2d8e1ae0d4b2ec912a0b9 Mon Sep 17 00:00:00 2001 From: Gergo ERDI Date: Fri, 8 Sep 2023 12:10:42 +0200 Subject: [PATCH 4/4] Add `resb` to reserve uninitialized bytes. Only really makes sense at the end --- src/Z80/Assembler.hs | 59 +++++++++++++++++++++++++++++--------------- 1 file changed, 39 insertions(+), 20 deletions(-) diff --git a/src/Z80/Assembler.hs b/src/Z80/Assembler.hs index b135f82..f19c61d 100644 --- a/src/Z80/Assembler.hs +++ b/src/Z80/Assembler.hs @@ -13,6 +13,7 @@ module Z80.Assembler , code , Bytes (..) , db + , resb , equ , label , labelled @@ -39,6 +40,7 @@ import Z80.Operands data ASMState = ASMState { loc :: Location + , lastLoc :: Location , entry :: Maybe Location } @@ -53,13 +55,29 @@ data ASMBlock , asmData :: ByteString } deriving (Eq, Show) -incrementLoc :: Location -> ASMState -> ASMState -incrementLoc x st = st { loc = loc st + x } +fillToLoc :: Z80ASM +fillToLoc = Z80 $ do + padding <- gets $ \st -> loc st - lastLoc st + tell $ BS.replicate (fromIntegral padding) 0x00 + +incrementLoc :: Location -> Z80ASM +incrementLoc x = do + fillToLoc + Z80 $ modify $ \st -> let loc' = loc st + x in st{ loc = loc', lastLoc = loc' } + +reserveLoc :: Location -> ASMState -> ASMState +reserveLoc x st = st{ loc = loc st + x } + +tellBytes :: [Word8] -> Z80ASM +tellBytes bytes = do + Z80 $ tell $ BS.pack bytes + incrementLoc . fromIntegral $ length bytes + -- The new location has to be computed lazily in the actual + -- content of the bytes, so that we can emit byte values + -- referring to later labels. code :: [Word8] -> Z80ASM -code bytes = Z80 $ do - tell $ BS.pack bytes - modify (incrementLoc . fromIntegral $ length bytes) +code = tellBytes class Bytes a where defb :: a -> Z80ASM @@ -67,20 +85,19 @@ class Bytes a where instance Bytes ByteString where defb = defByteString instance (b ~ Word8) => Bytes [b] where - defb bs = Z80 $ do - tell $ BS.pack bs - modify (incrementLoc . fromIntegral $ length bs) - -- The new location has to be computed lazily in the actual - -- content of the bytes, so that we can emit byte values - -- referring to later labels. + defb = tellBytes db :: Bytes a => a -> Z80ASM db = defb +resb :: Word16 -> Z80ASM +resb n = Z80 $ do + modify $ reserveLoc n + defByteString :: ByteString -> Z80ASM -defByteString bs = Z80 $ do - tell bs - modify (incrementLoc . fromIntegral $ BS.length bs) +defByteString bs = do + Z80 $ tell bs + incrementLoc . fromIntegral $ BS.length bs label :: Z80 Location label = loc <$> Z80 get @@ -102,16 +119,18 @@ beginExecution :: Z80ASM beginExecution = do l <- label Z80 . modify $ setEntry l - where setEntry l st@(ASMState _ Nothing) = st { entry = Just l } - setEntry l st@(ASMState _ (Just e)) = - error $ "Cannot set execution start point twice. First start point: " ++ show e ++ - " This start point: " ++ show l + where setEntry l st = case entry st of + Nothing -> st{ entry = Just l } + Just e -> + error $ "Cannot set execution start point twice. First start point: " ++ show e ++ + " This start point: " ++ show l org :: Location -> Z80ASM -> ASMBlock org addr (Z80 mc) = ASMBlock { asmOrg = addr, asmEntry = fromMaybe addr $ entry finalState, - asmData = asm } - where ((), finalState, asm) = runRWS mc () (ASMState addr Nothing) + asmData = truncate asm } + where ((), finalState, asm) = runRWS mc () (ASMState addr addr Nothing) + truncate = BS.take (fromIntegral $ lastLoc finalState - addr) equ :: a -> Z80 a equ = return