Generate qsys files for altpll and alterapll

Fixes #545

clash-ghc/src-ghc/Clash/GHC/NetlistTypes.hs

@@ -133,9 +133,19 @@ ghcTypeToHWType iw floatSupport = go
 
         -- XXX: this is a hack to get a KnownDomain from a KnownConfiguration
         "GHC.Classes.(%,%)"
-          | [arg0@(tyView -> TyConApp kdNm _), _] <- args
+          | [arg0@(tyView -> TyConApp kdNm _), arg1] <- args
           , nameOcc kdNm == "Clash.Signal.Internal.KnownDomain"
-          -> ExceptT (MaybeT (go reprs m arg0))
+          -> case tyView arg1 of
+                TyConApp kdNm1 _
+                  | nameOcc kdNm1 == "Clash.Signal.Internal.KnownDomain"
+                  -> do k1 <- (stripVoid . stripFiltered) <$> ExceptT (MaybeT (go reprs m arg0))
+                        k2 <- (stripVoid . stripFiltered) <$> ExceptT (MaybeT (go reprs m arg1))
+                        returnN (Void (Just (Product "(%,%)" Nothing [k1,k2])))
+                  where
+                    stripVoid (Void (Just t)) = t
+                    stripVoid t = t
+                _ -> ExceptT (MaybeT (go reprs m arg0))
+
 
         "Clash.Signal.Internal.KnownDomain"
           -> case tyConDataCons (m `lookupUniqMap'` tc) of

clash-lib/prims/common/Clash_Intel_ClockGen.json

@@ -2,6 +2,12 @@
     { "name"      : "Clash.Intel.ClockGen.altpll"
     , "workInfo"  : "Always"
     , "kind"      : "Declaration"
+    , "includes"  : [ {"extension": "qsys"
+                      ,"name": "altpll"
+                      ,"format": "Haskell"
+                      ,"templateFunction": "Clash.Primitives.Intel.ClockGen.altpllQsysTF"
+                      }
+                    ]
     , "format"    : "Haskell"
     , "templateFunction" : "Clash.Primitives.Intel.ClockGen.altpllTF"
     }
@@ -10,6 +16,12 @@
     { "name"      : "Clash.Intel.ClockGen.alteraPll"
     , "workInfo"  : "Always"
     , "kind"      : "Declaration"
+    , "includes"  : [ {"extension": "qsys"
+                      ,"name": "altera_pll"
+                      ,"format": "Haskell"
+                      ,"templateFunction": "Clash.Primitives.Intel.ClockGen.alteraPllQsysTF"
+                      }
+                    ]
     , "format"    : "Haskell"
     , "templateFunction" : "Clash.Primitives.Intel.ClockGen.alteraPllTF"
     }

clash-lib/src/Clash/Netlist/BlackBox/Util.hs

@@ -54,17 +54,11 @@ import           Clash.Netlist.Types             (BlackBoxContext (..),
                                                   Modifier (..),
                                                   Declaration(BlackBoxD))
 import qualified Clash.Netlist.Types             as N
-import           Clash.Netlist.Util              (typeSize, isVoid)
+import           Clash.Netlist.Util              (typeSize, isVoid, stripVoid)
 import           Clash.Signal.Internal
   (ResetKind(..), ResetPolarity(..), InitBehavior(..))
 import           Clash.Util
 
--- | Strip as many "Void" layers as possible. Might still return a Void if the
--- void doesn't contain a hwtype.
-stripVoid :: HWType -> HWType
-stripVoid (Void (Just e)) = stripVoid e
-stripVoid e = e
-
 inputHole :: Element -> Maybe Int
 inputHole = \case
   Arg _ n       -> pure n

clash-lib/src/Clash/Netlist/Util.hs

@@ -92,6 +92,12 @@ import           Clash.Util
 stripFiltered :: FilteredHWType -> HWType
 stripFiltered (FilteredHWType hwty _filtered) = hwty
 
+-- | Strip as many "Void" layers as possible. Might still return a Void if the
+-- void doesn't contain a hwtype.
+stripVoid :: HWType -> HWType
+stripVoid (Void (Just e)) = stripVoid e
+stripVoid e = e
+
 flattenFiltered :: FilteredHWType -> [[Bool]]
 flattenFiltered (FilteredHWType _hwty filtered) = map (map fst) filtered
 
