CodeGen.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | High-level translation of Copilot Core into Bluespec.
module Copilot.Compile.Bluespec.CodeGen
  ( -- * Type declarations
    mkStructDecln

    -- * Ring buffers
  , mkBuffDecln
  , mkIndexDecln
  , mkAccessDecln

    -- * Stream generators
  , mkGenFun

    -- * Monitor processing
  , mkStepRule
  , mkTriggerRule

    -- * Module interface specifications
  , mkSpecIfcFields
  ) where

-- External imports
import Data.String (IsString (..))
import qualified Language.Bluespec.Classic.AST as BS
import qualified Language.Bluespec.Classic.AST.Builtin.Ids as BS
import qualified Language.Bluespec.Classic.AST.Builtin.Types as BS

-- Internal imports: Copilot
import Copilot.Core

-- Internal imports
import Copilot.Compile.Bluespec.Expr
import Copilot.Compile.Bluespec.External
import Copilot.Compile.Bluespec.Name
import Copilot.Compile.Bluespec.Representation
import Copilot.Compile.Bluespec.Type

-- | Write a generator function for a stream.
mkGenFun :: String -> Expr a -> Type a -> BS.CDefl
mkGenFun name expr ty =
    -- name :: ty
    -- name = expr
    BS.CLValueSign
      (BS.CDef nameId (BS.CQType [] (transType ty)) [def])
      []
  where
    nameId = BS.mkId BS.NoPos $ fromString $ lowercaseName name
    def = BS.CClause [] [] (transExpr expr)

-- | Bind a buffer variable and initialise it with the stream buffer.
mkBuffDecln :: forall a. Id -> Type a -> [a] -> [BS.CStmt]
mkBuffDecln sId ty xs =
    initVals ++ [BS.CSletrec [initBufSig]]
  where
    -- sId_0     :: Reg <ty> <- mkReg xs_0
    -- ...
    -- sId_(n-1) :: Reg <ty> <- mkReg xs_(n-1)
    initVals = zipWith mkInitVal xs [0..]
    -- sId :: Vector n (Reg <ty>)
    -- sId = update (... (update newVector 0 sId_0) ...) (n-1) sId_(n-1)
    initBufSig = BS.CLValueSign
                   (BS.CDef nameId (BS.CQType [] vecTy) [initBufDef])
                   []
    initBufDef = BS.CClause
                   []
                   []
                   (genVector
                     (\idx _ -> BS.CVar $ BS.mkId BS.NoPos $
                                fromString $ streamElemName sId idx)
                     xs)

    nameId   = BS.mkId BS.NoPos $ fromString $ streamName sId
    bsTy     = tReg `BS.TAp` transType ty
    vecTy    = tVector `BS.TAp` BS.cTNum numElems BS.NoPos `BS.TAp` bsTy
    numElems = toInteger $ length xs

    mkInitVal :: a -> Int -> BS.CStmt
    mkInitVal x elemNum =
        BS.CSBindT
          (BS.CPVar elemId)
          Nothing
          []
          (BS.CQType [] bsTy)
          (BS.CApply (BS.CVar (BS.mkId BS.NoPos "mkReg")) [constTy ty x])
      where
        elemName = streamElemName sId elemNum
        elemId   = BS.mkId BS.NoPos $ fromString elemName

-- | Make an index variable and initialise it to 0.
mkIndexDecln :: Id -> BS.CStmt
mkIndexDecln sId =
  -- sId_idx :: Reg (Bit 64) <- mkReg 0
  BS.CSBindT
    (BS.CPVar nameId)
    Nothing
    []
    (BS.CQType [] bsTy)
    (BS.CApply (BS.CVar (BS.mkId BS.NoPos "mkReg"))
               [cLit $ BS.LInt $ BS.ilDec 0])
  where
    nameId = BS.mkId BS.NoPos $ fromString $ indexName sId
    bsTy   = tReg `BS.TAp` BS.tBitN 64 BS.NoPos

-- | Define an accessor function for the ring buffer associated with a stream
mkAccessDecln :: Id -> Type a -> [a] -> BS.CDefl
mkAccessDecln sId ty xs =
    -- sId_get :: Bits 64 -> ty
    -- sId_get x = (select sId ((sId_idx + x) % buffLength))._read
    BS.CLValueSign (BS.CDef nameId (BS.CQType [] funTy) [def]) []
  where
    def        = BS.CClause [BS.CPVar argId] [] expr
    argTy      = BS.tBit `BS.TAp` BS.cTNum 64 BS.NoPos
    retTy      = transType ty
    funTy      = BS.tArrow `BS.TAp` argTy `BS.TAp` retTy
    name       = streamAccessorName sId
    nameId     = BS.mkId BS.NoPos $ fromString name
    buffLength = cLit $ BS.LInt $ BS.ilDec $ toInteger $ length xs
    argId      = BS.mkId BS.NoPos "x"
    index      = BS.CApply (BS.CVar (BS.idPercentAt BS.NoPos))
                   [ BS.CApply (BS.CVar BS.idPlus)
                       [ BS.CVar (BS.mkId BS.NoPos (fromString (indexName sId)))
                       , BS.CVar argId
                       ]
                   , buffLength
                   ]
    indexExpr  = cIndexVector
                   (BS.CVar (BS.mkId BS.NoPos (fromString (streamName sId))))
                   index
    expr       = BS.CSelect indexExpr (BS.id_read BS.NoPos)

