├── .gitignore ├── Makefile ├── README ├── agame ├── Actors.hs ├── agame.hs ├── background.png └── sprites.png ├── controllertest ├── background.bin ├── controllertest.hs ├── sprites.bin └── sprites.png ├── lib ├── ASM.hs ├── ASM6502.hs ├── Assembler.hs ├── NES.hs └── NES │ ├── ASoundEngine.hs │ ├── Header001.hs │ ├── ImageLoader.hs │ └── Reservations.hs ├── make.pl ├── soundtest └── soundtest.hs └── tool └── MakePl.pm /.gitignore: -------------------------------------------------------------------------------- 1 | *.hi 2 | *.o 3 | *.exe 4 | *.nes 5 | # fceux debug files 6 | *.deb 7 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | build: 3 | ./make.pl build 4 | 5 | .PHONY: clean 6 | 7 | clean: 8 | ./make.pl clean 9 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | 2 | More info coming "soon". 3 | 4 | -------------------------------------------------------------------------------- /agame/Actors.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE RecursiveDo #-} 3 | 4 | module Actors where 5 | 6 | import Assembler 7 | import ASM 8 | import ASM6502 9 | import NES 10 | import NES.Reservations 11 | import Data.Word 12 | import Text.Printf 13 | 14 | data Actors = Actors { 15 | amount :: Word8, 16 | t_models :: Section6502 (), 17 | xs :: Section Word8 (), 18 | ys :: Section Word8 (), 19 | ts :: Section Word8 (), 20 | fs :: Section Word8 (), 21 | camera :: Section Word8 (), 22 | sprites_left :: Section Word8 (), 23 | start_draw' :: ASM6502 (Section6502 ()), 24 | draw_actors' :: ASM6502 (Section6502 ()), 25 | finish_draw' :: ASM6502 (Section6502 ()) 26 | } 27 | 28 | actors' :: Word8 -> Section6502 () -> ASM6502 Actors 29 | actors' amount t_models = do 30 | s <- sect "actors" $ do 31 | fail_assembler_if (size t_models /= fromIntegral amount * 2) 32 | (printf "Second argument given to actors' (t_models) was the wrong size (0x%x /= 0x%x)" 33 | (size t_models) (amount * 2)) 34 | xs <- resz amount 35 | ys <- resz amount 36 | ts <- resz amount 37 | fs <- resz amount 38 | camera <- resz 2 39 | sprites_left <- resz 1 40 | return Actors { 41 | amount = amount, 42 | t_models = t_models, 43 | xs=xs, ys=ys, ts=ts, fs=fs, camera=camera, 44 | sprites_left=sprites_left, 45 | start_draw' = sect "Actors.start_draw" $ do 46 | ldai 0x40 47 | sta sprites_left 48 | ldai 0x00 49 | sta NES.oamaddr 50 | , 51 | draw_actors' = sect "Actors.draw_actors" $ do 52 | let modelp = 0x00 53 | model_size = 0x02 54 | repfor (ldxi 0) (inx >> cpxi amount >>. bne) $ do 55 | ldax ts 56 | asla 57 | tay 58 | lday t_models 59 | sta modelp 60 | lday (t_models + 1) 61 | sta (modelp + 1) 62 | ldyi 0x00 63 | ldayp modelp 64 | sta model_size 65 | iny 66 | rep (cpy model_size >>. bcc) $ do 67 | ldayp modelp 68 | clc >> adcx ys 69 | sub (camera + 0) 70 | sta NES.oamdata 71 | iny 72 | ldayp modelp 73 | sta NES.oamdata 74 | iny 75 | ldayp modelp 76 | andx fs 77 | sta NES.oamdata 78 | iny 79 | ldayp modelp 80 | clc >> adcx xs 81 | sub (camera + 1) 82 | sta NES.oamdata 83 | iny 84 | dec sprites_left 85 | , 86 | finish_draw' = sect "Actors.finish_draw" $ mdo 87 | ldx sprites_left 88 | beq ギリギリ 89 | lda 0xfe 90 | rep (dex >>. bne) $ do 91 | sta NES.oamdata 92 | sta NES.oamdata 93 | sta NES.oamdata 94 | sta NES.oamdata 95 | ギリギリ <- here 96 | nothing 97 | } 98 | return (section_return s) 99 | 100 | 101 | -------------------------------------------------------------------------------- /agame/agame.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE RecursiveDo #-} 3 | 4 | import Assembler 5 | import ASM 6 | import ASM6502 7 | import NES 8 | import NES.ImageLoader 9 | import NES.Reservations 10 | import NES.Header001 11 | import qualified Data.ByteString as B 12 | import qualified Actors as A 13 | import Data.Bits 14 | 15 | main = do 16 | -- 1 PRG, 1 CHR, mapper 1, has sram 17 | B.putStr $ NES.header 0x01 0x01 0x01 0x02 18 | B.putStr $ asm_result prgbank 19 | sprites <- file_to_chr greyscale_palette "agame/sprites.png" 20 | B.putStr $ sprites 21 | B.putStr $ B.replicate (0x1000 - B.length sprites) 0xff 22 | background <- file_to_chr greyscale_palette "agame/background.png" 23 | B.putStr $ background 24 | B.putStr $ B.replicate (0x1000 - B.length background) 0xff 25 | 26 | 27 | (_, prgbank) = asm 0xc000 $ mdo 28 | actors <- A.actors' 1 actor_models 29 | framecounter <- resz 1 30 | reset <- sect "reset" $ do 31 | NES.initialize' 32 | NES.Header001.reset' 33 | NES.Header001.write' 0x8000 0x03 -- Horizontal mirroring 34 | NES.Header001.writeA0' 0xe000 -- Enable WRAM 35 | -- Load palettes 36 | NES.set_ppuaddr NES.vram_palettes 37 | forinyin palettes $ do 38 | lday palettes 39 | sta NES.ppudata 40 | -- For testing purposes, let's try writing to sram 41 | ldyi 0x00 42 | ldxi 0x00 43 | rep (iny >>. bne) $ do 44 | txa 45 | stay 0x6000 46 | inx 47 | -- Show some tiles 48 | NES.set_ppuaddr (NES.vram_nametable_0 + 36) 49 | ldyi 0x00 >> sty NES.ppudata 50 | iny >> sty NES.ppudata 51 | iny >> sty NES.ppudata 52 | iny >> sty NES.ppudata 53 | NES.set_ppuaddr (NES.vram_nametable_0 + 68) 54 | ldyi 0x00 >> sty NES.ppudata 55 | iny >> sty NES.ppudata 56 | iny >> sty NES.ppudata 57 | iny >> sty NES.ppudata 58 | -- Set all attributes in nametable 0 59 | NES.set_ppuaddr NES.vram_attribute_table_0 60 | ldai 0x50 61 | sta NES.ppudata 62 | sta NES.ppudata 63 | sta NES.ppudata 64 | sta NES.ppudata 65 | sta NES.ppudata 66 | sta NES.ppudata 67 | sta NES.ppudata 68 | sta NES.ppudata 69 | -- Init inital actor 70 | ldai 0x80 71 | sta (A.xs actors) 72 | sta (A.ys actors) 73 | ldai (NES.background_1000_bit .|. NES.enable_nmi_bit) 74 | sta NES.ppuctrl 75 | ldai (NES.enable_background_bit .|. NES.enable_sprites_bit) 76 | sta NES.ppumask 77 | idle <- sect "idle" (jmp idle) 78 | nmi <- sect "nmi" $ do 79 | A.start_draw' actors 80 | A.draw_actors' actors 81 | A.finish_draw' actors 82 | lda NES.ppustatus 83 | ldai 0 84 | sta NES.ppuscroll 85 | sta NES.ppuscroll 86 | inc framecounter 87 | rti 88 | 89 | palettes <- section $ do 90 | hexdata "0f 1d 2d 3d" 91 | hexdata "0f 10 20 30" 92 | hexdata "0f 07 0a 1a" 93 | hexdata "0f 07 0a 1a" 94 | hexdata "0f 1d 2d 3d" 95 | hexdata "0f 1d 2d 3d" 96 | hexdata "0f 1d 2d 3d" 97 | hexdata "0f 1d 2d 3d" 98 | robot_model <- section $ do 99 | byte (size robot_model) 100 | hexdata "00 00 00 00" 101 | hexdata "08 01 00 00" 102 | hexdata "10 02 00 00" 103 | hexdata "00 08 00 08" 104 | hexdata "08 09 00 08" 105 | hexdata "10 0a 00 08" 106 | actor_models <- section $ 107 | le16 robot_model 108 | fillto 0xfffa 0xff 109 | provide NES.nmi $ le16 nmi 110 | provide NES.reset $ le16 reset 111 | provide NES.irq $ le16 0 112 | 113 | -------------------------------------------------------------------------------- /agame/background.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/quietfanatic/neskell/63ebd4316959ab95c8b2a4aea21eb114340a39c0/agame/background.png -------------------------------------------------------------------------------- /agame/sprites.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/quietfanatic/neskell/63ebd4316959ab95c8b2a4aea21eb114340a39c0/agame/sprites.png -------------------------------------------------------------------------------- /controllertest/background.bin: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/quietfanatic/neskell/63ebd4316959ab95c8b2a4aea21eb114340a39c0/controllertest/background.bin -------------------------------------------------------------------------------- /controllertest/controllertest.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE RecursiveDo #-} 3 | 4 | import qualified Data.ByteString as B 5 | import Assembler 6 | import ASM 7 | import ASM6502 8 | import qualified NES 9 | import NES.Reservations 10 | import NES.ImageLoader 11 | import Codec.Picture.Types 12 | import Data.Word 13 | import Data.Bits ((.|.), shiftL) 14 | import Data.Monoid 15 | import Debug.Trace 16 | import Text.Printf 17 | 18 | palette :: PixelRGBA8 -> Int 19 | palette (PixelRGBA8 0 0 0 255) = 0 20 | palette (PixelRGBA8 90 90 90 255) = 1 21 | palette (PixelRGBA8 180 180 180 255) = 2 22 | palette (PixelRGBA8 255 255 255 255) = 3 23 | palette (PixelRGBA8 r g b a) = error $ printf "Unrecognized pixel value: %u %u %u %u" r g b a 24 | 25 | main = do 26 | B.putStr $ NES.header 0x01 0x01 0x00 0x00 27 | B.putStr $ asm_result prgbank 28 | sprites <- file_to_chr palette "controllertest/sprites.png" 29 | B.putStr $ sprites 30 | B.putStr $ B.replicate (0x1000 - B.length sprites) 0xff 31 | background <- B.readFile "controllertest/background.bin" 32 | B.putStr $ background 33 | B.putStr $ B.replicate (0x1000 - B.length background) 0xff 34 | 35 | (_, prgbank) = asm 0xc000 $ mdo 36 | 37 | -- Keeps track of how many sprites have been drawn so far. 38 | -- Only valid during drawing phase. 39 | let sprites_left = 0x0f 40 | -- Vectors are stored in x,y order 41 | let xc = (+ 0x00) 42 | let yc = (+ 0x01) 43 | -- Let's have a ball that's moved by the arrow keys. 44 | -- That's original, right? 45 | ball <- resz 2 46 | camera <- resz 2 47 | screen <- resz 2 48 | save_ppuctrl <- res 1 49 | input2 <- res 1 50 | input1 <- res 1 51 | 52 | char_pos <- resz 2 53 | char_vel <- resz 2 54 | char_flags <- resz 1 55 | let char_flag_ground = 0x01 56 | 57 | -- UTILITY VALUES 58 | 59 | let init_ball' = sect "init_ball" $ mdo 60 | ldai 0x80 61 | sta (xc ball) 62 | sta (yc ball) 63 | 64 | let move_ball' = sect "move_ball" $ mdo 65 | let bump GT = inc 66 | bump LT = dec 67 | unbump GT = dec 68 | unbump LT = inc 69 | branch GT = bcc 70 | branch LT = bcs 71 | move bit coord dir thr flipper = mdo 72 | lda input1 73 | andi bit 74 | skip beq $ do 75 | bump dir (coord ball) 76 | lda (coord ball) 77 | sub (coord camera) 78 | cmpi thr 79 | skip (branch dir) $ do 80 | bump dir (coord camera) 81 | bump dir (coord screen) 82 | flipper 83 | move NES.btn_left xc LT 0x40 $ do 84 | skip (lda (xc screen) >> cmpi 0xff >>. bne) $ do 85 | NES.nametable_x_bit -^>* save_ppuctrl 86 | move NES.btn_right xc GT 0xc1 $ do 87 | skip bne $ do 88 | NES.nametable_x_bit -^>* save_ppuctrl 89 | move NES.btn_up yc LT 0x40 $ do 90 | skip (lda (yc screen) >> cmpi 0xff >>. bne) $ do 91 | 0xef ->* (yc screen) 92 | NES.nametable_y_bit -^>* save_ppuctrl 93 | move NES.btn_down yc GT 0xb1 $ do 94 | skip (lda (yc screen) >> cmpi 0xf0 >>. bne) $ do 95 | 0x00 ->* (yc screen) 96 | NES.nametable_y_bit -^>* save_ppuctrl 97 | 98 | let init_char' = sect "init_char" $ mdo 99 | lda 0x40 100 | sta (xc char_pos) 101 | sta (yc char_pos) 102 | 103 | let move_char' = sect "move_char" $ mdo 104 | let when_press bit act = do 105 | lda input1 106 | andi bit 107 | skip beq act 108 | when_press NES.btn_left $ do 109 | dec (xc char_vel) 110 | when_press NES.btn_right $ do 111 | inc (xc char_vel) 112 | when_press NES.btn_a $ do 113 | -- lda char_flags 114 | -- andi char_flag_ground 115 | -- skip beq $ do 116 | lda 0xf8 117 | sta (yc char_vel) 118 | lda (yc char_vel) 119 | skip (cmpi 0x08 >>. bcc) $ do 120 | inc (yc char_vel) 121 | lda (yc char_vel) 122 | add (yc char_pos) 123 | sta (yc char_pos) 124 | 125 | 126 | -- draw_model : Y = model size in bytes, 00:01 = pointer to model, 02 = xcoord, 03 = ycoord 127 | draw_model <- sect "draw_model_sub" $ do 128 | let modelp = 0x00 129 | offset = 0x02 130 | dey 131 | rep bpl $ do 132 | ldayp modelp 133 | add (yc offset) 134 | sub (yc camera) 135 | sta NES.oamdata 136 | dey 137 | ldayp modelp 138 | sta NES.oamdata 139 | dey 140 | ldayp modelp 141 | sta NES.oamdata 142 | dey 143 | ldayp modelp 144 | add (xc offset) 145 | sub (xc camera) 146 | sta NES.oamdata 147 | dec sprites_left 148 | dey 149 | rts 150 | 151 | 152 | reset <- sect "reset" $ mdo 153 | NES.initialize' 154 | -- Load all the palettes 155 | NES.set_ppuaddr NES.vram_palettes 156 | fordeyin all_palettes $ mdo 157 | lday all_palettes 158 | sta NES.ppudata 159 | -- Draw background 160 | NES.set_ppuaddr NES.vram_nametable_0 161 | -- name table 162 | repfor (ldxi 0x00) (cpxi (size background) >>. bne) $ mdo 163 | let col = 0x00 164 | tmpx = 0x01 165 | -- top row 166 | stx tmpx 167 | repfor (0x10 ->* col) (dec col >>. bne) $ mdo 168 | ldyx background 169 | lday tiles_tl 170 | sta NES.ppudata 171 | lday tiles_tr 172 | sta NES.ppudata 173 | inx 174 | ldx tmpx 175 | -- bottom row 176 | repfor (0x10 ->* col) (dec col >>. bne) $ mdo 177 | ldyx background 178 | lday tiles_bl 179 | sta NES.ppudata 180 | lday tiles_br 181 | sta NES.ppudata 182 | inx 183 | -- attribute table 184 | ldai 0xAA 185 | repfor (ldyi 0x40) (dey >>. bne) $ mdo 186 | sta NES.ppudata 187 | -- enable rendering 188 | save_ppuctrl *<- NES.enable_nmi_bit .|. NES.background_1000_bit 189 | sta NES.ppuctrl 190 | NES.ppumask *<- NES.dont_clip_background_bit .|. NES.dont_clip_sprites_bit 191 | .|. NES.enable_background_bit .|. NES.enable_sprites_bit 192 | 193 | init_ball' 194 | init_char' 195 | -- Done with everything 196 | idle <- here 197 | jmp idle 198 | 199 | nmi <- sect "nmi" $ mdo 200 | NES.read_input_to' input1 201 | -- Start sprite memory transfer 202 | 0x00 ->* NES.oamaddr 203 | 0x40 ->* sprites_left 204 | -- Draw the buttons 205 | let input_tmp = 0x00 206 | input1 *->* input_tmp 207 | repfor (ldxi 0x07) (dex >>. bpl) $ mdo 208 | ldax btnspr_y >> sta NES.oamdata 209 | ldax btnspr_tile >> sta NES.oamdata 210 | ldax btnspr_attr >> mdo 211 | asl input_tmp 212 | skip bcs $ mdo 213 | orai 0x03 214 | sta NES.oamdata 215 | ldax btnspr_x >> sta NES.oamdata 216 | dec sprites_left 217 | -- Draw the ball 218 | move_ball' 219 | low ball_model ->* 0x00 220 | high ball_model ->* 0x01 221 | xc ball *->* 0x02 222 | yc ball *->* 0x03 223 | ldyi (size ball_model) 224 | jsr draw_model 225 | -- Draw the character 226 | move_char' 227 | xc char_pos *->* 0x02 228 | yc char_pos *->* 0x03 229 | ldyi (size ball_model) 230 | jsr draw_model 231 | -- Stow away any unused sprites 232 | ldai 0xfe 233 | rep (dec sprites_left >>. bne) $ mdo 234 | sta NES.oamdata 235 | sta NES.oamdata 236 | sta NES.oamdata 237 | sta NES.oamdata 238 | -- Set the bg scroll 239 | save_ppuctrl *->* NES.ppuctrl 240 | lda NES.ppustatus 241 | (xc screen) *->* NES.ppuscroll 242 | (yc screen) *->* NES.ppuscroll 243 | rti 244 | 245 | data_begin <- here 246 | -- Use allocate and provide to ensure sizes are correct 247 | let [sprite_palettes, background_palettes, ball_model, btnspr_x, btnspr_y, btnspr_tile, btnspr_attr, 248 | tiles_tl, tiles_tr, tiles_bl, tiles_br, background] = allocate16 data_begin 249 | [16, 16, 4 * 4, 8, 8, 8, 8, 7, 7, 7, 7, 0xf0] 250 | all_palettes = section_merge sprite_palettes background_palettes 251 | 252 | provide sprite_palettes $ hexdata $ "" 253 | ++ "22 12 02 0f" 254 | ++ "2a 1a 0a 0f" 255 | ++ "26 16 06 0f" 256 | ++ "30 10 00 0f" 257 | 258 | provide background_palettes $ hexdata $ "" 259 | ++ "22 12 02 0f" 260 | ++ "2a 1a 0a 0f" 261 | ++ "26 16 06 0f" 262 | ++ "30 10 00 0f" 263 | 264 | provide ball_model $ hexdata $ "" 265 | ++ "08 41 06 08" 266 | ++ "08 41 05 00" 267 | ++ "00 01 06 08" 268 | ++ "00 01 05 00" 269 | 270 | provide btnspr_x $ hexdata "d0 bf c8 c8 e0 d8 e8 f0" 271 | provide btnspr_y $ hexdata "d0 d0 d8 c8 d0 d0 d0 d0" 272 | provide btnspr_tile $ hexdata "01 01 00 00 03 03 02 02" 273 | provide btnspr_attr $ hexdata "40 00 80 00 00 00 01 01" 274 | 275 | provide tiles_tl $ hexdata $ 276 | "00 01 02 01 04 06 06" 277 | provide tiles_tr $ hexdata $ 278 | "00 01 01 03 06 05 06" 279 | provide tiles_bl $ hexdata $ 280 | "00 06 04 06 04 06 06" 281 | provide tiles_br $ hexdata $ 282 | "00 06 06 05 06 05 06" 283 | 284 | provide background $ hexdata $ "" 285 | ++ "00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00" 286 | ++ "00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00" 287 | ++ "00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00" 288 | ++ "00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00" 289 | ++ "00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00" 290 | ++ "00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00" 291 | ++ "00 00 00 00 00 00 00 00 00 00 02 01 01 03 00 00" 292 | ++ "00 00 00 00 00 00 00 00 00 00 04 06 06 05 00 00" 293 | ++ "00 00 00 00 00 00 00 00 00 00 04 06 06 05 00 00" 294 | ++ "00 00 00 00 00 00 00 00 00 00 04 06 06 05 00 00" 295 | ++ "00 00 02 01 01 01 03 00 00 00 04 06 06 05 00 00" 296 | ++ "00 00 04 06 06 06 05 00 00 00 04 06 06 05 00 00" 297 | ++ "01 01 01 01 01 01 01 01 01 01 01 01 01 01 01 01" 298 | ++ "06 06 06 06 06 06 06 06 06 06 06 06 06 06 06 06" 299 | ++ "06 06 06 06 06 06 06 06 06 06 06 06 06 06 06 06" 300 | 301 | fillto 0xfffa 0xff 302 | provide NES.nmi $ le16 nmi 303 | provide NES.reset $ le16 reset 304 | provide NES.irq $ le16 0 305 | 306 | -------------------------------------------------------------------------------- /controllertest/sprites.bin: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/quietfanatic/neskell/63ebd4316959ab95c8b2a4aea21eb114340a39c0/controllertest/sprites.bin -------------------------------------------------------------------------------- /controllertest/sprites.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/quietfanatic/neskell/63ebd4316959ab95c8b2a4aea21eb114340a39c0/controllertest/sprites.png -------------------------------------------------------------------------------- /lib/ASM.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE RecursiveDo #-} 3 | 4 | module ASM ( 5 | ASM, ASMblage, asm, asm_result, 6 | byte, bytes, ascii, bytestring, binfile, fill, fillto, pad, hex, hexdata, 7 | le16, be16, le32, be32, le64, be64, lefloat, befloat, ledouble, bedouble, 8 | nothing, here, 9 | no_overflow, 10 | rep, repfor, skip, (>>.), 11 | allocate8, allocate16, allocate32, allocate64 12 | ) where 13 | 14 | import Data.Word 15 | import Data.Bits 16 | import Data.Char 17 | import Data.Monoid 18 | import qualified Data.Sequence as S 19 | import qualified Data.Foldable as F 20 | import qualified Data.ByteString as B 21 | import Text.Printf 22 | import Assembler 23 | import Unsafe.Coerce -- for serializing floats and doubles 24 | import System.IO.Unsafe -- for binfile 25 | 26 | type ASM ctr a = Assembler (S.Seq Word8) ctr a 27 | type ASMblage ctr = Assemblage (S.Seq Word8) ctr 28 | 29 | asm :: Num ctr => ASMblage ctr -> ASM ctr b -> (b, ASMblage ctr) 30 | asm = assemble 31 | 32 | asm_result :: ASMblage ctr -> B.ByteString 33 | asm_result = B.pack . F.toList . assemblage_result 34 | 35 | byte :: (Integral a, Num ctr) => a -> ASM ctr () 36 | byte = unit_assembler . S.singleton . fromIntegral 37 | 38 | bytes :: (Integral a, Num ctr) => F.Foldable t => t a -> ASM ctr () 39 | bytes bs = Assembler f where 40 | f (ann, pos) = (ann, F.foldl (const . (+ 1)) pos bs, S.fromList (map fromIntegral (F.toList bs)), ()) 41 | 42 | ascii :: Num ctr => [Char] -> ASM ctr () 43 | ascii = bytes . map (fromIntegral . ord) 44 | 45 | bytestring :: Num ctr => B.ByteString -> ASM ctr () 46 | bytestring bs = Assembler f where 47 | f (ann, pos) = (ann, pos + fromIntegral (B.length bs), S.fromList (B.unpack bs), ()) 48 | 49 | {-# NOINLINE binfile #-} 50 | binfile :: String -> B.ByteString 51 | binfile = unsafePerformIO . B.readFile 52 | 53 | fill :: Integral ctr => ctr -> Word8 -> ASM ctr () 54 | fill size b = Assembler f where 55 | f (ann, pos) = if size >= 0 56 | then (ann, pos + size, S.replicate (fromIntegral size) b, ()) 57 | else (ann, pos + size, err ann pos, ()) 58 | err ann pos = error$ printf "Tried to fill a block with negative size%s at 0x%x (did something assemble too large?)" 59 | (appendable_section_name ann) (toInteger pos) 60 | 61 | fillto :: Integral ctr => ctr -> Word8 -> ASM ctr () 62 | fillto target b = Assembler f where 63 | f (ann, pos) = let 64 | payload = if target - pos < 0 -- allow target to be 0 on unsigned types for instance 65 | then error$ printf "fillto was called too late%s at 0x%x (did something assemble too large?)" 66 | (appendable_section_name ann) (toInteger pos) 67 | else S.replicate (fromIntegral (target - pos)) b 68 | in (ann, target, payload, ()) 69 | 70 | pad :: Integral ctr => ctr -> Word8 -> ASM ctr a -> ASM ctr a 71 | pad size = pad_assembler size . S.singleton 72 | 73 | hex :: String -> [Word8] 74 | hex [] = [] 75 | hex (c:rest) | not (isHexDigit c) = hex rest 76 | hex (h:l:rest) | isHexDigit l = fromIntegral (digitToInt h * 16 + digitToInt l) : hex rest 77 | hex _ = error "Odd number of hex digits in hexdata string." 78 | 79 | hexdata :: Num ctr => String -> ASM ctr () 80 | hexdata = bytes . hex 81 | 82 | le16 :: (Integral a, Integral ctr) => a -> ASM ctr () 83 | le16 x = Assembler f where 84 | w = fromIntegral x :: Word16 85 | res = S.fromList (map (fromIntegral . shiftR w . (8 *)) [0..1]) 86 | f (ann, pos) = (ann, pos+2, res, ()) 87 | be16 :: (Integral a, Integral ctr) => a -> ASM ctr () 88 | be16 x = Assembler f where 89 | w = fromIntegral x :: Word16 90 | res = S.fromList (map (fromIntegral . shiftR w . (8 *)) (reverse [0..1])) 91 | f (ann, pos) = (ann, pos+2, res, ()) 92 | le32 :: (Integral a, Integral ctr) => a -> ASM ctr () 93 | le32 x = Assembler f where 94 | w = fromIntegral x :: Word32 95 | res = S.fromList (map (fromIntegral . shiftR w . (8 *)) [0..3]) 96 | f (ann, pos) = (ann, pos+4, res, ()) 97 | be32 :: (Integral a, Integral ctr) => a -> ASM ctr () 98 | be32 x = Assembler f where 99 | w = fromIntegral x :: Word32 100 | res = S.fromList (map (fromIntegral . shiftR w . (8 *)) (reverse [0..3])) 101 | f (ann, pos) = (ann, pos+4, res, ()) 102 | le64 :: (Integral a, Integral ctr) => a -> ASM ctr () 103 | le64 x = Assembler f where 104 | w = fromIntegral x :: Word64 105 | res = S.fromList (map (fromIntegral . shiftR w . (8 *)) [0..7]) 106 | f (ann, pos) = (ann, pos+8, res, ()) 107 | be64 :: (Integral a, Integral ctr) => a -> ASM ctr () 108 | be64 x = Assembler f where 109 | w = fromIntegral x :: Word64 110 | res = S.fromList (map (fromIntegral . shiftR w . (8 *)) (reverse [0..7])) 111 | f (ann, pos) = (ann, pos+8, res, ()) 112 | lefloat :: Integral ctr => Float -> ASM ctr () 113 | lefloat = le32 . (unsafeCoerce :: Float -> Word32) 114 | befloat :: Integral ctr => Float -> ASM ctr () 115 | befloat = be32 . (unsafeCoerce :: Float -> Word32) 116 | ledouble :: Integral ctr => Double -> ASM ctr () 117 | ledouble = le32 . (unsafeCoerce :: Double -> Word64) 118 | bedouble :: Integral ctr => Double -> ASM ctr () 119 | bedouble = be32 . (unsafeCoerce :: Double -> Word64) 120 | 121 | no_overflow' :: (Integral a, Integral b) => b -> b -> a -> Maybe b 122 | no_overflow' min max x = if toInteger min <= toInteger x && toInteger x <= toInteger max 123 | then Just (fromIntegral x) 124 | else Nothing 125 | 126 | no_overflow :: (Integral a, Integral b, Bounded b) => a -> Maybe b 127 | no_overflow = no_overflow' minBound maxBound 128 | 129 | rep :: Integral ctr => (ctr -> ASM ctr a) -> ASM ctr b -> ASM ctr b 130 | rep branch code = mdo 131 | start <- here 132 | res <- code 133 | branch start 134 | return res 135 | 136 | repfor :: Integral ctr => ASM ctr a -> (ctr -> ASM ctr b) -> ASM ctr c -> ASM ctr c 137 | repfor init branch code = mdo 138 | init 139 | start <- here 140 | res <- code 141 | branch start 142 | return res 143 | 144 | skip :: Integral ctr => (ctr -> ASM ctr a) -> ASM ctr b -> ASM ctr b 145 | skip branch code = mdo 146 | branch end 147 | res <- code 148 | end <- here 149 | return res 150 | 151 | infixl 1 >>. 152 | cmp >>. branch = (cmp >>) . branch 153 | 154 | allocate8 :: Integral siz => Word8 -> [siz] -> [Section Word8 ()] 155 | allocate8 = allocate 156 | 157 | allocate16 :: Integral siz => Word16 -> [siz] -> [Section Word16 ()] 158 | allocate16 = allocate 159 | 160 | allocate32 :: Integral siz => Word32 -> [siz] -> [Section Word32 ()] 161 | allocate32 = allocate 162 | 163 | allocate64 :: Integral siz => Word64 -> [siz] -> [Section Word64 ()] 164 | allocate64 = allocate 165 | 166 | -------------------------------------------------------------------------------- /lib/ASM6502.hs: -------------------------------------------------------------------------------- 1 | 2 | module ASM6502 where 3 | 4 | import Prelude hiding (and) 5 | import qualified Prelude (and) 6 | import Data.Word 7 | import Data.Int 8 | import qualified Data.Bits as B 9 | import qualified Data.Sequence as S 10 | import Assembler 11 | import ASM 12 | import Text.Printf 13 | 14 | type ASM6502 a = ASM Word16 a 15 | type Section6502 a = Section Word16 a 16 | type ASMblage6502 = ASMblage Word16 17 | 18 | low :: Integral a => a -> Word8 19 | low = fromIntegral 20 | high :: Integral a => a -> Word8 21 | high x = fromIntegral (B.shiftR (fromIntegral x :: Word16) 8) 22 | 23 | op8 :: Integral x => String -> Word8 -> x -> ASM6502 () 24 | op8 name a x = byte a >> Assembler f where 25 | f (ann, pos) = let 26 | res = case no_overflow x :: Maybe Word8 of 27 | Just w8 -> S.singleton w8 28 | Nothing -> error$ printf "Overflow error in argument to %s%s at 0x%x (0x%x > 0xff)" 29 | name (appendable_section_name ann) (toInteger pos) (toInteger x) 30 | in (ann, pos + 1, res, ()) 31 | 32 | op16 :: Integral x => String -> Word8 -> x -> ASM6502 () 33 | op16 name a x = byte a >> Assembler f where 34 | f (ann, pos) = let 35 | res16 = case no_overflow x :: Maybe Word8 of 36 | Just w8 -> fromIntegral w8 37 | Nothing -> case no_overflow x :: Maybe Word16 of 38 | Just w16 -> w16 39 | Nothing -> error$ printf "Overflow error in argument to %s%s at 0x%x (0x%x > 0xffff)" 40 | name (appendable_section_name ann) (toInteger pos) (toInteger x) 41 | res = S.singleton (fromIntegral res16) S.>< S.singleton (fromIntegral (B.shiftR res16 8)) 42 | in (ann, pos + 2, res, ()) 43 | 44 | -- case (size of argument type) of 45 | -- 8bit -> generate op8 46 | -- 16bit -> generate op16 47 | -- other -> generate op8 or op16 depending on argument's value 48 | -- This last case will lead to an infinite loop if the argument 49 | -- depends on the size of the generated op. Fortunately, arguments with 50 | -- that dependency are likely to be ASM labels, which are 16bit words. 51 | op8or16 :: Integral x => String -> Word8 -> Word8 -> x -> ASM6502 () 52 | op8or16 name a b x = case fromIntegral (0x010101 `asTypeOf` x) of 53 | 0x01 -> byte a >> byte (fromIntegral x) 54 | 0x0101 -> byte b >> le16 (fromIntegral x) 55 | _ -> case no_overflow x :: Maybe Word8 of 56 | Just w8 -> byte a >> byte w8 57 | Nothing -> case no_overflow x :: Maybe Word16 of 58 | Just w16 -> byte b >> le16 w16 59 | Nothing -> Assembler f where 60 | f (ann, pos) = error$ printf "Overflow error in argument to %s%s at 0x%x (0x%x > 0xffff)" 61 | name (appendable_section_name ann) (toInteger pos) (toInteger x) 62 | 63 | rel8 :: Integral a => String -> Word8 -> a -> ASM6502 () 64 | rel8 name b x = byte b >> Assembler f where 65 | f (ann, pos) = let 66 | off = fromIntegral x - fromIntegral (pos + 1) 67 | res = case no_overflow off :: Maybe Int8 of 68 | Just i8 -> S.singleton (fromIntegral i8) 69 | Nothing -> fail$ printf "Branch target is too far away in %s%s at 0x%x (0x%x)" 70 | name (appendable_section_name ann) (toInteger pos) (toInteger off) 71 | in (ann, pos + 1, res, ()) 72 | 73 | adci :: Integral a => a -> ASM6502 () 74 | adci = op8 "adci" 0x69 75 | adcz :: Integral a => a -> ASM6502 () 76 | adcz = op8 "adcz" 0x65 77 | adcm :: Integral a => a -> ASM6502 () 78 | adcm = op16 "adcm" 0x6d 79 | adc :: Integral a => a -> ASM6502 () 80 | adc = op8or16 "adc" 0x65 0x6d 81 | adcxz :: Integral a => a -> ASM6502 () 82 | adcxz = op8 "adcxz" 0x75 83 | adcxm :: Integral a => a -> ASM6502 () 84 | adcxm = op16 "adcxm" 0x7d 85 | adcx :: Integral a => a -> ASM6502 () 86 | adcx = op8or16 "adcx" 0x75 0x7d 87 | adcy :: Integral a => a -> ASM6502 () 88 | adcy = op16 "adcy" 0x79 89 | adcxp :: Integral a => a -> ASM6502 () 90 | adcxp = op8 "adcxp" 0x61 91 | adcpy :: Integral a => a -> ASM6502 () 92 | adcpy = op8 "adcpy" 0x71 93 | 94 | andi :: Integral a => a -> ASM6502 () 95 | andi = op8 "andi" 0x29 96 | andz :: Integral a => a -> ASM6502 () 97 | andz = op8 "andz" 0x25 98 | andm :: Integral a => a -> ASM6502 () 99 | andm = op16 "andm" 0x2d 100 | and :: Integral a => a -> ASM6502 () 101 | and = op8or16 "and" 0x25 0x2d 102 | andxz :: Integral a => a -> ASM6502 () 103 | andxz = op8 "andxz" 0x35 104 | andxm :: Integral a => a -> ASM6502 () 105 | andxm = op16 "andxm" 0x3d 106 | andx :: Integral a => a -> ASM6502 () 107 | andx = op8or16 "andx" 0x35 0x3d 108 | andy :: Integral a => a -> ASM6502 () 109 | andy = op16 "andy" 0x39 110 | andpx :: Integral a => a -> ASM6502 () 111 | andpx = op8 "andpx" 0x21 112 | andyp :: Integral a => a -> ASM6502 () 113 | andyp = op8 "andyp" 0x31 114 | 115 | asla :: ASM6502 () 116 | asla = byte 0x0a 117 | aslz :: Integral a => a -> ASM6502 () 118 | aslz = op8 "aslz" 0x06 119 | aslm :: Integral a => a -> ASM6502 () 120 | aslm = op16 "aslm" 0x0e 121 | asl :: Integral a => a -> ASM6502 () 122 | asl = op8or16 "asl" 0x06 0x0e 123 | aslxz :: Integral a => a -> ASM6502 () 124 | aslxz = op8 "aslxz" 0x16 125 | aslxm :: Integral a => a -> ASM6502 () 126 | aslxm = op16 "aslxm" 0x1e 127 | aslx :: Integral a => a -> ASM6502 () 128 | aslx = op8or16 "aslx" 0x16 0x1e 129 | 130 | bcc :: Integral a => a -> ASM6502 () 131 | bcc = rel8 "bcc" 0x90 132 | 133 | bcs :: Integral a => a -> ASM6502 () 134 | bcs = rel8 "bcs" 0xb0 135 | 136 | beq :: Integral a => a -> ASM6502 () 137 | beq = rel8 "beq" 0xf0 138 | 139 | bitz :: Integral a => a -> ASM6502 () 140 | bitz = op8 "bitz" 0x24 141 | bitm :: Integral a => a -> ASM6502 () 142 | bitm = op16 "bitm" 0x2c 143 | bit :: Integral a => a -> ASM6502 () 144 | bit = op8or16 "bit" 0x24 0x2c 145 | 146 | bmi :: Integral a => a -> ASM6502 () 147 | bmi = rel8 "bmi" 0x30 148 | 149 | bne :: Integral a => a -> ASM6502 () 150 | bne = rel8 "bne" 0xd0 151 | 152 | bpl :: Integral a => a -> ASM6502 () 153 | bpl = rel8 "bpl" 0x10 154 | 155 | brk :: ASM6502 () 156 | brk = byte 0x00 157 | 158 | bvc :: Integral a => a -> ASM6502 () 159 | bvc = rel8 "bvc" 0x50 160 | 161 | bvs :: Integral a => a -> ASM6502 () 162 | bvs = rel8 "bvs" 0x70 163 | 164 | clc :: ASM6502 () 165 | clc = byte 0x18 166 | 167 | cld :: ASM6502 () 168 | cld = byte 0xd8 169 | 170 | cli :: ASM6502 () 171 | cli = byte 0x58 172 | 173 | clv :: ASM6502 () 174 | clv = byte 0xb8 175 | 176 | cmpi :: Integral a => a -> ASM6502 () 177 | cmpi = op8 "cmpi" 0xc9 178 | 179 | cmpz :: Integral a => a -> ASM6502 () 180 | cmpz = op8 "cmpz" 0xc5 181 | cmpm :: Integral a => a -> ASM6502 () 182 | cmpm = op16 "cmpm" 0xcd 183 | cmp :: Integral a => a -> ASM6502 () 184 | cmp = op8or16 "cmp" 0xc5 0xcd 185 | cmpxz :: Integral a => a -> ASM6502 () 186 | cmpxz = op8 "cmpxz" 0xd5 187 | cmpxm :: Integral a => a -> ASM6502 () 188 | cmpxm = op16 "cmpxm" 0xdd 189 | cmpx :: Integral a => a -> ASM6502 () 190 | cmpx = op8or16 "cmpx" 0xd5 0xdd 191 | cmpy :: Integral a => a -> ASM6502 () 192 | cmpy = op16 "cmpy" 0xd9 193 | cmppx :: Integral a => a -> ASM6502 () 194 | cmppx = op8 "cmppx" 0xc1 195 | cmpyp :: Integral a => a -> ASM6502 () 196 | cmpyp = op8 "cmpyp" 0xd1 197 | 198 | cpxi :: Integral a => a -> ASM6502 () 199 | cpxi = op8 "cpxi" 0xe0 200 | cpxz :: Integral a => a -> ASM6502 () 201 | cpxz = op8 "cpxz" 0xe4 202 | cpxm :: Integral a => a -> ASM6502 () 203 | cpxm = op16 "cpxm" 0xec 204 | cpx :: Integral a => a -> ASM6502 () 205 | cpx = op8or16 "cpx" 0xe4 0xec 206 | 207 | cpyi :: Integral a => a -> ASM6502 () 208 | cpyi = op8 "cpyi" 0xc0 209 | cpyz :: Integral a => a -> ASM6502 () 210 | cpyz = op8 "cpyz" 0xc4 211 | cpym :: Integral a => a -> ASM6502 () 212 | cpym = op16 "cpym" 0xcc 213 | cpy :: Integral a => a -> ASM6502 () 214 | cpy = op8or16 "cpy" 0xc4 0xcc 215 | 216 | decz :: Integral a => a -> ASM6502 () 217 | decz = op8 "decz" 0xc6 218 | decm :: Integral a => a -> ASM6502 () 219 | decm = op16 "decm" 0xce 220 | dec :: Integral a => a -> ASM6502 () 221 | dec = op8or16 "dec" 0xc6 0xce 222 | decxz :: Integral a => a -> ASM6502 () 223 | decxz = op8 "decxz" 0xd6 224 | decxm :: Integral a => a -> ASM6502 () 225 | decxm = op16 "decxm" 0xde 226 | decx :: Integral a => a -> ASM6502 () 227 | decx = op8or16 "decx" 0xd6 0xde 228 | 229 | dex :: ASM6502 () 230 | dex = byte 0xca 231 | 232 | dey :: ASM6502 () 233 | dey = byte 0x88 234 | 235 | eori :: Integral a => a -> ASM6502 () 236 | eori = op8 "eori" 0x49 237 | eorz :: Integral a => a -> ASM6502 () 238 | eorz = op8 "eorz" 0x45 239 | eorm :: Integral a => a -> ASM6502 () 240 | eorm = op16 "eorm" 0x4d 241 | eor :: Integral a => a -> ASM6502 () 242 | eor = op8or16 "eor" 0x45 0x4d 243 | eorxz :: Integral a => a -> ASM6502 () 244 | eorxz = op8 "eorxz" 0x55 245 | eorxm :: Integral a => a -> ASM6502 () 246 | eorxm = op16 "eorxm" 0x5d 247 | eorx :: Integral a => a -> ASM6502 () 248 | eorx = op8or16 "eorx" 0x55 0x5d 249 | eory :: Integral a => a -> ASM6502 () 250 | eory = op16 "eory" 0x59 251 | eorpx :: Integral a => a -> ASM6502 () 252 | eorpx = op8 "eorpx" 0x41 253 | eoryp :: Integral a => a -> ASM6502 () 254 | eoryp = op8 "eoryp" 0x51 255 | 256 | incz :: Integral a => a -> ASM6502 () 257 | incz = op8 "incz" 0xe6 258 | incm :: Integral a => a -> ASM6502 () 259 | incm = op16 "incm" 0xee 260 | inc :: Integral a => a -> ASM6502 () 261 | inc = op8or16 "inc" 0xe6 0xee 262 | incxz :: Integral a => a -> ASM6502 () 263 | incxz = op8 "incxz" 0xf6 264 | incxm :: Integral a => a -> ASM6502 () 265 | incxm = op16 "incxm" 0xfe 266 | incx :: Integral a => a -> ASM6502 () 267 | incx = op8or16 "incx" 0xf6 0xfe 268 | 269 | inx :: ASM6502 () 270 | inx = byte 0xe8 271 | 272 | iny :: ASM6502 () 273 | iny = byte 0xc8 274 | 275 | jmp :: Integral a => a -> ASM6502 () 276 | jmp = op16 "jmp" 0x4c 277 | 278 | jmpp :: Integral a => a -> ASM6502 () 279 | jmpp = op16 "jmpp" 0x6c 280 | 281 | jsr :: Integral a => a -> ASM6502 () 282 | jsr = op16 "jsr" 0x20 283 | 284 | ldai :: Integral a => a -> ASM6502 () 285 | ldai = op8 "ldai" 0xa9 286 | ldaz :: Integral a => a -> ASM6502 () 287 | ldaz = op8 "ldaz" 0xa5 288 | ldam :: Integral a => a -> ASM6502 () 289 | ldam = op16 "ldam" 0xad 290 | lda :: Integral a => a -> ASM6502 () 291 | lda = op8or16 "lda" 0xa5 0xad 292 | ldaxz :: Integral a => a -> ASM6502 () 293 | ldaxz = op8 "ldaxz" 0xb5 294 | ldaxm :: Integral a => a -> ASM6502 () 295 | ldaxm = op16 "ldaxm" 0xbd 296 | ldax :: Integral a => a -> ASM6502 () 297 | ldax = op8or16 "ldax" 0xb5 0xbd 298 | lday :: Integral a => a -> ASM6502 () 299 | lday = op16 "lday" 0xb9 300 | ldapx :: Integral a => a -> ASM6502 () 301 | ldapx = op8 "ldapx" 0xa1 302 | ldayp :: Integral a => a -> ASM6502 () 303 | ldayp = op8 "ldayp" 0xb1 304 | 305 | ldxi :: Integral a => a -> ASM6502 () 306 | ldxi = op8 "ldxi" 0xa2 307 | ldxz :: Integral a => a -> ASM6502 () 308 | ldxz = op8 "ldxz" 0xa6 309 | ldxm :: Integral a => a -> ASM6502 () 310 | ldxm = op16 "ldxm" 0xae 311 | ldx :: Integral a => a -> ASM6502 () 312 | ldx = op8or16 "ldx" 0xa6 0xae 313 | ldxyz :: Integral a => a -> ASM6502 () 314 | ldxyz = op8 "ldxyz" 0xb6 315 | ldxym :: Integral a => a -> ASM6502 () 316 | ldxym = op16 "ldxym" 0xbe 317 | ldxy :: Integral a => a -> ASM6502 () 318 | ldxy = op8or16 "ldxy" 0xb6 0xbe 319 | 320 | ldyi :: Integral a => a -> ASM6502 () 321 | ldyi = op8 "ldyi" 0xa0 322 | ldyz :: Integral a => a -> ASM6502 () 323 | ldyz = op8 "ldyz" 0xa4 324 | ldym :: Integral a => a -> ASM6502 () 325 | ldym = op16 "ldym" 0xac 326 | ldy :: Integral a => a -> ASM6502 () 327 | ldy = op8or16 "ldy" 0xa4 0xac 328 | ldyxz :: Integral a => a -> ASM6502 () 329 | ldyxz = op8 "ldyxz" 0xb4 330 | ldyxm :: Integral a => a -> ASM6502 () 331 | ldyxm = op16 "ldyxm" 0xbc 332 | ldyx :: Integral a => a -> ASM6502 () 333 | ldyx = op8or16 "ldyx" 0xb4 0xbc 334 | 335 | lsra :: ASM6502 () 336 | lsra = byte 0x4a 337 | lsrz :: Integral a => a -> ASM6502 () 338 | lsrz = op8 "lsrz" 0x46 339 | lsrm :: Integral a => a -> ASM6502 () 340 | lsrm = op16 "lsrm" 0x4e 341 | lsr :: Integral a => a -> ASM6502 () 342 | lsr = op8or16 "lsr" 0x46 0x4e 343 | lsrxz :: Integral a => a -> ASM6502 () 344 | lsrxz = op8 "lsrxz" 0x56 345 | lsrxm :: Integral a => a -> ASM6502 () 346 | lsrxm = op16 "lsrxm" 0x5e 347 | lsrx :: Integral a => a -> ASM6502 () 348 | lsrx = op8or16 "lsrx" 0x56 0x5e 349 | 350 | nop :: ASM6502 () 351 | nop = byte 0xea 352 | 353 | orai :: Integral a => a -> ASM6502 () 354 | orai = op8 "orai" 0x09 355 | oraz :: Integral a => a -> ASM6502 () 356 | oraz = op8 "oraz" 0x05 357 | oram :: Integral a => a -> ASM6502 () 358 | oram = op16 "oram" 0x0d 359 | ora :: Integral a => a -> ASM6502 () 360 | ora = op8or16 "ora" 0x05 0x0d 361 | oraxz :: Integral a => a -> ASM6502 () 362 | oraxz = op8 "oraxz" 0x15 363 | oraxm :: Integral a => a -> ASM6502 () 364 | oraxm = op16 "oraxm" 0x1d 365 | orax :: Integral a => a -> ASM6502 () 366 | orax = op8or16 "orax" 0x15 0x1d 367 | oray :: Integral a => a -> ASM6502 () 368 | oray = op16 "oray" 0x19 369 | orapx :: Integral a => a -> ASM6502 () 370 | orapx = op8 "orapx" 0x01 371 | orayp :: Integral a => a -> ASM6502 () 372 | orayp = op8 "orayp" 0x11 373 | 374 | pha :: ASM6502 () 375 | pha = byte 0x48 376 | 377 | php :: ASM6502 () 378 | php = byte 0x08 379 | 380 | pla :: ASM6502 () 381 | pla = byte 0x68 382 | 383 | plp :: ASM6502 () 384 | plp = byte 0x28 385 | 386 | rola :: ASM6502 () 387 | rola = byte 0x2a 388 | rolz :: Integral a => a -> ASM6502 () 389 | rolz = op8 "rolz" 0x26 390 | rolm :: Integral a => a -> ASM6502 () 391 | rolm = op16 "rolm" 0x2e 392 | rol :: Integral a => a -> ASM6502 () 393 | rol = op8or16 "rol" 0x26 0x2e 394 | rolxz :: Integral a => a -> ASM6502 () 395 | rolxz = op8 "rolxz" 0x36 396 | rolxm :: Integral a => a -> ASM6502 () 397 | rolxm = op16 "rolxm" 0x3e 398 | rolx :: Integral a => a -> ASM6502 () 399 | rolx = op8or16 "rolx" 0x36 0x3e 400 | 401 | rora :: ASM6502 () 402 | rora = byte 0x6a 403 | rorz :: Integral a => a -> ASM6502 () 404 | rorz = op8 "rorz" 0x66 405 | rorm :: Integral a => a -> ASM6502 () 406 | rorm = op16 "rorm" 0x6e 407 | ror :: Integral a => a -> ASM6502 () 408 | ror = op8or16 "ror" 0x66 0x6e 409 | rorxz :: Integral a => a -> ASM6502 () 410 | rorxz = op8 "rorxz" 0x76 411 | rorxm :: Integral a => a -> ASM6502 () 412 | rorxm = op16 "rorxm" 0x7e 413 | rorx :: Integral a => a -> ASM6502 () 414 | rorx = op8or16 "rorx" 0x76 0x7e 415 | 416 | rti :: ASM6502 () 417 | rti = byte 0x40 418 | 419 | rts :: ASM6502 () 420 | rts = byte 0x60 421 | 422 | sbci :: Integral a => a -> ASM6502 () 423 | sbci = op8 "sbci" 0xe9 424 | sbcz :: Integral a => a -> ASM6502 () 425 | sbcz = op8 "sbcz" 0xe5 426 | sbcm :: Integral a => a -> ASM6502 () 427 | sbcm = op16 "sbcm" 0xed 428 | sbc :: Integral a => a -> ASM6502 () 429 | sbc = op8or16 "sbc" 0xe5 0xed 430 | sbcxz :: Integral a => a -> ASM6502 () 431 | sbcxz = op8 "sbcxz" 0xf5 432 | sbcxm :: Integral a => a -> ASM6502 () 433 | sbcxm = op16 "sbcxm" 0xfd 434 | sbcx :: Integral a => a -> ASM6502 () 435 | sbcx = op8or16 "sbcx" 0xf5 0xfd 436 | sbcy :: Integral a => a -> ASM6502 () 437 | sbcy = op16 "sbcy" 0xf9 438 | sbcpx :: Integral a => a -> ASM6502 () 439 | sbcpx = op8 "sbcpx" 0xe1 440 | sbcyp :: Integral a => a -> ASM6502 () 441 | sbcyp = op8 "sbcyp" 0xf1 442 | 443 | sec :: ASM6502 () 444 | sec = byte 0x38 445 | 446 | sed :: ASM6502 () 447 | sed = byte 0xf8 448 | 449 | sei :: ASM6502 () 450 | sei = byte 0x78 451 | 452 | staz :: Integral a => a -> ASM6502 () 453 | staz = op8 "staz" 0x85 454 | stam :: Integral a => a -> ASM6502 () 455 | stam = op16 "stam" 0x8d 456 | sta :: Integral a => a -> ASM6502 () 457 | sta = op8or16 "sta" 0x85 0x8d 458 | staxz :: Integral a => a -> ASM6502 () 459 | staxz = op8 "staxz" 0x95 460 | staxm :: Integral a => a -> ASM6502 () 461 | staxm = op16 "staxm" 0x9d 462 | stax :: Integral a => a -> ASM6502 () 463 | stax = op8or16 "stax" 0x95 0x9d 464 | stay :: Integral a => a -> ASM6502 () 465 | stay = op16 "stay" 0x99 466 | stapx :: Integral a => a -> ASM6502 () 467 | stapx = op8 "stapx" 0x81 468 | stayp :: Integral a => a -> ASM6502 () 469 | stayp = op8 "stayp" 0x91 470 | 471 | stxz :: Integral a => a -> ASM6502 () 472 | stxz = op8 "stxz" 0x86 473 | stxm :: Integral a => a -> ASM6502 () 474 | stxm = op16 "stxm" 0x8e 475 | stx :: Integral a => a -> ASM6502 () 476 | stx = op8or16 "stx" 0x86 0x8e 477 | stxy :: Integral a => a -> ASM6502 () 478 | stxy = op8 "stxy" 0x8e 479 | 480 | styz :: Integral a => a -> ASM6502 () 481 | styz = op8 "styz" 0x84 482 | stym :: Integral a => a -> ASM6502 () 483 | stym = op16 "stym" 0x8c 484 | sty :: Integral a => a -> ASM6502 () 485 | sty = op8or16 "sty" 0x84 0x8c 486 | styx :: Integral a => a -> ASM6502 () 487 | styx = op8 "styx" 0x94 488 | 489 | tax :: ASM6502 () 490 | tax = byte 0xaa 491 | 492 | tay :: ASM6502 () 493 | tay = byte 0xa8 494 | 495 | tsx :: ASM6502 () 496 | tsx = byte 0xba 497 | 498 | txa :: ASM6502 () 499 | txa = byte 0x8a 500 | 501 | txs :: ASM6502 () 502 | txs = byte 0x9a 503 | 504 | tya :: ASM6502 () 505 | tya = byte 0x98 506 | 507 | -- Nice shortcuts 508 | 509 | addi x = clc >> adci x 510 | addz x = clc >> adcz x 511 | addm x = clc >> adcm x 512 | add x = clc >> adc x 513 | 514 | subi x = sec >> sbci x 515 | subz x = sec >> sbcz x 516 | subm x = sec >> sbcm x 517 | sub x = sec >> sbc x 518 | 519 | forinxin res = repfor (ldxi 0x00) (inx >> cpxi (size res) >>. bne) 520 | forinyin res = repfor (ldyi 0x00) (iny >> cpyi (size res) >>. bne) 521 | -- NOTE: These can only work for resources of size <= 0x80 522 | fordexin res = repfor (ldxi (size res - 1)) (dex >>. bpl) 523 | fordeyin res = repfor (ldyi (size res - 1)) (dey >>. bpl) 524 | 525 | infix 2 ->* 526 | infix 2 -&>* 527 | infix 2 -|>* 528 | infix 2 -^>* 529 | infix 2 -+>* 530 | infix 2 -->* 531 | infix 2 *<- 532 | infix 2 *<&- 533 | infix 2 *<|- 534 | infix 2 *<^- 535 | infix 2 *<+- 536 | infix 2 *<-- 537 | infix 2 *->* 538 | infix 2 *-&>* 539 | infix 2 *-|>* 540 | infix 2 *-^>* 541 | infix 2 *-+>* 542 | infix 2 *-->* 543 | infix 2 *<-* 544 | infix 2 *<&-* 545 | infix 2 *<|-* 546 | infix 2 *<^-* 547 | infix 2 *<+-* 548 | infix 2 *<--* 549 | 550 | (->*) :: Integral a => Word8 -> a -> ASM6502 () 551 | val ->* mem = ldai val >> sta mem 552 | (-&>*) :: Integral a => Word8 -> a -> ASM6502 () 553 | val -&>* mem = lda mem >> andi val >> sta mem 554 | (-|>*) :: Integral a => Word8 -> a -> ASM6502 () 555 | val -|>* mem = lda mem >> orai val >> sta mem 556 | (-^>*) :: Integral a => Word8 -> a -> ASM6502 () 557 | val -^>* mem = lda mem >> eori val >> sta mem 558 | (-+>*) :: Integral a => Word8 -> a -> ASM6502 () 559 | val -+>* mem = lda mem >> addi val >> sta mem 560 | (-->*) :: Integral a => Word8 -> a -> ASM6502 () 561 | val -->* mem = lda mem >> subi val >> sta mem 562 | 563 | (*<-) :: Integral a => a -> Word8 -> ASM6502 () 564 | (*<-) = flip (->*) 565 | (*<&-) :: Integral a => a -> Word8 -> ASM6502 () 566 | (*<&-) = flip (-&>*) 567 | (*<|-) :: Integral a => a -> Word8 -> ASM6502 () 568 | (*<|-) = flip (-|>*) 569 | (*<^-) :: Integral a => a -> Word8 -> ASM6502 () 570 | (*<^-) = flip (-^>*) 571 | (*<+-) :: Integral a => a -> Word8 -> ASM6502 () 572 | (*<+-) = flip (-+>*) 573 | (*<--) :: Integral a => a -> Word8 -> ASM6502 () 574 | (*<--) = flip (-->*) 575 | 576 | (*->*) :: (Integral a, Integral b) => a -> b -> ASM6502 () 577 | from *->* to = lda from >> sta to 578 | (*-&>*) :: (Integral a, Integral b) => a -> b -> ASM6502 () 579 | from *-&>* to = lda to >> and from >> sta to 580 | (*-|>*) :: (Integral a, Integral b) => a -> b -> ASM6502 () 581 | from *-|>* to = lda to >> ora from >> sta to 582 | (*-^>*) :: (Integral a, Integral b) => a -> b -> ASM6502 () 583 | from *-^>* to = lda to >> eor from >> sta to 584 | (*-+>*) :: (Integral a, Integral b) => a -> b -> ASM6502 () 585 | from *-+>* to = lda to >> add from >> sta to 586 | (*-->*) :: (Integral a, Integral b) => a -> b -> ASM6502 () 587 | from *-->* to = lda to >> sub from >> sta to 588 | 589 | (*<-*) :: (Integral a, Integral b) => b -> a -> ASM6502 () 590 | (*<-*) = flip (*->*) 591 | (*<&-*) :: (Integral a, Integral b) => b -> a -> ASM6502 () 592 | (*<&-*) = flip (*-&>*) 593 | (*<|-*) :: (Integral a, Integral b) => b -> a -> ASM6502 () 594 | (*<|-*) = flip (*-|>*) 595 | (*<^-*) :: (Integral a, Integral b) => b -> a -> ASM6502 () 596 | (*<^-*) = flip (*-^>*) 597 | (*<+-*) :: (Integral a, Integral b) => b -> a -> ASM6502 () 598 | (*<+-*) = flip (*-+>*) 599 | (*<--*) :: (Integral a, Integral b) => b -> a -> ASM6502 () 600 | (*<--*) = flip (*-->*) 601 | 602 | 603 | -------------------------------------------------------------------------------- /lib/Assembler.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE DeriveDataTypeable, RecursiveDo, EmptyDataDecls #-} 3 | 4 | module Assembler ( 5 | Assemblage, assemblage_annotations, assemblage_start, assemblage_end, assemblage_result, 6 | Assembler(..), assembler_function, assemble, 7 | nothing, here, unit_assembler, return_assembler, 8 | fail_assembler, fail_assembler_if, generate_fail_message, 9 | append_assembler, bind_assembler, fix_assembler, pad_assembler, 10 | enforce_counter, trace_counter, enforce_size, 11 | Annotations, annotations_get, get_all_annotations, 12 | get_annotation, get_annotation_typed, get_annotation_maybe, get_annotation_maybe_typed, get_annotation_default, 13 | set_annotation, clear_annotation, set_annotation_maybe, 14 | modify_annotation, modify_annotation_default, with_annotation, 15 | Section(..), section_annotations, section_name, section_start, section_size, section_end, section_return, 16 | start, size, end, 17 | section, sect, allocate, allocate_named, allocate1, allocate1_named, provide, 18 | section_merge, appendable_section_name, get_section, current_section 19 | ) where 20 | 21 | import Data.Int 22 | import Data.Word 23 | import Data.Monoid 24 | import Data.Typeable 25 | import Unsafe.Coerce 26 | import Data.Maybe 27 | import qualified Data.Map as M 28 | import qualified Data.Foldable as F 29 | import Control.Monad.Fix 30 | import Text.Printf 31 | import Debug.Trace 32 | 33 | -- ASSEMBLAGES 34 | data Assemblage mon ctr = Assemblage Annotations ctr ctr mon 35 | assemblage_annotations (Assemblage x _ _ _) = x 36 | assemblage_start (Assemblage _ x _ _) = x 37 | assemblage_end (Assemblage _ _ x _) = x 38 | assemblage_result (Assemblage _ _ _ x) = x 39 | 40 | -- This is so you can say "assemble 0 $ do ..." 41 | instance (Monoid mon, Num ctr) => Num (Assemblage mon ctr) where 42 | a + b = Assemblage M.empty (assemblage_start a + assemblage_start b) (assemblage_start a + assemblage_start b) mempty 43 | a - b = Assemblage M.empty (assemblage_start a - assemblage_start b) (assemblage_start a - assemblage_start b) mempty 44 | a * b = Assemblage M.empty (assemblage_start a * assemblage_start b) (assemblage_start a * assemblage_start b) mempty 45 | abs = error$ "Cannot take the abs of an Assemblage." 46 | signum = error$ "Cannot take the signum of an Assemblage." 47 | fromInteger x = Assemblage M.empty (fromInteger x) (fromInteger x) mempty 48 | 49 | -- ASSEMBLERS 50 | newtype Assembler mon ctr a = Assembler ((Annotations, ctr) -> (Annotations, ctr, mon, a)) 51 | assembler_function (Assembler f) = f 52 | 53 | -- Run an assembler and give its return value and an Assemblage 54 | assemble :: (Monoid mon, Num ctr) => Assemblage mon ctr -> Assembler mon ctr a -> (a, Assemblage mon ctr) 55 | assemble prev (Assembler f) = let 56 | (ann, re, rp, rr) = f (M.empty, assemblage_end prev) 57 | in (rr, Assemblage ann (assemblage_start prev) re (assemblage_result prev <> rp)) 58 | 59 | -- An assembler that does nothing, more useful than you'd think. 60 | nothing :: (Monoid mon, Num ctr) => Assembler mon ctr () 61 | nothing = Assembler $ \(ann, pos) -> (ann, pos, mempty, ()) 62 | 63 | -- Returns the current counter. Use this to declare labels. 64 | here :: Monoid mon => Assembler mon ctr ctr 65 | here = Assembler $ \(ann, pos) -> (ann, pos, mempty, pos) 66 | 67 | -- One of whatever mon is. 68 | unit_assembler :: Num ctr => mon -> Assembler mon ctr () 69 | unit_assembler x = Assembler $ \(ann, pos) -> (ann, pos + 1, x, ()) 70 | 71 | return_assembler :: Monoid mon => a -> Assembler mon ctr a 72 | return_assembler x = Assembler $ \(ann, pos) -> (ann, pos, mempty, x) 73 | 74 | fail_assembler :: Integral ctr => String -> Assembler mon ctr a 75 | fail_assembler mess = Assembler $ \(ann, pos) -> let 76 | err = error$ printf "%s%s at 0x%x" mess (appendable_section_name ann) (toInteger pos) 77 | in (ann, pos, err, err) 78 | 79 | -- This is for being as lazy as possible 80 | fail_assembler_if :: (Monoid mon, Integral ctr) => Bool -> String -> Assembler mon ctr () 81 | fail_assembler_if cond mess = Assembler $ \(ann, pos) -> let 82 | err = error$ printf "%s%s at 0x%x" mess (appendable_section_name ann) (toInteger pos) 83 | in (ann, pos, if cond then err else mempty, ()) 84 | 85 | -- If you need to put the fail message somewhere else 86 | generate_fail_message :: (Monoid mon, Integral ctr) => String -> Assembler mon ctr String 87 | generate_fail_message mess = Assembler $ \(ann, pos) -> let 88 | message = printf "%s%s at 0x%x" mess (appendable_section_name ann) (toInteger pos) 89 | in (ann, pos, mempty, message) 90 | 91 | -- (>>) 92 | append_assembler :: Monoid mon => Assembler mon ctr a -> Assembler mon ctr b -> Assembler mon ctr b 93 | append_assembler (Assembler left) (Assembler right) = 94 | Assembler $ \(ann1, pos) -> let 95 | (ann2, le, lp, lr) = left (ann1, pos) 96 | (ann3, re, rp, rr) = right (ann2, le) 97 | in (ann3, re, lp <> rp, rr) 98 | 99 | -- (>>=) 100 | bind_assembler :: Monoid mon => Assembler mon ctr a -> (a -> Assembler mon ctr b) -> Assembler mon ctr b 101 | bind_assembler (Assembler left) rightf = Assembler f where 102 | f (ann1, pos) = let 103 | (ann2, le, lp, lr) = left (ann1, pos) 104 | (ann3, re, rp, rr) = assembler_function (rightf lr) (ann2, le) 105 | in (ann3, re, lp <> rp, rr) 106 | 107 | -- mfix 108 | fix_assembler :: (a -> Assembler mon ctr a) -> Assembler mon ctr a 109 | fix_assembler f = Assembler $ \(ann1, pos) -> let 110 | (ann2, end, pay, ret) = assembler_function (f ret) (ann1, pos) 111 | in (ann2, end, pay, ret) 112 | 113 | -- Force an section to be a certain size by padding it up. This can break infinite dependency loops. 114 | pad_assembler :: (Monoid mon, Integral ctr) => ctr -> mon -> Assembler mon ctr a -> Assembler mon ctr a 115 | pad_assembler size filling (Assembler inner) = Assembler $ \(ann1, pos) -> let 116 | (ann2, ie, ip, ir) = inner (ann1, pos) 117 | payload = if ie > pos + size 118 | then error$ printf "Code given to pad_assembler was larger than the alloted size%s (0x%x - 0x%x > 0x%x)" 119 | (appendable_section_name ann2) (toInteger ie) (toInteger pos) (toInteger size) 120 | else ip <> F.fold (replicate (fromIntegral (pos + size - ie)) filling) 121 | in (ann2, pos + size, payload, ir) 122 | 123 | -- Make sure the counter is at a certain spot. Used in, for instance, provide 124 | enforce_counter :: (Monoid mon, Integral ctr) => ctr -> String -> Assembler mon ctr () 125 | enforce_counter expected name = Assembler $ \(ann, got) -> let 126 | errmess = if null name 127 | then printf "enforce_counter encountered an incorrect counter (0x%x /= 0x%x)%s" 128 | (toInteger got) (toInteger expected) (appendable_section_name ann) 129 | else printf "%s is in the wrong place (0x%x /= 0x%x)%s" 130 | name (toInteger got) (toInteger expected) (appendable_section_name ann) 131 | payload = if got == expected 132 | then mempty 133 | else error errmess 134 | in (ann, expected, payload, ()) 135 | 136 | enforce_size :: (Monoid mon, Integral ctr) => ctr -> Assembler mon ctr a -> Assembler mon ctr a 137 | enforce_size size body = do 138 | start <- here 139 | ret <- body 140 | enforce_counter (start + size) "" 141 | return ret 142 | 143 | -- Debug.Trace.trace the current counter value 144 | trace_counter :: (Monoid mon, Integral ctr, Show a) => a -> Assembler mon ctr () 145 | trace_counter label = do 146 | spot <- here 147 | trace (show label ++ ": " ++ show (toInteger spot)) nothing 148 | 149 | instance (Monoid mon, Integral ctr) => Monad (Assembler mon ctr) where 150 | return = return_assembler 151 | (>>=) = bind_assembler 152 | (>>) = append_assembler 153 | fail = fail_assembler 154 | 155 | instance (Monoid mon, Integral ctr) => MonadFix (Assembler mon ctr) where 156 | mfix = fix_assembler 157 | 158 | -- ANNOTATIONS 159 | -- These provide 160 | type Annotations = M.Map TypeRep Unknown 161 | data Unknown 162 | annotations_get :: Typeable a => Annotations -> Maybe a 163 | annotations_get = f' undefined where 164 | f' :: Typeable a => a -> Annotations -> Maybe a 165 | f' undef = unsafeCoerce . M.lookup (typeOf undef) 166 | 167 | -- Get all the annotations at once. You probably don't need to do this. 168 | get_all_annotations :: Monoid mon => Assembler mon ctr Annotations 169 | get_all_annotations = Assembler $ \(ann, pos) -> (ann, pos, mempty, ann) 170 | 171 | -- Set an annotation to be a value. 172 | set_annotation :: (Typeable a, Monoid mon) => a -> Assembler mon ctr () 173 | set_annotation x = set_annotation_maybe (Just x) 174 | 175 | -- Clear an annotation. This takes the type from its argument and ignores the value, 176 | -- so you can pass it undefined or whatever. 177 | clear_annotation :: (Typeable a, Monoid mon) => a -> Assembler mon ctr () 178 | clear_annotation x = Assembler $ \(ann, pos) -> (M.delete (typeOf x) ann, pos, mempty, ()) 179 | 180 | -- Set or clear an annotation based on the argument's Justice 181 | set_annotation_maybe :: (Typeable a, Monoid mon) => Maybe a -> Assembler mon ctr () 182 | set_annotation_maybe x = Assembler $ \(ann, pos) -> let 183 | ann2 = case x of 184 | Just v -> M.insert (typeOf v) (unsafeCoerce v) ann 185 | Nothing -> M.delete (typeOf (fromJust x)) ann 186 | in (ann2, pos, mempty, ()) 187 | 188 | -- Get an annotation, or error if there's no annotation of that type 189 | get_annotation :: (Typeable a, Monoid mon, Integral ctr) => Assembler mon ctr a 190 | get_annotation = get_annotation_typed undefined 191 | 192 | -- In case it's more convenient to manually specify the type of the annotation 193 | get_annotation_typed :: (Typeable a, Monoid mon, Integral ctr) => a -> Assembler mon ctr a 194 | get_annotation_typed _ = Assembler $ \(ann, pos) -> let 195 | ret = case annotations_get ann of 196 | Just x -> x 197 | Nothing -> error$ printf "Tried to get non-existent annotation of type %s%s at 0x%x" 198 | (appendable_section_name ann) (show (typeOf ret)) (toInteger pos) 199 | in (ann, pos, mempty, ret) 200 | 201 | -- Get Just an annotation or Nothing if there is none 202 | get_annotation_maybe :: (Typeable a, Monoid mon) => Assembler mon ctr (Maybe a) 203 | get_annotation_maybe = get_annotation_maybe_typed undefined 204 | 205 | get_annotation_maybe_typed :: (Typeable a, Monoid mon) => a -> Assembler mon ctr (Maybe a) 206 | get_annotation_maybe_typed _ = 207 | Assembler $ \(ann, pos) -> (ann, pos, mempty, annotations_get ann) 208 | 209 | -- Get an annotation or a default value if it hasn't been set 210 | get_annotation_default :: (Typeable a, Monoid mon) => a -> Assembler mon ctr a 211 | get_annotation_default def = 212 | Assembler $ \(ann, pos) -> (ann, pos, mempty, fromMaybe def (annotations_get ann)) 213 | 214 | -- Modify an annotation in place. If none exists, does nothing. 215 | modify_annotation :: (Typeable a, Monoid mon, Integral ctr) => (a -> a) -> Assembler mon ctr () 216 | modify_annotation f = do 217 | ann <- get_annotation_maybe 218 | let result = case ann of 219 | Just x -> Just (f x) 220 | Nothing -> Nothing 221 | set_annotation_maybe result 222 | 223 | -- Modify an annotation in place. If the annotation hasn't been set, the given default value 224 | -- will be processed with the given function instead of the current value. 225 | modify_annotation_default :: (Typeable a, Monoid mon, Integral ctr) => a -> (a -> a) -> Assembler mon ctr () 226 | modify_annotation_default def f = do 227 | ann <- get_annotation_default def 228 | set_annotation (f ann) 229 | 230 | -- Temporarily set an annotation and restore its previous value after the block is done 231 | with_annotation :: (Typeable a, Monoid mon, Integral ctr) => a -> Assembler mon ctr b -> Assembler mon ctr b 232 | with_annotation x inner = do 233 | old <- get_annotation_maybe_typed x 234 | set_annotation x 235 | ret <- inner 236 | set_annotation_maybe old 237 | return ret 238 | 239 | -- SECTIONS 240 | -- A section describes simply a region of memory, either one containing code or 241 | -- one in RAM. It may have a name, it may have annotations, and it may have 242 | -- a return value, but it always has a start and end. 243 | 244 | data Section ctr a = Section Annotations String ctr ctr a 245 | -- Sections may carry Annotations in case they're needed. 246 | -- The set of annotations is that which was in effect when the section ended. 247 | section_annotations :: Section ctr a -> Annotations 248 | section_annotations (Section x _ _ _ _) = x 249 | -- The name of a section is primarily for diagnostic purposes, i.e. 250 | -- if there's an error in the code somewhere, the error message can 251 | -- tell you what section it is in. 252 | section_name :: Section ctr a -> String 253 | section_name (Section _ x _ _ _) = x 254 | section_start :: Section ctr a -> ctr 255 | section_start (Section _ _ x _ _) = x 256 | start :: Section ctr a -> ctr 257 | start = section_start 258 | section_size :: Num ctr => Section ctr a -> ctr 259 | section_size (Section _ _ s e _) = e - s 260 | size :: Num ctr => Section ctr a -> ctr 261 | size = section_size 262 | section_end :: Section ctr a -> ctr 263 | section_end (Section _ _ _ x _) = x 264 | end :: Section ctr a -> ctr 265 | end = section_end 266 | -- If you wanted to return something from an Assembler monad but it's buried in a Section, use this 267 | section_return :: Section ctr a -> a 268 | section_return (Section _ _ _ _ x) = x 269 | -- If the return type is bogging you down you can do this. 270 | section_erase_return :: Section ctr a -> Section ctr Unknown 271 | section_erase_return = unsafeCoerce 272 | section_erase_types :: Section ctr a -> Section Unknown Unknown 273 | section_erase_types = unsafeCoerce 274 | section_recover_ctr_type :: Section Unknown Unknown -> Section ctr Unknown 275 | section_recover_ctr_type = unsafeCoerce 276 | 277 | -- Various annotations to be used with sections 278 | newtype NamedSections = NamedSections (M.Map String [Section Unknown Unknown]) deriving (Typeable) 279 | newtype CurrentSection = CurrentSection (Section Unknown Unknown) deriving (Typeable) 280 | 281 | -- Wraps the code in an unnamed section 282 | section :: (Monoid mon, Integral ctr) => Assembler mon ctr a -> Assembler mon ctr (Section ctr a) 283 | section = sect "" 284 | 285 | -- Wraps the code in a named section, prepending it with the outer section name and "/" 286 | sect :: (Monoid mon, Integral ctr) => String -> Assembler mon ctr a -> Assembler mon ctr (Section ctr a) 287 | sect name inner = mdo 288 | let newname = if null name then name else fromMaybe name $ do -- Maybe monad 289 | CurrentSection oldsection <- old 290 | return (section_name oldsection ++ "/" ++ name) 291 | sect = Section ann newname start end ret 292 | add_named_section (NamedSections map) = case newname of 293 | "" -> NamedSections map 294 | newname -> NamedSections (M.insertWith (++) newname [section_erase_types sect] map) 295 | old <- get_annotation_maybe 296 | set_annotation (CurrentSection (section_erase_types sect)) 297 | modify_annotation_default (NamedSections M.empty) add_named_section 298 | start <- here 299 | ret <- inner 300 | end <- here 301 | ann <- get_all_annotations 302 | set_annotation_maybe old 303 | return sect 304 | 305 | 306 | -- Given a starting spot and a list of sizes, returns a list of sections. 307 | -- One use case for this is to allow separate banks in bank-switching systems to 308 | -- share a common layout. 309 | allocate :: (Num ctr, Integral siz) => ctr -> [siz] -> [Section ctr ()] 310 | allocate prev [] = [] 311 | allocate prev (z:zs) = let 312 | s = Section M.empty "" prev (prev + fromIntegral z) () 313 | in s : allocate (end s) zs 314 | -- Like above but give the sections names as well. 315 | allocate_named :: (Num ctr, Integral siz) => ctr -> [(String, siz)] -> [Section ctr ()] 316 | allocate_named prev [] = [] 317 | allocate_named prev ((n,z):nzs) = let 318 | s = Section M.empty n prev (prev + fromIntegral z) () 319 | in s : allocate_named (end s) nzs 320 | 321 | -- Like allocate but just make one Section. 322 | allocate1 :: (Num ctr, Integral siz) => ctr -> siz -> Section ctr () 323 | allocate1 prev z = Section M.empty "" prev (prev + fromIntegral z) () 324 | 325 | -- Like allocate1 but gives it a name. 326 | allocate1_named :: (Num ctr, Integral siz) => String -> ctr -> siz -> Section ctr () 327 | allocate1_named name prev z = Section M.empty name prev (prev + fromIntegral z) () 328 | 329 | -- Ensure that the given code satisfies the given section. 330 | -- It also propagates the name of the allocated section into the code. 331 | -- This is strict in the Maybe-ness of the name of the allocated section, because to 332 | -- be otherwise would just be a big pain. 333 | provide :: (Monoid mon, Integral ctr) => Section ctr a -> Assembler mon ctr b -> Assembler mon ctr (Section ctr b) 334 | provide allocation code = do 335 | enforce_counter (start allocation) (section_name allocation) 336 | ret <- sect (section_name allocation) code 337 | enforce_counter (end allocation) (section_name allocation) 338 | return ret 339 | 340 | -- Merge adjacent (allocated) Sections together. Will fail if they're not adjacent. 341 | section_merge :: Integral ctr => Section ctr a -> Section ctr b -> Section ctr b 342 | section_merge a b = if end a == start b 343 | then Section M.empty "" (start a) (end b) (section_return b) 344 | else error$ printf "Tried to merge nonadjacent sections (0x%x..0x%x and 0x%x..0x%x)" 345 | (toInteger (start a)) (toInteger (end a)) (toInteger (start b)) (toInteger (end b)) 346 | 347 | -- Get the name of the current section in a format that's appropriate for error messages 348 | appendable_section_name :: Annotations -> String 349 | appendable_section_name ann = case annotations_get ann of 350 | Just (CurrentSection sec) -> case section_name sec of 351 | "" -> "" 352 | name -> " in \"" ++ name ++ "\"" 353 | Nothing -> "" 354 | 355 | -- Returns the section currently being processed. 356 | current_section :: (Monoid mon, Integral ctr) => Assembler mon ctr (Maybe (Section ctr Unknown)) 357 | current_section = do 358 | x <- get_annotation_maybe 359 | let ret = case x of 360 | Just (CurrentSection sect) -> Just (section_recover_ctr_type sect) 361 | Nothing -> Nothing 362 | return ret 363 | 364 | -- Get a section with a certain name from an assemblage. Will fail if no or multiple sections 365 | -- were given that name. 366 | get_section :: String -> Assemblage mon ctr -> Section ctr Unknown 367 | get_section name asg = case annotations_get (assemblage_annotations asg) of 368 | Just (NamedSections sections) -> case M.lookup name sections of 369 | Just [section] -> (section_recover_ctr_type section) 370 | Just (section:_) -> error$ "Can't get_section \"" ++ name ++ "\" because multiple sections with that name were assembled." 371 | _ -> error$ "Can't get_section \"" ++ name ++ "\" because no section with that name was assembled." 372 | Nothing -> error$ "Can't get_section \"" ++ name ++ "\" because no section with that name was assembled. In fact, no named sections were assembled at all." 373 | 374 | -- Sections have to be able to act like integers. 375 | instance Num ctr => Num (Section ctr a) where 376 | a + b = Section M.empty "" (start a + start b) (start a + start b) (noreturn "(+)") 377 | a - b = Section M.empty "" (start a - start b) (start a + start b) (noreturn "(-)") 378 | (*) = cantXsection "(*)" 379 | abs = cantXsection "abs" 380 | signum = cantXsection "signum" 381 | fromInteger x = Section M.empty "" (fromInteger x) (fromInteger x) (noreturn "fromInteger") 382 | 383 | 384 | instance Enum ctr => Enum (Section ctr a) where 385 | succ a = Section M.empty "" (succ (start a)) (succ (start a)) (noreturn "succ") 386 | pred a = Section M.empty "" (pred (start a)) (pred (start a)) (noreturn "pred") 387 | toEnum = error$ "Can't toEnum to get a Section" 388 | fromEnum = error$ "Can't fromEnum Section (you can toInteger it though)" 389 | 390 | instance Eq ctr => Eq (Section ctr a) where 391 | a == b = start a == start b 392 | 393 | instance Ord ctr => Ord (Section ctr a) where 394 | compare a b = compare (start a) (start b) 395 | 396 | instance Real ctr => Real (Section ctr a) where 397 | toRational = toRational . start 398 | 399 | instance Integral ctr => Integral (Section ctr a) where 400 | quot = cantXsection "quot" 401 | rem = cantXsection "rem" 402 | div = cantXsection "div" 403 | mod = cantXsection "mod" 404 | quotRem = cantXsection "quotRem" 405 | divMod = cantXsection "divMod" 406 | toInteger = toInteger . start 407 | 408 | instance Bounded ctr => Bounded (Section ctr a) where 409 | minBound = Section M.empty "" minBound minBound (noreturn "minBound") 410 | maxBound = Section M.empty "" maxBound maxBound (noreturn "maxBound") 411 | 412 | cantXsection name = error $ "Can't " ++ name ++ " Section." 413 | noreturn name = error $ "Section generated from " ++ name ++ " has no section_return." 414 | -------------------------------------------------------------------------------- /lib/NES.hs: -------------------------------------------------------------------------------- 1 | module NES where 2 | 3 | import Data.Word 4 | import Assembler 5 | import ASM 6 | import ASM6502 hiding (bit) 7 | import Data.Bits 8 | import Data.Char 9 | import qualified Data.ByteString as B 10 | 11 | -- Provides an ines header. 12 | -- See http://wiki.nesdev.com/w/index.php/INES for more info. 13 | -- prgs chrs mapper flags 14 | header :: Word8 -> Word8 -> Word8 -> Word8 -> B.ByteString 15 | header prgs chrs mapper flags = let asc = fromIntegral . ord in B.pack [ 16 | asc 'N', asc 'E', asc 'S', 0x1a, 17 | prgs, chrs, 18 | shiftL (mapper .&. 0xf) 4 .|. (flags .&. 0xf), 19 | (mapper .&. 0xf0) .|. shiftR (flags .&. 0xf0) 4, 20 | 0, 0, 0, 0, 0, 0, 0, 0 21 | ] 22 | 23 | -- PPU PORTS 24 | 25 | ppuctrl = 0x2000 :: Word16 26 | nametable_x_bit = bit 0 :: Word8 27 | nametable_y_bit = bit 1 :: Word8 28 | inc_32_bit = bit 2 :: Word8 29 | sprites_1000_bit = bit 3 :: Word8 30 | background_1000_bit = bit 4 :: Word8 31 | sprites_8x16_bit = bit 5 :: Word8 32 | enable_nmi_bit = bit 7 :: Word8 33 | 34 | ppumask = 0x2001 :: Word16 35 | grayscale_bit = bit 0 :: Word8 36 | dont_clip_background_bit = bit 1 :: Word8 37 | dont_clip_sprites_bit = bit 2 :: Word8 38 | enable_background_bit = bit 3 :: Word8 39 | enable_sprites_bit = bit 4 :: Word8 40 | intensify_red_bit = bit 5 :: Word8 41 | intensify_green_bit = bit 6 :: Word8 42 | intensify_blue_bit = bit 7 :: Word8 43 | 44 | ppustatus = 0x2002 :: Word16 45 | sprite_overflow_bit = bit 5 :: Word8 46 | sprite_0_hit_but = bit 6 :: Word8 47 | vblank_bit = bit 7 :: Word8 48 | 49 | oamaddr = 0x2003 :: Word16 50 | oamdata = 0x2004 :: Word16 51 | 52 | ppuscroll = 0x2005 :: Word16 53 | 54 | ppuaddr = 0x2006 :: Word16 55 | set_ppuaddr w16 = do 56 | lda ppustatus 57 | high w16 ->* ppuaddr 58 | low w16 ->* ppuaddr 59 | ppudata = 0x2007 :: Word16 60 | 61 | oam_dma = 0x4014 :: Word16 62 | 63 | set_oam_dma w16 = do 64 | low w16 ->* ppuaddr 65 | high w16 ->* oam_dma 66 | 67 | -- VRAM ADDRESSES 68 | 69 | vram_pattern_table_0 = 0x0000 70 | vram_pattern_table_1 = 0x1000 71 | vram_nametable_0 = 0x2000 72 | vram_nametable_1 = 0x2400 73 | vram_nametable_2 = 0x2800 74 | vram_nametable_3 = 0x2c00 75 | vram_attribute_table_0 = 0x23c0 76 | vram_attribute_table_1 = 0x27c0 77 | vram_attribute_table_2 = 0x2bc0 78 | vram_attribute_table_3 = 0x2fc0 79 | vram_palettes = 0x3f00 80 | vram_background_palettes = 0x3f00 81 | vram_sprite_palettes = 0x3f10 82 | 83 | -- APU STUFF 84 | 85 | chn_env = 0x4000 :: Word16 86 | volume_bits = 0x3f :: Word8 87 | constant_volume = 0x10 :: Word8 88 | disable_length_counter = 0x20 :: Word8 89 | duty_bits = 0xc0 :: Word8 90 | duty_eighth = 0x00 :: Word8 91 | duty_quarter = 0x40 :: Word8 92 | duty_half = 0x80 :: Word8 93 | duty_inverted_quarter = 0xc0 :: Word8 94 | 95 | chn_sweep = 0x4001 :: Word16 96 | 97 | chn_low = 0x4002 :: Word16 98 | 99 | chn_high = 0x4003 :: Word16 100 | period_high_bits = 0x07 :: Word8 101 | length_counter_bits = 0xf8 :: Word8 102 | 103 | apuports = 0x4000 :: Word16 104 | pulse1 = 0x0 :: Word16 -- For some reason it's prematurely defaulting to Integer 105 | pulse2 = 0x4 :: Word16 106 | triangle = 0x8 :: Word16 107 | noise = 0xc :: Word16 108 | 109 | pulse1_env = 0x4000 :: Word16 110 | pulse1_sweep = 0x4001 :: Word16 111 | pulse1_low = 0x4002 :: Word16 112 | pulse1_high = 0x4003 :: Word16 113 | pulse2_env = 0x4004 :: Word16 114 | pulse2_sweep = 0x4005 :: Word16 115 | pulse2_low = 0x4006 :: Word16 116 | pulse2_high = 0x4007 :: Word16 117 | triangle1_env = 0x4008 :: Word16 118 | triangle1_low = 0x400a :: Word16 119 | triangle1_high = 0x400b :: Word16 120 | 121 | dmc_flags = 0x4010 :: Word16 122 | loop_sample_bit = bit 6 :: Word8 123 | enable_dmc_irq_bit = bit 7 :: Word8 124 | 125 | apuctrl = 0x4015 :: Word16 126 | enable_pulse1 = bit 0 :: Word8 127 | enable_pulse2 = bit 1 :: Word8 128 | enable_triangle = bit 2 :: Word8 129 | enable_noise = bit 3 :: Word8 130 | enable_dmc = bit 4 :: Word8 131 | 132 | controller1 = 0x4016 :: Word16 133 | controller2 = 0x4017 :: Word16 134 | apumode = 0x4017 :: Word16 135 | disable_frame_irq_bit = bit 6 :: Word8 136 | sequencer_mode_bit = bit 7 :: Word8 137 | 138 | initialize_begin' = do 139 | sei 140 | cld 141 | disable_frame_irq_bit ->* apumode 142 | ldxi 0xff 143 | txs -- make stack 144 | inx 145 | stx ppuctrl -- disable nmi 146 | stx ppumask -- disable rendering 147 | stx dmc_flags -- disable dmc irqs 148 | 149 | -- wait for first vblank 150 | rep bpl (bitm ppustatus) 151 | 152 | clear_memory' = do 153 | repfor (ldxi 0x00) (dex >>. bne) $ do 154 | ldai 0x00 155 | stax 0x00 156 | stax 0x0100 157 | stax 0x0200 158 | stax 0x0300 159 | stax 0x0400 160 | stax 0x0500 161 | stax 0x0600 162 | stax 0x0700 163 | 164 | initialize_end' = do 165 | -- wait for second vblank 166 | rep bpl (bitm ppustatus) 167 | 168 | initialize_custom_clear' clear = sect "NES.initialize" (initialize_begin' >> clear >> initialize_end') 169 | initialize' = initialize_custom_clear' clear_memory' 170 | 171 | read_input_to' :: Integral a => a -> ASM6502 (Section6502 ()) 172 | read_input_to' spot = sect "NES.read_input_to" $ do 173 | -- Freeze controllers for polling 174 | 0x01 ->* NES.controller1 175 | 0x00 ->* NES.controller1 176 | -- Roll bits in one at a time 177 | repfor (ldxi 0x01) (dex >>. bpl) $ do 178 | repfor (ldyi 0x07) (dey >>. bpl) $ do 179 | ldax NES.controller1 180 | lsra 181 | rolx spot 182 | 183 | [btn_right, btn_left, btn_down, btn_up, btn_start, btn_select, btn_b, btn_a] = 184 | map (shiftL 1) [0..7] :: [Word8] 185 | 186 | [nmi, reset, irq] = allocate_named (0xfffa::Word16) 187 | [("NES.nmi", 2), ("NES.reset", 2), ("NES.irq", 2)] 188 | 189 | 190 | -------------------------------------------------------------------------------- /lib/NES/ASoundEngine.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE RecursiveDo, DeriveDataTypeable #-} 3 | 4 | -- Please import this qualified. 5 | module NES.ASoundEngine ( 6 | ASoundEngine, a_sound_engine', initialize', set_stream', run', 7 | note, delay, loop, repeat, set_env, call, ensure_length 8 | ) where 9 | 10 | import Prelude hiding (repeat) 11 | import Data.Word 12 | import Data.Typeable 13 | import Assembler 14 | import ASM 15 | import ASM6502 16 | import NES hiding (initialize') 17 | import NES.Reservations 18 | import Text.Printf 19 | 20 | data ASoundEngine = ASoundEngine (Section6502 ()) (Section6502 ()) 21 | engine_note_table (ASoundEngine x _) = x 22 | engine_state (ASoundEngine _ x) = x 23 | -- Data is laid out in fours to match the NES channels 24 | -- 11112222ttttnnnn11--22--tt--nn-- 25 | engine_position = (+ 0x00) . section_start . engine_state 26 | engine_timer = (+ 0x02) . section_start . engine_state 27 | engine_reps = (+ 0x10) . section_start . engine_state -- Takes up two slots for two loop units 28 | engine_size = 0x20 :: Word16 29 | 30 | -- Takes a note table as input. 31 | a_sound_engine' :: Section6502 () -> ASM6502 ASoundEngine 32 | a_sound_engine' note_table = do 33 | state <- res engine_size 34 | return $ ASoundEngine note_table state 35 | 36 | initialize' :: ASoundEngine -> ASM6502 (Section6502 ()) 37 | initialize' engine = sect "NES.ASoundEngine.initialize" $ mdo 38 | let init_part :: Word16 -> ASM6502 () 39 | init_part chn = do 40 | -- We're assuming memory has been zeroed out. 41 | 0x01 ->* engine_timer engine + chn 42 | init_part NES.pulse1 43 | init_part NES.pulse2 44 | init_part NES.triangle 45 | 46 | set_stream' engine chn stream = sect "NES.ASoundEngine.set_stream" $ mdo 47 | ldai (low stream) 48 | sta (engine_position engine + chn) 49 | ldai (high stream) 50 | sta (engine_position engine + chn + 1) 51 | 52 | run' :: ASoundEngine -> ASM6502 (Section6502 ()) 53 | run' engine = sect "NES.ASoundEngine.run" $ mdo 54 | -- X is always the channel offset (0, 4, 8, or c) 55 | -- Y is either the low end of pos or the note index. 56 | let note_table = engine_note_table engine 57 | position = engine_position engine 58 | timer = engine_timer engine 59 | reps = engine_reps engine 60 | pos = 0x00 -- 0x00 stays 0 (the real pointer is y:0x01) 61 | tmpy = 0x02 62 | command_ptr = 0x03 63 | tmppos = 0x05 64 | next = do 65 | iny 66 | skip bne (inc (pos + 1)) 67 | ldxi 0x00 68 | run_one <- here 69 | read_commands <- mdo 70 | ldax (position + 1) 71 | beq just_wait 72 | decx timer 73 | bne just_wait 74 | read_commands <- mdo 75 | ldyx position 76 | sta (pos + 1) 77 | read_commands <- sect "read_commands" $ mdo 78 | ldayp pos 79 | next 80 | sty tmpy 81 | asla 82 | tay 83 | skip bcs $ mdo -- play a note 84 | lday (start note_table) 85 | stax NES.chn_low 86 | lday (start note_table + 1) 87 | orai 0xf8 88 | stax NES.chn_high 89 | ldy tmpy 90 | ldayp pos -- Also read a delay. 91 | skip bne $ mdo 92 | next 93 | jmp read_commands 94 | next 95 | stax timer 96 | jmp (end read_commands) 97 | lday command_table -- Do a special comand 98 | sta command_ptr 99 | lday (command_table + 1) 100 | sta (command_ptr + 1) 101 | ldy tmpy 102 | jmpp command_ptr 103 | tya 104 | stax position 105 | lda (pos + 1) >> stax (position + 1) 106 | return read_commands 107 | just_wait <- here 108 | return read_commands 109 | inx >> inx >> inx >> inx 110 | skip (cpxi 0x0c >>. beq) (jmp run_one) 111 | jmp (end command_table) 112 | command_table <- section$ mdo 113 | le16 command_loopa 114 | le16 command_loopb 115 | le16 command_delay 116 | le16 command_set_env 117 | le16 command_call 118 | command_loopb <- here 119 | stx tmpy 120 | inx 121 | jmp command_loop_start 122 | command_loopa <- here 123 | stx tmpy 124 | command_loop_start <- here 125 | ldax reps 126 | skip bne$ mdo 127 | ldayp pos -- reps is zero; start loop 128 | skip bne $ mdo 129 | next -- If the program says zero reps it means infinite 130 | jmp do_goto 131 | stax reps 132 | next 133 | decx reps 134 | skip bne $ mdo 135 | next 136 | next 137 | ldx tmpy 138 | jmp read_commands 139 | do_goto <- section$ mdo 140 | ldx tmpy 141 | ldayp pos -- reps is non-zero or loop is infinite 142 | sta tmpy 143 | next 144 | ldayp pos 145 | sta (pos + 1) 146 | ldy tmpy 147 | jmp read_commands 148 | command_delay <- section$ mdo 149 | ldayp pos >> stax timer 150 | next 151 | jmp (end read_commands) 152 | command_set_env <- section$ mdo 153 | ldayp pos >> stax NES.chn_env 154 | next 155 | jmp read_commands 156 | command_call <- section$ mdo 157 | ldayp pos >> sta command_ptr 158 | next 159 | ldayp pos >> sta (command_ptr + 1) 160 | next 161 | jsr call_sub 162 | jmp read_commands 163 | call_sub <- section$ mdo 164 | jmpp command_ptr 165 | nothing 166 | nothing 167 | 168 | loopa_code : loopb_code : delay_code : set_env_code : call_code : _ = [0x80..] :: [Word8] 169 | 170 | newtype LoopCount = LoopCount Int deriving (Typeable) 171 | newtype LengthCount = LengthCount Int deriving (Typeable) 172 | addlength x (LengthCount y) = LengthCount (fromIntegral x + y) 173 | inflength (LengthCount _) = LengthCount (error "ensure_length failed; length became infinit due to a repeat.") 174 | 175 | delaybyte :: Integral a => a -> ASM6502 () 176 | delaybyte d = if d <= 0xff 177 | then byte (fromIntegral d) 178 | else byte 0xff >> delay' (d - 0xff) 179 | 180 | note :: (Integral a, Integral b) => a -> b -> ASM6502 () 181 | note n d = do 182 | pos <- here 183 | if n <= 0x7f 184 | then byte (fromIntegral n) >> delaybyte d 185 | else fail$ printf "Note value is too large (0x%x > 0x7f) at 0x%x" (toInteger n) pos 186 | modify_annotation (addlength d) 187 | 188 | delay' :: Integral a => a -> ASM6502 () 189 | delay' d = byte delay_code >> delaybyte d 190 | 191 | delay :: Integral a => a -> ASM6502 () 192 | delay d = delay' d >> modify_annotation (addlength d) 193 | 194 | loop_code spot 0 = loopa_code 195 | loop_code spot 1 = loopb_code 196 | loop_code spot _ = error$ printf "Too many nested loops in music stream at 0x%x" spot 197 | 198 | loop :: Word8 -> ASM6502 a -> ASM6502 () 199 | loop times code = do 200 | begin <- here 201 | LoopCount c <- get_annotation_default (LoopCount 0) 202 | set_annotation (LoopCount (c + 1)) 203 | startlen <- get_annotation_maybe 204 | code 205 | endlen <- get_annotation_maybe 206 | set_annotation (LoopCount c) 207 | byte (loop_code begin c) 208 | byte times 209 | le16 begin 210 | let finallen = case (startlen, endlen) of 211 | (Just (LengthCount s), Just (LengthCount e)) -> Just (LengthCount (s + (e - s) * (fromIntegral times))) 212 | _ -> Nothing 213 | set_annotation_maybe finallen 214 | 215 | 216 | repeat :: ASM6502 a -> ASM6502 () 217 | repeat code = do 218 | begin <- here 219 | code 220 | byte loopa_code 221 | byte 0 222 | le16 begin 223 | modify_annotation inflength 224 | 225 | set_env :: Word8 -> ASM6502 () 226 | set_env val = byte set_env_code >> byte val 227 | 228 | call :: Integral a => a -> ASM6502 () 229 | call = op16 "NES.ASoundEngine.call" call_code 230 | 231 | ensure_length :: Integral a => a -> ASM6502 b -> ASM6502 b 232 | ensure_length len inner = do 233 | (ret, got) <- with_annotation (LengthCount 0) $ do 234 | ret <- inner 235 | LengthCount got <- get_annotation 236 | return (ret, got) 237 | fail_assembler_if (got /= fromIntegral len) (printf "ensure_length failed; expected length %d but got length %d." 238 | (toInteger len) got) 239 | return ret 240 | -------------------------------------------------------------------------------- /lib/NES/Header001.hs: -------------------------------------------------------------------------------- 1 | module NES.Header001 ( 2 | reset', writeA', writeA0', write' 3 | ) where 4 | import Data.Word 5 | import Assembler 6 | import ASM6502 7 | import NES 8 | 9 | -- Note: this only resets the temporary transfer register and bits 10 | -- 2-3 of register 0x8000 11 | reset' = sect "NES.Mapper001.reset'" $ do 12 | ldai 0x80 13 | sta 0x8000 14 | 15 | writeA' :: Word16 -> ASM6502 (Section6502 ()) 16 | writeA' reg = sect "NES.Mapper001.writeA'" $ do 17 | sta reg 18 | sequence_ $ replicate 4 (lsra >> sta reg) 19 | 20 | writeA0' :: Word16 -> ASM6502 (Section6502 ()) 21 | writeA0' reg = sect "NES.Mapper001.writeA0'" $ do 22 | sequence_ $ replicate 5 (sta reg) 23 | 24 | write' :: Word16 -> Word8 -> ASM6502 (Section6502 ()) 25 | write' reg val = sect "NES.Mapper001.write'" $ do 26 | ldai val 27 | if val == 0 then writeA0' reg else writeA' reg 28 | return () 29 | 30 | 31 | 32 | 33 | -------------------------------------------------------------------------------- /lib/NES/ImageLoader.hs: -------------------------------------------------------------------------------- 1 | module NES.ImageLoader ( 2 | file_to_chr, bytestring_to_chr, image_to_chr, greyscale_palette, 3 | file_to_pixels, bytestring_to_pixels, image_to_pixels 4 | ) where 5 | 6 | import Data.Bits 7 | import Data.Word 8 | import qualified Data.ByteString as B 9 | import qualified Codec.Picture as P 10 | import qualified Codec.Picture.Types as PT 11 | 12 | greyscale_palette :: (P.PixelRGBA8 -> Int) 13 | greyscale_palette (P.PixelRGBA8 r g b a) = let 14 | total = sum $ map toInteger $ [r, g, b] 15 | in if total <= (64 * 3) then 0 16 | else if total <= (128 * 3) then 1 17 | else if total <= (192 * 3) then 2 18 | else 3 19 | 20 | bits_to_bytes :: [Bool] -> [Word8] 21 | bits_to_bytes [] = [] 22 | bits_to_bytes (b0:b1:b2:b3:b4:b5:b6:b7:rest) = 23 | foldl (\acc b -> shiftL acc 1 .|. if b then 1 else 0) 0 [b0,b1,b2,b3,b4,b5,b6,b7] : bits_to_bytes rest 24 | bits_to_bytes weird = error $ "Got a weird number of bits: " ++ show (length weird) 25 | 26 | image_to_chr :: Bits output => (P.PixelRGBA8 -> output) -> P.DynamicImage -> B.ByteString 27 | image_to_chr pal dynimg = let 28 | img :: P.Image P.PixelRGBA8 29 | img = case dynimg of 30 | P.ImageY8 i -> PT.promoteImage i 31 | P.ImageYA8 i -> PT.promoteImage i 32 | P.ImageRGB8 i -> PT.promoteImage i 33 | P.ImageRGBA8 i -> PT.promoteImage i 34 | P.ImageYCbCr8 i -> error$ "Sorry, NES.ImageLoader cannot use image in YCbCr8 format." 35 | width = P.imageWidth img 36 | height = P.imageHeight img 37 | cols = width `div` 8 38 | rows = height `div` 8 39 | blocks = [(x, y) | x <- [0..cols-1], y <- [0..rows-1]] 40 | pxblocks = [[P.pixelAt img (bx * 8 + px) (by * 8 + py) | py <- [0..7], px <- [0..7]] | (bx, by) <- blocks] 41 | indexblocks = [[pal p | p <- ps] | ps <- pxblocks] 42 | bitfields b = [[testBit i b | i <- is] | is <- indexblocks] 43 | bits = map (uncurry (++)) $ zip (bitfields 0) (bitfields 1) 44 | bytes = concatMap bits_to_bytes bits 45 | in B.pack bytes 46 | 47 | unLeft (Left mess) = error mess 48 | unLeft (Right val) = val 49 | 50 | bytestring_to_chr :: Bits output => (P.PixelRGBA8 -> output) -> B.ByteString -> B.ByteString 51 | bytestring_to_chr pal = image_to_chr pal . unLeft . P.decodeImage 52 | 53 | file_to_chr :: Bits output => (P.PixelRGBA8 -> output) -> FilePath -> IO B.ByteString 54 | file_to_chr pal = fmap (image_to_chr pal . unLeft) . P.readImage 55 | 56 | image_to_pixels :: P.DynamicImage -> [[P.PixelRGBA8]] 57 | image_to_pixels dynimg = let 58 | img :: P.Image P.PixelRGBA8 59 | img = case dynimg of 60 | P.ImageY8 i -> PT.promoteImage i 61 | P.ImageYA8 i -> PT.promoteImage i 62 | P.ImageRGB8 i -> PT.promoteImage i 63 | P.ImageRGBA8 i -> PT.promoteImage i 64 | P.ImageYCbCr8 i -> error$ "Sorry, NES.ImageLoader cannot use image in YCbCr8 format." 65 | width = P.imageWidth img 66 | height = P.imageHeight img 67 | in [[P.pixelAt img x y | x <- [0..width-1]] | y <- [0..height-1]] 68 | 69 | bytestring_to_pixels :: B.ByteString -> [[P.PixelRGBA8]] 70 | bytestring_to_pixels = image_to_pixels . unLeft . P.decodeImage 71 | 72 | file_to_pixels :: String -> IO [[P.PixelRGBA8]] 73 | file_to_pixels = fmap (image_to_pixels . unLeft) . P.readImage 74 | -------------------------------------------------------------------------------- /lib/NES/Reservations.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | 4 | module NES.Reservations (res, resz) where 5 | 6 | import Assembler 7 | import ASM 8 | import ASM6502 9 | import Data.Typeable 10 | import Data.Word 11 | import Text.Printf 12 | 13 | data ResCounter a = ResCounter a Bool deriving (Typeable) 14 | 15 | res_generic :: (Typeable a, Integral a, Integral b) => String -> a -> a -> b -> ASM6502 (Section a ()) 16 | res_generic space_name space_start space_end size = do 17 | ResCounter alloc_end started <- get_annotation_default (ResCounter space_end False) 18 | errmess <- generate_fail_message (printf "Not enough %s space left to reserve 0x%x bytes" space_name (toInteger size)) 19 | let alloc_size = fromIntegral size 20 | alloc_start = if (not started) || space_start + alloc_size <= alloc_end 21 | then alloc_end - alloc_size 22 | else error errmess 23 | ret = allocate1 alloc_start alloc_size 24 | set_annotation (ResCounter alloc_start True) 25 | return ret 26 | 27 | res :: Integral a => a -> ASM6502 (Section Word16 ()) 28 | res = res_generic "main memory" 0x300 0x800 29 | resz :: Integral a => a -> ASM6502 (Section Word8 ()) 30 | resz = res_generic "zero page" 0x10 0x00 31 | 32 | 33 | -------------------------------------------------------------------------------- /make.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use lib do {__FILE__ =~ /^(.*)[\/\\]/; ($1||'.').'/tool'}; 3 | use MakePl; 4 | 5 | my $here; 6 | my @modules; 7 | 8 | sub module { 9 | my ($name) = @_; 10 | rule "$name/$name.nes", "$name/$name.hs", sub { 11 | run "runghc -ilib -i'$name' '$name/$name.hs' > '$name/$name.nes'"; 12 | }; 13 | push @modules, "$name/$name.nes"; 14 | } 15 | # Compile modules for future efficiency 16 | for (glob "*/*.hs */*/*.hs") { 17 | $_ =~ /^(.*)\.hs$/; 18 | rule "$1.o", "$1.hs", sub { 19 | run "ghc -ilib $_[1][0]" 20 | }; 21 | } 22 | 23 | # Provide subdeps in the files themselves 24 | subdep sub { 25 | my ($file) = @_; 26 | $file =~ /\.hs$/ or return (); 27 | my $base = ($file =~ /(.*?)[^\\\/]*$/ and $1); 28 | my @imports = (slurp $file, 2048) =~ /import\s+(?:qualified\s+)?([A-Za-z0-9_.]+)/g; 29 | my @deps; 30 | for my $f (@imports) { 31 | $f =~ s/\./\//g; 32 | if (exists_or_target "$base$f.hs") { 33 | push @deps, "$base$f.o"; 34 | } 35 | elsif (exists_or_target "lib/$f.hs") { 36 | push @deps, "lib/$f.o"; 37 | } 38 | } 39 | return @deps; 40 | }; 41 | 42 | subdep 'controllertest/controllertest.hs', [qw(controllertest/sprites.png controllertest/background.bin)]; 43 | subdep 'agame/agame.hs', [qw(agame/sprites.png agame/background.png)]; 44 | module 'soundtest'; 45 | module 'controllertest'; 46 | module 'agame'; 47 | 48 | phony 'build', [@modules]; 49 | 50 | phony 'clean', [], sub { 51 | unlink glob '*/*.nes */*.exe */*.hi */*.o */*/*.hi */*/*.o'; 52 | }; 53 | 54 | defaults 'build'; 55 | 56 | make; 57 | 58 | 59 | -------------------------------------------------------------------------------- /soundtest/soundtest.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE RecursiveDo #-} 3 | 4 | import Data.Word 5 | import Data.Bits 6 | import qualified Data.ByteString as B 7 | import Assembler 8 | import ASM 9 | import ASM6502 10 | import qualified NES 11 | import Debug.Trace 12 | import qualified NES.ASoundEngine as S 13 | 14 | main = do 15 | B.putStr $ NES.header 0x01 0x00 0x00 0x00 16 | B.putStr $ asm_result prgbank 17 | 18 | 19 | (_, prgbank) = asm 0xc000 $ mdo 20 | let [bg_color] = allocate8 0x10 [1] 21 | 22 | sound <- S.a_sound_engine' note_table 23 | 24 | reset <- sect "reset" $ mdo 25 | NES.initialize' 26 | 27 | -- Set background color 28 | NES.set_ppuaddr 0x3f00 29 | 0x0f ->* NES.ppudata 30 | sta bg_color 31 | 32 | -- nmi for the sound 33 | NES.ppuctrl *<- NES.enable_nmi_bit 34 | NES.ppumask *<- 0 35 | 36 | -- enable sound 37 | NES.apuctrl *<- NES.enable_pulse1 .|. NES.enable_pulse2 .|. NES.enable_triangle 38 | NES.apumode *<- NES.sequencer_mode_bit .|. NES.disable_frame_irq_bit 39 | 40 | 41 | S.initialize' sound 42 | S.set_stream' sound NES.pulse1 pulse1_stream2 43 | S.set_stream' sound NES.pulse2 pulse2_stream2 44 | S.set_stream' sound NES.triangle triangle_stream2 45 | 46 | idle <- here 47 | jmp idle 48 | 49 | nmi <- sect "nmi" $ mdo 50 | NES.set_ppuaddr 0x3f00 51 | start bg_color *->* NES.ppudata 52 | 53 | S.run' sound 54 | 55 | rti 56 | 57 | set_bg_blue <- sect "set_bg_blue" $ mdo 58 | 0x02 ->* start bg_color 59 | rts 60 | set_bg_orange <- sect "set_bg_orange" $ mdo 61 | 0x08 ->* start bg_color 62 | rts 63 | 64 | -- this was initially copypasted from http://www.nintendoage.com/forum/messageview.cfm?catid=22&threadid=22776 65 | -- but a couple tweaks may have been made to sharpen notes up a little 66 | note_table <- sect "note_table" $ mapM_ le16 ([ 0x0000, 0x07f1, 0x0780, 0x0713, -- a1-b1 (0x01-0x03) 67 | 0x06ad, 0x064d, 0x05f3, 0x059d, 0x054d, 0x0500, 0x04b8, 0x0475, 0x0435, 0x03f8, 0x03bf, 0x0389, -- c2-b2 (0x04-0x0f) 68 | 0x0356, 0x0326, 0x02f9, 0x02ce, 0x02a6, 0x027f, 0x025c, 0x023a, 0x021a, 0x01fb, 0x01df, 0x01c4, -- c3-b3 (0x10-0x1b) 69 | 0x01ab, 0x0193, 0x017c, 0x0167, 0x0151, 0x013f, 0x012d, 0x011c, 0x010c, 0x00fd, 0x00ef, 0x00e1, -- c4-b4 (0x1c-0x27) 70 | 0x00d4, 0x00c9, 0x00bd, 0x00b3, 0x00a9, 0x009f, 0x0096, 0x008e, 0x0086, 0x007e, 0x0077, 0x0070, -- c5-b5 (0x28-0x33) 71 | 0x006a, 0x0064, 0x005e, 0x0059, 0x0054, 0x004f, 0x004b, 0x0046, 0x0042, 0x003f, 0x003b, 0x0038, -- c6-b6 (0x34-0x3f) 72 | 0x0034, 0x0031, 0x002f, 0x002c, 0x0029, 0x0027, 0x0025, 0x0023, 0x0021, 0x001f, 0x001d, 0x001b, -- c7-b7 (0x40-0x4b) 73 | 0x001a, 0x0018, 0x0017, 0x0015, 0x0014, 0x0013, 0x0012, 0x0011, 0x0010, 0x000f, 0x000e, 0x000d, -- c8-b8 (0x4c-0x57) 74 | 0x000c, 0x000c, 0x000b, 0x000a, 0x000a, 0x0009, 0x0008] :: [Word16]) -- c9-f#9 (0x58-0x5e) 75 | 76 | pulse1_stream1 <- sect "pulse1_stream1" $ do 77 | S.set_env (NES.duty_quarter .|. NES.disable_length_counter .|. NES.constant_volume .|. 0x8) 78 | S.call set_bg_blue 79 | S.repeat $ do 80 | hexdata "2040 2240 2340 2740 2540 2320 2220 201c 0004 2010 1e10 1b34 000c" 81 | hexdata "2040 2340 2240 1e40 2054 000c 2720 2564 001c" 82 | 83 | pulse2_stream1 <- sect "pulse2_stream1" $ do 84 | S.set_env (NES.duty_quarter .|. NES.disable_length_counter .|. NES.constant_volume .|. 0x6) 85 | S.repeat $ do 86 | hexdata "1480 1280 1040 1240 1480" 87 | hexdata "1080 1280 1480 1280" 88 | 89 | let chime x = S.note x 0x14 >> S.note 0 0x04 90 | let volume x = S.set_env (NES.duty_half .|. NES.disable_length_counter .|. NES.constant_volume .|. x :: Word8) 91 | let measure = S.ensure_length 0xc0 92 | pulse1_stream2 <- sect "pulse1_stream2" $ do 93 | S.set_env (NES.duty_half .|. NES.disable_length_counter .|. 0x3) 94 | S.call set_bg_orange 95 | S.loop 2 $ measure $ do 96 | S.loop 3 $ chime 0x38 >> chime 0x34 97 | chime 0x37 >> chime 0x34 98 | S.repeat $ do 99 | S.loop 8 $ measure $ do 100 | mapM chime (hex "38 34 38 34 37 34 37 34") 101 | S.loop 8 $ measure $ do 102 | mapM (flip S.note 0x0c) (hex "38 2f 34 2f 38 2f 34 2f 37 30 34 30 37 30 34 30") 103 | pulse2_stream2 <- sect "pulse2_stream2" $ do 104 | S.set_env (NES.duty_half .|. NES.disable_length_counter .|. 0x3) 105 | S.loop 2 $ measure $ do 106 | S.loop 3 $ chime 0x31 >> chime 0x2c 107 | chime 0x30 >> chime 0x2b 108 | S.repeat $ do 109 | S.loop 8 $ measure $ mapM chime (hex "31 2c 31 2c 30 2b 30 2b") 110 | volume 5 -- The order of the volume and the loop is on purpose. 111 | S.loop 2 $ do 112 | S.loop 3 $ measure $ do 113 | let cresc x = volume x >> S.delay 0x18 114 | S.note 0x2c 0x18 >> cresc 5 >> cresc 6 >> cresc 7 115 | volume 6 >> S.note 0x2b 0x24 >> volume 5 >> S.note 0x2a 0x24 >> volume 4 >> S.note 0x28 0x18 116 | measure $ S.delay 0x18 >> volume 3 >> S.delay 0x48 >> volume 5 >> S.note 0x28 0x30 >> S.note 0x26 0x30 117 | S.set_env (NES.duty_half .|. NES.disable_length_counter .|. 0x3) 118 | triangle_stream2 <- sect "triangle_stream2" $ do 119 | S.set_env 0x81 120 | S.delay 0x180 121 | S.repeat $ do 122 | S.loop 2 $ do 123 | hexdata "0030 1412 1912 1c06 0006 1c24 1330 000c" 124 | hexdata "0030 1412 1912 1c06 0006 1c24 1e04 1f04 1e04 1c24 000c" 125 | hexdata "0030 1412 1912 1c06 0006 1c24 1324 1506 0006 1430 009c" 126 | S.loop 2 $ do 127 | S.loop 2 $ do 128 | hexdata "1c30 2330 2430 2b1a 0016" 129 | hexdata "1c30 2330 2430 2b30 2a30 2330 2130 2830" 130 | 131 | fillto 0xfffa 0xff 132 | provide NES.nmi $ le16 nmi 133 | provide NES.reset $ le16 reset 134 | provide NES.irq $ le16 0 135 | 136 | -------------------------------------------------------------------------------- /tool/MakePl.pm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | =cut 3 | 4 | MakePl - Portable drop-in build system 5 | https://github.com/quietfanatic/make-pl 6 | 2013-10-05 7 | 8 | USAGE: See the README in the above repo. 9 | 10 | =====LICENSE===== 11 | 12 | The MIT License (MIT) 13 | 14 | Copyright (c) 2013 Lewis Wall 15 | 16 | Permission is hereby granted, free of charge, to any person obtaining a copy 17 | of this software and associated documentation files (the "Software"), to deal 18 | in the Software without restriction, including without limitation the rights 19 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 20 | copies of the Software, and to permit persons to whom the Software is 21 | furnished to do so, subject to the following conditions: 22 | 23 | The above copyright notice and this permission notice shall be included in 24 | all copies or substantial portions of the Software. 25 | 26 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 27 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 28 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 29 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 30 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 31 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 32 | THE SOFTWARE. 33 | 34 | ================= 35 | 36 | =cut 37 | 38 | package MakePl; 39 | 40 | use v5.10; 41 | use strict qw(subs vars); 42 | use warnings; no warnings 'once'; 43 | use utf8; 44 | binmode STDOUT, ':utf8'; 45 | binmode STDERR, ':utf8'; 46 | use Carp 'croak'; 47 | use subs qw(cwd chdir); 48 | 49 | our @EXPORT = qw( 50 | make rule phony subdep defaults include config option 51 | targets exists_or_target 52 | slurp splat slurp_utf8 splat_utf8 53 | run which 54 | cwd chdir canonpath abs2rel rel2abs 55 | ); 56 | 57 | $ENV{PWD} //= do { require Cwd; Cwd::cwd() }; 58 | 59 | # GLOBALS 60 | my $original_base = cwd; # Set once only. 61 | our $this_is_root = 1; # This is set to 0 when recursing. 62 | our $current_file; # Which make.pl we're processing 63 | my $this_file = rel2abs(__FILE__); 64 | my $make_was_called = 0; 65 | # RULES AND STUFF 66 | my @rules; # All registered rules 67 | my %phonies; # Targets that aren't really files 68 | my %targets; # List rules to build each target 69 | my %subdeps; # Registered subdeps by file 70 | my @auto_subdeps; # Functions that generate subdeps 71 | my %autoed_subdeps; # Minimize calls to the above 72 | my $defaults; # undef or array ref 73 | # SYSTEM INTERACTION 74 | my %modtimes; # Cache of file modification times 75 | # CONFIGURATION 76 | my %configs; # Set of registered config names, for cosmetic purposes only 77 | my %builtin_options; # Defined later 78 | my %custom_options; # Kept only for the help message 79 | my %options; # Cache of command-line options 80 | my $force = 0; # Flags set from options 81 | my $verbose = 0; 82 | my $simulate = 0; 83 | my $touch = 0; 84 | my $jobs = 1; 85 | 86 | # START, INCLUDE, END 87 | 88 | sub import { 89 | my $self = shift; 90 | my ($package, $file, $line) = caller; 91 | $current_file = rel2abs($file); 92 | # Export symbols 93 | my @args = (@_ == 0 or grep $_ eq ':all' || $_ eq ':ALL', @_) 94 | ? @EXPORT 95 | : @_; 96 | for my $f (@args) { 97 | grep $_ eq $f, @EXPORT or croak "No export '$f' in MakePl."; 98 | *{$package.'::'.$f} = \&{$f}; 99 | } 100 | # Change to directory of the calling file 101 | $current_file =~ /^(.*)[\/\\]/ or die "path returned by rel2abs wasn't abs. ($current_file)"; 102 | chdir $1; 103 | # Also import strict and warnings. 104 | strict->import(); 105 | warnings->import(); 106 | } 107 | 108 | # Prevent double-inclusion; can't use %INC because it does relative paths. 109 | my %included = (rel2abs($0) => 1); 110 | sub include { 111 | for (@_) { 112 | my $file = canonpath($_); 113 | # Error on specific files, but skip directories. 114 | -e $file or croak "Cannot include $file because it doesn't exist"; 115 | if (-d $file) { 116 | my $makepl = "$file/make.pl"; 117 | next unless -e $makepl; 118 | $file = $makepl; 119 | } 120 | my $real = rel2abs($file); 121 | # Just like a C include, a subdep is warranted. 122 | push @{$subdeps{$real}}, { base => MakePl::cwd, to => [$real], from => [$current_file] }; 123 | # Skip already-included files 124 | next if $included{$real}; 125 | $included{$real} = 1; 126 | # Make new project. 127 | local $this_is_root = 0; 128 | local $current_file; 129 | do { 130 | package main; 131 | my $old_cwd = MakePl::cwd; 132 | do $file; # This file will do its own chdir 133 | MakePl::chdir $old_cwd; 134 | }; 135 | $@ and die status($@); 136 | if (!$make_was_called) { 137 | die "\e[31m✗\e[0m $file did not end with 'make;'\n"; 138 | } 139 | $make_was_called = 0; 140 | $defaults = undef; 141 | } 142 | } 143 | 144 | sub directory_prefix { 145 | my ($d, $base) = @_; 146 | $d //= cwd; 147 | $base //= $original_base; 148 | $d =~ s/\/*$//; 149 | $base =~ s/\/*$//; 150 | return $d eq $base 151 | ? '' 152 | : '[' . abs2rel($d, $base) . '/] '; 153 | } 154 | sub status { 155 | say directory_prefix(), @_; 156 | return "\n"; # Marker to hand to die 157 | } 158 | 159 | sub do_rule { 160 | my ($rule) = @_; 161 | if (!$simulate and defined $rule->{recipe}) { 162 | if ($touch) { 163 | for (@{$rule->{to}}) { 164 | utime(undef, undef, $_); 165 | } 166 | } 167 | else { 168 | $rule->{recipe}->($rule->{to}, $rule->{from}); 169 | } 170 | } 171 | } 172 | 173 | sub make () { 174 | if ($make_was_called) { 175 | say "\e[31m✗\e[0m make was called twice in the same project."; 176 | exit 1; 177 | } 178 | $make_was_called = 1; 179 | if ($this_is_root) { 180 | # Finish processing the command line 181 | # Recognize builtin options and complain at unrecognized ones 182 | my @args; 183 | eval { 184 | my $double_minus; 185 | for (@ARGV) { 186 | if ($double_minus) { 187 | push @args, $_; 188 | } 189 | elsif ($_ eq '--') { 190 | $double_minus = 1; 191 | } 192 | elsif (/^--(no-)?([^=]*)(?:=(.*))?$/) { 193 | my ($no, $name, $val) = ($1, $2, $3); 194 | if (exists $custom_options{$name}) { 195 | # We already processed this 196 | } 197 | elsif (my $opt = $builtin_options{$name}) { 198 | if (ref $opt->{ref} eq 'SCALAR') { 199 | ${$opt->{ref}} = $val // ($no ? 0 : 1); 200 | } 201 | else { 202 | $opt->{ref}($val // ($no ? 0 : 1)); 203 | } 204 | } 205 | else { 206 | say "\e[31m✗\e[0m Unrecognized option --$name. Try --help to see available options."; 207 | exit 1; 208 | } 209 | } 210 | else { 211 | push @args, $_; 212 | } 213 | } 214 | }; 215 | if ($@) { 216 | warn $@ unless "$@" eq "\n"; 217 | say "\e[31m✗\e[0m Nothing was done due to command-line error."; 218 | exit 1; 219 | } 220 | # Make a plan to build the selected or default targets 221 | my $plan = init_plan(); 222 | eval { 223 | if (@args) { 224 | grep plan_target($plan, rel2abs($_, $original_base)), @args; 225 | } 226 | elsif ($defaults) { 227 | grep plan_target($plan, $_), @$defaults; 228 | } 229 | else { 230 | plan_rule($plan, $rules[0]); 231 | } 232 | }; 233 | if ($@) { 234 | warn $@ unless "$@" eq "\n"; 235 | say "\e[31m✗\e[0m Nothing was done due to error."; 236 | exit 1; 237 | } 238 | # Execute the plan. 239 | my @program = @{$plan->{program}}; 240 | if (not @rules) { 241 | say "\e[32m✓\e[0m Nothing was done because no rules have been declared."; 242 | } 243 | elsif (not grep defined($_->{recipe}), @program) { 244 | say "\e[32m✓\e[0m All up to date."; 245 | } 246 | else { 247 | eval { 248 | if ($jobs > 1) { 249 | my %jobs; 250 | $SIG{INT} = sub { 251 | kill 2, $_ for keys %jobs; 252 | die "interrupted\n"; 253 | }; 254 | $SIG{__DIE__} = sub { 255 | kill 2, $_ for keys %jobs; 256 | die $_[0]; 257 | }; 258 | my $do_wait; 259 | $do_wait = sub { 260 | keys(%jobs) > 0 or do { 261 | die "Tried to wait on no jobs -- internal planner error?\n", join "\n", map show_rule($_), @program; 262 | }; 263 | my $child = wait; 264 | if ($child == -1) { 265 | die "Unexpectedly lost children!\n"; 266 | } 267 | if ($?) { 268 | print readline($jobs{$child}{output}); 269 | close $jobs{$child}{output}; 270 | delete $jobs{$child}; 271 | # Wait for more children 272 | $do_wait->() if %jobs; 273 | die "\n"; 274 | } 275 | $jobs{$child}{done} = 1; 276 | print readline($jobs{$child}{output}); 277 | close $jobs{$child}{output}; 278 | delete $jobs{$child}; 279 | }; 280 | while (@program || %jobs) { 281 | $do_wait->() if keys(%jobs) >= $jobs; 282 | my $rule; 283 | for (0..$#program) { 284 | next unless $program[$_]{options}{fork}; 285 | # Don't run program if its deps haven't been finished 286 | next if grep !$_->{done}, @{$program[$_]{follow}}; 287 | $rule = splice @program, $_, 1; 288 | last; 289 | } 290 | if (defined $rule) { 291 | chdir $rule->{base}; 292 | status $rule->{config} ? "⚒ " : "⚙ ", show_rule($rule); 293 | delazify($rule); 294 | pipe($rule->{output}, my $OUTPUT) or die "pipe failed: $!\n"; 295 | binmode $rule->{output}, ':utf8'; 296 | binmode $OUTPUT, ':utf8'; 297 | if (my $child = fork // die "Failed to fork: $!\n") { 298 | # parent 299 | $jobs{$child} = $rule; 300 | } 301 | else { # child 302 | # Don't fall out of the eval {} out there 303 | $SIG{__DIE__} = sub { warn @_; exit 1; }; 304 | close STDOUT; 305 | open STDOUT, '>&', $OUTPUT or die "Could not reopen STDOUT: $!\n"; 306 | close STDERR; 307 | open STDERR, '>&', $OUTPUT or die "Could not reopen STDERR: $!\n"; 308 | do_rule($rule); 309 | exit 0; 310 | } 311 | close $OUTPUT; 312 | } 313 | elsif (%jobs) { 314 | $do_wait->(); 315 | } 316 | else { # Do a non-parallel job 317 | my $rule = shift @program; 318 | chdir $rule->{base}; 319 | status $rule->{config} ? "⚒ " : "⚙ ", show_rule($rule); 320 | delazify($rule); 321 | do_rule($rule); 322 | $rule->{done} = 1; 323 | } 324 | } 325 | } 326 | else { 327 | for my $rule (@program) { 328 | chdir $rule->{base}; 329 | status $rule->{config} ? "⚒ " : "⚙ ", show_rule($rule); 330 | delazify($rule); 331 | do_rule($rule); 332 | } 333 | } 334 | }; 335 | if ("$@" eq "interrupted\n") { 336 | say "\e[31m✗\e[0m Interrupted."; 337 | exit 1; 338 | } 339 | elsif ($@) { 340 | warn $@ unless "$@" eq "\n"; 341 | say "\e[31m✗\e[0m Did not finish due to error."; 342 | exit 1; 343 | } 344 | if ($simulate) { 345 | say "\e[32m✓\e[0m Simulation finished."; 346 | } 347 | elsif ($touch) { 348 | say "\e[32m✓\e[0m File modtimes updated."; 349 | } 350 | else { 351 | say "\e[32m✓\e[0m Done."; 352 | } 353 | } 354 | exit 0; 355 | } 356 | 1; 357 | } 358 | 359 | # Fuss if make wasn't called 360 | END { 361 | if ($? == 0 and !$make_was_called) { 362 | my $file = abs2rel($current_file, $original_base); 363 | warn "\e[31m✗\e[0m $file did not end with 'make;'\n"; 364 | } 365 | } 366 | 367 | # RULES AND DEPENDENCIES 368 | 369 | sub create_rule { 370 | my ($to, $from, $recipe, $options, $package, $file, $line) = @_; 371 | ref $recipe eq 'CODE' or !defined $recipe or croak "Non-code recipe given to rule"; 372 | my $rule = { 373 | caller_file => $current_file, 374 | caller_line => $line, 375 | base => cwd, 376 | to => [arrayify($to)], 377 | from => lazify($from), 378 | deps => undef, # Generated from from 379 | recipe => $recipe, 380 | options => $options, 381 | check_stale => undef, 382 | config => 0, 383 | # Intrusive state for planning and execution phases 384 | planned => 0, 385 | follow => [], 386 | done => 0, 387 | output => undef, 388 | }; 389 | push @rules, $rule; 390 | for (@{$rule->{to}}) { 391 | push @{$targets{rel2abs($_)}}, $rule; 392 | } 393 | } 394 | 395 | sub rule ($$$;$) { 396 | create_rule($_[0], $_[1], $_[2], $_[3] // {}, caller); 397 | } 398 | 399 | sub phony ($;$$$) { 400 | my ($to, $from, $recipe, $options) = @_; 401 | for (arrayify($to)) { 402 | $phonies{rel2abs($_)} = 1; 403 | } 404 | create_rule($to, $from, $recipe, $options // {}, caller) if defined $from; 405 | } 406 | 407 | sub subdep ($;$) { 408 | my ($to, $from) = @_; 409 | if (ref $to eq 'CODE') { # Auto 410 | push @auto_subdeps, { 411 | base => cwd, 412 | code => $to 413 | }; 414 | } 415 | elsif (defined $from) { # Manual 416 | my $subdep = { 417 | base => cwd, 418 | to => [arrayify($to)], 419 | from => lazify($from), 420 | }; 421 | for (@{$subdep->{to}}) { 422 | push @{$subdeps{rel2abs($_)}}, $subdep; 423 | } 424 | } 425 | else { 426 | croak 'subdep must be called with two arguments unless the first is a CODE ref'; 427 | } 428 | } 429 | 430 | sub defaults { 431 | push @$defaults, map rel2abs($_), @_; 432 | } 433 | 434 | sub targets { 435 | return keys %targets; 436 | } 437 | 438 | sub exists_or_target { 439 | return (-e $_[0] or exists $targets{rel2abs($_[0])}); 440 | } 441 | 442 | sub arrayify { 443 | return ref $_[0] eq 'ARRAY' ? @{$_[0]} : $_[0]; 444 | } 445 | sub lazify { 446 | my ($dep) = @_; 447 | return ref $dep eq 'CODE' ? $dep : [arrayify($dep)]; 448 | } 449 | sub delazify { 450 | # Works on subdeps too 451 | my ($rule) = @_; 452 | if (ref $rule->{from} eq 'CODE') { 453 | $rule->{from} = [$rule->{from}(@{$rule->{to}})]; 454 | } 455 | } 456 | 457 | sub get_auto_subdeps { 458 | return map { 459 | my $target = $_; 460 | @{$autoed_subdeps{$target} //= [ 461 | map { 462 | chdir $_->{base}; 463 | my @got = $_->{code}($target); 464 | if (grep !defined, @got) { 465 | warn "Warning: function that generated auto subdeps for $target returned an undefined value\n"; 466 | } 467 | realpaths(grep defined, @got); 468 | } @auto_subdeps 469 | ]} 470 | } @_; 471 | } 472 | sub push_new { 473 | my ($deps, @new) = @_; 474 | push @$deps, grep { 475 | my $d = $_; 476 | not grep $d eq $_, @$deps; 477 | } @new; 478 | } 479 | sub resolve_deps { 480 | my ($rule) = @_; 481 | return if defined $rule->{deps}; 482 | # Get the realpaths of all dependencies and their subdeps 483 | chdir $rule->{base}; 484 | delazify($rule); 485 | # Depend on the build script and this module too. 486 | my @deps = (realpaths(@{$rule->{from}}), $rule->{caller_file}, $this_file); 487 | # Using this style of loop because @deps will keep expanding. 488 | for (my $i = 0; $i < @deps; $i++) { 489 | defined $deps[$i] or die "Undef dependency given to rule at $rule->{caller_file} line $rule->{caller_line}\n"; 490 | push_new(\@deps, get_auto_subdeps($deps[$i])); 491 | for my $subdep (@{$subdeps{$deps[$i]}}) { 492 | chdir $subdep->{base}; 493 | delazify($subdep); 494 | push_new(\@deps, realpaths(@{$subdep->{from}})); 495 | } 496 | } 497 | chdir $rule->{base}; 498 | $rule->{deps} = [@deps]; 499 | } 500 | 501 | sub show_rule ($) { 502 | if ($verbose) { 503 | resolve_deps($_[0]); 504 | return "@{$_[0]{to}} ← " . join ' ', map abs2rel($_), @{$_[0]{deps}}; 505 | } 506 | else { 507 | my @froms = grep !$configs{rel2abs($_)}, @{$_[0]{from}}; 508 | @froms or @froms = @{$_[0]{from}}; 509 | return "@{$_[0]{to}} ← " . join ' ', @froms; 510 | } 511 | } 512 | sub debug_rule ($) { 513 | return "$_[0]{caller_file}:$_[0]{caller_line}: " . directory_prefix($_[0]{base}) . show_rule($_[0]); 514 | } 515 | 516 | sub target_is_default ($) { 517 | if (defined $defaults) { 518 | my $is = grep $_ eq $_[0], @$defaults; 519 | return $is; 520 | } 521 | else { 522 | my $rule = $rules[0]; 523 | defined $rule or return 0; 524 | for (@{$rule->{to}}) { 525 | if (rel2abs($_, $rule->{base}) eq $_[0]) { 526 | return 1; 527 | } 528 | } 529 | return 0; 530 | } 531 | } 532 | 533 | # CONFIGURATION 534 | 535 | sub corrupted { return "\e[31m✗\e[0m Corrupted config file $_[0]$_[1]; please delete it and try again.\n"; } 536 | sub read_config { 537 | my ($file, $str) = @_; 538 | my ($val, $rest) = read_thing($file, $str); 539 | $rest eq '' or die corrupted($file, " (extra junk at end)"); 540 | return $val; 541 | } 542 | sub read_thing { 543 | my ($file, $s) = @_; 544 | my $string_rx = qr/"((?:\\\\|\\"|[^\\"])*)"/s; 545 | if ($s =~ s/^\{//) { # Hash 546 | my %r; 547 | unless ($s =~ s/^}//) { 548 | while (1) { 549 | $s =~ s/^$string_rx:// 550 | or die corrupted($file, " (didn't find key after {)"); 551 | my $key = $1; 552 | $key =~ s/\\([\\"])/$1/g; 553 | (my $val, $s) = read_thing($file, $s); 554 | $r{$key} = $val; 555 | next if $s =~ s/^,//; 556 | last if $s =~ s/^}//; 557 | die corrupted($file, " (unrecognized char in hash)"); 558 | } 559 | } 560 | return (\%r, $s); 561 | } 562 | elsif ($s =~ s/^\[//) { # Array 563 | my @r; 564 | unless ($s =~ s/^]//) { 565 | while (1) { 566 | (my $val, $s) = read_thing($file, $s); 567 | push @r, $val; 568 | next if $s =~ s/^,//; 569 | last if $s =~ s/^]//; 570 | die corrupted($file, " (unrecognized char in array)"); 571 | } 572 | } 573 | return (\@r, $s); 574 | } 575 | elsif ($s =~ /^"/) { # String 576 | $s =~ s/^$string_rx// 577 | or die corrupted($file, " (malformed string or something)"); 578 | my $r = $1; 579 | $r =~ s/\\([\\"])/$1/g; 580 | return ($r, $s); 581 | } 582 | elsif ($s =~ s/^null//) { 583 | return (undef, $s); 584 | } 585 | else { 586 | die corrupted($file, " (unknown character in term position)"); 587 | } 588 | } 589 | sub show_thing { 590 | my ($thing) = @_; 591 | if (not defined $thing) { 592 | return 'null'; 593 | } 594 | elsif (ref $thing eq 'HASH') { 595 | my $r = '{'; 596 | $r .= join ',', map { 597 | my $k = $_; 598 | $k =~ s/([\\"])/\\$1/g; 599 | "\"$k\":" . show_thing($thing->{$_}); 600 | } sort keys %$thing; 601 | return $r . '}'; 602 | } 603 | elsif (ref $thing eq 'ARRAY') { 604 | return '[' . (join ',', map show_thing($_), @$thing) . ']'; 605 | } 606 | elsif (ref $thing eq '') { 607 | $thing =~ s/([\\"])/\\$1/g; 608 | return "\"$thing\""; 609 | } 610 | else { 611 | croak "Cannot serialize object of ref type '" . ref $thing . "'"; 612 | } 613 | } 614 | 615 | sub config { 616 | my ($filename, $var, $routine) = @_; 617 | grep ref $var eq $_, qw(SCALAR ARRAY HASH) 618 | or croak "config's second argument is not a SCALAR, ARRAY, or HASH ref (It's a " . ref($var) . " ref)"; 619 | !defined $routine or ref $routine eq 'CODE' 620 | or croak "config's third argument is not a CODE ref"; 621 | my ($package, $file, $line) = caller; 622 | my $rule = { 623 | base => cwd, 624 | to => [$filename], 625 | from => [], 626 | deps => undef, 627 | check_stale => sub { stale_config($filename, $var); }, 628 | recipe => sub { gen_config($filename, $var, $routine); }, 629 | caller_file => $current_file, 630 | caller_line => $line, 631 | config => 1, 632 | options => {}, 633 | stale => 0, 634 | # Intrusive state for planning and execution phases 635 | planned => 0, 636 | follow => [], 637 | executed => 0, 638 | }; 639 | push @rules, $rule; 640 | push @{$targets{rel2abs($filename)}}, $rule; 641 | $configs{rel2abs($filename)} = 1; 642 | # Read into $var immediately 643 | if (-e $filename) { 644 | my $str = slurp_utf8($filename); 645 | chomp $str; 646 | my $val = read_config($filename, $str); 647 | if (ref $var eq 'SCALAR') { 648 | $$var = $val; 649 | } 650 | elsif (ref $var eq 'ARRAY') { 651 | ref $val eq 'ARRAY' or die corrupted($filename, " (expected ARRAY, got " . ref($val) . ")"); 652 | @$var = @$val; 653 | } 654 | elsif (ref $var eq 'HASH') { 655 | ref $val eq 'HASH' or die corrupted($filename, " (expected HASH, got " . ref($val) . ")"); 656 | %$var = %$val; 657 | } 658 | } 659 | } 660 | 661 | sub stale_config ($$) { 662 | my ($filename, $var) = @_; 663 | return 1 unless -e $filename; 664 | my $old = slurp_utf8($filename); 665 | chomp $old; 666 | my $new = show_thing(ref $var eq 'SCALAR' ? $$var : $var); 667 | return $new ne $old; 668 | } 669 | 670 | sub gen_config ($$$) { 671 | my ($filename, $var, $routine) = @_; 672 | $routine->() if defined $routine; 673 | my $new = show_thing(ref $var eq 'SCALAR' ? $$var : $var); 674 | splat_utf8($filename, "$new\n"); 675 | } 676 | 677 | sub option ($$;$) { 678 | my ($name, $ref, $desc) = @_; 679 | if (ref $name eq 'ARRAY') { 680 | &option($_, $ref, $desc) for @$name; 681 | return; 682 | } 683 | elsif (ref $ref eq 'SCALAR' or ref $ref eq 'CODE') { 684 | $custom_options{$name} = { 685 | ref => $ref, 686 | desc => $desc, 687 | custom => 1 688 | }; 689 | delete $builtin_options{$name}; 690 | } 691 | else { 692 | croak "Second argument to option is not a SCALAR or CODE ref"; 693 | } 694 | # Immediately find option. 695 | unless (%options) { 696 | for (@ARGV) { 697 | if ($_ eq '--') { 698 | last; 699 | } 700 | elsif (/^--no-([^=]+)$/) { 701 | $options{$1} = 0; 702 | } 703 | elsif (/^--([^=]+)(?:=(.*))?$/) { 704 | $options{$1} = $2 // 1; 705 | } 706 | } 707 | } 708 | if (exists $options{$name}) { 709 | if (ref $ref eq 'SCALAR') { 710 | $$ref = $options{$name}; 711 | } 712 | elsif (ref $ref eq 'CODE') { 713 | $ref->($options{$name}); 714 | } 715 | } 716 | } 717 | 718 | %builtin_options = ( 719 | help => { 720 | ref => sub { 721 | my (%nonfinal, %suggested, %nonsuggested, %default); 722 | for my $rule (@rules) { 723 | resolve_deps($rule); 724 | $nonfinal{$_} = 1 for @{$rule->{deps}}; 725 | if (defined $rule->{options}{suggested}) { 726 | for (@{$rule->{to}}) { 727 | if ($rule->{options}{suggested}) { 728 | $suggested{rel2abs($_, $rule->{base})} = 1; 729 | } 730 | else { 731 | $nonsuggested{rel2abs($_, $rule->{base})} = 1; 732 | } 733 | } 734 | } 735 | } 736 | if (defined $defaults) { 737 | for (@$defaults) { 738 | $default{$_} = 1; 739 | } 740 | } 741 | elsif (@rules) { 742 | for (@{$rules[0]{to}}) { 743 | $default{rel2abs($_, $rules[0]{base})} = 1; 744 | } 745 | } 746 | # Gradually narrow down criteria for suggestion 747 | my @suggested = grep { 748 | ($default{$_} or $phonies{$_} or !$nonfinal{$_}) and not $nonsuggested{$_} 749 | } targets; 750 | if (@suggested > 12) { 751 | @suggested = grep { 752 | $default{$_} or !$nonfinal{$_} or $suggested{$_} 753 | } @suggested; 754 | if (@suggested > 12) { 755 | @suggested = grep { 756 | $default{$_} or $phonies{$_} or $suggested{$_} 757 | } @suggested; 758 | if (@suggested > 12) { 759 | @suggested = grep { 760 | $default{$_} or $suggested{$_} 761 | } @suggested; 762 | } 763 | } 764 | } 765 | say "\e[31m✗\e[0m Usage: $0 "; 766 | if (%custom_options) { 767 | say "Custom options:"; 768 | for (sort keys %custom_options) { 769 | say " ", $custom_options{$_}{desc} // "--$_"; 770 | } 771 | } 772 | if (%builtin_options) { 773 | say "General options:"; 774 | for (sort keys %builtin_options) { 775 | say " $builtin_options{$_}{desc}"; 776 | } 777 | } 778 | say "Suggested targets:"; 779 | for (sort @suggested) { 780 | say " ", abs2rel($_), target_is_default($_) ? " (default)" : ""; 781 | } 782 | exit 1; 783 | }, 784 | desc => "--help - show this help message", 785 | custom => 0 786 | }, 787 | 'list-targets' => { 788 | ref => sub { 789 | say "\e[31m✗\e[0m All targets:"; 790 | for (sort keys %targets) { 791 | say " ", abs2rel($_), target_is_default($_) ? " (default)" : ""; 792 | } 793 | exit 1; 794 | }, 795 | desc => "--list-targets - list all declared targets", 796 | custom => 0 797 | }, 798 | force => { 799 | ref => \$force, 800 | desc => '--force - Skip modification time checks and always run the rules', 801 | custom => 0 802 | }, 803 | verbose => { 804 | ref => \$verbose, 805 | desc => '--verbose - Show sub-dependencies and shell commands', 806 | custom => 0 807 | }, 808 | simulate => { 809 | ref => \$simulate, 810 | desc => '--simulate - Show rules that would be run but don\'t run them', 811 | custom => 0 812 | }, 813 | touch => { 814 | ref => \$touch, 815 | desc => '--touch - Update existing files\' modtimes instead of running the rules', 816 | custom => 0 817 | }, 818 | jobs => { 819 | ref => \$jobs, 820 | desc => '--jobs= - Run this many parallel jobs if the rules support it', 821 | custom => 0 822 | }, 823 | ); 824 | 825 | # SYSTEM INTERACTION 826 | 827 | sub cwd () { 828 | return $ENV{PWD}; 829 | } 830 | sub chdir ($) { 831 | my $new = rel2abs($_[0]); 832 | if ($new ne cwd) { 833 | CORE::chdir $new or die "Failed to chdir to $new: $!\n"; 834 | $ENV{PWD} = $new; 835 | } 836 | } 837 | sub fexists { 838 | defined $_[0] or Carp::confess "Undefined argument passed to fexists."; 839 | return 0 if $phonies{$_[0]}; 840 | return -e $_[0]; 841 | } 842 | sub modtime { 843 | return $modtimes{$_[0]} //= (fexists($_[0]) ? (stat $_[0])[9] : 0); 844 | } 845 | 846 | sub show_command (@) { 847 | my (@command) = @_; 848 | for (@command) { 849 | if (/\s/) { 850 | $_ =~ s/'/'\\''/g; 851 | $_ = "'$_'"; 852 | } 853 | } 854 | return "\e[96m" . (join ' ', @command) . "\e[0m"; 855 | } 856 | 857 | sub run (@) { 858 | if ($verbose) { 859 | say show_command(@_); 860 | } 861 | system(@_) == 0 or do { 862 | my @command = @_; 863 | # As per perldoc -f system 864 | if ($? == -1) { 865 | status("☢ Couldn't start command: $!"); 866 | } 867 | elsif (($? & 127) == 2) { 868 | die "interrupted\n"; 869 | } 870 | elsif ($? & 127) { 871 | status(sprintf "☢ Command died with signal %d, %s coredump", 872 | ($? & 127), ($? & 128) ? 'with' : 'without'); 873 | } 874 | else { 875 | status(sprintf "☢ Command exited with value %d", $? >> 8); 876 | } 877 | die status("☢ Failed command: " . show_command(@_)); 878 | } 879 | } 880 | 881 | sub realpaths (@) { 882 | return map rel2abs($_), @_; 883 | } 884 | 885 | sub canonpath { 886 | $_[0] eq '.' and return $_[0]; 887 | if (index($_[0], '\\') == -1 888 | and index($_[0], '//') == -1 889 | and index($_[0], '/.') == -1 890 | and index($_[0], '/', length($_[0])-1) != length($_[0])-1) { 891 | return $_[0]; 892 | } 893 | my $p = $_[0]; 894 | $p =~ tr/\\/\//; 895 | 1 while $p =~ s/\/(?:\.?|(?!\.\.\/)[^\/]*\/\.\.)(?=\/|$)//; 896 | return $p; 897 | } 898 | 899 | sub rel2abs { 900 | my ($rel, $base) = @_; 901 | $base //= cwd; 902 | return canonpath(rindex($rel, '/', 0) == 0 ? $rel : "$base/$rel"); 903 | } 904 | sub abs2rel { 905 | my ($abs, $base) = @_; 906 | $abs = canonpath($abs); 907 | rindex($abs, '/', 0) == 0 or return $abs; 908 | $base = defined($base) ? canonpath($base) : cwd; 909 | if ($abs eq $base) { 910 | return '.'; 911 | } 912 | if (rindex($abs, $base . '/', 0) == 0) { 913 | return substr($abs, length($base) + 1); 914 | } 915 | return $abs; 916 | } 917 | 918 | sub iofail { $_[0] or croak $_[1]; undef } 919 | 920 | sub slurp { 921 | my ($file, $bytes, $fail) = @_; 922 | $fail //= 1; 923 | open my $F, '<', $file or return iofail $fail, "Failed to open $file for reading: $! in call to slurp"; 924 | my $r; 925 | if (defined $bytes) { 926 | defined read($F, $r, $bytes) or return iofail $fail, "Failed to read $file: $! in call to slurp"; 927 | } 928 | else { 929 | local $/; $r = <$F>; 930 | defined $r or return $fail, "Failed to read $file: $! in call to slurp"; 931 | } 932 | close $F or return $fail, "Failed to clode $file: $! in call to slurp"; 933 | return $r; 934 | } 935 | sub splat { 936 | my ($file, $string, $fail) = @_; 937 | $fail //= 1; 938 | defined $string or return iofail $fail, "Cannot splat undef to $file"; 939 | open my $F, '>', $file or return iofail $fail, "Failed to open $file for writing: $! in call to splat"; 940 | print $F $string or return iofail $fail, "Failed to write to $file: $! in call to splat"; 941 | close $F or return iofail $fail, "Failed to close $file: $! in call to close"; 942 | } 943 | sub slurp_utf8 { 944 | require Encode; 945 | return Encode::decode_utf8(slurp(@_)); 946 | } 947 | sub splat_utf8 { 948 | require Encode; 949 | splat($_[0], Encode::encode_utf8($_[1]), $_[2]); 950 | } 951 | 952 | sub which { 953 | my ($cmd) = @_; 954 | for (split /[:;]/, $ENV{PATH}) { 955 | my $f = "$_/$cmd"; 956 | return $f if -x $f; 957 | if (exists $ENV{PATHEXT}) { 958 | for my $ext (split /;/, $ENV{PATHEXT}) { 959 | my $f = "$_/$cmd$ext"; 960 | return $f if -x $f; 961 | } 962 | } 963 | } 964 | return undef; 965 | } 966 | 967 | # PLANNING 968 | 969 | sub init_plan { 970 | return { # We had and might have more real stuff here 971 | stack => [], 972 | program => [] 973 | }; 974 | } 975 | 976 | sub plan_target { 977 | my ($plan, $target) = @_; 978 | # Make sure the file exists or there's a rule for it 979 | unless ($targets{$target} or fexists($target)) { 980 | my $rel = abs2rel($target, $original_base); 981 | my $mess = "☢ Cannot find or make $rel ($target)" . (@{$plan->{stack}} ? ", required by\n" : "\n"); 982 | for my $rule (reverse @{$plan->{stack}}) { 983 | $mess .= "\t" . debug_rule($rule) . "\n"; 984 | } 985 | die status($mess); 986 | } 987 | # In general, there should be only rule per target, but there can be more. 988 | return grep plan_rule($plan, $_), @{$targets{$target}}; 989 | } 990 | 991 | sub plan_rule { 992 | my ($plan, $rule) = @_; 993 | # Register dependency for parallel scheduling. 994 | if (@{$plan->{stack}}) { 995 | push @{$plan->{stack}[-1]{follow}}, $rule; 996 | } 997 | # detect loops 998 | if (not defined $rule->{planned}) { 999 | my $mess = "☢ Dependency loop\n"; 1000 | for my $old (reverse @{$plan->{stack}}) { 1001 | $mess .= "\t" . debug_rule($old) . "\n"; 1002 | die status($mess) if $rule eq $old; # reference compare 1003 | } 1004 | Carp::confess $mess . "\t...oh wait, false alarm. Which means there's a bug in make.pm.\nDetected"; 1005 | } 1006 | elsif ($rule->{planned}) { 1007 | return $rule->{stale}; # Already planned 1008 | } 1009 | # Commit to planning 1010 | push @{$plan->{stack}}, $rule; 1011 | $rule->{planned} = undef; # Mark that we're currently planning this 1012 | 1013 | resolve_deps($rule); 1014 | # always recurse to plan_target 1015 | my $stale = grep plan_target($plan, $_), @{$rule->{deps}}; 1016 | # chdir precisely now. 1017 | chdir $rule->{base}; 1018 | $stale ||= $force; 1019 | $stale ||= $rule->{check_stale}() if defined $rule->{check_stale}; 1020 | $stale ||= grep { 1021 | my $abs = rel2abs($_); 1022 | !fexists($abs) or grep modtime($abs) < modtime($_), @{$rule->{deps}}; 1023 | } @{$rule->{to}}; 1024 | if ($stale) { 1025 | push @{$plan->{program}}, $rule; 1026 | } 1027 | else { 1028 | $rule->{done} = 1; # Don't confuse parallel scheduler. 1029 | } 1030 | # Done planning this rule 1031 | $rule->{planned} = 1; 1032 | $rule->{stale} = $stale; 1033 | pop @{$plan->{stack}}; 1034 | return $stale; 1035 | } 1036 | 1037 | # RUNNING THIS FILE DIRECTLY 1038 | 1039 | # Generate a make.pl scaffold. 1040 | if ($^S == 0) { # We've been called directly 1041 | $make_was_called = 1; # Not really but supresses warning 1042 | if (@ARGV > 1 or (defined $ARGV[0] and $ARGV[0] =~ /-?-h(?:elp)?/)) { 1043 | say "\e[31m✗\e[0m Usage: perl $0 "; 1044 | exit 1; 1045 | } 1046 | my $loc = defined $ARGV[0] ? canonpath($ARGV[0]) : cwd; 1047 | $loc = "$loc/make.pl" if -d $loc; 1048 | if (-e $loc) { 1049 | say "\e[31m✗\e[0m Did not generate $loc because it already exists."; 1050 | exit 1; 1051 | } 1052 | my $dir = $loc =~ /^(.*)\/[^\/]*$/ ? $1 : cwd; 1053 | my $path_to_pm = abs2rel(rel2abs(__FILE__), $dir); 1054 | $path_to_pm =~ s/\/?MakePl\.pm$//; 1055 | $path_to_pm =~ s/'/\\'/g; 1056 | my $pathext = $path_to_pm eq '' ? '' : ".'/$path_to_pm'"; 1057 | local $/; 1058 | my $out = ; 1059 | $out =~ s/◀PATHEXT▶/$pathext/; 1060 | open my $MAKEPL, '>:utf8', $loc or die "Failed to open $loc for writing: $!\n"; 1061 | print $MAKEPL $out or die "Failed to write to $loc: $!\n"; 1062 | chmod 0755, $MAKEPL or warn "Failed to chmod $loc: $!\n"; 1063 | close $MAKEPL or die "Failed to close $loc: $!\n"; 1064 | say "\e[32m✓\e[0m Generated $loc."; 1065 | } 1066 | 1067 | 1; 1068 | 1069 | __DATA__ 1070 | #!/usr/bin/perl 1071 | use lib do {__FILE__ =~ /^(.*)[\/\\]/; ($1||'.')◀PATHEXT▶}; 1072 | use MakePl; 1073 | 1074 | # Sample rules 1075 | rule \$program, \$main, sub { 1076 | run "gcc -Wall \\Q\$main\\E -o \\Q\$program\\E"; 1077 | }; 1078 | rule 'clean', [], sub { unlink \$program; }; 1079 | 1080 | make; 1081 | --------------------------------------------------------------------------------