path: root/SHARC/Instruction.hs

{-
  This file is part of shark-disassembler.

  Copyright (C) 2014 Ricardo Wurmus

  This program is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with this program.  If not, see <http://www.gnu.org/licenses/>.
-}

{-# LANGUAGE QuasiQuotes #-}

module SHARC.Instruction where

import           SHARC.Types
import           SHARC.Word48
import           SHARC.ComputeField

import           Language.Literals.Binary
import           Data.Bits ((.&.), (.|.), xor, shift, shiftL, shiftR, testBit)
import           Data.Word
import           Data.List (intercalate)
import           Text.Printf (printf)
import           Data.Binary.Get


data Instruction = Type1 Word48
                 | Type2 Cond ComputeField
                 | Type3
                   Cond
                   ComputeField
                   Ireg
                   Mreg
                   Ureg
                   AccessType
                   Memory
                   WordAccess
                   Update
                 | Type4
                   Cond
                   ComputeField
                   Word8 {-6 bit data-}
                   Dreg
                   Ireg
                   AccessType
                   Memory
                   Update
                 | Type5Transfer
                   Cond
                   ComputeField
                   Ureg {-source register, 7 bit-}
                   Ureg {-destination register, 7 bit-}
                 | Type5Swap
                   Cond
                   ComputeField
                   Dreg {-x, 4 bit-}
                   Dreg {-y, 4 bit-}
                 | Type6WithDataAccess -- with data access
                   Cond
                   ImmediateShift
                   Dreg
                   Ireg
                   Mreg
                   AccessType
                   Memory
                 | Type6WithoutDataAccess -- without data access
                   Cond
                   ImmediateShift
                 | Type7 Word48
                 | Type8
                   BranchType
                   Cond
                   Address24
                   Bool {-loop abort-}
                   Bool {-branch delayed or not-}
                   Bool {-clear interrupt-}
                 | Type9 Word48
                 | Type10 Word48
                 | Type11
                   ReturnSource {- subroutine or interrupt -}
                   Cond
                   Bool {-return delayed or not-}
                   Bool {-else clause used or not-}
                   Bool {-loop reentry modifier specified or not-}
                   ComputeField
                 | Type12Ureg Ureg Address24
                 | Type12Immediate Word16 Address24
                 | Type13 TermCond Address24
                 | Type14 AccessType Memory WordAccess Ureg Address32
                 | Type15 Word48
                 | Type16 Word48
                 | Type17 Ureg Word32
                 | Type18 BitOp Sreg Word32
                 | Type19 Word48
                 | Type20
                   ([String], [String]) {-list of pushes and pops-}
                   Bool    {-cause a cash flush-}
                 | NOP  -- Type 21
                 | IDLE -- Type 22
                 | Type25 Word48
                 | UndefinedInstruction Word48
                 | InvalidInstruction Word48

instance Show Instruction where
  show NOP  = "NOP"
  show IDLE = "IDLE"
  show (UndefinedInstruction w) = "!! UNDEFINED: " ++ show w
  show (InvalidInstruction w)   = "!! INVALID: " ++ show w
  show t = let f = printf "%-46s; %s" in case t of
    Type1 w                  -> f (showType1 w) "type 1"
    Type2{}                  -> f (showType2 t) "type 2"
    Type3{}                  -> f (showType3 t) "type 3"
    Type4{}                  -> f (showType4 t) "type 4"
    Type5Transfer{}          -> f (showType5 t) "type 5 (transfer)"
    Type5Swap{}              -> f (showType5 t) "type 5 (swap)"
    Type6WithDataAccess{}    -> f (showType6 t) "type 6 (with data access)"
    Type6WithoutDataAccess{} -> f (showType6 t) "type 6 (without data access)"
    Type7 w                  -> f (showType7 w) "type 7"
    Type8{}                  -> f (showType8 t) "type 8"
    Type9 w                  -> f (showType9 w) "type 9"
    Type10 w                 -> f (showType10 w) "type 10"
    Type11{}                 -> f (showType11 t) "type 11"
    Type12Immediate{}        -> f (showType12 t) "type 12 (immediate)"
    Type12Ureg{}             -> f (showType12 t) "type 12 (from ureg)"
    Type13{}                 -> f (showType13 t) "type 13"
    Type14{}                 -> f (showType14 t) "type 14"
    Type15 w                 -> f (showType15 w) "type 15"
    Type16 w                 -> f (showType16 w) "type 16"
    Type17{}                 -> f (showType17 t) "type 17"
    Type18{}                 -> f (showType18 t) "type 18"
    Type19 w                 -> f (showType19 w) "type 19"
    Type20{}                 -> f (showType20 t) "type 20"
    Type25 w                 -> f (showType25 w) "type 25"


showType1 w = "  TODO: " ++ show w

showType2 (Type2 cond cf) = show cond ++ show cf

showType3 (Type3 cond compute ireg mreg ureg rw mem wa up) =
  show cond ++ show compute ++ assignment ++ flag
  where
    imOrder = case up of
               PreModify -> [show mreg, show ireg]
               PostModify -> [show ireg, show mreg]
    pair = "(" ++ intercalate ", " imOrder ++ ")"
    mem' = case mem of
      Prog -> "PM" ++ pair
      Data -> "DM" ++ pair
    assignment = case rw of
      Read  -> show ureg ++ "=" ++ mem'
      Write -> mem' ++ "=" ++ show ureg
    flag = case wa of
      LW -> " (LW)"
      _ -> ""

showType4 (Type4 cond compute dat dreg ireg rw mem up) =
  show cond ++ show compute ++ assignment
  where
    -- print 6 bit data as two's complement
    dat' = if dat `testBit` 5
           then '-' : show (dat `xor` 0x3F)
           else show dat
    order = case up of
      PreModify -> [dat', show ireg]
      PostModify -> [show ireg, dat']
    pair = "(" ++ intercalate ", " order ++ ")"
    mem' = case mem of
      Prog -> "PM" ++ pair
      Data -> "DM" ++ pair
    assignment = case rw of
      Read  -> show dreg ++ "=" ++ mem'
      Write -> mem' ++ "=" ++ show dreg

showType5 (Type5Transfer cond compute src dest) =
  optional ++ sep ++ show dest ++ "=" ++ show src
  where
    optional = show cond ++ show compute
    sep = if optional == "" then "" else ", "
showType5 (Type5Swap cond compute x y) =
  optional ++ sep ++ show x ++ "<->" ++ show y
  where
    optional = show cond ++ show compute
    sep = if optional == "" then "" else ", "

showType6 (Type6WithDataAccess cond shiftField dreg ireg mreg rw mem) =
  show cond ++ show shiftField ++ assignment
  where
    pair = "(" ++ intercalate ", " [show ireg, show mreg] ++ ")"
    mem' = case mem of
      Prog -> "PM" ++ pair
      Data -> "DM" ++ pair
    assignment = case rw of
      Read  -> show dreg ++ "=" ++ mem'
      Write -> mem' ++ "=" ++ show dreg

showType6 (Type6WithoutDataAccess cond shiftField) =
  show cond ++ show shiftField

showType7 w = "  TODO: " ++ show w

-- TODO: if Call, ignore LA and CI
-- TODO: flag handling is ugly
showType8 (Type8 t cond addr a d c) = show cond ++ t' ++ flags
  where
    t' = case t of
      Jump -> "JUMP " ++ show addr
      Call -> "CALL " ++ show addr
    a' = if a then "LA" else ""
    d' = if d then "DB" else ""
    c' = if c then "CI" else ""
    flags = if a || d || c
            then " (" ++ intercalate ", " (filter (/= "") [a', d', c']) ++ ")"
            else ""

showType9 w = "  TODO: " ++ show w

showType10 w = "  TODO: " ++ show w

showType11 (Type11 rs cond d e l cf) = show cond ++ rs' ++ flags ++ elseCompute
  where
    rs' = case rs of
      Subroutine -> "RTS"
      Interrupt  -> "RTI"
    -- TODO: this is ugly
    d' = if d then "DB" else ""
    l' = if l then "LR" else ""
    flags = if d || l
            then " (" ++ intercalate ", " (filter (/= "") [d', l']) ++ ")"
            else ""
    e' = if e then ", ELSE " else ", "
    -- do not print at all if opcode in compute field is empty
    -- TODO: can this be encoded in the type instead of doing an ugly string comparison?
    elseCompute = if show cf == "" then "" else e' ++ show cf

showType12 (Type12Immediate dat reladdr) =
  "LNCTR=" ++ show dat ++ ", DO " ++ show reladdr ++ " UNTIL LCE"
showType12 (Type12Ureg ureg reladdr) =
  "LNCTR=" ++ show ureg ++ ", DO " ++ show reladdr ++ " UNTIL LCE"

showType13 (Type13 term reladdr) =
  "DO " ++ show reladdr ++ " UNTIL " ++ show term

showType14 (Type14 rw mem wa ureg addr) = lhs ++ " = " ++ rhs ++ lwflag
  where
    lwflag = case wa of
              LW -> " (LW)"
              _ -> ""
    memloc = case mem of
              Data -> "DM(" ++ show addr ++ ")"
              Prog -> "PM(" ++ show addr ++ ")"
    lhs = case rw of
           Write -> memloc
           Read  -> show ureg
    rhs = case rw of
           Write -> show ureg
           Read  -> memloc

showType15 w = "  TODO: " ++ show w

showType16 w = "  TODO: " ++ show w

showType17 (Type17 ureg dat) = show ureg ++ " = " ++ printf "0x%08X" dat

showType18 (Type18 bop sreg w) =
  "BIT " ++ show bop ++ " " ++ show sreg ++ " " ++ printf "0x%08X" w

showType19 w = "  TODO: " ++ show w

showType20 (Type20 (pushes,pops) fc) = intercalate ", " (pu ++ po ++ [flush])
  where
    pu = map (\x -> "PUSH " ++ x) pushes
    po = map (\x -> "POP "  ++ x) pops
    flush = if fc then "FLUSH CACHE" else ""

showType25 w = "  TODO: " ++ show w



-- TODO
parseType1 = Type1

parseType2 w = Type2 cond (mkComputeField w)
  where
    cond = mkCond w

parseType3 w = Type3 cond compute ireg mreg ureg rw mem wa up
  where
    w64 = word48ToWord64 w
    cond = mkCond w
    compute = mkComputeField w
    ireg = mkIreg $ w64 `cutMask` [b| 000 0 111 000 00000 000 0000000 0000000 00000000 00000000 |]
    mreg = mkMreg $ w64 `cutMask` [b| 000 0 000 111 00000 000 0000000 0000000 00000000 00000000 |]
    ureg = mkUreg $ w64 `cutMask` [b| 000 0 000 000 00000 000 1111111 0000000 00000000 00000000 |]
    rw   = if w64 `testBit` 31 then Read else Write
    mem  = if w64 `testBit` 32 then Data else Prog
    wa   = if w64 `testBit` 30 then LW else NW
    up   = if w64 `testBit` 44 then PostModify else PreModify

parseType4 w = Type4 cond compute dat dreg ireg rw mem up
  where
    w64 = word48ToWord64 w
    cond = mkCond w
    compute = mkComputeField w
    dat  = w64 `cutMask` 0x0001F8000000
    dreg = mkDreg $ w64 `cutMask` 0x000007800000
    ireg = mkIreg $ w64 `cutMask` [b| 000 0 111 000 00000 000 0000000 0000000 00000000 00000000 |]
    rw   = if w64 `testBit` 39 then Read else Write
    mem  = if w64 `testBit` 40 then Data else Prog
    up   = if w64 `testBit` 38 then PostModify else PreModify

parseType5 w = if w64 `testBit` 43
               then let
                 x = mkDreg $ w64 `cutMask` 0x000007800000
                 y = mkDreg $ w64 `cutMask` 0x03C000000000
                 in Type5Swap cond compute x y
               else let
                 src  = mkUreg $ ((w64 `cutMask` 0x07C000000000) `shiftL` 2) .|. (w64 `cutMask` 0x000180000000)
                 dest = mkUreg $ w64 `cutMask` 0x00003F800000
                 in Type5Transfer cond compute src dest
  where
    w64 = word48ToWord64 w
    cond = mkCond w
    compute = mkComputeField w

parseType6 w = if w64 `testBit` 47
               then let -- with data access
                 dreg = mkDreg $ w64 `cutMask` [b| 0000 000 000 00000 00 0000 1111 0 000000 00000000 0000 0000 |]
                 ireg = mkIreg $ w64 `cutMask` [b| 0000 111 000 00000 00 0000 0000 0 000000 00000000 0000 0000 |]
                 mreg = mkMreg $ w64 `cutMask` [b| 0000 000 111 00000 00 0000 0000 0 000000 00000000 0000 0000 |]
                 rw   = if w64 `testBit` 31 then Read else Write
                 mem  = if w64 `testBit` 32 then Data else Prog
                 in
                  Type6WithDataAccess cond shiftField dreg ireg mreg rw mem
               else -- without data access
                 Type6WithoutDataAccess cond shiftField
  where
    w64 = word48ToWord64 w
    cond = mkCond w
    shiftField = ImmediateShift op dat rn rx
    op  = w64 `cutMask` 0x0000003F0000
    dat = (w64 `cutMask` 0x000078000000) `shiftL` 8 .|. (w64 `cutMask` 0x00000000FF00)
    rn = Dreg $ w64 `cutMask` 0xF0
    rx = Dreg $ w64 `cutMask` 0x0F

-- TODO
parseType7 = Type7

parseType8 :: (Word32 -> Address24) -> Word48 -> Instruction
parseType8 addressConstr w = Type8 t cond addr a d c
  where
    w64 = word48ToWord64 w
    t = if w64 `testBit` 39 then Jump else Call
    cond = mkCond w
    addr = addressConstr $ w64 `cutMask` 0x000000FFFFFF
    a = w64 `testBit` 38 -- loop abort
    d = w64 `testBit` 26 -- branch delayed or not
    c = w64 `testBit` 24 -- clear interrupt

-- TODO
parseType9 = Type9

-- TODO
parseType10 = Type10

parseType11 rs w = Type11 rs cond d e l cf where
    cond = mkCond w
    w64 = word48ToWord64 w
    d = w64 `testBit` 26 -- return delayed
    e = w64 `testBit` 25 -- else clause
    l = w64 `testBit` 24 -- loop reentry
    cf = mkComputeField w

parseType12 w = if w64 `testBit` 40
                then let -- loop counter load from a Ureg
                  ureg = mkUreg $ w64 `cutMask` 0x007F00000000
                  in Type12Ureg ureg reladdr
                else let -- immediate loop counter load
                  dat = w64 `cutMask` 0x00FFFF000000
                  in Type12Immediate dat reladdr
  where
    w64 = word48ToWord64 w
    reladdr = RelAddress24 $ w64 `cutMask` 0xFFFFFF -- lowest 24 bit

parseType13 w = Type13 term reladdr
  where
    w64 = word48ToWord64 w
    term = mkTermCond w
    reladdr = RelAddress24 $ w64 `cutMask` 0xFFFFFF -- lowest 24 bit

parseType14 w = Type14 rw mem wa ureg addr
  where
    w64 = word48ToWord64 w
    rw   = if w64 `testBit` 40 then Read else Write
    mem  = if w64 `testBit` 41 then Data else Prog
    wa   = if w64 `testBit` 39 then LW   else NW
    ureg = mkUreg $ w64 `cutMask` 0x00EF00000000
    addr = Address32 $ w64 `cutMask` 0x0000FFFFFFFF

-- TODO
parseType15 = Type15
parseType16 = Type16

parseType17 w = Type17 ureg dat
  where
    w64 = word48ToWord64 w
    dat = w64 `cutMask` 0x0000FFFFFFFF
    ureg = mkUreg $ w64 `cutMask` 0x00EF00000000

parseType18 w = Type18 bop sreg dat
  where
    w64 = word48ToWord64 w
    dat = w64 `cutMask` 0x0000FFFFFFFF
    bop = [ SET, CLR, TGL, TST, XOR ] !! (w64 `cutMask` 0x00E000000000)
    sreg = mkSreg $ w64 `cutMask` 0x00FF00000000

-- TODO
parseType19 = Type19

parseType20 w = Type20 (pushes, pops) fc
  where
    w64 = word48ToWord64 w
    lpu = if w64 `testBit` 39 then "LOOP"  else ""
    lpo = if w64 `testBit` 38 then "LOOP"  else ""
    spu = if w64 `testBit` 37 then "STS"   else ""
    spo = if w64 `testBit` 36 then "STS"   else ""
    ppu = if w64 `testBit` 35 then "PCSTK" else ""
    ppo = if w64 `testBit` 34 then "PCSTK" else ""
    pushes = filter (/= "") [lpu, spu, ppu]
    pops = filter (/= "") [lpo, spo, ppo]
    fc = w64 `testBit` 33

-- TODO
parseType25 = Type25


parseInstruction :: Word48 -> Instruction
parseInstruction word =
  let
    w64 = word48ToWord64 word
    b1 = (w64 `cutMask` 0xFF0000000000) :: Word8
    b2 = (w64 `cutMask` 0x00FF00000000) :: Word8
  in case fromIntegral b1 of
   [b| 0000 0000 |] -> if b2 `testBit` 7
                       then IDLE
                       else NOP
   [b| 0000 0001 |] -> parseType2 word
   [b| 0000 0010 |] -> parseType6 word
   [b| 0000 0011 |] -> UndefinedInstruction word
   [b| 0000 0100 |] -> parseType7 word
   [b| 0000 0101 |] -> UndefinedInstruction word
   [b| 0000 0110 |] -> parseType8 Address24 word
   [b| 0000 0111 |] -> parseType8 RelAddress24 word
   [b| 0000 1000 |] -> parseType9 word
   [b| 0000 1001 |] -> parseType9 word
   [b| 0000 1010 |] -> parseType11 Subroutine word
   [b| 0000 1011 |] -> parseType11 Interrupt word
   [b| 0000 1100 |] -> parseType12 word
   [b| 0000 1101 |] -> parseType12 word
   [b| 0000 1110 |] -> parseType13 word
   [b| 0000 1111 |] -> parseType17 word

   [b| 0001 0100 |] -> parseType18 word
   [b| 0001 0101 |] -> UndefinedInstruction word
   [b| 0001 0110 |] -> parseType19 word
   [b| 0001 0111 |] -> parseType20 word
   [b| 0001 1000 |] -> parseType25 word

   -- check six bit prefix
   _ -> case b1 .&. 0xFC of
     [b| 0001 0000 |] -> parseType14 word
     -- check four bit prefix
     _ -> case b1 .&. 0xF0 of
       [b| 0110 0000 |] -> parseType4 word
       [b| 0111 0000 |] -> parseType5 word
       [b| 1000 0000 |] -> parseType6 word
       [b| 1001 0000 |] -> parseType16 word
       -- check three bit prefix
       _ -> case b1 .&. 0xE0 of
         [b| 001 00000 |] -> parseType1 word
         [b| 010 00000 |] -> parseType3 word
         [b| 101 00000 |] -> parseType15 word
         [b| 110 00000 |] -> parseType10 word
         [b| 111 00000 |] -> parseType10 word
         _ -> InvalidInstruction word

getInstruction :: Get Instruction
getInstruction = fmap parseInstruction getPackedWord48

printInstructionWithAddr :: (Word64, Instruction) -> IO ()
printInstructionWithAddr (addr, instr) = printf "0x%05X: %s\n" addr (show instr)