{-|
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 $Q Type
instType where
        type ClocksCxt $Q Type
instType = $Q Type
cxtType
        type NumOutClocks $Q Type
instType = $Q Type
numOutClocks

        clocks (Clock _ Nothing) $(Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
rst) = $Q Exp
funcImpl
        clocks _ _ = error "clocks: dynamic clocks unsupported"
        {-# CLASH_OPAQUE clocks #-}
    |]
 where
  clkTyVar :: a -> m Type
clkTyVar a
m = Name -> m Type
forall (m :: Type -> Type). Quote m => Name -> m Type
varT (Name -> m Type) -> Name -> m Type
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 :: [Q Type]
clkTypes = (Int -> Q Type) -> [Int] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
m -> [t| Clock $(Int -> Q Type
forall {m :: Type -> Type} {a}. (Quote m, Show a) => a -> m Type
clkTyVar Int
m) |]) [Int
1..Int
n]
  lockTyVar :: Q Type
lockTyVar = Name -> Q Type
forall (m :: Type -> Type). Quote m => Name -> m Type
varT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"pllLock"
  -- (Clock c1, Clock c2, ..., Signal pllLock Bool)
  instType :: Q Type
instType = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
forall (m :: Type -> Type). Quote m => m Type -> m Type -> m Type
appT (Int -> Q Type
forall (m :: Type -> Type). Quote m => Int -> m Type
tupleT (Int -> Q Type) -> Int -> Q Type
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ([Q Type] -> Q Type) -> [Q Type] -> Q Type
forall a b. (a -> b) -> a -> b
$
               [Q Type]
clkTypes [Q Type] -> [Q Type] -> [Q Type]
forall a. Semigroup a => a -> a -> a
<> [ [t| Signal $Q Type
lockTyVar Bool |] ]
  clkKnownDoms :: [Q Type]
clkKnownDoms = (Int -> Q Type) -> [Int] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
m -> [t| KnownDomain $(Int -> Q Type
forall {m :: Type -> Type} {a}. (Quote m, Show a) => a -> m Type
clkTyVar Int
m) |]) [Int
1..Int
n]
  -- (KnownDomain c1, KnownDomain c2, ..., KnownDomain pllLock)
  cxtType :: Q Type
cxtType = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
forall (m :: Type -> Type). Quote m => m Type -> m Type -> m Type
appT (Int -> Q Type
forall (m :: Type -> Type). Quote m => Int -> m Type
tupleT (Int -> Q Type) -> Int -> Q Type
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ([Q Type] -> Q Type) -> [Q Type] -> Q Type
forall a b. (a -> b) -> a -> b
$
              [Q Type]
clkKnownDoms [Q Type] -> [Q Type] -> [Q Type]
forall a. Semigroup a => a -> a -> a
<> [ [t| KnownDomain $Q Type
lockTyVar |] ]
  numOutClocks :: Q Type
numOutClocks = Q TyLit -> Q Type
forall (m :: Type -> Type). Quote m => m TyLit -> m Type
litT (Q TyLit -> Q Type) -> (Integer -> Q TyLit) -> Integer -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Q TyLit
forall (m :: Type -> Type). Quote m => Integer -> m TyLit
numTyLit (Integer -> Q Type) -> Integer -> Q Type
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 :: Q Exp
lockImpl = [|
    unsafeSynchronizer clockGen clockGen (unsafeToActiveLow $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
rst))
    |]
  clkImpls :: [Q Exp]
clkImpls = Int -> Q Exp -> [Q Exp]
forall a. Int -> a -> [a]
replicate Int
n [| Clock SSymbol Nothing |]
  funcImpl :: Q Exp
