TestDriver.bs

package TestDriver where

import Driver
import ChessState
import MoveEval
import MoveUpdate
import SearchCore
import ShallowSearchCores
import DefaultHeuristic
import GenCMsg
import GenCRepr
import GetPut
import ClientServer
import Connectable
import COBS
import CShow
import FIFOF
import Vector

type InitMoves = 2

data Command
  = Config { depth :: Depth; white :: Config; black :: Config }
  | RunTrial { rid :: UInt 8; initMoves :: Vector InitMoves (UInt 8); }
  deriving (Bits)

data TrialOutcome = Win Color | Draw | Error
 deriving (Eq, Bits)

struct TrialResult =
  rid :: (UInt 8)
  outcome :: TrialOutcome
 deriving (Bits)

interface ChessTestMsgs =
  command :: Rx 1 1 Command
  result :: Tx 8 8 TrialResult

{-# verilog mkChessTestDriver #-}
mkChessTestDriver :: Module Driver
mkChessTestDriver = _mkChessTestDriver

-- Seperate due to the context
_mkChessTestDriver :: (GenCMsg ChessTestMsgs rxBytes txBytes) => Module Driver
_mkChessTestDriver = module
  writeCMsgDecls "chess_test" (_ :: ChessTestMsgs)

  enc :: COBSEncoder txBytes <- mkCOBSEncoder
  dec :: COBSDecoder rxBytes <- mkCOBSDecoder
  msgMgr :: MsgManager ChessTestMsgs rxBytes txBytes <- mkMsgManager

  dec.msg <-> dropSize msgMgr.rxMsg
  msgMgr.txMsg <-> enc.msg

  stateUpdates :: FIFOF State <- mkFIFOF
  state :: Reg State <- mkReg initialState
  moveUpdate <- mkMoveUpdate
  searchCore <- mkShallowParallelSearchCore

  whiteConfig :: Reg Config <- mkReg defaultValue
  blackConfig :: Reg Config <- mkReg defaultValue
  depth :: Reg Depth <- mkReg 5
  rid :: Reg (UInt 8) <- mkReg 0
  trialRunning :: Reg Bool <- mkReg False
  numInitMoves :: Reg (UInt (TAdd 1 (TLog InitMoves))) <- mkReg 0
  initMoves :: Vector InitMoves (Reg (UInt 8)) <- replicateM $ mkReg _

  let config = if state.turn == White then whiteConfig else blackConfig
      initMoveIndex = initMoves `select` (numInitMoves - 1)

  addRules $
    rules
      {-# ASSERT fire when enabled #-}
      "get_update_result": when True ==> do
        stateUpdates.enq moveUpdate.nextState
        moveUpdate.deq
    `rJoinDescendingUrgency`
    rules
      when not trialRunning
        rules
          "config": when Config {depth=newDepth; white; black;} <- msgMgr.fifos.command.first ==> do
            $display "config " newDepth " " (cshow white) " " (cshow black)
            depth := newDepth
            whiteConfig := white
            blackConfig := black
            msgMgr.fifos.command.deq

          "start_trial": when RunTrial {rid=trialRid; initMoves=trialInitMoves;} <- msgMgr.fifos.command.first ==> do
            $display "start_trial " (cshow trialRid) " " (cshow trialInitMoves)
            rid := trialRid
            joinActions $ zipWith writeReg initMoves trialInitMoves
            trialRunning := True
            numInitMoves := fromInteger (valueOf InitMoves)
            stateUpdates.enq initialState
            msgMgr.fifos.command.deq

      when trialRunning
        rules
          "update_state": when True ==> do
            $display "update_state"
            state := stateUpdates.first
            if numInitMoves > 0
              then searchCore.server.request.put $ defaultValue {rid=extend numInitMoves; state=stateUpdates.first; depth=1; getMoves=True;}
              else searchCore.server.request.put $ defaultValue {rid=0; state=stateUpdates.first; depth=depth; config=config}
            stateUpdates.deq

          when not stateUpdates.notEmpty
            rules
              when numInitMoves > 0
                rules
                  when NextMove m <- searchCore.moves.first
                    rules
                      "do_initial_move": when initMoveIndex == 0 ==> do
                        $display "do_initial_move " initMoveIndex
                        moveUpdate.enq state m
                        searchCore.clear
                        numInitMoves := numInitMoves - 1

                      "skip_initial_move": when initMoveIndex > 0 ==> do
                        $display "skip_initial_move " initMoveIndex
                        searchCore.moves.deq
                        initMoveIndex := initMoveIndex - 1

                  -- initMoveIndex was larger than the number of moves
                  "error_initial_move": when NoMove <- searchCore.moves.first ==> do
                    $display "error_initial_move " initMoveIndex
                    searchCore.clear
                    msgMgr.fifos.result.enq $ TrialResult {rid=rid; outcome=Error}
                    trialRunning := False

              "do_search_move": when numInitMoves == 0 ==> do
                result <- searchCore.server.response.get
                $display "do_search_move " (cshow result)
                case result.outcome of
                  CheckMate -> do
                    trialRunning := False
                    msgMgr.fifos.result.enq $ TrialResult {rid=rid; outcome=Win state.turn}
                  Draw -> do
                    trialRunning := False
                    msgMgr.fifos.result.enq $ TrialResult {rid=rid; outcome=Draw}
                  _ ->
                    case result.bestMove of
                      Just move -> moveUpdate.enq state move
                      Nothing -> do
                        trialRunning := False
                        msgMgr.fifos.result.enq $ TrialResult {rid=rid; outcome=Error}
                        searchCore.clear

  interface
    txData = enc.byte
    rxData = dec.byte
    status = searchCore.status

{-# verilog mkTestTop #-}
mkTestTop :: Module Top
mkTestTop = mkHwTop mkChessTestDriver

{-# verilog sysChessTestSim #-}
sysChessTestSim :: Module Empty
sysChessTestSim = mkSimTop mkChessTestDriver