{-|
Copyright  :  (C) 2018-2022, Google Inc
                  2019,      Myrtle Software Ltd
                  2023,      QBayLogic B.V.
License    :  BSD2 (see the file LICENSE)
Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>
-}

{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

module Clash.Clocks.Internal
  ( Clocks(..)
  , deriveClocksInstances
  , ClocksSync(..)
  , deriveClocksSyncInstances
  ) where

import Control.Monad.Extra (concatMapM)
import Data.Kind (Constraint, Type)
import GHC.TypeLits (Nat)
import Language.Haskell.TH hiding (Type)

import Clash.CPP (haddockOnly)
import Clash.Explicit.Reset (resetSynchronizer)
import Clash.Explicit.Signal (unsafeSynchronizer)
import Clash.Magic (setName)
import Clash.Promoted.Symbol (SSymbol(..))
import Clash.Signal.Internal
  (clockGen, Clock(..), Domain, KnownDomain, Reset, Signal, unsafeFromActiveLow,
   unsafeToActiveLow)

-- | __NB__: The documentation only shows instances up to /3/ output clocks. By
-- default, instances up to and including /18/ clocks will exist.
class Clocks t where
  type ClocksCxt t :: Constraint
  type NumOutClocks t :: Nat

  clocks ::
    (KnownDomain domIn, ClocksCxt t) =>
    Clock domIn ->
    Reset domIn ->
    t

-- Derive instance for /n/ clocks
deriveClocksInstance :: Int -> DecsQ
deriveClocksInstance :: Int -> DecsQ
deriveClocksInstance Int
n =
  [d| instance Clocks $instType where
        type ClocksCxt $instType = $cxtType
        type NumOutClocks $instType = $numOutClocks

        clocks (Clock _ Nothing) $(varP rst) = $funcImpl
        clocks _ _ = error "clocks: dynamic clocks unsupported"
        {-# CLASH_OPAQUE clocks #-}
    |]
 where
  clkTyVar :: a -> TypeQ
clkTyVar a
m = Name -> TypeQ
varT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"c" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
m
  clkTypes :: [TypeQ]
clkTypes = (Int -> TypeQ) -> [Int] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
m -> [t| Clock $(clkTyVar m) |]) [Int
1..Int
n]
  lockTyVar :: TypeQ
lockTyVar = Name -> TypeQ
varT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"pllLock"
  -- (Clock c1, Clock c2, ..., Signal pllLock Bool)
  instType :: TypeQ
instType = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT (Int -> TypeQ
tupleT (Int -> TypeQ) -> Int -> TypeQ
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ([TypeQ] -> TypeQ) -> [TypeQ] -> TypeQ
forall a b. (a -> b) -> a -> b
$
               [TypeQ]
clkTypes [TypeQ] -> [TypeQ] -> [TypeQ]
forall a. Semigroup a => a -> a -> a
<> [ [t| Signal $lockTyVar Bool |] ]
  clkKnownDoms :: [TypeQ]
clkKnownDoms = (Int -> TypeQ) -> [Int] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
m -> [t| KnownDomain $(clkTyVar m) |]) [Int
1..Int
n]
  -- (KnownDomain c1, KnownDomain c2, ..., KnownDomain pllLock)
  cxtType :: TypeQ
cxtType = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT (Int -> TypeQ
tupleT (Int -> TypeQ) -> Int -> TypeQ
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ([TypeQ] -> TypeQ) -> [TypeQ] -> TypeQ
forall a b. (a -> b) -> a -> b
$
              [TypeQ]
clkKnownDoms [TypeQ] -> [TypeQ] -> [TypeQ]
forall a. Semigroup a => a -> a -> a
<> [ [t| KnownDomain $lockTyVar |] ]
  numOutClocks :: TypeQ
numOutClocks = TyLitQ -> TypeQ
litT (TyLitQ -> TypeQ) -> (Integer -> TyLitQ) -> Integer -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> TyLitQ
numTyLit (Integer -> TypeQ) -> Integer -> TypeQ
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
n

  -- 'clocks' function
  rst :: Name
rst = String -> Name
mkName String
"rst"
  lockImpl :: ExpQ
lockImpl = [|
    unsafeSynchronizer clockGen clockGen (unsafeToActiveLow $(varE rst))
    |]
  clkImpls :: [ExpQ]
clkImpls = Int -> ExpQ -> [ExpQ]
forall a. Int -> a -> [a]
replicate Int
n [| Clock SSymbol Nothing |]
  funcImpl :: ExpQ
funcImpl = [ExpQ] -> ExpQ
tupE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ [ExpQ]
clkImpls [ExpQ] -> [ExpQ] -> [ExpQ]
forall a. Semigroup a => a -> a -> a
<> [ExpQ
lockImpl]

-- Derive instances for up to and including 18 clocks, except when we are
-- generating Haddock
deriveClocksInstances :: DecsQ
deriveClocksInstances :: DecsQ
deriveClocksInstances = (Int -> DecsQ) -> [Int] -> DecsQ
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m [b]) -> [a] -> m [b]
concatMapM Int -> DecsQ
deriveClocksInstance [Int
1..Int
n]
 where
  n :: Int
n | Bool
haddockOnly = Int
3
    | Bool
otherwise   = Int
18

-- | __NB__: The documentation only shows instances up to /3/ output clocks. By
-- default, instances up to and including /18/ clocks will exist.
class ClocksSync t where
  type ClocksSyncClocksInst t (domIn :: Domain) :: Type
  type ClocksResetSynchronizerCxt t :: Constraint

  clocksResetSynchronizer ::
    ( KnownDomain domIn
    , ClocksResetSynchronizerCxt t
    ) =>
    ClocksSyncClocksInst t domIn ->
    Clock domIn ->
    t

-- Derive instance for /n/ clocks
deriveClocksSyncInstance :: Int -> DecsQ
deriveClocksSyncInstance :: Int -> DecsQ
deriveClocksSyncInstance Int
n =
  [d|
    instance ClocksSync $instType where
      type ClocksSyncClocksInst $instType $domInTyVar = $clocksInstType
      type ClocksResetSynchronizerCxt $instType = $cxtType

      clocksResetSynchronizer pllOut $(varP clkIn) =
        let $pllPat = pllOut
        in $funcImpl
  |]
 where
  clkVarName :: a -> Name
clkVarName a
m = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"c" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
m
  clkTyVar :: Int -> TypeQ
  clkTyVar :: Int -> TypeQ
clkTyVar = Name -> TypeQ
varT (Name -> TypeQ) -> (Int -> Name) -> Int -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Name
forall a. Show a => a -> Name
clkVarName
  clkAndRstTy :: Int -> [TypeQ]
clkAndRstTy Int
m = [ [t| Clock $(clkTyVar m) |]
                  , [t| Reset $(clkTyVar m) |]
                  ]
  -- (Clock c1, Reset c1, Clock c2, Reset c2, ...)
  instType :: TypeQ
instType = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT (Int -> TypeQ
tupleT (Int -> TypeQ) -> Int -> TypeQ
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) ([TypeQ] -> TypeQ) -> [TypeQ] -> TypeQ
forall a b. (a -> b) -> a -> b
$ (Int -> [TypeQ]) -> [Int] -> [TypeQ]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap Int -> [TypeQ]
clkAndRstTy [Int
1..Int
n]
  domInTyVar :: TypeQ
domInTyVar = Name -> TypeQ
varT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"domIn"
  clkTypes :: [TypeQ]
clkTypes = (Int -> TypeQ) -> [Int] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
m -> [t| Clock $(clkTyVar m) |]) [Int
1..Int
n]
  -- (Clock c1, Clock c2, ..., Signal domIn Bool)
  clocksInstType :: TypeQ