-- | Define fields for a module interface containing a specification's trigger
-- functions and external variables.
mkSpecIfcFields :: [Trigger] -> [External] -> [BS.CField]
mkSpecIfcFields triggers exts =
    map mkTriggerField triggers ++ map mkExtField exts
  where
    -- trigger :: args_1 -> ... -> args_n -> Action
    mkTriggerField :: Trigger -> BS.CField
    mkTriggerField (Trigger name _ args) =
      mkField name $
      foldr
        (\(UExpr arg _) res -> BS.tArrow `BS.TAp` transType arg `BS.TAp` res)
        BS.tAction
        args

    -- ext :: Reg ty
    mkExtField :: External -> BS.CField
    mkExtField (External name ty) =
      mkField name $ tReg `BS.TAp` transType ty

-- | Define a rule for a trigger function.
mkTriggerRule :: UniqueTrigger -> BS.CRule
mkTriggerRule (UniqueTrigger uniqueName (Trigger name _ args)) =
    BS.CRule
      []
      (Just $ cLit $ BS.LString uniqueName)
      [ BS.CQFilter $
        BS.CVar $ BS.mkId BS.NoPos $
        fromString $ guardName uniqueName
      ]
      (BS.CApply nameExpr args')
  where
    ifcArgId = BS.mkId BS.NoPos $ fromString ifcArgName
    -- Note that we use 'name' here instead of 'uniqueName', as 'name' is the
    -- name of the actual external function.
    nameId   = BS.mkId BS.NoPos $ fromString $ lowercaseName name
    nameExpr = BS.CSelect (BS.CVar ifcArgId) nameId

    args'   = take (length args) (map argCall (argNames uniqueName))
    argCall = BS.CVar . BS.mkId BS.NoPos . fromString

-- | Writes the @step@ rule that updates all streams.
mkStepRule :: [Stream] -> Maybe BS.CRule
mkStepRule streams
  | null allUpdates
  = -- If there is nothing to update, don't bother creating a step rule.
    -- Doing so wouldn't harm anything, but bsc will generate a warning
    -- when compiling such an empty rule.
    Nothing
  | otherwise
  = Just $
    BS.CRule
      []
      (Just $ cLit $ BS.LString "step")
      [BS.CQFilter $ BS.CCon BS.idTrue []]
      (BS.Caction BS.NoPos allUpdates)
  where
    allUpdates = bufferUpdates ++ indexUpdates
    (bufferUpdates, indexUpdates) = unzip $ map mkUpdateGlobals streams

    -- Write code to update global stream buffers and index.
    mkUpdateGlobals :: Stream -> (BS.CStmt, BS.CStmt)
    mkUpdateGlobals (Stream sId buff _ _) =
        (bufferUpdate, indexUpdate)
      where
        bufferUpdate =
          BS.CSExpr Nothing $
          BS.Cwrite
            BS.NoPos
            (cIndexVector (BS.CVar buffId) (BS.CVar indexId))
            (BS.CVar genId)

        indexUpdate =
          BS.CSExpr Nothing $
          BS.Cwrite
            BS.NoPos
            (BS.CVar indexId)
            (BS.CApply (BS.CVar (BS.idPercentAt BS.NoPos))
                       [incIndex, buffLength])
          where
            buffLength = cLit $ BS.LInt $ BS.ilDec $ toInteger $ length buff
            incIndex   = BS.CApply (BS.CVar BS.idPlus)
                           [ BS.CVar indexId
                           , cLit $ BS.LInt $ BS.ilDec 1
                           ]

        buffId  = BS.mkId BS.NoPos $ fromString $ streamName sId
        genId   = BS.mkId BS.NoPos $ fromString $ generatorName sId
        indexId = BS.mkId BS.NoPos $ fromString $ indexName sId

-- | Write a struct declaration based on its definition.
mkStructDecln :: Struct a => a -> BS.CDefn
mkStructDecln x =
    BS.Cstruct
      True
      BS.SStruct
      (BS.IdK structId)
      [] -- No type variables
      structFields
      -- Derive a Bits instance so that we can put this struct in a Reg
      [BS.CTypeclass BS.idBits]
  where
    structId = BS.mkId BS.NoPos $ fromString $ uppercaseName $ typeName x
    structFields = map mkStructField $ toValues x

    mkStructField :: Value a -> BS.CField
    mkStructField (Value ty field) =
      mkField (fieldName field) (transType ty)

-- | Write a field of a struct or interface, along with its type.
mkField :: String -> BS.CType -> BS.CField
mkField name ty =
  BS.CField
    { BS.cf_name = BS.mkId BS.NoPos $ fromString $ lowercaseName name
    , BS.cf_pragmas = Nothing
    , BS.cf_type = BS.CQType [] ty
    , BS.cf_default = []
    , BS.cf_orig_type = Nothing
    }

-- | The @Reg@ Bluespec interface type.
tReg :: BS.CType
tReg = BS.TCon $
  BS.TyCon
    { BS.tcon_name = BS.idReg
    , BS.tcon_kind = Just (BS.Kfun BS.KStar BS.KStar)
    , BS.tcon_sort = BS.TIstruct (BS.SInterface [])
                                 [BS.id_write BS.NoPos, BS.id_read BS.NoPos]
    }