HARM-0.1.2: Arm/Encoder.hs
----------------------------------------------------------------------
-- FILE: Encoder.hs
-- DATE: 03/04/2001
-- PROJECT: HARM (was VARM (Virtual ARM)), for CSE240 Spring 2001
-- LANGUAGE PLATFORM: HUGS
-- OS PLATFORM: RedHat Linux 6.2
-- AUTHOR: Jeffrey A. Meunier
-- EMAIL: jeffm@cse.uconn.edu
-- MAINTAINER: Alex Mason
-- EMAIL: axman6@gmail.com
----------------------------------------------------------------------
module Arm.Encoder
( encode )
where
----------------------------------------------------------------------
-- Standard libraries.
----------------------------------------------------------------------
import Data.Bits
import Data.Int
import Data.Word
import Data.Array
----------------------------------------------------------------------
-- Local libraries.
----------------------------------------------------------------------
import Arm.Instruction
import Arm.Operand
import Arm.RegisterName
----------------------------------------------------------------------
-- Encoding shortcuts.
----------------------------------------------------------------------
condEq :: (Int, Int, Word32)
condNe :: (Int, Int, Word32)
condCs :: (Int, Int, Word32)
condHs :: (Int, Int, Word32)
condCc :: (Int, Int, Word32)
condLo :: (Int, Int, Word32)
condMi :: (Int, Int, Word32)
condPl :: (Int, Int, Word32)
condVs :: (Int, Int, Word32)
condVc :: (Int, Int, Word32)
condHi :: (Int, Int, Word32)
condLs :: (Int, Int, Word32)
condGe :: (Int, Int, Word32)
condLt :: (Int, Int, Word32)
condGt :: (Int, Int, Word32)
condLe :: (Int, Int, Word32)
condAl :: (Int, Int, Word32)
condNv :: (Int, Int, Word32)
condEq = (31, 28, 0x0)
condNe = (31, 28, 0x1)
condCs = (31, 28, 0x2)
condHs = (31, 28, 0x2)
condCc = (31, 28, 0x3)
condLo = (31, 28, 0x3)
condMi = (31, 28, 0x4)
condPl = (31, 28, 0x5)
condVs = (31, 28, 0x6)
condVc = (31, 28, 0x7)
condHi = (31, 28, 0x8)
condLs = (31, 28, 0x9)
condGe = (31, 28, 0xA)
condLt = (31, 28, 0xB)
condGt = (31, 28, 0xC)
condLe = (31, 28, 0xD)
condAl = (31, 28, 0xE)
condNv = (31, 28, 0xF)
----------------------------------------------------------------------
-- Encode an instruction into a Word32.
----------------------------------------------------------------------
encode
:: Instruction
-> Word32
----------------------------------------
-- add three registers
encode (Add (Reg r1) (Reg r2) op2)
= let w1 = concatFields 0
[ condAl -- condition
, (24, 21, 0x04) -- opcode
, (19, 16, regIndex r2) -- first operand register
, (15, 12, regIndex r1) -- destination register
]
w2 = concatFields 0
(case op2 of
Reg r3
-> [(25, 25, 0), (3, 0, regIndex r3)] -- second operand is register
Con c1
-> [(25, 25, 1), (7, 0, c1)] -- 8-bit constant
)
in w1 .|. w2
----------------------------------------
-- logical bit-wise and
encode (And (Reg r1) (Reg r2) op2)
= let w1 = concatFields 0
[ condAl -- condition
, (24, 21, 0x00) -- opcode
, (19, 16, regIndex r2) -- first operand register
, (15, 12, regIndex r1) -- destination register
]
w2 = concatFields 0
(case op2 of
Reg r3
-> [(3, 0, regIndex r3)] -- second operand register
Con c1
-> [(7, 0, c1)] -- 8-bit constant
)
in w1 .|. w2
----------------------------------------
-- branch unconditionally
encode (B (Rel rel))
= encodeBranch condAl rel
----------------------------------------
-- branch if equal
encode (Beq (Rel rel))
= encodeBranch condEq rel
----------------------------------------
-- branch if greater than
encode (Bgt (Rel rel))
= encodeBranch condGt rel
----------------------------------------
-- bit clear
encode (Bic (Reg r1) (Reg r2) op2)
= let w1 = concatFields 0
[ condAl -- condition
, (24, 21, 0x0E) -- opcode
, (19, 16, regIndex r2) -- first operand register
, (15, 12, regIndex r1) -- destination register
]
w2 = concatFields 0
(case op2 of
Reg r3
-> [(3, 0, regIndex r3)] -- second operand register
Con c1
-> [(7, 0, c1)] -- 8-bit constant
)
in w1 .|. w2
----------------------------------------
-- branch and link
encode (Bl (Rel rel))
= encodeBranch condAl rel .|. concatFields 0 [(24, 24, 1)]
----------------------------------------
-- branch if less than
encode (Blt (Rel rel))
= encodeBranch condLt rel
----------------------------------------
-- branch if not equal
encode (Bne (Rel rel))
= encodeBranch condNe rel
----------------------------------------
-- compare two operands
encode (Cmp (Reg r1) op2)
= let w1 = concatFields 0
[ condAl -- condition
, (24, 21, 0x0A) -- opcode
, (15, 12, regIndex r1) -- register 1
]
w2 = encodeOp2 op2
in w1 .|. w2
----------------------------------------
-- logical bit-wise exclusive or
encode (Eor (Reg r1) (Reg r2) op2)
= let w1 = concatFields 0
[ condAl -- condition
, (24, 21, 0x01) -- opcode
, (19, 16, regIndex r2) -- first operand register
, (15, 12, regIndex r1) -- destination register
]
w2 = concatFields 0
(case op2 of
Reg r3
-> [(3, 0, regIndex r3)] -- second operand register
Con c1
-> [(7, 0, c1)] -- 8-bit constant
)
in w1 .|. w2
----------------------------------------
-- load multiple registers
encode (Ldmea op1 (Mrg regs))
= encodeMReg 0x0 op1 regs
----------------------------------------
-- load register
encode (Ldr (Reg r1) op2)
= encodeLdrStr 0x0 0x1 r1 op2
----------------------------------------
-- load register, unsigned byte
encode (Ldrb (Reg r1) op2)
= encodeLdrStr 0x0 0x0 r1 op2
----------------------------------------
-- move register to register
encode (Mov (Reg r1) op2)
= let w1 = concatFields 0
[ condAl -- condition
, (24, 21, 0x0D) -- opcode
, (15, 12, regIndex r1) -- destination register
]
w2 = encodeOp2 op2
in w1 .|. w2
----------------------------------------
-- multiply
encode (Mul (Reg r1) (Reg r2) (Reg r3))
= concatFields 0
[ condAl
, (19, 16, regIndex r1)
, (11, 8, regIndex r3)
, ( 7, 4, 0x09)
, ( 3, 0, regIndex r2)
]
----------------------------------------
-- logical bit-wise or
encode (Orr (Reg r1) (Reg r2) op2)
= let w1 = concatFields 0
[ condAl -- condition
, (24, 21, 0x0C) -- opcode
, (19, 16, regIndex r2) -- first operand register
, (15, 12, regIndex r1) -- destination register
]
w2 = concatFields 0
(case op2 of
Reg r3
-> [(3, 0, regIndex r3)] -- second operand register
Con c1
-> [(7, 0, c1)] -- 8-bit constant
)
in w1 .|. w2
----------------------------------------
-- load multiple registers
encode (Stmea op1 (Mrg regs))
= encodeMReg 0x1 op1 regs
----------------------------------------
-- store register
encode (Str (Reg r1) op2)
= encodeLdrStr 0x1 0x1 r1 op2
----------------------------------------
-- store register, unsigned byte
encode (Strb (Reg r1) op2)
= encodeLdrStr 0x1 0x0 r1 op2
----------------------------------------
-- add three registers
encode (Sub (Reg r1) (Reg r2) op2)
= let w1 = concatFields 0
[ condAl -- condition
, (24, 21, 0x02) -- opcode
, (19, 16, regIndex r2) -- first operand register
, (15, 12, regIndex r1) -- destination register
]
w2 = concatFields 0
(case op2 of
Reg r3
-> [(3, 0, regIndex r3)] -- second operand register
Con c1
-> [(7, 0, c1)] -- 8-bit constant
)
in w1 .|. w2
----------------------------------------
-- software interrupt
encode (Swi (Con c))
= concatFields 0 [ condAl
, (27, 24, 0xF)
] .|. c
----------------------------------------------------------------------
-- helper functions
encodeBranch cond rel
= concatFields 0 [ cond,
(27, 25, 0x5)
] .|. (to16to32 rel)
to16to32 n = (fromIntegral (fromIntegral n :: Word16) :: Word32)
encodeOp2 op
= concatFields 0
(case op of
Reg r2
-> [(3, 0, regIndex r2)] -- first operand register
Con c1
-> [ (25, 25, 0x01) -- ``#'' field
, (7, 0, c1) -- 8-bit immediate
])
-- encode a multiple register load or store
encodeMReg ls op1 regs
= let w1 = concatFields 0
[ condAl
, (27, 25, 0x04) -- opcode
--, (24, 24, 0x00) -- post-increment or decrement
, (23, 23, 0x01) -- increment or decrement
, (20, 20, ls) -- load
]
w2 = concatFields 0
(case op1 of
Aut (Reg reg)
-> [ (21, 21, 0x01) -- write-back
, (19, 16, regIndex reg)
]
Reg reg
-> [ (19, 16, regIndex reg)
]
)
w3 = concatFields 0
(map (\reg -> let i = fromIntegral (regIndex reg) in (i, i, 1)) regs)
in w1 .|. w2 .|. w3
-- encode a load or store
encodeLdrStr ls bw r1 op2
= let w1 = concatFields 0
[ condAl -- condition
, (27, 26, 0x01) -- constant field
--, (25, 25, 0x00) -- ``#'' field
--, (23, 23, 0x00) -- up/down
, (22, 22, bw) -- unsigned byte/word
, (20, 20, ls) -- load/store
, (15, 12, regIndex r1) -- destination register
]
w2 = concatFields 0
(case op2 of
Ind r2
-> [ --(24, 24, 0x00) -- pre/post index
--, (21, 21, 0x00) -- write-back (auto-index)
(19, 16, regIndex r2) -- base register
]
Bas r2 offset
-> [ --(24, 24, 0x00) -- pre/post index
--, (21, 21, 0x00) -- write-back (auto-index)
(19, 16, regIndex r2) -- base register
, (11, 0, offset) -- offset
]
Aut (Bas r2 offset)
-> [ --(24, 24, 0x00) -- pre/post index
(21, 21, 0x01) -- write-back (auto-index)
, (19, 16, regIndex r2) -- base register
, (11, 0, offset) -- offset
]
Pos (Ind r2) const
-> [ (24, 24, 0x01) -- pre/post index
, (21, 21, 0x01) -- write-back (auto-index)
, (19, 16, regIndex r2) -- base register
, (11, 0, const) -- offset
]
)
in w1 .|. w2
----------------------------------------------------------------------
-- Concatenate bit fields into one word.
----------------------------------------------------------------------
concatFields
:: Word32
-> [(Int, Int, Word32)]
-> Word32
concatFields word [] = word
concatFields word ((hi, lo, val) : fields)
= let mask = fromIntegral (2 ^ (hi - lo + 1) - 1)
val' = val .&. mask
in concatFields (word .|. (val' `shiftL` lo)) fields
----------------------------------------------------------------------
-- Convert a register name into a word32.
----------------------------------------------------------------------
regIndex
:: RegisterName
-> Word32
regIndex = fromIntegral . (index (R0, CPSR))
----------------------------------------------------------------------
-- eof
----------------------------------------------------------------------