clocksInstType = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT (Int -> TypeQ
tupleT (Int -> TypeQ) -> Int -> TypeQ
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ([TypeQ] -> TypeQ) -> [TypeQ] -> TypeQ
forall a b. (a -> b) -> a -> b
$
                     [TypeQ]
clkTypes [TypeQ] -> [TypeQ] -> [TypeQ]
forall a. Semigroup a => a -> a -> a
<> [ [t| Signal $domInTyVar Bool |] ]
  -- (KnownDomain c1, KnownDomain c2, ...)
  cxtType :: TypeQ
cxtType
    | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
    = [t| KnownDomain $(clkTyVar 1) |]
    | Bool
otherwise
    = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT (Int -> TypeQ
tupleT Int
n) ([TypeQ] -> TypeQ) -> [TypeQ] -> TypeQ
forall a b. (a -> b) -> a -> b
$
        (Int -> TypeQ) -> [Int] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
m -> [t| KnownDomain $(clkTyVar m) |]) [Int
1..Int
n]

  -- 'clocksResetSynchronizer' function
  clkIn :: Name
clkIn = String -> Name
mkName String
"clkIn"
  pllLock :: Name
pllLock = String -> Name
mkName String
"pllLock"
  -- (c1, c2, ..., pllLock)
  pllPat :: PatQ
pllPat = [PatQ] -> PatQ
tupP ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Int -> PatQ) -> [Int] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> PatQ
varP (Name -> PatQ) -> (Int -> Name) -> Int -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Name
forall a. Show a => a -> Name
clkVarName) [Int
1..Int
n] [PatQ] -> [PatQ] -> [PatQ]
forall a. Semigroup a => a -> a -> a
<> [Name -> PatQ
varP Name
pllLock]
  syncImpl :: a -> ExpQ
syncImpl a
m =
    [|
      setName @"resetSynchronizer" (resetSynchronizer $(varE $ clkVarName m)
        (unsafeFromActiveLow
          (unsafeSynchronizer $(varE clkIn) $(varE $ clkVarName m)
                              $(varE pllLock))))
    |]
  clkAndRstExp :: a -> [ExpQ]
clkAndRstExp a
m = [ Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ a -> Name
forall a. Show a => a -> Name
clkVarName a
m
                   , a -> ExpQ
forall a. Show a => a -> ExpQ
syncImpl a
m
                   ]
  -- (c1, r1, c2, r2, ...) where rN is the synchronized reset for clock N
  funcImpl :: ExpQ
funcImpl = [ExpQ] -> ExpQ
tupE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Int -> [ExpQ]) -> [Int] -> [ExpQ]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap Int -> [ExpQ]
forall a. Show a => a -> [ExpQ]
clkAndRstExp [Int
1..Int
n]

-- Derive instances for up to and including 18 clocks, except when we are
-- generating Haddock
deriveClocksSyncInstances :: DecsQ
deriveClocksSyncInstances :: DecsQ
deriveClocksSyncInstances = (Int -> DecsQ) -> [Int] -> DecsQ
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m [b]) -> [a] -> m [b]
concatMapM Int -> DecsQ
deriveClocksSyncInstance [Int
1..Int
n]
 where
  n :: Int
n | Bool
haddockOnly = Int
3
    | Bool
otherwise   = Int
18