funcImpl = [Q Exp] -> Q Exp
forall (m :: Type -> Type). Quote m => [m Exp] -> m Exp
tupE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Q Exp]
clkImpls [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. Semigroup a => a -> a -> a
<> [Q Exp
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 $Q Type
instType where
      type ClocksSyncClocksInst $Q Type
instType $Q Type
domInTyVar = $Q Type
clocksInstType
      type ClocksResetSynchronizerCxt $Q Type
instType = $Q Type
cxtType

      clocksResetSynchronizer pllOut $(Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
clkIn) =
        let $Q Pat
pllPat = pllOut
        in $Q Exp
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 -> Q Type
clkTyVar = Name -> Q Type
forall (m :: Type -> Type). Quote m => Name -> m Type
varT (Name -> Q Type) -> (Int -> Name) -> Int -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Name
forall {a}. Show a => a -> Name
clkVarName
  clkAndRstTy :: Int -> [Q Type]
clkAndRstTy Int
m = [ [t| Clock $(Int -> Q Type
clkTyVar Int
m) |]
                  , [t| Reset $(Int -> Q Type
clkTyVar Int
m) |]
                  ]
  -- (Clock c1, Reset c1, Clock c2, Reset c2, ...)
  instType :: Q Type
instType = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
forall (m :: Type -> Type). Quote m => m Type -> m Type -> m Type
appT (Int -> Q Type
forall (m :: Type -> Type). Quote m => Int -> m Type
tupleT (Int -> Q Type) -> Int -> Q Type
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) ([Q Type] -> Q Type) -> [Q Type] -> Q Type
forall a b. (a -> b) -> a -> b
$ (Int -> [Q Type]) -> [Int] -> [Q Type]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap Int -> [Q Type]
clkAndRstTy [Int
1..Int
n]
  domInTyVar :: Q Type
domInTyVar = Name -> Q Type
forall (m :: Type -> Type). Quote m => Name -> m Type
varT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"domIn"
  clkTypes :: [Q Type]
clkTypes = (Int -> Q Type) -> [Int] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
m -> [t| Clock $(Int -> Q Type
clkTyVar Int
m) |]) [Int
1..Int
n]
  -- (Clock c1, Clock c2, ..., Signal domIn Bool)
  clocksInstType :: Q Type
clocksInstType = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
forall (m :: Type -> Type). Quote m => m Type -> m Type -> m Type
appT (Int -> Q Type
forall (m :: Type -> Type). Quote m => Int -> m Type
tupleT (Int -> Q Type) -> Int -> Q Type
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ([Q Type] -> Q Type) -> [Q Type] -> Q Type
forall a b. (a -> b) -> a -> b
$
                     [Q Type]
clkTypes [Q Type] -> [Q Type] -> [Q Type]
forall a. Semigroup a => a -> a -> a
<> [ [t| Signal $Q Type
domInTyVar Bool |] ]
  -- (KnownDomain c1, KnownDomain c2, ...)
  cxtType :: Q Type
cxtType
    | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
    = [t| KnownDomain $(Int -> Q Type
clkTyVar Int
1) |]
    | Bool
otherwise
    = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
forall (m :: Type -> Type). Quote m => m Type -> m Type -> m Type
appT (Int -> Q Type
forall (m :: Type -> Type). Quote m => Int -> m Type
tupleT Int
n) ([Q Type] -> Q Type) -> [Q Type] -> Q Type
forall a b. (a -> b) -> a -> b
$
        (Int -> Q Type) -> [Int] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
m -> [t| KnownDomain $(Int -> Q Type
clkTyVar Int
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 :: Q Pat
pllPat = [Q Pat] -> Q Pat
forall (m :: Type -> Type). Quote m => [m Pat] -> m Pat
tupP ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (Int -> Q Pat) -> [Int] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP (Name -> Q Pat) -> (Int -> Name) -> Int -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Name
forall {a}. Show a => a -> Name
clkVarName) [Int
1..Int
n] [Q Pat] -> [Q Pat] -> [Q Pat]
forall a. Semigroup a => a -> a -> a
<> [Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
pllLock]
  syncImpl :: a -> m Exp
syncImpl a
m =
    [|
      setName @"resetSynchronizer" (resetSynchronizer $(Name -> m Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE (Name -> m Exp) -> Name -> m Exp
forall a b. (a -> b) -> a -> b
$ a -> Name
forall {a}. Show a => a -> Name
clkVarName a
m)
        (unsafeFromActiveLow
          (unsafeSynchronizer $(Name -> m Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
clkIn) $(Name -> m Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE (Name -> m Exp) -> Name -> m Exp
forall a b. (a -> b) -> a -> b
$ a -> Name
forall {a}. Show a => a -> Name
clkVarName a
m)
                              $(Name -> m Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
pllLock))))
    |]
  clkAndRstExp :: a -> [m Exp]
clkAndRstExp a
m = [ Name -> m Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE (Name -> m Exp) -> Name -> m Exp
forall a b. (a -> b) -> a -> b
$ a -> Name
forall {a}. Show a => a -> Name
clkVarName a
m
                   , a -> m Exp
forall {m :: Type -> Type} {a}. (Quote m, Show a) => a -> m Exp
syncImpl a
m
                   ]
  -- (c1, r1, c2, r2, ...) where rN is the synchronized reset for clock N
  funcImpl :: Q Exp
funcImpl = [Q Exp] -> Q Exp
forall (m :: Type -> Type). Quote m => [m Exp] -> m Exp
tupE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Int -> [Q Exp]) -> [Int] -> [Q Exp]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap Int -> [Q Exp]
forall {m :: Type -> Type} {a}. (Quote m, Show a) => a -> [m Exp]
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