@@ -456,8 +462,14 @@ mkADT builtInTranslation reprs m _tyString tc args = case tyConDataCons (m `look
         -- If none of the dataconstructors have fields, and there are 1 or less
         -- of them, this type only has one inhabitant. It can therefore be
         -- represented by zero bits, and is therefore empty:
-        | length dcs <= 1 ->
-          return (FilteredHWType (Void Nothing) argHTyss1)
+        | length dcs <= 1 -> case argHTyss0 of
+            [argHTys0] ->
+              -- We need this to preserve constraint-tuples of `KnownDomains`
+              let argHTys1 = map (stripVoid . stripFiltered) argHTys0
+              in  return (FilteredHWType
+                            (Void (Just (Product tcName Nothing argHTys1)))
+                            argHTyss1)
+            _ -> return (FilteredHWType (Void Nothing) argHTyss1)
         -- None of the dataconstructors have fields. This type is therefore a
         -- simple Sum type.
         | otherwise ->

clash-lib/src/Clash/Primitives/Intel/ClockGen.hs

@@ -7,27 +7,42 @@
 -}
 
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE ViewPatterns      #-}
 
 module Clash.Primitives.Intel.ClockGen where
 
 import Clash.Backend
 import Clash.Netlist.BlackBox.Util
 import Clash.Netlist.Id
 import Clash.Netlist.Types
+import Clash.Netlist.Util hiding (mkUniqueIdentifier)
 
 import Control.Monad.State
 
 import Data.Semigroup.Monad
+import qualified Data.String.Interpolate.IsString as I
 import Data.Text.Prettyprint.Doc.Extra
 
 import qualified Data.Text as TextS
 
 altpllTF :: TemplateFunction
 altpllTF = TemplateFunction used valid altpllTemplate
  where
-  used         = [0,1,2]
+  used         = [0..4]
   valid bbCtx
-    | [(nm,_,_),_,_] <- bbInputs bbCtx
+    | [_,_,(nm,_,_),_,_] <- bbInputs bbCtx
+    , Just _ <- exprToString nm
+    , (Identifier _ Nothing,Product {}) <- bbResult bbCtx
+    = True
+  valid _ = False
+
+altpllQsysTF :: TemplateFunction
+altpllQsysTF = TemplateFunction used valid altpllQsysTemplate
+ where
+  used = [0..4]
+  valid bbCtx
+    | [_,_,(nm,_,_),_,_] <- bbInputs bbCtx
     , Just _ <- exprToString nm
     , (Identifier _ Nothing,Product {}) <- bbResult bbCtx
     = True
@@ -36,11 +51,20 @@ altpllTF = TemplateFunction used valid altpllTemplate
 alteraPllTF :: TemplateFunction
 alteraPllTF = TemplateFunction used valid alteraPllTemplate
  where
-  used         = [1,2,3]
+  used         = [1..20]
   valid bbCtx
-    | [_,(nm,_,_),_,_] <- bbInputs bbCtx
+    | ((nm,_,_):_) <- drop 3 (bbInputs bbCtx)
+    , Just _ <- exprToString nm
+    = True
+  valid _ = False
+
+alteraPllQsysTF :: TemplateFunction
+alteraPllQsysTF = TemplateFunction used valid alteraPllQsysTemplate
+ where
+  used  = [1..20]
+  valid bbCtx
+    | ((nm,_,_):_) <- drop 3 (bbInputs bbCtx)
     , Just _ <- exprToString nm
-    , (Identifier _ Nothing,Product {}) <- bbResult bbCtx
     = True
   valid _ = False
 
@@ -52,8 +76,8 @@ alteraPllTemplate bbCtx = do
  let mkId = mkUniqueIdentifier Basic
  locked <- mkId "locked"
  pllLock <- mkId "pllLock"
- alteraPll <- mkId "alteraPll"
- alteraPll_inst <- mkId "alterPll_inst"
+ alteraPll <- mkId "altera_pll_block"
+ alteraPll_inst <- mkId instname0
 
  clocks <- traverse (mkUniqueIdentifier Extended)
                     [TextS.pack ("pllOut" ++ show n) | n <- [0..length tys - 1]]
@@ -77,10 +101,11 @@ alteraPllTemplate bbCtx = do
    ]
   ]
  where
-  [_,(nm,_,_),(clk,clkTy,_),(rst,rstTy,_)] = bbInputs bbCtx
-  (Identifier result Nothing,resTy@(Product _ _ (tail -> tys))) = bbResult bbCtx
+  (Identifier result Nothing,resTy@(Product _ _ (init -> tys))) = bbResult bbCtx
+  [(nm,_,_),(clk,clkTy,_),(rst,rstTy,_)] = drop 3 (bbInputs bbCtx)
   Just nm' = exprToString nm
-  compName = TextS.pack nm'
+  instname0 = TextS.pack nm'
+  compName = head (bbQsysIncName bbCtx)
 
 altpllTemplate
   :: Backend s
@@ -91,14 +116,14 @@ altpllTemplate bbCtx = do
  pllOut <- mkId "pllOut"
  locked <- mkId "locked"
  pllLock <- mkId "pllLock"
- alteraPll <- mkId "altpll"
- alteraPll_inst <- mkId "altpll_inst"
+ alteraPll <- mkId "altpll_block"
+ alteraPll_inst <- mkId instname0
  getMon $ blockDecl alteraPll
   [ NetDecl Nothing locked  Bit
   , NetDecl' Nothing Reg pllLock (Right Bool) Nothing
   , NetDecl Nothing pllOut clkOutTy
   , InstDecl Comp Nothing compName alteraPll_inst []
-      [(Identifier "inclk0" Nothing,In,clkTy,clk)
+      [(Identifier "clk" Nothing,In,clkTy,clk)
       ,(Identifier "areset" Nothing,In,rstTy,rst)
       ,(Identifier "c0" Nothing,Out,clkOutTy,Identifier pllOut Nothing)
       ,(Identifier "locked" Nothing,Out,Bit,Identifier locked Nothing)]
@@ -111,8 +136,88 @@ altpllTemplate bbCtx = do
 
   ]
  where
-  [(nm,_,_),(clk,clkTy,_),(rst,rstTy,_)] = bbInputs bbCtx
+  [_,_,(nm,_,_),(clk,clkTy,_),(rst,rstTy,_)] = bbInputs bbCtx
   (Identifier result Nothing,resTy@(Product _ _ [clkOutTy,_])) = bbResult bbCtx
   Just nm' = exprToString nm
-  compName = TextS.pack nm'
+  instname0 = TextS.pack nm'
+  compName = head (bbQsysIncName bbCtx)
+
+
+altpllQsysTemplate
+  :: Backend s
+  => BlackBoxContext
+  -> State s Doc
+altpllQsysTemplate bbCtx = pure bbText
+ where
+  ((_,stripVoid -> kdIn,_):(_,stripVoid -> kdOut,_):_) = bbInputs bbCtx
+  KnownDomain _ clkInPeriod _ _ _ _ = kdIn
+  KnownDomain _ clkOutPeriod _ _ _ _ = kdOut
+  clkOutFreq :: Double
+  clkOutFreq = (1.0 / (fromInteger clkOutPeriod * 1.0e-12)) / 1e6
+  clklcm = lcm clkInPeriod clkOutPeriod
+  clkmult = clklcm `quot` clkOutPeriod
+  clkdiv = clklcm `quot` clkInPeriod
+  bbText = [I.i|<?xml version="1.0" encoding="UTF-8"?>
+<system name="$${FILENAME}">
+  <module
+    name="altpll0"
+    kind="altpll"
+    enabled="1"
+    autoexport="1">
+  <parameter name="AVALON_USE_SEPARATE_SYSCLK" value="NO" />
+  <parameter name="BANDWIDTH" value="" />
+  <parameter name="BANDWIDTH_TYPE" value="AUTO" />
+  <parameter name="CLK0_DIVIDE_BY" value="#{clkdiv}" />
+  <parameter name="CLK0_DUTY_CYCLE" value="50" />
+  <parameter name="CLK0_MULTIPLY_BY" value="#{clkmult}" />
+  <parameter name="CLK0_PHASE_SHIFT" value="0" />
+  <parameter name="COMPENSATE_CLOCK" value="CLK0" />
+  <parameter name="INCLK0_INPUT_FREQUENCY" value="#{clkInPeriod}" />
+  <parameter name="OPERATION_MODE" value="NORMAL" />
+  <parameter name="PLL_TYPE" value="AUTO" />
+  <parameter name="PORT_ARESET" value="PORT_USED" />
+  <parameter name="PORT_INCLK0" value="PORT_USED" />
+  <parameter name="PORT_LOCKED" value="PORT_USED" />
+  <parameter name="PORT_clk0" value="PORT_USED" />
+  <parameter name="HIDDEN_IS_FIRST_EDIT" value="0" />
+  <parameter name="HIDDEN_PRIVATES">PT#EFF_OUTPUT_FREQ_VALUE0 #{clkOutFreq}</parameter>
+  </module>
+</system>|]
+
+alteraPllQsysTemplate
+  :: Backend s
+  => BlackBoxContext
+  -> State s Doc
+alteraPllQsysTemplate bbCtx = pure bbText
+ where
+  (_:(_,stripVoid -> kdIn,_):(_,stripVoid -> kdOutsProd,_):_) = bbInputs bbCtx
+  kdOuts = case kdOutsProd of
+    Product _ _ ps -> ps
+    KnownDomain {} -> [kdOutsProd]
+    _ -> error "internal error: not a Product or KnownDomain"
+
+  cklFreq (KnownDomain _ p _ _ _ _)
+    = (1.0 / (fromInteger p * 1.0e-12 :: Double)) / 1e6
+  cklFreq _ = error "internal error: not a KnownDomain"
+
+  clkOuts = TextS.unlines
+    [[I.i|<parameter name="gui_output_clock_frequency#{n}" value="#{f}"/>|]
+    | (n,f) <- zip [(0 :: Word)..] (map cklFreq kdOuts)
+    ]
 
+  bbText = [I.i|<?xml version="1.0" encoding="UTF-8"?>
+<system name="$${FILENAME}">
+ <module
+    name="pll_0"
+    kind="altera_pll"
+    enabled="1"
+    autoexport="1">
+  <parameter name="gui_feedback_clock" value="Global Clock" />
+  <parameter name="gui_number_of_clocks" value="#{length kdOuts}" />
+  <parameter name="gui_operation_mode" value="direct" />
+  #{clkOuts}
+  <parameter name="gui_pll_mode" value="Integer-N PLL" />
+  <parameter name="gui_reference_clock_frequency" value="#{cklFreq kdIn}" />
+  <parameter name="gui_use_locked" value="true" />
+ </module>
+</system>|]

clash-prelude/src/Clash/Clocks.hs

@@ -7,18 +7,25 @@ Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>
 Generic clock related utilities.
 -}
 
+{-# LANGUAGE ConstrainedClassMethods #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
 
-module Clash.Clocks (Clocks, clocks) where
+module Clash.Clocks (Clocks(..)) where
+
+import Data.Kind (Constraint)
 
 import Clash.Signal.Internal
 import Clash.Clocks.Deriving (deriveClocksInstances)
 
 class Clocks t where
+  type ClocksCxt t :: Constraint
+
   clocks
-    :: Clock domIn
+    :: (KnownDomain domIn, ClocksCxt t)
+    => Clock domIn
     -> Reset domIn
     -> t
 

clash-prelude/src/Clash/Clocks/Deriving.hs

@@ -5,6 +5,7 @@ License    :  BSD2 (see the file LICENSE)
 Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>
 -}
 
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
 
@@ -20,8 +21,17 @@ import Unsafe.Coerce               (unsafeCoerce)
 derive' :: Int -> Q Dec
 derive' n = do
   -- (Clock d0, Clock d1, )
-  instType  <- foldM (\a n' -> AppT a <$> clkType n') (TupleT $ n + 1) [1..n]
-  instType' <- (AppT (ConT $ mkName "Clocks") . AppT instType) <$> lockType
+  instType0 <- foldM (\a n' -> AppT a <$> clkType n') (TupleT $ n + 1) [1..n]
+  instType1 <- AppT instType0 <$> lockType
+  let instHead = AppT (ConT $ mkName "Clocks") instType1
+
+  cxtRHS <- foldM (\a n' -> AppT a <$> knownDomainCxt n') (TupleT n) [1..n]
+#if MIN_VERSION_template_haskell(2,15,0)
+  let cxtLHS = AppT (ConT $ mkName "ClocksCxt") instType1
+  let cxtTy  = TySynInstD (TySynEqn Nothing cxtLHS cxtRHS)
+#else
+  let cxtTy  = TySynInstD (mkName "ClocksCxt") (TySynEqn [instType1] cxtRHS)
+#endif
 
   -- Function definition of 'clocks'
   let clk = mkName "clk"
@@ -34,14 +44,18 @@ derive' n = do
   let funcBody  = NormalB instTuple
   let instFunc  = FunD (mkName "clocks") [Clause [VarP clk, VarP rst] funcBody []]
 
-  return $ InstanceD Nothing [] instType' [instFunc, noInline]
+  return $ InstanceD Nothing [] instHead [cxtTy, instFunc, noInline]
 
   where
     -- | Generate type @Clock dom@ with fresh @dom@ variable
     clkType n' =
       let c = varT $ mkName ("c" ++ show n') in
       [t| Clock $c |]
 
+    knownDomainCxt n' =
+      let c = varT $ mkName ("c" ++ show n') in
+      [t| KnownDomain $c |]
+
     -- | Generate type @Signal dom 'Bool@ with fresh @dom@ variable
     lockType =
       let c = varT $ mkName "pllLock" in