diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,19 @@ # Changelog for the [`clash-lib`](http://hackage.haskell.org/package/clash-lib) package +## 0.99 *March 31st 2018* +* New features: + * Support for `clash-prelude-0.99`: + * Explicit clock and reset arguments + * Overhaul of `TopEntity` annotations + * Hierarchies with multiple synthesisable boundaries by allowing more than one + function in scope to have a `Synthesize` annotation. + * Local caching of functions with a `Synthesize` annotation + * `Bit` type is mapped to a HDL scalar type (e.g. `std_logic` in VHDL) + * Improved name preservation + * Zero-bit values are filtered out of the generated HDL + * Improved compile-time computation +* Many bug fixes + ## 0.7.1 *April 11th 2017* * New features: * Support distribution of primitive templates with Cabal/Hackage packages [commit](https://github.com/clash-lang/clash-compiler/commit/82cd31863aafcbaf3bdbf7746d89d13859af5aaf) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,5 +1,6 @@ Copyright (c) 2012-2016, University of Twente, - 2017, QBayLogic + 2016-2017, Myrtle Software Ltd, + 2017 , QBayLogic, Google Inc. All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/clash-lib.cabal b/clash-lib.cabal --- a/clash-lib.cabal +++ b/clash-lib.cabal @@ -1,5 +1,5 @@ Name: clash-lib -Version: 0.7.1 +Version: 0.99 Synopsis: CAES Language for Synchronous Hardware - As a Library Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that @@ -48,13 +48,23 @@ License-file: LICENSE Author: Christiaan Baaij Maintainer: Christiaan Baaij -Copyright: Copyright © 2012-2016, University of Twente, 2017, QBayLogic +Copyright: Copyright © 2012-2016, University of Twente, + 2016-2017, Myrtle Software Ltd, + 2017 , QBayLogic, Google Inc. Category: Hardware Build-type: Simple -Extra-source-files: README.md, - CHANGELOG.md +Extra-source-files: + README.md, + CHANGELOG.md +Data-files: + prims/common/*.json, + prims/commonverilog/*.json, + prims/verilog/*.json, + prims/systemverilog/*.json, + prims/vhdl/*.json + Cabal-version: >=1.10 source-repository head @@ -86,81 +96,90 @@ TupleSections ViewPatterns - Build-depends: aeson >= 0.6.2.0 && < 1.2, + Build-depends: aeson >= 0.6.2.0 && < 1.3, + ansi-wl-pprint >= 0.6.8.2 && < 1.0, attoparsec >= 0.10.4.0 && < 0.14, base >= 4.8 && < 5, bytestring >= 0.10.0.2 && < 0.11, - clash-prelude >= 0.11 && < 0.12, + clash-prelude >= 0.11.1 && < 1.0, concurrent-supply >= 0.1.7 && < 0.2, containers >= 0.5.0.0 && < 0.6, data-binary-ieee754 >= 0.4.4 && < 0.6, deepseq >= 1.3.0.2 && < 1.5, directory >= 1.2.0.1 && < 1.4, - errors >= 1.4.2 && < 2.2, - fgl >= 5.4.2.4 && < 5.6, + errors >= 1.4.2 && < 2.3, + fgl >= 5.4.2.4 && < 5.7, filepath >= 1.3.0.1 && < 1.5, - ghc >= 8.0.1 && < 8.2, + ghc >= 8.0.2 && < 8.6, hashable >= 1.2.1.0 && < 1.3, integer-gmp >= 1.0 && < 1.1, - lens >= 3.9.2 && < 4.16, + lens >= 3.9.2 && < 4.17, mtl >= 2.1.2 && < 2.3, - pretty >= 1.1.1.0 && < 1.2, - process >= 1.1.0.2 && < 1.5, - template-haskell >= 2.8.0.0 && < 2.12, + parsers >= 0.12.8 && < 1.0, + prettyprinter >= 1.2.0.1 && < 2.0, + process >= 1.1.0.2 && < 1.7, + reducers >= 3.12.2 && < 4.0, + template-haskell >= 2.8.0.0 && < 2.14, text >= 0.11.3.1 && < 1.3, - time >= 1.4.0.1 && < 1.8, + time >= 1.4.0.1 && < 1.9, transformers >= 0.3.0.0 && < 0.6, + trifecta >= 1.7.1.1 && < 2.0, unbound-generics >= 0.1 && < 0.4, - unordered-containers >= 0.2.3.3 && < 0.3, - uu-parsinglib >= 2.8.1 && < 2.10, - wl-pprint-text >= 1.1.0.0 && < 1.2 + unordered-containers >= 0.2.3.3 && < 0.3 - Exposed-modules: CLaSH.Backend + Exposed-modules: Clash.Backend + Clash.Backend.SystemVerilog + Clash.Backend.Verilog + Clash.Backend.VHDL - CLaSH.Core.DataCon - CLaSH.Core.FreeVars - CLaSH.Core.Literal - CLaSH.Core.Pretty - CLaSH.Core.Subst - CLaSH.Core.Term - CLaSH.Core.TyCon - CLaSH.Core.Type - CLaSH.Core.TysPrim - CLaSH.Core.Util - CLaSH.Core.Var + Clash.Core.DataCon + Clash.Core.Evaluator + Clash.Core.FreeVars + Clash.Core.Literal + Clash.Core.Name + Clash.Core.Pretty + Clash.Core.Subst + Clash.Core.Term + Clash.Core.TyCon + Clash.Core.Type + Clash.Core.TysPrim + Clash.Core.Util + Clash.Core.Var - CLaSH.Driver - CLaSH.Driver.TestbenchGen - CLaSH.Driver.TopWrapper - CLaSH.Driver.Types + Clash.Driver + Clash.Driver.Types - CLaSH.Netlist - CLaSH.Netlist.BlackBox - CLaSH.Netlist.BlackBox.Parser - CLaSH.Netlist.BlackBox.Types - CLaSH.Netlist.BlackBox.Util - CLaSH.Netlist.Id - CLaSH.Netlist.Types - CLaSH.Netlist.Util + Clash.Netlist + Clash.Netlist.BlackBox + Clash.Netlist.BlackBox.Parser + Clash.Netlist.BlackBox.Types + Clash.Netlist.BlackBox.Util + Clash.Netlist.Id + Clash.Netlist.Types + Clash.Netlist.Util - CLaSH.Normalize - CLaSH.Normalize.DEC - CLaSH.Normalize.PrimitiveReductions - CLaSH.Normalize.Strategy - CLaSH.Normalize.Transformations - CLaSH.Normalize.Types - CLaSH.Normalize.Util + Clash.Normalize + Clash.Normalize.DEC + Clash.Normalize.PrimitiveReductions + Clash.Normalize.Strategy + Clash.Normalize.Transformations + Clash.Normalize.Types + Clash.Normalize.Util - CLaSH.Primitives.Types - CLaSH.Primitives.Util + Clash.Primitives.Types + Clash.Primitives.Util - CLaSH.Rewrite.Combinators - CLaSH.Rewrite.Types - CLaSH.Rewrite.Util + Clash.Rewrite.Combinators + Clash.Rewrite.Types + Clash.Rewrite.Util - CLaSH.Util + Clash.Util - Other-Modules: Data.Aeson.Extra - GHC.Extra + Other-Modules: Clash.Annotations.TopEntity.Extra + Data.Aeson.Extra + Data.Semigroup.Monad.Extra + Data.Text.Prettyprint.Doc.Extra + GHC.BasicTypes.Extra + GHC.SrcLoc.Extra Paths_clash_lib Unbound.Generics.LocallyNameless.Extra diff --git a/prims/common/Clash_Class_BitPack.json b/prims/common/Clash_Class_BitPack.json new file mode 100644 --- /dev/null +++ b/prims/common/Clash_Class_BitPack.json @@ -0,0 +1,29 @@ +[ { "BlackBox" : + { "name" : "Clash.Class.BitPack.packFloat#" + , "type" : +"packFloat# :: Float -> BitVector 32" + , "templateE" : "~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Class.BitPack.unpackFloat#" + , "type" : +"packFloat# :: BitVector 32 -> Float" + , "templateE" : "~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Class.BitPack.packDouble#" + , "type" : +"packFloat# :: Double -> BitVector 64" + , "templateE" : "~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Class.BitPack.unpackDouble#" + , "type" : +"packFloat# :: BitVector 64 -> Double" + , "templateE" : "~ARG[0]" + } + } +] diff --git a/prims/common/Clash_Explicit_Signal.json b/prims/common/Clash_Explicit_Signal.json new file mode 100644 --- /dev/null +++ b/prims/common/Clash_Explicit_Signal.json @@ -0,0 +1,12 @@ +[ { "BlackBox" : + { "name" : "Clash.Explicit.Signal.unsafeSynchronizer" + , "type" : +"unsafeSynchronizer + :: Clock dom1 g1 + -> Clock dom2 g2 + -> Signal dom1 a -- ARG[2] + -> Signal dom2 a" + , "templateE" : "~ARG[2]" + } + } +] diff --git a/prims/common/Clash_GHC_GHC2Core.json b/prims/common/Clash_GHC_GHC2Core.json new file mode 100644 --- /dev/null +++ b/prims/common/Clash_GHC_GHC2Core.json @@ -0,0 +1,16 @@ +[ { "BlackBox" : + { "name" : "EmptyCase" + , "templateE" : "~ERRORO" + } + } +, { "Primitive" : + { "name" : "_CO_" + , "primType" : "Constructor" + } + } +, { "Primitive" : + { "name" : "_TY_" + , "primType" : "Constructor" + } + } +] diff --git a/prims/common/Clash_Promoted_Nat_Unsafe.json b/prims/common/Clash_Promoted_Nat_Unsafe.json new file mode 100644 --- /dev/null +++ b/prims/common/Clash_Promoted_Nat_Unsafe.json @@ -0,0 +1,7 @@ +[ { "BlackBox" : + { "name" : "Clash.Promoted.Nat.Unsafe.unsafeSNat" + , "type" : "Clash.Promoted.Nat.Unsafe.unsafeSNat :: Integer -> SNat k" + , "templateE" : "~LIT[0]" + } + } +] diff --git a/prims/common/Clash_Promoted_Symbol.json b/prims/common/Clash_Promoted_Symbol.json new file mode 100644 --- /dev/null +++ b/prims/common/Clash_Promoted_Symbol.json @@ -0,0 +1,13 @@ +[ { "BlackBox" : + { "name" : "Clash.Promoted.Symbol.SSymbol" + , "type" : "SSymbol :: KnownNat n => Proxy n -> SSymbol n" + , "templateE" : "~LIT[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Promoted.Symbol.symbolToString" + , "type" : "symbolToString :: SSymbol n -> String" + , "templateE" : "~LIT[0]" + } + } +] diff --git a/prims/common/Clash_Signal_Bundle.json b/prims/common/Clash_Signal_Bundle.json new file mode 100644 --- /dev/null +++ b/prims/common/Clash_Signal_Bundle.json @@ -0,0 +1,6 @@ +[ { "Primitive" : + { "name" : "Clash.Signal.Bundle.vecBundle#" + , "primType" : "Function" + } + } +] diff --git a/prims/common/Clash_Transformations.json b/prims/common/Clash_Transformations.json new file mode 100644 --- /dev/null +++ b/prims/common/Clash_Transformations.json @@ -0,0 +1,7 @@ +[ { "BlackBox" : + { "name" : "Clash.Transformations.removedArg" + , "type" : "removedArg :: a" + , "templateE" : "~ERRORO" + } + } +] diff --git a/prims/common/Clash_XException.json b/prims/common/Clash_XException.json new file mode 100644 --- /dev/null +++ b/prims/common/Clash_XException.json @@ -0,0 +1,13 @@ +[ { "BlackBox" : + { "name" : "Clash.XException.seqX" + , "type" : "seqX :: a -> b -> b" + , "templateE" : "~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.XException.errorX" + , "type" : "errorX :: HasCallStack -> String -> a" + , "templateE" : "~ERRORO" + } + } +] diff --git a/prims/common/Control_Exception_Base.json b/prims/common/Control_Exception_Base.json new file mode 100644 --- /dev/null +++ b/prims/common/Control_Exception_Base.json @@ -0,0 +1,25 @@ +[ { "BlackBox" : + { "name" : "Control.Exception.Base.patError" + , "type" : "patError :: Addr# -> a" + , "templateE" : "~ERRORO" + } + } +, { "BlackBox" : + { "name" : "Control.Exception.Base.irrefutPatError" + , "type" : "irrefutPatError :: Addr# -> a" + , "templateE" : "~ERRORO" + } + } +, { "BlackBox" : + { "name" : "Control.Exception.Base.recSelError" + , "type" : "recSelError :: Addr# -> a" + , "templateE" : "~ERRORO" + } + } +, { "BlackBox" : + { "name" : "Control.Exception.Base.absentError" + , "type" : "absentError :: Addr# -> a" + , "templateE" : "~ERRORO" + } + } +] diff --git a/prims/common/Debug_Trace.json b/prims/common/Debug_Trace.json new file mode 100644 --- /dev/null +++ b/prims/common/Debug_Trace.json @@ -0,0 +1,7 @@ +[ { "BlackBox" : + { "name" : "Debug.Trace.trace" + , "type" : "trace :: String -> a -> a" + , "templateE" : "~ARG[1]" + } + } +] diff --git a/prims/common/GHC_CString.json b/prims/common/GHC_CString.json new file mode 100644 --- /dev/null +++ b/prims/common/GHC_CString.json @@ -0,0 +1,16 @@ +[ { "BlackBox" : + { "name" : "GHC.CString.unpackCString#" + , "templateE" : "~LIT[0]" + } + } +, { "BlackBox" : + { "name" : "GHC.CString.unpackFoldrCString#" + , "templateE" : "~LIT[0]" + } + } +, { "Primitive" : + { "name" : "GHC.CString.unpackCStringUtf8#" + , "primType" : "Function" + } + } +] diff --git a/prims/common/GHC_Err.json b/prims/common/GHC_Err.json new file mode 100644 --- /dev/null +++ b/prims/common/GHC_Err.json @@ -0,0 +1,19 @@ +[ { "BlackBox" : + { "name" : "GHC.Err.error" + , "type" : "error :: [Char] -> a" + , "templateE" : "~ERRORO" + } + } +, { "BlackBox" : + { "name" : "GHC.Err.errorWithoutStackTrace" + , "type" : "errorWithoutStackTrace :: [Char] -> a" + , "templateE" : "~ERRORO" + } + } +, { "BlackBox" : + { "name" : "GHC.Err.undefined" + , "type" : "undefined :: a" + , "templateE" : "~ERRORO" + } + } +] diff --git a/prims/common/GHC_IO_Exception.json b/prims/common/GHC_IO_Exception.json new file mode 100644 --- /dev/null +++ b/prims/common/GHC_IO_Exception.json @@ -0,0 +1,12 @@ +[ { "BlackBox" : + { "name" : "GHC.IO.Exception.assertError" + , "type" : "assertError :: HasCallStack => Bool -> a -> a" + , "comment" : "It would be nice if we could use a HDL assertion, however, + because in HDL, case alternatives are evaluated + concurrently, we would end up with the assertion being + triggered, even when the result of that branch is not + chosen in the multiplexer" + , "templateE" : "~ARG[2]" + } + } +] diff --git a/prims/common/GHC_Magic.json b/prims/common/GHC_Magic.json new file mode 100644 --- /dev/null +++ b/prims/common/GHC_Magic.json @@ -0,0 +1,11 @@ +[ { "Primitive" : + { "name" : "GHC.Magic.lazy" + , "primType" : "Function" + } + } +, { "Primitive" : + { "name" : "GHC.Magic.runRW#" + , "primType" : "Function" + } + } +] diff --git a/prims/common/GHC_Natural.json b/prims/common/GHC_Natural.json new file mode 100644 --- /dev/null +++ b/prims/common/GHC_Natural.json @@ -0,0 +1,12 @@ +[ { "Primitive" : + { "name" : "GHC.Natural.NatS#" + , "primType" : "Constructor" + } + } +, { "BlackBox" : + { "name" : "GHC.Natural.underflowError" + , "type" : "underflowError :: a" + , "templateE" : "~ERRORO" + } + } +] diff --git a/prims/common/GHC_Real.json b/prims/common/GHC_Real.json new file mode 100644 --- /dev/null +++ b/prims/common/GHC_Real.json @@ -0,0 +1,19 @@ +[ { "BlackBox" : + { "name" : "GHC.Real.divZeroError" + , "type" : "divZeroError :: a" + , "templateE" : "~ERRORO" + } + } +, { "BlackBox" : + { "name" : "GHC.Real.ratioZeroDenominatorError" + , "type" : "ratioZeroDenominatorError :: a" + , "templateE" : "~ERRORO" + } + } +, { "BlackBox" : + { "name" : "GHC.Real.overflowError" + , "type" : "overflowError :: a" + , "templateE" : "~ERRORO" + } + } +] diff --git a/prims/common/GHC_TypeNats.json b/prims/common/GHC_TypeNats.json new file mode 100644 --- /dev/null +++ b/prims/common/GHC_TypeNats.json @@ -0,0 +1,7 @@ +[ { "BlackBox" : + { "name" : "GHC.TypeNats.natVal" + , "type" : "natVal :: forall n proxy. KnownNat n => proxy n -> Natural" + , "templateE" : "~ARG[0]" + } + } +] diff --git a/prims/common/GHC_Typelits.json b/prims/common/GHC_Typelits.json new file mode 100644 --- /dev/null +++ b/prims/common/GHC_Typelits.json @@ -0,0 +1,7 @@ +[ { "BlackBox" : + { "name" : "GHC.TypeLits.natVal" + , "type" : "natVal :: forall n proxy. KnownNat n => proxy n -> Integer" + , "templateE" : "~ARG[0]" + } + } +] diff --git a/prims/common/Unsafe_Coerce.json b/prims/common/Unsafe_Coerce.json new file mode 100644 --- /dev/null +++ b/prims/common/Unsafe_Coerce.json @@ -0,0 +1,7 @@ +[ { "BlackBox" : + { "name" : "Unsafe.Coerce.unsafeCoerce" + , "type" : "unsafeCoerce :: a -> b" + , "templateE" : "~ARG[0]" + } + } +] diff --git a/prims/commonverilog/Clash_Promoted_Nat.json b/prims/commonverilog/Clash_Promoted_Nat.json new file mode 100644 --- /dev/null +++ b/prims/commonverilog/Clash_Promoted_Nat.json @@ -0,0 +1,75 @@ +[ { "BlackBox" : + { "name" : "Clash.Promoted.Nat.powSNat" + , "type" : "Clash.Promoted.Nat.powSNat :: SNat a -> SNat b -> SNat (a^b)" + , "templateE" : "~LIT[0] ** ~LIT[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Promoted.Nat.flogBaseSNat" + , "type" : "Clash.Promoted.Nat.flogBaseSNat :: (2 <= base, 1 <= x) + => SNat base -- ARG[2] + -> SNat x -- ARG[3] + -> SNat (FLog base x" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "flogBase" + , "extension" : "inc" + , "content" : +"// floor of logBase +function integer ~INCLUDENAME; + input integer base, value; + begin + for (~INCLUDENAME = 0; value >= base; ~INCLUDENAME=~INCLUDENAME+1) + value = value / base; + end +endfunction" + } + , "templateE" : "~INCLUDENAME(~LIT[2],~LIT[3])" + } + } +, { "BlackBox" : + { "name" : "Clash.Promoted.Nat.clogBaseSNat" + , "type" : "Clash.Promoted.Nat.clogBaseSNat :: (2 <= base, 1 <= x) + => SNat base -- ARG[2] + -> SNat x -- ARG[3] + -> SNat (CLog base x" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "clogBase" + , "extension" : "inc" + , "content" : +"// ceiling of logBase +function integer ~INCLUDENAME; + input integer base, value; + begin + for (~INCLUDENAME = 0; base ** ~INCLUDENAME < value; ~~INCLUDENAME=~INCLUDENAME+1); + end +endfunction" + } + , "templateE" : "~INCLUDENAME(~LIT[2],~LIT[3])" + } + } +, { "BlackBox" : + { "name" : "Clash.Promoted.Nat.logBaseSNat" + , "type" : "Clash.Promoted.Nat.logBaseSNat :: (FLog base x ~ CLog base x) + => SNat base -- ARG[1] + -> SNat x -- ARG[2] + -> SNat (Log base x)" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "clogBase" + , "extension" : "inc" + , "content" : +"// logBaseSNat begin +function integer ~INCLUDENAME; + input integer base, value; + begin + for (~INCLUDENAME = 0; value >= base; ~INCLUDENAME=~INCLUDENAME+1) + value = value / base; + end +endfunction" + } + , "templateE" : "~INCLUDENAME(~LIT[1],~LIT[2])" + } + } +] diff --git a/prims/commonverilog/Clash_Sized_Internal_BitVector.json b/prims/commonverilog/Clash_Sized_Internal_BitVector.json new file mode 100644 --- /dev/null +++ b/prims/commonverilog/Clash_Sized_Internal_BitVector.json @@ -0,0 +1,151 @@ +[ { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.high" + , "type" : "high :: Bit" + , "templateE" : "1'b1" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.low" + , "type" : "low :: Bit" + , "templateE" : "1'b0" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.pack#" + , "type" : "pack# :: Bit -> BitVector 1" + , "templateE" : "~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.unpack#" + , "type" : "unpack# :: BitVector 1 -> Bit" + , "templateE" : "~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.reduceAnd#" + , "type" : "reduceAnd# :: KnownNat n => BitVector n -> Bit" + , "templateE" : "& (~ARG[1])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.reduceOr#" + , "type" : "reduceOr# :: BitVector n -> Bit" + , "templateE" : "| (~ARG[0])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.reduceXor#" + , "type" : "reduceXor# :: BitVector n -> Bit" + , "templateE" : "^ (~ARG[0])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.eq##" + , "type" : "eq## :: Bit -> Bit -> Bool" + , "templateE" : "~ARG[0] == ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.neq##" + , "type" : "neq## :: Bit -> Bit -> Bool" + , "templateE" : "~ARG[0] != ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.lt##" + , "type" : "lt## :: Bit -> Bit -> Bool" + , "templateE" : "~ARG[0] < ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.ge##" + , "type" : "ge## :: Bit -> Bit -> Bool" + , "templateE" : "~ARG[0] >= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.gt##" + , "type" : "gt## :: Bit -> Bit -> Bool" + , "templateE" : "~ARG[0] > ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.le##" + , "type" : "le## :: Bit -> Bit -> Bool" + , "templateE" : "~ARG[0] <= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.fromInteger##" + , "type" : "fromInteger# :: Integer -> Bit" + , "templateE" : "~VAR[i][0][0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.and##" + , "type" : "and## :: Bit -> Bit -> Bit" + , "templateE" : "~ARG[0] & ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.or##" + , "type" : "or## :: Bit -> Bit -> Bit" + , "templateE" : "~ARG[0] | ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.xor##" + , "type" : "xor## :: Bit -> Bit -> Bit" + , "templateE" : "~ARG[0] ^ ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.complement##" + , "type" : "complement## :: Bit -> Bit" + , "templateE" : "~ ~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.eq#" + , "type" : "eq# :: BitVector n -> BitVector n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] == ~ARG[1]~ELSE1'b1~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.neq#" + , "type" : "neq# :: BitVector n -> BitVector n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] != ~ARG[1]~ELSE1'b0~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.lt#" + , "type" : "lt# :: BitVector n -> BitVector n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] < ~ARG[1]~ELSE1'b0~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.ge#" + , "type" : "ge# :: BitVector n -> BitVector n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] >= ~ARG[1]~ELSE1'b1~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.gt#" + , "type" : "gt# :: BitVector n -> BitVector n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] > ~ARG[1]~ELSE1'b0~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.le#" + , "type" : "le# :: BitVector n -> BitVector n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] <= ~ARG[1]~ELSE1'b1~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.toInteger#" + , "type" : "toInteger# :: BitVector n -> Integer" + , "templateD" : "assign ~RESULT = ~IF~SIZE[~TYP[0]]~THEN$unsigned(~ARG[0])~ELSE64'sd0~FI;" + } + } +] diff --git a/prims/commonverilog/Clash_Sized_Internal_Index.json b/prims/commonverilog/Clash_Sized_Internal_Index.json new file mode 100644 --- /dev/null +++ b/prims/commonverilog/Clash_Sized_Internal_Index.json @@ -0,0 +1,121 @@ +[ { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.pack#" + , "type" : "pack# :: Index n -> BitVector (CLog 2 n)" + , "templateE" : "~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.unpack#" + , "type" : "unpack# :: KnownNat n => BitVector (CLog 2 n) -> Index n" + , "templateE" : "~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.eq#" + , "type" : "eq# :: Index n -> Index n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] == ~ARG[1]~ELSE1'b1~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.neq#" + , "type" : "neq# :: Index n -> Index n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] != ~ARG[1]~ELSE1'b0~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.lt#" + , "type" : "lt# :: Index n -> Index n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] < ~ARG[1]~ELSE1'b0~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.ge#" + , "type" : "ge# :: Index n -> Index n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] >= ~ARG[1]~ELSE1'b1~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.gt#" + , "type" : "gt# :: Index n -> Index n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] > ~ARG[1]~ELSE1'b0~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.le#" + , "type" : "le# :: Index n -> Index n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] <= ~ARG[1]~ELSE1'b1~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.maxBound#" + , "type" : "maxBound# :: KnownNat n => Index n" + , "templateE" : "~ARG[0]-~SIZE[~TYPO]'d1" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.+#" + , "type" : "(+#) :: KnownNat n => Index n -> Index n -> Index n" + , "templateE" : "~ARG[1] + ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.-#" + , "type" : "(-#) :: KnownNat n => Index n -> Index n -> Index n" + , "templateE" : "~ARG[1] - ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.*#" + , "type" : "(*#) :: KnownNat n => Index n -> Index n -> Index n" + , "templateE" : "~ARG[1] * ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.fromInteger#" + , "type" : "fromInteger# :: KnownNat n => Integer -> Index n" + , "templateE" : "$unsigned(~ARG[1][(~SIZE[~TYPO]-1):0])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.plus#" + , "type" : "Index m -> Index n -> Index (m + n - 1)" + , "templateD" : "assign ~RESULT = ~ARG[0] + ~ARG[1];" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.minus#" + , "type" : "Index m -> Index n -> Index (m + n - 1)" + , "templateD" : "assign ~RESULT = ~ARG[0] - ~ARG[1];" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.times#" + , "type" : "Index m -> Index n -> Index (((m-1) * (n-1)) + 1)" + , "templateD" : "assign ~RESULT = ~ARG[0] * ~ARG[1];" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.quot#" + , "type" : "quot# :: Index n -> Index n -> Index n" + , "templateE" : "~ARG[0] / ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.rem#" + , "type" : "rem# :: Index n -> Index n -> Index n" + , "templateE" : "~ARG[0] % ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.toInteger#" + , "type" : "toInteger# :: Index n -> Integer" + , "templateD" : "assign ~RESULT = ~IF~SIZE[~TYP[0]]~THEN$unsigned(~ARG[0])~ELSE64'sd0~FI;" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.resize#" + , "type" : "resize# :: KnownNat m => Index n -> Index m" + , "templateD" : "assign ~RESULT = $unsigned(~ARG[1]);" + } + } +] diff --git a/prims/commonverilog/Clash_Sized_Internal_Signed.json b/prims/commonverilog/Clash_Sized_Internal_Signed.json new file mode 100644 --- /dev/null +++ b/prims/commonverilog/Clash_Sized_Internal_Signed.json @@ -0,0 +1,43 @@ +[ { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.eq#" + , "type" : "eq# :: Signed n -> Signed n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] == ~ARG[1]~ELSE1'b1~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.neq#" + , "type" : "neq# :: Signed n -> Signed n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] != ~ARG[1]~ELSE1'b0~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.lt#" + , "type" : "lt# :: Signed n -> Signed n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] < ~ARG[1]~ELSE1'b0~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.ge#" + , "type" : "ge# :: Signed n -> Signed n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] >= ~ARG[1]~ELSE1'b1~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.gt#" + , "type" : "gt# :: Signed n -> Signed n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] > ~ARG[1]~ELSE1'b0~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.le#" + , "type" : "le# :: Signed n -> Signed n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] <= ~ARG[1]~ELSE1'b1~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.toInteger#" + , "type" : "toInteger# :: Signed n -> Integer" + , "templateD" : "assign ~RESULT = ~IF~SIZE[~TYP[0]]~THEN$unsigned(~ARG[0])~ELSE64'sd0~FI;" + } + } +] diff --git a/prims/commonverilog/Clash_Sized_Internal_Unsigned.json b/prims/commonverilog/Clash_Sized_Internal_Unsigned.json new file mode 100644 --- /dev/null +++ b/prims/commonverilog/Clash_Sized_Internal_Unsigned.json @@ -0,0 +1,43 @@ +[ { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.eq#" + , "type" : "eq# :: Unsigned n -> Unsigned n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] == ~ARG[1]~ELSE1'b1~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.neq#" + , "type" : "neq# :: Unsigned n -> Unsigned n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] != ~ARG[1]~ELSE1'b0~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.lt#" + , "type" : "lt# :: Unsigned n -> Unsigned n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] < ~ARG[1]~ELSE1'b0~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.ge#" + , "type" : "ge# :: Unsigned n -> Unsigned n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] >= ~ARG[1]~ELSE1'b1~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.gt#" + , "type" : "gt# :: Unsigned n -> Unsigned n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] > ~ARG[1]~ELSE1'b0~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.le#" + , "type" : "le# :: Unsigned n -> Unsigned n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] <= ~ARG[1]~ELSE1'b1~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.toInteger#" + , "type" : "toInteger# :: Unsigned n -> Integer" + , "templateD" : "assign ~RESULT = ~IF~SIZE[~TYP[0]]~THEN$unsigned(~ARG[0])~ELSE64'sd0~FI;" + } + } +] diff --git a/prims/commonverilog/GHC_Integer_Logarithms.json b/prims/commonverilog/GHC_Integer_Logarithms.json new file mode 100644 --- /dev/null +++ b/prims/commonverilog/GHC_Integer_Logarithms.json @@ -0,0 +1,21 @@ +[ { "BlackBox" : + { "name" : "GHC.Integer.Logarithms.integerLogBase#" + , "type" : "integerLogBase# :: Integer -> Integer -> Int#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "integerLogBase" + , "extension" : "inc" + , "content" : +"// integer logBase +function integer ~INCLUDENAME; + input integer base, value; + begin + for (~INCLUDENAME = 0; value >= base; ~INCLUDENAME=~INCLUDENAME+1) + value = value / base; + end +endfunction" + } + , "templateE" : "~INCLUDENAME(~ARG[0],~ARG[1])" + } + } +] diff --git a/prims/systemverilog/Clash_Explicit_BlockRam.json b/prims/systemverilog/Clash_Explicit_BlockRam.json new file mode 100644 --- /dev/null +++ b/prims/systemverilog/Clash_Explicit_BlockRam.json @@ -0,0 +1,44 @@ +[ { "BlackBox" : + { "name" : "Clash.Explicit.BlockRam.blockRam#" + , "type" : +"blockRam# + :: HasCallStack -- ARG[0] + => Clock dom gated -- clk, ARG[1] + -> Vec n a -- init, ARG[2] + -> Signal dom Int -- rd, ARG[3] + -> Signal dom Bool -- wren, ARG[4] + -> Signal dom Int -- wr, ARG[5] + -> Signal dom a -- din, ARG[6] + -> Signal dom a" + , "templateD" : +"// blockRam begin +~SIGD[~GENSYM[RAM][0]][2]; +logic [~SIZE[~TYP[6]]-1:0] ~GENSYM[~RESULT_q][1]; +initial begin + ~SYM[0] = ~LIT[2]; +end~IF ~ISGATED[1] ~THEN +always @(posedge ~ARG[1][1]) begin : ~GENSYM[~COMPNAME_blockRam][2]~IF ~VIVADO ~THEN + if (~ARG[1][0]) begin + if (~ARG[4]) begin + ~SYM[0][~ARG[5]] <= ~TOBV[~ARG[6]][~TYP[6]]; + end + ~SYM[1] <= ~SYM[0][~ARG[3]]; + end~ELSE + if (~ARG[4] & ~ARG[1][0]) begin + ~SYM[0][~ARG[5]] <= ~TOBV[~ARG[6]][~TYP[6]]; + end + if (~ARG[1][0]) begin + ~SYM[1] <= ~SYM[0][~ARG[3]]; + end~FI +end~ELSE +always @(posedge ~ARG[1]) begin : ~SYM[2] + if (~ARG[4]) begin + ~SYM[0][~ARG[5]] <= ~TOBV[~ARG[6]][~TYP[6]]; + end + ~SYM[1] <= ~SYM[0][~ARG[3]]; +end~FI +assign ~RESULT = ~FROMBV[~SYM[1]][~TYP[6]]; +// blockRam end" + } + } +] diff --git a/prims/systemverilog/Clash_Explicit_BlockRam_File.json b/prims/systemverilog/Clash_Explicit_BlockRam_File.json new file mode 100644 --- /dev/null +++ b/prims/systemverilog/Clash_Explicit_BlockRam_File.json @@ -0,0 +1,48 @@ +[ { "BlackBox" : + { "name" : "Clash.Explicit.BlockRam.File.blockRamFile#" + , "type" : +"blockRamFile# + :: (KnownNat m, HasCallStack)-- (ARG[0],ARG[1]) + => Clock dom gated -- clk, ARG[2] + -> SNat n -- sz, ARG[3] + -> FilePath -- file, ARG[4] + -> Signal dom Int -- rd, ARG[5] + -> Signal dom Bool -- wren, ARG[6] + -> Signal dom Int -- wr, ARG[7] + -> Signal dom (BitVector m) -- din, ARG[8] + -> Signal dom (BitVector m)" + , "templateD" : +"// blockRamFile begin +~SIGDO[~GENSYM[RAM][0]] [0:~LIT[3]-1]; +~SIGD[~GENSYM[~RESULT_q][1]][8]; + +initial begin + $readmemb(~FILE[~LIT[4]],~SYM[0]); +end +~IF ~ISGATED[2] ~THEN +always @(posedge ~ARG[2][1]) begin : ~GENSYM[~COMPNAME_blockRamFile][2]~IF ~VIVADO ~THEN + if (~ARG[2][0]) begin + if (~ARG[6]) begin + ~SYM[0][~ARG[7]] <= ~ARG[8]; + end + ~SYM[1] <= ~SYM[0][~ARG[5]]; + end~ELSE + if (~ARG[6] & ~ARG[2][0]) begin + ~SYM[0][~ARG[7]] <= ~ARG[8]; + end + if (~ARG[2][0] begin + ~SYM[1] <= ~SYM[0][~ARG[5]]; + end~FI +end~ELSE +always @(posedge ~ARG[2]) begin : ~SYM[2] + if (~ARG[6]) begin + ~SYM[0][~ARG[7]] <= ~ARG[8]; + end + ~SYM[1] <= ~SYM[0][~ARG[5]]; +end~FI + +assign ~RESULT = ~SYM[1]; +// blockRamFile end" + } + } +] diff --git a/prims/systemverilog/Clash_Explicit_DDR.json b/prims/systemverilog/Clash_Explicit_DDR.json new file mode 100644 --- /dev/null +++ b/prims/systemverilog/Clash_Explicit_DDR.json @@ -0,0 +1,128 @@ +[ { "BlackBox" : + { "name" : "Clash.Explicit.DDR.ddrIn#" + , "type" : +"ddrIn# :: forall a slow fast n pFast gated synchronous. + ( HasCallStack -- ARG[0] + , fast ~ Dom n pFast -- ARG[1] + , slow ~ Dom n (2*pFast)) -- ARG[2] + => Clock slow gated -- ARG[3] + -> Reset slow synchronous -- ARG[4] + -> a -- ARG[5] + -> a -- ARG[6] + -> a -- ARG[7] + -> Signal fast a -- ARG[8] + -> Signal slow (a,a)" + , "templateD" : +"// ddrIn begin +~SIGD[~GENSYM[data_Pos][1]][8]; +~SIGD[~GENSYM[data_Neg][2]][8]; +~SIGD[~GENSYM[data_Neg_Latch][3]][8]; +~IF ~ISGATED[3] ~THEN +always @(posedge ~ARG[3][1]~IF ~ISSYNC[4] ~THEN ~ELSE or posedge ~ARG[4]~FI) begin : ~GENSYM[~COMPNAME_ddrIn_pos][6] + if (~ARG[4]) begin + ~SYM[1] <= ~ARG[6]; + end else if (~ARG[3][0]) begin + ~SYM[1] <= ~ARG[8]; + end +end~ELSE +always @(posedge ~ARG[3]~IF ~ISSYNC[4] ~THEN ~ELSE or posedge ~ARG[4]~FI) begin : ~SYM[6] + if (~ARG[4]) begin + ~SYM[1] <= ~ARG[6]; + end else begin + ~SYM[1] <= ~ARG[8]; + end +end~FI +~IF ~ISGATED[3] ~THEN +always @(negedge ~ARG[3][1]~IF ~ISSYNC[4] ~THEN ~ELSE or posedge ~ARG[4]~FI) begin : ~GENSYM[~COMPNAME_ddrIn_neg][7] + if (~ARG[4]) begin + ~SYM[2] <= ~ARG[7]; + end else if (~ARG[3][0]) begin + ~SYM[2] <= ~ARG[8]; + end +end~ELSE +always @(negedge ~ARG[3]~IF ~ISSYNC[4] ~THEN ~ELSE or posedge ~ARG[4]~FI) begin : ~SYM[7] + if (~ARG[4]) begin + ~SYM[2] <= ~ARG[7]; + end else begin + ~SYM[2] <= ~ARG[8]; + end +end~FI +~IF ~ISGATED[3] ~THEN +always @(posedge ~ARG[3][1]~IF ~ISSYNC[4] ~THEN ~ELSE or posedge ~ARG[4]~FI) begin : ~GENSYM[~COMPNAME_ddrIn_neg_latch][8] + if (~ARG[4]) begin + ~SYM[3] <= ~ARG[5]; + end else if (~ARG[3][0]) begin + ~SYM[3] <= ~SYM[2]; + end +end~ELSE +always @(posedge ~ARG[3]~IF ~ISSYNC[4] ~THEN ~ELSE or posedge ~ARG[4]~FI) begin : ~SYM[8] + if (~ARG[4]) begin + ~SYM[3] <= ~ARG[5]; + end else begin + ~SYM[3] <= ~SYM[2]; + end +end~FI + +assign ~RESULT = {~SYM[3], ~SYM[1]}; +// ddrIn end" + } + } +, { "BlackBox" : + { "name" : "Clash.Explicit.DDR.ddrOut#" + , "type" : +"ddrOut# :: ( HasCallStack -- ARG[0] + , fast ~ Dom n pFast -- ARG[1] + , slow ~ Dom n (2*pFast)) -- ARG[2] + => Clock slow gated -- ARG[3] + -> Reset slow synchronous -- ARG[4] + -> a -- ARG[5] + -> Signal slow a -- ARG[6] + -> Signal slow a -- ARG[7] + -> Signal fast a" + , "templateD" : +"// ddrOut begin +~SIGD[~GENSYM[data_Pos][1]][5]; +~SIGD[~GENSYM[data_Neg][2]][5]; +~IF ~ISGATED[3] ~THEN +always @(posedge ~ARG[3][1]~IF ~ISSYNC[4] ~THEN ~ELSE or posedge ~ARG[4]~FI) begin : ~GENSYM[~COMPNAME_ddrOut_pos][5] + if (~ARG[4]) begin + ~SYM[1] <= ~ARG[5]; + end else if (~ARG[3][0]) begin + ~SYM[1] <= ~ARG[6]; + end +end~ELSE +always @(posedge ~ARG[3]~IF ~ISSYNC[4] ~THEN ~ELSE or posedge ~ARG[4]~FI) begin : ~SYM[5] + if (~ARG[4]) begin + ~SYM[1] <= ~ARG[5]; + end else begin + ~SYM[1] <= ~ARG[6]; + end +end~FI +~IF ~ISGATED[3] ~THEN +always @(posedge ~ARG[3][1]~IF ~ISSYNC[4] ~THEN ~ELSE or posedge ~ARG[4]~FI) begin : ~GENSYM[~COMPNAME_ddrOut_neg][6] + if (~ARG[4]) begin + ~SYM[2] <= ~ARG[5]; + end else if (~ARG[3][0]) begin + ~SYM[2] <= ~ARG[7]; + end +end~ELSE +always @(posedge ~ARG[3]~IF ~ISSYNC[4] ~THEN ~ELSE or posedge ~ARG[4]~FI) begin : ~SYM[6] + if (~ARG[4]) begin + ~SYM[2] <= ~ARG[5]; + end else begin + ~SYM[2] <= ~ARG[7]; + end +end~FI + +always @(*) begin ~IF ~ISGATED[3] ~THEN + if (~ARG[3][1]) begin~ELSE + if (~ARG[3]) begin~FI + ~RESULT = ~SYM[1]; + end else begin + ~RESULT = ~SYM[2]; + end +end +// ddrOut end" + } + } +] diff --git a/prims/systemverilog/Clash_Explicit_RAM.json b/prims/systemverilog/Clash_Explicit_RAM.json new file mode 100644 --- /dev/null +++ b/prims/systemverilog/Clash_Explicit_RAM.json @@ -0,0 +1,32 @@ +[ { "BlackBox" : + { "name" : "Clash.Explicit.RAM.asyncRam#" + , "type" : +"asyncRam# + :: HasCallStack -- ARG[0] + => Clock wdom wgated -- ^ wclk, ARG[1] + -> Clock rdom rgated -- ^ rclk, ARG[2] + -> SNat n -- ^ sz, ARG[3] + -> Signal rdom Int -- ^ rd, ARG[4] + -> Signal wdom Bool -- ^ en, ARG[5] + -> Signal wdom Int -- ^ wr, ARG[6] + -> Signal wdom a -- ^ din, ARG[7] + -> Signal rdom a" + , "templateD" : +"// asyncRam begin +logic [~SIZE[~TYP[7]]-1:0] ~GENSYM[RAM][0] [0:~LIT[3]-1];~IF ~ISGATED[1] ~THEN +always @(posedge ~ARG[1][1]) begin : ~GENSYM[~COMPNAME_Ram][1] + if (~ARG[5] & ~ARG[1][0]) begin + ~SYM[0][~ARG[6]] <= ~TOBV[~ARG[7]][~TYP[7]]; + end +end~ELSE +always @(posedge ~ARG[1]) begin : ~SYM[1] + if (~ARG[5]) begin + ~SYM[0][~ARG[6]] <= ~TOBV[~ARG[7]][~TYP[7]]; + end +end~FI + +assign ~RESULT = ~FROMBV[~SYM[0][\\~ARG[4]\\]][~TYPO]; +// asyncRam end" + } + } +] diff --git a/prims/systemverilog/Clash_Explicit_ROM.json b/prims/systemverilog/Clash_Explicit_ROM.json new file mode 100644 --- /dev/null +++ b/prims/systemverilog/Clash_Explicit_ROM.json @@ -0,0 +1,28 @@ +[ { "BlackBox" : + { "name" : "Clash.Explicit.ROM.rom#" + , "type" : +"rom# :: KnownNat n -- ARG[0] + => Clock dom gated -- clk, ARG[1] + -> Vec n a -- init, ARG[2] + -> Signal dom Int -- rd, ARG[3] + -> Signal dom a" + , "templateD" : +"// rom begin +~SIGD[~GENSYM[ROM][0]][2]; +assign ~SYM[0] = ~ARG[2]; + +logic [~SIZE[~TYPO]-1:0] ~GENSYM[~RESULT_q][1];~IF ~ISGATED[1] ~THEN +always @(posedge ~ARG[1][1]) begin : ~GENSYM[~COMPNAME_rom][2] + if (~ARG[1][0]) begin + ~SYM[1] <= ~SYM[0][~ARG[3]]; + end +end~ELSE +always @(posedge ~ARG[1]) begin : ~SYM[2] + ~SYM[1] <= ~SYM[0][~ARG[3]]; +end~FI + +assign ~RESULT = ~FROMBV[~SYM[1]][~TYPO]; +// rom end" + } + } +] diff --git a/prims/systemverilog/Clash_Explicit_ROM_File.json b/prims/systemverilog/Clash_Explicit_ROM_File.json new file mode 100644 --- /dev/null +++ b/prims/systemverilog/Clash_Explicit_ROM_File.json @@ -0,0 +1,32 @@ +[ { "BlackBox" : + { "name" : "Clash.Explicit.ROM.File.romFile#" + , "type" : +"romFile# :: KnownNat m -- ARG[0] + => Clock clk gated -- clk, ARG[1] + -> SNat n -- sz, ARG[2] + -> FilePath -- file, ARG[3] + -> Signal dom Int -- rd, ARG[4] + -> Signal dom (BitVector m)" + , "templateD" : +"// romFile begin +~SIGDO[~GENSYM[ROM][0]] [0:~LIT[2]-1]; + +initial begin + $readmemb(~FILE[~LIT[3]],~SYM[0]); +end + +~SIGDO[~GENSYM[~RESULT_q][1]];~IF ~ISGATED[1] ~THEN +always @(posedge ~ARG[1][1]) begin : ~GENSYM[~COMPNAME_romFile][2] + if (~ARG[1][0]) begin + ~SYM[1] <= ~SYM[0][~ARG[4]]; + end +end~ELSE +always @(posedge ~ARG[1]) begin : ~SYM[2] + ~SYM[1] <= ~SYM[0][~ARG[4]]; +end~FI + +assign ~RESULT = ~SYM[1]; +// romFile end" + } + } +] diff --git a/prims/systemverilog/Clash_Explicit_Testbench.json b/prims/systemverilog/Clash_Explicit_Testbench.json new file mode 100644 --- /dev/null +++ b/prims/systemverilog/Clash_Explicit_Testbench.json @@ -0,0 +1,27 @@ +[ { "BlackBox" : + { "name" : "Clash.Explicit.Testbench.assert" + , "type" : +"assert + :: (Eq a,Show a) -- (ARG[0],ARG[1]) + => Clock domain gated -- ARG[2] + -> Reset domain synchronous -- ARG[3] + -> String -- ARG[4] + -> Signal domain a -- Checked value (ARG[5]) + -> Signal domain a -- Expected value (ARG[6]) + -> Signal domain b -- Return valued (ARG[7]) + -> Signal domain b" + , "templateD" : +"// assert begin +// pragma translate_off +always @(posedge ~IF ~ISGATED[2] ~THEN ~ARG[2][1] ~ELSE ~ARG[2] ~FI~IF ~ISSYNC[3] ~THEN ~ELSE or negedge ~ARG[3]~FI) begin + if (~ARG[5] !== ~ARG[6]) begin + $display(\"@%0tns: %s, expected: %b, actual: %b\", $time, ~LIT[4], ~TOBV[~ARG[6]][~TYP[6]], ~TOBV[~ARG[5]][~TYP[5]]); + $stop; + end +end +// pragma translate_on +assign ~RESULT = ~ARG[7]; +// assert end" + } + } +] diff --git a/prims/systemverilog/Clash_Intel_ClockGen.json b/prims/systemverilog/Clash_Intel_ClockGen.json new file mode 100644 --- /dev/null +++ b/prims/systemverilog/Clash_Intel_ClockGen.json @@ -0,0 +1,37 @@ +[ { "BlackBox" : + { "name" : "Clash.Intel.ClockGen.altpll" + , "type" : +"altpll + :: SSymbol name -- ARG[0] + -> Clock pllIn 'Source -- ARG[1] + -> Reset pllIn 'Asynchronous -- ARG[2] + -> (Clock pllOut 'Source, Signal pllOut Bool)" + , "templateD" : +"// altpll begin +~NAME[0] ~GENSYM[altpll_inst][2] +(.inclk0 (~ARG[1]) +,.areset (~ARG[2]) +,.c0 (~RESULT[1]) +,.locked (~RESULT[0])); +// altpll end" + } + } +, { "BlackBox" : + { "name" : "Clash.Intel.ClockGen.alteraPll" + , "type" : +"alteraPll + :: SSymbol name -- ARG[0] + -> Clock pllIn 'Source -- ARG[1] + -> Reset pllIn 'Asynchronous -- ARG[2] + -> (Clock pllOut 'Source, Signal pllOut Bool)" + , "templateD" : +"// alteraPll begin +~NAME[0] ~GENSYM[alteraPll_inst][2] +(.refclk (~ARG[1]) +,.rst (~ARG[2]) +,.outclk_0 (~RESULT[1]) +,.locked (~RESULT[0])); +// alteraPll end" + } + } +] diff --git a/prims/systemverilog/Clash_Intel_DDR.json b/prims/systemverilog/Clash_Intel_DDR.json new file mode 100644 --- /dev/null +++ b/prims/systemverilog/Clash_Intel_DDR.json @@ -0,0 +1,89 @@ +[ { "BlackBox" : + { "name" : "Clash.Intel.DDR.altddioIn" + , "type" : +"altddioIn + :: ( HasCallStack -- ARG[0] + , fast ~ Dom n pFast -- ARG[1] + , slow ~ Dom n (2*pFast) -- ARG[2] + , KnownNat m ) -- ARG[3] + => SSymbol deviceFamily -- ARG[4] + -> Clock slow gated -- ARG[5] + -> Reset slow synchronous -- ARG[6] + -> Signal fast (BitVector m) -- ARG[7] + -> Signal slow (BitVector m,BitVector m)" + , "templateD" : +"// altddioIn begin +~SIGD[~GENSYM[dataout_l][1]][7]; +~SIGD[~GENSYM[dataout_h][2]][7]; + +altddio_in ~GENSYM[~COMPNAME_ALTDDIO_IN][7] (~IF ~ISSYNC[6] ~THEN + .sclr (~ARG[6]), + .aclr (1'b0),~ELSE + .aclr (~ARG[6]), + .sclr (1'b0),~FI + .datain (~ARG[7]),~IF ~ISGATED[5] ~THEN + .inclock (~ARG[5][1]), + .inclocken (~ARG[5][0]),~ELSE + .inclock (~ARG[5]), + .inclocken (1'b1),~FI + .dataout_h (~SYM[2]), + .dataout_l (~SYM[1]), + .aset (1'b0), + .sset (1'b0)); +defparam + ~SYM[7].intended_device_family = ~LIT[4], + ~SYM[7].invert_input_clocks = \"OFF\", + ~SYM[7].lpm_hint = \"UNUSED\", + ~SYM[7].lpm_type = \"altddio_in\", + ~SYM[7].power_up_high = \"OFF\", + ~SYM[7].width = ~SIZE[~TYP[7]]; + +assign ~RESULT = {~SYM[1],~SYM[2]}; +// altddioIn end" + } + } +, { "BlackBox" : + { "name" : "Clash.Intel.DDR.altddioOut#" + , "type" : +"altddioOut# + :: ( HasCallStack -- ARG[0] + , fast ~ Dom n pFast -- ARG[1] + , slow ~ Dom n (2*pFast) -- ARG[2] + , KnownNat m ) -- ARG[3] + => SSymbol deviceFamily -- ARG[4] + -> Clock slow gated -- ARG[5] + -> Reset slow synchronous -- ARG[6] + -> Signal slow (BitVector m) -- ARG[7] + -> Signal slow (BitVector m) -- ARG[8] + -> Signal fast (BitVector m)" + , "templateD" : +"// altddioOut begin +altddio_out ~GENSYM[~COMPNAME_ALTDDIO_OUT][7] (~IF ~ISSYNC[6] ~THEN + .sclr (~ARG[6]), + .aclr (1'b0),~ELSE + .aclr (~ARG[6]), + .sclr (1'b0),~FI + .datain_h (~ARG[7]), + .datain_l (~ARG[8]),~IF ~ISGATED[5] ~THEN + .outclock (~ARG[5][1]), + .outclocken (~ARG[5][0]),~ELSE + .outclock (~ARG[5]), + .outclocken (1'b1),~FI + .dataout (~RESULT), + .aset (1'b0), + .sset (1'b0), + .oe (1'b1), + .oe_out ()); +defparam + ~SYM[7].extend_oe_disable = \"OFF\", + ~SYM[7].intended_device_family = ~LIT[4], + ~SYM[7].invert_output = \"OFF\", + ~SYM[7].lpm_hint = \"UNUSED\", + ~SYM[7].lpm_type = \"altddio_out\", + ~SYM[7].oe_reg = \"UNREGISTERED\", + ~SYM[7].power_up_high = \"OFF\", + ~SYM[7].width = ~SIZE[~TYPO]; +// altddioOut end" + } + } +] diff --git a/prims/systemverilog/Clash_Prelude_ROM.json b/prims/systemverilog/Clash_Prelude_ROM.json new file mode 100644 --- /dev/null +++ b/prims/systemverilog/Clash_Prelude_ROM.json @@ -0,0 +1,17 @@ +[ { "BlackBox" : + { "name" : "Clash.Prelude.ROM.asyncRom#" + , "type" : +"asyncRom# :: KnownNat n -- ^ ARG[0] + => Vec n a -- ^ ARG[1] + -> Int -- ^ ARG[2] + -> a" + , "templateD" : +"// asyncRom begin +~SIGD[~GENSYM[ROM][0]][1]; +assign ~SYM[0] = ~ARG[1]; + +assign ~RESULT = ~FROMBV[~SYM[0][\\~ARG[2]\\]][~TYPO]; +// asyncRom end" + } + } +] diff --git a/prims/systemverilog/Clash_Prelude_ROM_File.json b/prims/systemverilog/Clash_Prelude_ROM_File.json new file mode 100644 --- /dev/null +++ b/prims/systemverilog/Clash_Prelude_ROM_File.json @@ -0,0 +1,21 @@ +[ { "BlackBox" : + { "name" : "Clash.Prelude.ROM.File.asyncRomFile#" + , "type" : +"asyncRomFile :: KnownNat m -- ARG[0] + => SNat n -- sz, ARG[1] + -> FilePath -- file, ARG[2] + -> Int -- rd, ARG[3] + -> BitVector m" + , "templateD" : +"// asyncRomFile begin +~SIGDO[~GENSYM[ROM][0]] [0:~LIT[1]-1]; + +initial begin + $readmemb(~FILE[~LIT[2]],~SYM[0]); +end + +assign ~RESULT = ~SYM[0][~ARG[3]]; +// asyncRomFile end" + } + } +] diff --git a/prims/systemverilog/Clash_Signal_Internal.json b/prims/systemverilog/Clash_Signal_Internal.json new file mode 100644 --- /dev/null +++ b/prims/systemverilog/Clash_Signal_Internal.json @@ -0,0 +1,200 @@ +[ { "BlackBox" : + { "name" : "Clash.Signal.Internal.delay#" + , "type" : +"delay# + :: HasCallStack -- ARG[0] + => Clock domain gated -- ARG[1] + -> Signal clk a -- ARG[2] + -> Signal clk a" + , "templateD" : +"// register begin~IF ~ISGATED[1] ~THEN +always_ff @(posedge ~ARG[1][1]) begin : ~GENSYM[~COMPNAME_delay][0] + if (~ARG[1][0]) begin + ~RESULT <= ~ARG[2]; + end +end~ELSE +always_ff @(posedge ~ARG[1]) begin : ~SYM[0] + ~RESULT <= ~ARG[2]; +end~FI +// register end" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.register#" + , "type" : +"register# + :: HasCallStack -- ARG[0] + => Clock domain gated -- ARG[1] + -> Reset domain synchronous -- ARG[2] + -> a -- ARG[3] + -> Signal clk a -- ARG[4] + -> Signal clk a" + , "templateD" : +"// register begin~IF ~ISGATED[1] ~THEN +always_ff @(posedge ~ARG[1][1]~IF ~ISSYNC[2] ~THEN ~ELSE or posedge ~ARG[2]~FI) begin : ~GENSYM[~COMPNAME_register][0] + if (~ARG[2]) begin + ~RESULT <= ~ARG[3]; + end else if (~ARG[1][0]) begin + ~RESULT <= ~ARG[4]; + end +end~ELSE +always_ff @(posedge ~ARG[1]~IF ~ISSYNC[2] ~THEN ~ELSE or posedge ~ARG[2]~FI) begin : ~SYM[0] + if (~ARG[2]) begin + ~RESULT <= ~ARG[3]; + end else begin + ~RESULT <= ~ARG[4]; + end +end~FI +// register end" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.clockGate" + , "type" : +"clockGate + :: Clock domain gated -- ARG[0] + -> Signal domain Bool -- ARG[1] + -> Clcok domain 'Gated" + , "templateD" : +"// clockGate begin~IF ~ISGATED[0] ~THEN +assign ~RESULT = {~ARG[0][1],~ARG[0][0] & ~ARG[1]};~ELSE +assign ~RESULT = {~ARG[0],~ARG[1]};~FI +// clockGate end" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.clockGen" + , "type" : +"clockGen + :: (domain ~ Dom nm period -- ARG[0] + ,KnownSymbol nm -- ARG[1] + ,KnownNat period) -- ARG[2] + => Clock domain Source" + , "templateD" : +"// pragma translate_off +// 1 = 0.1ps +localparam ~GENSYM[half_period][0] = (~LIT[2]0 / 2); +always begin + ~RESULT = 0; + #3000 forever begin + ~RESULT = ~ ~RESULT; + #~SYM[0]; + ~RESULT = ~ ~RESULT; + #~SYM[0]; + end +end +// pragma translate_on" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.tbClockGen" + , "type" : +"tbClockGen + :: (domain ~ Dom nm period -- ARG[0] + ,KnownSymbol nm -- ARG[1] + ,KnownNat period) -- ARG[2] + => Signal domain Bool -- ARG[3] + -> Clock domain Source" + , "templateD" : +"// pragma translate_off +// 1 = 0.1ps +localparam ~GENSYM[half_period][0] = (~LIT[2]0 / 2); +always begin + ~RESULT = 0; + #3000 forever begin + if (~ ~ARG[3]) begin + $finish; + end + ~RESULT = ~ ~RESULT; + #~SYM[0]; + ~RESULT = ~ ~RESULT; + #~SYM[0]; + end +end +// pragma translate_on" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.asyncResetGen" + , "type" : "asyncResetGen :: Reset domain Asynchronous" + , "templateD" : +"// pragma translate_off +initial begin + #1 ~RESULT = 1; + #1999 ~RESULT = 0; +end +// pragma translate_on" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.syncResetGen" + , "type" : "asyncResetGen :: Reset domain Synchronous" + , "templateD" : +"// pragma translate_off +localparam ~GENSYM[reset_period][1] = 2998 + ~LIT[1]0; +initial begin + #1 ~RESULT = 1; + #~SYM[1] ~RESULT = 0; +end +// pragma translate_on" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.unsafeFromAsyncReset" + , "type" : +"unsafeFromAsyncReset :: Reset domain Asynchronous -> Signal domain Bool" + , "templateE" : "~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.unsafeToAsyncReset" + , "type" : +"unsafeToAsyncReset :: Signal domain Bool -> Reset domain Asynchronous" + , "templateE" : "~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.fromSyncReset" + , "type" : +"fromSyncReset :: Reset domain Synchronous -> Signal domain Bool" + , "templateE" : "~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.unsafeToSyncReset" + , "type" : +"unsafeToSyncReset :: Signal domain Bool -> Reset domain Synchronous" + , "templateE" : "~ARG[0]" + } + } +, { "Primitive" : + { "name" : "Clash.Signal.Internal.signal#" + , "primType" : "Function" + } + } +, { "Primitive" : + { "name" : "Clash.Signal.Internal.mapSignal#" + , "primType" : "Function" + } + } +, { "Primitive" : + { "name" : "Clash.Signal.Internal.appSignal#" + , "primType" : "Function" + } + } +, { "Primitive" : + { "name" : "Clash.Signal.Internal.foldr#" + , "primType" : "Function" + } + } +, { "Primitive" : + { "name" : "Clash.Signal.Internal.traverse#" + , "primType" : "Function" + } + } +, { "Primitive" : + { "name" : "Clash.Signal.Internal.joinSignal#" + , "primType" : "Function" + } + } +] diff --git a/prims/systemverilog/Clash_Sized_Internal_BitVector.json b/prims/systemverilog/Clash_Sized_Internal_BitVector.json new file mode 100644 --- /dev/null +++ b/prims/systemverilog/Clash_Sized_Internal_BitVector.json @@ -0,0 +1,240 @@ +[ { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.size#" + , "type" : "size# :: KnownNat n => BitVector n -> Int" + , "templateE" : "~SIZE[~TYPO]'sd~LIT[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.maxIndex#" + , "type" : "maxIndex# :: KnownNat n => BitVector n -> Int" + , "templateE" : "~SIZE[~TYPO]'sd~LIT[0] - ~SIZE[~TYPO]'sd1" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.++#" + , "type" : "(++#) :: KnownNat m => BitVector n -> BitVector m -> BitVector (n + m)" + , "templateE" : "{~ARG[1],~ARG[2]}" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.index#" + , "type" : +"index# :: KnownNat n -- ARG[0] + => BitVector n -- ARG[1] + -> Int -- ARG[2] + -> Bit" + , "templateE" : "~VAR[bv][1][~ARG[2]]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.replaceBit#" + , "type" : +"replaceBit# :: KnownNat n -- ARG[0] + => BitVector n -- ARG[1] + -> Int -- ARG[2] + -> Bit -- ARG[3] + -> BitVector n" + , "templateD" : +"// replaceBit start +always_comb begin + ~RESULT = ~ARG[1]; + ~RESULT[~ARG[2]] = ~ARG[3]; +end +// replaceBit end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.setSlice#" + , "type" : +"setSlice# :: BitVector (m + 1 + i) -- ARG[0] + -> SNat m -- ARG[1] + -> SNat n -- ARG[2] + -> BitVector (m + 1 - n) -- ARG[3] + -> BitVector (m + 1 + i)" + , "templateD" : +"// setSlice begin +always_comb begin + ~RESULT = ~ARG[0]; + ~RESULT[~LIT[1] : ~LIT[2]] = ~ARG[3]; +end +// setSlice end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.slice#" + , "type" : +"slice# :: BitVector (m + 1 + i) -- ARG[0] + -> SNat m -- ARG[1] + -> SNat n -- ARG[2] + -> BitVector (m + 1 - n)" + , "templateE" : "~VAR[bv][0][~LIT[1] : ~LIT[2]]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.split#" + , "type" : +"split# :: KnownNat n -- ARG[0] + => BitVector (m + n) -- ARG[1] + -> (BitVector m, BitVector n)" + , "templateD" : +"// split begin +assign ~RESULT = { ~VAR[bv][1][$high(~VAR[bv][1]) : ~LIT[0]] + , ~VAR[bv][1][(~LIT[0]-1) : 0] + }; +// split end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.msb#" + , "type" : +"msb# :: KnownNat n -- ARG[0] + => BitVector n -- ARG[1] + -> Bit" + , "templateE" : "~IF ~LIT[0] ~THEN ~VAR[bv][1][~LIT[0]-1] ~ELSE 1'b0 ~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.lsb#" + , "type" : +"lsb# :: BitVector n -- ARG[0] + -> Bit" + , "templateE" : "~IF ~SIZE[~TYP[0]] ~THEN ~VAR[bv][0][0] ~ELSE 1'b0 ~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.minBound#" + , "type" : "minBound# :: BitVector n" + , "templateE" : "~SIZE[~TYPO]'d0" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.maxBound#" + , "type" : "maxBound# :: KnownNat n => BitVector n" + , "templateE" : "{~LIT[0] {1'b1}}" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.+#" + , "type" : "(+#) :: KnownNat n => BitVector n -> BitVector n -> BitVector n" + , "templateE" : "~ARG[1] + ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.-#" + , "type" : "(-#) :: KnownNat n => BitVector n -> BitVector n -> BitVector n" + , "templateE" : "~ARG[1] - ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.*#" + , "type" : "(*#) :: KnownNat n => BitVector n -> BitVector n -> BitVector n" + , "templateE" : "~ARG[1] * ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.negate#" + , "type" : "negate# :: KnownNat n => BitVector n -> BitVector n" + , "templateE" : "-~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.fromInteger#" + , "type" : "fromInteger# :: KnownNat n => Integer -> BitVector n" + , "templateE" : "$unsigned(~ARG[1][(~LIT[0]-1):0])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.plus#" + , "type" : "plus# :: BitVector m -> BitVector n -> BitVector (Max m n + 1)" + , "templateD" : "assign ~RESULT = ~ARG[0] + ~ARG[1];" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.minus#" + , "type" : "minus# :: (KnownNat m, KnownNat n) => BitVector m -> BitVector n -> BitVector (Max m n + 1)" + , "templateD" : "assign ~RESULT = ~ARG[2] - ~ARG[3];" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.times#" + , "type" : "times# :: KnownNat (m + n) => BitVector m -> BitVector n -> BitVector (m + n)" + , "templateD" : "assign ~RESULT = ~ARG[0] * ~ARG[1];" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.quot#" + , "type" : "quot# :: BitVector n -> BitVector n -> BitVector n" + , "templateE" : "~ARG[0] / ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.rem#" + , "type" : "rem# :: BitVector n -> BitVector n -> BitVector n" + , "templateE" : "~ARG[0] % ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.and#" + , "type" : "and# :: BitVector n -> BitVector n -> BitVector n" + , "templateE" : "~ARG[0] & ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.or#" + , "type" : "or# :: BitVector n -> BitVector n -> BitVector n" + , "templateE" : "~ARG[0] | ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.xor#" + , "type" : "xor# :: BitVector n -> BitVector n -> BitVector n" + , "templateE" : "~ARG[0] ^ ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.complement#" + , "type" : "complement# :: KnownNat n => BitVector n -> BitVector n" + , "templateE" : "~ ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.shiftL#" + , "type" : "shiftL# :: KnownNat n => BitVector n -> Int -> BitVector n" + , "templateE" : "~ARG[1] << ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.shiftR#" + , "type" : "shiftR# :: KnownNat n => BitVector n -> Int -> BitVector n" + , "templateE" : "~ARG[1] >> ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.rotateL#" + , "type" : "rotateL# :: KnownNat n => BitVector n -> Int -> BitVector n" + , "templateD" : +"// rotateL begin +logic [2*~LIT[0]-1:0] ~GENSYM[bv][0]; +assign ~SYM[0] = {~ARG[1],~ARG[1]} << ~ARG[2]; +assign ~RESULT = ~SYM[0][2*~LIT[0]-1 : ~LIT[0]]; +// rotateL end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.rotateR#" + , "type" : "rotateR# :: KnownNat n => BitVector n -> Int -> BitVector n" + , "templateD" : +"// rotateR begin +logic [2*~LIT[0]-1:0] ~GENSYM[bv][0]; +assign ~SYM[0] = {~ARG[1],~ARG[1]} >> ~ARG[2]; +assign ~RESULT = ~SYM[0][~LIT[0]-1 : 0]; +// rotateR end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.resize#" + , "type" : "resize# :: KnownNat m => BitVector n -> BitVector m" + , "templateD" : "assign ~RESULT = $unsigned(~ARG[1]);" + } + } +] diff --git a/prims/systemverilog/Clash_Sized_Internal_Signed.json b/prims/systemverilog/Clash_Sized_Internal_Signed.json new file mode 100644 --- /dev/null +++ b/prims/systemverilog/Clash_Sized_Internal_Signed.json @@ -0,0 +1,211 @@ +[ { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.size#" + , "type" : "size# :: KnownNat n => Signed n -> Int" + , "templateE" : "~SIZE[~TYPO]'sd~LIT[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.pack#" + , "type" : "pack# :: KnownNat n => Signed n -> BitVector n" + , "templateE" : "$unsigned(~ARG[1])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.unpack#" + , "type" : "unpack# :: KnownNat n => BitVector n -> Signed n" + , "templateE" : "$signed(~ARG[1])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.minBound#" + , "type" : "minBound# :: KnownNat n => Signed n" + , "comment" : "Generates incorrect SV for n=0" + , "templateE" : "$signed({1'b1, {(~LIT[0]-1) {1'b0}}})" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.maxBound#" + , "type" : "maxBound# :: KnownNat n => Signed n" + , "comment" : "Generates incorrect SV for n=0" + , "templateE" : "$signed({1'b0, {(~LIT[0]-1) {1'b1}}})" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.+#" + , "type" : "(+#) :: KnownNat n => Signed n -> Signed n -> Signed n" + , "templateE" : "~ARG[1] + ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.-#" + , "type" : "(-#) :: KnownNat n => Signed n -> Signed n -> Signed n" + , "templateE" : "~ARG[1] - ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.*#" + , "type" : "(*#) :: KnownNat n => Signed n -> Signed n -> Signed n" + , "templateE" : "~ARG[1] * ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.negate#" + , "type" : "negate# :: KnownNat n => Signed n -> Signed n" + , "templateE" : "-~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.abs#" + , "type" : "abs# :: KnownNat n => Signed n -> Signed n" + , "templateE" : "(~ARG[1] < ~LIT[0]'sd0) ? -~ARG[1] : ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.fromInteger#" + , "type" : "fromInteger# :: KnownNat n => Integer -> Signed (n :: Nat)" + , "templateE" : "$signed(~ARG[1][(~LIT[0]-1):0])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.plus#" + , "type" : "plus# :: Signed m -> Signed n -> Signed (1 + Max m n)" + , "templateD" : "assign ~RESULT = ~ARG[0] + ~ARG[1];" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.minus#" + , "type" : "minus# :: Signed m -> Signed n -> Signed (1 + Max m n)" + , "templateD" : "assign ~RESULT = ~ARG[0] - ~ARG[1];" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.times#" + , "type" : "times# :: Signed m -> Signed n -> Signed (m + n)" + , "templateD" : "assign ~RESULT = ~ARG[0] * ~ARG[1];" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.quot#" + , "type" : "quot# :: Signed n -> Signed n -> Signed n" + , "templateE" : "~ARG[0] / ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.rem#" + , "type" : "rem# :: Signed n -> Signed n -> Signed n" + , "templateE" : "~ARG[0] % ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.div#" + , "type" : "div# :: KnownNat n => Signed n -> Signed n -> Signed n" + , "templateD" : +"// divSigned begin +// divide (rounds towards zero) +~SIGD[~GENSYM[quot_res][0]][1]; +assign ~SYM[0] = ~VAR[dividend][1] / ~VAR[divider][2]; + +// round toward minus infinity +assign ~RESULT = (~VAR[dividend][1][~LIT[0]-1] == ~VAR[divider][2][~LIT[0]-1]) ? ~SYM[0] : ~SYM[0] - ~LIT[0]'sd1; +// divSigned end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.mod#" + , "type" : "mod# :: Signed n -> Signed n -> Signed n" + , "templateD" : +"// modSigned begin +// remainder +~SIGD[~GENSYM[rem_res][0]][0]; +assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1]; + +// modulo +assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? + ~SYM[0] : + (~VAR[dividend][0] == ~SIZE[~TYPO]'sd0 ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]); +// modSigned end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.and#" + , "type" : "and# :: KnownNat n => Signed n -> Signed n -> Signed n" + , "templateE" : "~ARG[1] & ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.or#" + , "type" : "or# :: KnownNat n => Signed n -> Signed n -> Signed n" + , "templateE" : "~ARG[1] | ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.xor#" + , "type" : "xor# :: KnownNat n => Signed n -> Signed n -> Signed n" + , "templateE" : "~ARG[1] ^ ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.complement#" + , "type" : "complement# :: KnownNat n => Signed n -> Signed n" + , "templateE" : "~ ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.shiftL#" + , "type" : "shiftL# :: KnownNat n => Signed n -> Int -> Signed n" + , "templateE" : "~ARG[1] <<< ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.shiftR#" + , "type" : "shiftR# :: KnownNat n => Signed n -> Int -> Signed n" + , "templateE" : "~ARG[1] >>> ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.rotateL#" + , "type" : "rotateL# :: KnownNat n => Signed n -> Int -> Signed n" + , "templateD" : +"// rotateL begin +logic [2*~LIT[0]-1:0] ~GENSYM[s][0]; +assign ~SYM[0] = {~ARG[1],~ARG[1]} << ~ARG[2]; +assign ~RESULT = $signed(~SYM[0][~LIT[0]-1 : 0]); +// rotateL end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.rotateR#" + , "type" : "rotateR# :: KnownNat n => Signed n -> Int -> Signed n" + , "templateD" : +"// rotateR begin +logic [2*~LIT[0]-1:0] ~GENSYM[s][0]; +assign ~SYM[0] = {~ARG[1],~ARG[1]} >> ~ARG[2]; +assign ~RESULT = $signed(~SYM[0][~LIT[0]-1 : 0]); +// rotateR end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.resize#" + , "type" : "resize# :: (KnownNat n, KnownNat m) => Signed n -> Signed m" + , "comment" : "Back-end should only use this code when the result is smaller than the argument" + , "templateD" : +"// resize begin +~GENERATE + if (~LIT[1] < ~LIT[0]) begin + // truncate, sign preserving + assign ~RESULT = $signed({~VAR[s][2][~LIT[0]-1],~VAR[s][2][(~LIT[1]-2):0]}); + end else begin + // sign-extend + assign ~RESULT = $signed(~VAR[s][2]); + end +~ENDGENERATE +// resize end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.truncateB#" + , "type" : "truncateB# :: KnownNat m => Signed (n + m) -> Signed m" + , "templateD" : "assign ~RESULT = $signed(~ARG[1]);" + } + } +] diff --git a/prims/systemverilog/Clash_Sized_Internal_Unsigned.json b/prims/systemverilog/Clash_Sized_Internal_Unsigned.json new file mode 100644 --- /dev/null +++ b/prims/systemverilog/Clash_Sized_Internal_Unsigned.json @@ -0,0 +1,155 @@ +[ { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.size#" + , "type" : "size# :: KnownNat n => Unsigned n -> Int" + , "templateE" : "~SIZE[~TYPO]'sd~LIT[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.pack#" + , "type" : "pack# :: Unsigned n -> BitVector n" + , "templateE" : "~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.unpack#" + , "type" : "unpack# :: BitVector n -> Unsigned n" + , "templateE" : "~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.minBound#" + , "type" : "minBound# :: Unsigned n" + , "templateE" : "~SIZE[~TYPO]'d0" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.maxBound#" + , "type" : "maxBound# :: KnownNat n => Unsigned n" + , "templateE" : "{~LIT[0] {1'b1}}" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.+#" + , "type" : "(+#) :: KnownNat n => Unsigned n -> Unsigned n -> Unsigned n" + , "templateE" : "~ARG[1] + ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.-#" + , "type" : "(-#) :: KnownNat n => Unsigned n -> Unsigned n -> Unsigned n" + , "templateE" : "~ARG[1] - ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.*#" + , "type" : "(*#) :: KnownNat n => Unsigned n -> Unsigned n -> Unsigned n" + , "templateE" : "~ARG[1] * ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.negate#" + , "type" : "negate# :: KnownNat n => Unsigned n -> Unsigned n" + , "templateE" : "- ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.fromInteger#" + , "type" : "fromInteger# :: KnownNat n => Integer -> Unsigned n" + , "templateE" : "$unsigned(~ARG[1][(~LIT[0]-1):0])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.plus#" + , "type" : "plus# :: Unsigned m -> Unsigned n -> Unsigned (1 + Max m n)" + , "templateD" : "assign ~RESULT = ~ARG[0] + ~ARG[1];" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.minus#" + , "type" : "minus# :: (KnownNat m, KnownNat n) => Unsigned m -> Unsigned n -> Unsigned (1 + Max m n)" + , "templateD" : "assign ~RESULT = ~ARG[2] - ~ARG[3];" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.times#" + , "type" : "times# :: Unsigned m -> Unsigned n -> Unsigned (m + n)" + , "templateD" : "assign ~RESULT = ~ARG[0] * ~ARG[1];" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.quot#" + , "type" : "quot# :: Unsigned n -> Unsigned n -> Unsigned n" + , "templateE" : "~ARG[0] / ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.rem#" + , "type" : "rem# :: Unsigned n -> Unsigned n -> Unsigned n" + , "templateE" : "~ARG[0] % ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.and#" + , "type" : "and# :: Unsigned n -> Unsigned n -> Unsigned n" + , "templateE" : "~ARG[0] & ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.or#" + , "type" : "or# :: Unsigned n -> Unsigned n -> Unsigned n" + , "templateE" : "~ARG[0] | ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.xor#" + , "type" : "xor# :: Unsigned n -> Unsigned n -> Unsigned n" + , "templateE" : "~ARG[0] ^ ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.complement#" + , "type" : "complement# :: KnownNat n => Unsigned n -> Unsigned n" + , "templateE" : "~ ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.shiftL#" + , "type" : "shiftL# :: KnownNat n => Unsigned n -> Int -> Unsigned n" + , "templateE" : "~ARG[1] << ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.shiftR#" + , "type" : "shiftR# :: KnownNat n => Unsigned n -> Int -> Unsigned n" + , "templateE" : "~ARG[1] >> ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.rotateL#" + , "type" : "rotateL# :: KnownNat n => Unsigned n -> Int -> Unsigned n" + , "templateD" : +"// rotateL begin +logic [2*~LIT[0]-1:0] ~GENSYM[u][0]; +assign ~SYM[0] = {~ARG[1],~ARG[1]} << ~ARG[2]; +assign ~RESULT = ~SYM[0][~LIT[0]-1 : 0]; +// rotateL end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.rotateR#" + , "type" : "rotateR# :: KnownNat n => Unsigned n -> Int -> Unsigned n" + , "templateD" : +"// rotateR begin +logic [2*~LIT[0]-1:0] ~GENSYM[u][0]; +assign ~SYM[0] = {~ARG[1],~ARG[1]} >> ~ARG[2]; +assign ~RESULT = ~SYM[0][~LIT[0]-1 : 0]; +// rotateR end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.resize#" + , "type" : "resize# :: KnownNat m => Unsigned n -> Unsigned m" + , "templateD" : "assign ~RESULT = $unsigned(~ARG[1]);" + } + } +] diff --git a/prims/systemverilog/Clash_Sized_RTree.json b/prims/systemverilog/Clash_Sized_RTree.json new file mode 100644 --- /dev/null +++ b/prims/systemverilog/Clash_Sized_RTree.json @@ -0,0 +1,19 @@ +[ { "BlackBox" : + { "name" : "Clash.Sized.RTree.treplicate" + , "type" : "replicate :: SNat d -> a -> RTree d a" + , "templateE" : "'{(2**~LIT[0]) {~TOBV[~ARG[1]][~TYP[1]]}}" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.RTree.textract" + , "type" : "textract :: RTree 0 a -> a" + , "templateE" : "~FROMBV[~VAR[tree][0][\\0\\]][~TYPO]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.RTree.tsplit" + , "type" : "tsplit:: RTree (d+1) a -> (RTree d a,RTree d a)" + , "templateE" : "~TOBV[~VAR[tree][0]][~TYP[0]]" + } + } +] diff --git a/prims/systemverilog/Clash_Sized_Vector.json b/prims/systemverilog/Clash_Sized_Vector.json new file mode 100644 --- /dev/null +++ b/prims/systemverilog/Clash_Sized_Vector.json @@ -0,0 +1,400 @@ +[ { "BlackBox" : + { "name" : "Clash.Sized.Vector.head" + , "type" : "head :: Vec (n + 1) a -> a" + , "templateE" : "~FROMBV[~VAR[vec][0][\\0\\]][~TYPO]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.tail" + , "type" : "tail :: Vec (n + 1) a -> Vec n a" + , "templateE" : "~VAR[vec][0][1 : $high(~VAR[vec][0])]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.last" + , "type" : "Vec (n + 1) a -> a" + , "templateE" : "~FROMBV[~VAR[vec][0][\\$high(~VAR[vec][0])\\]][~TYPO]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.init" + , "type" : "Vec (n + 1) a -> Vec n a" + , "templateE" : "~VAR[vec][0][0 : $high(~VAR[vec][0]) - 1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.select" + , "type" : +"select :: (CmpNat (i + s) (s * n) ~ GT) -- ARG[0] + => SNat f -- ARG[1] + -> SNat s -- ARG[2] + -> SNat n -- ARG[3] + -> Vec i a -- ARG[4] + -> Vec n a" + , "templateD" : +"// select begin +genvar ~GENSYM[n][1]; +~GENERATE + for (~SYM[1]=0; ~SYM[1] < ~LIT[3]; ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[select][2] + assign ~RESULT[~SYM[1]] = ~VAR[vec][4][~LIT[1] + (~LIT[2] * ~SYM[1])]; + end +~ENDGENERATE +// select end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.++" + , "type" : "(++) :: Vec n a -> Vec m a -> Vec (n + m) a" + , "templateE" : "~FROMBV[{~TOBV[~ARG[0]][~TYP[0]],~TOBV[~ARG[1]][~TYP[1]]}][~TYPO]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.concat" + , "type" : "concat :: Vec n (Vec m a) -> Vec (n * m) a" + , "templateD" : +"// concat begin +genvar ~GENSYM[n][1]; +~GENERATE + for (~SYM[1]=0; ~SYM[1] < $size(~VAR[vec][0]); ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[concat][2] + assign ~RESULT[~SYM[1]*~LENGTH[~TYPEL[~TYP[0]]] : ~SYM[1]*~LENGTH[~TYPEL[~TYP[0]]]+(~LENGTH[~TYPEL[~TYP[0]]]-1)] = ~FROMBV[~VAR[vec][0][\\~SYM[1]\\]][~TYPEL[~TYP[0]]]; + end +~ENDGENERATE +// concat end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.splitAt" + , "type" : "splitAt :: SNat m -> Vec (m + n) a -> (Vec m a, Vec n a)" + , "templateD" : +"// splitAt begin~IF~LENGTH[~TYPO]~THEN +assign ~RESULT = ~ARG[1];~ELSE +logic [0:~LENGTH[~TYP[1]]-1] [0:~SIZE[~TYPEL[~TYP[1]]]-1] ~GENSYM[vec][0]; +assign ~SYM[0] = ~TOBV[~ARG[1]][~TYP[1]]; +~GENERATE + if (~LIT[0] == ~LENGTH[~TYP[1]]) begin : ~GENSYM[no_split][1] + assign ~RESULT = {~SYM[0]}; + end else begin : ~GENSYM[do_split][2] + assign ~RESULT = {~SYM[0][0:~LIT[0]-1] + ,~SYM[0][~LIT[0]:~LENGTH[~TYP[1]]-1] + }; + end +~ENDGENERATE~FI +// splitAt end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.unconcat" + , "type" : + "unconcat :: KnownNat n -- ARG[0] + => SNat m -- ARG[1] + -> Vec (n * m) a -- ARG[2] + -> Vec n (Vec m a)" + , "templateD" : +"// unconcat begin +genvar ~GENSYM[n][1]; +~GENERATE + for (~SYM[1] = 0; ~SYM[1] < $size(~RESULT); ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[unconcat][2] + assign ~RESULT[~SYM[1]] = ~TOBV[~VAR[vec][2][\\(~SYM[1] * ~LIT[1]) : ((~SYM[1] * ~LIT[1]) + ~LIT[1] - 1)\\]][~TYPEL[~TYPO]]; + end +~ENDGENERATE +// unconcat end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.map" + , "type" : "map :: (a -> b) -> Vec n a -> Vec n b" + , "templateD" : +"// map begin +genvar ~GENSYM[n][1]; +~GENERATE +for (~SYM[1]=0; ~SYM[1] < $size(~RESULT); ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[map][2]~IF~SIZE[~TYP[1]]~THEN + ~TYPEL[~TYP[1]] ~GENSYM[map_in][3]; + assign ~SYM[3] = ~FROMBV[~VAR[vec][1][\\~SYM[1]\\]][~TYPEL[~TYP[1]]];~ELSE ~FI + ~TYPEL[~TYPO] ~GENSYM[map_out][4]; + ~INST 0 + ~OUTPUT <= ~SYM[4]~ ~TYPEL[~TYPO]~ + ~INPUT <= ~SYM[3]~ ~TYPEL[~TYP[1]]~ + ~INST + assign ~RESULT[~SYM[1]] = ~TOBV[~SYM[4]][~TYPEL[~TYPO]]; +end +~ENDGENERATE +// map end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.imap" + , "type" : "imap :: KnownNat n => (Index n -> a -> b) -> Vec n a -> Vec n b" + , "templateD" : +"// imap begin +genvar ~GENSYM[n][1]; +~GENERATE +for (~SYM[1]=0; ~SYM[1] < $size(~RESULT); ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[imap][2] + ~INDEXTYPE[~LIT[0]] ~GENSYM[i][3]; + assign ~SYM[3] = ~LENGTH[~TYPO] - 1 - ~SYM[1];~IF~SIZE[~TYP[2]]~THEN + ~TYPEL[~TYP[2]] ~GENSYM[imap_in][4]; + assign ~SYM[4] = ~FROMBV[~VAR[vec][2][\\~SYM[1]\\]][~TYPEL[~TYP[2]]];~ELSE ~FI + ~TYPEL[~TYPO] ~GENSYM[imap_out][5]; + ~INST 1 + ~OUTPUT <= ~SYM[5]~ ~TYPEL[~TYPO]~ + ~INPUT <= ~SYM[3]~ ~INDEXTYPE[~LIT[0]]~ + ~INPUT <= ~SYM[4]~ ~TYPEL[~TYP[2]]~ + ~INST + assign ~RESULT[~SYM[1]] = ~TOBV[~SYM[5]][~TYPEL[~TYPO]]; +end +~ENDGENERATE +// imap end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.imap_go" + , "type" : "imap_go :: Index n -> (Index n -> a -> b) -> Vec m a -> Vec m b" + , "templateD" : +"// imap begin +genvar ~GENSYM[n][1]; +~GENERATE +for (~SYM[1]=0; ~SYM[1] < $size(~RESULT); ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[imap][2] + ~TYP[0] ~GENSYM[i][3]; + assign ~SYM[3] = ~LENGTH[~TYPO] - 1 - ~SYM[1] + ~ARG[0];~IF~SIZE[~TYP[2]]~THEN + ~TYPEL[~TYP[2]] ~GENSYM[imap_in][4]; + assign ~SYM[4] = ~FROMBV[~VAR[vec][2][\\~SYM[1]\\]][~TYPEL[~TYP[2]]];~ELSE ~FI + ~TYPEL[~TYPO] ~GENSYM[imap_out][5]; + ~INST 1 + ~OUTPUT <= ~SYM[5]~ ~TYPEL[~TYPO]~ + ~INPUT <= ~SYM[3]~ ~TYP[0]~ + ~INPUT <= ~SYM[4]~ ~TYPEL[~TYP[2]]~ + ~INST + assign ~RESULT[~SYM[1]] = ~TOBV[~SYM[5]][~TYPEL[~TYPO]]; +end +~ENDGENERATE +// imap end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.zipWith" + , "type" : "zipWith :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c" + , "templateD" : +"// zipWith begin +genvar ~GENSYM[n][2]; +~GENERATE +for (~SYM[2] = 0; ~SYM[2] < $size(~RESULT); ~SYM[2] = ~SYM[2] + 1) begin : ~GENSYM[zipWith][3]~IF~SIZE[~TYP[1]]~THEN + ~TYPEL[~TYP[1]] ~GENSYM[zipWith_in1][4]; + assign ~SYM[4] = ~FROMBV[~VAR[vec1][1][\\~SYM[2]\\]][~TYPEL[~TYP[1]]];~ELSE ~FI~IF~SIZE[~TYP[2]]~THEN + ~TYPEL[~TYP[2]] ~GENSYM[zipWith_in2][5]; + assign ~SYM[5] = ~FROMBV[~VAR[vec2][2][\\~SYM[2]\\]][~TYPEL[~TYP[2]]];~ELSE ~FI + ~TYPEL[~TYPO] ~GENSYM[zipWith_out][6]; + ~INST 0 + ~OUTPUT <= ~SYM[6]~ ~TYPEL[~TYPO]~ + ~INPUT <= ~SYM[4]~ ~TYPEL[~TYP[1]]~ + ~INPUT <= ~SYM[5]~ ~TYPEL[~TYP[2]]~ + ~INST + assign ~RESULT[~SYM[2]] = ~TOBV[~SYM[6]][~TYPEL[~TYPO]]; +end +~ENDGENERATE +// zipWith end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.foldr" + , "type" : "foldr :: (a -> b -> b) -> b -> Vec n a -> b" + , "templateD" : +"// foldr start~IF ~LENGTH[~TYP[2]] ~THEN +~SIGDO[~GENSYM[intermediate][0]] [0:~LENGTH[~TYP[2]]]; +assign ~SYM[0][~LENGTH[~TYP[2]]] = ~ARG[1]; + +genvar ~GENSYM[i][3]; +~GENERATE +for (~SYM[3]=0; ~SYM[3] < ~LENGTH[~TYP[2]]; ~SYM[3]=~SYM[3]+1) begin : ~GENSYM[foldr_loop][4]~IF~SIZE[~TYP[2]]~THEN + ~TYPEL[~TYP[2]] ~GENSYM[foldr_in][5]; + assign ~SYM[5] = ~FROMBV[~VAR[xs][2][\\~SYM[3]\\]][~TYPEL[~TYP[2]]];~ELSE ~FI + ~INST 0 + ~OUTPUT <= ~SYM[0][~SYM[3]]~ ~TYP[1]~ + ~INPUT <= ~SYM[5]~ ~TYPEL[~TYP[2]]~ + ~INPUT <= ~SYM[0][~SYM[3]+1]~ ~TYP[1]~ + ~INST +end +~ENDGENERATE + +assign ~RESULT = ~SYM[0][0]; +~ELSE +assign ~RESULT = ~ARG[1]; +~FI// foldr end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.fold" + , "type" : "fold :: (a -> a -> a) -> Vec (n+1) a -> a" + , "comment" : "THIS ONLY WORKS FOR POWER OF TWO LENGTH VECTORS" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "depth2Index" + , "extension" : "inc" + , "content" : +"// given a level and a depth, calculate the corresponding index into the +// intermediate array +function integer ~INCLUDENAME; + input integer levels; + input integer depth; + + ~INCLUDENAME = (2 ** levels) - (2 ** depth); +endfunction" + } + , "templateD" : +"// fold begin +// put flat input array into the first half of the intermediate array +~SIGDO[~GENSYM[intermediate][0]] [0:(2*~LENGTH[~TYP[1]])-2]; +assign ~SYM[0][0:~LENGTH[~TYP[1]]-1] = ~ARG[1]; + +// calculate the depth of the tree +localparam ~GENSYM[levels][4] = $clog2(~LENGTH[~TYP[1]]); + +// Create the tree of instantiated components +genvar ~GENSYM[d][5]; +genvar ~GENSYM[i][6]; +~GENERATE +if (~SYM[4] != 0) begin : ~GENSYM[make_tree][7] + for (~SYM[5] = (~SYM[4] - 1); ~SYM[5] >= 0; ~SYM[5]=~SYM[5]-1) begin : tree_depth + for (~SYM[6] = 0; ~SYM[6] < (2**~SYM[5]); ~SYM[6] = ~SYM[6]+1) begin : tree_depth_loop + ~INST 0 + ~OUTPUT <= ~SYM[0][~INCLUDENAME(~SYM[4]+1,~SYM[5]+1)+~SYM[6]]~ ~TYPO~ + ~INPUT <= ~SYM[0][~INCLUDENAME(~SYM[4]+1,~SYM[5]+2)+(2*~SYM[6])]~ ~TYPO~ + ~INPUT <= ~SYM[0][~INCLUDENAME(~SYM[4]+1,~SYM[5]+2)+(2*~SYM[6])+1]~ ~TYPO~ + ~INST + end + end +end +~ENDGENERATE + +// The last element of the intermediate array holds the result +assign ~RESULT = ~SYM[0][(2*~LENGTH[~TYP[1]])-2]; +// fold end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.index_int" + , "type" : "index_integer :: KnownNat n => Vec n a -> Int -> a" + , "templateE" : "~FROMBV[~VAR[vec][1][\\~ARG[2]\\]][~TYPO]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.replace_int" + , "type" : "replace_int :: KnownNat n => Vec n a -> Int -> a -> Vec n a" + , "templateD" : +"// replaceVec start +always_comb begin + ~RESULT = ~ARG[1]; + ~RESULT[~ARG[2]] = ~TOBV[~ARG[3]][~TYP[3]]; +end +// replaceVec end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.maxIndex" + , "type" : "maxIndex :: KnownNat n => Vec n a -> Int" + , "templateE" : "~SIZE[~TYPO]'sd~LIT[0] - ~SIZE[~TYPO]'sd1" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.length" + , "type" : "length :: KnownNat n => Vec n a -> Int" + , "templateE" : "~SIZE[~TYPO]'sd~LIT[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.replicate" + , "type" : "replicate :: SNat n -> a -> Vec n a" + , "templateE" : "'{~LIT[0] {~TOBV[~ARG[1]][~TYP[1]]}}" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.transpose" + , "type" : "transpose :: KnownNat n => Vec m (Vec n a) -> Vec n (Vec m a)" + , "templateD" : +"// transpose begin +genvar ~GENSYM[row_index][1]; +genvar ~GENSYM[col_index][2]; +~GENERATE + for (~SYM[1] = 0; ~SYM[1] < $size(~VAR[matrix][1]); ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[transpose_outer][3] + for (~SYM[2] = 0; ~SYM[2] < $size(~RESULT); ~SYM[2] = ~SYM[2] + 1) begin : ~GENSYM[transpose_inner][4]~IF ~VIVADO ~THEN + assign ~RESULT[~SYM[2]][($size(~VAR[matrix][1])-~SYM[1])*~SIZE[~TYPEL[~TYPEL[~TYPO]]]-1 : ($size(~VAR[matrix][1])-~SYM[1]-1)*~SIZE[~TYPEL[~TYPEL[~TYPO]]]] = ~VAR[matrix][1][~SYM[1]][($size(~RESULT)-~SYM[2])*~SIZE[~TYPEL[~TYPEL[~TYPO]]]-1 : ($size(~RESULT)-~SYM[2]-1)*~SIZE[~TYPEL[~TYPEL[~TYPO]]]];~ELSE + assign ~RESULT[~SYM[2]][~SYM[1]] = ~VAR[matrix][1][~SYM[1]][~SYM[2]];~FI + end + end +~ENDGENERATE +// transpose end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.reverse" + , "type" : "reverse :: Vec n a -> Vec n a" + , "templateD" : +"// reverse begin +genvar ~GENSYM[n][1]; +~GENERATE + for (~SYM[1] = 0; ~SYM[1] < $size(~VAR[vec][0]); ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[reverse][2] + assign ~RESULT[$high(~VAR[vec][0]) - ~SYM[1]] = ~VAR[vec][0][~SYM[1]]; + end +~ENDGENERATE +// reverse end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.lazyV" + , "type" : "lazyV :: KnownNat n => Vec n a -> Vec n a" + , "templateE" : "~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.concatBitVector#" + , "type" : +"concatBitVector# :: (KnownNat n,KnownNat m) -- (ARG[0],ARG[1]) + => Vec n (BitVector m) -- ARG[2] + -> BitVector (n * m)" + , "templateE" : "~TOBV[~ARG[2]][~TYP[2]]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.unconcatBitVector#" + , "type" : +"unconcatBitVector# :: (KnownNat n, KnownNat m) -- (ARG[0],ARG[1]) + => BitVector (n * m) -- ARG[2] + -> Vec n (BitVector m)" + , "templateE" : "~FROMBV[~ARG[2]][~TYPO]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.rotateLeftS" + , "type" : "rotateLeftS :: KnownNat n => Vec n a -> SNat d -> Vec n a" + , "templateD" : +"// rotateLeftS begin +localparam ~GENSYM[shift_amount][2] = ~LIT[2] % ~LIT[0]; + +~GENERATE +if (~SYM[2] == 0) begin : ~GENSYM[no_shift][3] + assign ~RESULT = ~VAR[vec][1]; +end else begin : ~GENSYM[do_shift][4] + assign ~RESULT[0:~LIT[0]-~SYM[2]-1] = ~VAR[vec][1][~SYM[2]:~LIT[0]-1]; + assign ~RESULT[~LIT[0]-~SYM[2]:~LIT[0]-1] = ~VAR[vec][1][0:~SYM[2]-1]; +end +~ENDGENERATE +// rotateLeftS end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.rotateRightS" + , "type" : "rotateRightS :: KnownNat n => Vec n a -> SNat d -> Vec n a" + , "templateD" : +"// rotateRightS begin +localparam ~GENSYM[shift_amount][2] = ~LIT[2] % ~LIT[0]; + +~GENERATE +if (~SYM[2] == 0) begin : ~GENSYM[no_shift][3] + assign ~RESULT = ~VAR[vec][1]; +end else begin : ~GENSYM[do_shift][4] + assign ~RESULT[0:~SYM[2]-1] = ~VAR[vec][1][~LIT[0]-~SYM[2]:~LIT[0]-1]; + assign ~RESULT[~SYM[2]:~LIT[0]-1] = ~VAR[vec][1][0:~LIT[0]-~SYM[2]-1]; +end +~ENDGENERATE +// rotateRightS end" + } + } +] diff --git a/prims/systemverilog/Clash_Xilinx_ClockGen.json b/prims/systemverilog/Clash_Xilinx_ClockGen.json new file mode 100644 --- /dev/null +++ b/prims/systemverilog/Clash_Xilinx_ClockGen.json @@ -0,0 +1,39 @@ +[ { "BlackBox" : + { "name" : "Clash.Xilinx.ClockGen.clockWizard" + , "type" : +"clockWizard + :: SSymbol name -- ARG[0] + -> Clock pllIn 'Source -- ARG[1] + -> Reset pllIn 'Asynchronous -- ARG[2] + -> (Clock pllOut 'Source, Signal pllOut Bool)" + , "templateD" : +"// clockWizard begin +~NAME[0] ~GENSYM[clockWizard_inst][2] +(.CLK_IN1 (~ARG[1]) +,.RESET (~ARG[2]) +,.CLK_OUT1 (~RESULT[1]) +,.LOCKED (~RESULT[0])); +// clockWizard end" + } + } +, { "BlackBox" : + { "name" : "Clash.Xilinx.ClockGen.clockWizardDifferential" + , "type" : +"clockWizardDifferential + :: SSymbol name -- ARG[0] + -> Clock pllIn 'Source -- ARG[1] + -> Clock pllIn 'Source -- ARG[2] + -> Reset pllIn 'Asynchronous -- ARG[3] + -> (Clock pllOut 'Source, Signal pllOut Bool)" + , "templateD" : +"// clockWizardDifferential begin +~NAME[0] ~GENSYM[clockWizardDifferential_inst][2] +(.CLK_IN1_D_clk_n (~ARG[1]) +,.CLK_IN1_D_clk_n (~ARG[2]) +,.RESET (~ARG[3]) +,.CLK_OUT1 (~RESULT[1]) +,.LOCKED (~RESULT[0])); +// clockWizardDifferential end" + } + } +] diff --git a/prims/systemverilog/Clash_Xilinx_DDR.json b/prims/systemverilog/Clash_Xilinx_DDR.json new file mode 100644 --- /dev/null +++ b/prims/systemverilog/Clash_Xilinx_DDR.json @@ -0,0 +1,92 @@ +[ { "BlackBox" : + { "name" : "Clash.Xilinx.DDR.iddr" + , "type" : +"iddr + :: ( HasCallStack -- ARG[0] + , fast ~ Dom n pFast -- ARG[1] + , slow ~ Dom n (2*pFast) -- ARG[2] + , KnownNat m ) -- ARG[3] + -> Clock slow gated -- ARG[4] + -> Reset slow synchronous -- ARG[5] + -> Signal fast (BitVector m) -- ARG[6] + -> Signal slow (BitVector m,BitVector m)" + , "templateD" : +"// iddr begin +~SIGD[~GENSYM[dataout_l][1]][6]; +~SIGD[~GENSYM[dataout_h][2]][6]; +~SIGD[~GENSYM[d][3]][6]; +assign ~SYM[3] = ~ARG[6]; + +genvar ~GENSYM[i][8]; +~GENERATE +for (~SYM[8]=0; ~SYM[8] < ~SIZE[~TYP[6]]; ~SYM[8]=~SYM[8]+1) begin : ~GENSYM[ddri_array][7] + IDDR #( + .DDR_CLK_EDGE(\"SAME_EDGE\"), + .INIT_Q1(1'b0), + .INIT_Q2(1'b0), + .SRTYPE(~IF ~ISSYNC[5] ~THEN \"SYNC\" ~ELSE \"ASYNC\" ~FI) + ) ~GENSYM[~COMPNAME_IDDR][9] ( + .Q1(~SYM[1][~SYM[8]]), + .Q2(~SYM[2][~SYM[8]]),~IF ~ISGATED[6] ~THEN + .C(~ARG[4][1]), + .CE(~ARG[4][0]),~ELSE + .C(~ARG[4]), + .CE(1'b1),~FI + .D(~SYM[3][~SYM[8]]), + .R(~ARG[5]), + .S(1'b0) + ); +end +~ENDGENERATE + +assign ~RESULT = {~SYM[2],~SYM[1]}; +// iddr end" + } + } +, { "BlackBox" : + { "name" : "Clash.Xilinx.DDR.oddr#" + , "type" : +"oddr# + :: ( slow ~ Dom n (2*pFast) -- ARG[0] + , fast ~ Dom n pFast -- ARG[1] + , KnownNat m ) -- ARG[2] + => Clock slow gated -- ARG[3] + -> Reset slow synchronous -- ARG[4] + -> Signal slow (BitVector m) -- ARG[5] + -> Signal slow (BitVector m) -- ARG[6] + -> Signal fast (BitVector m)" + , "templateD" : +"// oddr begin +~SIGD[~GENSYM[datain_l][1]][6]; +~SIGD[~GENSYM[datain_h][2]][6]; +~SIGD[~GENSYM[q][3]][6]; + +assign ~SYM[1] = ~ARG[5]; +assign ~SYM[2] = ~ARG[6]; + +genvar ~GENSYM[i][8]; +~GENERATE +for (~SYM[8]=0; ~SYM[8] < ~SIZE[~TYP[6]]; ~SYM[8]=~SYM[8]+1) begin : ~GENSYM[ddro_array][7] + ODDR #( + .DDR_CLK_EDGE(\"SAME_EDGE\"), + .INIT(1'b0), + .SRTYPE(~IF ~ISSYNC[4] ~THEN \"SYNC\" ~ELSE \"ASYNC\" ~FI) + ) ~GENSYM[~COMPNAME_ODDR][9] ( + .Q(~SYM[3][~SYM[8]]),~IF ~ISGATED[3] ~THEN + .C(~ARG[3][1]), + .CE(~ARG[3][0]),~ELSE + .C(~ARG[3]), + .CE(1'b1),~FI + .D1(~SYM[1][~SYM[8]]), + .D2(~SYM[2][~SYM[8]]), + .R(~ARG[4]), + .S(1'b0) + ); +end +~ENDGENERATE + +assign ~RESULT = ~SYM[3]; +// oddr end" + } + } +] diff --git a/prims/systemverilog/GHC_Base.json b/prims/systemverilog/GHC_Base.json new file mode 100644 --- /dev/null +++ b/prims/systemverilog/GHC_Base.json @@ -0,0 +1,48 @@ +[ { "Primitive" : + { "name" : "GHC.Base.$" + , "primType" : "Function" + } + } +, { "BlackBox" : + { "name" : "GHC.Base.quotInt" + , "type" : "quotInt :: Int -> Int -> Int" + , "templateE" : "~ARG[0] / ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Base.remInt" + , "type" : "remInt :: Int -> Int -> Int" + , "templateE" : "~ARG[0] % ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Base.divInt" + , "type" : "divInt :: Int -> Int -> Int" + , "templateD" : +"// divInt begin +// divide (rounds towards zero) +~SIGD[~GENSYM[quot_res][0]][0]; +assign ~SYM[0] = ~VAR[dividend][0] / ~VAR[divider][1]; + +// round toward minus infinity +assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? ~SYM[0] : ~SYM[0] - ~SIZE[~TYPO]'sd1; +// divInt end" + } + } +, { "BlackBox" : + { "name" : "GHC.Base.modInt" + , "type" : "modInt :: Int -> Int -> Int" + , "templateD" : +"// modInt begin +// remainder +~SIGD[~GENSYM[rem_res][0]][0]; +assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1]; + +// modulo +assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? + ~SYM[0] : + ((~VAR[dividend][0] == ~SIZE[~TYPO]'sd0) ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]); +// modInt end" + } + } +] diff --git a/prims/systemverilog/GHC_Classes.json b/prims/systemverilog/GHC_Classes.json new file mode 100644 --- /dev/null +++ b/prims/systemverilog/GHC_Classes.json @@ -0,0 +1,85 @@ +[ { "BlackBox" : + { "name" : "GHC.Classes.eqInt" + , "type" : "eqInt :: Int -> Int -> Bool" + , "templateE" : "~ARG[0] == ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.neInt" + , "type" : "neInt :: Int -> Int -> Bool" + , "templateE" : "~ARG[0] != ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.gtInt" + , "type" : "gtInt :: Int -> Int -> Bool" + , "templateE" : "~ARG[0] > ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.geInt" + , "type" : "geInt :: Int -> Int -> Bool" + , "templateE" : "~ARG[0] >= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.ltInt" + , "type" : "ltInt :: Int -> Int -> Bool" + , "templateE" : "~ARG[0] < ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.leInt" + , "type" : "leInt :: Int -> Int -> Bool" + , "templateE" : "~ARG[0] <= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.&&" + , "type" : "(&&) :: Bool -> Bool -> Bool" + , "templateE" : "~ARG[0] & ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.||" + , "type" : "(::) :: Bool -> Bool -> Bool" + , "templateE" : "~ARG[0] | ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.not" + , "type" : "not :: Bool -> Bool" + , "templateE" : "~ ~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.divInt#" + , "type" : "divInt# :: Int# -> Int# -> Int#" + , "templateD" : +"// divInt# begin +// divide (rounds towards zero) +~SIGD[~GENSYM[quot_res][0]][0]; +assign ~SYM[0] = ~VAR[dividend][0] / ~VAR[divider][1]; + +// round toward minus infinity +assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? ~SYM[0] : ~SYM[0] - ~SIZE[~TYPO]'sd1; +// divInt# end" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.modInt#" + , "type" : "modInt# :: Int# -> Int# -> Int#" + , "templateD" : +"// modInt# begin +// remainder +~SIGD[~GENSYM[rem_res][0]][0]; +assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1]; + +// modulo +assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? + ~SYM[0] : + ((~VAR[dividend][0] == ~SIZE[~TYPO]'sd0) ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]); +// modInt# end" + } + } +] diff --git a/prims/systemverilog/GHC_Int.json b/prims/systemverilog/GHC_Int.json new file mode 100644 --- /dev/null +++ b/prims/systemverilog/GHC_Int.json @@ -0,0 +1,25 @@ +[ { "BlackBox" : + { "name" : "GHC.Int.I8#" + , "type" : "I8# :: Int# -> Int8" + , "templateD" : "assign ~RESULT = $signed(~ARG[0]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Int.I16#" + , "type" : "I16# :: Int# -> Int16" + , "templateD" : "assign ~RESULT = $signed(~ARG[0]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Int.I32#" + , "type" : "I32# :: Int# -> Int32" + , "templateD" : "assign ~RESULT = $signed(~ARG[0]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Int.I64#" + , "type" : "I64# :: Int# -> Int64" + , "templateD" : "assign ~RESULT = $signed(~ARG[0]);" + } + } +] diff --git a/prims/systemverilog/GHC_Integer_Type.json b/prims/systemverilog/GHC_Integer_Type.json new file mode 100644 --- /dev/null +++ b/prims/systemverilog/GHC_Integer_Type.json @@ -0,0 +1,181 @@ +[ { "BlackBox" : + { "name" : "GHC.Integer.Type.smallInteger" + , "type" : "smallInteger :: Int# -> Integer" + , "templateD" : "assign ~RESULT = $signed(~ARG[0]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.integerToInt" + , "type" : "integerToInt :: Integer -> Int#" + , "templateD" : "assign ~RESULT = $signed(~ARG[0]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.plusInteger" + , "type" : "plusInteger :: Integer -> Integer -> Integer" + , "templateE" : "~ARG[0] + ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.minusInteger" + , "type" : "minusInteger :: Integer -> Integer -> Integer" + , "templateE" : "~ARG[0] - ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.timesInteger" + , "type" : "timesInteger :: Integer -> Integer -> Integer" + , "templateE" : "~ARG[0] * ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.negateInteger" + , "type" : "negateInteger :: Integer -> Integer" + , "templateE" : "-~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.absInteger" + , "type" : "absInteger :: Integer -> Integer" + , "templateE" : "(~ARG[0] < ~SIZE[~TYPO]'sd0) ? -~ARG[0] : ~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.divInteger" + , "type" : "divInteger :: Integer -> Integer -> Integer" + , "templateD" : +"// divInteger begin +// divide (rounds towards zero) +~SIGD[~GENSYM[quot_res][0]][0]; +assign ~SYM[0] = ~VAR[dividend][0] / ~VAR[divider][1]; + +// round toward minus infinity +assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? ~SYM[0] : ~SYM[0] - ~SIZE[~TYPO]'sd1; +// divInteger end" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.modInteger" + , "type" : "modInteger :: Integer -> Integer -> Integer" + , "templateD" : +"// modInteger begin +// remainder +~SIGD[~GENSYM[rem_res][0]][0]; +assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1]; + +// modulo +assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? + ~SYM[0] : + ((~VAR[dividend][0] == ~SIZE[~TYPO]'sd0) ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]); +// modInteger end" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.quotInteger" + , "type" : "quotInteger :: Integer -> Integer -> Integer" + , "templateE" : "~ARG[0] / ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.remInteger" + , "type" : "remInteger :: Integer -> Integer -> Integer" + , "templateE" : "~ARG[0] % ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.eqInteger" + , "type" : "eqInteger :: Integer -> Integer -> Bool" + , "templateE" : "~ARG[0] == ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.neqInteger" + , "type" : "neqInteger :: Integer -> Integer -> Bool" + , "templateE" : "~ARG[0] != ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.leInteger" + , "type" : "leInteger :: Integer -> Integer -> Bool" + , "templateE" : "~ARG[0] <= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.gtInteger" + , "type" : "gtInteger :: Integer -> Integer -> Bool" + , "templateE" : "~ARG[0] > ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.ltInteger" + , "type" : "ltInteger :: Integer -> Integer -> Bool" + , "templateE" : "~ARG[0] < ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.geInteger" + , "type" : "geInteger :: Integer -> Integer -> Bool" + , "templateE" : "~ARG[0] >= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.eqInteger#" + , "type" : "eqInteger :: Integer -> Integer -> Bool" + , "templateE" : "(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.neqInteger#" + , "type" : "neqInteger :: Integer -> Integer -> Bool" + , "templateE" : "(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.leInteger#" + , "type" : "leInteger :: Integer -> Integer -> Bool" + , "templateE" : "(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.gtInteger#" + , "type" : "gtInteger :: Integer -> Integer -> Bool" + , "templateE" : "(~ARG[0] > ~ARG[1] ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.ltInteger#" + , "type" : "ltInteger :: Integer -> Integer -> Bool" + , "templateE" : "(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.geInteger#" + , "type" : "geInteger :: Integer -> Integer -> Bool" + , "templateE" : "(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.shiftRInteger" + , "type" : "shiftRInteger :: Integer -> Int# -> Integer" + , "templateE" : "~ARG[0] >>> ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.shiftLInteger" + , "type" : "shiftLInteger :: Integer -> Int# -> Integer" + , "templateE" : "~ARG[0] <<< ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.wordToInteger" + , "type" : "wordToInteger :: Word# -> Integer" + , "templateD" : "assign ~RESULT = $signed(~ARG[0]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.integerToWord" + , "type" : "integerToWord :: Integer -> Word#" + , "templateD" : "assign ~RESULT = $unsigned(~ARG[0]);" + } + } +] diff --git a/prims/systemverilog/GHC_Prim.json b/prims/systemverilog/GHC_Prim.json new file mode 100644 --- /dev/null +++ b/prims/systemverilog/GHC_Prim.json @@ -0,0 +1,1814 @@ +[ { "BlackBox" : + { "name" : "GHC.Prim.gtChar#" + , "type" : "gtChar# :: Char# -> Char# -> Int#" + , "templateE" : "(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.geChar#" + , "type" : "geChar# :: Char# -> Char# -> Int#" + , "templateE" : "(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.eqChar#" + , "type" : "eqChar# :: Char# -> Char# -> Int#" + , "templateE" : "(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.neChar#" + , "type" : "neChar# :: Char# -> Char# -> Int#" + , "templateE" : "(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.ltChar#" + , "type" : "ltChar# :: Char# -> Char# -> Int#" + , "templateE" : "(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.leChar#" + , "type" : "leChar# :: Char# -> Char# -> Int#" + , "templateE" : "(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.ord#" + , "type" : "ord :: Char# -> Int#" + , "templateD" : "assign ~RESULT = $unsigned(~ARG[0]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.+#" + , "type" : "(+#) :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] + ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.-#" + , "type" : "(-#) :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] - ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.*#" + , "type" : "(*#) :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] * ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.quotInt#" + , "type" : "quotInt# :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] / ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.remInt#" + , "type" : "remInt# :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] % ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.quotRemInt#" + , "type" : "quotRemInt# :: Int# -> Int# -> (#Int#, Int##)" + , "templateD" : +"// quotRemInt begin +~SIGD[~GENSYM[quot_res][0]][0]; +~SIGD[~GENSYM[rem_res][1]][0]; +assign ~SYM[0] = ~ARG[0] / ~ARG[1]; +assign ~SYM[1] = ~ARG[0] % ~ARG[1]; + +assign ~RESULT = {~SYM[0],~SYM[1]}; +// quotRemInt end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.andI#" + , "type" : "andI# :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] & ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.orI#" + , "type" : "orI# :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] | ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.xorI#" + , "type" : "xorI# :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] ^ ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.notI#" + , "type" : "notI# :: Int# -> Int#" + , "templateE" : "~ ~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.negateInt#" + , "type" : "negateInt# :: Int# -> Int#" + , "templateE" : "-(~ARG[0])" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.>#" + , "type" : "(>#) :: Int# -> Int# -> Int#" + , "templateE" : "(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.>=#" + , "type" : "(>=#) :: Int# -> Int# -> Int#" + , "templateE" : "(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.==#" + , "type" : "(==) :: Int# -> Int# -> Int#" + , "templateE" : "(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim./=#" + , "type" : "(/=#) :: Int# -> Int# -> Int#" + , "templateE" : "(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.<#" + , "type" : "(<#) :: Int# -> Int# -> Int#" + , "templateE" : "(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.<=#" + , "type" : "(<=#) :: Int# -> Int# -> Int#" + , "templateE" : "(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.chr#" + , "type" : "ord :: Int# -> Char#" + , "templateD" : "assign ~RESULT = $unsigned(~ARG[0]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.int2Word#" + , "type" : "int2Word# :: Int# -> Word#" + , "templateE" : "$unsigned(~ARG[0])" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.uncheckedIShiftL#" + , "type" : "uncheckedIShiftL# :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] <<< ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.uncheckedIShiftRA#" + , "type" : "uncheckedIShiftRA# :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] >>> ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.uncheckedIShiftRL#" + , "type" : "uncheckedIShiftRL# :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] >> ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.plusWord#" + , "type" : "plusWord# :: Word# -> Word# -> Word#" + , "templateE" : "~ARG[0] + ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.minusWord#" + , "type" : "minusWord# :: Word# -> Word# -> Word#" + , "templateE" : "~ARG[0] - ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.timesWord#" + , "type" : "timesWord# :: Word# -> Word# -> Word#" + , "templateE" : "~ARG[0] * ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.quotWord#" + , "type" : "quotWord# :: Word# -> Word# -> Word#" + , "templateE" : "~ARG[0] / ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.remWord#" + , "type" : "remWord# :: Word# -> Word# -> Word#" + , "templateE" : "~ARG[0] % ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.quotRemWord#" + , "type" : "quotRemWord# :: Word# -> Word# -> (#Word#, Word##)" + , "templateD" : +"// quotRemWord begin +~SIGD[~GENSYM[quot_res][0]][0]; +~SIGD[~GENSYM[rem_res][1]][0]; +assign ~SYM[0] = ~ARG[0] / ~ARG[1]; +assign ~SYM[1] = ~ARG[0] % ~ARG[1]; + +assign ~RESULT = {~SYM[0],~SYM[1]}; +// quotRemWord end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.and#" + , "type" : "and# :: Word# -> Word# -> Word#" + , "templateE" : "~ARG[0] & ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.or#" + , "type" : "or# :: Word# -> Word# -> Word#" + , "templateE" : "~ARG[0] | ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.xor#" + , "type" : "xor# :: Word# -> Word# -> Word#" + , "templateE" : "~ARG[0] ^ ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.not#" + , "type" : "not# :: Word# -> Word#" + , "templateE" : "~ ~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.uncheckedShiftL#" + , "type" : "uncheckedShiftL# :: Word# -> Int# -> Word#" + , "templateE" : "~ARG[0] << ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.uncheckedShiftRL#" + , "type" : "uncheckedShiftRL# :: Word# -> Int# -> Word#" + , "templateE" : "~ARG[0] >> ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.word2Int#" + , "type" : "int2Word# :: Word# -> Int#" + , "templateE" : "$signed(~ARG[0])" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.gtWord#" + , "type" : "gtWord# :: Word# -> Word# -> Int#" + , "templateE" : "(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.geWord#" + , "type" : "geWord# :: Word# -> Word# -> Int#" + , "templateE" : "(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.eqWord#" + , "type" : "eqWord# :: Word# -> Word# -> Int#" + , "templateE" : "(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.neWord#" + , "type" : "neWord# :: Word# -> Word# -> Int#" + , "templateE" : "(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.ltWord#" + , "type" : "ltWord# :: Word# -> Word# -> Int#" + , "templateE" : "(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.leWord#" + , "type" : "leWord# :: Word# -> Word# -> Int#" + , "templateE" : "(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.popCnt8#" + , "type" : "popCnt8# :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "depth2Index" + , "extension" : "inc" + , "content" : +"// given a level and a depth, calculate the corresponding index into the +// intermediate array +function integer ~INCLUDENAME; + input integer levels; + input integer depth; + + ~INCLUDENAME = (2 ** levels) - (2 ** depth); +endfunction" + } + , "templateD" : +"// popCnt8 begin +localparam ~GENSYM[width][0] = 8; + +// depth of the tree +localparam ~GENSYM[levels][2] = $clog2(~SYM[0]); + +logic [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2]; + +// put input into the first half of the intermediate array +genvar ~GENSYM[i][4]; +~GENERATE +for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11] + assign ~SYM[3][~SYM[4]] = $unsigned(~ARG[0][~SYM[4]]); +end +~ENDGENERATE + +// Create the tree of instantiated components +genvar ~GENSYM[d][6]; +genvar ~GENSYM[i][7]; +~GENERATE +if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8] + for (~SYM[6] = (~SYM[2] - 1); ~SYM[6] >= 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9] + for (~SYM[7] = 0; ~SYM[7] < (2**~SYM[6]); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10] + assign ~SYM[3][~INCLUDENAME(~SYM[2]+1,~SYM[6]+1)+~SYM[7]] = + ~SYM[3][~INCLUDENAME(~SYM[2]+1,~SYM[6]+2)+(2*~SYM[7])] + + ~SYM[3][~INCLUDENAME(~SYM[2]+1,~SYM[6]+2)+(2*~SYM[7])+1]; + end + end +end +~ENDGENERATE + +// The last element of the intermediate array holds the result +assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]); +// popCnt8 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.popCnt16#" + , "type" : "popCnt16# :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "depth2Index" + , "extension" : "inc" + , "content" : +"// given a level and a depth, calculate the corresponding index into the +// intermediate array +function integer ~INCLUDENAME; + input integer levels; + input integer depth; + + ~INCLUDENAME = (2 ** levels) - (2 ** depth); +endfunction" + } + , "templateD" : +"// popCnt16 begin +localparam ~GENSYM[width][0] = 16; + +// depth of the tree +localparam ~GENSYM[levels][2] = $clog2(~SYM[0]); + +logic [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2]; + +// put input into the first half of the intermediate array +genvar ~GENSYM[i][4]; +~GENERATE +for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11] + assign ~SYM[3][~SYM[4]] = $unsigned(~ARG[0][~SYM[4]]); +end +~ENDGENERATE + +// Create the tree of instantiated components +genvar ~GENSYM[d][6]; +genvar ~GENSYM[i][7]; +~GENERATE +if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8] + for (~SYM[6] = (~SYM[2] - 1); ~SYM[6] >= 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9] + for (~SYM[7] = 0; ~SYM[7] < (2**~SYM[6]); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10] + assign ~SYM[3][~INCLUDENAME(~SYM[2]+1,~SYM[6]+1)+~SYM[7]] = + ~SYM[3][~INCLUDENAME(~SYM[2]+1,~SYM[6]+2)+(2*~SYM[7])] + + ~SYM[3][~INCLUDENAME(~SYM[2]+1,~SYM[6]+2)+(2*~SYM[7])+1]; + end + end +end +~ENDGENERATE + +// The last element of the intermediate array holds the result +assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]); +// popCnt16 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.popCnt32#" + , "type" : "popCnt32# :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "depth2Index" + , "extension" : "inc" + , "content" : +"// given a level and a depth, calculate the corresponding index into the +// intermediate array +function integer ~INCLUDENAME; + input integer levels; + input integer depth; + + ~INCLUDENAME = (2 ** levels) - (2 ** depth); +endfunction" + } + , "templateD" : +"// popCnt32 begin +localparam ~GENSYM[width][0] = 32; + +// depth of the tree +localparam ~GENSYM[levels][2] = $clog2(~SYM[0]); + +logic [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2]; + +// put input into the first half of the intermediate array +genvar ~GENSYM[i][4]; +~GENERATE +for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11] + assign ~SYM[3][~SYM[4]] = $unsigned(~ARG[0][~SYM[4]]); +end +~ENDGENERATE + +// Create the tree of instantiated components +genvar ~GENSYM[d][6]; +genvar ~GENSYM[i][7]; +~GENERATE +if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8] + for (~SYM[6] = (~SYM[2] - 1); ~SYM[6] >= 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9] + for (~SYM[7] = 0; ~SYM[7] < (2**~SYM[6]); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10] + assign ~SYM[3][~INCLUDENAME(~SYM[2]+1,~SYM[6]+1)+~SYM[7]] = + ~SYM[3][~INCLUDENAME(~SYM[2]+1,~SYM[6]+2)+(2*~SYM[7])] + + ~SYM[3][~INCLUDENAME(~SYM[2]+1,~SYM[6]+2)+(2*~SYM[7])+1]; + end + end +end +~ENDGENERATE + +// The last element of the intermediate array holds the result +assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]); +// popCnt32 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.popCnt64#" + , "type" : "popCnt64# :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "depth2Index" + , "extension" : "inc" + , "content" : +"// given a level and a depth, calculate the corresponding index into the +// intermediate array +function integer ~INCLUDENAME; + input integer levels; + input integer depth; + + ~INCLUDENAME = (2 ** levels) - (2 ** depth); +endfunction" + } + , "templateD" : +"// popCnt64 begin +localparam ~GENSYM[width][0] = 64; + +// depth of the tree +localparam ~GENSYM[levels][2] = $clog2(~SYM[0]); + +logic [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2]; + +// put input into the first half of the intermediate array +genvar ~GENSYM[i][4]; +~GENERATE +for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11] + assign ~SYM[3][~SYM[4]] = $unsigned(~ARG[0][~SYM[4]]); +end +~ENDGENERATE + +// Create the tree of instantiated components +genvar ~GENSYM[d][6]; +genvar ~GENSYM[i][7]; +~GENERATE +if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8] + for (~SYM[6] = (~SYM[2] - 1); ~SYM[6] >= 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9] + for (~SYM[7] = 0; ~SYM[7] < (2**~SYM[6]); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10] + assign ~SYM[3][~INCLUDENAME(~SYM[2]+1,~SYM[6]+1)+~SYM[7]] = + ~SYM[3][~INCLUDENAME(~SYM[2]+1,~SYM[6]+2)+(2*~SYM[7])] + + ~SYM[3][~INCLUDENAME(~SYM[2]+1,~SYM[6]+2)+(2*~SYM[7])+1]; + end + end +end +~ENDGENERATE + +// The last element of the intermediate array holds the result +assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]); +// popCnt64 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.popCnt#" + , "type" : "popCnt8# :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "depth2Index" + , "extension" : "inc" + , "content" : +"// given a level and a depth, calculate the corresponding index into the +// intermediate array +function integer ~INCLUDENAME; + input integer levels; + input integer depth; + + ~INCLUDENAME = (2 ** levels) - (2 ** depth); +endfunction" + } + , "templateD" : +"// popCnt begin +localparam ~GENSYM[width][0] = ~SIZE[~TYPO]; + +// depth of the tree +localparam ~GENSYM[levels][2] = $clog2(~SYM[0]); + +logic [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2]; + +// put input into the first half of the intermediate array +genvar ~GENSYM[i][4]; +~GENERATE +for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11] + assign ~SYM[3][~SYM[4]] = $unsigned(~ARG[0][~SYM[4]]); +end +~ENDGENERATE + +// Create the tree of instantiated components +genvar ~GENSYM[d][6]; +genvar ~GENSYM[i][7]; +~GENERATE +if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8] + for (~SYM[6] = (~SYM[2] - 1); ~SYM[6] >= 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9] + for (~SYM[7] = 0; ~SYM[7] < (2**~SYM[6]); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10] + assign ~SYM[3][~INCLUDENAME(~SYM[2]+1,~SYM[6]+1)+~SYM[7]] = + ~SYM[3][~INCLUDENAME(~SYM[2]+1,~SYM[6]+2)+(2*~SYM[7])] + + ~SYM[3][~INCLUDENAME(~SYM[2]+1,~SYM[6]+2)+(2*~SYM[7])+1]; + end + end +end +~ENDGENERATE + +// The last element of the intermediate array holds the result +assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]); +// popCnt end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.clz8#" + , "type" : "clz8 :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "enc" + , "extension" : "inc" + , "content" : +"function [1:0] ~INCLUDENAME; + input [1:0] a; + case (a) + 2'b00: ~INCLUDENAME = 2'b10; + 2'b01: ~INCLUDENAME = 2'b01; + 2'b10: ~INCLUDENAME = 2'b00; + default: ~INCLUDENAME = 2'b00; + endcase +endfunction" + } + , "templateD" : +"// clz8 begin +logic [0:7] ~GENSYM[v][1]; +assign ~SYM[1] = ~ARG[0][7:0]; + +logic [0:7] ~GENSYM[e][2]; +genvar ~GENSYM[n][3]; +~GENERATE +for (~SYM[3]=0;~SYM[3]<4;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] + assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME(~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); +end +~ENDGENERATE + +logic [0:5] ~GENSYM[a][4]; +genvar ~GENSYM[i1][5]; +~GENERATE +for (~SYM[5]=0;~SYM[5]<2;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage1][6] + localparam n = 2; + logic [3:0] i; + assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:3] ~GENSYM[res][7]; +~GENERATE +if (1) begin +localparam n = 3; +logic [5:0] i; +assign i = ~SYM[4][0:5]; +always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase +end +end +~ENDGENERATE + +assign ~RESULT = $unsigned(~SYM[7]); +// clz8 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.clz16#" + , "type" : "clz16 :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "enc" + , "extension" : "inc" + , "content" : +"function [1:0] ~INCLUDENAME; + input [1:0] a; + case (a) + 2'b00: ~INCLUDENAME = 2'b10; + 2'b01: ~INCLUDENAME = 2'b01; + 2'b10: ~INCLUDENAME = 2'b00; + default: ~INCLUDENAME = 2'b00; + endcase +endfunction" + } + , "templateD" : +"// clz16 begin +logic [0:15] ~GENSYM[v][1]; +assign ~SYM[1] = ~ARG[0][15:0]; + +logic [0:15] ~GENSYM[e][2]; +genvar ~GENSYM[i][3]; +~GENERATE +for (~SYM[3]=0;~SYM[3]<8;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] + assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME(~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); +end +~ENDGENERATE + +logic [0:11] ~GENSYM[a][4]; +genvar ~GENSYM[i1][5]; +~GENERATE +for (~SYM[5]=0;~SYM[5]<4;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] + localparam n = 2; + logic [3:0] i; + assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:7] ~GENSYM[b][9]; +genvar ~GENSYM[i2][10]; +~GENERATE +for (~SYM[10]=0;~SYM[10]<2;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] + localparam n = 3; + logic [5:0] i; + assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:4] ~GENSYM[res][7]; +~GENERATE +if (1) begin +localparam n = 4; +logic [7:0] i; +assign i = ~SYM[9][0:7]; +always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase +end +end +~ENDGENERATE + +assign ~RESULT = $unsigned(~SYM[7]); +// clz16 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.clz32#" + , "type" : "clz32 :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "enc" + , "extension" : "inc" + , "content" : +"function [1:0] ~INCLUDENAME; + input [1:0] a; + case (a) + 2'b00: ~INCLUDENAME = 2'b10; + 2'b01: ~INCLUDENAME = 2'b01; + 2'b10: ~INCLUDENAME = 2'b00; + default: ~INCLUDENAME = 2'b00; + endcase +endfunction" + } + , "templateD" : +"// clz32 begin +logic [0:31] ~GENSYM[v][1]; +assign ~SYM[1] = ~ARG[0][31:0]; + +logic [0:31] ~GENSYM[e][2]; +genvar ~GENSYM[i][3]; +~GENERATE +for (~SYM[3]=0;~SYM[3]<16;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] + assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME(~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); +end +~ENDGENERATE + +logic [0:23] ~GENSYM[a][4]; +genvar ~GENSYM[i1][5]; +~GENERATE +for (~SYM[5]=0;~SYM[5]<8;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] + localparam n = 2; + logic [3:0] i; + assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:15] ~GENSYM[b][9]; +genvar ~GENSYM[i2][10]; +~GENERATE +for (~SYM[10]=0;~SYM[10]<4;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] + localparam n = 3; + logic [5:0] i; + assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:9] ~GENSYM[c][12]; +genvar ~GENSYM[i3][13]; +~GENERATE +for (~SYM[13]=0;~SYM[13]<2;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14] + localparam n = 4; + logic [7:0] i; + assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:5] ~GENSYM[res][7]; +~GENERATE +if (1) begin +localparam n = 5; +logic [9:0] i; +assign i = ~SYM[12][0:9]; +always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase +end +end +~ENDGENERATE + +assign ~RESULT = $unsigned(~SYM[7]); +// clz32 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.clz64#" + , "type" : "clz64 :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "enc" + , "extension" : "inc" + , "content" : +"function [1:0] ~INCLUDENAME; + input [1:0] a; + case (a) + 2'b00: ~INCLUDENAME = 2'b10; + 2'b01: ~INCLUDENAME = 2'b01; + 2'b10: ~INCLUDENAME = 2'b00; + default: ~INCLUDENAME = 2'b00; + endcase +endfunction" + } + , "templateD" : +"// clz64 begin +logic [0:63] ~GENSYM[v][1]; +assign ~SYM[1] = ~ARG[0][63:0]; + +logic [0:63] ~GENSYM[e][2]; +genvar ~GENSYM[i][3]; +~GENERATE +for (~SYM[3]=0;~SYM[3]<32;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] + assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME(~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); +end +~ENDGENERATE + +logic [0:47] ~GENSYM[a][4]; +genvar ~GENSYM[i1][5]; +~GENERATE +for (~SYM[5]=0;~SYM[5]<16;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] + localparam n = 2; + logic [3:0] i; + assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:31] ~GENSYM[b][9]; +genvar ~GENSYM[i2][10]; +~GENERATE +for (~SYM[10]=0;~SYM[10]<8;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] + localparam n = 3; + logic [5:0] i; + assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:19] ~GENSYM[c][12]; +genvar ~GENSYM[i3][13]; +~GENERATE +for (~SYM[13]=0;~SYM[13]<4;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14] + localparam n = 4; + logic [7:0] i; + assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:11] ~GENSYM[d][15]; +genvar ~GENSYM[i4][16]; +~GENERATE +for (~SYM[16]=0;~SYM[16]<2;~SYM[16]=~SYM[16]+1) begin : ~GENSYM[mux_stage4][17] + localparam n = 5; + logic [9:0] i; + assign i = ~SYM[12][~SYM[16]*10:~SYM[16]*10+9]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:6] ~GENSYM[res][7]; +~GENERATE +if (1) begin +localparam n = 6; +logic [11:0] i; +assign i = ~SYM[15][0:11]; +always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase +end +end +~ENDGENERATE + +assign ~RESULT = $unsigned(~SYM[7]); +// clz64 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.clz#" + , "type" : "clz :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "enc" + , "extension" : "inc" + , "content" : +"function [1:0] ~INCLUDENAME; + input [1:0] a; + case (a) + 2'b00: ~INCLUDENAME = 2'b10; + 2'b01: ~INCLUDENAME = 2'b01; + 2'b10: ~INCLUDENAME = 2'b00; + default: ~INCLUDENAME = 2'b00; + endcase +endfunction" + } + , "templateD" : +"// clz begin +~IF ~IW64 ~THEN +logic [0:63] ~GENSYM[v][1]; +assign ~SYM[1] = ~ARG[0][63:0]; + +logic [0:63] ~GENSYM[e][2]; +genvar ~GENSYM[i][3]; +~GENERATE +for (~SYM[3]=0;~SYM[3]<32;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] + assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME(~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); +end +~ENDGENERATE + +logic [0:47] ~GENSYM[a][4]; +genvar ~GENSYM[i1][5]; +~GENERATE +for (~SYM[5]=0;~SYM[5]<16;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] + localparam n = 2; + logic [3:0] i; + assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:31] ~GENSYM[b][9]; +genvar ~GENSYM[i2][10]; +~GENERATE +for (~SYM[10]=0;~SYM[10]<8;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] + localparam n = 3; + logic [5:0] i; + assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:19] ~GENSYM[c][12]; +genvar ~GENSYM[i3][13]; +~GENERATE +for (~SYM[13]=0;~SYM[13]<4;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14] + localparam n = 4; + logic [7:0] i; + assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:11] ~GENSYM[d][15]; +genvar ~GENSYM[i4][16]; +~GENERATE +for (~SYM[16]=0;~SYM[16]<2;~SYM[16]=~SYM[16]+1) begin : ~GENSYM[mux_stage4][17] + localparam n = 5; + logic [9:0] i; + assign i = ~SYM[12][~SYM[16]*10:~SYM[16]*10+9]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:6] ~GENSYM[res][7]; +~GENERATE +if (1) begin +localparam n = 6; +logic [11:0] i; +assign i = ~SYM[15][0:11]; +always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase +end +end +~ENDGENERATE +~ELSE +logic [0:31] ~SYM[1]; +assign ~SYM[1] = ~ARG[0][31:0]; + +logic [0:31] ~SYM[2]; +genvar ~SYM[3]; +~GENERATE +for (~SYM[3]=0;~SYM[3]<16;~SYM[3]=~SYM[3]+1) begin : ~SYM[8] + assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME(~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); +end +~ENDGENERATE + +logic [0:23] ~SYM[4]; +genvar ~SYM[5]; +~GENERATE +for (~SYM[5]=0;~SYM[5]<8;~SYM[5]=~SYM[5]+1) begin : ~SYM[6] + localparam n = 2; + logic [3:0] i; + assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:15] ~SYM[9]; +genvar ~SYM[10]; +~GENERATE +for (~SYM[10]=0;~SYM[10]<4;~SYM[10]=~SYM[10]+1) begin : ~SYM[11] + localparam n = 3; + logic [5:0] i; + assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:9] ~SYM[12]; +genvar ~SYM[13]; +~GENERATE +for (~SYM[13]=0;~SYM[13]<2;~SYM[13]=~SYM[13]+1) begin : ~SYM[14] + localparam n = 4; + logic [7:0] i; + assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:5] ~SYM[7]; +~GENERATE +if (1) begin +localparam n = 5; +logic [9:0] i; +assign i = ~SYM[12][0:9]; +always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase +end +end +~ENDGENERATE +~FI +assign ~RESULT = $unsigned(~SYM[7]); +// clz end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.ctz8#" + , "type" : "ctz8 :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "enc" + , "extension" : "inc" + , "content" : +"function [1:0] ~INCLUDENAME; + input [1:0] a; + case (a) + 2'b00: ~INCLUDENAME = 2'b10; + 2'b01: ~INCLUDENAME = 2'b01; + 2'b10: ~INCLUDENAME = 2'b00; + default: ~INCLUDENAME = 2'b00; + endcase +endfunction" + } + , "templateD" : +"// ctz8 begin +logic [0:7] ~GENSYM[v][1]; +genvar ~GENSYM[k][18]; +~GENERATE +for (~SYM[18]=0;~SYM[18]<8;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19] + assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]]; +end +~ENDGENERATE + +logic [0:7] ~GENSYM[e][2]; +genvar ~GENSYM[i][3]; +~GENERATE +for (~SYM[3]=0;~SYM[3]<4;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] + assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME(~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); +end +~ENDGENERATE + +logic [0:5] ~GENSYM[a][4]; +genvar ~GENSYM[i1][5]; +~GENERATE +for (~SYM[5]=0;~SYM[5]<2;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] + localparam n = 2; + logic [3:0] i; + assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:3] ~GENSYM[res][7]; +~GENERATE +if (1) begin +localparam n = 3; +logic [5:0] i; +assign i = ~SYM[4][0:5]; +always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase +end +end +~ENDGENERATE + +assign ~RESULT = $unsigned(~SYM[7]); +// ctz8 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.ctz16#" + , "type" : "ctz16 :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "enc" + , "extension" : "inc" + , "content" : +"function [1:0] ~INCLUDENAME; + input [1:0] a; + case (a) + 2'b00: ~INCLUDENAME = 2'b10; + 2'b01: ~INCLUDENAME = 2'b01; + 2'b10: ~INCLUDENAME = 2'b00; + default: ~INCLUDENAME = 2'b00; + endcase +endfunction" + } + , "templateD" : +"// ctz16 begin +logic [0:15] ~GENSYM[v][1]; +genvar ~GENSYM[k][18]; +~GENERATE +for (~SYM[18]=0;~SYM[18]<16;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19] + assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]]; +end +~ENDGENERATE + +logic [0:15] ~GENSYM[e][2]; +genvar ~GENSYM[i][3]; +~GENERATE +for (~SYM[3]=0;~SYM[3]<8;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] + assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME(~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); +end +~ENDGENERATE + +logic [0:11] ~GENSYM[a][4]; +genvar ~GENSYM[i1][5]; +~GENERATE +for (~SYM[5]=0;~SYM[5]<4;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] + localparam n = 2; + logic [3:0] i; + assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:7] ~GENSYM[b][9]; +genvar ~GENSYM[i2][10]; +~GENERATE +for (~SYM[10]=0;~SYM[10]<2;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] + localparam n = 3; + logic [5:0] i; + assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:4] ~GENSYM[res][7]; +~GENERATE +if (1) begin +localparam n = 4; +logic [7:0] i; +assign i = ~SYM[9][0:7]; +always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase +end +end +~ENDGENERATE + +assign ~RESULT = $unsigned(~SYM[7]); +// ctz16 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.ctz32#" + , "type" : "ctz32 :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "enc" + , "extension" : "inc" + , "content" : +"function [1:0] ~INCLUDENAME; + input [1:0] a; + case (a) + 2'b00: ~INCLUDENAME = 2'b10; + 2'b01: ~INCLUDENAME = 2'b01; + 2'b10: ~INCLUDENAME = 2'b00; + default: ~INCLUDENAME = 2'b00; + endcase +endfunction" + } + , "templateD" : +"// ctz32 begin +logic [0:31] ~GENSYM[v][1]; +genvar ~GENSYM[k][18]; +~GENERATE +for (~SYM[18]=0;~SYM[18]<32;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19] + assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]]; +end +~ENDGENERATE + +logic [0:31] ~GENSYM[e][2]; +genvar ~GENSYM[i][3]; +~GENERATE +for (~SYM[3]=0;~SYM[3]<16;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] + assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME(~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); +end +~ENDGENERATE + +logic [0:23] ~GENSYM[a][4]; +genvar ~GENSYM[i1][5]; +~GENERATE +for (~SYM[5]=0;~SYM[5]<8;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] + localparam n = 2; + logic [3:0] i; + assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:15] ~GENSYM[b][9]; +genvar ~GENSYM[i2][10]; +~GENERATE +for (~SYM[10]=0;~SYM[10]<4;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] + localparam n = 3; + logic [5:0] i; + assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:9] ~GENSYM[c][12]; +genvar ~GENSYM[i3][13]; +~GENERATE +for (~SYM[13]=0;~SYM[13]<2;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14] + localparam n = 4; + logic [7:0] i; + assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:5] ~GENSYM[res][7]; +~GENERATE +if (1) begin +localparam n = 5; +logic [9:0] i; +assign i = ~SYM[12][0:9]; +always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase +end +end +~ENDGENERATE + +assign ~RESULT = $unsigned(~SYM[7]); +// ctz32 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.ctz64#" + , "type" : "ctz64 :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "enc" + , "extension" : "inc" + , "content" : +"function [1:0] ~INCLUDENAME; + input [1:0] a; + case (a) + 2'b00: ~INCLUDENAME = 2'b10; + 2'b01: ~INCLUDENAME = 2'b01; + 2'b10: ~INCLUDENAME = 2'b00; + default: ~INCLUDENAME = 2'b00; + endcase +endfunction" + } + , "templateD" : +"// ctz64 begin +logic [0:63] ~GENSYM[v][1]; +genvar ~GENSYM[k][18]; +~GENERATE +for (~SYM[18]=0;~SYM[18]<64;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19] + assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]]; +end +~ENDGENERATE + +logic [0:63] ~GENSYM[e][2]; +genvar ~GENSYM[i][3]; +~GENERATE +for (~SYM[3]=0;~SYM[3]<32;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] + assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME(~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); +end +~ENDGENERATE + +logic [0:47] a; +genvar ~GENSYM[i1][5]; +~GENERATE +for (~SYM[5]=0;~SYM[5]<16;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] + localparam n = 2; + logic [3:0] i; + assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:31] ~GENSYM[b][9]; +genvar ~GENSYM[i2][10]; +~GENERATE +for (~SYM[10]=0;~SYM[10]<8;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] + localparam n = 3; + logic [5:0] i; + assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:19] ~GENSYM[c][12]; +genvar ~GENSYM[i3][13]; +~GENERATE +for (~SYM[13]=0;~SYM[13]<4;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14] + localparam n = 4; + logic [7:0] i; + assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:11] ~GENSYM[d][15]; +genvar ~GENSYM[i4][16]; +~GENERATE +for (~SYM[16]=0;~SYM[16]<2;~SYM[16]=~SYM[16]+1) begin : ~GENSYM[mux_stage4][17] + localparam n = 5; + logic [9:0] i; + assign i = ~SYM[12][~SYM[16]*10:~SYM[16]*10+9]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:6] ~GENSYM[res][7]; +~GENERATE +if (1) begin +localparam n = 6; +logic [11:0] i; +assign i = ~SYM[15][0:11]; +always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase +end +end +~ENDGENERATE + +assign ~RESULT = $unsigned(~SYM[7]); +// ctz64 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.ctz#" + , "type" : "ctz :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "enc" + , "extension" : "inc" + , "content" : +"function [1:0] ~INCLUDENAME; + input [1:0] a; + case (a) + 2'b00: ~INCLUDENAME = 2'b10; + 2'b01: ~INCLUDENAME = 2'b01; + 2'b10: ~INCLUDENAME = 2'b00; + default: ~INCLUDENAME = 2'b00; + endcase +endfunction" + } + , "templateD" : +"// ctz begin +~IF ~IW64 ~THEN +logic [0:63] ~GENSYM[v][1]; +genvar ~GENSYM[k][18]; +~GENERATE +for (~SYM[18]=0;~SYM[18]<64;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19] + assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]]; +end +~ENDGENERATE + +logic [0:63] ~GENSYM[e][2]; +genvar ~GENSYM[i][3]; +~GENERATE +for (~SYM[3]=0;~SYM[3]<32;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] + assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME(~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); +end +~ENDGENERATE + +logic [0:47] ~GENSYM[a][4]; +genvar ~GENSYM[i1][5]; +~GENERATE +for (~SYM[5]=0;~SYM[5]<16;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] + localparam n = 2; + logic [3:0] i; + assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:31] ~GENSYM[b][9]; +genvar ~GENSYM[i2][10]; +~GENERATE +for (~SYM[10]=0;~SYM[10]<8;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] + localparam n = 3; + logic [5:0] i; + assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:19] ~GENSYM[c][12]; +genvar ~GENSYM[i3][13]; +~GENERATE +for (~SYM[13]=0;~SYM[13]<4;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14] + localparam n = 4; + logic [7:0] i; + assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:11] ~GENSYM[d][15]; +genvar ~GENSYM[i4][16]; +~GENERATE +for (~SYM[16]=0;~SYM[16]<2;~SYM[16]=~SYM[16]+1) begin : ~GENSYM[mux_stage4][17] + localparam n = 5; + logic [9:0] i; + assign i = ~SYM[12][~SYM[16]*10:~SYM[16]*10+9]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:6] ~GENSYM[res][7]; +~GENERATE +if (1) begin +localparam n = 6; +logic [11:0] i; +assign i = ~SYM[15][0:11]; +always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase +end +end +~ENDGENERATE +~ELSE +logic [0:31] ~SYM[1]; +genvar ~SYM[18]; +~GENERATE +for (~SYM[18]=0;~SYM[18]<32;~SYM[18]=~SYM[18]+1) begin : ~SYM[19] + assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]]; +end +~ENDGENERATE + +logic [0:31] ~SYM[2]; +genvar ~SYM[3]; +~GENERATE +for (~SYM[3]=0;~SYM[3]<16;~SYM[3]=~SYM[3]+1) begin : ~SYM[8] + assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME(~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); +end +~ENDGENERATE + +logic [0:23] ~SYM[4]; +genvar ~SYM[5]; +~GENERATE +for (~SYM[5]=0;~SYM[5]<8;~SYM[5]=~SYM[5]+1) begin : ~SYM[6] + localparam n = 2; + logic [3:0] i; + assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:15] ~SYM[9]; +genvar ~SYM[10]; +~GENERATE +for (~SYM[10]=0;~SYM[10]<4;~SYM[10]=~SYM[10]+1) begin : ~SYM[11] + localparam n = 3; + logic [5:0] i; + assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:9] ~SYM[12]; +genvar ~SYM[13]; +~GENERATE +for (~SYM[13]=0;~SYM[13]<2;~SYM[13]=~SYM[13]+1) begin : ~SYM[14] + localparam n = 4; + logic [7:0] i; + assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; + always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +logic [0:5] ~SYM[7]; +~GENERATE +if (1) begin +localparam n = 5; +logic [9:0] i; +assign i = ~SYM[12][0:9]; +always_comb begin + case (i[n-1+n]) + 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase +end +end +~ENDGENERATE +~FI +assign ~RESULT = $unsigned(~SYM[7]); +// ctz end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.byteSwap16#" + , "type" : "byteSwap16# :: Word# -> Word#" + , "templateD" : +"// byteSwap16 begin~IF ~IW64 ~THEN +assign ~RESULT = {~VAR[w][0][63:16],~VAR[w][0][7:0],~VAR[w][0][15:8]};~ELSE +assign ~RESULT = {~VAR[w][0][31:16],~VAR[w][0][7:0],~VAR[w][0][15:8]};~FI +// byteSwap16 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.byteSwap32#" + , "type" : "byteSwap32# :: Word# -> Word#" + , "templateD" : +"// byteSwap32 begin~IF ~IW64 ~THEN +assign ~RESULT = {~VAR[w][0][63:32],~VAR[w][0][7:0],~VAR[w][0][15:8],~VAR[w][0][23:16],~VAR[w][0][31:24]};~ELSE +assign ~RESULT = {~VAR[w][0][7:0],~VAR[w][0][15:8],~VAR[w][0][23:16],~VAR[w][0][31:24]};~FI +// byteSwap32 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.byteSwap64#" + , "type" : "byteSwap64# :: Word# -> Word#" + , "templateD" : +"// byteSwap64 begin +assign ~RESULT = {~VAR[w][0][7:0],~VAR[w][0][15:8],~VAR[w][0][23:16],~VAR[w][0][31:24] + ,~VAR[w][0][39:32],~VAR[w][0][47:40],~VAR[w][0][55:48],~VAR[w][0][63:56]}; +// byteSwap64 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.byteSwap#" + , "type" : "byteSwap# :: Word# -> Word#" + , "templateD" : +"// byteSwap begin~IF ~IW64 ~THEN +assign ~RESULT = {~VAR[w][0][7:0],~VAR[w][0][15:8],~VAR[w][0][23:16],~VAR[w][0][31:24] + ,~VAR[w][0][39:32],~VAR[w][0][47:40],~VAR[w][0][55:48],~VAR[w][0][63:56]};~ELSE +assign ~RESULT = {~VAR[w][0][7:0],~VAR[w][0][15:8],~VAR[w][0][23:16],~VAR[w][0][31:24]};~FI +// byteSwap end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.narrow8Int#" + , "type" : "narrow8Int# :: Int# -> Int#" + , "templateD" : +"// narrow8Int begin +assign ~RESULT = $signed(~VAR[i][0][7:0]); +// narrow8Int end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.narrow16Int#" + , "type" : "narrow16Int# :: Int# -> Int#" + , "templateD" : +"// narrow16Int begin +assign ~RESULT = $signed(~VAR[i][0][15:0]); +// narrow16Int end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.narrow32Int#" + , "type" : "narrow32Int# :: Int# -> Int#" + , "templateD" : +"// narrow32Int begin +assign ~RESULT = $signed(~VAR[i][0][31:0]); +// narrow32Int end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.narrow8Word#" + , "type" : "narrow8Int# :: Word# -> Word#" + , "templateD" : +"// narrow8Word begin +assign ~RESULT = $unsigned(~VAR[w][0][7:0]); +// narrow8Word end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.narrow16Word#" + , "type" : "narrow16Word# :: Word# -> Word#" + , "templateD" : +"// narrow16Word begin +assign ~RESULT = $unsigned(~VAR[w][0][15:0]); +// narrow16Word end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.narrow32Word#" + , "type" : "narrow32Int# :: Word# -> Word#" + , "templateD" : +"// narrow32Word begin +assign ~RESULT = $unsigned(~VAR[w][0][31:0]); +// narrow32Word end" + } + } +, { "Primitive" : + { "name" : "GHC.Prim.dataToTag#" + , "primType" : "Function" + } + } +, { "Primitive" : + { "name" : "GHC.Prim.tagToEnum#" + , "primType" : "Function" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.unsafeCoerce#" + , "type" : "unsafeCoerce# :: a -> b" + , "templateE" : "~ARG[0]" + } + } +] diff --git a/prims/systemverilog/GHC_Types.json b/prims/systemverilog/GHC_Types.json new file mode 100644 --- /dev/null +++ b/prims/systemverilog/GHC_Types.json @@ -0,0 +1,24 @@ +[ { "Primitive" : + { "name" : "GHC.Types.MkCoercible" + , "primType" : "Constructor" + } + } +, { "BlackBox" : + { "name" : "GHC.Types.C#" + , "type" : "I# :: Char# -> Char" + , "templateE" : "~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "GHC.Types.I#" + , "type" : "I# :: Int# -> Int" + , "templateE" : "~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "GHC.Types.W#" + , "type" : "W# :: Word# -> Word" + , "templateE" : "~ARG[0]" + } + } +] diff --git a/prims/systemverilog/GHC_Word.json b/prims/systemverilog/GHC_Word.json new file mode 100644 --- /dev/null +++ b/prims/systemverilog/GHC_Word.json @@ -0,0 +1,25 @@ +[ { "BlackBox" : + { "name" : "GHC.Word.W8#" + , "type" : "W8# :: Word# -> Word8" + , "templateD" : "assign ~RESULT = $unsigned(~ARG[0]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Word.W16#" + , "type" : "W16# :: Word# -> Word16" + , "templateD" : "assign ~RESULT = $unsigned(~ARG[0]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Word.W32#" + , "type" : "W32# :: Word# -> Word32" + , "templateD" : "assign ~RESULT = $unsigned(~ARG[0]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Word.W64#" + , "type" : "W64# :: Word# -> Word64" + , "templateD" : "assign ~RESULT = $unsigned(~ARG[0]);" + } + } +] diff --git a/prims/verilog/Clash_Explicit_BlockRam.json b/prims/verilog/Clash_Explicit_BlockRam.json new file mode 100644 --- /dev/null +++ b/prims/verilog/Clash_Explicit_BlockRam.json @@ -0,0 +1,50 @@ +[ { "BlackBox" : + { "name" : "Clash.Explicit.BlockRam.blockRam#" + , "type" : +"blockRam# + :: HasCallStack -- ARG[0] + => Clock dom gated -- clk, ARG[1] + -> Vec n a -- init, ARG[2] + -> Signal dom Int -- rd, ARG[3] + -> Signal dom Bool -- wren, ARG[4] + -> Signal dom Int -- wr, ARG[5] + -> Signal dom a -- din, ARG[6] + -> Signal dom a" + , "outputReg" : true + , "templateD" : +"// blockRam begin +reg ~TYPO ~GENSYM[RAM][0] [0:~LENGTH[~TYP[2]]-1]; + +reg ~TYP[2] ~GENSYM[ram_init][2]; +integer ~GENSYM[i][3]; +initial begin + ~SYM[2] = ~ARG[2]; + for (~SYM[3]=0; ~SYM[3] < ~LENGTH[~TYP[2]]; ~SYM[3] = ~SYM[3] + 1) begin + ~SYM[0][~LENGTH[~TYP[2]]-1-~SYM[3]] = ~SYM[2][~SYM[3]*~SIZE[~TYPO]+:~SIZE[~TYPO]]; + end +end +~IF ~ISGATED[1] ~THEN +always @(posedge ~ARG[1][1]) begin : ~GENSYM[~COMPNAME_blockRam][4]~IF ~VIVADO ~THEN + if (~ARG[1][0]) begin + if (~ARG[4]) begin + ~SYM[0][~ARG[5]] <= ~ARG[6]; + end + ~RESULT <= ~SYM[0][~ARG[3]]; + end~ELSE + if (~ARG[4] & ~ARG[1][0]) begin + ~SYM[0][~ARG[5]] <= ~ARG[6]; + end + if (~ARG[1][0]) begin + ~RESULT <= ~SYM[0][~ARG[3]]; + end~FI +end~ELSE +always @(posedge ~ARG[1]) begin : ~SYM[4] + if (~ARG[4]) begin + ~SYM[0][~ARG[5]] <= ~ARG[6]; + end + ~RESULT <= ~SYM[0][~ARG[3]]; +end~FI +// blockRam end" + } + } +] diff --git a/prims/verilog/Clash_Explicit_BlockRam_File.json b/prims/verilog/Clash_Explicit_BlockRam_File.json new file mode 100644 --- /dev/null +++ b/prims/verilog/Clash_Explicit_BlockRam_File.json @@ -0,0 +1,46 @@ +[ { "BlackBox" : + { "name" : "Clash.Explicit.BlockRam.File.blockRamFile#" + , "type" : +"blockRamFile# + :: (KnownNat m, HasCallStack)-- (ARG[0],ARG[1]) + => Clock dom gated -- clk, ARG[2] + -> SNat n -- sz, ARG[3] + -> FilePath -- file, ARG[4] + -> Signal dom Int -- rd, ARG[5] + -> Signal dom Bool -- wren, ARG[6] + -> Signal dom Int -- wr, ARG[7] + -> Signal dom (BitVector m) -- din, ARG[8] + -> Signal dom (BitVector m)" + , "outputReg" : true + , "templateD" : +"// blockRamFile begin +reg ~TYPO ~GENSYM[RAM][0] [0:~LIT[3]-1]; + +initial begin + $readmemb(~FILE[~LIT[4]],~SYM[0]); +end +~IF ~ISGATED[2] ~THEN +always @(posedge ~ARG[2][1]) begin : ~GENSYM[~COMPNAME_blockRamFile][2]~IF ~VIVADO ~THEN + if (~ARG[2][0]) begin + if (~ARG[6]) begin + ~SYM[0][~ARG[7]] <= ~ARG[8]; + end + ~RESULT <= ~SYM[0][~ARG[5]]; + end~ELSE + if (~ARG[6] & ~ARG[2][0]) begin + ~SYM[0][~ARG[7]] <= ~ARG[8]; + end + if (~ARG[2][0]) begin + ~RESULT <= ~SYM[0][~ARG[5]]; + end~FI +end~ELSE +always @(posedge ~ARG[2]) begin : ~SYM[2] + if (~ARG[6]) begin + ~SYM[0][~ARG[7]] <= ~ARG[8]; + end + ~RESULT <= ~SYM[0][~ARG[5]]; +end~FI +// blockRamFile end" + } + } +] diff --git a/prims/verilog/Clash_Explicit_DDR.json b/prims/verilog/Clash_Explicit_DDR.json new file mode 100644 --- /dev/null +++ b/prims/verilog/Clash_Explicit_DDR.json @@ -0,0 +1,131 @@ +[ { "BlackBox" : + { "name" : "Clash.Explicit.DDR.ddrIn#" + , "type" : +"ddrIn# :: forall a slow fast n pFast gated synchronous. + ( HasCallStack -- ARG[0] + , fast ~ Dom n pFast -- ARG[1] + , slow ~ Dom n (2*pFast)) -- ARG[2] + => Clock slow gated -- ARG[3] + -> Reset slow synchronous -- ARG[4] + -> a -- ARG[5] + -> a -- ARG[6] + -> a -- ARG[7] + -> Signal fast a -- ARG[8] + -> Signal slow (a,a)" + , "templateD" : +"// ddrIn begin +reg ~SIGD[~GENSYM[data_Pos][1]][8]; +reg ~SIGD[~GENSYM[data_Neg][2]][8]; +reg ~SIGD[~GENSYM[data_Neg_Latch][3]][8]; +~IF ~ISGATED[3] ~THEN +always @(posedge ~ARG[3][1]~IF ~ISSYNC[4] ~THEN ~ELSE or posedge ~ARG[4]~FI) begin : ~GENSYM[~COMPNAME_ddrIn_pos][6] + if (~ARG[4]) begin + ~SYM[1] <= ~ARG[6]; + end else if (~ARG[3][0]) begin + ~SYM[1] <= ~ARG[8]; + end +end~ELSE +always @(posedge ~ARG[3]~IF ~ISSYNC[4] ~THEN ~ELSE or posedge ~ARG[4]~FI) begin : ~SYM[6] + if (~ARG[4]) begin + ~SYM[1] <= ~ARG[6]; + end else begin + ~SYM[1] <= ~ARG[8]; + end +end~FI +~IF ~ISGATED[3] ~THEN +always @(negedge ~ARG[3][1]~IF ~ISSYNC[4] ~THEN ~ELSE or posedge ~ARG[4]~FI) begin : ~GENSYM[~COMPNAME_ddrIn_neg][7] + if (~ARG[4]) begin + ~SYM[2] <= ~ARG[7]; + end else if (~ARG[3][0]) begin + ~SYM[2] <= ~ARG[8]; + end +end~ELSE +always @(negedge ~ARG[3]~IF ~ISSYNC[4] ~THEN ~ELSE or posedge ~ARG[4]~FI) begin : ~SYM[7] + if (~ARG[4]) begin + ~SYM[2] <= ~ARG[7]; + end else begin + ~SYM[2] <= ~ARG[8]; + end +end~FI +~IF ~ISGATED[3] ~THEN +always @(posedge ~ARG[3][1]~IF ~ISSYNC[4] ~THEN ~ELSE or posedge ~ARG[4]~FI) begin : ~GENSYM[~COMPNAME_ddrIn_neg_latch][8] + if (~ARG[4]) begin + ~SYM[3] <= ~ARG[5]; + end else if (~ARG[3][0]) begin + ~SYM[3] <= ~SYM[2]; + end +end~ELSE +always @(posedge ~ARG[3]~IF ~ISSYNC[4] ~THEN ~ELSE or posedge ~ARG[4]~FI) begin : ~SYM[8] + if (~ARG[4]) begin + ~SYM[3] <= ~ARG[5]; + end else begin + ~SYM[3] <= ~SYM[2]; + end +end~FI + +assign ~RESULT = {~SYM[3], ~SYM[1]}; +// ddrIn end" + } + } +, { "BlackBox" : + { "name" : "Clash.Explicit.DDR.ddrOut#" + , "type" : +"ddrOut# :: ( HasCallStack -- ARG[0] + , fast ~ Dom n pFast -- ARG[1] + , slow ~ Dom n (2*pFast)) -- ARG[2] + => Clock slow gated -- ARG[3] + -> Reset slow synchronous -- ARG[4] + -> a -- ARG[5] + -> Signal slow a -- ARG[6] + -> Signal slow a -- ARG[7] + -> Signal fast a" + , "templateD" : +"// ddrOut begin +reg ~SIGD[~GENSYM[data_Pos][1]][5]; +reg ~SIGD[~GENSYM[data_Neg][2]][5]; +reg ~SIGD[~GENSYM[data_Out][3]][5]; +~IF ~ISGATED[3] ~THEN +always @(posedge ~ARG[3][1]~IF ~ISSYNC[4] ~THEN ~ELSE or posedge ~ARG[4]~FI) begin : ~GENSYM[~COMPNAME_ddrOut_pos][5] + if (~ARG[4]) begin + ~SYM[1] <= ~ARG[5]; + end else if (~ARG[3][0]) begin + ~SYM[1] <= ~ARG[6]; + end +end~ELSE +always @(posedge ~ARG[3]~IF ~ISSYNC[4] ~THEN ~ELSE or posedge ~ARG[4]~FI) begin : ~SYM[5] + if (~ARG[4]) begin + ~SYM[1] <= ~ARG[5]; + end else begin + ~SYM[1] <= ~ARG[6]; + end +end~FI +~IF ~ISGATED[3] ~THEN +always @(posedge ~ARG[3][1]~IF ~ISSYNC[4] ~THEN ~ELSE or posedge ~ARG[4]~FI) begin : ~GENSYM[~COMPNAME_ddrOut_neg][6] + if (~ARG[4]) begin + ~SYM[2] <= ~ARG[5]; + end else if (~ARG[3][0]) begin + ~SYM[2] <= ~ARG[7]; + end +end~ELSE +always @(posedge ~ARG[3]~IF ~ISSYNC[4] ~THEN ~ELSE or posedge ~ARG[4]~FI) begin : ~SYM[6] + if (~ARG[4]) begin + ~SYM[2] <= ~ARG[5]; + end else begin + ~SYM[2] <= ~ARG[7]; + end +end~FI + +always @(*) begin ~IF ~ISGATED[3] ~THEN + if (~ARG[3][1]) begin~ELSE + if (~ARG[3]) begin~FI + ~SYM[3] = ~SYM[1]; + end else begin + ~SYM[3] = ~SYM[2]; + end +end + +assign ~RESULT = ~SYM[3]; +// ddrOut end" + } + } +] diff --git a/prims/verilog/Clash_Explicit_RAM.json b/prims/verilog/Clash_Explicit_RAM.json new file mode 100644 --- /dev/null +++ b/prims/verilog/Clash_Explicit_RAM.json @@ -0,0 +1,33 @@ +[ { "BlackBox" : + { "name" : "Clash.Explicit.RAM.asyncRam#" + , "type" : +"asyncRam# + :: HasCallStack -- ARG[0] + => Clock wdom wgated -- ^ wclk, ARG[1] + -> Clock rdom rgated -- ^ rclk, ARG[2] + -> SNat n -- ^ sz, ARG[3] + -> Signal rdom Int -- ^ rd, ARG[4] + -> Signal wdom Bool -- ^ en, ARG[5] + -> Signal wdom Int -- ^ wr, ARG[6] + -> Signal wdom a -- ^ din, ARG[7] + -> Signal rdom a" + , "templateD" : +"// asyncRam begin +reg ~TYPO ~GENSYM[RAM][0] [0:~LIT[3]-1]; +~IF ~ISGATED[1] ~THEN +always @(posedge ~ARG[1][1]) begin : ~GENSYM[~COMPNAME_Ram][1] + if (~ARG[5] & ~ARG[1][0]) begin + ~SYM[0][~ARG[6]] <= ~ARG[7]; + end +end~ELSE +always @(posedge ~ARG[1]) begin : ~SYM[1] + if (~ARG[5]) begin + ~SYM[0][~ARG[6]] <= ~ARG[7]; + end +end~FI + +assign ~RESULT = ~SYM[0][~ARG[4]]; +// asyncRam end" + } + } +] diff --git a/prims/verilog/Clash_Explicit_ROM.json b/prims/verilog/Clash_Explicit_ROM.json new file mode 100644 --- /dev/null +++ b/prims/verilog/Clash_Explicit_ROM.json @@ -0,0 +1,34 @@ +[ { "BlackBox" : + { "name" : "Clash.Explicit.ROM.rom#" + , "type" : +"rom# :: KnownNat n -- ARG[0] + => Clock dom gated -- clk, ARG[1] + -> Vec n a -- init, ARG[2] + -> Signal dom Int -- rd, ARG[3] + -> Signal dom a" + , "outputReg" : true + , "templateD" : +"// rom begin +reg ~TYPO ~GENSYM[ROM][0] [0:~LIT[0]-1]; + +reg ~TYP[2] ~GENSYM[rom_init][2]; +integer ~GENSYM[i][3]; +initial begin + ~SYM[2] = ~ARG[2]; + for (~SYM[3]=0; ~SYM[3] < ~LIT[0]; ~SYM[3] = ~SYM[3] + 1) begin + ~SYM[0][~LIT[0]-1-~SYM[3]] = ~SYM[2][~SYM[3]*~SIZE[~TYPO]+:~SIZE[~TYPO]]; + end +end +~IF ~ISGATED[1] ~THEN +always @(posedge ~ARG[1][1]) begin : ~GENSYM[~COMPNAME_rom][4] + if (~ARG[1][0]) begin + ~RESULT <= ~SYM[0][~ARG[3]]; + end +end~ELSE +always @(posedge ~ARG[1]) begin : ~SYM[4] + ~RESULT <= ~SYM[0][~ARG[3]]; +end~FI +// rom end" + } + } +] diff --git a/prims/verilog/Clash_Explicit_ROM_File.json b/prims/verilog/Clash_Explicit_ROM_File.json new file mode 100644 --- /dev/null +++ b/prims/verilog/Clash_Explicit_ROM_File.json @@ -0,0 +1,30 @@ +[ { "BlackBox" : + { "name" : "Clash.Explicit.ROM.File.romFile#" + , "type" : +"romFile# :: KnownNat m -- ARG[0] + => Clock dom gated -- clk, ARG[1] + -> SNat n -- sz, ARG[2] + -> FilePath -- file, ARG[3] + -> Signal dom Int -- rd, ARG[4] + -> Signal dom (BitVector m)" + , "outputReg" : true + , "templateD" : +"// romFile begin +reg ~TYPO ~GENSYM[ROM][0] [0:~LIT[2]-1]; + +initial begin + $readmemb(~FILE[~LIT[3]],~SYM[0]); +end +~IF ~ISGATED[1] ~THEN +always @(posedge ~ARG[1][1]) begin : ~GENSYM[~COMPNAME_romFile][2] + if (~ARG[1][0]) begin + ~RESULT <= ~SYM[0][~ARG[4]]; + end +end~ELSE +always @(posedge ~ARG[1]) begin : ~SYM[2] + ~RESULT <= ~SYM[0][~ARG[4]]; +end~FI +// romFile end" + } + } +] diff --git a/prims/verilog/Clash_Explicit_Testbench.json b/prims/verilog/Clash_Explicit_Testbench.json new file mode 100644 --- /dev/null +++ b/prims/verilog/Clash_Explicit_Testbench.json @@ -0,0 +1,27 @@ +[ { "BlackBox" : + { "name" : "Clash.Explicit.Testbench.assert" + , "type" : +"assert + :: (Eq a,ShowX a) -- (ARG[0],ARG[1]) + => Clock domain gated -- ARG[2] + -> Reset domain synchronous -- ARG[3] + -> String -- ARG[4] + -> Signal domain a -- Checked value (ARG[5]) + -> Signal domain a -- Expected value (ARG[6]) + -> Signal domain b -- Return valued (ARG[7]) + -> Signal domain b" + , "templateD" : +"// assert begin +// pragma translate_off +always @(posedge ~IF ~ISGATED[2] ~THEN ~ARG[2][1] ~ELSE ~ARG[2] ~FI~IF ~ISSYNC[3] ~THEN ~ELSE or negedge ~ARG[3]~FI) begin + if (~ARG[5] !== ~ARG[6]) begin + $display(\"@%0tns: %s, expected: %b, actual: %b\", $time, ~LIT[4], ~ARG[6], ~ARG[5]); + $finish; + end +end +// pragma translate_on +assign ~RESULT = ~ARG[7]; +// assert end" + } + } +] diff --git a/prims/verilog/Clash_Intel_ClockGen.json b/prims/verilog/Clash_Intel_ClockGen.json new file mode 100644 --- /dev/null +++ b/prims/verilog/Clash_Intel_ClockGen.json @@ -0,0 +1,37 @@ +[ { "BlackBox" : + { "name" : "Clash.Intel.ClockGen.altpll" + , "type" : +"altpll + :: SSymbol name -- ARG[0] + -> Clock pllIn 'Source -- ARG[1] + -> Reset pllIn 'Asynchronous -- ARG[2] + -> (Clock pllOut 'Source, Signal pllOut Bool)" + , "templateD" : +"// altpll begin +~NAME[0] ~GENSYM[altpll_inst][2] +(.inclk0 (~ARG[1]) +,.areset (~ARG[2]) +,.c0 (~RESULT[1]) +,.locked (~RESULT[0])); +// altpll end" + } + } +, { "BlackBox" : + { "name" : "Clash.Intel.ClockGen.alteraPll" + , "type" : +"alteraPll + :: SSymbol name -- ARG[0] + -> Clock pllIn 'Source -- ARG[1] + -> Reset pllIn 'Asynchronous -- ARG[2] + -> (Clock pllOut 'Source, Signal pllOut Bool)" + , "templateD" : +"// alteraPll begin +~NAME[0] ~GENSYM[alteraPll_inst][2] +(.refclk (~ARG[1]) +,.rst (~ARG[2]) +,.outclk_0 (~RESULT[1]) +,.locked (~RESULT[0])); +// alteraPll end" + } + } +] diff --git a/prims/verilog/Clash_Intel_DDR.json b/prims/verilog/Clash_Intel_DDR.json new file mode 100644 --- /dev/null +++ b/prims/verilog/Clash_Intel_DDR.json @@ -0,0 +1,89 @@ +[ { "BlackBox" : + { "name" : "Clash.Intel.DDR.altddioIn" + , "type" : +"altddioIn + :: ( HasCallStack -- ARG[0] + , fast ~ Dom n pFast -- ARG[1] + , slow ~ Dom n (2*pFast) -- ARG[2] + , KnownNat m ) -- ARG[3] + => SSymbol deviceFamily -- ARG[4] + -> Clock slow gated -- ARG[5] + -> Reset slow synchronous -- ARG[6] + -> Signal fast (BitVector m) -- ARG[7] + -> Signal slow (BitVector m,BitVector m)" + , "templateD" : +"// altddioIn begin +wire ~SIGD[~GENSYM[dataout_l][1]][7]; +wire ~SIGD[~GENSYM[dataout_h][2]][7]; + +altddio_in ~GENSYM[~COMPNAME_ALTDDIO_IN][7] (~IF ~ISSYNC[6] ~THEN + .sclr (~ARG[6]), + .aclr (1'b0),~ELSE + .aclr (~ARG[6]), + .sclr (1'b0),~FI + .datain (~ARG[7]),~IF ~ISGATED[5] ~THEN + .inclock (~ARG[5][1]), + .inclocken (~ARG[5][0]),~ELSE + .inclock (~ARG[5]), + .inclocken (1'b1),~FI + .dataout_h (~SYM[2]), + .dataout_l (~SYM[1]), + .aset (1'b0), + .sset (1'b0)); +defparam + ~SYM[7].intended_device_family = ~LIT[4], + ~SYM[7].invert_input_clocks = \"OFF\", + ~SYM[7].lpm_hint = \"UNUSED\", + ~SYM[7].lpm_type = \"altddio_in\", + ~SYM[7].power_up_high = \"OFF\", + ~SYM[7].width = ~SIZE[~TYP[7]]; + +assign ~RESULT = {~SYM[1],~SYM[2]}; +// altddioIn end" + } + } +, { "BlackBox" : + { "name" : "Clash.Intel.DDR.altddioOut#" + , "type" : +"altddioOut# + :: ( HasCallStack -- ARG[0] + , fast ~ Dom n pFast -- ARG[1] + , slow ~ Dom n (2*pFast) -- ARG[2] + , KnownNat m ) -- ARG[3] + => SSymbol deviceFamily -- ARG[4] + -> Clock slow gated -- ARG[5] + -> Reset slow synchronous -- ARG[6] + -> Signal slow (BitVector m) -- ARG[7] + -> Signal slow (BitVector m) -- ARG[8] + -> Signal fast (BitVector m)" + , "templateD" : +"// altddioOut begin +altddio_out ~GENSYM[~COMPNAME_ALTDDIO_OUT][7] (~IF ~ISSYNC[6] ~THEN + .sclr (~ARG[6]), + .aclr (1'b0),~ELSE + .aclr (~ARG[6]), + .sclr (1'b0),~FI + .datain_h (~ARG[7]), + .datain_l (~ARG[8]),~IF ~ISGATED[5] ~THEN + .outclock (~ARG[5][1]), + .outclocken (~ARG[5][0]),~ELSE + .outclock (~ARG[5]), + .outclocken (1'b1),~FI + .dataout (~RESULT), + .aset (1'b0), + .sset (1'b0), + .oe (1'b1), + .oe_out ()); +defparam + ~SYM[7].extend_oe_disable = \"OFF\", + ~SYM[7].intended_device_family = ~LIT[4], + ~SYM[7].invert_output = \"OFF\", + ~SYM[7].lpm_hint = \"UNUSED\", + ~SYM[7].lpm_type = \"altddio_out\", + ~SYM[7].oe_reg = \"UNREGISTERED\", + ~SYM[7].power_up_high = \"OFF\", + ~SYM[7].width = ~SIZE[~TYPO]; +// altddioOut end" + } + } +] diff --git a/prims/verilog/Clash_Prelude_ROM.json b/prims/verilog/Clash_Prelude_ROM.json new file mode 100644 --- /dev/null +++ b/prims/verilog/Clash_Prelude_ROM.json @@ -0,0 +1,25 @@ +[ { "BlackBox" : + { "name" : "Clash.Prelude.ROM.asyncRom#" + , "type" : +"asyncRom# :: KnownNat n -- ^ ARG[0] + => Vec n a -- ^ ARG[1] + -> Int -- ^ ARG[2] + -> a" + , "templateD" : +"// asyncRom begin +wire ~TYPO ~GENSYM[ROM][0] [0:~LIT[0]-1]; + +wire ~TYP[1] ~GENSYM[romflat][1]; +assign ~SYM[1] = ~ARG[1]; +genvar ~GENSYM[i][2]; +~GENERATE +for (~SYM[2]=0; ~SYM[2] < ~LIT[0]; ~SYM[2]=~SYM[2]+1) begin : ~GENSYM[mk_array][3] + assign ~SYM[0][(~LIT[0]-1)-~SYM[2]] = ~SYM[1][~SYM[2]*~SIZE[~TYPO]+:~SIZE[~TYPO]]; +end +~ENDGENERATE + +assign ~RESULT = ~SYM[0][~ARG[2]]; +// asyncRom end" + } + } +] diff --git a/prims/verilog/Clash_Prelude_ROM_File.json b/prims/verilog/Clash_Prelude_ROM_File.json new file mode 100644 --- /dev/null +++ b/prims/verilog/Clash_Prelude_ROM_File.json @@ -0,0 +1,21 @@ +[ { "BlackBox" : + { "name" : "Clash.Prelude.ROM.File.asyncRomFile#" + , "type" : +"asyncRomFile :: KnownNat m -- ARG[0] + => SNat n -- sz, ARG[1] + -> FilePath -- file, ARG[2] + -> Int -- rd, ARG[3] + -> BitVector m" + , "templateD" : +"// asyncRomFile begin +reg ~TYPO ~GENSYM[ROM][0] [0:~LIT[1]-1]; + +initial begin + $readmemb(~FILE[~LIT[2]],~SYM[0]); +end + +assign ~RESULT = ~SYM[0][~ARG[3]]; +// asyncRomFile end" + } + } +] diff --git a/prims/verilog/Clash_Signal_Internal.json b/prims/verilog/Clash_Signal_Internal.json new file mode 100644 --- /dev/null +++ b/prims/verilog/Clash_Signal_Internal.json @@ -0,0 +1,212 @@ +[ { "BlackBox" : + { "name" : "Clash.Signal.Internal.delay#" + , "type" : +"delay# + :: HasCallStack -- ARG[0] + => Clock domain gated -- ARG[1] + -> Signal clk a -- ARG[2] + -> Signal clk a" + , "outputReg" : true + , "templateD" : +"// delay begin~IF ~ISGATED[1] ~THEN +always @(posedge ~ARG[1][1]) begin : ~GENSYM[~COMPNAME_delay][1] + if (~ARG[1][0]) begin + ~RESULT <= ~ARG[2]; + end +end~ELSE +always @(posedge ~ARG[1]) begin : ~SYM[1] + ~RESULT <= ~ARG[2]; +end~FI +// delay end" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.register#" + , "type" : +"register# + :: HasCallStack -- ARG[0] + => Clock domain gated -- ARG[1] + -> Reset domain synchronous -- ARG[2] + -> a -- ARG[3] + -> Signal clk a -- ARG[4] + -> Signal clk a" + , "outputReg" : true + , "templateD" : +"// register begin~IF ~ISGATED[1] ~THEN +always @(posedge ~ARG[1][1]~IF ~ISSYNC[2] ~THEN ~ELSE or posedge ~ARG[2]~FI) begin : ~GENSYM[~COMPNAME_register][1] + if (~ARG[2]) begin + ~RESULT <= ~ARG[3]; + end else if (~ARG[1][0]) begin + ~RESULT <= ~ARG[4]; + end +end~ELSE +always @(posedge ~ARG[1]~IF ~ISSYNC[2] ~THEN ~ELSE or posedge ~ARG[2]~FI) begin : ~SYM[1] + if (~ARG[2]) begin + ~RESULT <= ~ARG[3]; + end else begin + ~RESULT <= ~ARG[4]; + end +end~FI +// register end" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.clockGate" + , "type" : +"clockGate + :: Clock domain gated -- ARG[0] + -> Signal domain Bool -- ARG[1] + -> Clcok domain 'Gated" + , "templateD" : +"// clockGate begin ~IF ~ISGATED[0] ~THEN +assign ~RESULT = {~ARG[0][1],~ARG[0][0] & ~ARG[1]};~ELSE +assign ~RESULT = {~ARG[0],~ARG[1]};~FI +// clockGate end" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.clockGen" + , "type" : +"clockGen + :: (domain ~ Dom nm period -- ARG[0] + ,KnownSymbol nm -- ARG[1] + ,KnownNat period) -- ARG[2] + => Clock domain Source" + , "templateD" : +"// pragma translate_off +reg ~TYPO ~GENSYM[clk][0]; +// 1 = 0.1ps +localparam ~GENSYM[half_period][1] = (~LIT[2]0 / 2); +always begin + ~SYM[0] = 0; + #3000 forever begin + ~SYM[0] = ~ ~SYM[0]; + #~SYM[1]; + ~SYM[0] = ~ ~SYM[0]; + #~SYM[1]; + end +end +assign ~RESULT = ~SYM[0]; +// pragma translate_on" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.tbClockGen" + , "type" : +"tbClockGen + :: (domain ~ Dom nm period -- ARG[0] + ,KnownSymbol nm -- ARG[1] + ,KnownNat period) -- ARG[2] + => Signal domain Bool -- ARG[3] + -> Clock domain Source" + , "templateD" : +"// pragma translate_off +reg ~TYPO ~GENSYM[clk][0]; +// 1 = 0.1ps +localparam ~GENSYM[half_period][1] = (~LIT[2]0 / 2); +always begin + ~SYM[0] = 0; + #3000 forever begin + if (~ ~ARG[3]) begin + $finish; + end + ~SYM[0] = ~ ~SYM[0]; + #~SYM[1]; + ~SYM[0] = ~ ~SYM[0]; + #~SYM[1]; + end +end +assign ~RESULT = ~SYM[0]; +// pragma translate_on" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.asyncResetGen" + , "type" : +"asyncResetGen :: Reset domain 'Asynchronous" + , "templateD" : +"// pragma translate_off +reg ~TYPO ~GENSYM[rst][0]; +initial begin + #1 ~SYM[0] = 1; + #1999 ~SYM[0] = 0; +end +assign ~RESULT = ~SYM[0]; +// pragma translate_on" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.syncResetGen" + , "type" : +"asyncResetGen :: Reset domain 'Synchronous" + , "templateD" : +"// pragma translate_off +reg ~TYPO ~GENSYM[rst][0]; +localparam ~GENSYM[reset_period][1] = 2998 + ~LIT[1]0; +initial begin + #1 ~SYM[0] = 1; + #~SYM[1] ~SYM[0] = 0; +end +assign ~RESULT = ~SYM[0]; +// pragma translate_on" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.unsafeFromAsyncReset" + , "type" : +"unsafeFromAsyncReset :: Reset domain Asynchronous -> Signal domain Bool" + , "templateE" : "~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.unsafeToAsyncReset" + , "type" : +"unsafeToAsyncReset :: Signal domain Bool -> Reset domain Asynchronous" + , "templateE" : "~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.fromSyncReset" + , "type" : +"fromSyncReset :: Reset domain Synchronous -> Signal domain Bool" + , "templateE" : "~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.unsafeToSyncReset" + , "type" : +"unsafeToSyncReset :: Signal domain Bool -> Reset domain Synchronous" + , "templateE" : "~ARG[0]" + } + } +, { "Primitive" : + { "name" : "Clash.Signal.Internal.signal#" + , "primType" : "Function" + } + } +, { "Primitive" : + { "name" : "Clash.Signal.Internal.mapSignal#" + , "primType" : "Function" + } + } +, { "Primitive" : + { "name" : "Clash.Signal.Internal.appSignal#" + , "primType" : "Function" + } + } +, { "Primitive" : + { "name" : "Clash.Signal.Internal.foldr#" + , "primType" : "Function" + } + } +, { "Primitive" : + { "name" : "Clash.Signal.Internal.traverse#" + , "primType" : "Function" + } + } +, { "Primitive" : + { "name" : "Clash.Signal.Internal.joinSignal#" + , "primType" : "Function" + } + } +] diff --git a/prims/verilog/Clash_Sized_Internal_BitVector.json b/prims/verilog/Clash_Sized_Internal_BitVector.json new file mode 100644 --- /dev/null +++ b/prims/verilog/Clash_Sized_Internal_BitVector.json @@ -0,0 +1,237 @@ +[ { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.size#" + , "type" : "size# :: KnownNat n => BitVector n -> Int" + , "templateE" : "~SIZE[~TYPO]'sd~LIT[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.maxIndex#" + , "type" : "maxIndex# :: KnownNat n => BitVector n -> Int" + , "templateE" : "~SIZE[~TYPO]'sd~LIT[0] - ~SIZE[~TYPO]'sd1" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.++#" + , "type" : "(++#) :: KnownNat m => BitVector n -> BitVector m -> BitVector (n + m)" + , "templateE" : "{~ARG[1],~ARG[2]}" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.index#" + , "type" : +"index# :: KnownNat n -- ARG[0] + => BitVector n -- ARG[1] + -> Int -- ARG[2] + -> Bit" + , "templateE" : "~VAR[bv][1][~ARG[2]]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.replaceBit#" + , "type" : +"replaceBit# :: KnownNat n -- ARG[0] + => BitVector n -- ARG[1] + -> Int -- ARG[2] + -> Bit -- ARG[3] + -> BitVector n" + , "outputReg" : true + , "templateD" : +"// replaceBit start +always @(*) begin + ~RESULT = ~ARG[1]; + ~RESULT[~ARG[2]] = ~VAR[din][3]; +end +// replaceBit end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.setSlice#" + , "type" : +"setSlice# :: BitVector (m + 1 + i) -- ARG[0] + -> SNat m -- ARG[1] + -> SNat n -- ARG[2] + -> BitVector (m + 1 - n) -- ARG[3] + -> BitVector (m + 1 + i)" + , "outputReg" : true + , "templateD" : +"// setSlice begin +always @(*) begin + ~RESULT = ~ARG[0]; + ~RESULT[~LIT[1] : ~LIT[2]] = ~VAR[din][3]; +end +// setSlice end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.slice#" + , "type" : +"slice# :: BitVector (m + 1 + i) -- ARG[0] + -> SNat m -- ARG[1] + -> SNat n -- ARG[2] + -> BitVector (m + 1 - n)" + , "templateE" : "~VAR[bv][0][~LIT[1] : ~LIT[2]]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.split#" + , "type" : +"split# :: KnownNat n -- ARG[0] + => BitVector (m + n) -- ARG[1] + -> (BitVector m, BitVector n)" + , "templateE" : "~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.msb#" + , "type" : +"msb# :: KnownNat n -- ARG[0] + => BitVector n -- ARG[1] + -> Bit" + , "templateE" : "~IF ~LIT[0] ~THEN ~VAR[bv][1][~LIT[0]-1] ~ELSE 1'b0 ~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.lsb#" + , "type" : +"lsb# :: BitVector n -- ARG[0] + -> Bit" + , "templateE" : "~IF ~SIZE[~TYP[0]] ~THEN ~VAR[bv][0][0] ~ELSE 1'b0 ~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.minBound#" + , "type" : "minBound# :: BitVector n" + , "templateE" : "~SIZE[~TYPO]'d0" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.maxBound#" + , "type" : "maxBound# :: KnownNat n => BitVector n" + , "templateE" : "{~LIT[0] {1'b1}}" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.+#" + , "type" : "(+#) :: KnownNat n => BitVector n -> BitVector n -> BitVector n" + , "templateE" : "~ARG[1] + ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.-#" + , "type" : "(-#) :: KnownNat n => BitVector n -> BitVector n -> BitVector n" + , "templateE" : "~ARG[1] - ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.*#" + , "type" : "(*#) :: KnownNat n => BitVector n -> BitVector n -> BitVector n" + , "templateE" : "~ARG[1] * ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.negate#" + , "type" : "negate# :: KnownNat n => BitVector n -> BitVector n" + , "templateE" : "-~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.fromInteger#" + , "type" : "fromInteger# :: KnownNat n => Integer -> BitVector n" + , "templateE" : "$unsigned(~ARG[1][(~LIT[0]-1):0])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.plus#" + , "type" : "plus# :: BitVector m -> BitVector n -> BitVector (Max m n + 1)" + , "templateD" : "assign ~RESULT = ~ARG[0] + ~ARG[1];" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.minus#" + , "type" : "minus# :: (KnownNat m, KnownNat n) => BitVector m -> BitVector n -> BitVector (Max m n + 1)" + , "templateD" : "assign ~RESULT = ~ARG[2] - ~ARG[3];" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.times#" + , "type" : "times# :: KnownNat (m + n) => BitVector m -> BitVector n -> BitVector (m + n)" + , "templateD" : "assign ~RESULT = ~ARG[0] * ~ARG[1];" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.quot#" + , "type" : "quot# :: BitVector n -> BitVector n -> BitVector n" + , "templateE" : "~ARG[0] / ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.rem#" + , "type" : "rem# :: BitVector n -> BitVector n -> BitVector n" + , "templateE" : "~ARG[0] % ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.and#" + , "type" : "and# :: BitVector n -> BitVector n -> BitVector n" + , "templateE" : "~ARG[0] & ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.or#" + , "type" : "or# :: BitVector n -> BitVector n -> BitVector n" + , "templateE" : "~ARG[0] | ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.xor#" + , "type" : "xor# :: BitVector n -> BitVector n -> BitVector n" + , "templateE" : "~ARG[0] ^ ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.complement#" + , "type" : "complement# :: KnownNat n => BitVector n -> BitVector n" + , "templateE" : "~ ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.shiftL#" + , "type" : "shiftL# :: KnownNat n => BitVector n -> Int -> BitVector n" + , "templateE" : "~ARG[1] << ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.shiftR#" + , "type" : "shiftR# :: KnownNat n => BitVector n -> Int -> BitVector n" + , "templateE" : "~ARG[1] >> ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.rotateL#" + , "type" : "rotateL# :: KnownNat n => BitVector n -> Int -> BitVector n" + , "templateD" : +"// rotateL begin +wire [2*~LIT[0]-1:0] ~SYM[0]; +assign ~SYM[0] = {~ARG[1],~ARG[1]} << ~ARG[2]; +assign ~RESULT = ~SYM[0][2*~LIT[0]-1 : ~LIT[0]]; +// rotateL end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.rotateR#" + , "type" : "rotateR# :: KnownNat n => BitVector n -> Int -> BitVector n" + , "templateD" : +"// rotateR begin +wire [2*~LIT[0]-1:0] ~GENSYM[bv][0]; +assign ~SYM[0] = {~ARG[1],~ARG[1]} >> ~ARG[2]; +assign ~RESULT = ~SYM[0][~LIT[0]-1 : 0]; +// rotateR end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.resize#" + , "type" : "resize# :: KnownNat m => BitVector n -> BitVector m" + , "templateD" : "assign ~RESULT = $unsigned(~ARG[1]);" + } + } +] diff --git a/prims/verilog/Clash_Sized_Internal_Signed.json b/prims/verilog/Clash_Sized_Internal_Signed.json new file mode 100644 --- /dev/null +++ b/prims/verilog/Clash_Sized_Internal_Signed.json @@ -0,0 +1,211 @@ +[ { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.size#" + , "type" : "size# :: KnownNat n => Signed n -> Int" + , "templateE" : "~SIZE[~TYPO]'sd~LIT[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.pack#" + , "type" : "pack# :: KnownNat n => Signed n -> BitVector n" + , "templateE" : "$unsigned(~ARG[1])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.unpack#" + , "type" : "unpack# :: KnownNat n => BitVector n -> Signed n" + , "templateE" : "$signed(~ARG[1])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.minBound#" + , "type" : "minBound# :: KnownNat n => Signed n" + , "comment" : "Generates incorrect SV for n=0" + , "templateE" : "$signed({1'b1, {(~LIT[0]-1) {1'b0}}})" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.maxBound#" + , "type" : "maxBound# :: KnownNat n => Signed n" + , "comment" : "Generates incorrect SV for n=0" + , "templateE" : "$signed({1'b0, {(~LIT[0]-1) {1'b1}}})" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.+#" + , "type" : "(+#) :: KnownNat n => Signed n -> Signed n -> Signed n" + , "templateE" : "~ARG[1] + ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.-#" + , "type" : "(-#) :: KnownNat n => Signed n -> Signed n -> Signed n" + , "templateE" : "~ARG[1] - ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.*#" + , "type" : "(*#) :: KnownNat n => Signed n -> Signed n -> Signed n" + , "templateE" : "~ARG[1] * ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.negate#" + , "type" : "negate# :: KnownNat n => Signed n -> Signed n" + , "templateE" : "-~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.abs#" + , "type" : "abs# :: KnownNat n => Signed n -> Signed n" + , "templateE" : "(~ARG[1] < ~LIT[0]'sd0) ? -~ARG[1] : ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.fromInteger#" + , "type" : "fromInteger# :: KnownNat n => Integer -> Signed (n :: Nat)" + , "templateE" : "$signed(~ARG[1][(~LIT[0]-1):0])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.plus#" + , "type" : "plus# :: Signed m -> Signed n -> Signed (1 + Max m n)" + , "templateD" : "assign ~RESULT = ~ARG[0] + ~ARG[1];" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.minus#" + , "type" : "minus# :: Signed m -> Signed n -> Signed (1 + Max m n)" + , "templateD" : "assign ~RESULT = ~ARG[0] - ~ARG[1];" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.times#" + , "type" : "times# :: Signed m -> Signed n -> Signed (m + n)" + , "templateD" : "assign ~RESULT = ~ARG[0] * ~ARG[1];" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.quot#" + , "type" : "quot# :: Signed n -> Signed n -> Signed n" + , "templateE" : "~ARG[0] / ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.rem#" + , "type" : "rem# :: Signed n -> Signed n -> Signed n" + , "templateE" : "~ARG[0] % ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.div#" + , "type" : "div# :: Signed n -> Signed n -> Signed n" + , "templateD" : +"// divSigned begin +// divide (rounds towards zero) +wire ~SIGD[~GENSYM[quot_res][0]][1]; +assign ~SYM[0] = ~VAR[dividend][1] / ~VAR[divider][2]; + +// round toward minus infinity +assign ~RESULT = (~VAR[dividend][1][~LIT[0]-1] == ~VAR[divider][2][~LIT[0]-1]) ? ~SYM[0] : ~SYM[0] - ~LIT[0]'sd1; +// divSigned end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.mod#" + , "type" : "mod# :: Signed n -> Signed n -> Signed n" + , "templateD" : +"// modSigned begin +// remainder +~SIGD[~GENSYM[rem_res][0]][0]; +assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1]; + +// modulo +assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? + ~SYM[0] : + (~VAR[dividend][0] == ~SIZE[~TYPO]'sd0 ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]); +// modSigned end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.and#" + , "type" : "and# :: KnownNat n => Signed n -> Signed n -> Signed n" + , "templateE" : "~ARG[1] & ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.or#" + , "type" : "or# :: KnownNat n => Signed n -> Signed n -> Signed n" + , "templateE" : "~ARG[1] | ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.xor#" + , "type" : "xor# :: KnownNat n => Signed n -> Signed n -> Signed n" + , "templateE" : "~ARG[1] ^ ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.complement#" + , "type" : "complement# :: KnownNat n => Signed n -> Signed n" + , "templateE" : "~ ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.shiftL#" + , "type" : "shiftL# :: KnownNat n => Signed n -> Int -> Signed n" + , "templateE" : "~ARG[1] <<< ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.shiftR#" + , "type" : "shiftR# :: KnownNat n => Signed n -> Int -> Signed n" + , "templateE" : "~ARG[1] >>> ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.rotateL#" + , "type" : "rotateL# :: KnownNat n => Signed n -> Int -> Signed n" + , "templateD" : +"// rotateL begin +wire [2*~LIT[0]-1:0] ~SYM[0]; +assign ~SYM[0] = {~ARG[1],~ARG[1]} << ~ARG[2]; +assign ~RESULT = $signed(~SYM[0][~LIT[0]-1 : 0]); +// rotateL end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.rotateR#" + , "type" : "rotateR# :: KnownNat n => Signed n -> Int -> Signed n" + , "templateD" : +"// rotateR begin +wire [2*~LIT[0]-1:0] ~GENSYM[s][0]; +assign ~SYM[0] = {~ARG[1],~ARG[1]} >> ~ARG[2]; +assign ~RESULT = $signed(~SYM[0][~LIT[0]-1 : 0]); +// rotateR end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.resize#" + , "type" : "resize# :: (KnownNat n, KnownNat m) => Signed n -> Signed m" + , "comment" : "Back-end should only use this code when the result is smaller than the argument" + , "templateD" : +"// resize begin +~GENERATE + if (~LIT[1] < ~LIT[0]) begin + // truncate, sign preserving + assign ~RESULT = $signed({~VAR[s][2][~LIT[0]-1],~VAR[s][2][(~LIT[1]-2):0]}); + end else begin + // sign-extend + assign ~RESULT = $signed(~VAR[s][2]); + end +~ENDGENERATE +// resize end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.truncateB#" + , "type" : "truncateB# :: KnownNat m => Signed (n + m) -> Signed m" + , "templateD" : "assign ~RESULT = $signed(~ARG[1]);" + } + } +] diff --git a/prims/verilog/Clash_Sized_Internal_Unsigned.json b/prims/verilog/Clash_Sized_Internal_Unsigned.json new file mode 100644 --- /dev/null +++ b/prims/verilog/Clash_Sized_Internal_Unsigned.json @@ -0,0 +1,155 @@ +[ { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.size#" + , "type" : "size# :: KnownNat n => Unsigned n -> Int" + , "templateE" : "~SIZE[~TYPO]'sd~LIT[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.pack#" + , "type" : "pack# :: Unsigned n -> BitVector n" + , "templateE" : "~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.unpack#" + , "type" : "unpack# :: BitVector n -> Unsigned n" + , "templateE" : "~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.minBound#" + , "type" : "minBound# :: Unsigned n" + , "templateE" : "~SIZE[~TYPO]'d0" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.maxBound#" + , "type" : "maxBound# :: KnownNat n => Unsigned n" + , "templateE" : "{~LIT[0] {1'b1}}" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.+#" + , "type" : "(+#) :: KnownNat n => Unsigned n -> Unsigned n -> Unsigned n" + , "templateE" : "~ARG[1] + ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.-#" + , "type" : "(-#) :: KnownNat n => Unsigned n -> Unsigned n -> Unsigned n" + , "templateE" : "~ARG[1] - ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.*#" + , "type" : "(*#) :: KnownNat n => Unsigned n -> Unsigned n -> Unsigned n" + , "templateE" : "~ARG[1] * ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.negate#" + , "type" : "negate# :: KnownNat n => Unsigned n -> Unsigned n" + , "templateE" : "- ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.fromInteger#" + , "type" : "fromInteger# :: KnownNat n => Integer -> Unsigned n" + , "templateE" : "$unsigned(~ARG[1][(~LIT[0]-1):0])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.plus#" + , "type" : "plus# :: Unsigned m -> Unsigned n -> Unsigned (1 + Max m n)" + , "templateD" : "assign ~RESULT = ~ARG[0] + ~ARG[1];" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.minus#" + , "type" : "minus# :: (KnownNat m, KnownNat n) => Unsigned m -> Unsigned n -> Unsigned (1 + Max m n)" + , "templateD" : "assign ~RESULT = ~ARG[2] - ~ARG[3];" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.times#" + , "type" : "times# :: Unsigned m -> Unsigned n -> Unsigned (m + n)" + , "templateD" : "assign ~RESULT = ~ARG[0] * ~ARG[1];" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.quot#" + , "type" : "quot# :: Unsigned n -> Unsigned n -> Unsigned n" + , "templateE" : "~ARG[0] / ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.rem#" + , "type" : "rem# :: Unsigned n -> Unsigned n -> Unsigned n" + , "templateE" : "~ARG[0] % ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.and#" + , "type" : "and# :: Unsigned n -> Unsigned n -> Unsigned n" + , "templateE" : "~ARG[0] & ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.or#" + , "type" : "or# :: Unsigned n -> Unsigned n -> Unsigned n" + , "templateE" : "~ARG[0] | ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.xor#" + , "type" : "xor# :: Unsigned n -> Unsigned n -> Unsigned n" + , "templateE" : "~ARG[0] ^ ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.complement#" + , "type" : "complement# :: KnownNat n => Unsigned n -> Unsigned n" + , "templateE" : "~ ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.shiftL#" + , "type" : "shiftL# :: KnownNat n => Unsigned n -> Int -> Unsigned n" + , "templateE" : "~ARG[1] << ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.shiftR#" + , "type" : "shiftR# :: KnownNat n => Unsigned n -> Int -> Unsigned n" + , "templateE" : "~ARG[1] >> ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.rotateL#" + , "type" : "rotateL# :: KnownNat n => Unsigned n -> Int -> Unsigned n" + , "templateD" : +"// rotateL begin +wire [2*~LIT[0]-1:0] ~GENSYM[u][0]; +assign ~SYM[0] = {~ARG[1],~ARG[1]} << ~ARG[2]; +assign ~RESULT = ~SYM[0][~LIT[0]-1 : 0]; +// rotateL end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.rotateR#" + , "type" : "rotateR# :: KnownNat n => Unsigned n -> Int -> Unsigned n" + , "templateD" : +"// rotateR begin +wire [2*~LIT[0]-1:0] ~GENSYM[u][0]; +assign ~SYM[0] = {~ARG[1],~ARG[1]} >> ~ARG[2]; +assign ~RESULT = ~SYM[0][~LIT[0]-1 : 0]; +// rotateR end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.resize#" + , "type" : "resize# :: KnownNat m => Unsigned n -> Unsigned m" + , "templateD" : "assign ~RESULT = $unsigned(~ARG[1]);" + } + } +] diff --git a/prims/verilog/Clash_Sized_RTree.json b/prims/verilog/Clash_Sized_RTree.json new file mode 100644 --- /dev/null +++ b/prims/verilog/Clash_Sized_RTree.json @@ -0,0 +1,19 @@ +[ { "BlackBox" : + { "name" : "Clash.Sized.RTree.treplicate" + , "type" : "replicate :: SNat d -> a -> RTree d a" + , "templateE" : "'{(2**~LIT[0]) {~ARG[1]}}" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.RTree.textract" + , "type" : "textract :: RTree 0 a -> a" + , "templateE" : "~VAR[tree][0][~SIZE[~TYP[0]]-1 -: ~SIZE[~TYPO]]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.RTree.tsplit" + , "type" : "tsplit:: RTree (d+1) a -> (RTree d a,RTree d a)" + , "templateE" : "~ARG[0]" + } + } +] diff --git a/prims/verilog/Clash_Sized_Vector.json b/prims/verilog/Clash_Sized_Vector.json new file mode 100644 --- /dev/null +++ b/prims/verilog/Clash_Sized_Vector.json @@ -0,0 +1,432 @@ +[ { "BlackBox" : + { "name" : "Clash.Sized.Vector.head" + , "type" : "head :: Vec (n + 1) a -> a" + , "templateE" : "~VAR[vec][0][~SIZE[~TYP[0]]-1 -: ~SIZE[~TYPO]]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.tail" + , "type" : "tail :: Vec (n + 1) a -> Vec n a" + , "templateE" : "~VAR[vec][0][~SIZE[~TYPO]-1 : 0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.last" + , "type" : "Vec (n + 1) a -> a" + , "templateE" : "~VAR[vec][0][~SIZE[~TYPO]-1:0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.init" + , "type" : "Vec (n + 1) a -> Vec n a" + , "templateE" : "~VAR[vec][0][~SIZE[~TYP[0]]-1 : ~SIZE[~TYPEL[~TYP[0]]]]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.select" + , "type" : +"select :: (CmpNat (i + s) (s * n) ~ GT) -- ARG[0] + => SNat f -- ARG[1] + -> SNat s -- ARG[2] + -> SNat n -- ARG[3] + -> Vec i a -- ARG[4] + -> Vec n a" + , "templateD" : +"// select begin +wire ~TYPEL[~TYPO] ~SYM[1] [0:~LENGTH[~TYP[4]]-1]; +genvar ~GENSYM[i][2]; +~GENERATE +for (~SYM[2]=0; ~SYM[2] < ~LENGTH[~TYP[4]]; ~SYM[2]=~SYM[2]+1) begin : ~GENSYM[mk_array][3] + assign ~SYM[1][(~LENGTH[~TYP[4]]-1)-~SYM[2]] = ~VAR[vec][4][~SYM[2]*~SIZE[~TYPEL[~TYPO]]+:~SIZE[~TYPEL[~TYPO]]]; +end +~ENDGENERATE + +genvar ~GENSYM[i][4]; +~GENERATE +for (~SYM[4]=0; ~SYM[4] < ~LIT[3]; ~SYM[4] = ~SYM[4] + 1) begin : ~GENSYM[select][5] + assign ~RESULT[(~LIT[3]-1-~SYM[4])*~SIZE[~TYPEL[~TYPO]]+:~SIZE[~TYPEL[~TYPO]]] = ~SYM[1][~LIT[1] + (~LIT[2] * ~SYM[4])]; +end +~ENDGENERATE +// select end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.++" + , "type" : "(++) :: Vec n a -> Vec m a -> Vec (n + m) a" + , "templateE" : "{~ARG[0],~ARG[1]}" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.concat" + , "type" : "concat :: Vec n (Vec m a) -> Vec (n * m) a" + , "templateE" : "~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.splitAt" + , "type" : "splitAt :: SNat m -> Vec (m + n) a -> (Vec m a, Vec n a)" + , "templateE" : "~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.unconcat" + , "type" : + "unconcat :: KnownNat n -- ARG[0] + => SNat m -- ARG[1] + -> Vec (n * m) a -- ARG[2] + -> Vec n (Vec m a)" + , "templateE" : "~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.map" + , "type" : "map :: (a -> b) -> Vec n a -> Vec n b" + , "templateD" : +"// map begin +genvar ~GENSYM[i][1]; +~GENERATE +for (~SYM[1]=0; ~SYM[1] < ~LENGTH[~TYPO]; ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[map][2]~IF~SIZE[~TYP[1]]~THEN + wire ~TYPEL[~TYP[1]] ~GENSYM[map_in][3]; + assign ~SYM[3] = ~VAR[vec][1][~SYM[1]*~SIZE[~TYPEL[~TYP[1]]]+:~SIZE[~TYPEL[~TYP[1]]]];~ELSE ~FI + ~OUTPUTWIREREG[0] ~TYPEL[~TYPO] ~GENSYM[map_out][4]; + ~INST 0 + ~OUTPUT <= ~SYM[4]~ ~TYPEL[~TYPO]~ + ~INPUT <= ~SYM[3]~ ~TYPEL[~TYP[1]]~ + ~INST + assign ~RESULT[~SYM[1]*~SIZE[~TYPEL[~TYPO]]+:~SIZE[~TYPEL[~TYPO]]] = ~SYM[4]; +end +~ENDGENERATE +// map end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.imap" + , "type" : "imap :: KnownNat n => (Index n -> a -> b) -> Vec n a -> Vec n b" + , "templateD" : +"// imap begin +genvar ~GENSYM[i][1]; +~GENERATE +for (~SYM[1]=0; ~SYM[1] < ~LENGTH[~TYPO]; ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[imap][2] + wire [~SIZE[~INDEXTYPE[~LIT[0]]]-1:0] ~GENSYM[map_index][3];~IF~SIZE[~TYP[2]]~THEN + wire ~TYPEL[~TYP[2]] ~GENSYM[map_in][4]; + assign ~SYM[4] = ~VAR[vec][2][~SYM[1]*~SIZE[~TYPEL[~TYP[2]]]+:~SIZE[~TYPEL[~TYP[2]]]];~ELSE ~FI + ~OUTPUTWIREREG[1] ~TYPEL[~TYPO] ~GENSYM[map_out][5]; + + assign ~SYM[3] = ~LENGTH[~TYPO] - 1 - ~SYM[1]; + ~INST 1 + ~OUTPUT <= ~SYM[5]~ ~TYPEL[~TYPO]~ + ~INPUT <= ~SYM[3]~ ~INDEXTYPE[~LIT[0]]~ + ~INPUT <= ~SYM[4]~ ~TYPEL[~TYP[2]]~ + ~INST + assign ~RESULT[~SYM[1]*~SIZE[~TYPEL[~TYPO]]+:~SIZE[~TYPEL[~TYPO]]] = ~SYM[5]; +end +~ENDGENERATE +// imap end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.imap_go" + , "type" : "imap :: Index n -> (Index n -> a -> b) -> Vec m a -> Vec m b" + , "templateD" : +"// imap begin +genvar ~GENSYM[i][1]; +~GENERATE +for (~SYM[1]=0; ~SYM[1] < ~LENGTH[~TYPO]; ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[imap][2] + wire ~TYP[0] ~GENSYM[map_index][3];~IF~SIZE[~TYP[2]]~THEN + wire ~TYPEL[~TYP[2]] ~GENSYM[map_in][4]; + assign ~SYM[4] = ~VAR[vec][2][~SYM[1]*~SIZE[~TYPEL[~TYP[2]]]+:~SIZE[~TYPEL[~TYP[2]]]];~ELSE ~FI + ~OUTPUTWIREREG[1] ~TYPEL[~TYPO] ~GENSYM[map_out][5]; + + assign ~SYM[3] = ~LENGTH[~TYPO] - 1 - ~SYM[1] + ~ARG[0]; + ~INST 1 + ~OUTPUT <= ~SYM[5]~ ~TYPEL[~TYPO]~ + ~INPUT <= ~SYM[3]~ ~TYP[0]~ + ~INPUT <= ~SYM[4]~ ~TYPEL[~TYP[2]]~ + ~INST + assign ~RESULT[~SYM[1]*~SIZE[~TYPEL[~TYPO]]+:~SIZE[~TYPEL[~TYPO]]] = ~SYM[5]; +end +~ENDGENERATE +// imap end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.zipWith" + , "type" : "zipWith :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c" + , "templateD" : +"// zipWith start +genvar ~GENSYM[i][2]; +~GENERATE +for (~SYM[2] = 0; ~SYM[2] < ~LENGTH[~TYPO]; ~SYM[2] = ~SYM[2] + 1) begin : ~GENSYM[zipWith][6]~IF~SIZE[~TYP[1]]~THEN + wire ~TYPEL[~TYP[1]] ~GENSYM[zipWith_in1][3]; + assign ~SYM[3] = ~VAR[vec1][1][~SYM[2]*~SIZE[~TYPEL[~TYP[1]]]+:~SIZE[~TYPEL[~TYP[1]]]];~ELSE ~FI~IF~SIZE[~TYP[2]]~THEN + wire ~TYPEL[~TYP[2]] ~GENSYM[zipWith_in2][4]; + assign ~SYM[4] = ~VAR[vec2][2][~SYM[2]*~SIZE[~TYPEL[~TYP[2]]]+:~SIZE[~TYPEL[~TYP[2]]]];~ELSE ~FI + ~OUTPUTWIREREG[0] ~TYPEL[~TYPO] ~SYM[5]; + ~INST 0 + ~OUTPUT <= ~SYM[5]~ ~TYPEL[~TYPO]~ + ~INPUT <= ~SYM[3]~ ~TYPEL[~TYP[1]]~ + ~INPUT <= ~SYM[4]~ ~TYPEL[~TYP[2]]~ + ~INST + assign ~RESULT[~SYM[2]*~SIZE[~TYPEL[~TYPO]]+:~SIZE[~TYPEL[~TYPO]]] = ~SYM[5]; +end +~ENDGENERATE +// zipWith end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.foldr" + , "type" : "foldr :: (a -> b -> b) -> b -> Vec n a -> b" + , "templateD" : +"// foldr start~IF ~LENGTH[~TYP[2]] ~THEN +wire ~TYPO ~GENSYM[intermediate][0] [0:~LENGTH[~TYP[2]]]; +assign ~SYM[0][~LENGTH[~TYP[2]]] = ~ARG[1]; + +genvar ~GENSYM[i][3]; +~GENERATE +for (~SYM[3]=0; ~SYM[3] < ~LENGTH[~TYP[2]]; ~SYM[3]=~SYM[3]+1) begin : ~GENSYM[foldr][4]~IF~SIZE[~TYP[2]]~THEN + wire ~TYPEL[~TYP[2]] ~GENSYM[foldr_in1][5]; + assign ~SYM[5] = ~VAR[xs][2][(~LENGTH[~TYP[2]]-1-~SYM[3])*~SIZE[~TYPEL[~TYP[2]]]+:~SIZE[~TYPEL[~TYP[2]]]];~ELSE ~FI + wire ~TYPO ~GENSYM[foldr_in2][6]; + ~OUTPUTWIREREG[0] ~TYPO ~GENSYM[foldr_out][7]; + + assign ~SYM[6] = ~SYM[0][~SYM[3]+1]; + ~INST 0 + ~OUTPUT <= ~SYM[7]~ ~TYP[1]~ + ~INPUT <= ~SYM[5]~ ~TYPEL[~TYP[2]]~ + ~INPUT <= ~SYM[6]~ ~TYP[1]~ + ~INST + assign ~SYM[0][~SYM[3]] = ~SYM[7]; +end +~ENDGENERATE + +assign ~RESULT = ~SYM[0][0]; +~ELSE +assign ~RESULT = ~ARG[1]; +~FI// foldr end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.fold" + , "type" : "fold :: (a -> a -> a) -> Vec (n+1) a -> a" + , "comment" : "THIS ONLY WORKS FOR POWER OF TWO LENGTH VECTORS" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "fold" + , "extension" : "inc" + , "content" : +"// ceiling of log2 +function integer ~INCLUDENAME_clog2; + input integer value; + begin + value = value-1; + for (~INCLUDENAME_clog2=0; value>0; ~INCLUDENAME_clog2=~INCLUDENAME_clog2+1) + value = value>>1; + end +endfunction + +// given a level and a depth, calculate the corresponding index into the +// intermediate array +function integer ~INCLUDENAME_depth2Index; + input integer levels; + input integer depth; + + ~INCLUDENAME_depth2Index = (2 ** levels) - (2 ** depth); +endfunction" + } + , "templateD" : +"// fold begin +// put flat input array into the first half of the intermediate array +wire ~TYPO ~GENSYM[intermediate][0] [0:(2*~LENGTH[~TYP[1]])-2]; + +genvar ~GENSYM[i][2]; +~GENERATE +for (~SYM[2]=0; ~SYM[2] < ~LENGTH[~TYP[1]]; ~SYM[2]=~SYM[2]+1) begin : ~GENSYM[mk_array][3] + assign ~SYM[0][(~LENGTH[~TYP[1]]-1)-~SYM[2]] = ~VAR[vecflat][1][~SYM[2]*~SIZE[~TYPO]+:~SIZE[~TYPO]]; +end +~ENDGENERATE + +// calculate the depth of the tree +localparam ~GENSYM[levels][4] = ~INCLUDENAME_clog2(~LENGTH[~TYP[1]]); + +// Create the tree of instantiated components +genvar ~GENSYM[d][5]; +genvar ~GENSYM[i][6]; +~GENERATE +if (~SYM[4] != 0) begin : ~GENSYM[make_tree][7] + for (~SYM[5] = (~SYM[4] - 1); ~SYM[5] >= 0; ~SYM[5]=~SYM[5]-1) begin : ~GENSYM[tree_depth][11] + for (~SYM[6] = 0; ~SYM[6] < (2**~SYM[5]); ~SYM[6] = ~SYM[6]+1) begin : ~GENSYM[tree_depth_loop][12] + wire ~TYPO ~GENSYM[fold_in1][8]; + wire ~TYPO ~GENSYM[fold_in2][9]; + ~OUTPUTWIREREG[0] ~TYPO ~GENSYM[fold_out][10]; + + assign ~SYM[8] = ~SYM[0][~INCLUDENAME_depth2Index(~SYM[4]+1,~SYM[5]+2)+(2*~SYM[6])]; + assign ~SYM[9] = ~SYM[0][~INCLUDENAME_depth2Index(~SYM[4]+1,~SYM[5]+2)+(2*~SYM[6])+1]; + ~INST 0 + ~OUTPUT <= ~SYM[10]~ ~TYPO~ + ~INPUT <= ~SYM[8]~ ~TYPO~ + ~INPUT <= ~SYM[9]~ ~TYPO~ + ~INST + assign ~SYM[0][~INCLUDENAME_depth2Index(~SYM[4]+1,~SYM[5]+1)+~SYM[6]] = ~SYM[10]; + end + end +end +~ENDGENERATE + +// The last element of the intermediate array holds the result +assign ~RESULT = ~SYM[0][(2*~LENGTH[~TYP[1]])-2]; +// fold end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.index_int" + , "type" : "index_integer :: KnownNat n => Vec n a -> Int -> a" + , "templateD" : +"// indexVec begin +wire ~TYPO ~GENSYM[vec][0] [0:~LIT[0]-1]; + +genvar ~GENSYM[i][2]; +~GENERATE +for (~SYM[2]=0; ~SYM[2] < ~LIT[0]; ~SYM[2]=~SYM[2]+1) begin : ~GENSYM[mk_array][3] + assign ~SYM[0][(~LIT[0]-1)-~SYM[2]] = ~VAR[vecflat][1][~SYM[2]*~SIZE[~TYPO]+:~SIZE[~TYPO]]; +end +~ENDGENERATE + +assign ~RESULT = ~SYM[0][~ARG[2]]; +// indexVec end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.replace_int" + , "type" : "replace_int :: KnownNat n => Vec n a -> Int -> a -> Vec n a" + , "templateD" : +"// replaceVec start +reg ~TYP[3] ~GENSYM[vec][1] [0:~LIT[0]-1]; +integer ~GENSYM[i][2]; +always @(*) begin + for (~SYM[2]=0;~SYM[2]<~LIT[0];~SYM[2]=~SYM[2]+1) begin + ~SYM[1][~LIT[0]-1-~SYM[2]] = ~VAR[vecflat][1][~SYM[2]*~SIZE[~TYP[3]]+:~SIZE[~TYP[3]]]; + end + ~SYM[1][~ARG[2]] = ~ARG[3]; +end + +genvar ~GENSYM[i][3]; +~GENERATE +for (~SYM[3]=0;~SYM[3]<~LIT[0];~SYM[3]=~SYM[3]+1) begin : ~GENSYM[mk_vec][4] + assign ~RESULT[~SYM[3]*~SIZE[~TYP[3]]+:~SIZE[~TYP[3]]] = ~SYM[1][(~LIT[0]-1)-~SYM[3]]; +end +~ENDGENERATE +// replaceVec end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.maxIndex" + , "type" : "maxIndex :: KnownNat n => Vec n a -> Int" + , "templateE" : "~SIZE[~TYPO]'sd~LIT[0] - ~SIZE[~TYPO]'d1" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.length" + , "type" : "length :: KnownNat n => Vec n a -> Int" + , "templateE" : "~SIZE[~TYPO]'sd~LIT[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.replicate" + , "type" : "replicate :: SNat n -> a -> Vec n a" + , "templateE" : "{~LIT[0] {~ARG[1]}}" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.transpose" + , "type" : "transpose :: KnownNat n => Vec m (Vec n a) -> Vec n (Vec m a)" + , "templateD" : +"// transpose begin +genvar ~GENSYM[row_index][1]; +genvar ~GENSYM[col_index][2]; +~GENERATE +for (~SYM[1] = 0; ~SYM[1] < ~LENGTH[~TYP[1]]; ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[transpose_outer][3] + for (~SYM[2] = 0; ~SYM[2] < ~LENGTH[~TYPO]; ~SYM[2] = ~SYM[2] + 1) begin : ~GENSYM[transpose_inner][4] + assign ~RESULT[((~SYM[2]*~SIZE[~TYPEL[~TYPO]])+(~SYM[1]*~SIZE[~TYPEL[~TYPEL[~TYPO]]]))+:~SIZE[~TYPEL[~TYPEL[~TYPO]]]] = ~VAR[matrix][1][((~SYM[1]*~SIZE[~TYPEL[~TYP[1]]])+(~SYM[2]*~SIZE[~TYPEL[~TYPEL[~TYPO]]]))+:~SIZE[~TYPEL[~TYPEL[~TYPO]]]]; + end +end +~ENDGENERATE +// transpose end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.reverse" + , "type" : "reverse :: Vec n a -> Vec n a" + , "templateD" : +"// reverse begin +genvar ~GENSYM[i][1]; +~GENERATE +for (~SYM[1] = 0; ~SYM[1] < ~LENGTH[~TYPO]; ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[reverse][2] + assign ~RESULT[(~LENGTH[~TYPO] - 1 - ~SYM[1])*~SIZE[~TYPEL[~TYPO]]+:~SIZE[~TYPEL[~TYPO]]] = ~VAR[vec][0][~SYM[1]*~SIZE[~TYPEL[~TYPO]]+:~SIZE[~TYPEL[~TYPO]]]; +end +~ENDGENERATE +// reverse end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.lazyV" + , "type" : "lazyV :: KnownNat n => Vec n a -> Vec n a" + , "templateE" : "~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.concatBitVector#" + , "type" : +"concatBitVector# :: (KnownNat n, KnownNat m) -- (ARG[0],ARG[1]) + => Vec n (BitVector m) -- ARG[2] + -> BitVector (n * m)" + , "templateE" : "~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.unconcatBitVector#" + , "type" : +"unconcatBitVector# :: (KnownNat n, KnownNat m) -- (ARG[0],ARG[1]) + => BitVector (n * m) -- ARG[2] + -> Vec n (BitVector m)" + , "templateE" : "~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.rotateLeftS" + , "type" : "rotateLeftS :: KnownNat n => Vec n a -> SNat d -> Vec n a" + , "templateD" : +"// rotateLeftS begin +localparam ~GENSYM[shift_amount][2] = ~LIT[2] % ~LIT[0]; + +~GENERATE +if (~SYM[2] == 0) begin : ~GENSYM[no_shift][3] + assign ~RESULT = ~VAR[vec][1]; +end else begin : ~GENSYM[do_shift][4] + assign ~RESULT = {~VAR[vec][1][((~LIT[0]-~SYM[2])*~SIZE[~TYPEL[~TYPO]])-1 : 0] + ,~VAR[vec][1][~SIZE[~TYPO]-1 : (~LIT[0]-~SYM[2])*~SIZE[~TYPEL[~TYPO]]] + }; +end +~ENDGENERATE +// rotateLeftS end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.rotateRightS" + , "type" : "rotateRightS :: KnownNat n => Vec n a -> SNat d -> Vec n a" + , "templateD" : +"// rotateRightS begin +localparam ~GENSYM[shift_amount][2] = ~LIT[2] % ~LIT[0]; + +~GENERATE +if (~SYM[2] == 0) begin : ~GENSYM[no_shift][3] + assign ~RESULT = ~VAR[vec][1]; +end else begin : ~GENSYM[do_shift][4] + assign ~RESULT = {~VAR[vec][1][(~SYM[2]*~SIZE[~TYPEL[~TYPO]])-1 : 0] + ,~VAR[vec][1][~SIZE[~TYPO]-1 : ~SYM[2]*~SIZE[~TYPEL[~TYPO]]] + }; +end +~ENDGENERATE +// rotateRightS end" + } + } +] diff --git a/prims/verilog/Clash_Xilinx_ClockGen.json b/prims/verilog/Clash_Xilinx_ClockGen.json new file mode 100644 --- /dev/null +++ b/prims/verilog/Clash_Xilinx_ClockGen.json @@ -0,0 +1,39 @@ +[ { "BlackBox" : + { "name" : "Clash.Xilinx.ClockGen.clockWizard" + , "type" : +"clockWizard + :: SSymbol name -- ARG[0] + -> Clock pllIn 'Source -- ARG[1] + -> Reset pllIn 'Asynchronous -- ARG[2] + -> (Clock pllOut 'Source, Signal pllOut Bool)" + , "templateD" : +"// clockWizard begin +~NAME[0] ~GENSYM[clockWizard_inst][2] +(.CLK_IN1 (~ARG[1]) +,.RESET (~ARG[2]) +,.CLK_OUT1 (~RESULT[1]) +,.LOCKED (~RESULT[0])); +// clockWizard end" + } + } +, { "BlackBox" : + { "name" : "Clash.Xilinx.ClockGen.clockWizardDifferential" + , "type" : +"clockWizardDifferential + :: SSymbol name -- ARG[0] + -> Clock pllIn 'Source -- ARG[1] + -> Clock pllIn 'Source -- ARG[2] + -> Reset pllIn 'Asynchronous -- ARG[3] + -> (Clock pllOut 'Source, Signal pllOut Bool)" + , "templateD" : +"// clockWizardDifferential begin +~NAME[0] ~GENSYM[clockWizardDifferential_inst][2] +(.CLK_IN1_D_clk_n (~ARG[1]) +,.CLK_IN1_D_clk_n (~ARG[2]) +,.RESET (~ARG[3]) +,.CLK_OUT1 (~RESULT[1]) +,.LOCKED (~RESULT[0])); +// clockWizardDifferential end" + } + } +] diff --git a/prims/verilog/Clash_Xilinx_DDR.json b/prims/verilog/Clash_Xilinx_DDR.json new file mode 100644 --- /dev/null +++ b/prims/verilog/Clash_Xilinx_DDR.json @@ -0,0 +1,92 @@ +[ { "BlackBox" : + { "name" : "Clash.Xilinx.DDR.iddr" + , "type" : +"iddr + :: ( HasCallStack -- ARG[0] + , fast ~ Dom n pFast -- ARG[1] + , slow ~ Dom n (2*pFast) -- ARG[2] + , KnownNat m ) -- ARG[3] + -> Clock slow gated -- ARG[4] + -> Reset slow synchronous -- ARG[5] + -> Signal fast (BitVector m) -- ARG[6] + -> Signal slow (BitVector m,BitVector m)" + , "templateD" : +"// iddr begin +wire ~SIGD[~GENSYM[dataout_l][1]][6]; +wire ~SIGD[~GENSYM[dataout_h][2]][6]; +wire ~SIGD[~GENSYM[d][3]][6]; +assign ~SYM[3] = ~ARG[6]; + +genvar ~GENSYM[i][8]; +~GENERATE +for (~SYM[8]=0; ~SYM[8] < ~SIZE[~TYP[6]]; ~SYM[8]=~SYM[8]+1) begin : ~GENSYM[ddri_array][7] + IDDR #( + .DDR_CLK_EDGE(\"SAME_EDGE\"), + .INIT_Q1(1'b0), + .INIT_Q2(1'b0), + .SRTYPE(~IF ~ISSYNC[5] ~THEN \"SYNC\" ~ELSE \"ASYNC\" ~FI) + ) ~GENSYM[~COMPNAME_IDDR][9] ( + .Q1(~SYM[1][~SYM[8]]), + .Q2(~SYM[2][~SYM[8]]),~IF ~ISGATED[6] ~THEN + .C(~ARG[4][1]), + .CE(~ARG[4][0]),~ELSE + .C(~ARG[4]), + .CE(1'b1),~FI + .D(~SYM[3][~SYM[8]]), + .R(~ARG[5]), + .S(1'b0) + ); +end +~ENDGENERATE + +assign ~RESULT = {~SYM[2],~SYM[1]}; +// iddr end" + } + } +, { "BlackBox" : + { "name" : "Clash.Xilinx.DDR.oddr#" + , "type" : +"oddr# + :: ( slow ~ Dom n (2*pFast) -- ARG[0] + , fast ~ Dom n pFast -- ARG[1] + , KnownNat m ) -- ARG[2] + => Clock slow gated -- ARG[3] + -> Reset slow synchronous -- ARG[4] + -> Signal slow (BitVector m) -- ARG[5] + -> Signal slow (BitVector m) -- ARG[6] + -> Signal fast (BitVector m)" + , "templateD" : +"// oddr begin +wire ~SIGD[~GENSYM[datain_l][1]][6]; +wire ~SIGD[~GENSYM[datain_h][2]][6]; +wire ~SIGD[~GENSYM[q][3]][6]; + +assign ~SYM[1] = ~ARG[5]; +assign ~SYM[2] = ~ARG[6]; + +genvar ~GENSYM[i][8]; +~GENERATE +for (~SYM[8]=0; ~SYM[8] < ~SIZE[~TYP[6]]; ~SYM[8]=~SYM[8]+1) begin : ~GENSYM[ddro_array][7] + ODDR #( + .DDR_CLK_EDGE(\"SAME_EDGE\"), + .INIT(1'b0), + .SRTYPE(~IF ~ISSYNC[4] ~THEN \"SYNC\" ~ELSE \"ASYNC\" ~FI) + ) ~GENSYM[~COMPNAME_ODDR][9] ( + .Q(~SYM[3][~SYM[8]]),~IF ~ISGATED[3] ~THEN + .C(~ARG[3][1]), + .CE(~ARG[3][0]),~ELSE + .C(~ARG[3]), + .CE(1'b1),~FI + .D1(~SYM[1][~SYM[8]]), + .D2(~SYM[2][~SYM[8]]), + .R(~ARG[4]), + .S(1'b0) + ); +end +~ENDGENERATE + +assign ~RESULT = ~SYM[3]; +// oddr end" + } + } +] diff --git a/prims/verilog/GHC_Base.json b/prims/verilog/GHC_Base.json new file mode 100644 --- /dev/null +++ b/prims/verilog/GHC_Base.json @@ -0,0 +1,48 @@ +[ { "Primitive" : + { "name" : "GHC.Base.$" + , "primType" : "Function" + } + } +, { "BlackBox" : + { "name" : "GHC.Base.quotInt" + , "type" : "quotInt :: Int -> Int -> Int" + , "templateE" : "~ARG[0] / ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Base.remInt" + , "type" : "remInt :: Int -> Int -> Int" + , "templateE" : "~ARG[0] % ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Base.divInt" + , "type" : "divInt :: Int -> Int -> Int" + , "templateD" : +"// divInt begin +// divide (rounds towards zero) +wire ~SIGD[~GENSYM[quot_res][0]][0]; +assign ~SYM[0] = ~VAR[dividend][0] / ~VAR[divider][1]; + +// round toward minus infinity +assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? ~SYM[0] : ~SYM[0] - ~SIZE[~TYPO]'sd1; +// divInt end" + } + } +, { "BlackBox" : + { "name" : "GHC.Base.modInt" + , "type" : "modInt :: Int -> Int -> Int" + , "templateD" : +"// modInt begin +// remainder +wire ~SIGD[~GENSYM[rem_res][0]][0]; +assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1]; + +// modulo +assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? + ~SYM[0] : + ((~VAR[dividend][0] == ~SIZE[~TYPO]'sd0) ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]); +// modInt end" + } + } +] diff --git a/prims/verilog/GHC_Classes.json b/prims/verilog/GHC_Classes.json new file mode 100644 --- /dev/null +++ b/prims/verilog/GHC_Classes.json @@ -0,0 +1,85 @@ +[ { "BlackBox" : + { "name" : "GHC.Classes.eqInt" + , "type" : "eqInt :: Int -> Int -> Bool" + , "templateE" : "~ARG[0] == ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.neInt" + , "type" : "neInt :: Int -> Int -> Bool" + , "templateE" : "~ARG[0] != ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.gtInt" + , "type" : "gtInt :: Int -> Int -> Bool" + , "templateE" : "~ARG[0] > ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.geInt" + , "type" : "geInt :: Int -> Int -> Bool" + , "templateE" : "~ARG[0] >= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.ltInt" + , "type" : "ltInt :: Int -> Int -> Bool" + , "templateE" : "~ARG[0] < ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.leInt" + , "type" : "leInt :: Int -> Int -> Bool" + , "templateE" : "~ARG[0] <= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.&&" + , "type" : "(&&) :: Bool -> Bool -> Bool" + , "templateE" : "~ARG[0] & ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.||" + , "type" : "(::) :: Bool -> Bool -> Bool" + , "templateE" : "~ARG[0] | ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.not" + , "type" : "not :: Bool -> Bool" + , "templateE" : "~ ~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.divInt#" + , "type" : "divInt# :: Int# -> Int# -> Int#" + , "templateD" : +"// divInt# begin +// divide (rounds towards zero) +wire ~SIGD[~GENSYM[quot_res][0]][0]; +assign ~SYM[0] = ~VAR[dividend][0] / ~VAR[divider][1]; + +// round toward minus infinity +assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? ~SYM[0] : ~SYM[0] - ~SIZE[~TYPO]'sd1; +// divInt# end" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.modInt#" + , "type" : "modInt# :: Int# -> Int# -> Int#" + , "templateD" : +"// modInt# begin +// remainder +wire ~SIGD[~GENSYM[rem_res][0]][0]; +assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1]; + +// modulo +assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? + ~SYM[0] : + ((~VAR[dividend][0] == ~SIZE[~TYPO]'sd0) ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]); +// modInt# end" + } + } +] diff --git a/prims/verilog/GHC_Int.json b/prims/verilog/GHC_Int.json new file mode 100644 --- /dev/null +++ b/prims/verilog/GHC_Int.json @@ -0,0 +1,25 @@ +[ { "BlackBox" : + { "name" : "GHC.Int.I8#" + , "type" : "I8# :: Int# -> Int8" + , "templateD" : "assign ~RESULT = $signed(~ARG[0]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Int.I16#" + , "type" : "I16# :: Int# -> Int16" + , "templateD" : "assign ~RESULT = $signed(~ARG[0]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Int.I32#" + , "type" : "I32# :: Int# -> Int32" + , "templateD" : "assign ~RESULT = $signed(~ARG[0]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Int.I64#" + , "type" : "I64# :: Int# -> Int64" + , "templateD" : "assign ~RESULT = $signed(~ARG[0]);" + } + } +] diff --git a/prims/verilog/GHC_Integer_Type.json b/prims/verilog/GHC_Integer_Type.json new file mode 100644 --- /dev/null +++ b/prims/verilog/GHC_Integer_Type.json @@ -0,0 +1,181 @@ +[ { "BlackBox" : + { "name" : "GHC.Integer.Type.smallInteger" + , "type" : "smallInteger :: Int# -> Integer" + , "templateD" : "assign ~RESULT = $signed(~ARG[0]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.integerToInt" + , "type" : "integerToInt :: Integer -> Int#" + , "templateD" : "assign ~RESULT = $signed(~ARG[0]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.plusInteger" + , "type" : "plusInteger :: Integer -> Integer -> Integer" + , "templateE" : "~ARG[0] + ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.minusInteger" + , "type" : "minusInteger :: Integer -> Integer -> Integer" + , "templateE" : "~ARG[0] - ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.timesInteger" + , "type" : "timesInteger :: Integer -> Integer -> Integer" + , "templateE" : "~ARG[0] * ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.negateInteger" + , "type" : "negateInteger :: Integer -> Integer" + , "templateE" : "-~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.absInteger" + , "type" : "absInteger :: Integer -> Integer" + , "templateE" : "(~ARG[0] < ~SIZE[~TYPO]'sd0) ? -~ARG[0] : ~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.divInteger" + , "type" : "divInteger :: Integer -> Integer -> Integer" + , "templateD" : +"// divInteger begin +// divide (rounds towards zero) +wire ~SIGD[~GENSYM[quot_res][0]][0]; +assign ~SYM[0] = ~VAR[dividend][0] / ~VAR[divider][1]; + +// round toward minus infinity +assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? ~SYM[0] : ~SYM[0] - ~SIZE[~TYPO]'sd1; +// divInteger end" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.modInteger" + , "type" : "modInteger :: Integer -> Integer -> Integer" + , "templateD" : +"// modInteger begin +// remainder +wire ~SIGD[~GENSYM[rem_res][0]][0]; +assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1]; + +// modulo +assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? + ~SYM[0] : + ((~VAR[dividend][0] == ~SIZE[~TYPO]'sd0) ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]); +// modInteger end" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.quotInteger" + , "type" : "quotInteger :: Integer -> Integer -> Integer" + , "templateE" : "~ARG[0] / ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.remInteger" + , "type" : "remInteger :: Integer -> Integer -> Integer" + , "templateE" : "~ARG[0] % ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.eqInteger" + , "type" : "eqInteger :: Integer -> Integer -> Bool" + , "templateE" : "~ARG[0] == ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.neqInteger" + , "type" : "neqInteger :: Integer -> Integer -> Bool" + , "templateE" : "~ARG[0] != ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.leInteger" + , "type" : "leInteger :: Integer -> Integer -> Bool" + , "templateE" : "~ARG[0] <= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.gtInteger" + , "type" : "gtInteger :: Integer -> Integer -> Bool" + , "templateE" : "~ARG[0] > ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.ltInteger" + , "type" : "ltInteger :: Integer -> Integer -> Bool" + , "templateE" : "~ARG[0] < ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.geInteger" + , "type" : "geInteger :: Integer -> Integer -> Bool" + , "templateE" : "~ARG[0] >= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.eqInteger#" + , "type" : "eqInteger :: Integer -> Integer -> Int#" + , "templateE" : "(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.neqInteger#" + , "type" : "neqInteger :: Integer -> Integer -> Int#" + , "templateE" : "(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.leInteger#" + , "type" : "leInteger :: Integer -> Integer -> Int#" + , "templateE" : "(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.gtInteger#" + , "type" : "gtInteger :: Integer -> Integer -> Int#" + , "templateE" : "(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.ltInteger#" + , "type" : "ltInteger :: Integer -> Integer -> Int#" + , "templateE" : "(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.geInteger#" + , "type" : "geInteger :: Integer -> Integer -> Int#" + , "templateE" : "(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.shiftRInteger" + , "type" : "shiftRInteger :: Integer -> Int# -> Integer" + , "templateE" : "~ARG[0] >>> ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.shiftLInteger" + , "type" : "shiftLInteger :: Integer -> Int# -> Integer" + , "templateE" : "~ARG[0] <<< ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.wordToInteger" + , "type" : "wordToInteger :: Word# -> Integer" + , "templateD" : "assign ~RESULT = $signed(~ARG[0]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.integerToWord" + , "type" : "integerToWord :: Integer -> Word#" + , "templateD" : "assign ~RESULT = $unsigned(~ARG[0]);" + } + } +] diff --git a/prims/verilog/GHC_Prim.json b/prims/verilog/GHC_Prim.json new file mode 100644 --- /dev/null +++ b/prims/verilog/GHC_Prim.json @@ -0,0 +1,1862 @@ +[ { "BlackBox" : + { "name" : "GHC.Prim.gtChar#" + , "type" : "gtChar# :: Char# -> Char# -> Int#" + , "templateE" : "(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.geChar#" + , "type" : "geChar# :: Char# -> Char# -> Int#" + , "templateE" : "(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.eqChar#" + , "type" : "eqChar# :: Char# -> Char# -> Int#" + , "templateE" : "(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.neChar#" + , "type" : "neChar# :: Char# -> Char# -> Int#" + , "templateE" : "(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.ltChar#" + , "type" : "ltChar# :: Char# -> Char# -> Int#" + , "templateE" : "(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.leChar#" + , "type" : "leChar# :: Char# -> Char# -> Int#" + , "templateE" : "(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.ord#" + , "type" : "ord :: Char# -> Int#" + , "templateD" : "assign ~RESULT = $unsigned(~ARG[0]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.+#" + , "type" : "(+#) :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] + ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.-#" + , "type" : "(-#) :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] - ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.*#" + , "type" : "(*#) :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] * ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.quotInt#" + , "type" : "quotInt# :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] / ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.remInt#" + , "type" : "remInt# :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] % ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.quotRemInt#" + , "type" : "quotRemInt# :: Int# -> Int# -> (#Int#, Int##)" + , "templateD" : +"// quotRemInt begin +wire ~SIGD[~GENSYM[quot_res][0]][0]; +wire ~SIGD[~GENSYM[rem_res][1]][0]; +assign ~SYM[0] = ~ARG[0] / ~ARG[1]; +assign ~SYM[1] = ~ARG[0] % ~ARG[1]; + +assign ~RESULT = {~SYM[0],~SYM[1]}; +// quotRemInt end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.andI#" + , "type" : "andI# :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] & ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.orI#" + , "type" : "orI# :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] | ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.xorI#" + , "type" : "xorI# :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] ^ ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.notI#" + , "type" : "notI# :: Int# -> Int#" + , "templateE" : "~ ~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.negateInt#" + , "type" : "negateInt# :: Int# -> Int#" + , "templateE" : "-(~ARG[0])" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.>#" + , "type" : "(>#) :: Int# -> Int# -> Int#" + , "templateE" : "(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.>=#" + , "type" : "(>=#) :: Int# -> Int# -> Int#" + , "templateE" : "(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.==#" + , "type" : "(==) :: Int# -> Int# -> Int#" + , "templateE" : "(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim./=#" + , "type" : "(/=#) :: Int# -> Int# -> Int#" + , "templateE" : "(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.<#" + , "type" : "(<#) :: Int# -> Int# -> Int#" + , "templateE" : "(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.<=#" + , "type" : "(<=#) :: Int# -> Int# -> Int#" + , "templateE" : "(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.chr#" + , "type" : "ord :: Int# -> Char#" + , "templateD" : "assign ~RESULT = $unsigned(~ARG[0]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.int2Word#" + , "type" : "int2Word# :: Int# -> Word#" + , "templateE" : "$unsigned(~ARG[0])" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.uncheckedIShiftL#" + , "type" : "uncheckedIShiftL# :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] <<< ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.uncheckedIShiftRA#" + , "type" : "uncheckedIShiftRA# :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] >>> ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.uncheckedIShiftRL#" + , "type" : "uncheckedIShiftRL# :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] >> ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.plusWord#" + , "type" : "plusWord# :: Word# -> Word# -> Word#" + , "templateE" : "~ARG[0] + ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.minusWord#" + , "type" : "minusWord# :: Word# -> Word# -> Word#" + , "templateE" : "~ARG[0] - ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.timesWord#" + , "type" : "timesWord# :: Word# -> Word# -> Word#" + , "templateE" : "~ARG[0] * ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.quotWord#" + , "type" : "quotWord# :: Word# -> Word# -> Word#" + , "templateE" : "~ARG[0] / ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.remWord#" + , "type" : "remWord# :: Word# -> Word# -> Word#" + , "templateE" : "~ARG[0] % ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.quotRemWord#" + , "type" : "quotRemWord# :: Word# -> Word# -> (#Word#, Word##)" + , "templateD" : +"// quotRemWord begin +wire ~SIGD[~GENSYM[quot_res][0]][0]; +wire ~SIGD[~GENSYM[rem_res][1]][0]; +assign ~SYM[0] = ~ARG[0] / ~ARG[1]; +assign ~SYM[1] = ~ARG[0] % ~ARG[1]; + +assign ~RESULT = {~SYM[0],~SYM[1]}; +// quotRemWord end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.and#" + , "type" : "and# :: Word# -> Word# -> Word#" + , "templateE" : "~ARG[0] & ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.or#" + , "type" : "or# :: Word# -> Word# -> Word#" + , "templateE" : "~ARG[0] | ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.xor#" + , "type" : "xor# :: Word# -> Word# -> Word#" + , "templateE" : "~ARG[0] ^ ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.not#" + , "type" : "not# :: Word# -> Word#" + , "templateE" : "~ ~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.uncheckedShiftL#" + , "type" : "uncheckedShiftL# :: Word# -> Int# -> Word#" + , "templateE" : "~ARG[0] << ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.uncheckedShiftRL#" + , "type" : "uncheckedShiftRL# :: Word# -> Int# -> Word#" + , "templateE" : "~ARG[0] >> ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.word2Int#" + , "type" : "int2Word# :: Word# -> Int#" + , "templateE" : "$signed(~ARG[0])" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.gtWord#" + , "type" : "gtWord# :: Word# -> Word# -> Int#" + , "templateE" : "(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.geWord#" + , "type" : "geWord# :: Word# -> Word# -> Int#" + , "templateE" : "(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.eqWord#" + , "type" : "eqWord# :: Word# -> Word# -> Int#" + , "templateE" : "(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.neWord#" + , "type" : "neWord# :: Word# -> Word# -> Int#" + , "templateE" : "(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.ltWord#" + , "type" : "ltWord# :: Word# -> Word# -> Int#" + , "templateE" : "(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.leWord#" + , "type" : "leWord# :: Word# -> Word# -> Int#" + , "templateE" : "(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.popCnt8#" + , "type" : "popCnt8# :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "popCnt8" + , "extension" : "inc" + , "content" : +"// ceiling of log2 +function integer ~INCLUDENAME_clog2; + input integer value; + begin + value = value-1; + for (~INCLUDENAME_clog2=0; value>0; ~INCLUDENAME_clog2=~INCLUDENAME_clog2+1) + value = value>>1; + end +endfunction + +// given a level and a depth, calculate the corresponding index into the +// intermediate array +function integer ~INCLUDENAME_depth2Index; + input integer levels; + input integer depth; + + ~INCLUDENAME_depth2Index = (2 ** levels) - (2 ** depth); +endfunction" + } + , "templateD" : +"// popCnt8 begin +localparam ~GENSYM[width][0] = 8; + +// depth of the tree +localparam ~GENSYM[levels][2] = ~INCLUDENAME_clog2(~SYM[0]); + +wire [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2]; + +// put input into the first half of the intermediate array +genvar ~GENSYM[i][4]; +~GENERATE +for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11] + assign ~SYM[3][~SYM[4]] = $unsigned(~ARG[0][~SYM[4]]); +end +~ENDGENERATE + +// Create the tree of instantiated components +genvar ~GENSYM[d][6]; +genvar ~GENSYM[i][7]; +~GENERATE +if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8] + for (~SYM[6] = (~SYM[2] - 1); ~SYM[6] >= 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9] + for (~SYM[7] = 0; ~SYM[7] < (2**~SYM[6]); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10] + assign ~SYM[3][~INCLUDENAME_depth2Index(~SYM[2]+1,~SYM[6]+1)+~SYM[7]] = + ~SYM[3][~INCLUDENAME_depth2Index(~SYM[2]+1,~SYM[6]+2)+(2*~SYM[7])] + + ~SYM[3][~INCLUDENAME_depth2Index(~SYM[2]+1,~SYM[6]+2)+(2*~SYM[7])+1]; + end + end +end +~ENDGENERATE + +// The last element of the intermediate array holds the result +assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]); +// popCnt8 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.popCnt16#" + , "type" : "popCnt16# :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "popCnt16" + , "extension" : "inc" + , "content" : +"// ceiling of log2 +function integer ~INCLUDENAME_clog2; + input integer value; + begin + value = value-1; + for (~INCLUDENAME_clog2=0; value>0; ~INCLUDENAME_clog2=~INCLUDENAME_clog2+1) + value = value>>1; + end +endfunction + +// given a level and a depth, calculate the corresponding index into the +// intermediate array +function integer ~INCLUDENAME_depth2Index; + input integer levels; + input integer depth; + + ~INCLUDENAME_depth2Index = (2 ** levels) - (2 ** depth); +endfunction" + } + , "templateD" : +"// popCnt16 begin +localparam ~GENSYM[width][0] = 16; + +// depth of the tree +localparam ~GENSYM[levels][2] = ~INCLUDENAME_clog2(~SYM[0]); + +wire [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2]; + +// put input into the first half of the intermediate array +genvar ~GENSYM[i][4]; +~GENERATE +for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11] + assign ~SYM[3][~SYM[4]] = $unsigned(~ARG[0][~SYM[4]]); +end +~ENDGENERATE + +// Create the tree of instantiated components +genvar ~GENSYM[d][6]; +genvar ~GENSYM[i][7]; +~GENERATE +if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8] + for (~SYM[6] = (~SYM[2] - 1); ~SYM[6] >= 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9] + for (~SYM[7] = 0; ~SYM[7] < (2**~SYM[6]); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10] + assign ~SYM[3][~INCLUDENAME_depth2Index(~SYM[2]+1,~SYM[6]+1)+~SYM[7]] = + ~SYM[3][~INCLUDENAME_depth2Index(~SYM[2]+1,~SYM[6]+2)+(2*~SYM[7])] + + ~SYM[3][~INCLUDENAME_depth2Index(~SYM[2]+1,~SYM[6]+2)+(2*~SYM[7])+1]; + end + end +end +~ENDGENERATE + +// The last element of the intermediate array holds the result +assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]); +// popCnt16 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.popCnt32#" + , "type" : "popCnt32# :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "popCnt32" + , "extension" : "inc" + , "content" : +"// ceiling of log2 +function integer ~INCLUDENAME_clog2; + input integer value; + begin + value = value-1; + for (~INCLUDENAME_clog2=0; value>0; ~INCLUDENAME_clog2=~INCLUDENAME_clog2+1) + value = value>>1; + end +endfunction + +// given a level and a depth, calculate the corresponding index into the +// intermediate array +function integer ~INCLUDENAME_depth2Index; + input integer levels; + input integer depth; + + ~INCLUDENAME_depth2Index = (2 ** levels) - (2 ** depth); +endfunction" + } + , "templateD" : +"// popCnt32 begin +localparam ~GENSYM[width][0] = 32; + +// depth of the tree +localparam ~GENSYM[levels][2] = ~INCLUDENAME_clog2(~SYM[0]); + +wire [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2]; + +// put input into the first half of the intermediate array +genvar ~GENSYM[i][4]; +~GENERATE +for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11] + assign ~SYM[3][~SYM[4]] = $unsigned(~ARG[0][~SYM[4]]); +end +~ENDGENERATE + +// Create the tree of instantiated components +genvar ~GENSYM[d][6]; +genvar ~GENSYM[i][7]; +~GENERATE +if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8] + for (~SYM[6] = (~SYM[2] - 1); ~SYM[6] >= 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9] + for (~SYM[7] = 0; ~SYM[7] < (2**~SYM[6]); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10] + assign ~SYM[3][~INCLUDENAME_depth2Index(~SYM[2]+1,~SYM[6]+1)+~SYM[7]] = + ~SYM[3][~INCLUDENAME_depth2Index(~SYM[2]+1,~SYM[6]+2)+(2*~SYM[7])] + + ~SYM[3][~INCLUDENAME_depth2Index(~SYM[2]+1,~SYM[6]+2)+(2*~SYM[7])+1]; + end + end +end +~ENDGENERATE + +// The last element of the intermediate array holds the result +assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]); +// popCnt32 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.popCnt64#" + , "type" : "popCnt64# :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "popCnt64" + , "extension" : "inc" + , "content" : +"// ceiling of log2 +function integer ~INCLUDENAME_clog2; + input integer value; + begin + value = value-1; + for (~INCLUDENAME_clog2=0; value>0; ~INCLUDENAME_clog2=~INCLUDENAME_clog2+1) + value = value>>1; + end +endfunction + +// given a level and a depth, calculate the corresponding index into the +// intermediate array +function integer ~INCLUDENAME_depth2Index; + input integer levels; + input integer depth; + + ~INCLUDENAME_depth2Index = (2 ** levels) - (2 ** depth); +endfunction" + } + , "templateD" : +"// popCnt64 begin +localparam ~GENSYM[width][0] = 64; + +// depth of the tree +localparam ~GENSYM[levels][2] = ~INCLUDENAME_clog2(~SYM[0]); + +wire [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2]; + +// put input into the first half of the intermediate array +genvar ~GENSYM[i][4]; +~GENERATE +for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11] + assign ~SYM[3][~SYM[4]] = $unsigned(~ARG[0][~SYM[4]]); +end +~ENDGENERATE + +// Create the tree of instantiated components +genvar ~GENSYM[d][6]; +genvar ~GENSYM[i][7]; +~GENERATE +if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8] + for (~SYM[6] = (~SYM[2] - 1); ~SYM[6] >= 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9] + for (~SYM[7] = 0; ~SYM[7] < (2**~SYM[6]); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10] + assign ~SYM[3][~INCLUDENAME_depth2Index(~SYM[2]+1,~SYM[6]+1)+~SYM[7]] = + ~SYM[3][~INCLUDENAME_depth2Index(~SYM[2]+1,~SYM[6]+2)+(2*~SYM[7])] + + ~SYM[3][~INCLUDENAME_depth2Index(~SYM[2]+1,~SYM[6]+2)+(2*~SYM[7])+1]; + end + end +end +~ENDGENERATE + +// The last element of the intermediate array holds the result +assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]); +// popCnt64 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.popCnt#" + , "type" : "popCnt8# :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "popCnt" + , "extension" : "inc" + , "content" : +"// ceiling of log2 +function integer ~INCLUDENAME_clog2; + input integer value; + begin + value = value-1; + for (~INCLUDENAME_clog2=0; value>0; ~INCLUDENAME_clog2=~INCLUDENAME_clog2+1) + value = value>>1; + end +endfunction + +// given a level and a depth, calculate the corresponding index into the +// intermediate array +function integer ~INCLUDENAME_depth2Index; + input integer levels; + input integer depth; + + ~INCLUDENAME_depth2Index = (2 ** levels) - (2 ** depth); +endfunction" + } + , "templateD" : +"// popCnt begin +localparam ~GENSYM[width][0] = ~SIZE[~TYPO]; + +// depth of the tree +localparam ~GENSYM[levels][2] = ~INCLUDENAME_clog2(~SYM[0]); + +wire [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2]; + +// put input into the first half of the intermediate array +genvar ~GENSYM[i][4]; +~GENERATE +for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11] + assign ~SYM[3][~SYM[4]] = $unsigned(~ARG[0][~SYM[4]]); +end +~ENDGENERATE + +// Create the tree of instantiated components +genvar ~GENSYM[d][6]; +genvar ~GENSYM[i][7]; +~GENERATE +if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8] + for (~SYM[6] = (~SYM[2] - 1); ~SYM[6] >= 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9] + for (~SYM[7] = 0; ~SYM[7] < (2**~SYM[6]); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10] + assign ~SYM[3][~INCLUDENAME_depth2Index(~SYM[2]+1,~SYM[6]+1)+~SYM[7]] = + ~SYM[3][~INCLUDENAME_depth2Index(~SYM[2]+1,~SYM[6]+2)+(2*~SYM[7])] + + ~SYM[3][~INCLUDENAME_depth2Index(~SYM[2]+1,~SYM[6]+2)+(2*~SYM[7])+1]; + end + end +end +~ENDGENERATE + +// The last element of the intermediate array holds the result +assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]); +// popCnt end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.clz8#" + , "type" : "clz8 :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "enc" + , "extension" : "inc" + , "content" : +"function [1:0] ~INCLUDENAME; + input [1:0] a; + case (a) + 2'b00: ~INCLUDENAME = 2'b10; + 2'b01: ~INCLUDENAME = 2'b01; + 2'b10: ~INCLUDENAME = 2'b00; + default: ~INCLUDENAME = 2'b00; + endcase +endfunction" + } + , "templateD" : +"// clz8 begin +wire [0:7] ~GENSYM[v][1]; +assign ~SYM[1] = ~ARG[0][7:0]; + +wire [0:7] ~GENSYM[e][2]; +genvar ~GENSYM[n][3]; +~GENERATE +for (~SYM[3]=0;~SYM[3]<4;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] + assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME(~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); +end +~ENDGENERATE + +reg [0:5] ~GENSYM[a][4]; +genvar ~GENSYM[i1][5]; +~GENERATE +for (~SYM[5]=0;~SYM[5]<2;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage1][6] + localparam n = 2; + wire [3:0] i; + assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:3] ~GENSYM[res][7]; +~GENERATE +if (1) begin +localparam n = 3; +wire [5:0] i; +assign i = ~SYM[4][0:5]; +always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase +end +end +~ENDGENERATE + +assign ~RESULT = $unsigned(~SYM[7]); +// clz8 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.clz16#" + , "type" : "clz16 :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "enc" + , "extension" : "inc" + , "content" : +"function [1:0] ~INCLUDENAME; + input [1:0] a; + case (a) + 2'b00: ~INCLUDENAME = 2'b10; + 2'b01: ~INCLUDENAME = 2'b01; + 2'b10: ~INCLUDENAME = 2'b00; + default: ~INCLUDENAME = 2'b00; + endcase +endfunction" + } + , "templateD" : +"// clz16 begin +wire [0:15] ~GENSYM[v][1]; +assign ~SYM[1] = ~ARG[0][15:0]; + +wire [0:15] ~GENSYM[e][2]; +genvar ~GENSYM[i][3]; +~GENERATE +for (~SYM[3]=0;~SYM[3]<8;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] + assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME(~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); +end +~ENDGENERATE + +reg [0:11] ~GENSYM[a][4]; +genvar ~GENSYM[i1][5]; +~GENERATE +for (~SYM[5]=0;~SYM[5]<4;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] + localparam n = 2; + wire [3:0] i; + assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:7] ~GENSYM[b][9]; +genvar ~GENSYM[i2][10]; +~GENERATE +for (~SYM[10]=0;~SYM[10]<2;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] + localparam n = 3; + wire [5:0] i; + assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:4] ~GENSYM[res][7]; +~GENERATE +if (1) begin +localparam n = 4; +wire [7:0] i; +assign i = ~SYM[9][0:7]; +always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase +end +end +~ENDGENERATE + +assign ~RESULT = $unsigned(~SYM[7]); +// clz16 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.clz32#" + , "type" : "clz32 :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "enc" + , "extension" : "inc" + , "content" : +"function [1:0] ~INCLUDENAME; + input [1:0] a; + case (a) + 2'b00: ~INCLUDENAME = 2'b10; + 2'b01: ~INCLUDENAME = 2'b01; + 2'b10: ~INCLUDENAME = 2'b00; + default: ~INCLUDENAME = 2'b00; + endcase +endfunction" + } + , "templateD" : +"// clz32 begin +wire [0:31] ~GENSYM[v][1]; +assign ~SYM[1] = ~ARG[0][31:0]; + +wire [0:31] ~GENSYM[e][2]; +genvar ~GENSYM[i][3]; +~GENERATE +for (~SYM[3]=0;~SYM[3]<16;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] + assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME(~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); +end +~ENDGENERATE + +reg [0:23] ~GENSYM[a][4]; +genvar ~GENSYM[i1][5]; +~GENERATE +for (~SYM[5]=0;~SYM[5]<8;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] + localparam n = 2; + wire [3:0] i; + assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:15] ~GENSYM[b][9]; +genvar ~GENSYM[i2][10]; +~GENERATE +for (~SYM[10]=0;~SYM[10]<4;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] + localparam n = 3; + wire [5:0] i; + assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:9] ~GENSYM[c][12]; +genvar ~GENSYM[i3][13]; +~GENERATE +for (~SYM[13]=0;~SYM[13]<2;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14] + localparam n = 4; + wire [7:0] i; + assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:5] ~GENSYM[res][7]; +~GENERATE +if (1) begin +localparam n = 5; +wire [9:0] i; +assign i = ~SYM[12][0:9]; +always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase +end +end +~ENDGENERATE + +assign ~RESULT = $unsigned(~SYM[7]); +// clz32 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.clz64#" + , "type" : "clz64 :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "enc" + , "extension" : "inc" + , "content" : +"function [1:0] ~INCLUDENAME; + input [1:0] a; + case (a) + 2'b00: ~INCLUDENAME = 2'b10; + 2'b01: ~INCLUDENAME = 2'b01; + 2'b10: ~INCLUDENAME = 2'b00; + default: ~INCLUDENAME = 2'b00; + endcase +endfunction" + } + , "templateD" : +"// clz64 begin +wire [0:63] ~GENSYM[v][1]; +assign ~SYM[1] = ~ARG[0][63:0]; + +wire [0:63] ~GENSYM[e][2]; +genvar ~GENSYM[i][3]; +~GENERATE +for (~SYM[3]=0;~SYM[3]<32;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] + assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME(~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); +end +~ENDGENERATE + +reg [0:47] ~GENSYM[a][4]; +genvar ~GENSYM[i1][5]; +~GENERATE +for (~SYM[5]=0;~SYM[5]<16;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] + localparam n = 2; + wire [3:0] i; + assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:31] ~GENSYM[b][9]; +genvar ~GENSYM[i2][10]; +~GENERATE +for (~SYM[10]=0;~SYM[10]<8;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] + localparam n = 3; + wire [5:0] i; + assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:19] ~GENSYM[c][12]; +genvar ~GENSYM[i3][13]; +~GENERATE +for (~SYM[13]=0;~SYM[13]<4;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14] + localparam n = 4; + wire [7:0] i; + assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:11] ~GENSYM[d][15]; +genvar ~GENSYM[i4][16]; +~GENERATE +for (~SYM[16]=0;~SYM[16]<2;~SYM[16]=~SYM[16]+1) begin : ~GENSYM[mux_stage4][17] + localparam n = 5; + wire [9:0] i; + assign i = ~SYM[12][~SYM[16]*10:~SYM[16]*10+9]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:6] ~GENSYM[res][7]; +~GENERATE +if (1) begin +localparam n = 6; +wire [11:0] i; +assign i = ~SYM[15][0:11]; +always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase +end +end +~ENDGENERATE + +assign ~RESULT = $unsigned(~SYM[7]); +// clz64 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.clz#" + , "type" : "clz :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "enc" + , "extension" : "inc" + , "content" : +"function [1:0] ~INCLUDENAME; + input [1:0] a; + case (a) + 2'b00: ~INCLUDENAME = 2'b10; + 2'b01: ~INCLUDENAME = 2'b01; + 2'b10: ~INCLUDENAME = 2'b00; + default: ~INCLUDENAME = 2'b00; + endcase +endfunction" + } + , "templateD" : +"// clz begin~IF ~IW64 ~THEN +wire [0:63] ~GENSYM[v][1]; +assign ~SYM[1] = ~ARG[0][63:0]; + +wire [0:63] ~GENSYM[e][2]; +genvar ~GENSYM[i][3]; +~GENERATE +for (~SYM[3]=0;~SYM[3]<32;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] + assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME(~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); +end +~ENDGENERATE + +reg [0:47] ~GENSYM[a][4]; +genvar ~GENSYM[i1][5]; +~GENERATE +for (~SYM[5]=0;~SYM[5]<16;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] + localparam n = 2; + wire [3:0] i; + assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:31] ~GENSYM[b][9]; +genvar ~GENSYM[i2][10]; +~GENERATE +for (~SYM[10]=0;~SYM[10]<8;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] + localparam n = 3; + wire [5:0] i; + assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:19] ~GENSYM[c][12]; +genvar ~GENSYM[i3][13]; +~GENERATE +for (~SYM[13]=0;~SYM[13]<4;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14] + localparam n = 4; + wire [7:0] i; + assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:11] ~GENSYM[d][15]; +genvar ~GENSYM[i4][16]; +~GENERATE +for (~SYM[16]=0;~SYM[16]<2;~SYM[16]=~SYM[16]+1) begin : ~GENSYM[mux_stage4][17] + localparam n = 5; + wire [9:0] i; + assign i = ~SYM[12][~SYM[16]*10:~SYM[16]*10+9]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:6] ~GENSYM[res][7]; +~GENERATE +if (1) begin +localparam n = 6; +wire [11:0] i; +assign i = ~SYM[15][0:11]; +always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase +end +end +~ENDGENERATE +~ELSE +wire [0:31] ~SYM[1]; +assign ~SYM[1] = ~ARG[0][31:0]; + +wire [0:31] ~SYM[2]; +genvar ~SYM[3]; +~GENERATE +for (~SYM[3]=0;~SYM[3]<16;~SYM[3]=~SYM[3]+1) begin : ~SYM[8] + assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME(~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); +end +~ENDGENERATE + +reg [0:23] ~SYM[4]; +genvar ~SYM[5]; +~GENERATE +for (~SYM[5]=0;~SYM[5]<8;~SYM[5]=~SYM[5]+1) begin : ~SYM[6] + localparam n = 2; + wire [3:0] i; + assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:15] ~SYM[9]; +genvar ~SYM[10]; +~GENERATE +for (~SYM[10]=0;~SYM[10]<4;~SYM[10]=~SYM[10]+1) begin : ~SYM[11] + localparam n = 3; + wire [5:0] i; + assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:9] ~SYM[12]; +genvar ~SYM[13]; +~GENERATE +for (~SYM[13]=0;~SYM[13]<2;~SYM[13]=~SYM[13]+1) begin : ~SYM[14] + localparam n = 4; + wire [7:0] i; + assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:5] ~SYM[7]; +~GENERATE +if (1) begin +localparam n = 5; +wire [9:0] i; +assign i = ~SYM[12][0:9]; +always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase +end +end +~ENDGENERATE +~FI +assign ~RESULT = $unsigned(~SYM[7]); +// clz end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.ctz8#" + , "type" : "ctz8 :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "enc" + , "extension" : "inc" + , "content" : +"function [1:0] ~INCLUDENAME; + input [1:0] a; + case (a) + 2'b00: ~INCLUDENAME = 2'b10; + 2'b01: ~INCLUDENAME = 2'b01; + 2'b10: ~INCLUDENAME = 2'b00; + default: ~INCLUDENAME = 2'b00; + endcase +endfunction" + } + , "templateD" : +"// ctz8 begin +wire [0:7] ~GENSYM[v][1]; +genvar ~GENSYM[k][18]; +~GENERATE +for (~SYM[18]=0;~SYM[18]<8;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19] + assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]]; +end +~ENDGENERATE + +wire [0:7] ~GENSYM[e][2]; +genvar ~GENSYM[i][3]; +~GENERATE +for (~SYM[3]=0;~SYM[3]<4;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] + assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME(~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); +end +~ENDGENERATE + +reg [0:5] ~GENSYM[a][4]; +genvar ~GENSYM[i1][5]; +~GENERATE +for (~SYM[5]=0;~SYM[5]<2;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] + localparam n = 2; + wire [3:0] i; + assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:3] ~GENSYM[res][7]; +~GENERATE +if (1) begin +localparam n = 3; +wire [5:0] i; +assign i = ~SYM[4][0:5]; +always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase +end +end +~ENDGENERATE + +assign ~RESULT = $unsigned(~SYM[7]); +// ctz8 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.ctz16#" + , "type" : "ctz16 :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "enc" + , "extension" : "inc" + , "content" : +"function [1:0] ~INCLUDENAME; + input [1:0] a; + case (a) + 2'b00: ~INCLUDENAME = 2'b10; + 2'b01: ~INCLUDENAME = 2'b01; + 2'b10: ~INCLUDENAME = 2'b00; + default: ~INCLUDENAME = 2'b00; + endcase +endfunction" + } + , "templateD" : +"// ctz16 begin +wire [0:15] ~GENSYM[v][1]; +genvar ~GENSYM[k][18]; +~GENERATE +for (~SYM[18]=0;~SYM[18]<16;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19] + assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]]; +end +~ENDGENERATE + +wire [0:15] ~GENSYM[e][2]; +genvar ~GENSYM[i][3]; +~GENERATE +for (~SYM[3]=0;~SYM[3]<8;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] + assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME(~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); +end +~ENDGENERATE + +reg [0:11] ~GENSYM[a][4]; +genvar ~GENSYM[i1][5]; +~GENERATE +for (~SYM[5]=0;~SYM[5]<4;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] + localparam n = 2; + wire [3:0] i; + assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:7] ~GENSYM[b][9]; +genvar ~GENSYM[i2][10]; +~GENERATE +for (~SYM[10]=0;~SYM[10]<2;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] + localparam n = 3; + wire [5:0] i; + assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:4] ~GENSYM[res][7]; +~GENERATE +if (1) begin +localparam n = 4; +wire [7:0] i; +assign i = ~SYM[9][0:7]; +always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase +end +end +~ENDGENERATE + +assign ~RESULT = $unsigned(~SYM[7]); +// ctz16 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.ctz32#" + , "type" : "ctz32 :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "enc" + , "extension" : "inc" + , "content" : +"function [1:0] ~INCLUDENAME; + input [1:0] a; + case (a) + 2'b00: ~INCLUDENAME = 2'b10; + 2'b01: ~INCLUDENAME = 2'b01; + 2'b10: ~INCLUDENAME = 2'b00; + default: ~INCLUDENAME = 2'b00; + endcase +endfunction" + } + , "templateD" : +"// ctz32 begin +wire [0:31] ~GENSYM[v][1]; +genvar ~GENSYM[k][18]; +~GENERATE +for (~SYM[18]=0;~SYM[18]<32;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19] + assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]]; +end +~ENDGENERATE + +wire [0:31] ~GENSYM[e][2]; +genvar ~GENSYM[i][3]; +~GENERATE +for (~SYM[3]=0;~SYM[3]<16;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] + assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME(~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); +end +~ENDGENERATE + +reg [0:23] ~GENSYM[a][4]; +genvar ~GENSYM[i1][5]; +~GENERATE +for (~SYM[5]=0;~SYM[5]<8;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] + localparam n = 2; + wire [3:0] i; + assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:15] ~GENSYM[b][9]; +genvar ~GENSYM[i2][10]; +~GENERATE +for (~SYM[10]=0;~SYM[10]<4;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] + localparam n = 3; + wire [5:0] i; + assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:9] ~GENSYM[c][12]; +genvar ~GENSYM[i3][13]; +~GENERATE +for (~SYM[13]=0;~SYM[13]<2;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14] + localparam n = 4; + wire [7:0] i; + assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:5] ~GENSYM[res][7]; +~GENERATE +if (1) begin +localparam n = 5; +wire [9:0] i; +assign i = ~SYM[12][0:9]; +always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase +end +end +~ENDGENERATE + +assign ~RESULT = $unsigned(~SYM[7]); +// ctz32 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.ctz64#" + , "type" : "ctz64 :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "enc" + , "extension" : "inc" + , "content" : +"function [1:0] ~INCLUDENAME; + input [1:0] a; + case (a) + 2'b00: ~INCLUDENAME = 2'b10; + 2'b01: ~INCLUDENAME = 2'b01; + 2'b10: ~INCLUDENAME = 2'b00; + default: ~INCLUDENAME = 2'b00; + endcase +endfunction" + } + , "templateD" : +"// ctz64 begin +wire [0:63] ~GENSYM[v][1]; +genvar ~GENSYM[k][18]; +~GENERATE +for (~SYM[18]=0;~SYM[18]<64;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19] + assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]]; +end +~ENDGENERATE + +wire [0:63] ~GENSYM[e][2]; +genvar ~GENSYM[i][3]; +~GENERATE +for (~SYM[3]=0;~SYM[3]<32;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] + assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME(~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); +end +~ENDGENERATE + +reg [0:47] a; +genvar ~GENSYM[i1][5]; +~GENERATE +for (~SYM[5]=0;~SYM[5]<16;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] + localparam n = 2; + wire [3:0] i; + assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:31] ~GENSYM[b][9]; +genvar ~GENSYM[i2][10]; +~GENERATE +for (~SYM[10]=0;~SYM[10]<8;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] + localparam n = 3; + wire [5:0] i; + assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:19] ~GENSYM[c][12]; +genvar ~GENSYM[i3][13]; +~GENERATE +for (~SYM[13]=0;~SYM[13]<4;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14] + localparam n = 4; + wire [7:0] i; + assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:11] ~GENSYM[d][15]; +genvar ~GENSYM[i4][16]; +~GENERATE +for (~SYM[16]=0;~SYM[16]<2;~SYM[16]=~SYM[16]+1) begin : ~GENSYM[mux_stage4][17] + localparam n = 5; + wire [9:0] i; + assign i = ~SYM[12][~SYM[16]*10:~SYM[16]*10+9]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:6] ~GENSYM[res][7]; +~GENERATE +if (1) begin +localparam n = 6; +wire [11:0] i; +assign i = ~SYM[15][0:11]; +always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase +end +end +~ENDGENERATE + +assign ~RESULT = $unsigned(~SYM[7]); +// ctz64 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.ctz#" + , "type" : "ctz :: Word# -> Word#" + , "imports" : ["~INCLUDENAME.inc"] + , "include" : + { "name" : "enc" + , "extension" : "inc" + , "content" : +"function [1:0] ~INCLUDENAME; + input [1:0] a; + case (a) + 2'b00: ~INCLUDENAME = 2'b10; + 2'b01: ~INCLUDENAME = 2'b01; + 2'b10: ~INCLUDENAME = 2'b00; + default: ~INCLUDENAME = 2'b00; + endcase +endfunction" + } + , "templateD" : +"// ctz begin~IF ~IW64 ~THEN +wire [0:63] ~GENSYM[v][1]; +genvar ~GENSYM[k][18]; +~GENERATE +for (~SYM[18]=0;~SYM[18]<64;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19] + assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]]; +end +~ENDGENERATE + +wire [0:63] ~GENSYM[e][2]; +genvar ~GENSYM[i][3]; +~GENERATE +for (~SYM[3]=0;~SYM[3]<32;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] + assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME(~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); +end +~ENDGENERATE + +reg [0:47] ~GENSYM[a][4]; +genvar ~GENSYM[i1][5]; +~GENERATE +for (~SYM[5]=0;~SYM[5]<16;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] + localparam n = 2; + wire [3:0] i; + assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:31] ~GENSYM[b][9]; +genvar ~GENSYM[i2][10]; +~GENERATE +for (~SYM[10]=0;~SYM[10]<8;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] + localparam n = 3; + wire [5:0] i; + assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:19] ~GENSYM[c][12]; +genvar ~GENSYM[i3][13]; +~GENERATE +for (~SYM[13]=0;~SYM[13]<4;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14] + localparam n = 4; + wire [7:0] i; + assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:11] ~GENSYM[d][15]; +genvar ~GENSYM[i4][16]; +~GENERATE +for (~SYM[16]=0;~SYM[16]<2;~SYM[16]=~SYM[16]+1) begin : ~GENSYM[mux_stage4][17] + localparam n = 5; + wire [9:0] i; + assign i = ~SYM[12][~SYM[16]*10:~SYM[16]*10+9]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:6] ~GENSYM[res][7]; +~GENERATE +if (1) begin +localparam n = 6; +wire [11:0] i; +assign i = ~SYM[15][0:11]; +always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase +end +end +~ENDGENERATE +~ELSE +wire [0:31] ~SYM[1]; +genvar ~SYM[18]; +~GENERATE +for (~SYM[18]=0;~SYM[18]<32;~SYM[18]=~SYM[18]+1) begin : ~SYM[19] + assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]]; +end +~ENDGENERATE + +wire [0:31] ~SYM[2]; +genvar ~SYM[3]; +~GENERATE +for (~SYM[3]=0;~SYM[3]<16;~SYM[3]=~SYM[3]+1) begin : ~SYM[8] + assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME(~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); +end +~ENDGENERATE + +reg [0:23] ~SYM[4]; +genvar ~SYM[5]; +~GENERATE +for (~SYM[5]=0;~SYM[5]<8;~SYM[5]=~SYM[5]+1) begin : ~SYM[6] + localparam n = 2; + wire [3:0] i; + assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:15] ~SYM[9]; +genvar ~SYM[10]; +~GENERATE +for (~SYM[10]=0;~SYM[10]<4;~SYM[10]=~SYM[10]+1) begin : ~SYM[11] + localparam n = 3; + wire [5:0] i; + assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:9] ~SYM[12]; +genvar ~SYM[13]; +~GENERATE +for (~SYM[13]=0;~SYM[13]<2;~SYM[13]=~SYM[13]+1) begin : ~SYM[14] + localparam n = 4; + wire [7:0] i; + assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; + always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase + end +end +~ENDGENERATE + +reg [0:5] ~SYM[7]; +~GENERATE +if (1) begin +localparam n = 5; +wire [9:0] i; +assign i = ~SYM[12][0:9]; +always @(*) begin + case (i[n-1+n]) + 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; + default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; + endcase +end +end +~ENDGENERATE +~FI +assign ~RESULT = $unsigned(~SYM[7]); +// ctz end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.byteSwap16#" + , "type" : "byteSwap16# :: Word# -> Word#" + , "templateD" : +"// byteSwap16 begin~IF ~IW64 ~THEN +assign ~RESULT = {~VAR[w][0][63:16],~VAR[w][0][7:0],~VAR[w][0][15:8]};~ELSE +assign ~RESULT = {~VAR[w][0][31:16],~VAR[w][0][7:0],~VAR[w][0][15:8]};~FI +// byteSwap16 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.byteSwap32#" + , "type" : "byteSwap32# :: Word# -> Word#" + , "templateD" : +"// byteSwap32 begin~IF ~IW64 ~THEN +assign ~RESULT = {~VAR[w][0][63:32],~VAR[w][0][7:0],~VAR[w][0][15:8],~VAR[w][0][23:16],~VAR[w][0][31:24]};~ELSE +assign ~RESULT = {~VAR[w][0][7:0],~VAR[w][0][15:8],~VAR[w][0][23:16],~VAR[w][0][31:24]};~FI +// byteSwap32 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.byteSwap64#" + , "type" : "byteSwap64# :: Word# -> Word#" + , "templateD" : +"// byteSwap64 begin +assign ~RESULT = {~VAR[w][0][7:0],~VAR[w][0][15:8],~VAR[w][0][23:16],~VAR[w][0][31:24] + ,~VAR[w][0][39:32],~VAR[w][0][47:40],~VAR[w][0][55:48],~VAR[w][0][63:56]}; +// byteSwap64 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.byteSwap#" + , "type" : "byteSwap# :: Word# -> Word#" + , "templateD" : +"// byteSwap begin~IF ~IW64 ~THEN +assign ~RESULT = {~VAR[w][0][7:0],~VAR[w][0][15:8],~VAR[w][0][23:16],~VAR[w][0][31:24] + ,~VAR[w][0][39:32],~VAR[w][0][47:40],~VAR[w][0][55:48],~VAR[w][0][63:56]};~ELSE +assign ~RESULT = {~VAR[w][0][7:0],~VAR[w][0][15:8],~VAR[w][0][23:16],~VAR[w][0][31:24]};~FI +// byteSwap end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.narrow8Int#" + , "type" : "narrow8Int# :: Int# -> Int#" + , "templateD" : +"// narrow8Int begin +assign ~RESULT = $signed(~VAR[i][0][7:0]); +// narrow8Int end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.narrow16Int#" + , "type" : "narrow16Int# :: Int# -> Int#" + , "templateD" : +"// narrow16Int begin +assign ~RESULT = $signed(~VAR[i][0][15:0]); +// narrow16Int end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.narrow32Int#" + , "type" : "narrow32Int# :: Int# -> Int#" + , "templateD" : +"// narrow32Int begin +assign ~RESULT = $signed(~VAR[i][0][31:0]); +// narrow32Int end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.narrow8Word#" + , "type" : "narrow8Int# :: Word# -> Word#" + , "templateD" : +"// narrow8Word begin +assign ~RESULT = $unsigned(~VAR[w][0][7:0]); +// narrow8Word end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.narrow16Word#" + , "type" : "narrow16Word# :: Word# -> Word#" + , "templateD" : +"// narrow16Word begin +assign ~RESULT = $unsigned(~VAR[w][0][15:0]); +// narrow16Word end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.narrow32Word#" + , "type" : "narrow32Int# :: Word# -> Word#" + , "templateD" : +"// narrow32Word begin +assign ~RESULT = $unsigned(~VAR[w][0][31:0]); +// narrow32Word end" + } + } +, { "Primitive" : + { "name" : "GHC.Prim.dataToTag#" + , "primType" : "Function" + } + } +, { "Primitive" : + { "name" : "GHC.Prim.tagToEnum#" + , "primType" : "Function" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.unsafeCoerce#" + , "type" : "unsafeCoerce# :: a -> b" + , "templateE" : "~ARG[0]" + } + } +] diff --git a/prims/verilog/GHC_Types.json b/prims/verilog/GHC_Types.json new file mode 100644 --- /dev/null +++ b/prims/verilog/GHC_Types.json @@ -0,0 +1,24 @@ +[ { "Primitive" : + { "name" : "GHC.Types.MkCoercible" + , "primType" : "Constructor" + } + } +, { "BlackBox" : + { "name" : "GHC.Types.C#" + , "type" : "I# :: Char# -> Char" + , "templateE" : "~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "GHC.Types.I#" + , "type" : "I# :: Int# -> Int" + , "templateE" : "~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "GHC.Types.W#" + , "type" : "W# :: Word# -> Word" + , "templateE" : "~ARG[0]" + } + } +] diff --git a/prims/verilog/GHC_Word.json b/prims/verilog/GHC_Word.json new file mode 100644 --- /dev/null +++ b/prims/verilog/GHC_Word.json @@ -0,0 +1,25 @@ +[ { "BlackBox" : + { "name" : "GHC.Word.W8#" + , "type" : "W8# :: Word# -> Word8" + , "templateD" : "assign ~RESULT = $unsigned(~ARG[0]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Word.W16#" + , "type" : "W16# :: Word# -> Word16" + , "templateD" : "assign ~RESULT = $unsigned(~ARG[0]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Word.W32#" + , "type" : "W32# :: Word# -> Word32" + , "templateD" : "assign ~RESULT = $unsigned(~ARG[0]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Word.W64#" + , "type" : "W64# :: Word# -> Word64" + , "templateD" : "assign ~RESULT = $unsigned(~ARG[0]);" + } + } +] diff --git a/prims/vhdl/Clash_Explicit_BlockRam.json b/prims/vhdl/Clash_Explicit_BlockRam.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/Clash_Explicit_BlockRam.json @@ -0,0 +1,96 @@ +[ { "BlackBox" : + { "name" : "Clash.Explicit.BlockRam.blockRam#" + , "type" : +"blockRam# + :: HasCallStack -- ARG[0] + => Clock dom gated -- clk, ARG[1] + -> Vec n a -- init, ARG[2] + -> Signal dom Int -- rd, ARG[3] + -> Signal dom Bool -- wren, ARG[4] + -> Signal dom Int -- wr, ARG[5] + -> Signal dom a -- din, ARG[6] + -> Signal dom a" + , "templateD" : +"-- blockRam begin +~GENSYM[~COMPNAME_blockRam][0] : block + signal ~GENSYM[RAM][1] : ~TYP[2] := ~LIT[2]; + signal ~GENSYM[rd][3] : integer range 0 to ~LENGTH[~TYP[2]] - 1; + signal ~GENSYM[wr][4] : integer range 0 to ~LENGTH[~TYP[2]] - 1;~IF ~ISGATED[1] ~THEN + signal ~GENSYM[clk][5] : std_logic; + signal ~GENSYM[ce][6] : boolean;~ELSE ~FI +begin + ~SYM[3] <= to_integer(~ARG[3]) + -- pragma translate_off + mod ~LENGTH[~TYP[2]] + -- pragma translate_on + ; + + ~SYM[4] <= to_integer(~ARG[5]) + -- pragma translate_off + mod ~LENGTH[~TYP[2]] + -- pragma translate_on + ; +~IF ~VIVADO ~THEN ~IF ~ISGATED[1] ~THEN + (~SYM[5],~SYM[6]) <= ~ARG[1]; + ~GENSYM[blockRam_sync][7] : process(~SYM[5]) + begin + if rising_edge(~SYM[5]) then + if ~SYM[6] then + if ~ARG[4] then + ~SYM[1](~SYM[4]) <= ~TOBV[~ARG[6]][~TYP[6]]; + end if; + ~RESULT <= fromSLV(~SYM[1](~SYM[3])) + -- pragma translate_off + after 1 ps + -- pragma translate_on + ; + end if; + end if; + end process;~ELSE + ~SYM[7] : process(~ARG[1]) + begin + if rising_edge(~ARG[1]) then + if ~ARG[4] then + ~SYM[1](~SYM[4]) <= ~TOBV[~ARG[6]][~TYP[6]]; + end if; + ~RESULT <= fromSLV(~SYM[1](~SYM[3])) + -- pragma translate_off + after 1 ps + -- pragma translate_on + ; + end if; + end process;~FI ~ELSE ~IF ~ISGATED[1] ~THEN + (~SYM[5],~SYM[6]) <= ~ARG[1]; + ~SYM[7] : process(~SYM[5]) + begin + if rising_edge(~SYM[5]) then + if ~ARG[4] and ~SYM[6] then + ~SYM[1](~SYM[4]) <= ~ARG[6]; + end if; + if ~SYM[6] then + ~RESULT <= ~SYM[1](~SYM[3]) + -- pragma translate_off + after 1 ps + -- pragma translate_on + ; + end if; + end if; + end process;~ELSE + ~SYM[7] : process(~ARG[1]) + begin + if rising_edge(~ARG[1]) then + if ~ARG[4] then + ~SYM[1](~SYM[4]) <= ~ARG[6]; + end if; + ~RESULT <= ~SYM[1](~SYM[3]) + -- pragma translate_off + after 1 ps + -- pragma translate_on + ; + end if; + end process;~FI ~FI +end block; +--end blockRam" + } + } +] diff --git a/prims/vhdl/Clash_Explicit_BlockRam_File.json b/prims/vhdl/Clash_Explicit_BlockRam_File.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/Clash_Explicit_BlockRam_File.json @@ -0,0 +1,111 @@ +[ { "BlackBox" : + { "name" : "Clash.Explicit.BlockRam.File.blockRamFile#" + , "type" : +"blockRamFile# + :: (KnownNat m, HasCallStack)-- (ARG[0],ARG]1) + => Clock dom gated -- clk, ARG[2] + -> SNat n -- sz, ARG[3] + -> FilePath -- file, ARG[4] + -> Signal dom Int -- rd, ARG[5] + -> Signal dom Bool -- wren, ARG[6] + -> Signal dom Int -- wr, ARG[7] + -> Signal dom (BitVector m) -- din, ARG[8] + -> Signal dom (BitVector m)" + , "templateD" : +"-- blockRamFile begin +~GENSYM[~COMPNAME_blockRamFile][0] : block + type ~GENSYM[RamType][6] is array(natural range <>) of bit_vector(~LIT[0]-1 downto 0); + + impure function ~GENSYM[InitRamFromFile][1] (RamFileName : in string) return ~SYM[6] is + FILE RamFile : text open read_mode is RamFileName; + variable RamFileLine : line; + variable RAM : ~SYM[6](0 to ~LIT[3]-1); + begin + for i in RAM'range loop + readline(RamFile,RamFileLine); + read(RamFileLine,RAM(i)); + end loop; + return RAM; + end function; + + signal ~GENSYM[RAM][2] : ~SYM[6](0 to ~LIT[3]-1) := ~SYM[1](~FILE[~LIT[4]]); + signal ~GENSYM[rd][4] : integer range 0 to ~LIT[3]-1; + signal ~GENSYM[wr][5] : integer range 0 to ~LIT[3]-1;~IF ~ISGATED[2] ~THEN + signal ~GENSYM[clk][7] : std_logic; + signal ~GENSYM[ce][8] : boolean;~ELSE ~FI +begin + ~SYM[4] <= to_integer(~ARG[5]) + -- pragma translate_off + mod ~LIT[3] + -- pragma translate_on + ; + + ~SYM[5] <= to_integer(~ARG[7]) + -- pragma translate_off + mod ~LIT[3] + -- pragma translate_on + ; + ~IF ~VIVADO ~THEN ~IF ~ISGATED[2] ~THEN + (~SYM[7],~SYM[8]) <= ~ARG[2]; + ~GENSYM[blockRamFile_sync][9] : process(~SYM[7]) + begin + if rising_edge(~SYM[7]) then + if ~SYM[8] then + if ~ARG[6] then + ~SYM[2](~SYM[5]) <= to_bitvector(~ARG[8]); + end if; + ~RESULT <= to_stdlogicvector(~SYM[2](~SYM[4])) + -- pragma translate_off + after 1 ps + -- pragma translate_on + ; + end if; + end if; + end process;~ELSE + ~SYM[9] : process(~ARG[2]) + begin + if rising_edge(~ARG[2]) then + if ~ARG[6] then + ~SYM[2](~SYM[5]) <= to_bitvector(~ARG[8]); + end if; + ~RESULT <= to_stdlogicvector(~SYM[2](~SYM[4])) + -- pragma translate_off + after 1 ps + -- pragma translate_on + ; + end if; + end process;~FI ~ELSE ~IF ~ISGATED[2] ~THEN + (~SYM[7],~SYM[8]) <= ~ARG[2]; + ~SYM[9] : process(~SYM[7]) + begin + if rising_edge(~SYM[7]) then + if ~ARG[6] and ~SYM[8] then + ~SYM[2](~SYM[5]) <= to_bitvector(~ARG[8]); + end if; + if ~SYM[8] then + ~RESULT <= to_stdlogicvector(~SYM[2](~SYM[4])) + -- pragma translate_off + after 1 ps + -- pragma translate_on + ; + end if; + end if; + end process;~ELSE + ~SYM[9] : process(~ARG[2]) + begin + if rising_edge(~ARG[2]) then + if ~ARG[6] then + ~SYM[2](~SYM[5]) <= to_bitvector(~ARG[8]); + end if; + ~RESULT <= to_stdlogicvector(~SYM[2](~SYM[4])) + -- pragma translate_off + after 1 ps + -- pragma translate_on + ; + end if; + end process;~FI ~FI +end block; +-- blockRamFile end" + } + } +] diff --git a/prims/vhdl/Clash_Explicit_DDR.json b/prims/vhdl/Clash_Explicit_DDR.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/Clash_Explicit_DDR.json @@ -0,0 +1,292 @@ +[ { "BlackBox" : + { "name" : "Clash.Explicit.DDR.ddrIn#" + , "type" : +"ddrIn# :: forall a slow fast n pFast gated synchronous. + ( HasCallStack -- ARG[0] + , fast ~ Dom n pFast -- ARG[1] + , slow ~ Dom n (2*pFast)) -- ARG[2] + => Clock slow gated -- ARG[3] + -> Reset slow synchronous -- ARG[4] + -> a -- ARG[5] + -> a -- ARG[6] + -> a -- ARG[7] + -> Signal fast a -- ARG[8] + -> Signal slow (a,a)" + , "templateD" : +"-- ddrIn begin +~GENSYM[~COMPNAME_ddrIn][0] : block + signal ~GENSYM[data_Pos][1] : ~TYP[8]; + signal ~GENSYM[data_Neg][2] : ~TYP[8]; + signal ~GENSYM[data_Neg_Latch][3] : ~TYP[8]; +~IF ~ISGATED[3] ~THEN + signal ~GENSYM[clk][4] : std_logic; + signal ~GENSYM[ce][5] : boolean; +~ELSE ~FI +begin +~IF ~ISGATED[3] ~THEN + ~IF ~ISSYNC[4] ~THEN + -- gated sync + ------------- + ~GENSYM[~COMPNAME_ddrIn_pos][6] : process(~SYM[4]) + begin + if rising_edge(~SYM[4]) then + if ~ARG[4] = '1' then + ~SYM[1] <= ~ARG[6]; + elsif ~SYM[5] then + ~SYM[1] <= ~ARG[8]; + end if; + end if; + end process; + + ~GENSYM[~COMPNAME_ddrIn_neg][7] : process(~SYM[4]) + begin + if falling_edge(~SYM[4]) then + if ~ARG[4] = '1' then + ~SYM[2] <= ~ARG[7]; + elsif ~SYM[5] then + ~SYM[2] <= ~ARG[8]; + end if; + end if; + end process; + + ~GENSYM[~COMPNAME_ddrIn_neg_latch][8] : process(~SYM[4]) + begin + if rising_edge(~SYM[4]) then + if ~ARG[4] = '1' then + ~SYM[3] <= ~ARG[5]; + elsif ~SYM[5] then + ~SYM[3] <= ~SYM[2]; + end if; + end if; + end process; + ~ELSE + -- gated async + -------------- + ~SYM[6] : process(~SYM[4],~ARG[4]~VARS[8]) + begin + if ~ARG[4] = '1' then + ~SYM[1] <= ~ARG[6]; + elsif ~SYM[5] and rising_edge(~SYM[4]) then + ~SYM[1] <= ~ARG[8]; + end if; + end process; + + ~SYM[7] : process(~SYM[4],~ARG[4]~VARS[8]) + begin + if ~ARG[4] = '1' then + ~SYM[2] <= ~ARG[7]; + elsif ~SYM[5] and falling_edge(~SYM[4]) then + ~SYM[2] <= ~ARG[8]; + end if; + end process; + + ~SYM[8] : process(~SYM[4],~ARG[4],~SYM[2]) + begin + if ~ARG[4] = '1' then + ~SYM[3] <= ~ARG[5]; + elsif ~SYM[5] and rising_edge(~SYM[4]) then + ~SYM[3] <= ~SYM[2]; + end if; + end process; + ~FI +~ELSE + ~IF ~ISSYNC[4] ~THEN + -- ungated sync + --------------- + ~SYM[6] : process(~ARG[3]) + begin + if rising_edge(~ARG[3]) then + if ~ARG[4] = '1' then + ~SYM[1] <= ~ARG[6]; + else + ~SYM[1] <= ~ARG[8]; + end if; + end if; + end process; + + ~SYM[7] : process(~ARG[3]) + begin + if falling_edge(~ARG[3]) then + if ~ARG[4] = '1' then + ~SYM[2] <= ~ARG[7]; + else + ~SYM[2] <= ~ARG[8]; + end if; + end if; + end process; + + ~SYM[8] : process(~ARG[3]) + begin + if rising_edge(~ARG[3]) then + if ~ARG[4] = '1' then + ~SYM[3] <= ~ARG[5]; + else + ~SYM[3] <= ~SYM[2]; + end if; + end if; + end process; + ~ELSE + -- ungated async + ---------------- + ~SYM[6] : process(~ARG[3],~ARG[4]~VARS[8]) + begin + if ~ARG[4] = '1' then + ~SYM[1] <= ~ARG[6]; + elsif rising_edge(~ARG[3]) then + ~SYM[1] <= ~ARG[8]; + end if; + end process; + + ~SYM[7] : process(~ARG[3],~ARG[4]~VARS[8]) + begin + if ~ARG[4] = '1' then + ~SYM[2] <= ~ARG[7]; + elsif falling_edge(~ARG[3]) then + ~SYM[2] <= ~ARG[8]; + end if; + end process; + + ~SYM[8] : process(~ARG[3],~ARG[4],~SYM[2]) + begin + if ~ARG[4] = '1' then + ~SYM[3] <= ~ARG[5]; + elsif rising_edge(~ARG[3]) then + ~SYM[3] <= ~SYM[2]; + end if; + end process; + ~FI +~FI + ~RESULT <= (~SYM[3], ~SYM[1]); +~IF ~ISGATED[3] ~THEN + (~SYM[4],~SYM[5]) <= ~ARG[3]; +~ELSE ~FI +end block; +-- ddrIn end" + } + } +, { "BlackBox" : + { "name" : "Clash.Explicit.DDR.ddrOut#" + , "type" : +"ddrOut# :: ( HasCallStack -- ARG[0] + , fast ~ Dom n pFast -- ARG[1] + , slow ~ Dom n (2*pFast)) -- ARG[2] + => Clock slow gated -- ARG[3] + -> Reset slow synchronous -- ARG[4] + -> a -- ARG[5] + -> Signal slow a -- ARG[6] + -> Signal slow a -- ARG[7] + -> Signal fast a" + , "templateD" : +"-- ddrOut begin +~GENSYM[~COMPNAME_ddrIn][0] : block + signal ~GENSYM[data_Pos][1] : ~TYP[5]; + signal ~GENSYM[data_Neg][2] : ~TYP[5]; +~IF ~ISGATED[3] ~THEN + signal ~GENSYM[clk][3] : std_logic; + signal ~GENSYM[ce][4] : boolean; +~ELSE ~FI +begin +~IF ~ISGATED[3] ~THEN + ~IF ~ISSYNC[4] ~THEN + -- gated sync + ------------- + ~GENSYM[~COMPNAME_ddrOut_pos][5] : process(~SYM[3]) + begin + if rising_edge(~SYM[3]) then + if ~ARG[4] = '1' then + ~SYM[1] <= ~ARG[5]; + elsif ~SYM[4] then + ~SYM[1] <= ~ARG[6]; + end if; + end if; + end process; + + ~GENSYM[~COMPNAME_ddrOut_neg][6] : process(~SYM[3]) + begin + if rising_edge(~SYM[3]) then + if ~ARG[4] = '1' then + ~SYM[2] <= ~ARG[5]; + elsif ~SYM[4] then + ~SYM[2] <= ~ARG[7]; + end if; + end if; + end process; + ~ELSE + -- gated async + -------------- + ~SYM[5] : process(~SYM[3],~ARG[4]~VARS[6]) + begin + if ~ARG[4] = '1' then + ~SYM[1] <= ~ARG[5]; + elsif rising_edge(~SYM[3]) then + ~SYM[1] <= ~ARG[6]; + end if; + end process; + + ~SYM[6] : process(~SYM[3],~ARG[4]~VARS[7]) + begin + if ~ARG[4] = '1' then + ~SYM[2] <= ~ARG[5]; + elsif rising_edge(~SYM[3]) then + ~SYM[2] <= ~ARG[7]; + end if; + end process; + ~FI +~ELSE + ~IF ~ISSYNC[4] ~THEN + -- ungated sync + --------------- + ~SYM[5] : process(~ARG[3]) + begin + if rising_edge(~ARG[3]) then + if ~ARG[4] = '1' then + ~SYM[1] <= ~ARG[5]; + else + ~SYM[1] <= ~ARG[6]; + end if; + end if; + end process; + + ~SYM[6] : process(~ARG[3]) + begin + if rising_edge(~ARG[3]) then + if ~ARG[4] = '1' then + ~SYM[2] <= ~ARG[5]; + else + ~SYM[2] <= ~ARG[7]; + end if; + end if; + end process; + ~ELSE + -- ungated async + ---------------- + ~SYM[5] : process(~ARG[3],~ARG[4]~VARS[6]) + begin + if ~ARG[4] = '1' then + ~SYM[1] <= ~ARG[5]; + elsif rising_edge(~ARG[3]) then + ~SYM[1] <= ~ARG[6]; + end if; + end process; + + ~SYM[6] : process(~ARG[3],~ARG[4]~VARS[7]) + begin + if ~ARG[4] = '1' then + ~SYM[2] <= ~ARG[5]; + elsif rising_edge(~ARG[3]) then + ~SYM[2] <= ~ARG[7]; + end if; + end process; + ~FI +~FI +~IF ~ISGATED[3] ~THEN + (~SYM[3],~SYM[4]) <= ~ARG[3]; + ~RESULT <= ~SYM[1] when (~SYM[3] = '1' and ~SYM[4]) else ~SYM[2]; +~ELSE + ~RESULT <= ~SYM[1] when (~ARG[3] = '1') else ~SYM[2]; +~FI +end block; +-- ddrOut end" + } + } +] diff --git a/prims/vhdl/Clash_Explicit_RAM.json b/prims/vhdl/Clash_Explicit_RAM.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/Clash_Explicit_RAM.json @@ -0,0 +1,63 @@ +[ { "BlackBox" : + { "name" : "Clash.Explicit.RAM.asyncRam#" + , "type" : +"asyncRam# + :: HasCallStack -- ARG[0] + => Clock wdom wgated -- ^ wclk, ARG[1] + -> Clock rdom rgated -- ^ rclk, ARG[2] + -> SNat n -- ^ sz, ARG[3] + -> Signal rdom Int -- ^ rd, ARG[4] + -> Signal wdom Bool -- ^ en, ARG[5] + -> Signal wdom Int -- ^ wr, ARG[6] + -> Signal wdom a -- ^ din, ARG[7] + -> Signal rdom a" + , "templateD" : +"-- asyncRam begin +~GENSYM[~COMPNAME_asyncRam][0] : block~IF ~VIVADO ~THEN + type ~GENSYM[RamType][4] is array(natural range <>) of std_logic_vector(~SIZE[~TYP[7]]-1 downto 0);~ELSE + type ~SYM[4] is array(natural range <>) of ~TYP[7];~FI + signal ~GENSYM[RAM][1] : ~SYM[4](0 to ~LIT[3]-1); + signal ~GENSYM[rd][2] : integer range 0 to ~LIT[3] - 1; + signal ~GENSYM[wr][3] : integer range 0 to ~LIT[3] - 1;~IF ~ISGATED[1] ~THEN + signal ~GENSYM[clk][5] : std_logic; + signal ~GENSYM[ce][6] : boolean;~ELSE ~FI +begin + ~SYM[2] <= to_integer(~ARG[4]) + -- pragma translate_off + mod ~LIT[3] + -- pragma translate_on + ; + + ~SYM[3] <= to_integer(~ARG[6]) + -- pragma translate_off + mod ~LIT[3] + -- pragma translate_on + ; + ~IF ~ISGATED[1] ~THEN + (~SYM[5],~SYM[6]) <= ~ARG[1]; + ~GENSYM[asyncRam_sync][7] : process(~SYM[5]) + begin + if rising_edge(~SYM[5]) then + if (~ARG[5] and ~SYM[6]) then~IF ~VIVADO ~THEN + ~SYM[1](~SYM[3]) <= ~TOBV[~ARG[7]][~TYP[7]];~ELSE + ~SYM[1](~SYM[3]) <= ~ARG[7];~FI + end if; + end if; + end process;~ELSE + ~SYM[7] : process(~ARG[1]) + begin + if rising_edge(~ARG[1]) then + if ~ARG[5] then~IF ~VIVADO ~THEN + ~SYM[1](~SYM[3]) <= ~TOBV[~ARG[7]][~TYP[7]];~ELSE + ~SYM[1](~SYM[3]) <= ~ARG[7];~FI + end if; + end if; + end process;~FI + ~IF ~VIVADO ~THEN + ~RESULT <= ~FROMBV[~SYM[1](~SYM[2])][~TYP[7]];~ELSE + ~RESULT <= ~SYM[1](~SYM[2]);~FI +end block; +-- asyncRam end" + } + } +] diff --git a/prims/vhdl/Clash_Explicit_ROM.json b/prims/vhdl/Clash_Explicit_ROM.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/Clash_Explicit_ROM.json @@ -0,0 +1,62 @@ +[ { "BlackBox" : + { "name" : "Clash.Explicit.ROM.rom#" + , "type" : +"rom# :: KnownNat n -- ARG[0] + => Clock dom gated -- clk, ARG[1] + -> Vec n a -- init, ARG[2] + -> Signal dom Int -- rd, ARG[3] + -> Signal dom a" + , "templateD" : +"-- rom begin +~GENSYM[~COMPNAME_rom][0] : block + signal ~GENSYM[ROM][1] : ~TYP[2]; + signal ~GENSYM[rd][2] : integer range 0 to ~LIT[0]-1;~IF ~ISGATED[1] ~THEN + signal ~GENSYM[clk][3] : std_logic; + signal ~GENSYM[ce][4] : boolean;~ELSE ~FI +begin + ~SYM[1] <= ~ARG[2]; + + ~SYM[2] <= to_integer(~ARG[3]) + -- pragma translate_off + mod ~LIT[0] + -- pragma translate_on + ; + ~IF ~ISGATED[1] ~THEN + (~SYM[3],~SYM[4]) <= ~ARG[1]; + ~GENSYM[romSync][5] : process (~SYM[3]) + begin + if (rising_edge(~SYM[3])) then + if ~SYM[4] then~IF ~VIVADO ~THEN + ~RESULT <= ~FROMBV[~SYM[1](~SYM[2])][~TYPO] + -- pragma translate_off + after 1 ps + -- pragma translate_on + ;~ELSE + ~RESULT <= ~SYM[1](~SYM[2]) + -- pragma translate_off + after 1 ps + -- pragma translate_on + ;~FI + end if; + end if; + end process;~ELSE + ~SYM[5] : process (~ARG[1]) + begin + if (rising_edge(~ARG[1])) then~IF ~VIVADO ~THEN + ~RESULT <= ~FROMBV[~SYM[1](~SYM[2])][~TYPO] + -- pragma translate_off + after 1 ps + -- pragma translate_on + ;~ELSE + ~RESULT <= ~SYM[1](~SYM[2]) + -- pragma translate_off + after 1 ps + -- pragma translate_on + ;~FI + end if; + end process;~FI +end block; +-- rom end" + } + } +] diff --git a/prims/vhdl/Clash_Explicit_ROM_File.json b/prims/vhdl/Clash_Explicit_ROM_File.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/Clash_Explicit_ROM_File.json @@ -0,0 +1,65 @@ +[ { "BlackBox" : + { "name" : "Clash.Explicit.ROM.File.romFile#" + , "type" : +"romFile# :: KnownNat m -- ARG[0] + => Clock dom gated -- clk, ARG[1] + -> SNat n -- sz, ARG[2] + -> FilePath -- file, ARG[3] + -> Signal dom Int -- rd, ARG[4] + -> Signal dom (BitVector m)" + , "templateD" : +"-- romFile begin +~GENSYM[~COMPNAME_romFile][0] : block + type ~GENSYM[RomType][4] is array(natural range <>) of bit_vector(~LIT[0]-1 downto 0); + + impure function ~GENSYM[InitRomFromFile][1] (RomFileName : in string) return ~SYM[4] is + FILE RomFile : text open read_mode is RomFileName; + variable RomFileLine : line; + variable ROM : ~SYM[4](0 to ~LIT[2]-1); + begin + for i in ROM'range loop + readline(RomFile,RomFileLine); + read(RomFileLine,ROM(i)); + end loop; + return ROM; + end function; + + signal ~GENSYM[ROM][2] : ~SYM[4](0 to ~LIT[2]-1) := ~SYM[1](~FILE[~LIT[3]]); + signal ~GENSYM[rd][3] : integer range 0 to ~LIT[2]-1;~IF ~ISGATED[1] ~THEN + signal ~GENSYM[clk][5] : std_logic; + signal ~GENSYM[ce][6] : boolean; ~ELSE ~FI +begin + ~SYM[3] <= to_integer(~ARG[4]) + -- pragma translate_off + mod ~LIT[2] + -- pragma translate_on + ; + ~IF ~ISGATED[1] ~THEN + (~SYM[5],~SYM[6]) <= ~ARG[1]; + ~GENSYM[romFileSync][7] : process (~SYM[5]) + begin + if (rising_edge(~SYM[5])) then + if ~SYM[6] then + ~RESULT <= to_stdlogicvector(~SYM[2](~SYM[3])) + -- pragma translate_off + after 1 ps + -- pragma translate_on + ; + end if; + end if; + end process;~ELSE + ~SYM[7] : process (~ARG[1]) + begin + if (rising_edge(~ARG[1])) then + ~RESULT <= to_stdlogicvector(~SYM[2](~SYM[3])) + -- pragma translate_off + after 1 ps + -- pragma translate_on + ; + end if; + end process;~FI +end block; +-- romFile end" + } + } +] diff --git a/prims/vhdl/Clash_Explicit_Testbench.json b/prims/vhdl/Clash_Explicit_Testbench.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/Clash_Explicit_Testbench.json @@ -0,0 +1,56 @@ +[ { "BlackBox" : + { "name" : "Clash.Explicit.Testbench.assert" + , "type" : +"assert + :: (Eq a,Show a) -- (ARG[0],ARG[1]) + => Clock domain gated -- ARG[2] + -> Reset domain synchronous -- ARG[3] + -> String -- ARG[4] + -> Signal domain a -- Checked value (ARG[5]) + -> Signal domain a -- Expected value (ARG[6]) + -> Signal domain b -- Return valued (ARG[7]) + -> Signal domain b" + , "templateD" : +"-- assert begin +~GENSYM[assert][0] : block + -- pragma translate_off + function ~GENSYM[slv2string][1] (slv : std_logic_vector) return STRING is + variable result : string (1 to slv'length); + variable res_l : string (1 to 3); + variable r : integer; + begin + r := 1; + for i in slv'range loop + res_l := std_logic'image(slv(i)); + result(r) := res_l(2); + r := r + 1; + end loop; + return result; + end; + signal ~GENSYM[actual][2] : ~TYP[5]; + signal ~GENSYM[expected][3] : ~TYP[6]; +~IF ~ISGATED[2] ~THEN + signal ~GENSYM[clk][4] : std_logic; + signal ~GENSYM[ce][5] : boolean; +~ELSE ~FI + -- pragma translate_on +begin + -- pragma translate_off + ~SYM[2] <= ~ARG[5]; + ~SYM[3] <= ~ARG[6]; + process(~IF ~ISGATED[2] ~THEN~SYM[4]~ELSE~ARG[2]~FI~IF ~ISSYNC[3] ~THEN ~ELSE,~ARG[3]~FI) is + begin + if (rising_edge(~IF ~ISGATED[2] ~THEN~SYM[4]~ELSE~ARG[2]~FI)~IF ~ISSYNC[3] ~THEN ~ELSE or falling_edge(~ARG[3])~FI) then + assert (std_match(toSLV(~SYM[2]),toSLV(~SYM[3]))) report (~LIT[4] & \", expected: \" & ~SYM[1](toSLV(~SYM[3])) & \", actual: \" & ~SYM[1](toSLV(~SYM[2]))) severity error; + end if; + end process; + -- pragma translate_on +~IF ~ISGATED[2] ~THEN + (~SYM[4],~SYM[5]) <= ~ARG[2]; +~ELSE ~FI + ~RESULT <= ~ARG[7]; +end block; +-- assert end" + } + } +] diff --git a/prims/vhdl/Clash_Intel_ClockGen.json b/prims/vhdl/Clash_Intel_ClockGen.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/Clash_Intel_ClockGen.json @@ -0,0 +1,59 @@ +[ { "BlackBox" : + { "name" : "Clash.Intel.ClockGen.altpll" + , "type" : +"altpll + :: SSymbol name -- ARG[0] + -> Clock pllIn 'Source -- ARG[1] + -> Reset pllIn 'Asynchronous -- ARG[2] + -> (Clock pllOut 'Source, Signal pllOut Bool)" + , "templateD" : +"-- altpll begin +~GENSYM[altpll][0] : block + signal ~GENSYM[pllOut][1] : std_logic; + signal ~GENSYM[locked][2] : std_logic; + signal ~GENSYM[pllLock][3] : boolean; + + component ~NAME[0] + port (inclk0 : in std_logic; + areset : in std_logic; + c0 : out std_logic; + locked : out std_logic); + end component; +begin + ~GENSYM[altpll_inst][4] : component ~NAME[0] port map (~ARG[1],~ARG[2],~SYM[1],~SYM[2]); + ~SYM[3] <= true when ~SYM[2] = '1' else false; + ~RESULT <= (~SYM[1],~SYM[3]); +end block; +-- altpll end" + } + } +, { "BlackBox" : + { "name" : "Clash.Intel.ClockGen.alteraPll" + , "type" : +"alteraPll + :: SSymbol name -- ARG[0] + -> Clock pllIn 'Source -- ARG[1] + -> Reset pllIn 'Asynchronous -- ARG[2] + -> (Clock pllOut 'Source, Signal pllOut Bool)" + , "templateD" : +"-- alteraPll begin +~GENSYM[alteraPll][0] : block + signal ~GENSYM[pllOut][1] : std_logic; + signal ~GENSYM[locked][2] : std_logic; + signal ~GENSYM[pllLock][3] : boolean; + + component ~NAME[0] + port (refclk : in std_logic; + rst : in std_logic; + outclk_0 : out std_logic; + locked : out std_logic); + end component; +begin + ~GENSYM[alteraPll_inst][4] : component ~NAME[0] port map (~ARG[1],~ARG[2],~SYM[1],~SYM[2]); + ~SYM[3] <= true when ~SYM[2] = '1' else false; + ~RESULT <= (~SYM[1],~SYM[3]); +end block; +-- alteraPll end" + } + } +] diff --git a/prims/vhdl/Clash_Intel_DDR.json b/prims/vhdl/Clash_Intel_DDR.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/Clash_Intel_DDR.json @@ -0,0 +1,101 @@ +[ { "BlackBox" : + { "name" : "Clash.Intel.DDR.altddioIn" + , "type" : +"altddioIn + :: ( HasCallStack -- ARG[0] + , fast ~ Dom n pFast -- ARG[1] + , slow ~ Dom n (2*pFast) -- ARG[2] + , KnownNat m ) -- ARG[3] + => SSymbol deviceFamily -- ARG[4] + -> Clock slow gated -- ARG[5] + -> Reset slow synchronous -- ARG[6] + -> Signal fast (BitVector m) -- ARG[7] + -> Signal slow (BitVector m,BitVector m)" + , "libraries" : ["altera_mf"] + , "imports" : ["altera_mf.altera_mf_components.all"] + , "templateD" : +"-- altddioIn begin +~GENSYM[~COMPNAME_ALTDDIO_IN][0] : block + signal ~GENSYM[dataout_l][1] : ~TYP[7]; + signal ~GENSYM[dataout_h][2] : ~TYP[7];~IF ~ISGATED[5] ~THEN + signal ~GENSYM[clk][4] : std_logic; + signal ~GENSYM[ce][5] : boolean; + signal ~GENSYM[ce_logic][6]: std_logic;~ELSE ~FI +begin~IF ~ISGATED[5] ~THEN + (~SYM[4],~SYM[5]) <= ~ARG[5]; + ~SYM[6] <= '1' when (~SYM[5]) else '0';~ELSE ~FI + ~GENSYM[~COMPNAME_ALTDDIO_IN][7] : ALTDDIO_IN + GENERIC MAP ( + intended_device_family => ~LIT[4], + invert_input_clocks => \"OFF\", + lpm_hint => \"UNUSED\", + lpm_type => \"altddio_in\", + power_up_high => \"OFF\", + width => ~SIZE[~TYP[7]] + ) + PORT MAP (~IF ~ISSYNC[6] ~THEN + sclr => ~ARG[6],~ELSE + aclr => ~ARG[6],~FI + datain => ~ARG[7],~IF ~ISGATED[5] ~THEN + inclock => ~SYM[4], + inclocken => ~SYM[6],~ELSE + inclock => ~ARG[5],~FI + dataout_h => ~SYM[2], + dataout_l => ~SYM[1] + ); + ~RESULT <= (~SYM[1],~SYM[2]); +end block; +-- altddioIn end" + } + } +, { "BlackBox" : + { "name" : "Clash.Intel.DDR.altddioOut#" + , "type" : +"altddioOut# + :: ( HasCallStack -- ARG[0] + , fast ~ Dom n pFast -- ARG[1] + , slow ~ Dom n (2*pFast) -- ARG[2] + , KnownNat m ) -- ARG[3] + => SSymbol deviceFamily -- ARG[4] + -> Clock slow gated -- ARG[5] + -> Reset slow synchronous -- ARG[6] + -> Signal slow (BitVector m) -- ARG[7] + -> Signal slow (BitVector m) -- ARG[8] + -> Signal fast (BitVector m)" + , "libraries" : ["altera_mf"] + , "imports" : ["altera_mf.altera_mf_components.all"] + , "templateD" : +"-- altddioOut begin +~GENSYM[~COMPNAME_ALTDDIO_OUT][0] : block ~IF ~ISGATED[5] ~THEN + signal ~GENSYM[clk][1] : std_logic; + signal ~GENSYM[ce][2] : boolean; + signal ~GENSYM[ce_logic][3] : std_logic; ~ELSE ~FI +begin~IF ~ISGATED[5] ~THEN + (~SYM[1],~SYM[2]) <= ~ARG[5]; + ~SYM[3] <= '1' when (~SYM[2]) else '0'; ~ELSE ~FI + ~GENSYM[~COMPNAME_ALTDDIO_OUT][7] : ALTDDIO_OUT + GENERIC MAP ( + extend_oe_disable => \"OFF\", + intended_device_family => ~LIT[4], + invert_output => \"OFF\", + lpm_hint => \"UNUSED\", + lpm_type => \"altddio_out\", + oe_reg => \"UNREGISTERED\", + power_up_high => \"OFF\", + width => ~SIZE[~TYPO] + ) + PORT MAP (~IF ~ISSYNC[6] ~THEN + sclr => ~ARG[6],~ELSE + aclr => ~ARG[6],~FI ~IF ~ISGATED[5] ~THEN + outclock => ~SYM[1], + outclocken => ~SYM[3],~ELSE + outclock => ~ARG[5],~FI + datain_h => ~ARG[7], + datain_l => ~ARG[8], + dataout => ~RESULT + ); +end block; +-- altddioOut end" + } + } +] diff --git a/prims/vhdl/Clash_Prelude_ROM.json b/prims/vhdl/Clash_Prelude_ROM.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/Clash_Prelude_ROM.json @@ -0,0 +1,27 @@ +[ { "BlackBox" : + { "name" : "Clash.Prelude.ROM.asyncRom#" + , "type" : +"asyncRom# :: KnownNat n -- ^ ARG[0] + => Vec n a -- ^ ARG[1] + -> Int -- ^ ARG[2] + -> a" + , "templateD" : +"-- asyncRom begin +~GENSYM[asyncRom][0] : block + signal ~GENSYM[ROM][1] : ~TYP[1]; + signal ~GENSYM[rd][2] : integer range 0 to ~LIT[0]-1; +begin + ~SYM[1] <= ~ARG[1]; + + ~SYM[2] <= to_integer(~ARG[2]) + -- pragma translate_off + mod ~LIT[0] + -- pragma translate_on + ;~IF ~VIVADO ~THEN + ~RESULT <= ~FROMBV[~SYM[1](~SYM[2])][~TYPO];~ELSE + ~RESULT <= ~SYM[1](~SYM[2]);~FI +end block; +-- asyncRom end" + } + } +] diff --git a/prims/vhdl/Clash_Prelude_ROM_File.json b/prims/vhdl/Clash_Prelude_ROM_File.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/Clash_Prelude_ROM_File.json @@ -0,0 +1,40 @@ +[ { "BlackBox" : + { "name" : "Clash.Prelude.ROM.File.asyncRomFile#" + , "type" : +"asyncRomFile# :: KnownNat m -- ARG[0] + => SNat n -- sz, ARG[1] + -> FilePath -- file, ARG[2] + -> Int -- rd, ARG[3] + -> BitVector m" + , "templateD" : +"-- asyncRomFile begin +~GENSYM[asyncROMFile][0] : block + type ~GENSYM[RomType][4] is array(natural range <>) of bit_vector(~LIT[0]-1 downto 0); + + impure function ~GENSYM[InitRomFromFile][1] (RomFileName : in string) return ~SYM[4] is + FILE RomFile : text open read_mode is RomFileName; + variable RomFileLine : line; + variable ROM : ~SYM[4](0 to ~LIT[1]-1); + begin + for i in ROM'range loop + readline(RomFile,RomFileLine); + read(RomFileLine,ROM(i)); + end loop; + return ROM; + end function; + + signal ~GENSYM[ROM][2] : ~SYM[4](0 to ~LIT[1]-1) := ~SYM[1](~FILE[~LIT[2]]); + signal ~GENSYM[rd][3] : integer range 0 to ~LIT[1]-1; +begin + ~SYM[3] <= to_integer(~ARG[3]) + -- pragma translate_off + mod ~LIT[1] + -- pragma translate_on + ; + + ~RESULT <= to_stdlogicvector(~SYM[2](~SYM[3])); +end block; +-- asyncRomFile end" + } + } +] diff --git a/prims/vhdl/Clash_Promoted_Nat.json b/prims/vhdl/Clash_Promoted_Nat.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/Clash_Promoted_Nat.json @@ -0,0 +1,34 @@ +[ { "BlackBox" : + { "name" : "Clash.Promoted.Nat.powSNat" + , "type" : "Clash.Promoted.Nat.powSNat :: SNat a -> SNat b -> SNat (a^b)" + , "templateE" : "~LIT[0] ** ~LIT[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Promoted.Nat.flogBaseSNat" + , "type" : "Clash.Promoted.Nat.flogBaseSNat :: (2 <= base, 1 <= x) + => SNat base -- ARG[2] + -> SNat x -- ARG[3] + -> SNat (FLog base x)" + , "templateE" : "integer(floor(log(real(~LIT[3]),real(~LIT[2]))))" + } + } +, { "BlackBox" : + { "name" : "Clash.Promoted.Nat.clogBaseSNat" + , "type" : "Clash.Promoted.Nat.clogBaseSNat :: (2 <= base, 1 <= x) + => SNat base -- ARG[2] + -> SNat x -- ARG[3] + -> SNat (CLog base x)" + , "templateE" : "integer(ceiling(log(real(~LIT[3]),real(~LIT[2]))))" + } + } +, { "BlackBox" : + { "name" : "Clash.Promoted.Nat.logBaseSNat" + , "type" : "Clash.Promoted.Nat.logBaseSNat :: (FLog base x ~ CLog base x) + => SNat base -- ARG[1] + -> SNat x -- ARG[2] + -> SNat (Log base x)" + , "templateE" : "integer(ceiling(log(real(~LIT[2]),real(~LIT[1]))))" + } + } +] diff --git a/prims/vhdl/Clash_Signal_Internal.json b/prims/vhdl/Clash_Signal_Internal.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/Clash_Signal_Internal.json @@ -0,0 +1,278 @@ +[ { "BlackBox" : + { "name" : "Clash.Signal.Internal.delay#" + , "type" : +"register# + :: HasCallStack -- ARG[0] + => Clock domain gated -- ARG[1] + -> Signal clk a -- ARG[2] + -> Signal clk a" + , "templateD" : +"-- register begin~IF ~ISGATED[1] ~THEN +~GENSYM[~COMPNAME_delay][0] : block + signal ~GENSYM[clk][1] : std_logic; + signal ~GENSYM[ce][2] : boolean; +begin + (~SYM[1],~SYM[2]) <= ~ARG[1]; + ~GENSYM[~COMPNAME_dly][3] : process(~SYM[1]) + begin + if rising_edge(~SYM[1]) then + if ~SYM[2] then + ~RESULT <= ~ARG[2] + -- pragma translate_off + after 1 ps + -- pragma translate_on + ; + end if; + end if; + end process; +end block;~ELSE +~SYM[0] : process(~ARG[1]) +begin + if rising_edge(~ARG[1]) then + ~RESULT <= ~ARG[2] + -- pragma translate_off + after 1 ps + -- pragma translate_on + ; + end if; +end process;~FI +-- register end" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.register#" + , "type" : +"register# + :: HasCallStack -- ARG[0] + => Clock domain gated -- ARG[1] + -> Reset domain synchronous -- ARG[2] + -> a -- ARG[3] + -> Signal clk a -- ARG[4] + -> Signal clk a" + , "templateD" : +"-- register begin~IF ~ISGATED[1] ~THEN +~GENSYM[~COMPNAME_register][0] : block + signal ~GENSYM[clk][1] : std_logic; + signal ~GENSYM[ce][2] : boolean; +begin + (~SYM[1],~SYM[2]) <= ~ARG[1];~IF ~ISSYNC[2] ~THEN + ~GENSYM[~COMPNAME_reg][3] : process(~SYM[1]) + begin + if rising_edge(~SYM[1]) then + if ~ARG[2] = '1' then + ~RESULT <= ~ARG[3] + -- pragma translate_off + after 1 ps + -- pragma translate_on + ; + elsif ~SYM[2] then + ~RESULT <= ~ARG[4] + -- pragma translate_off + after 1 ps + -- pragma translate_on + ; + end if; + end if; + end process;~ELSE + ~SYM[3] : process(~SYM[1],~ARG[2]~VARS[3]) + begin + if ~ARG[2] = '1' then + ~RESULT <= ~ARG[3]; + elsif rising_edge(~SYM[1]) then + if ~SYM[2] then + ~RESULT <= ~ARG[4] + -- pragma translate_off + after 1 ps + -- pragma translate_on + ; + end if; + end if; + end process;~FI +end block;~ELSE ~IF ~ISSYNC[2] ~THEN +~SYM[0] : process(~ARG[1]) +begin + if rising_edge(~ARG[1]) then + if ~ARG[2] = '1' then + ~RESULT <= ~ARG[3] + -- pragma translate_off + after 1 ps + -- pragma translate_on + ; + else + ~RESULT <= ~ARG[4] + -- pragma translate_off + after 1 ps + -- pragma translate_on + ; + end if; + end if; +end process;~ELSE +~SYM[0] : process(~ARG[1],~ARG[2]~VARS[3]) +begin + if ~ARG[2] = '1' then + ~RESULT <= ~ARG[3] + -- pragma translate_off + after 1 ps + -- pragma translate_on + ; + elsif rising_edge(~ARG[1]) then + ~RESULT <= ~ARG[4] + -- pragma translate_off + after 1 ps + -- pragma translate_on + ; + end if; +end process;~FI~FI +-- register end" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.clockGate" + , "type" : +"clockGate + :: Clock domain gated -- ARG[0] + -> Signal domain Bool -- ARG[1] + -> Clcok domain 'Gated" + , "templateD" : +"-- clockGate begin~IF ~ISGATED[0] ~THEN +~RESULT <= (~ARG[0].~TYPM[0]_sel0,~ARG[0].~TYPM[0]_sel1 and ~ARG[1]);~ELSE +~RESULT <= (~ARG[0],~ARG[1]);~FI +-- clockGate end" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.clockGen" + , "type" : +"clockGen + :: (domain ~ Dom nm period -- ARG[0] + ,KnownSymbol nm -- ARG[1] + ,KnownNat period) -- ARG[2] + => Clock domain Source" + , "templateD" : +"-- pragma translate_off +~GENSYM[clkGen][0] : process is + constant ~GENSYM[half_period][1] : time := ~LIT[2]0 ps / 2; +begin + ~RESULT <= '0'; + wait for 3000 ps; + loop + ~RESULT <= not ~RESULT; + wait for ~SYM[1]; + ~RESULT <= not ~RESULT; + wait for ~SYM[1]; + end loop; + wait; +end process; +-- pragma translate_on" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.tbClockGen" + , "type" : +"tbClockGen + :: (domain ~ Dom nm period -- ARG[0] + ,KnownSymbol nm -- ARG[1] + ,KnownNat period) -- ARG[2] + => Signal domain Bool -- ARG[3] + -> Clock domain Source" + , "templateD" : +"-- pragma translate_off +~GENSYM[clkGen][0] : process is + constant ~GENSYM[half_period][1] : time := ~LIT[2]0 ps / 2; +begin + ~RESULT <= '0'; + wait for 3000 ps; + while ~ARG[3] loop + ~RESULT <= not ~RESULT; + wait for ~SYM[1]; + ~RESULT <= not ~RESULT; + wait for ~SYM[1]; + end loop; + wait; +end process; +-- pragma translate_on" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.asyncResetGen" + , "type" : +"asyncResetGen :: Reset domain 'Asynchronous" + , "templateD" : +"-- pragma translate_off +~RESULT <= '1', + '0' after 2000 ps; +-- pragma translate_on" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.syncResetGen" + , "type" : +"syncResetGen :: ( domain ~ 'Dom n clkPeriod + , KnownNat clkPeriod ) + => Reset domain 'Synchronous" + , "templateD" : +"-- pragma translate_off +~RESULT <= '1', + '0' after (2999 ps + ~LIT[1]0 ps); +-- pragma translate_on" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.unsafeFromAsyncReset" + , "type" : +"unsafeFromAsyncReset :: Reset domain Asynchronous -> Signal domain Bool" + , "templateD" : "~RESULT <= true when ~ARG[0] = '1' else false;" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.unsafeToAsyncReset" + , "type" : +"unsafeToAsyncReset :: Signal domain Bool -> Reset domain Asynchronous" + , "templateD" : "~RESULT <= '1' when ~ARG[0] else '0';" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.fromSyncReset" + , "type" : +"fromSyncReset :: Reset domain Synchronous -> Signal domain Bool" + , "templateD" : "~RESULT <= true when ~ARG[0] = '1' else false;" + } + } +, { "BlackBox" : + { "name" : "Clash.Signal.Internal.unsafeToSyncReset" + , "type" : +"unsafeToSyncReset :: Signal domain Bool -> Reset domain Synchronous" + , "templateD" : "~RESULT <= '1' when ~ARG[0] else '0';" + } + } +, { "Primitive" : + { "name" : "Clash.Signal.Internal.signal#" + , "primType" : "Function" + } + } +, { "Primitive" : + { "name" : "Clash.Signal.Internal.mapSignal#" + , "primType" : "Function" + } + } +, { "Primitive" : + { "name" : "Clash.Signal.Internal.appSignal#" + , "primType" : "Function" + } + } +, { "Primitive" : + { "name" : "Clash.Signal.Internal.foldr#" + , "primType" : "Function" + } + } +, { "Primitive" : + { "name" : "Clash.Signal.Internal.traverse#" + , "primType" : "Function" + } + } +, { "Primitive" : + { "name" : "Clash.Signal.Internal.joinSignal#" + , "primType" : "Function" + } + } +] diff --git a/prims/vhdl/Clash_Sized_Internal_BitVector.json b/prims/vhdl/Clash_Sized_Internal_BitVector.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/Clash_Sized_Internal_BitVector.json @@ -0,0 +1,496 @@ +[ { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.size#" + , "type" : "size# :: KnownNat n => BitVector n -> Int" + , "templateE" : "to_signed(~LIT[0],~SIZE[~TYPO])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.maxIndex#" + , "type" : "maxIndex# :: KnownNat n => BitVector n -> Int" + , "templateE" : "to_signed(~LIT[0] - 1,~SIZE[~TYPO])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.high" + , "type" : "high :: Bit" + , "templateE" : "'1'" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.low" + , "type" : "low :: Bit" + , "templateE" : "'0'" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.pack#" + , "type" : "pack# :: Bit -> BitVector 1" + , "templateE" : "std_logic_vector'(0 => ~ARG[0])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.unpack#" + , "type" : "unpack# :: BitVector 1 -> Bit" + , "templateE" : "~VAR[bv][0](0)" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.eq##" + , "type" : "eq## :: Bit -> Bit -> Bool" + , "templateE" : "~ARG[0] = ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.neq##" + , "type" : "neq## :: Bit -> Bit -> Bool" + , "templateE" : "~ARG[0] /= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.lt##" + , "type" : "lt## :: Bit -> Bit -> Bool" + , "templateE" : "~ARG[0] < ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.ge##" + , "type" : "ge## :: Bit -> Bit -> Bool" + , "templateE" : "~ARG[0] >= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.gt##" + , "type" : "gt## :: Bit -> Bit -> Bool" + , "templateE" : "~ARG[0] > ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.le##" + , "type" : "le## :: Bit -> Bit -> Bool" + , "templateE" : "~ARG[0] <= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.fromInteger##" + , "type" : "fromInteger# :: Integer -> Bit" + , "templateE" : "~VAR[i][0](0)" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.and##" + , "type" : "and## :: Bit -> Bit -> Bit" + , "templateE" : "~ARG[0] and ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.or##" + , "type" : "or## :: Bit -> Bit -> Bit" + , "templateE" : "~ARG[0] or ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.xor##" + , "type" : "xor## :: Bit -> Bit -> Bit" + , "templateE" : "~ARG[0] xor ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.complement##" + , "type" : "complement## :: Bit -> Bit" + , "templateE" : "not ~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.++#" + , "type" : "(++#) :: KnownNat m => BitVector n -> BitVector m -> BitVector (n + m)" + , "templateE" : "std_logic_vector'(std_logic_vector'(~ARG[1]) & std_logic_vector'(~ARG[2]))" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.reduceAnd#" + , "type" : "reduceAnd# :: KnownNat n => BitVector n -> Bit" + , "templateD" : +"-- reduceAnd begin +~GENSYM[reduceAnd][0] : block + function and_reduce (arg : std_logic_vector) return std_logic is + variable upper, lower : std_logic; + variable half : integer; + variable argi : std_logic_vector (arg'length - 1 downto 0); + variable result : std_logic; + begin + if (arg'length < 1) then + result := '1'; + else + argi := arg; + if (argi'length = 1) then + result := argi(argi'left); + else + half := (argi'length + 1) / 2; -- lsb-biased tree + upper := and_reduce (argi (argi'left downto half)); + lower := and_reduce (argi (half - 1 downto argi'right)); + result := upper and lower; + end if; + end if; + return result; + end; +begin + ~RESULT <= and_reduce(~ARG[1]); +end block; +-- reduceAnd end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.reduceOr#" + , "type" : "reduceOr# :: BitVector n -> Bit" + , "templateD" : +"-- reduceOr begin +~GENSYM[reduceOr][0] : block + function or_reduce (arg : std_logic_vector) return std_logic is + variable upper, lower : std_logic; + variable half : integer; + variable argi : std_logic_vector (arg'length - 1 downto 0); + variable result : std_logic; + begin + if (arg'length < 1) then + result := '0'; + else + argi := arg; + if (argi'length = 1) then + result := argi(argi'left); + else + half := (argi'length + 1) / 2; -- lsb-biased tree + upper := or_reduce (argi (argi'left downto half)); + lower := or_reduce (argi (half - 1 downto argi'right)); + result := upper or lower; + end if; + end if; + return result; + end; +begin + ~RESULT <= or_reduce(~ARG[0]); +end block; +-- reduceOr end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.reduceXor#" + , "type" : "reduceXor# :: BitVector n -> Bit" + , "templateD" : +"-- reduceXor begin +~GENSYM[reduceXor][0] : block + function xor_reduce (arg : std_logic_vector) return std_logic is + variable upper, lower : std_logic; + variable half : integer; + variable argi : std_logic_vector (arg'length - 1 downto 0); + variable result : std_logic; + begin + if (arg'length < 1) then + result := '0'; + else + argi := arg; + if (argi'length = 1) then + result := argi(argi'left); + else + half := (argi'length + 1) / 2; -- lsb-biased tree + upper := xor_reduce (argi (argi'left downto half)); + lower := xor_reduce (argi (half - 1 downto argi'right)); + result := upper xor lower; + end if; + end if; + return result; + end; +begin + ~RESULT <= xor_reduce(~ARG[0]); +end block; +-- reduceXor end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.index#" + , "type" : +"index# :: KnownNat n -- ARG[0] + => BitVector n -- ARG[1] + -> Int -- ARG[2] + -> Bit" + , "templateD" : +"-- indexBitVector begin~IF ~ISVAR[1] ~THEN +~GENSYM[indexBitVector][0] : block + signal ~GENSYM[vec_index][1] : integer range 0 to ~LIT[0]-1; +begin + ~SYM[1] <= to_integer(~ARG[2]) + -- pragma translate_off + mod ~LIT[0] + -- pragma translate_on + ; + + ~RESULT <= ~ARG[1](~SYM[1]); +end block;~ELSE +~SYM[0] : block + signal ~SYM[1] : integer range 0 to ~LIT[0]-1; +begin + ~SYM[1] <= to_integer(~ARG[2]) + -- pragma translate_off + mod ~LIT[0] + -- pragma translate_on + ; + + ~RESULT <= ~VAR[bv][1](~SYM[1]); +end block;~FI +-- indexBitVector end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.replaceBit#" + , "type" : +"replaceBit# :: KnownNat n -- ARG[0] + => BitVector n -- ARG[1] + -> Int -- ARG[2] + -> Bit -- ARG[3] + -> BitVector n" + , "templateD" : +"-- replaceBit begin +~GENSYM[replaceBit][0] : block + signal ~GENSYM[vec_index][1] : integer range 0 to ~LIT[0]-1; +begin + ~SYM[1] <= to_integer(~ARG[2]) + -- pragma translate_off + mod ~LIT[0] + -- pragma translate_on + ; + + process(~SYM[1],~VAR[b][3]~VARS[1]) + variable ~GENSYM[ivec][2] : ~TYP[1]; + begin + ~SYM[2] := ~ARG[1]; + ~SYM[2](~SYM[1]) := ~ARG[3]; + ~RESULT <= ~SYM[2]; + end process; +end block; +-- replaceBit end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.setSlice#" + , "type" : +"setSlice# :: BitVector (m + 1 + i) -- ARG[0] + -> SNat m -- ARG[1] + -> SNat n -- ARG[2] + -> BitVector (m + 1 - n) -- ARG[3] + -> BitVector (m + 1 + i)" + , "templateD" : +"-- setSlice begin +~GENSYM[setSlice][0] : process(~VAR[bv][0]~VARS[3]) + variable ~GENSYM[ivec][1] : ~TYP[0]; +begin + ~SYM[1] := ~ARG[0]; + ~SYM[1](~LIT[1] downto ~LIT[2]) := ~VAR[bv][3]; + ~RESULT <= ~SYM[1]; +end process; +-- setSlice end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.slice#" + , "type" : +"slice# :: BitVector (m + 1 + i) -- ARG[0] + -> SNat m -- ARG[1] + -> SNat n -- ARG[2] + -> BitVector (m + 1 - n)" + , "templateE" : "~VAR[bv][0](~LIT[1] downto ~LIT[2])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.split#" + , "type" : +"split# :: KnownNat n -- ARG[0] + => BitVector (m + n) -- ARG[1] + -> (BitVector m, BitVector n)" + , "templateE" : "(~VAR[bv][1](~VAR[bv][1]'high downto ~LIT[0]),~VAR[bv][1](~LIT[0]-1 downto 0))" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.msb#" + , "type" : +"msb# :: KnownNat n -- ARG[0] + => BitVector n -- ARG[1] + -> Bit" + , "templateE" : "~IF ~LIT[0] ~THEN ~VAR[bv][1](~VAR[bv][1]'high) ~ELSE \"0\" ~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.lsb#" + , "type" : +"lsb# :: BitVector n -- ARG[0] + -> Bit" + , "templateE" : "~IF ~SIZE[~TYP[0]] ~THEN ~VAR[bv][0](0) ~ELSE \"0\" ~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.eq#" + , "type" : "eq# :: BitVector n -> BitVector n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] = ~ARG[1]~ELSEtrue~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.neq#" + , "type" : "neq# :: BitVector n -> BitVector n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] /= ~ARG[1]~ELSEfalse~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.lt#" + , "type" : "lt# :: BitVector n -> BitVector n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] < ~ARG[1]~ELSEfalse~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.ge#" + , "type" : "ge# :: BitVector n -> BitVector n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] >= ~ARG[1]~ELSEtrue~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.gt#" + , "type" : "gt# :: BitVector n -> BitVector n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] > ~ARG[1]~ELSEfalse~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.le#" + , "type" : "le# :: BitVector n -> BitVector n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] <= ~ARG[1]~ELSEtrue~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.minBound#" + , "type" : "minBound# :: BitVector n" + , "templateE" : "~IF~SIZE[~TYPO]~THENstd_logic_vector'(~SIZE[~TYPO]-1 downto 0 => '0')~ELSEstd_logic_vector'(0 downto 1 => '0')~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.maxBound#" + , "type" : "maxBound# :: KnownNat n => BitVector n" + , "templateE" : "~IF~SIZE[~TYPO]~THENstd_logic_vector'(~SIZE[~TYPO]-1 downto 0 => '1')~ELSEstd_logic_vector'(0 downto 1 => '1')~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.+#" + , "type" : "(+#) :: KnownNat n => BitVector n -> BitVector n -> BitVector n" + , "templateE" : "std_logic_vector(unsigned(~ARG[1]) + unsigned(~ARG[2]))" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.-#" + , "type" : "(-#) :: KnownNat n => BitVector n -> BitVector n -> BitVector n" + , "templateE" : "std_logic_vector(unsigned(~ARG[1]) - unsigned(~ARG[2]))" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.*#" + , "type" : "(*#) :: KnownNat n => BitVector n -> BitVector n -> BitVector n" + , "templateE" : "std_logic_vector(resize(unsigned(~ARG[1]) * unsigned(~ARG[2]), ~LIT[0]))" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.negate#" + , "type" : "negate# :: KnownNat n => BitVector n -> BitVector n" + , "templateE" : "std_logic_vector(-(signed(~ARG[1])))" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.fromInteger#" + , "type" : "fromInteger# :: KnownNat n => Integer -> BitVector n" + , "templateE" : "std_logic_vector(resize(unsigned(std_logic_vector(~ARG[1])),~LIT[0]))" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.plus#" + , "type" : "plus# :: BitVector m -> BitVector n -> BitVector (Max m n + 1)" + , "templateE" : "std_logic_vector(resize(unsigned(~ARG[0]),~SIZE[~TYPO]) + resize(unsigned(~ARG[1]),~SIZE[~TYPO]))" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.minus#" + , "type" : "minus# :: (KnownNat m, KnownNat n) => BitVector m -> BitVector n -> BitVector (Max m n + 1)" + , "templateE" : "std_logic_vector(resize(unsigned(~ARG[2]),~SIZE[~TYPO]) - resize(unsigned(~ARG[3]),~SIZE[~TYPO]))" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.times#" + , "type" : "times# :: BitVector m -> BitVector n -> BitVector (m + n)" + , "templateE" : "std_logic_vector(unsigned(~ARG[0]) * unsigned(~ARG[1]))" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.quot#" + , "type" : "quot# :: BitVector n -> BitVector n -> BitVector n" + , "templateE" : "std_logic_vector(unsigned(~ARG[0]) / unsigned(~ARG[1]))" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.rem#" + , "type" : "rem# :: BitVector n -> BitVector n -> BitVector n" + , "templateE" : "std_logic_vector(unsigned(~ARG[0]) rem unsigned(~ARG[1]))" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.toInteger#" + , "type" : "toInteger# :: BitVector n -> Integer" + , "templateE" : "~IF~SIZE[~TYP[0]]~THENsigned(std_logic_vector(resize(unsigned(~ARG[0]),~SIZE[~TYPO])))~ELSEto_signed(0,64)~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.and#" + , "type" : "and# :: BitVector n -> BitVector n -> BitVector n" + , "templateE" : "~ARG[0] and ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.or#" + , "type" : "or# :: BitVector n -> BitVector n -> BitVector n" + , "templateE" : "~ARG[0] or ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.xor#" + , "type" : "xor# :: BitVector n -> BitVector n -> BitVector n" + , "templateE" : "~ARG[0] xor ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.complement#" + , "type" : "complement# :: KnownNat n => BitVector n -> BitVector n" + , "templateE" : "not ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.shiftL#" + , "type" : "shiftL# :: KnownNat n => BitVector n -> Int -> BitVector n" + , "templateE" : "std_logic_vector(shift_left(unsigned(~ARG[1]),to_integer(~ARG[2])))" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.shiftR#" + , "type" : "shiftR# :: KnownNat n => BitVector n -> Int -> BitVector n" + , "templateE" : "std_logic_vector(shift_right(unsigned(~ARG[1]),to_integer(~ARG[2])))" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.rotateL#" + , "type" : "rotateL# :: KnownNat n => BitVector n -> Int -> BitVector n" + , "templateE" : "std_logic_vector(rotate_left(unsigned(~ARG[1]),to_integer(~ARG[2])))" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.rotateR#" + , "type" : "rotateR# :: KnownNat n => BitVector n -> Int -> BitVector n" + , "templateE" : "std_logic_vector(rotate_right(unsigned(~ARG[1]),to_integer(~ARG[2])))" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.BitVector.resize#" + , "type" : "resize# :: KnownNat m => BitVector n -> BitVector m" + , "templateE" : "std_logic_vector(resize(unsigned(~ARG[1]),~LIT[0]))" + } + } +] diff --git a/prims/vhdl/Clash_Sized_Internal_Index.json b/prims/vhdl/Clash_Sized_Internal_Index.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/Clash_Sized_Internal_Index.json @@ -0,0 +1,121 @@ +[ { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.pack#" + , "type" : "pack# :: Index n -> BitVector (CLog 2 n)" + , "templateE" : "std_logic_vector(~ARG[0])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.unpack#" + , "type" : "unpack# :: KnownNat n => BitVector (CLog 2 n) -> Index n" + , "templateE" : "unsigned(~ARG[1])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.eq#" + , "type" : "eq# :: Index n -> Index n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] = ~ARG[1]~ELSEtrue~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.neq#" + , "type" : "neq# :: Index n -> Index n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] /= ~ARG[1]~ELSEfalse~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.lt#" + , "type" : "lt# :: Index n -> Index n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] < ~ARG[1]~ELSEfalse~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.ge#" + , "type" : "ge# :: Index n -> Index n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] >= ~ARG[1]~ELSEtrue~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.gt#" + , "type" : "gt# :: Index n -> Index n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] > ~ARG[1]~ELSEfalse~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.le#" + , "type" : "le# :: Index n -> Index n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] <= ~ARG[1]~ELSEtrue~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.maxBound#" + , "type" : "maxBound# :: KnownNat n => Index n" + , "templateE" : "to_unsigned(~LIT[0]-1,~SIZE[~TYPO])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.+#" + , "type" : "(+#) :: KnownNat n => Index n -> Index n -> Index n" + , "templateE" : "~ARG[1] + ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.-#" + , "type" : "(-#) :: KnownNat n => Index n -> Index n -> Index n" + , "templateE" : "~ARG[1] - ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.*#" + , "type" : "(*#) :: KnownNat n => Index n -> Index n -> Index n" + , "templateE" : "resize(~ARG[1] * ~ARG[2], ~SIZE[~TYPO])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.fromInteger#" + , "type" : "fromInteger# :: KnownNat n => Integer -> Index n" + , "templateE" : "resize(unsigned(std_logic_vector(~ARG[1])),~SIZE[~TYPO])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.plus#" + , "type" : "Index m -> Index n -> Index (m + n - 1)" + , "templateE" : "resize(~ARG[0],~SIZE[~TYPO]) + resize(~ARG[1],~SIZE[~TYPO])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.minus#" + , "type" : "Index m -> Index n -> Index (m + n - 1)" + , "templateE" : "resize(~ARG[0],~SIZE[~TYPO]) - resize(~ARG[1],~SIZE[~TYPO])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.times#" + , "type" : "Index m -> Index n -> Index (((m-1) * (n-1)) + 1)" + , "templateE" : "resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.quot#" + , "type" : "quot# :: Index n -> Index n -> Index n" + , "templateE" : "~ARG[0] / ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.rem#" + , "type" : "rem# :: Index n -> Index n -> Index n" + , "templateE" : "~ARG[0] rem ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.toInteger#" + , "type" : "toInteger# :: Index n -> Integer" + , "templateE" : "~IF~SIZE[~TYP[0]]~THENsigned(std_logic_vector(resize(~ARG[0],~SIZE[~TYPO])))~ELSEto_signed(0,64)~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Index.resize#" + , "type" : "resize# :: KnownNat m => Index n -> Index m" + , "templateE" : "resize(~ARG[1],~SIZE[~TYPO])" + } + } +] diff --git a/prims/vhdl/Clash_Sized_Internal_Signed.json b/prims/vhdl/Clash_Sized_Internal_Signed.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/Clash_Sized_Internal_Signed.json @@ -0,0 +1,222 @@ +[ { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.size#" + , "type" : "size# :: KnownNat n => Signed n -> Int" + , "templateE" : "to_signed(~LIT[0],~SIZE[~TYPO])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.pack#" + , "type" : "pack# :: KnownNat n => Signed n -> BitVector n" + , "templateE" : "std_logic_vector(~ARG[1])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.unpack#" + , "type" : "unpack# :: KnownNat n => BitVector n -> Signed n" + , "templateE" : "signed(~ARG[1])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.eq#" + , "type" : "eq# :: Signed n -> Signed n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] = ~ARG[1]~ELSEtrue~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.neq#" + , "type" : "neq# :: Signed n -> Signed n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] /= ~ARG[1]~ELSEfalse~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.lt#" + , "type" : "lt# :: Signed n -> Signed n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] < ~ARG[1]~ELSEfalse~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.ge#" + , "type" : "ge# :: Signed n -> Signed n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] >= ~ARG[1]~ELSEtrue~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.gt#" + , "type" : "gt# :: Signed n -> Signed n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] > ~ARG[1]~ELSEfalse~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.le#" + , "type" : "le# :: Signed n -> Signed n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] <= ~ARG[1]~ELSEtrue~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.minBound#" + , "type" : "minBound# :: KnownNat n => Signed n" + , "comment" : "the quantification with signed gives the array an ascending index" + , "templateE" : "~IF~SIZE[~TYPO]~THENsigned'(0 => '1', 1 to ~LIT[0]-1 => '0')~ELSEsigned'(1 downto 0 => '0')~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.maxBound#" + , "type" : "maxBound# :: KnownNat n => Signed n" + , "comment" : "the quantification with signed gives the array an ascending index" + , "templateE" : "~IF~SIZE[~TYPO]~THENsigned'(0 => '0', 1 to ~LIT[0]-1 => '1')~ELSEsigned'(1 downto 0 => '0')~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.+#" + , "type" : "(+#) :: KnownNat n => Signed n -> Signed n -> Signed n" + , "templateE" : "~ARG[1] + ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.-#" + , "type" : "(-#) :: KnownNat n => Signed n -> Signed n -> Signed n" + , "templateE" : "~ARG[1] - ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.*#" + , "type" : "(*#) :: KnownNat n => Signed n -> Signed n -> Signed n" + , "templateE" : "resize(~ARG[1] * ~ARG[2], ~LIT[0])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.negate#" + , "type" : "negate# :: KnownNat n => Signed n -> Signed n" + , "templateE" : "-~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.abs#" + , "type" : "abs# :: KnownNat n => Signed n -> Signed n" + , "templateE" : "abs ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.fromInteger#" + , "type" : "fromInteger# :: KnownNat n => Integer -> Signed (n :: Nat)" + , "templateE" : "resize(~ARG[1],~LIT[0])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.plus#" + , "type" : "plus# :: Signed m -> Signed n -> Signed (1 + Max m n)" + , "templateE" : "resize(~ARG[0],~SIZE[~TYPO]) + resize(~ARG[1],~SIZE[~TYPO])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.minus#" + , "type" : "minus# :: Signed m -> Signed n -> Signed (1 + Max m n)" + , "templateE" : "resize(~ARG[0],~SIZE[~TYPO]) - resize(~ARG[1],~SIZE[~TYPO])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.times#" + , "type" : "times# :: Signed m -> Signed n -> Signed (m + n)" + , "templateE" : "~ARG[0] * ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.quot#" + , "type" : "quot# :: Signed n -> Signed n -> Signed n" + , "templateE" : "~ARG[0] / ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.rem#" + , "type" : "rem# :: Signed n -> Signed n -> Signed n" + , "templateE" : "~ARG[0] rem ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.div#" + , "type" : "div# :: Signed n -> Signed n -> Signed n" + , "templateD" : +"-- divSigned begin +~GENSYM[divSigned][0] : block + signal ~GENSYM[quot_res][3] : ~TYP[0]; +begin + ~SYM[3] <= ~ARG[0] / ~ARG[1]; + ~RESULT <= ~SYM[3] - to_signed(1,~SIZE[~TYPO]) when ~VAR[dividend][0](~VAR[dividend][0]'high) = not (~VAR[divider][1](~VAR[divider][1]'high)) else + ~SYM[3]; +end block; +-- divSigned end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.mod#" + , "type" : "mod# :: Signed n -> Signed n -> Signed n" + , "templateE" : "~ARG[0] mod ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.toInteger#" + , "type" : "toInteger# :: Signed n -> Integer" + , "templateE" : "~IF~SIZE[~TYP[0]]~THENresize(~ARG[0],~SIZE[~TYPO])~ELSEto_signed(0,64)~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.and#" + , "type" : "and# :: KnownNat n => Signed n -> Signed n -> Signed n" + , "templateE" : "~ARG[1] and ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.or#" + , "type" : "or# :: KnownNat n => Signed n -> Signed n -> Signed n" + , "templateE" : "~ARG[1] or ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.xor#" + , "type" : "xor# :: KnownNat n => Signed n -> Signed n -> Signed n" + , "templateE" : "~ARG[1] xor ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.complement#" + , "type" : "complement# :: KnownNat n => Signed n -> Signed n" + , "templateE" : "not ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.shiftL#" + , "type" : "shiftL# :: KnownNat n => Signed n -> Int -> Signed n" + , "templateE" : "shift_left(~ARG[1],to_integer(~ARG[2]))" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.shiftR#" + , "type" : "shiftR# :: KnownNat n => Signed n -> Int -> Signed n" + , "templateE" : "shift_right(~ARG[1],to_integer(~ARG[2]))" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.rotateL#" + , "type" : "rotateL# :: KnownNat n => Signed n -> Int -> Signed n" + , "templateE" : "rotate_left(~ARG[1],to_integer(~ARG[2]))" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.rotateR#" + , "type" : "rotateR# :: KnownNat n => Signed n -> Int -> Signed n" + , "templateE" : "rotate_right(~ARG[1],to_integer(~ARG[2]))" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.resize#" + , "type" : "resize# :: (KnownNat n, KnownNat m) => Signed n -> Signed m" + , "templateE" : "resize(~ARG[2],~LIT[1])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Signed.truncateB#" + , "type" : "truncateB# :: KnownNat m => Signed (n + m) -> Signed m" + , "templateE" : "~IF~SIZE[~TYPO]~THEN~VAR[s][1](~LIT[0]-1 downto 0)~ELSEsigned'(0 downto 1 => '0')~FI" + } + } +] diff --git a/prims/vhdl/Clash_Sized_Internal_Unsigned.json b/prims/vhdl/Clash_Sized_Internal_Unsigned.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/Clash_Sized_Internal_Unsigned.json @@ -0,0 +1,187 @@ +[ { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.size#" + , "type" : "size# :: KnownNat n => Unsigned n -> Int" + , "templateE" : "to_signed(~LIT[0],~SIZE[~TYPO])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.pack#" + , "type" : "pack# :: Unsigned n -> BitVector n" + , "templateE" : "std_logic_vector(~ARG[0])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.unpack#" + , "type" : "unpack# :: BitVector n -> Unsigned n" + , "templateE" : "unsigned(~ARG[0])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.eq#" + , "type" : "eq# :: Unsigned n -> Unsigned n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] = ~ARG[1]~ELSEtrue~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.neq#" + , "type" : "neq# :: Unsigned n -> Unsigned n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] /= ~ARG[1]~ELSEfalse~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.lt#" + , "type" : "lt# :: Unsigned n -> Unsigned n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] < ~ARG[1]~ELSEfalse~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.ge#" + , "type" : "ge# :: Unsigned n -> Unsigned n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] >= ~ARG[1]~ELSEtrue~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.gt#" + , "type" : "gt# :: Unsigned n -> Unsigned n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] > ~ARG[1]~ELSEfalse~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.le#" + , "type" : "le# :: Unsigned n -> Unsigned n -> Bool" + , "templateE" : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] <= ~ARG[1]~ELSEtrue~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.minBound#" + , "type" : "minBound# :: Unsigned n" + , "templateE" : "~IF~SIZE[~TYPO]~THENunsigned'(~SIZE[~TYPO]-1 downto 0 => '0')~ELSEunsigned'(0 downto 1 => '0')~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.maxBound#" + , "type" : "maxBound# :: KnownNat n => Unsigned n" + , "templateE" : "~IF~SIZE[~TYPO]~THENunsigned'(~LIT[0]-1 downto 0 => '1')~ELSEunsigned'(0 downto 1 => '1')~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.+#" + , "type" : "(+#) :: KnownNat n => Unsigned n -> Unsigned n -> Unsigned n" + , "templateE" : "~ARG[1] + ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.-#" + , "type" : "(-#) :: KnownNat n => Unsigned n -> Unsigned n -> Unsigned n" + , "templateE" : "~ARG[1] - ~ARG[2]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.*#" + , "type" : "(*#) :: KnownNat n => Unsigned n -> Unsigned n -> Unsigned n" + , "templateE" : "resize(~ARG[1] * ~ARG[2], ~LIT[0])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.negate#" + , "type" : "negate# :: KnownNat n => Unsigned n -> Unsigned n" + , "templateE" : "unsigned(std_logic_vector(-(signed(std_logic_vector(~ARG[1])))))" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.fromInteger#" + , "type" : "fromInteger# :: KnownNat n => Integer -> Unsigned n" + , "templateE" : "resize(unsigned(std_logic_vector(~ARG[1])),~LIT[0])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.plus#" + , "type" : "plus# :: Unsigned m -> Unsigned n -> Unsigned (1 + Max m n)" + , "templateE" : "resize(~ARG[0],~SIZE[~TYPO]) + resize(~ARG[1],~SIZE[~TYPO])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.minus#" + , "type" : "minus# :: (KnownNat m,KnownNat n) => Unsigned m -> Unsigned n -> Unsigned (1 + Max m n)" + , "templateE" : "resize(~ARG[2],~SIZE[~TYPO]) - resize(~ARG[3],~SIZE[~TYPO])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.times#" + , "type" : "times# :: Unsigned m -> Unsigned n -> Unsigned (m + n)" + , "templateE" : "~ARG[0] * ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.quot#" + , "type" : "quot# :: Unsigned n -> Unsigned n -> Unsigned n" + , "templateE" : "~ARG[0] / ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.rem#" + , "type" : "rem# :: Unsigned n -> Unsigned n -> Unsigned n" + , "templateE" : "~ARG[0] rem ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.toInteger#" + , "type" : "toInteger# :: Unsigned n -> Integer" + , "templateE" : "~IF~SIZE[~TYP[0]]~THENsigned(std_logic_vector(resize(~ARG[0],~SIZE[~TYPO])))~ELSEto_signed(0,64)~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.and#" + , "type" : "and# :: Unsigned n -> Unsigned n -> Unsigned n" + , "templateE" : "~ARG[0] and ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.or#" + , "type" : "or# :: Unsigned n -> Unsigned n -> Unsigned n" + , "templateE" : "~ARG[0] or ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.xor#" + , "type" : "xor# :: Unsigned n -> Unsigned n -> Unsigned n" + , "templateE" : "~ARG[0] xor ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.complement#" + , "type" : "complement# :: KnownNat n => Unsigned n -> Unsigned n" + , "templateE" : "not ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.shiftL#" + , "type" : "shiftL# :: KnownNat n => Unsigned n -> Int -> Unsigned n" + , "templateE" : "shift_left(~ARG[1],to_integer(~ARG[2]))" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.shiftR#" + , "type" : "shiftR# :: KnownNat n => Unsigned n -> Int -> Unsigned n" + , "templateE" : "shift_right(~ARG[1],to_integer(~ARG[2]))" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.rotateL#" + , "type" : "rotateL# :: KnownNat n => Unsigned n -> Int -> Unsigned n" + , "templateE" : "rotate_left(~ARG[1],to_integer(~ARG[2]))" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.rotateR#" + , "type" : "rotateR# :: KnownNat n => Unsigned n -> Int -> Unsigned n" + , "templateE" : "rotate_right(~ARG[1],to_integer(~ARG[2]))" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Internal.Unsigned.resize#" + , "type" : "resize# :: KnownNat m => Unsigned n -> Unsigned m" + , "templateE" : "resize(~ARG[1],~LIT[0])" + } + } +] diff --git a/prims/vhdl/Clash_Sized_RTree.json b/prims/vhdl/Clash_Sized_RTree.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/Clash_Sized_RTree.json @@ -0,0 +1,19 @@ +[ { "BlackBox" : + { "name" : "Clash.Sized.RTree.treplicate" + , "type" : "replicate :: SNat n -> a -> RTree d a" + , "templateE" : "~TYPMO'(0 to (2**~LIT[0])-1 => ~ARG[1])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.RTree.textract" + , "type" : "textract :: RTree 0 a -> a" + , "templateE" : "~IF ~VIVADO ~THEN ~FROMBV[~VAR[t][0]][~TYPO] ~ELSE ~VAR[t][0](0) ~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.RTree.tsplit" + , "type" : "tsplit:: RTree (d+1) a -> (RTree d a,RTree d a)" + , "templateE" : "(~VAR[t][0](0 to (2**(~DEPTH[~TYP[0]]-1))-1) ,~VAR[t][0](2**(~DEPTH[~TYP[0]]-1) to (2**~DEPTH[~TYP[0]])-1))" + } + } +] diff --git a/prims/vhdl/Clash_Sized_Vector.json b/prims/vhdl/Clash_Sized_Vector.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/Clash_Sized_Vector.json @@ -0,0 +1,446 @@ +[ { "BlackBox" : + { "name" : "Clash.Sized.Vector.head" + , "type" : "head :: Vec (n + 1) a -> a" + , "templateE" : "~IF ~VIVADO ~THEN ~TYPMO'(fromSLV(~VAR[vec][0](0))) ~ELSE ~VAR[vec][0](0) ~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.tail" + , "type" : "tail :: Vec (n + 1) a -> Vec n a" + , "templateE" : "~VAR[vec][0](1 to ~VAR[vec][0]'high)" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.last" + , "type" : "Vec (n + 1) a -> a" + , "templateE" : "~IF ~VIVADO ~THEN ~TYPMO'(fromSLV(~VAR[vec][0](~VAR[vec][0]'high))) ~ELSE ~VAR[vec][0](~VAR[vec][0]'high) ~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.init" + , "type" : "Vec (n + 1) a -> Vec n a" + , "templateE" : "~VAR[vec][0](0 to ~VAR[vec][0]'high - 1)" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.select" + , "type" : +"select :: (CmpNat (i + s) (s * n) ~ GT) -- ARG[0] + => SNat f -- ARG[1] + -> SNat s -- ARG[2] + -> SNat n -- ARG[3] + -> Vec i a -- ARG[4] + -> Vec n a" + , "templateD" : +"-- select begin +~GENSYM[select][0] : for ~GENSYM[i][1] in ~RESULT'range generate + ~RESULT(~SYM[1]) <= ~VAR[vec][4](~LIT[1]+(~LIT[2]*~SYM[1])); +end generate; +-- select end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.++" + , "type" : "(++) :: Vec n a -> Vec m a -> Vec (n + m) a" + , "templateE" : "~TYPMO'(~TYPM[0]'(~ARG[0]) & ~TYPM[1]'(~ARG[1]))" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.concat" + , "type" : "concat :: Vec n (Vec m a) -> Vec (n * m) a" + , "templateD" : +"-- concat begin +~GENSYM[concat][0] : for ~GENSYM[i][1] in ~VAR[vec][0]'range generate +begin~IF ~VIVADO ~THEN +~RESULT(~SYM[1] * ~LENGTH[~TYPEL[~TYP[0]]] to ((~SYM[1]+1) * ~LENGTH[~TYPEL[~TYP[0]]]) - 1) <= fromSLV(~VAR[vec][0](~SYM[1]));~ELSE +~RESULT(~SYM[1] * ~LENGTH[~TYPEL[~TYP[0]]] to ((~SYM[1]+1) * ~LENGTH[~TYPEL[~TYP[0]]]) - 1) <= ~VAR[vec][0](~SYM[1]);~FI +end generate; +-- concat end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.splitAt" + , "type" : "splitAt :: SNat m -> Vec (m + n) a -> (Vec m a, Vec n a)" + , "templateE" : "~IF~LENGTH[~TYPO]~THEN~ARG[1]~ELSE(~VAR[vec][1](0 to ~LIT[0]-1),~VAR[vec][1](~LIT[0] to ~VAR[vec][1]'high))~FI" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.unconcat" + , "type" : +"unconcat :: KnownNat n -- ARG[0] + => SNat m -- ARG[1] + -> Vec (n * m) a -- ARG[2] + -> Vec n (Vec m a)" + , "templateD" : +"-- unconcat begin +~GENSYM[unconcat][0] : for ~GENSYM[i][2] in ~RESULT'range generate +begin~IF ~VIVADO ~THEN + ~RESULT(~SYM[2]) <= ~TOBV[~VAR[vec][2]((~SYM[2] * ~LIT[1]) to ((~SYM[2] * ~LIT[1]) + ~LIT[1] - 1))][~TYPEL[~TYPO]];~ELSE + ~RESULT(~SYM[2]) <= ~VAR[vec][2]((~SYM[2] * ~LIT[1]) to ((~SYM[2] * ~LIT[1]) + ~LIT[1] - 1));~FI +end generate; +-- unconcat end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.map" + , "type" : "map :: (a -> b) -> Vec n a -> Vec n b" + , "templateD" : +"-- map begin +~GENSYM[map][0] : for ~GENSYM[i][1] in ~RESULT'range generate~IF ~VIVADO ~THEN~IF~SIZE[~TYP[1]]~THEN + signal ~GENSYM[map_in][2] : ~TYPEL[~TYP[1]];~ELSE ~FI + signal ~GENSYM[map_out][3] : ~TYPEL[~TYPO]; +begin~IF~SIZE[~TYP[1]]~THEN + ~SYM[2] <= fromSLV(~VAR[vec][1](~SYM[1]));~ELSE ~FI + ~INST 0 + ~OUTPUT <= ~SYM[3]~ ~TYPEL[~TYPO]~ + ~INPUT <= ~SYM[2]~ ~TYPEL[~TYP[1]]~ + ~INST + ~RESULT(~SYM[1]) <= ~TOBV[~SYM[3]][~TYPEL[~TYPO]]; +end generate;~ELSE +begin + ~INST 0 + ~OUTPUT <= ~RESULT(~SYM[1])~ ~TYPEL[~TYPO]~ + ~INPUT <= ~VAR[vec][1](~SYM[1])~ ~TYPEL[~TYP[1]]~ + ~INST +end generate;~FI +-- map end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.imap" + , "type" : "imap :: KnownNat n => (Index n -> a -> b) -> Vec n a -> Vec n b" + , "templateD" : +"-- imap begin +~GENSYM[imap][0] : block + function ~GENSYM[max][6] (l,r : in natural) return natural is + begin + if l > r then return l; + else return r; + end if; + end function; +begin + ~GENSYM[imap][5] : for ~GENSYM[i][1] in ~RESULT'range generate~IF ~VIVADO ~THEN~IF~SIZE[~TYP[2]]~THEN + signal ~GENSYM[map_in][2] : ~TYPEL[~TYP[2]];~ELSE ~FI + signal ~GENSYM[map_out][3] : ~TYPEL[~TYPO]; + begin~IF~SIZE[~TYP[2]]~THEN + ~SYM[2] <= fromSLV(~VAR[vec][2](~SYM[1]));~ELSE ~FI + ~INST 1 + ~OUTPUT <= ~SYM[3]~ ~TYPEL[~TYPO]~ + ~INPUT <= to_unsigned(~SYM[1],~SYM[6](1,integer(ceil(log2(real(~LIT[0]))))))~ ~INDEXTYPE[~LIT[0]]~ + ~INPUT <= ~SYM[2]~ ~TYPEL[~TYP[2]]~ + ~INST + ~RESULT(~SYM[1]) <= ~TOBV[~SYM[3]][~TYPEL[~TYPO]]; + end generate;~ELSE + begin + ~INST 1 + ~OUTPUT <= ~RESULT(~SYM[1])~ ~TYPEL[~TYPO]~ + ~INPUT <= to_unsigned(~SYM[1],~SYM[6](1,integer(ceil(log2(real(~LIT[0]))))))~ ~INDEXTYPE[~LIT[0]]~ + ~INPUT <= ~VAR[vec][2](~SYM[1])~ ~TYPEL[~TYP[2]]~ + ~INST + end generate;~FI +end block; +-- imap end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.imap_go" + , "type" : "imap_go :: Index n -> (Index n -> a -> b) -> Vec m a -> Vec m b" + , "templateD" : +"-- imap_go begin +~GENSYM[imap][5] : for ~GENSYM[i][1] in ~RESULT'range generate~IF ~VIVADO ~THEN~IF~SIZE[~TYP[2]]~THEN + signal ~GENSYM[map_in][2] : ~TYPEL[~TYP[2]];~ELSE ~FI + signal ~GENSYM[map_out][3] : ~TYPEL[~TYPO]; + signal ~GENSYM[i2][4] : ~TYP[0]; +begin~IF~SIZE[~TYP[2]]~THEN + ~SYM[2] <= fromSLV(~VAR[vec][2](~SYM[1]));~ELSE ~FI + ~SYM[4] <= ~ARG[0] + to_unsigned(~SYM[1],~SIZE[~TYP[0]]); + ~INST 1 + ~OUTPUT <= ~SYM[3]~ ~TYPEL[~TYPO]~ + ~INPUT <= ~SYM[4]~ ~TYP[0]~ + ~INPUT <= ~SYM[2]~ ~TYPEL[~TYP[2]]~ + ~INST + ~RESULT(~SYM[1]) <= ~TOBV[~SYM[3]][~TYPEL[~TYPO]]; +end generate;~ELSE + signal ~SYM[4] : ~TYP[0]; +begin + ~SYM[4] <= ~ARG[0] + to_unsigned(~SYM[1],~SIZE[~TYP[0]]); + ~INST 1 + ~OUTPUT <= ~RESULT(~SYM[1])~ ~TYPEL[~TYPO]~ + ~INPUT <= ~SYM[4]~ ~TYP[0]~ + ~INPUT <= ~VAR[vec][2](~SYM[1])~ ~TYPEL[~TYP[2]]~ + ~INST +end generate;~FI +-- imap_go end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.zipWith" + , "type" : "zipWith :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c" + , "templateD" : +"-- zipWith begin +~GENSYM[zipWith][0] : for ~GENSYM[i][1] in ~RESULT'range generate~IF ~VIVADO ~THEN~IF~SIZE[~TYP[1]]~THEN + signal ~GENSYM[zipWith_in1][2] : ~TYPEL[~TYP[1]];~ELSE ~FI~IF~SIZE[~TYP[2]]~THEN + signal ~GENSYM[zipWith_in2][6] : ~TYPEL[~TYP[2]];~ELSE ~FI + signal ~GENSYM[zipWith_out][3] : ~TYPEL[~TYPO]; +begin~IF~SIZE[~TYP[1]]~THEN + ~SYM[2] <= fromSLV(~VAR[vec1][1](~SYM[1]));~ELSE ~FI~IF~SIZE[~TYP[2]]~THEN + ~SYM[6] <= fromSLV(~VAR[vec2][2](~SYM[1]));~ELSE ~FI + ~INST 0 + ~OUTPUT <= ~SYM[3]~ ~TYPEL[~TYPO]~ + ~INPUT <= ~SYM[2]~ ~TYPEL[~TYP[1]]~ + ~INPUT <= ~SYM[6]~ ~TYPEL[~TYP[2]]~ + ~INST + ~RESULT(~SYM[1]) <= ~TOBV[~SYM[3]][~TYPEL[~TYPO]]; +end generate;~ELSE +begin + ~INST 0 + ~OUTPUT <= ~RESULT(~SYM[1])~ ~TYPEL[~TYPO]~ + ~INPUT <= ~VAR[vec1][1](~SYM[1])~ ~TYPEL[~TYP[1]]~ + ~INPUT <= ~VAR[vec2][2](~SYM[1])~ ~TYPEL[~TYP[2]]~ + ~INST +end generate;~FI +-- zipWith end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.foldr" + , "type" : "foldr :: (a -> b -> b) -> b -> Vec n a -> b" + , "templateD" : +"-- foldr begin~IF ~LENGTH[~TYP[2]] ~THEN +~GENSYM[foldr][0] : block + type ~GENSYM[foldr_res_type][1] is array (natural range <>) of ~TYP[1]; + signal ~GENSYM[intermediate][2] : ~SYM[1] (0 to ~LENGTH[~TYP[2]]); +begin + ~SYM[2](~LENGTH[~TYP[2]]) <= ~ARG[1]; + + foldr_loop : for ~GENSYM[i][3] in ~VAR[vec][2]'range generate~IF ~VIVADO ~THEN~IF~SIZE[~TYP[2]]~THEN + signal ~GENSYM[foldr_in][4] : ~TYPEL[~TYP[2]];~ELSE ~FI + begin~IF~SIZE[~TYP[2]]~THEN + ~SYM[4] <= fromSLV(~VAR[vec][2](~SYM[3]));~ELSE ~FI + ~INST 0 + ~OUTPUT <= ~SYM[2](~SYM[3])~ ~TYP[1]~ + ~INPUT <= ~SYM[4]~ ~TYPEL[~TYP[2]]~ + ~INPUT <= ~SYM[2](~SYM[3]+1)~ ~TYP[1]~ + ~INST + end generate;~ELSE + begin + ~INST 0 + ~OUTPUT <= ~SYM[2](~SYM[3])~ ~TYP[1]~ + ~INPUT <= ~VAR[vec][2](~SYM[3])~ ~TYPEL[~TYP[2]]~ + ~INPUT <= ~SYM[2](~SYM[3]+1)~ ~TYP[1]~ + ~INST + end generate;~FI + + ~RESULT <= ~SYM[2](0); +end block;~ELSE +~RESULT <= ~ARG[1];~FI +-- foldr end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.fold" + , "type" : "fold :: (a -> a -> a) -> Vec (n+1) a -> a" + , "comment" : "THIS ONLY WORKS FOR POWER OF TWO LENGTH VECTORS" + , "templateD" : +"-- fold begin +~GENSYM[fold][0] : block + -- given a level and a depth, calculate the corresponding index into the + -- intermediate array + function ~GENSYM[depth2Index][1] (levels,depth : in natural) return natural is + begin + return (2 ** levels - 2 ** depth); + end function; +~IF ~VIVADO ~THEN + type ~GENSYM[fold_res_type][2] is array(natural range <>) of ~TYPO; + signal ~GENSYM[intermediate][3] : ~SYM[2](0 to (2*~LENGTH[~TYP[1]])-2);~ELSE + signal ~SYM[3] : ~TYPM[1](0 to (2*~LENGTH[~TYP[1]])-2);~FI + constant ~GENSYM[levels][5] : natural := natural (ceil (log2 (real (~LENGTH[~TYP[1]])))); +begin + -- put input array into the first half of the intermediate array~IF ~VIVADO ~THEN + ~SYM[6] : for ~SYM[7] in ~VAR[vec][1]'range generate + ~SYM[3](~SYM[7]) <= fromSLV(~VAR[vec][1](~SYM[7])); + end generate;~ELSE + ~SYM[3](0 to ~LENGTH[~TYP[1]]-1) <= ~VAR[vec][1];~FI + + -- Create the tree of instantiated components + ~GENSYM[make_tree][8] : if ~SYM[5] /= 0 generate + ~GENSYM[tree_depth][9] : for ~GENSYM[d][10] in ~SYM[5]-1 downto 0 generate + ~GENSYM[tree_depth_loop][11] : for ~GENSYM[i][12] in 0 to (natural(2**~SYM[10]) - 1) generate + ~INST 0 + ~OUTPUT <= ~SYM[3](~SYM[1](~SYM[5]+1,~SYM[10]+1)+~SYM[12])~ ~TYPO~ + ~INPUT <= ~SYM[3](~SYM[1](~SYM[5]+1,~SYM[10]+2)+(2*~SYM[12]))~ ~TYPO~ + ~INPUT <= ~SYM[3](~SYM[1](~SYM[5]+1,~SYM[10]+2)+(2*~SYM[12])+1)~ ~TYPO~ + ~INST + end generate; + end generate; + end generate; + + -- The last element of the intermediate array holds the result + ~RESULT <= ~SYM[3]((2*~LENGTH[~TYP[1]])-2); +end block; +-- fold end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.index_int" + , "type" : "index_int :: KnownNat n => Vec n a -> Int -> a" + , "templateD" : +"-- index begin +~GENSYM[indexVec][0] : block + signal ~GENSYM[vec_index][1] : integer range 0 to ~LIT[0]-1; +begin + ~SYM[1] <= to_integer(~ARG[2]) + -- pragma translate_off + mod ~LIT[0] + -- pragma translate_on + ;~IF ~VIVADO ~THEN + ~RESULT <= fromSLV(~VAR[vec][1](~SYM[1]));~ELSE + ~RESULT <= ~VAR[vec][1](~SYM[1]);~FI +end block; +-- index end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.replace_int" + , "type" : "replace_int :: KnownNat n => Vec n a -> Int -> a -> Vec n a" + , "templateD" : +"-- replace begin +~GENSYM[replaceVec][0] : block + signal ~GENSYM[vec_index][1] : integer range 0 to ~LIT[0]-1; +begin + ~SYM[1] <= to_integer(~ARG[2]) + -- pragma translate_off + mod ~LIT[0] + -- pragma translate_on + ; + + process(~SYM[1]~VARS[1]~VARS[3]) + variable ~GENSYM[ivec][2] : ~TYP[1]; + begin + ~SYM[2] := ~ARG[1];~IF ~VIVADO ~THEN + ~SYM[2](~SYM[1]) := ~TOBV[~ARG[3]][~TYP[3]];~ELSE + ~SYM[2](~SYM[1]) := ~ARG[3];~FI + ~RESULT <= ~SYM[2]; + end process; +end block; +-- replace end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.maxIndex" + , "type" : "maxIndex :: KnownNat n => Vec n a -> Int" + , "templateE" : "to_signed(~LIT[0] - 1,~SIZE[~TYPO])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.length" + , "type" : "length :: KnownNat n => Vec n a -> Int" + , "templateE" : "to_signed(~LIT[0],~SIZE[~TYPO])" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.replicate" + , "type" : "replicate :: SNat n -> a -> Vec n a" + , "templateE" : "~TYPMO'(0 to ~LIT[0]-1 => ~IF ~VIVADO ~THEN ~TOBV[~TYPM[1]'(~ARG[1])][~TYP[1]] ~ELSE ~ARG[1] ~FI)" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.transpose" + , "type" : "transpose :: KnownNat n => Vec m (Vec n a) -> Vec n (Vec m a)" + , "templateD" : +"-- transpose begin +~GENSYM[transpose_outer][2] : for ~GENSYM[row_index][3] in ~VAR[matrix][1]'range generate + ~GENSYM[transpose_inner][4] : for ~GENSYM[col_index][5] in ~RESULT'range generate~IF ~VIVADO ~THEN + ~RESULT(~SYM[5])((~VAR[matrix][1]'length-~SYM[3])*~SIZE[~TYPEL[~TYPEL[~TYPO]]]-1 downto (~VAR[matrix][1]'length-~SYM[3]-1)*~SIZE[~TYPEL[~TYPEL[~TYPO]]]) <= ~VAR[vec][1](~SYM[3])((~RESULT'length-~SYM[5])*~SIZE[~TYPEL[~TYPEL[~TYPO]]]-1 downto (~RESULT'length-~SYM[5]-1)*~SIZE[~TYPEL[~TYPEL[~TYPO]]]);~ELSE + ~RESULT(~SYM[5])(~SYM[3]) <= ~VAR[matrix][1](~SYM[3])(~SYM[5]);~FI + end generate; +end generate; +-- transpose end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.reverse" + , "type" : "reverse :: Vec n a -> Vec n a" + , "templateD" : +"-- reverse begin +~GENSYM[reverse_loop][2] : for ~GENSYM[i][3] in ~VAR[vec][0]'range generate + ~RESULT(~VAR[vec][0]'high - ~SYM[3]) <= ~VAR[vec][0](~SYM[3]); +end generate; +-- reverse end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.lazyV" + , "type" : "lazyV :: KnownNat n => Vec n a -> Vec n a" + , "templateE" : "~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.concatBitVector#" + , "type" : +"concatBitVector# :: (KnownNat n,KnownNat m) -- (ARG[0],ARG[1]) + => Vec n (BitVector m) -- ARG[2] + -> BitVector (n * m)" + , "templateD" : +"-- concatBitVector begin +~GENSYM[concatBitVectorIter_loop][2] : for ~GENSYM[i][3] in ~VAR[vec][2]'range generate + ~RESULT(((~SYM[3] * ~LIT[1]) + ~LIT[1] - 1) downto (~SYM[3] * ~LIT[1])) <= ~TYPMO'(~VAR[vec][2](~VAR[vec][2]'high - ~SYM[3])); +end generate; +-- concatBitVector end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.unconcatBitVector#" + , "type" : +"unconcatBitVector# :: (KnownNat n, KnownNat m) -- (ARG[0],ARG[1]) + => BitVector (n * m) -- ARG[2] + -> Vec n (BitVector m)" + , "templateD" : +"-- unconcatBitVector begin +~GENSYM[unconcatBitVectorIter_loop][2] : for ~GENSYM[i][3] in ~RESULT'range generate + ~RESULT(~RESULT'high - ~SYM[3]) <= ~VAR[vec][2](((~SYM[3] * ~LIT[1]) + ~LIT[1] - 1) downto (~SYM[3] * ~LIT[1])); +end generate; +-- unconcatBitVector end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.rotateLeftS" + , "type" : "rotateLeftS :: KnownNat n => Vec n a -> SNat d -> Vec n a" + , "templateD" : +"-- rotateLeftS begin +~GENSYM[rotateLeftS][0] : block + constant ~GENSYM[shift_amount][2] : natural := ~LIT[2] mod ~LIT[0]; +begin + ~GENSYM[no_shift][3] : if ~SYM[2] = 0 generate + ~RESULT <= ~VAR[vec][1]; + end generate; + + ~GENSYM[do_shift][4] : if ~SYM[2] /= 0 generate + ~RESULT <= ~VAR[vec][1](~SYM[2] to ~LIT[0]-1) & + ~VAR[vec][1](0 to ~SYM[2]-1); + end generate; +end block; +-- rotateLeftS end" + } + } +, { "BlackBox" : + { "name" : "Clash.Sized.Vector.rotateRightS" + , "type" : "rotateRightS :: KnownNat n => Vec n a -> SNat d -> Vec n a" + , "templateD" : +"-- rotateRightS begin +~GENSYM[rotateLeftS][0] : block + constant ~GENSYM[shift_amount][2] : natural := ~LIT[2] mod ~LIT[0]; +begin + ~GENSYM[no_shift][3] : if ~SYM[2] = 0 generate + ~RESULT <= ~VAR[vec][1]; + end generate; + + ~GENSYM[do_shift][4] : if ~SYM[2] /= 0 generate + ~RESULT <= ~VAR[vec][1](~LIT[0]-~SYM[2] to ~LIT[0]-1) & + ~VAR[vec][1](0 to ~LIT[0]-~SYM[2]-1); + end generate; +end block; +-- rotateRightS end" + } + } +] diff --git a/prims/vhdl/Clash_Xilinx_ClockGen.json b/prims/vhdl/Clash_Xilinx_ClockGen.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/Clash_Xilinx_ClockGen.json @@ -0,0 +1,62 @@ +[ { "BlackBox" : + { "name" : "Clash.Xilinx.ClockGen.clockWizard" + , "type" : +"clockWizard + :: SSymbol name -- ARG[0] + -> Clock pllIn 'Source -- ARG[1] + -> Reset pllIn 'Asynchronous -- ARG[2] + -> (Clock pllOut 'Source, Signal pllOut Bool)" + , "templateD" : +"-- clockWizard begin +~GENSYM[clockWizard][0] : block + signal ~GENSYM[pllOut][1] : std_logic; + signal ~GENSYM[locked][2] : std_logic; + signal ~GENSYM[pllLock][3] : boolean; + + component ~NAME[0] + port (CLK_IN1 : in std_logic; + RESET : in std_logic; + CLK_OUT1 : out std_logic; + LOCKED : out std_logic); + end component; +begin + ~GENSYM[clockWizard_inst][4] : component ~NAME[0] port map (~ARG[1],~ARG[2],~SYM[1],~SYM[2]); + ~SYM[3] <= true when ~SYM[2] = '1' else false; + ~RESULT <= (~SYM[1],~SYM[3]); +end block; +-- clockWizard end" + } + } +, { "BlackBox" : + { "name" : "Clash.Xilinx.ClockGen.clockWizardDifferential" + , "type" : +"clockWizardDifferential + :: SSymbol name -- ARG[0] + -> Clock pllIn 'Source -- ARG[1] + -> Clock pllIn 'Source -- ARG[2] + -> Reset pllIn 'Asynchronous -- ARG[3] + -> (Clock pllOut 'Source, Signal pllOut Bool)" + , "templateD" : +"-- clockWizardDifferential begin +~GENSYM[clockWizardDifferential][0] : block + signal ~GENSYM[pllOut][1] : std_logic; + signal ~GENSYM[locked][2] : std_logic; + signal ~GENSYM[pllLock][3] : boolean; + + component ~NAME[0] + port (CLK_IN1_D_clk_n : in std_logic; + CLK_IN1_D_clk_p : in std_logic; + RESET : in std_logic; + CLK_OUT1 : out std_logic; + LOCKED : out std_logic); + end component; +begin + ~GENSYM[clockWizardDifferential_inst][4] : component ~NAME[0] + port map (~ARG[1],~ARG[2],~ARG[3],~SYM[1],~SYM[2]); + ~SYM[3] <= true when ~SYM[2] = '1' else false; + ~RESULT <= (~SYM[1],~SYM[3]); +end block; +-- clockWizardDifferential end" + } + } +] diff --git a/prims/vhdl/Clash_Xilinx_DDR.json b/prims/vhdl/Clash_Xilinx_DDR.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/Clash_Xilinx_DDR.json @@ -0,0 +1,109 @@ +[ { "BlackBox" : + { "name" : "Clash.Xilinx.DDR.iddr" + , "type" : +"iddr + :: ( HasCallStack -- ARG[0] + , fast ~ Dom n pFast -- ARG[1] + , slow ~ Dom n (2*pFast) -- ARG[2] + , KnownNat m ) -- ARG[3] + -> Clock slow gated -- ARG[4] + -> Reset slow synchronous -- ARG[5] + -> Signal fast (BitVector m) -- ARG[6] + -> Signal slow (BitVector m,BitVector m)" + , "libraries" : ["UNISIM"] + , "imports" : ["UNISIM.vcomponents.all"] + , "templateD" : +"-- iddr begin +~GENSYM[~COMPNAME_IDDR][0] : block + signal ~GENSYM[dataout_l][1] : ~TYP[6]; + signal ~GENSYM[dataout_h][2] : ~TYP[6]; + signal ~GENSYM[d][3] : ~TYP[6];~IF ~ISGATED[4] ~THEN + signal ~GENSYM[clk][4] : std_logic; + signal ~GENSYM[ce][5] : boolean; + signal ~GENSYM[ce_logic][6]: std_logic;~ELSE ~FI +begin~IF ~ISGATED[4] ~THEN + (~SYM[4],~SYM[5]) <= ~ARG[4]; + ~SYM[6] <= '1' when (~SYM[5]) else '0';~ELSE ~FI + ~SYM[3] <= ~ARG[6]; + + ~GENSYM[gen_iddr][7] : for ~GENSYM[i][8] in ~SYM[3]'range generate + begin + ~GENSYM[~COMPNAME_IDDR_inst][9] : IDDR + generic map ( + DDR_CLK_EDGE => \"SAME_EDGE\", + INIT_Q1 => '0', + INIT_Q2 => '0', + SRTYPE => ~IF ~ISSYNC[5] ~THEN \"SYNC\" ~ELSE \"ASYNC\" ~FI) + port map ( + Q1 => ~SYM[1](~SYM[8]), -- 1-bit output for positive edge of clock + Q2 => ~SYM[2](~SYM[8]), -- 1-bit output for negative edge of clock~IF ~ISGATED[4] ~THEN + C => ~SYM[4], -- 1-bit clock input + CE => ~SYM[6], -- 1-bit clock enable input~ELSE + C => ~ARG[4], -- 1-bit clock input + CE => '1', -- 1-bit clock enable input~FI + D => ~SYM[3](~SYM[8]), -- 1-bit DDR data input + R => ~ARG[5], -- 1-bit reset + S => '0' -- 1-bit set + ); + end generate; + + ~RESULT <= (~SYM[2], ~SYM[1]); +end block; +-- iddr# end" + } + } +, { "BlackBox" : + { "name" : "Clash.Xilinx.DDR.oddr#" + , "type" : +"oddr# + :: ( slow ~ Dom n (2*pFast) -- ARG[0] + , fast ~ Dom n pFast -- ARG[1] + , KnownNat m ) -- ARG[2] + => Clock slow gated -- ARG[3] + -> Reset slow synchronous -- ARG[4] + -> Signal slow (BitVector m) -- ARG[5] + -> Signal slow (BitVector m) -- ARG[6] + -> Signal fast (BitVector m)" + , "libraries" : ["UNISIM"] + , "imports" : ["UNISIM.vcomponents.all"] + , "templateD" : +"-- oddr begin +~GENSYM[~COMPNAME_ODDR][0] : block + signal ~GENSYM[dataout_l][1] : ~TYPO; + signal ~GENSYM[dataout_h][2] : ~TYPO; + signal ~GENSYM[q][3] : ~TYPO;~IF ~ISGATED[3] ~THEN + signal ~GENSYM[clk][4] : std_logic; + signal ~GENSYM[ce][5] : boolean; + signal ~GENSYM[ce_logic][6] : std_logic;~ELSE ~FI +begin~IF ~ISGATED[3] ~THEN + (~SYM[4],~SYM[5]) <= ~ARG[3]; + ~SYM[6] <= '1' when (~SYM[5]) else '0';~ELSE ~FI + ~SYM[1] <= ~ARG[5]; + ~SYM[2] <= ~ARG[6]; + + ~GENSYM[gen_iddr][7] : for ~GENSYM[i][8] in ~SYM[3]'range generate + begin + ~GENSYM[~COMPNAME_ODDR_inst][9] : ODDR + generic map( + DDR_CLK_EDGE => \"SAME_EDGE\", + INIT => '0', + SRTYPE => ~IF ~ISSYNC[4] ~THEN \"SYNC\" ~ELSE \"ASYNC\" ~FI) + port map ( + Q => ~SYM[3](~SYM[8]), -- 1-bit DDR output~IF ~ISGATED[3] ~THEN + C => ~SYM[4], -- 1-bit clock input + CE => ~SYM[6], -- 1-bit clock enable input~ELSE + C => ~ARG[3], -- 1-bit clock input + CE => '1', -- 1-bit clock enable input~FI + D1 => ~SYM[1](~SYM[8]), -- 1-bit data input (positive edge) + D2 => ~SYM[2](~SYM[8]), -- 1-bit data input (negative edge) + R => ~ARG[4], -- 1-bit reset input + S => '0' -- 1-bit set input + ); + end generate; + + ~RESULT <= ~SYM[3]; +end block; +-- oddr end" + } + } +] diff --git a/prims/vhdl/GHC_Base.json b/prims/vhdl/GHC_Base.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/GHC_Base.json @@ -0,0 +1,39 @@ +[ { "Primitive" : + { "name" : "GHC.Base.$" + , "primType" : "Function" + } + } +, { "BlackBox" : + { "name" : "GHC.Base.quotInt" + , "type" : "quotInt :: Int -> Int -> Int" + , "templateE" : "~ARG[0] / ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Base.remInt" + , "type" : "remInt :: Int -> Int -> Int" + , "templateE" : "~ARG[0] rem ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Base.divInt" + , "type" : "divInt :: Int -> Int -> Int" + , "templateD" : +"-- divInt begin +~GENSYM[divInt][0] : block + signal ~GENSYM[quot_res][1] : ~TYP[1]; +begin + ~SYM[1] <= ~ARG[0] / ~ARG[1]; + ~RESULT <= ~SYM[1] - 1 when ((~ARG[0] = abs ~ARG[0]) /= (~ARG[1] = abs ~ARG[1])) else + ~SYM[1]; +end block; +-- divInt end" + } + } +, { "BlackBox" : + { "name" : "GHC.Base.modInt" + , "type" : "modInt :: Int -> Int -> Int" + , "templateE" : "~ARG[0] mod ~ARG[1]" + } + } +] diff --git a/prims/vhdl/GHC_Classes.json b/prims/vhdl/GHC_Classes.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/GHC_Classes.json @@ -0,0 +1,76 @@ +[ { "BlackBox" : + { "name" : "GHC.Classes.eqInt" + , "type" : "eqInt :: Int -> Int -> Bool" + , "templateE" : "~ARG[0] = ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.neInt" + , "type" : "neInt :: Int -> Int -> Bool" + , "templateE" : "~ARG[0] /= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.gtInt" + , "type" : "gtInt :: Int -> Int -> Bool" + , "templateE" : "~ARG[0] > ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.geInt" + , "type" : "geInt :: Int -> Int -> Bool" + , "templateE" : "~ARG[0] >= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.ltInt" + , "type" : "ltInt :: Int -> Int -> Bool" + , "templateE" : "~ARG[0] < ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.leInt" + , "type" : "leInt :: Int -> Int -> Bool" + , "templateE" : "~ARG[0] <= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.&&" + , "type" : "(&&) :: Bool -> Bool -> Bool" + , "templateE" : "~ARG[0] and ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.||" + , "type" : "(::) :: Bool -> Bool -> Bool" + , "templateE" : "~ARG[0] or ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.not" + , "type" : "not :: Bool -> Bool" + , "templateE" : "not ~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.divInt#" + , "type" : "divInt# :: Int# -> Int# -> Int#" + , "templateD" : +"-- divInt begin +~GENSYM[divInt][0] : block + signal ~GENSYM[quot_res][1] : ~TYP[1]; +begin + ~SYM[1] <= ~ARG[0] / ~ARG[1]; + ~RESULT <= ~SYM[1] - 1 when ((~ARG[0] = abs ~ARG[0]) /= (~ARG[1] = abs ~ARG[1])) else + ~SYM[1]; +end block; +-- divInt end" + } + } +, { "BlackBox" : + { "name" : "GHC.Classes.modInt#" + , "type" : "modInt# :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] mod ~ARG[1]" + } + } +] diff --git a/prims/vhdl/GHC_Int.json b/prims/vhdl/GHC_Int.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/GHC_Int.json @@ -0,0 +1,25 @@ +[ { "BlackBox" : + { "name" : "GHC.Int.I8#" + , "type" : "I8# :: Int# -> Int8" + , "templateE" : "resize(~ARG[0],8)" + } + } +, { "BlackBox" : + { "name" : "GHC.Int.I16#" + , "type" : "I16# :: Int# -> Int16" + , "templateE" : "resize(~ARG[0],16)" + } + } +, { "BlackBox" : + { "name" : "GHC.Int.I32#" + , "type" : "I32# :: Int# -> Int32" + , "templateE" : "resize(~ARG[0],32)" + } + } +, { "BlackBox" : + { "name" : "GHC.Int.I64#" + , "type" : "I64# :: Int# -> Int64" + , "templateE" : "resize(~ARG[0],64)" + } + } +] diff --git a/prims/vhdl/GHC_Integer_Logarithms.json b/prims/vhdl/GHC_Integer_Logarithms.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/GHC_Integer_Logarithms.json @@ -0,0 +1,7 @@ +[ { "BlackBox" : + { "name" : "GHC.Integer.Logarithms.integerLogBase#" + , "type" : "integerLogBase# :: Integer -> Integer -> Int#" + , "templateE" : "integer(floor(log(real(~ARG[1]),real(~ARG[0]))))" + } + } +] diff --git a/prims/vhdl/GHC_Integer_Type.json b/prims/vhdl/GHC_Integer_Type.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/GHC_Integer_Type.json @@ -0,0 +1,172 @@ +[ { "BlackBox" : + { "name" : "GHC.Integer.Type.smallInteger" + , "type" : "smallInteger :: Int# -> Integer" + , "templateE" : "~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.integerToInt" + , "type" : "integerToInt :: Integer -> Int#" + , "templateE" : "~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.plusInteger" + , "type" : "plusInteger :: Integer -> Integer -> Integer" + , "templateE" : "~ARG[0] + ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.minusInteger" + , "type" : "minusInteger :: Integer -> Integer -> Integer" + , "templateE" : "~ARG[0] - ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.timesInteger" + , "type" : "timesInteger :: Integer -> Integer -> Integer" + , "templateE" : "resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO])" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.negateInteger" + , "type" : "negateInteger :: Integer -> Integer" + , "templateE" : "-~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.absInteger" + , "type" : "absInteger :: Integer -> Integer" + , "templateE" : "abs ~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.divInteger" + , "type" : "divInteger :: Integer -> Integer -> Integer" + , "templateD" : +"-- divInteger begin +~GENSYM[divInteger][0] : block + signal ~GENSYM[quot_res][1] : ~TYP[1]; +begin + ~SYM[1] <= ~ARG[0] / ~ARG[1]; + ~RESULT <= ~SYM[1] - 1 when ((~ARG[0] = abs ~ARG[0]) /= (~ARG[1] = abs ~ARG[1])) else + ~SYM[1]; +end block; +-- divInteger end" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.modInteger" + , "type" : "modInteger :: Integer -> Integer -> Integer" + , "templateE" : "~ARG[0] mod ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.quotInteger" + , "type" : "quotInteger :: Integer -> Integer -> Integer" + , "templateE" : "~ARG[0] / ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.remInteger" + , "type" : "remInteger :: Integer -> Integer -> Integer" + , "templateE" : "~ARG[0] rem ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.eqInteger" + , "type" : "eqInteger :: Integer -> Integer -> Bool" + , "templateE" : "~ARG[0] = ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.neqInteger" + , "type" : "neqInteger :: Integer -> Integer -> Bool" + , "templateE" : "~ARG[0] /= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.leInteger" + , "type" : "leInteger :: Integer -> Integer -> Bool" + , "templateE" : "~ARG[0] <= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.gtInteger" + , "type" : "gtInteger :: Integer -> Integer -> Bool" + , "templateE" : "~ARG[0] > ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.ltInteger" + , "type" : "ltInteger :: Integer -> Integer -> Bool" + , "templateE" : "~ARG[0] < ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.geInteger" + , "type" : "geInteger :: Integer -> Integer -> Bool" + , "templateE" : "~ARG[0] >= ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.eqInteger#" + , "type" : "eqInteger# :: Integer -> Integer -> Int#" + , "templateD" : "~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.neqInteger#" + , "type" : "neqInteger# :: Integer -> Integer -> Int#" + , "templateD" : "~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.leInteger#" + , "type" : "leInteger# :: Integer -> Integer -> Int#" + , "templateD" : "~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.gtInteger#" + , "type" : "gtInteger# :: Integer -> Integer -> Int#" + , "templateD" : "~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.ltInteger#" + , "type" : "ltInteger# :: Integer -> Integer -> Int#" + , "templateD" : "~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.geInteger#" + , "type" : "geInteger# :: Integer -> Integer -> Int#" + , "templateD" : "~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.shiftRInteger" + , "type" : "shiftRInteger :: Integer -> Int# -> Integer" + , "templateE" : "shift_right(~ARG[0],to_integer(~ARG[1]))" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.shiftLInteger" + , "type" : "shiftLInteger :: Integer -> Int# -> Integer" + , "templateE" : "shift_left(~ARG[0],to_integer(~ARG[1]))" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.wordToInteger" + , "type" : "wordToInteger :: Word# -> Integer" + , "templateE" : "signed(std_logic_vector(~ARG[0]))" + } + } +, { "BlackBox" : + { "name" : "GHC.Integer.Type.integerToWord" + , "type" : "integerToWord :: Integer -> Word#" + , "templateE" : "unsigned(std_logic_vector(~ARG[0]))" + } + } +] diff --git a/prims/vhdl/GHC_Prim.json b/prims/vhdl/GHC_Prim.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/GHC_Prim.json @@ -0,0 +1,1120 @@ +[ { "BlackBox" : + { "name" : "GHC.Prim.gtChar#" + , "type" : "gtChar# :: Char# -> Char# -> Int#" + , "templateD" : "~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.geChar#" + , "type" : "geChar# :: Char# -> Char# -> Int#" + , "templateD" : "~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.eqChar#" + , "type" : "eqChar# :: Char# -> Char# -> Int#" + , "templateD" : "~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.neChar#" + , "type" : "neChar# :: Char# -> Char# -> Int#" + , "templateD" : "~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.ltChar#" + , "type" : "ltChar# :: Char# -> Char# -> Int#" + , "templateD" : "~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.leChar#" + , "type" : "leChar# :: Char# -> Char# -> Int#" + , "templateD" : "~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.ord#" + , "type" : "ord# :: Char# -> Int#" + , "templateE" : "signed(std_logic_vector(resize(~ARG[0],~SIZE[~TYPO])))" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.+#" + , "type" : "(+#) :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] + ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.-#" + , "type" : "(-#) :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] - ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.*#" + , "type" : "(*#) :: Int# -> Int# -> Int#" + , "templateE" : "resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO])" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.quotInt#" + , "type" : "quotInt# :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] / ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.remInt#" + , "type" : "remInt# :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] rem ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.quotRemInt#" + , "type" : "quotRemInt# :: Int# -> Int# -> (#Int#, Int##)" + , "templateE" : "(~ARG[0] / ~ARG[1], ~ARG[0] rem ~ARG[1])" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.andI#" + , "type" : "and# :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] and ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.orI#" + , "type" : "or# :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] or ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.xorI#" + , "type" : "xor# :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] xor ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.notI#" + , "type" : "not# :: Int# -> Int#" + , "templateE" : "not ~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.negateInt#" + , "type" : "negateInt# :: Int# -> Int#" + , "templateE" : "-~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.>#" + , "type" : "(>#) :: Int# -> Int# -> Int#" + , "templateD" : "~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.>=#" + , "type" : "(>=#) :: Int# -> Int# -> Int#" + , "templateD" : "~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.==#" + , "type" : "(==) :: Int# -> Int# -> Int#" + , "templateD" : "~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim./=#" + , "type" : "(/=#) :: Int# -> Int# -> Int#" + , "templateD" : "~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.<#" + , "type" : "(<#) :: Int# -> Int# -> Int#" + , "templateD" : "~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.<=#" + , "type" : "(<=#) :: Int# -> Int# -> Int#" + , "templateD" : "~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.chr#" + , "type" : "ord# :: Int# -> Chr#" + , "templateE" : "resize(unsigned(std_logic_vector(~ARG[0])),21)" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.int2Word#" + , "type" : "word2Int# :: Int# -> Word#" + , "templateE" : "unsigned(std_logic_vector(~ARG[0]))" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.uncheckedIShiftL#" + , "type" : "uncheckedIShiftL# :: Int# -> Int# -> Int#" + , "templateE" : "shift_left(~ARG[0],to_integer(~ARG[1]))" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.uncheckedIShiftRA#" + , "type" : "uncheckedIShiftRA# :: Int# -> Int# -> Int#" + , "templateE" : "shift_right(~ARG[0],to_integer(~ARG[1]))" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.uncheckedIShiftRL#" + , "type" : "uncheckedIShiftRL# :: Int# -> Int# -> Int#" + , "templateE" : "~ARG[0] srl to_integer(~ARG[1])" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.plusWord#" + , "type" : "plusWord# :: Word# -> Word# -> Word#" + , "templateE" : "~ARG[0] + ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.minusWord#" + , "type" : "minusWord# :: Word# -> Word# -> Word#" + , "templateE" : "~ARG[0] - ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.timesWord#" + , "type" : "timesWord# :: Word# -> Word# -> Word#" + , "templateE" : "resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO])" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.quotWord#" + , "type" : "quotWord# :: Word# -> Word# -> Word#" + , "templateE" : "~ARG[0] / ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.remWord#" + , "type" : "remWord# :: Word# -> Word# -> Word#" + , "templateE" : "~ARG[0] rem ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.quotRemWord#" + , "type" : "quotRemWord# :: Word# -> Word# -> (#Word#, Word##)" + , "templateE" : "(~ARG[0] / ~ARG[1], ~ARG[0] rem ~ARG[1])" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.and#" + , "type" : "and# :: Word# -> Word# -> Word#" + , "templateE" : "~ARG[0] and ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.or#" + , "type" : "or# :: Word# -> Word# -> Word#" + , "templateE" : "~ARG[0] or ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.xor#" + , "type" : "xor# :: Word# -> Word# -> Word#" + , "templateE" : "~ARG[0] xor ~ARG[1]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.not#" + , "type" : "not# :: Word# -> Word#" + , "templateE" : "not ~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.uncheckedShiftL#" + , "type" : "uncheckedShiftL# :: Word# -> Int# -> Word#" + , "templateE" : "shift_left(~ARG[0],to_integer(~ARG[1]))" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.uncheckedShiftRL#" + , "type" : "uncheckedShiftR# :: Word# -> Int# -> Word#" + , "templateE" : "shift_right(~ARG[0],to_integer(~ARG[1]))" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.word2Int#" + , "type" : "word2Int# :: word# -> Int#" + , "templateE" : "signed(std_logic_vector(~ARG[0]))" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.gtWord#" + , "type" : "gtWord# :: Word# -> Word# -> Int#" + , "templateD" : "~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.geWord#" + , "type" : "geWord# :: Word# -> Word# -> Int#" + , "templateD" : "~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.eqWord#" + , "type" : "eqWord# :: Word# -> Word# -> Int#" + , "templateD" : "~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.neWord#" + , "type" : "neWord# :: Word# -> Word# -> Int#" + , "templateD" : "~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.ltWord#" + , "type" : "ltWord# :: Word# -> Word# -> Int#" + , "templateD" : "~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.leWord#" + , "type" : "leWord# :: Word# -> Word# -> Int#" + , "templateD" : "~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.popCnt8#" + , "type" : "popCnt8 :: Word# -> Word#" + , "templateD" : +"-- popCnt8 begin +~GENSYM[popCnt8][0] : block + -- given a level and a depth, calculate the corresponding index into the + -- intermediate array + function ~GENSYM[depth2Index][1] (levels,depth : in natural) return natural is + begin + return (2 ** levels - 2 ** depth); + end function; + + constant ~GENSYM[width][2] : natural := 8; + constant ~GENSYM[levels][3] : natural := natural (ceil (log2 (real (~SYM[2])))); + type ~GENSYM[popCnt_res_vec][4] is array (natural range <>) of unsigned(~SYM[3] downto 0); + signal ~GENSYM[intermediate][5] : ~SYM[4](0 to (2*~SYM[2])-2); +begin + -- put input into the first half of the intermediate array + ~GENSYM[make_array][6]: for ~GENSYM[i][7] in 0 to (~SYM[2] - 1) generate + ~SYM[5](i) <= resize(~ARG[0](~SYM[7] downto ~SYM[7]),~SYM[3]+1); + end generate; + + -- Create the tree of adders + ~GENSYM[make_tree][8] : if ~SYM[3] /= 0 generate + ~GENSYM[tree_depth][9] : for ~GENSYM[d][10] in ~SYM[3]-1 downto 0 generate + ~GENSYM[tree_depth_loop][11] : for ~GENSYM[i][12] in 0 to (natural(2**~SYM[10]) - 1) generate + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+1)+~SYM[12]) <= + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])) + + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])+1); + end generate; + end generate; + end generate; + + -- The last element of the intermediate array holds the result + ~RESULT <= resize(~SYM[5]((2*~SYM[2])-2),~SIZE[~TYPO]); +end block; +-- popCnt8 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.popCnt16#" + , "type" : "popCnt16 :: Word# -> Word#" + , "templateD" : +"-- popCnt16 begin +~GENSYM[popCnt16][0] : block + -- given a level and a depth, calculate the corresponding index into the + -- intermediate array + function ~GENSYM[depth2Index][1] (levels,depth : in natural) return natural is + begin + return (2 ** levels - 2 ** depth); + end function; + + constant ~GENSYM[width][2] : natural := 16; + constant ~GENSYM[levels][3] : natural := natural (ceil (log2 (real (~SYM[2])))); + type ~GENSYM[popCnt_res_vec][4] is array (natural range <>) of unsigned(~SYM[3] downto 0); + signal ~GENSYM[intermediate][5] : ~SYM[4](0 to (2*~SYM[2])-2); +begin + -- put input into the first half of the intermediate array + ~GENSYM[make_array][6]: for ~GENSYM[i][7] in 0 to (~SYM[2] - 1) generate + ~SYM[5](i) <= resize(~ARG[0](~SYM[7] downto ~SYM[7]),~SYM[3]+1); + end generate; + + -- Create the tree of adders + ~GENSYM[make_tree][8] : if ~SYM[3] /= 0 generate + ~GENSYM[tree_depth][9] : for ~GENSYM[d][10] in ~SYM[3]-1 downto 0 generate + ~GENSYM[tree_depth_loop][11] : for ~GENSYM[i][12] in 0 to (natural(2**~SYM[10]) - 1) generate + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+1)+~SYM[12]) <= + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])) + + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])+1); + end generate; + end generate; + end generate; + + -- The last element of the intermediate array holds the result + ~RESULT <= resize(~SYM[5]((2*~SYM[2])-2),~SIZE[~TYPO]); +end block; +-- popCnt16 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.popCnt32#" + , "type" : "popCnt16 :: Word# -> Word#" + , "templateD" : +"-- popCnt32 begin +~GENSYM[popCnt32][0] : block + -- given a level and a depth, calculate the corresponding index into the + -- intermediate array + function ~GENSYM[depth2Index][1] (levels,depth : in natural) return natural is + begin + return (2 ** levels - 2 ** depth); + end function; + + constant ~GENSYM[width][2] : natural := 32; + constant ~GENSYM[levels][3] : natural := natural (ceil (log2 (real (~SYM[2])))); + type ~GENSYM[popCnt_res_vec][4] is array (natural range <>) of unsigned(~SYM[3] downto 0); + signal ~GENSYM[intermediate][5] : ~SYM[4](0 to (2*~SYM[2])-2); +begin + -- put input into the first half of the intermediate array + ~GENSYM[make_array][6]: for ~GENSYM[i][7] in 0 to (~SYM[2] - 1) generate + ~SYM[5](i) <= resize(~ARG[0](~SYM[7] downto ~SYM[7]),~SYM[3]+1); + end generate; + + -- Create the tree of adders + ~GENSYM[make_tree][8] : if ~SYM[3] /= 0 generate + ~GENSYM[tree_depth][9] : for ~GENSYM[d][10] in ~SYM[3]-1 downto 0 generate + ~GENSYM[tree_depth_loop][11] : for ~GENSYM[i][12] in 0 to (natural(2**~SYM[10]) - 1) generate + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+1)+~SYM[12]) <= + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])) + + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])+1); + end generate; + end generate; + end generate; + + -- The last element of the intermediate array holds the result + ~RESULT <= resize(~SYM[5]((2*~SYM[2])-2),~SIZE[~TYPO]); +end block; +-- popCnt32 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.popCnt64#" + , "type" : "popCnt16 :: Word# -> Word#" + , "templateD" : +"-- popCnt64 begin +~GENSYM[popCnt64][0] : block + -- given a level and a depth, calculate the corresponding index into the + -- intermediate array + function ~GENSYM[depth2Index][1] (levels,depth : in natural) return natural is + begin + return (2 ** levels - 2 ** depth); + end function; + + constant ~GENSYM[width][2] : natural := 64; + constant ~GENSYM[levels][3] : natural := natural (ceil (log2 (real (~SYM[2])))); + type ~GENSYM[popCnt_res_vec][4] is array (natural range <>) of unsigned(~SYM[3] downto 0); + signal ~GENSYM[intermediate][5] : ~SYM[4](0 to (2*~SYM[2])-2); +begin + -- put input into the first half of the intermediate array + ~GENSYM[make_array][6]: for ~GENSYM[i][7] in 0 to (~SYM[2] - 1) generate + ~SYM[5](i) <= resize(~ARG[0](~SYM[7] downto ~SYM[7]),~SYM[3]+1); + end generate; + + -- Create the tree of adders + ~GENSYM[make_tree][8] : if ~SYM[3] /= 0 generate + ~GENSYM[tree_depth][9] : for ~GENSYM[d][10] in ~SYM[3]-1 downto 0 generate + ~GENSYM[tree_depth_loop][11] : for ~GENSYM[i][12] in 0 to (natural(2**~SYM[10]) - 1) generate + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+1)+~SYM[12]) <= + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])) + + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])+1); + end generate; + end generate; + end generate; + + -- The last element of the intermediate array holds the result + ~RESULT <= resize(~SYM[5]((2*~SYM[2])-2),~SIZE[~TYPO]); +end block; +-- popCnt64 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.popCnt#" + , "type" : "popCnt :: Word# -> Word#" + , "templateD" : +"-- popCnt begin +~GENSYM[popCnt][0] : block + -- given a level and a depth, calculate the corresponding index into the + -- intermediate array + function ~GENSYM[depth2Index][1] (levels,depth : in natural) return natural is + begin + return (2 ** levels - 2 ** depth); + end function; + + constant ~GENSYM[width][2] : natural := ~SIZE[~TYPO]; + constant ~GENSYM[levels][3] : natural := natural (ceil (log2 (real (~SYM[2])))); + type ~GENSYM[popCnt_res_vec][4] is array (natural range <>) of unsigned(~SYM[3] downto 0); + signal ~GENSYM[intermediate][5] : ~SYM[4](0 to (2*~SYM[2])-2); +begin + -- put input into the first half of the intermediate array + ~GENSYM[make_array][6]: for ~GENSYM[i][7] in 0 to (~SYM[2] - 1) generate + ~SYM[5](i) <= resize(~ARG[0](~SYM[7] downto ~SYM[7]),~SYM[3]+1); + end generate; + + -- Create the tree of adders + ~GENSYM[make_tree][8] : if ~SYM[3] /= 0 generate + ~GENSYM[tree_depth][9] : for ~GENSYM[d][10] in ~SYM[3]-1 downto 0 generate + ~GENSYM[tree_depth_loop][11] : for ~GENSYM[i][12] in 0 to (natural(2**~SYM[10]) - 1) generate + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+1)+~SYM[12]) <= + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])) + + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])+1); + end generate; + end generate; + end generate; + + -- The last element of the intermediate array holds the result + ~RESULT <= resize(~SYM[5]((2*~SYM[2])-2),~SIZE[~TYPO]); +end block; +-- popCnt end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.clz8#" + , "type" : "clz8 :: Word# -> Word#" + , "templateD" : +"-- clz8 begin +~GENSYM[clz8][0] : block + function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is + begin + case a is + when \"00\" => return \"10\"; + when \"01\" => return \"01\"; + when \"10\" => return \"00\"; + when others => return \"00\"; + end case; + end function; + + function ~GENSYM[clzi][2] ( + constant n : in natural; + constant i : in unsigned) return unsigned is + variable v : unsigned(i'length-1 downto 0):=i; + begin + if v(n-1+n)='0' then + return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); + else + return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); + end if; + end function; + + function ~GENSYM[clz8][3] (constant v : unsigned(0 to 7)) return unsigned is + variable e : unsigned(0 to 7); -- 8 + variable a : unsigned(0 to 2*3-1); -- 6 + begin + for i in 0 to 3 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; + for i in 0 to 1 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; + return ~SYM[2](3,a(0 to 5)); + end function; +begin + ~RESULT <= resize(~SYM[3](~ARG[0](7 downto 0)),~SIZE[~TYPO]); +end block; +-- clz8 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.clz16#" + , "type" : "clz16 :: Word# -> Word#" + , "templateD" : +"-- clz16 begin +clz16~SYM[0] : block + function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is + begin + case a is + when \"00\" => return \"10\"; + when \"01\" => return \"01\"; + when \"10\" => return \"00\"; + when others => return \"00\"; + end case; + end function; + + function ~GENSYM[clzi][2] ( + constant n : in natural; + constant i : in unsigned) return unsigned is + variable v : unsigned(i'length-1 downto 0):=i; + begin + if v(n-1+n)='0' then + return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); + else + return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); + end if; + end function; + + function ~GENSYM[clz16][3] (constant v : unsigned(0 to 15)) return unsigned is + variable e : unsigned(0 to 15); -- 16 + variable a : unsigned(0 to 4*3-1); -- 12 + variable b : unsigned(0 to 2*4-1); -- 8 + begin + for i in 0 to 7 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; + for i in 0 to 3 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; + for i in 0 to 1 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; + return ~SYM[2](4,b(0 to 7)); + end function; +begin + ~RESULT <= resize(~SYM[3](~ARG[0](15 downto 0)),~SIZE[~TYPO]); +end block; +-- clz16 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.clz32#" + , "type" : "clz32 :: Word# -> Word#" + , "templateD" : +"-- clz32 begin +clz32~SYM[0] : block + function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is + begin + case a is + when \"00\" => return \"10\"; + when \"01\" => return \"01\"; + when \"10\" => return \"00\"; + when others => return \"00\"; + end case; + end function; + + function ~GENSYM[clzi][2] ( + constant n : in natural; + constant i : in unsigned) return unsigned is + variable v : unsigned(i'length-1 downto 0):=i; + begin + if v(n-1+n)='0' then + return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); + else + return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); + end if; + end function; + + function ~GENSYM[clz32][3] (constant v : unsigned(0 to 31)) return unsigned is + variable e : unsigned(0 to 31); -- 32 + variable a : unsigned(0 to 8*3-1); -- 24 + variable b : unsigned(0 to 4*4-1); -- 16 + variable c : unsigned(0 to 2*5-1); -- 10 + begin + for i in 0 to 15 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; + for i in 0 to 7 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; + for i in 0 to 3 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; + for i in 0 to 1 loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop; + return ~SYM[2](5,c(0 to 9)); + end function; +begin + ~RESULT <= resize(~SYM[3](~ARG[0](31 downto 0)),~SIZE[~TYPO]); +end block; +-- clz32 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.clz64#" + , "type" : "clz64 :: Word# -> Word#" + , "templateD" : +"-- clz64 begin +clz64~SYM[0] : block + function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is + begin + case a is + when \"00\" => return \"10\"; + when \"01\" => return \"01\"; + when \"10\" => return \"00\"; + when others => return \"00\"; + end case; + end function; + + function ~GENSYM[clzi][2] ( + constant n : in natural; + constant i : in unsigned) return unsigned is + variable v : unsigned(i'length-1 downto 0):=i; + begin + if v(n-1+n)='0' then + return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); + else + return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); + end if; + end function; + + function ~GENSYM[clz64][3] (constant v : unsigned(0 to 63)) return unsigned is + variable e : unsigned(0 to 63); -- 64 + variable a : unsigned(0 to 16*3-1); -- 48 + variable b : unsigned(0 to 8*4-1); -- 32 + variable c : unsigned(0 to 4*5-1); -- 20 + variable d : unsigned(0 to 2*6-1); -- 12 + begin + for i in 0 to 31 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; + for i in 0 to 15 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; + for i in 0 to 7 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; + for i in 0 to 3 loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop; + for i in 0 to 1 loop d(i*6 to i*6+5):=~SYM[2](5,c(i*10 to i*10+9)); end loop; + return ~SYM[2](6,d(0 to 11)); + end function; +begin + ~RESULT <= resize(~SYM[3](~ARG[0]),~SIZE[~TYPO]); +end block; +-- clz64 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.clz#" + , "type" : "clz :: Word# -> Word#" + , "templateD" : +"-- clz begin +clz~SYM[0] : block + function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is + begin + case a is + when \"00\" => return \"10\"; + when \"01\" => return \"01\"; + when \"10\" => return \"00\"; + when others => return \"00\"; + end case; + end function; + + function ~GENSYM[clzi][2] ( + constant n : in natural; + constant i : in unsigned) return unsigned is + variable v : unsigned(i'length-1 downto 0):=i; + begin + if v(n-1+n)='0' then + return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); + else + return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); + end if; + end function; +~IF ~IW64 ~THEN + function ~GENSYM[clz64][3] (constant v : unsigned(0 to 63)) return unsigned is + variable e : unsigned(0 to 63); -- 64 + variable a : unsigned(0 to 16*3-1); -- 48 + variable b : unsigned(0 to 8*4-1); -- 32 + variable c : unsigned(0 to 4*5-1); -- 20 + variable d : unsigned(0 to 2*6-1); -- 12 + begin + for i in 0 to 31 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; + for i in 0 to 15 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; + for i in 0 to 7 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; + for i in 0 to 3 loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop; + for i in 0 to 1 loop d(i*6 to i*6+5):=~SYM[2](5,c(i*10 to i*10+9)); end loop; + return ~SYM[2](6,d(0 to 11)); + end function; +~ELSE + function ~GENSYM[clz32][4] (constant v : unsigned(0 to 31)) return unsigned is + variable e : unsigned(0 to 31); -- 32 + variable a : unsigned(0 to 8*3-1); -- 24 + variable b : unsigned(0 to 4*4-1); -- 16 + variable c : unsigned(0 to 2*5-1); -- 10 + begin + for i in 0 to 15 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; + for i in 0 to 7 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; + for i in 0 to 3 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; + for i in 0 to 1 loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop; + return ~SYM[2](5,c(0 to 9)); + end function; +~FI +begin +~IF ~IW64 ~THEN + ~RESULT <= resize(~SYM[3](~ARG[0]),~SIZE[~TYPO]); +~ELSE + ~RESULT <= resize(~SYM[4](~ARG[0]),~SIZE[~TYPO]); +~FI +end block; +-- clz end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.ctz8#" + , "type" : "ctz8 :: Word# -> Word#" + , "templateD" : +"-- ctz8 begin +~GENSYM[ctz8][0] : block + function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is + begin + case a is + when \"00\" => return \"10\"; + when \"01\" => return \"01\"; + when \"10\" => return \"00\"; + when others => return \"00\"; + end case; + end function; + + function ~GENSYM[clzi][2] ( + constant n : in natural; + constant i : in unsigned) return unsigned is + variable v : unsigned(i'length-1 downto 0):=i; + begin + if v(n-1+n)='0' then + return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); + else + return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); + end if; + end function; + + function ~GENSYM[clz8][3] (constant v : unsigned(0 to 7)) return unsigned is + variable e : unsigned(0 to 7); -- 8 + variable a : unsigned(0 to 2*3-1); -- 6 + begin + for i in 0 to 3 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; + for i in 0 to 1 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; + return ~SYM[2](3,a(0 to 5)); + end function; + + signal ~GENSYM[w_reversed][5] : ~TYP[0]; +begin + ~GENSYM[reverse_loop][6] : for ~GENSYM[n][7] in ~VAR[w][0]'range generate + ~SYM[5](~VAR[w][0]'high - ~SYM[7]) <= ~VAR[w][0](~SYM[7]); + end generate; +~IF ~IW64 ~THEN + ~RESULT <= resize(~SYM[3](~SYM[5](63 downto 56)),~SIZE[~TYPO]); +~ELSE + ~RESULT <= resize(~SYM[3](~SYM[5](31 downto 24)),~SIZE[~TYPO]); +~FI +end block; +-- ctz8 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.ctz16#" + , "type" : "ctz16 :: Word# -> Word#" + , "templateD" : +"-- ctz16 begin +~GENSYM[ctz16][0] : block + function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is + begin + case a is + when \"00\" => return \"10\"; + when \"01\" => return \"01\"; + when \"10\" => return \"00\"; + when others => return \"00\"; + end case; + end function; + + function ~GENSYM[clzi][2] ( + constant n : in natural; + constant i : in unsigned) return unsigned is + variable v : unsigned(i'length-1 downto 0):=i; + begin + if v(n-1+n)='0' then + return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); + else + return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); + end if; + end function; + + function ~GENSYM[clz16][3] (constant v : unsigned(0 to 15)) return unsigned is + variable e : unsigned(0 to 15); -- 16 + variable a : unsigned(0 to 4*3-1); -- 12 + variable b : unsigned(0 to 2*4-1); -- 8 + begin + for i in 0 to 7 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; + for i in 0 to 3 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; + for i in 0 to 1 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; + return ~SYM[2](4,b(0 to 7)); + end function; + + signal ~GENSYM[w_reversed][5] : ~TYP[0]; +begin + ~GENSYM[reverse_loop][6] : for ~GENSYM[n][7] in ~VAR[w][0]'range generate + ~SYM[5](~VAR[w][0]'high - ~SYM[7]) <= ~VAR[w][0](~SYM[7]); + end generate; +~IF ~IW64 ~THEN + ~RESULT <= resize(~SYM[3](~SYM[5](63 downto 48)),~SIZE[~TYPO]); +~ELSE + ~RESULT <= resize(~SYM[3](~SYM[5](31 downto 16)),~SIZE[~TYPO]); +~FI +end block; +-- ctz16 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.ctz32#" + , "type" : "ctz32 :: Word# -> Word#" + , "templateD" : +"-- ctz32 begin +~GENSYM[ctz32][0] : block + function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is + begin + case a is + when \"00\" => return \"10\"; + when \"01\" => return \"01\"; + when \"10\" => return \"00\"; + when others => return \"00\"; + end case; + end function; + + function ~GENSYM[clzi][2] ( + constant n : in natural; + constant i : in unsigned) return unsigned is + variable v : unsigned(i'length-1 downto 0):=i; + begin + if v(n-1+n)='0' then + return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); + else + return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); + end if; + end function; + + function ~GENSYM[clz32][3] (constant v : unsigned(0 to 31)) return unsigned is + variable e : unsigned(0 to 31); -- 32 + variable a : unsigned(0 to 8*3-1); -- 24 + variable b : unsigned(0 to 4*4-1); -- 16 + variable c : unsigned(0 to 2*5-1); -- 10 + begin + for i in 0 to 15 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; + for i in 0 to 7 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; + for i in 0 to 3 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; + for i in 0 to 1 loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop; + return ~SYM[2](5,c(0 to 9)); + end function; + + signal ~GENSYM[w_reversed][5] : ~TYP[0]; +begin + ~GENSYM[reverse_loop][6] : for ~GENSYM[n][7] in ~VAR[w][0]'range generate + ~SYM[5](~VAR[w][0]'high - ~SYM[7]) <= ~VAR[w][0](~SYM[3]); + end generate; +~IF ~IW64 ~THEN + ~RESULT <= resize(~SYM[3](~SYM[5](63 downto 32)),~SIZE[~TYPO]); +~ELSE + ~RESULT <= resize(~SYM[3](~SYM[5]),~SIZE[~TYPO]); +~FI +end block; +-- ctz32 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.ctz64#" + , "type" : "ctz64 :: Word# -> Word#" + , "templateD" : +"-- ctz64 begin +~GENSYM[ctz64][0] : block + function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is + begin + case a is + when \"00\" => return \"10\"; + when \"01\" => return \"01\"; + when \"10\" => return \"00\"; + when others => return \"00\"; + end case; + end function; + + function ~GENSYM[clzi][2] ( + constant n : in natural; + constant i : in unsigned) return unsigned is + variable v : unsigned(i'length-1 downto 0):=i; + begin + if v(n-1+n)='0' then + return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); + else + return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); + end if; + end function; + + function ~GENSYM[clz64][3] (constant v : unsigned(0 to 63)) return unsigned is + variable e : unsigned(0 to 63); -- 64 + variable a : unsigned(0 to 16*3-1); -- 48 + variable b : unsigned(0 to 8*4-1); -- 32 + variable c : unsigned(0 to 4*5-1); -- 20 + variable d : unsigned(0 to 2*6-1); -- 12 + begin + for i in 0 to 31 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; + for i in 0 to 15 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; + for i in 0 to 7 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; + for i in 0 to 3 loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop; + for i in 0 to 1 loop d(i*6 to i*6+5):=~SYM[2](5,c(i*10 to i*10+9)); end loop; + return ~SYM[2](6,d(0 to 11)); + end function; + + signal ~GENSYM[w_reversed][5] : ~TYP[0]; +begin + ~GENSYM[reverse_loop][6] : for ~GENSYM[n][7] in ~VAR[w][0]'range generate + ~SYM[5](~VAR[w][0]'high - ~SYM[7]) <= ~VAR[w][0](~SYM[7]); + end generate; + + ~RESULT <= resize(~SYM[3](~SYM[5]),~SIZE[~TYPO]); +end block; +-- ctz64 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.ctz#" + , "type" : "ctz :: Word# -> Word#" + , "templateD" : +"-- ctz begin +~GENSYM[ctz][0] : block + function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is + begin + case a is + when \"00\" => return \"10\"; + when \"01\" => return \"01\"; + when \"10\" => return \"00\"; + when others => return \"00\"; + end case; + end function; + + function ~GENSYM[clzi][2] ( + constant n : in natural; + constant i : in unsigned) return unsigned is + variable v : unsigned(i'length-1 downto 0):=i; + begin + if v(n-1+n)='0' then + return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); + else + return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); + end if; + end function; + +~IF ~IW64 ~THEN + function ~GENSYM[clz64][3] (constant v : unsigned(0 to 63)) return unsigned is + variable e : unsigned(0 to 63); -- 64 + variable a : unsigned(0 to 16*3-1); -- 48 + variable b : unsigned(0 to 8*4-1); -- 32 + variable c : unsigned(0 to 4*5-1); -- 20 + variable d : unsigned(0 to 2*6-1); -- 12 + begin + for i in 0 to 31 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; + for i in 0 to 15 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; + for i in 0 to 7 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; + for i in 0 to 3 loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop; + for i in 0 to 1 loop d(i*6 to i*6+5):=~SYM[2](5,c(i*10 to i*10+9)); end loop; + return ~SYM[2](6,d(0 to 11)); + end function; +~ELSE + function ~GENSYM[clz32][4] (constant v : unsigned(0 to 31)) return unsigned is + variable e : unsigned(0 to 31); -- 32 + variable a : unsigned(0 to 8*3-1); -- 24 + variable b : unsigned(0 to 4*4-1); -- 16 + variable c : unsigned(0 to 2*5-1); -- 10 + begin + for i in 0 to 15 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; + for i in 0 to 7 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; + for i in 0 to 3 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; + for i in 0 to 1 loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop; + return ~SYM[2](5,c(0 to 9)); + end function; +~FI + + signal ~GENSYM[w_reversed][6] : ~TYP[0]; +begin + ~GENSYM[reverse_loop][7] : for ~GENSYM[n][8] in ~VAR[w][0]'range generate + ~SYM[6](~VAR[w][0]'high - ~SYM[8]) <= ~VAR[w][0](~SYM[8]); + end generate; +~IF ~IW64 ~THEN + ~RESULT <= resize(~SYM[3](~SYM[6]),~SIZE[~TYPO]); +~ELSE + ~RESULT <= resize(~SYM[4](~SYM[6]),~SIZE[~TYPO]); +~FI +end block; +-- ctz end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.byteSwap16#" + , "type" : "byteSwap16# :: Word# -> Word#" + , "templateD" : +"-- byteSwap16 begin~IF ~IW64 ~THEN +~RESULT <= ~VAR[w][0](63 downto 16) & ~VAR[w][0](7 downto 0) & ~VAR[w][0](15 downto 8);~ELSE +~RESULT <= ~VAR[w][0](31 downto 16) & ~VAR[w][0](7 downto 0) & ~VAR[w][0](15 downto 8);~FI +-- byteSwap16 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.byteSwap32#" + , "type" : "byteSwap32# :: Word# -> Word#" + , "templateD" : +"-- byteSwap32 begin~IF ~IW64 ~THEN +~RESULT <= ~VAR[w][0](63 downto 32) & ~VAR[w][0](7 downto 0 ) & ~VAR[w][0](15 downto 8) + & ~VAR[w][0](23 downto 16) & ~VAR[w][0](31 downto 24);~ELSE +~RESULT <= ~VAR[w][0](7 downto 0 ) & ~VAR[w][0](15 downto 8) + & ~VAR[w][0](23 downto 16) & ~VAR[w][0](31 downto 24);~FI +-- byteSwap32 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.byteSwap64#" + , "type" : "byteSwap64# :: Word# -> Word#" + , "templateD" : +"-- byteSwap64 begin +~RESULT <= ~VAR[w][0](7 downto 0 ) & ~VAR[w][0](15 downto 8) + & ~VAR[w][0](23 downto 16) & ~VAR[w][0](31 downto 24) + & ~VAR[w][0](39 downto 32) & ~VAR[w][0](47 downto 40) + & ~VAR[w][0](55 downto 48) & ~VAR[w][0](63 downto 56); +-- byteSwap64 end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.byteSwap#" + , "type" : "byteSwap# :: Word# -> Word#" + , "templateD" : +"-- byteSwap begin ~IF ~IW64 ~THEN +~RESULT <= ~VAR[w][0](7 downto 0 ) & ~VAR[w][0](15 downto 8) + & ~VAR[w][0](23 downto 16) & ~VAR[w][0](31 downto 24) + & ~VAR[w][0](39 downto 32) & ~VAR[w][0](47 downto 40) + & ~VAR[w][0](55 downto 48) & ~VAR[w][0](63 downto 56);~ELSE +~RESULT <= ~VAR[w][0](7 downto 0 ) & ~VAR[w][0](15 downto 8) + & ~VAR[w][0](23 downto 16) & ~VAR[w][0](31 downto 24);~FI +-- byteSwap end" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.narrow8Int#" + , "type" : "narrow8Int# :: Int# -> Int#" + , "templateE" : "resize(~VAR[i][0](7 downto 0),~SIZE[~TYPO])" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.narrow16Int#" + , "type" : "narrow16Int# :: Int# -> Int#" + , "templateE" : "resize(~VAR[i][0](15 downto 0),~SIZE[~TYPO])" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.narrow32Int#" + , "type" : "narrow32Int# :: Int# -> Int#" + , "templateE" : "resize(~VAR[i][0](31 downto 0),~SIZE[~TYPO])" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.narrow8Word#" + , "type" : "narrow8Word# :: Word# -> Word#" + , "templateE" : "resize(~VAR[w][0](7 downto 0),~SIZE[~TYPO])" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.narrow16Word#" + , "type" : "narrow16Word# :: Word# -> Word#" + , "templateE" : "resize(~VAR[w][0](15 downto 0),~SIZE[~TYPO])" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.narrow32Word#" + , "type" : "narrow32Word# :: Word# -> Word#" + , "templateE" : "resize(~VAR[w][0](31 downto 0),~SIZE[~TYPO])" + } + } +, { "Primitive" : + { "name" : "GHC.Prim.dataToTag#" + , "primType" : "Function" + } + } +, { "Primitive" : + { "name" : "GHC.Prim.tagToEnum#" + , "primType" : "Function" + } + } +, { "BlackBox" : + { "name" : "GHC.Prim.unsafeCoerce#" + , "type" : "unsafeCoerce# :: a -> b" + , "templateE" : "~ARG[0]" + } + } +] diff --git a/prims/vhdl/GHC_Types.json b/prims/vhdl/GHC_Types.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/GHC_Types.json @@ -0,0 +1,24 @@ +[ { "Primitive" : + { "name" : "GHC.Types.MkCoercible" + , "primType" : "Constructor" + } + } +, { "BlackBox" : + { "name" : "GHC.Types.C#" + , "type" : "C# :: Char# -> Char" + , "templateE" : "~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "GHC.Types.I#" + , "type" : "I# :: Int# -> Int" + , "templateE" : "~ARG[0]" + } + } +, { "BlackBox" : + { "name" : "GHC.Types.W#" + , "type" : "W# :: Word# -> Word" + , "templateE" : "~ARG[0]" + } + } +] diff --git a/prims/vhdl/GHC_Word.json b/prims/vhdl/GHC_Word.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/GHC_Word.json @@ -0,0 +1,25 @@ +[ { "BlackBox" : + { "name" : "GHC.Word.W8#" + , "type" : "W8# :: Word# -> Word8" + , "templateE" : "resize(~ARG[0],8)" + } + } +, { "BlackBox" : + { "name" : "GHC.Word.W16#" + , "type" : "W16# :: Word# -> Word16" + , "templateE" : "resize(~ARG[0],16)" + } + } +, { "BlackBox" : + { "name" : "GHC.Word.W32#" + , "type" : "W32# :: Word# -> Word32" + , "templateE" : "resize(~ARG[0],32)" + } + } +, { "BlackBox" : + { "name" : "GHC.Word.W64#" + , "type" : "W64# :: Word# -> Word64" + , "templateE" : "resize(~ARG[0],64)" + } + } +] diff --git a/src/CLaSH/Backend.hs b/src/CLaSH/Backend.hs deleted file mode 100644 --- a/src/CLaSH/Backend.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-| - Copyright : (C) 2015-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij --} - -module CLaSH.Backend where - -import Data.HashSet (HashSet) -import Data.Text.Lazy (Text) -import Control.Monad.State (State) -import Text.PrettyPrint.Leijen.Text.Monadic (Doc) - -import SrcLoc (SrcSpan) - -import CLaSH.Netlist.Types -import CLaSH.Netlist.BlackBox.Types - -import CLaSH.Annotations.Primitive (HDL) - -type ModName = String - -class Backend state where - -- | Initial state for state monad - initBackend :: Int -> HdlSyn -> state - - -- | What HDL is the backend generating - hdlKind :: state -> HDL - - -- | Location for the primitive definitions - primDir :: state -> IO FilePath - - -- | Name of backend, used for directory to put output files in. Should be - -- | constant function / ignore argument. - name :: state -> String - - -- | File extension for target langauge - extension :: state -> String - - -- | Get the set of types out of state - extractTypes :: state -> HashSet HWType - - -- | Generate HDL for a Netlist component - genHDL :: String -> SrcSpan -> Component -> State state ((String, Doc),[(String,Doc)]) - -- | Generate a HDL package containing type definitions for the given HWTypes - mkTyPackage :: String -> [HWType] -> State state [(String, Doc)] - -- | Convert a Netlist HWType to a target HDL type - hdlType :: HWType -> State state Doc - -- | Convert a Netlist HWType to an HDL error value for that type - hdlTypeErrValue :: HWType -> State state Doc - -- | Convert a Netlist HWType to the root of a target HDL type - hdlTypeMark :: HWType -> State state Doc - -- | Create a signal declaration from an identifier (Text) and Netlist HWType - hdlSig :: Text -> HWType -> State state Doc - -- | Create a generative block statement marker - genStmt :: Bool -> State state Doc - -- | Turn a Netlist Declaration to a HDL concurrent block - inst :: Declaration -> State state (Maybe Doc) - -- | Turn a Netlist expression into a HDL expression - expr :: Bool -> Expr -> State state Doc - -- | Bit-width of Int/Word/Integer - iwWidth :: State state Int - -- | Convert to a bit-vector - toBV :: HWType -> Text -> State state Doc - -- | Convert from a bit-vector - fromBV :: HWType -> Text -> State state Doc - -- | Synthesis tool we're generating HDL for - hdlSyn :: State state HdlSyn - -- | mkBasicId - mkBasicId :: State state (Identifier -> Identifier) - -- | setModName - setModName :: ModName -> state -> state - -- | setSrcSpan - setSrcSpan :: SrcSpan -> State state () - -- | getSrcSpan - getSrcSpan :: State state SrcSpan diff --git a/src/CLaSH/Core/DataCon.hs b/src/CLaSH/Core/DataCon.hs deleted file mode 100644 --- a/src/CLaSH/Core/DataCon.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Data Constructors in CoreHW --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} - -module CLaSH.Core.DataCon - ( DataCon (..) - , DcName - , ConTag - , dataConInstArgTys - ) -where - -#ifndef MIN_VERSION_unbound_generics -#define MIN_VERSION_unbound_generics(x,y,z)(1) -#endif - -import Control.DeepSeq (NFData(..)) -import GHC.Generics (Generic) -import Unbound.Generics.LocallyNameless (Alpha(..),Name,Subst(..)) -import Unbound.Generics.LocallyNameless.Extra () -#if MIN_VERSION_unbound_generics(0,3,0) -import Data.Monoid (All (..)) -import Unbound.Generics.LocallyNameless (NthPatFind (..), - NamePatFind (..)) -#endif - -import {-# SOURCE #-} CLaSH.Core.Type (TyName, Type) -import CLaSH.Util - --- | Data Constructor -data DataCon - = MkData - { dcName :: !DcName -- ^ Name of the DataCon - , dcTag :: !ConTag -- ^ Syntactical position in the type definition - , dcType :: !Type -- ^ Type of the 'DataCon - , dcUnivTyVars :: [TyName] -- ^ Universally quantified type-variables, - -- these type variables are also part of the - -- result type of the DataCon - , dcExtTyVars :: [TyName] -- ^ Existentially quantified type-variables, - -- these type variables are not part of the result - -- of the DataCon, but only of the arguments. - , dcArgTys :: [Type] -- ^ Argument types - } deriving (Generic,NFData) - -instance Show DataCon where - show = show . dcName - -instance Eq DataCon where - (==) = (==) `on` dcName - -instance Ord DataCon where - compare = compare `on` dcName - --- | Syntactical position of the DataCon in the type definition -type ConTag = Int --- | DataCon reference -type DcName = Name DataCon - -instance Alpha DataCon where - aeq' c dc1 dc2 = aeq' c (dcName dc1) (dcName dc2) - - fvAny' _ _ dc = pure dc - - close _ _ dc = dc - open _ _ dc = dc - - isPat _ = mempty - -#if MIN_VERSION_unbound_generics(0,3,0) - isTerm _ = All True - nthPatFind _ = NthPatFind Left - namePatFind _ = NamePatFind (const (Left 0)) -#else - isTerm _ = True - nthPatFind _ = Left - namePatFind _ _ = Left 0 -#endif - - swaps' _ _ dc = dc - lfreshen' _ dc cont = cont dc mempty - freshen' _ dc = return (dc,mempty) - - acompare' c dc1 dc2 = acompare' c (dcName dc1) (dcName dc2) - -instance Subst a DataCon where - subst _ _ dc = dc - substs _ dc = dc - --- | Given a DataCon and a list of types, the type variables of the DataCon --- type are substituted for the list of types. The argument types are returned. --- --- The list of types should be equal to the number of type variables, otherwise --- @Nothing@ is returned. -dataConInstArgTys :: DataCon -> [Type] -> Maybe [Type] -dataConInstArgTys (MkData { dcArgTys = arg_tys - , dcUnivTyVars = univ_tvs - , dcExtTyVars = ex_tvs - }) - inst_tys - | length tyvars == length inst_tys - = Just (map (substs (zip tyvars inst_tys)) arg_tys) - - | otherwise - = Nothing - - where - tyvars = univ_tvs ++ ex_tvs diff --git a/src/CLaSH/Core/FreeVars.hs b/src/CLaSH/Core/FreeVars.hs deleted file mode 100644 --- a/src/CLaSH/Core/FreeVars.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Free variable calculations --} - -module CLaSH.Core.FreeVars where - -import Control.Lens.Fold (Fold) -import Unbound.Generics.LocallyNameless (fv) - -import CLaSH.Core.Term (Term, TmName) -import CLaSH.Core.Type (TyName, Type) - --- | Gives the free type-variables in a Type -typeFreeVars :: Fold Type TyName -typeFreeVars = fv - --- | Gives the free term-variables of a Term -termFreeIds :: Fold Term TmName -termFreeIds = fv - --- | Gives the free type-variables of a Term -termFreeTyVars :: Fold Term TyName -termFreeTyVars = fv diff --git a/src/CLaSH/Core/Literal.hs b/src/CLaSH/Core/Literal.hs deleted file mode 100644 --- a/src/CLaSH/Core/Literal.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Term Literal --} - -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module CLaSH.Core.Literal - ( Literal (..) - , literalType - ) -where - -import Control.DeepSeq (NFData (..)) -import GHC.Generics (Generic) -import Unbound.Generics.LocallyNameless.Extra () -import Unbound.Generics.LocallyNameless (Alpha (..), Subst (..)) - -import {-# SOURCE #-} CLaSH.Core.Type (Type) -import CLaSH.Core.TysPrim (intPrimTy, integerPrimTy, - charPrimTy, stringPrimTy, - wordPrimTy, - int64PrimTy, word64PrimTy, - floatPrimTy, doublePrimTy) - --- | Term Literal -data Literal - = IntegerLiteral !Integer - | IntLiteral !Integer - | WordLiteral !Integer - | Int64Literal !Integer - | Word64Literal !Integer - | StringLiteral !String - | FloatLiteral !Rational - | DoubleLiteral !Rational - | CharLiteral !Char - deriving (Eq,Ord,Show,Generic,NFData) - -instance Alpha Literal where - fvAny' _ _ l = pure l - -instance Subst a Literal where - subst _ _ l = l - substs _ l = l - --- | Determines the Type of a Literal -literalType :: Literal - -> Type -literalType (IntegerLiteral _) = integerPrimTy -literalType (IntLiteral _) = intPrimTy -literalType (WordLiteral _) = wordPrimTy -literalType (StringLiteral _) = stringPrimTy -literalType (FloatLiteral _) = floatPrimTy -literalType (DoubleLiteral _) = doublePrimTy -literalType (CharLiteral _) = charPrimTy -literalType (Int64Literal _) = int64PrimTy -literalType (Word64Literal _) = word64PrimTy diff --git a/src/CLaSH/Core/Pretty.hs b/src/CLaSH/Core/Pretty.hs deleted file mode 100644 --- a/src/CLaSH/Core/Pretty.hs +++ /dev/null @@ -1,358 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Pretty printing class and instances for CoreHW --} - -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} - -module CLaSH.Core.Pretty - ( Pretty (..) - , showDoc - ) -where - -import Data.Char (isSymbol, isUpper, ord) -import Data.Text (unpack) -import GHC.Show (showMultiLineString) -import Numeric (fromRat) -import Text.PrettyPrint (Doc, char, comma, empty, equals, hang, - hsep, integer, parens, punctuate, - render, sep, text, vcat, ($$), ($+$), - (<+>), (<>), nest, float, double) -import Unbound.Generics.LocallyNameless (Embed (..), LFresh, Name, lunbind, - name2String, runLFreshM, unembed, - unrebind, unrec) - -import CLaSH.Core.DataCon (DataCon (..)) -import CLaSH.Core.Literal (Literal (..)) -import CLaSH.Core.Term (Pat (..), Term (..)) -import CLaSH.Core.TyCon (TyCon (..), TyConName, isTupleTyConLike) -import CLaSH.Core.Type (ConstTy (..), Kind, LitTy (..), - Type (..), TypeView (..), tyView) -import CLaSH.Core.Var (Id, TyVar, Var, varKind, varName, - varType) -import CLaSH.Util - --- | Pretty printing Show-like typeclass -class Pretty p where - ppr :: LFresh m => p -> m Doc - ppr = pprPrec 0 - - pprPrec :: LFresh m => Rational -> p -> m Doc - -noPrec, opPrec, appPrec :: Num a => a -noPrec = 0 -opPrec = 1 -appPrec = 2 - --- | Print a Pretty thing to a String -showDoc :: Pretty p => p -> String -showDoc = render . runLFreshM . ppr - -prettyParen :: Bool -> Doc -> Doc -prettyParen False = id -prettyParen True = parens - -instance Pretty (Name a) where - pprPrec _ = return . text . show - -instance Pretty a => Pretty [a] where - pprPrec prec xs = do - xs' <- mapM (pprPrec prec) xs - return $ vcat xs' - -instance Pretty (Id, Term) where - pprPrec _ = pprTopLevelBndr - -pprTopLevelBndr :: LFresh m => (Id,Term) -> m Doc -pprTopLevelBndr (bndr,expr) = do - bndr' <- ppr bndr - bndrName <- ppr (varName bndr) - expr' <- ppr expr - return $ bndr' $$ hang (bndrName <+> equals) 2 expr' <> text "\n" - -dcolon :: Doc -dcolon = text "::" - -period :: Doc -period = char '.' - -rarrow :: Doc -rarrow = text "->" - -instance Pretty Type where - pprPrec _ = pprType - -instance Pretty (Var Type) where - pprPrec _ v = ppr $ varName v - -instance Pretty TyCon where - pprPrec _ tc = return . text . name2String $ tyConName tc - -instance Pretty LitTy where - pprPrec _ (NumTy i) = return $ integer i - pprPrec _ (SymTy s) = return $ text s - -instance Pretty Term where - pprPrec prec e = case e of - Var _ x -> pprPrec prec x - Data dc -> pprPrec prec dc - Literal l -> pprPrec prec l - Prim nm _ -> return $ text $ unpack nm - Lam b -> lunbind b $ \(v,e') -> pprPrecLam prec [v] e' - TyLam b -> lunbind b $ \(tv,e') -> pprPrecTyLam prec [tv] e' - App fun arg -> pprPrecApp prec fun arg - TyApp e' ty -> pprPrecTyApp prec e' ty - Letrec b -> lunbind b $ \(xes,e') -> pprPrecLetrec prec (unrec xes) e' - Case e' _ alts -> pprPrecCase prec e' =<< mapM (`lunbind` return) alts - -data BindingSite - = LambdaBind - | CaseBind - | LetBind - -instance Pretty (Var Term) where - pprPrec _ v = do - v' <- ppr (varName v) - ty' <- ppr (unembed $ varType v) - return $ v' <+> dcolon <+> ty' - -instance Pretty DataCon where - pprPrec _ dc = return . text . name2String $ dcName dc - -instance Pretty Literal where - pprPrec _ l = case l of - IntegerLiteral i - | i < 0 -> return $ parens (integer i) - | otherwise -> return $ integer i - IntLiteral i - | i < 0 -> return $ parens (integer i) - | otherwise -> return $ integer i - Int64Literal i - | i < 0 -> return $ parens (integer i) - | otherwise -> return $ integer i - WordLiteral w -> return $ integer w - Word64Literal w -> return $ integer w - FloatLiteral r -> return $ float (fromRat r) - DoubleLiteral r -> return $ double (fromRat r) - CharLiteral c -> return $ char c - StringLiteral s -> return $ vcat $ map text $ showMultiLineString s - -instance Pretty Pat where - pprPrec prec pat = case pat of - DataPat dc pxs -> do - let (txs,xs) = unrebind pxs - dc' <- ppr (unembed dc) - txs' <- mapM (pprBndr LetBind) txs - xs' <- mapM (pprBndr CaseBind) xs - return $ prettyParen (prec >= appPrec) $ dc' <+> hsep txs' $$ (nest 2 (vcat xs')) - LitPat l -> ppr (unembed l) - DefaultPat -> return $ char '_' - -pprPrecLam :: LFresh m => Rational -> [Id] -> Term -> m Doc -pprPrecLam prec xs e = do - xs' <- mapM (pprBndr LambdaBind) xs - e' <- pprPrec noPrec e - return $ prettyParen (prec > noPrec) $ - char 'λ' <> hsep xs' <+> rarrow $+$ e' - -pprPrecTyLam :: LFresh m => Rational -> [TyVar] -> Term -> m Doc -pprPrecTyLam prec tvs e = do - tvs' <- mapM ppr tvs - e' <- pprPrec noPrec e - return $ prettyParen (prec > noPrec) $ - char 'Λ' <> hsep tvs' <+> rarrow $+$ e' - -pprPrecApp :: LFresh m => Rational -> Term -> Term -> m Doc -pprPrecApp prec e1 e2 = do - e1' <- pprPrec opPrec e1 - e2' <- pprPrec appPrec e2 - return $ prettyParen (prec >= appPrec) $ e1' $$ (nest 2 e2') - -pprPrecTyApp :: LFresh m => Rational -> Term -> Type -> m Doc -pprPrecTyApp prec e ty = do - e' <- pprPrec opPrec e - ty' <- pprParendType ty - return $ prettyParen (prec >= appPrec) $ e' $$ (char '@' <> ty') - -pprPrecLetrec :: LFresh m => Rational -> [(Id, Embed Term)] -> Term - -> m Doc -pprPrecLetrec prec xes body - | [] <- xes = pprPrec prec body - | otherwise = do - body' <- pprPrec noPrec body - xes' <- mapM (\(x,e) -> do - x' <- pprBndr LetBind x - e' <- pprPrec noPrec (unembed e) - return $ x' $$ equals <+> e' - ) xes - return $ prettyParen (prec > noPrec) $ - hang (text "letrec") 2 (vcat xes') $$ text "in" <+> body' - -pprPrecCase :: LFresh m => Rational -> Term -> [(Pat,Term)] -> m Doc -pprPrecCase prec e alts = do - e' <- pprPrec prec e - alts' <- mapM (pprPrecAlt noPrec) alts - return $ prettyParen (prec > noPrec) $ - hang (text "case" <+> e' <+> text "of") 2 $ vcat alts' - -pprPrecAlt :: LFresh m => Rational -> (Pat,Term) -> m Doc -pprPrecAlt _ (altPat, altE) = do - altPat' <- pprPrec noPrec altPat - altE' <- pprPrec noPrec altE - return $ hang (altPat' <+> rarrow) 2 altE' - -pprBndr :: (LFresh m, Pretty a) => BindingSite -> a -> m Doc -pprBndr bs x = prettyParen needsParen <$> ppr x - where - needsParen = case bs of - LambdaBind -> True - CaseBind -> True - LetBind -> False - -data TypePrec - = TopPrec - | FunPrec - | TyConPrec - deriving (Eq,Ord) - -maybeParen :: TypePrec -> TypePrec -> Doc -> Doc -maybeParen ctxt_prec inner_prec = prettyParen (ctxt_prec >= inner_prec) - -pprType :: LFresh m => Type -> m Doc -pprType = ppr_type TopPrec - -pprParendType :: LFresh m => Type -> m Doc -pprParendType = ppr_type TyConPrec - -ppr_type :: LFresh m => TypePrec -> Type -> m Doc -ppr_type _ (VarTy _ tv) = ppr tv -ppr_type _ (LitTy tyLit) = ppr tyLit -ppr_type p ty@(ForAllTy _) = pprForAllType p ty -ppr_type p (ConstTy (TyCon tc)) = pprTcApp p ppr_type tc [] -ppr_type p (tyView -> TyConApp tc args) = pprTcApp p ppr_type tc args -ppr_type p (tyView -> FunTy ty1 ty2) = pprArrowChain p <$> ppr_type FunPrec ty1 <:> pprFunTail ty2 - where - pprFunTail (tyView -> FunTy ty1' ty2') = ppr_type FunPrec ty1' <:> pprFunTail ty2' - pprFunTail otherTy = ppr_type TopPrec otherTy <:> pure [] - -ppr_type p (AppTy ty1 ty2) = maybeParen p TyConPrec <$> ((<+>) <$> pprType ty1 <*> ppr_type TyConPrec ty2) -ppr_type _ (ConstTy Arrow) = return (parens rarrow) - -pprForAllType :: LFresh m => TypePrec -> Type -> m Doc -pprForAllType p ty = maybeParen p FunPrec <$> pprSigmaType True ty - -pprSigmaType :: LFresh m => Bool -> Type -> m Doc -pprSigmaType showForalls ty = do - (tvs, rho) <- split1 [] ty - sep <$> sequenceA [ if showForalls then pprForAll tvs else pure empty - , pprType rho - ] - where - split1 tvs (ForAllTy b) = - lunbind b $ \(tv,resTy) -> split1 (tv:tvs) resTy - split1 tvs resTy = return (reverse tvs,resTy) - -pprForAll :: LFresh m => [TyVar] -> m Doc -pprForAll [] = return empty -pprForAll tvs = do - tvs' <- mapM pprTvBndr tvs - return $ char '∀' <+> sep tvs' <> period - -pprTvBndr :: LFresh m => TyVar -> m Doc -pprTvBndr tv - = do - tv' <- ppr tv - kind' <- pprKind kind - return $ parens (tv' <+> dcolon <+> kind') - where - kind = unembed $ varKind tv - -pprKind :: LFresh m => Kind -> m Doc -pprKind = pprType - -pprTcApp :: LFresh m => TypePrec -> (TypePrec -> Type -> m Doc) - -> TyConName -> [Type] -> m Doc -pprTcApp _ _ tc [] - = return . text $ name2String tc - -pprTcApp p pp tc tys - | isTupleTyConLike tc - = do - tys' <- mapM (pp TopPrec) tys - return $ parens $ sep $ punctuate comma tys' - - | otherwise - = pprTypeNameApp p pp tc tys - -pprTypeNameApp :: LFresh m => TypePrec -> (TypePrec -> Type -> m Doc) - -> Name a -> [Type] -> m Doc -pprTypeNameApp p pp name tys - | isSym - , [ty1,ty2] <- tys - = pprInfixApp p pp name ty1 ty2 - | otherwise - = do - tys' <- mapM (pp TyConPrec) tys - let name' = text $ name2String name - return $ pprPrefixApp p (pprPrefixVar isSym name') tys' - where - isSym = isSymName name - -pprInfixApp :: LFresh m => TypePrec -> (TypePrec -> Type -> m Doc) - -> Name a -> Type -> Type -> m Doc -pprInfixApp p pp name ty1 ty2 = do - ty1' <- pp FunPrec ty1 - ty2' <- pp FunPrec ty2 - let name' = text $ name2String name - return $ maybeParen p FunPrec $ sep [ty1', pprInfixVar True name' <+> ty2'] - -pprPrefixApp :: TypePrec -> Doc -> [Doc] -> Doc -pprPrefixApp p pp_fun pp_tys = maybeParen p TyConPrec $ - hang pp_fun 2 (sep pp_tys) - -pprPrefixVar :: Bool -> Doc -> Doc -pprPrefixVar is_operator pp_v - | is_operator = parens pp_v - | otherwise = pp_v - -pprInfixVar :: Bool -> Doc -> Doc -pprInfixVar is_operator pp_v - | is_operator = pp_v - | otherwise = char '`' <> pp_v <> char '`' - -pprArrowChain :: TypePrec -> [Doc] -> Doc -pprArrowChain _ [] = empty -pprArrowChain p (arg:args) = maybeParen p FunPrec $ - sep [arg, sep (map (rarrow <+>) args)] - -isSymName :: Name a -> Bool -isSymName n = go (name2String n) - where - go s | null s = False - | isUpper $ head s = isLexConSym s - | otherwise = isLexSym s - -isLexSym :: String -> Bool -isLexSym cs = isLexConSym cs || isLexVarSym cs - -isLexConSym :: String -> Bool -isLexConSym "->" = True -isLexConSym cs = startsConSym (head cs) - -isLexVarSym :: String -> Bool -isLexVarSym cs = startsVarSym (head cs) - -startsConSym :: Char -> Bool -startsConSym c = c == ':' - -startsVarSym :: Char -> Bool -startsVarSym c = isSymbolASCII c || (ord c > 0x7f && isSymbol c) - -isSymbolASCII :: Char -> Bool -isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-" diff --git a/src/CLaSH/Core/Subst.hs b/src/CLaSH/Core/Subst.hs deleted file mode 100644 --- a/src/CLaSH/Core/Subst.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Capture-free substitution function for CoreHW --} - -module CLaSH.Core.Subst where - -import Unbound.Generics.LocallyNameless (subst, substs) - -import CLaSH.Core.Term (Term, TmName) -import {-# SOURCE #-} CLaSH.Core.Type (KiName, Kind, TyName, Type) - --- | Substitutes types in a type -substTys :: [(TyName,Type)] - -> Type - -> Type -substTys = substs - --- | Substitutes a type in a type -substTy :: TyName - -> Type - -> Type - -> Type -substTy = subst - --- | Substitutes kinds in a kind -substKindWith :: [(KiName,Kind)] - -> Kind - -> Kind -substKindWith = substs - --- | Substitutes a type in a term -substTyInTm :: TyName - -> Type - -> Term - -> Term -substTyInTm = subst - --- | Substitutes types in a term -substTysinTm :: [(TyName,Type)] - -> Term - -> Term -substTysinTm = substs - --- | Substitutes a term in a term -substTm :: TmName - -> Term - -> Term - -> Term -substTm = subst - --- | Substitutes terms in a term -substTms :: [(TmName,Term)] - -> Term - -> Term -substTms = substs diff --git a/src/CLaSH/Core/Term.hs b/src/CLaSH/Core/Term.hs deleted file mode 100644 --- a/src/CLaSH/Core/Term.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Term representation in the CoreHW language: System F + LetRec + Case --} - -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} - -module CLaSH.Core.Term - ( Term (..) - , TmName - , LetBinding - , Pat (..) - ) -where - --- External Modules -import Control.DeepSeq -import Data.Text (Text) -import GHC.Generics -import Unbound.Generics.LocallyNameless -import Unbound.Generics.LocallyNameless.Extra () - --- Internal Modules -import CLaSH.Core.DataCon (DataCon) -import CLaSH.Core.Literal (Literal) -import {-# SOURCE #-} CLaSH.Core.Type (Type) -import CLaSH.Core.Var (Id, TyVar) - --- | Term representation in the CoreHW language: System F + LetRec + Case -data Term - = Var !Type !TmName -- ^ Variable reference - | Data !DataCon -- ^ Datatype constructor - | Literal !Literal -- ^ Literal - | Prim !Text !Type -- ^ Primitive - | Lam !(Bind Id Term) -- ^ Term-abstraction - | TyLam !(Bind TyVar Term) -- ^ Type-abstraction - | App !Term !Term -- ^ Application - | TyApp !Term !Type -- ^ Type-application - | Letrec !(Bind (Rec [LetBinding]) Term) -- ^ Recursive let-binding - | Case !Term !Type [Bind Pat Term] -- ^ Case-expression: subject, type of - -- alternatives, list of alternatives - deriving (Show,Generic,NFData) - --- | Term reference -type TmName = Name Term --- | Binding in a LetRec construct -type LetBinding = (Id, Embed Term) - --- | Patterns in the LHS of a case-decomposition -data Pat - = DataPat !(Embed DataCon) !(Rebind [TyVar] [Id]) - -- ^ Datatype pattern, '[TyVar]' bind existentially-quantified - -- type-variables of a DataCon - | LitPat !(Embed Literal) - -- ^ Literal pattern - | DefaultPat - -- ^ Default pattern - deriving (Eq,Show,Generic,NFData,Alpha) - -instance Eq Term where - (==) = aeq - -instance Ord Term where - compare = acompare - -instance Alpha Term where - fvAny' c nfn (Var t n) = fmap (Var t) $ fvAny' c nfn n - fvAny' c nfn t = fmap to . gfvAny c nfn $ from t - - aeq' c (Var _ n) (Var _ m) = aeq' c n m - aeq' _ (Prim t1 _) (Prim t2 _) = t1 == t2 - aeq' c t1 t2 = gaeq c (from t1) (from t2) - - acompare' c (Var _ n) (Var _ m) = acompare' c n m - acompare' _ (Prim t1 _) (Prim t2 _) = compare t1 t2 - acompare' c t1 t2 = gacompare c (from t1) (from t2) - -instance Subst Type Pat -instance Subst Term Pat - -instance Subst Term Term where - isvar (Var _ x) = Just (SubstName x) - isvar _ = Nothing - -instance Subst Type Term diff --git a/src/CLaSH/Core/Term.hs-boot b/src/CLaSH/Core/Term.hs-boot deleted file mode 100644 --- a/src/CLaSH/Core/Term.hs-boot +++ /dev/null @@ -1,17 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij --} - -{-# OPTIONS_GHC -fno-warn-missing-methods #-} - -module CLaSH.Core.Term where - -import GHC.Generics (Generic) -import Unbound.Generics.LocallyNameless (Name) - -data Term -type TmName = Name Term - -instance Generic Term diff --git a/src/CLaSH/Core/TyCon.hs b/src/CLaSH/Core/TyCon.hs deleted file mode 100644 --- a/src/CLaSH/Core/TyCon.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Type Constructors in CoreHW --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module CLaSH.Core.TyCon - ( TyCon (..) - , TyConName - , AlgTyConRhs (..) - , mkKindTyCon - , isTupleTyConLike - , tyConDataCons - ) -where - -#ifndef MIN_VERSION_unbound_generics -#define MIN_VERSION_unbound_generics(x,y,z)(1) -#endif - --- External Import -import Control.DeepSeq -import GHC.Generics -import Unbound.Generics.LocallyNameless (Alpha(..)) -import Unbound.Generics.LocallyNameless.Extra () -import Unbound.Generics.LocallyNameless.Name (Name,name2String) -#if MIN_VERSION_unbound_generics(0,3,0) -import Data.Monoid (All (..)) -import Unbound.Generics.LocallyNameless (NthPatFind (..), - NamePatFind (..)) -#endif - --- Internal Imports -import CLaSH.Core.DataCon (DataCon) -import {-# SOURCE #-} CLaSH.Core.Type (Kind, TyName, Type) -import CLaSH.Util - --- | Type Constructor -data TyCon - -- | Algorithmic DataCons - = AlgTyCon - { tyConName :: !TyConName -- ^ Name of the TyCon - , tyConKind :: !Kind -- ^ Kind of the TyCon - , tyConArity :: !Int -- ^ Number of type arguments - , algTcRhs :: !AlgTyConRhs -- ^ DataCon definitions - } - -- | Function TyCons (e.g. type families) - | FunTyCon - { tyConName :: !TyConName -- ^ Name of the TyCon - , tyConKind :: !Kind -- ^ Kind of the TyCon - , tyConArity :: !Int -- ^ Number of type arguments - , tyConSubst :: [([Type],Type)] -- ^ List of: ([LHS match types], RHS type) - } - -- | Primitive TyCons - | PrimTyCon - { tyConName :: !TyConName -- ^ Name of the TyCon - , tyConKind :: !Kind -- ^ Kind of the TyCon - , tyConArity :: !Int -- ^ Number of type arguments - } - -- | To close the loop on the type hierarchy - | SuperKindTyCon - { tyConName :: !TyConName -- ^ Name of the TyCon - } - deriving (Generic,NFData) - -instance Show TyCon where - show (AlgTyCon {tyConName = n}) = "AlgTyCon: " ++ show n - show (FunTyCon {tyConName = n}) = "FunTyCon: " ++ show n - show (PrimTyCon {tyConName = n}) = "PrimTyCon: " ++ show n - show (SuperKindTyCon {tyConName = n}) = "SuperKindTyCon: " ++ show n - -instance Eq TyCon where - (==) = (==) `on` tyConName - -instance Ord TyCon where - compare = compare `on` tyConName - --- | TyCon reference -type TyConName = Name TyCon - --- | The RHS of an Algebraic Datatype -data AlgTyConRhs - = DataTyCon - { dataCons :: [DataCon] -- ^ The DataCons of a TyCon - } - | NewTyCon - { dataCon :: !DataCon -- ^ The newtype DataCon - , ntEtadRhs :: ([TyName],Type) -- ^ The argument type of the newtype - -- DataCon in eta-reduced form, which is - -- just the representation of the TyCon. - -- The TyName's are the type-variables from - -- the corresponding TyCon. - } - deriving (Show,Generic,NFData,Alpha) - -instance Alpha TyCon where - aeq' c tc1 tc2 = aeq' c (tyConName tc1) (tyConName tc2) - - fvAny' _ _ tc = pure tc - - close _ _ tc = tc - open _ _ tc = tc - - isPat _ = mempty - -#if MIN_VERSION_unbound_generics(0,3,0) - isTerm _ = All True - nthPatFind _ = NthPatFind Left - namePatFind _ = NamePatFind (const (Left 0)) -#else - isTerm _ = True - nthPatFind _ = Left - namePatFind _ _ = Left 0 -#endif - - swaps' _ _ tc = tc - lfreshen' _ tc cont = cont tc mempty - freshen' _ tc = return (tc,mempty) - - acompare' c tc1 tc2 = acompare' c (tyConName tc1) (tyConName tc2) - --- | Create a Kind out of a TyConName -mkKindTyCon :: TyConName - -> Kind - -> TyCon -mkKindTyCon name kind - = PrimTyCon name kind 0 - --- | Does the TyCon look like a tuple TyCon -isTupleTyConLike :: TyConName -> Bool -isTupleTyConLike nm = tupleName (name2String nm) - where - tupleName nm' - | '(' <- head nm' - , ')' <- last nm' - = all (== ',') (init $ tail nm') - tupleName _ = False - --- | Get the DataCons belonging to a TyCon -tyConDataCons :: TyCon -> [DataCon] -tyConDataCons (AlgTyCon {algTcRhs = DataTyCon { dataCons = cons}}) = cons -tyConDataCons (AlgTyCon {algTcRhs = NewTyCon { dataCon = con }}) = [con] -tyConDataCons _ = [] diff --git a/src/CLaSH/Core/TyCon.hs-boot b/src/CLaSH/Core/TyCon.hs-boot deleted file mode 100644 --- a/src/CLaSH/Core/TyCon.hs-boot +++ /dev/null @@ -1,12 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij --} - -module CLaSH.Core.TyCon where - -import Unbound.Generics.LocallyNameless (Name) - -data TyCon -type TyConName = Name TyCon diff --git a/src/CLaSH/Core/Type.hs b/src/CLaSH/Core/Type.hs deleted file mode 100644 --- a/src/CLaSH/Core/Type.hs +++ /dev/null @@ -1,469 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Types in CoreHW --} - -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} - -module CLaSH.Core.Type - ( Type (..) - , TypeView (..) - , ConstTy (..) - , LitTy (..) - , Kind - , KindOrType - , KiName - , TyName - , TyVar - , tyView - , coreView - , typeKind - , mkTyConTy - , mkFunTy - , mkTyConApp - , splitFunTy - , splitFunTys - , splitFunForallTy - , splitCoreFunForallTy - , splitTyConAppM - , isPolyFunTy - , isPolyFunCoreTy - , isPolyTy - , isFunTy - , applyFunTy - , applyTy - , findFunSubst - , reduceTypeFamily - , undefinedTy - ) -where - --- External import -import Control.DeepSeq as DS -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.Maybe (isJust, mapMaybe) -import GHC.Base (isTrue#,(==#)) -import GHC.Generics (Generic(..)) -import GHC.Integer (smallInteger) -import GHC.Integer.Logarithms (integerLogBase#) -import Unbound.Generics.LocallyNameless (Alpha(..),Bind,Fresh, - Subst(..),SubstName(..), - acompare,aeq,bind,embed, - gacompare,gaeq,gfvAny, - runFreshM,unbind) -import Unbound.Generics.LocallyNameless.Name (Name (..),name2String, - string2Name) -import Unbound.Generics.LocallyNameless.Extra () - --- Local imports -import CLaSH.Core.DataCon -import CLaSH.Core.Subst -import {-# SOURCE #-} CLaSH.Core.Term -import CLaSH.Core.TyCon -import CLaSH.Core.TysPrim -import CLaSH.Core.Var -import CLaSH.Util - --- | Types in CoreHW: function and polymorphic types -data Type - = VarTy !Kind !TyName -- ^ Type variable - | ConstTy !ConstTy -- ^ Type constant - | ForAllTy !(Bind TyVar Type) -- ^ Polymorphic Type - | AppTy !Type !Type -- ^ Type Application - | LitTy !LitTy -- ^ Type literal - deriving (Show,Generic,NFData) - --- | An easier view on types -data TypeView - = FunTy !Type !Type -- ^ Function type - | TyConApp !TyConName [Type] -- ^ Applied TyCon - | OtherType !Type -- ^ Neither of the above - deriving Show - --- | Type Constants -data ConstTy - = TyCon !TyConName -- ^ TyCon type - | Arrow -- ^ Function type - deriving (Show,Generic,NFData,Alpha) - --- | Literal Types -data LitTy - = NumTy !Integer - | SymTy !String - deriving (Show,Generic,NFData,Alpha) - --- | The level above types -type Kind = Type --- | Either a Kind or a Type -type KindOrType = Type - --- | Reference to a Type -type TyName = Name Type --- | Reference to a Kind -type KiName = Name Kind - -instance Alpha Type where - fvAny' c nfn (VarTy t n) = fmap (VarTy t) $ fvAny' c nfn n - fvAny' c nfn t = fmap to . gfvAny c nfn $ from t - - aeq' c (VarTy _ n) (VarTy _ m) = aeq' c n m - aeq' c t1 t2 = gaeq c (from t1) (from t2) - - acompare' c (VarTy _ n) (VarTy _ m) = acompare' c n m - acompare' c t1 t2 = gacompare c (from t1) (from t2) - -instance Subst a LitTy where - subst _ _ lt = lt - substs _ lt = lt - -instance Subst a ConstTy where - subst _ _ ct = ct - substs _ ct = ct - -instance Subst Term Type -instance Subst Type Type where - isvar (VarTy _ v) = Just (SubstName v) - isvar _ = Nothing - -instance Eq Type where - (==) = aeq - -instance Ord Type where - compare = acompare - --- | An easier view on types -tyView :: Type -> TypeView -tyView ty@(AppTy _ _) = case splitTyAppM ty of - Just (ConstTy Arrow, [ty1,ty2]) -> FunTy ty1 ty2 - Just (ConstTy (TyCon tc), args) -> TyConApp tc args - _ -> OtherType ty -tyView (ConstTy (TyCon tc)) = TyConApp tc [] -tyView t = OtherType t - --- | A view on types in which newtypes are transparent, the Signal type is --- transparent, and type functions are evaluated to WHNF (when possible). --- --- Only strips away one "layer". -coreView :: HashMap TyConName TyCon -> Type -> Maybe Type -coreView tcMap ty = case tyView ty of - TyConApp tcNm args - | name2String tcNm == "CLaSH.Signal.Internal.Signal'" - , [_,elTy] <- args - -> Just elTy - | otherwise - -> case tcMap HashMap.! tcNm of - AlgTyCon {algTcRhs = (NewTyCon _ nt)} - -> Just (newTyConInstRhs nt args) - _ -> reduceTypeFamily tcMap ty - _ -> Nothing - --- | Instantiate and Apply the RHS/Original of a NewType with the given --- list of argument types -newTyConInstRhs :: ([TyName],Type) -> [Type] -> Type -newTyConInstRhs (tvs,ty) tys = foldl AppTy (substTys (zip tvs tys1) ty) tys2 - where - (tys1, tys2) = splitAtList tvs tys - --- | Make a function type of an argument and result type -mkFunTy :: Type -> Type -> Type -mkFunTy t1 = AppTy (AppTy (ConstTy Arrow) t1) - --- | Make a TyCon Application out of a TyCon and a list of argument types -mkTyConApp :: TyConName -> [Type] -> Type -mkTyConApp tc = foldl AppTy (ConstTy $ TyCon tc) - --- | Make a Type out of a TyCon -mkTyConTy :: TyConName -> Type -mkTyConTy ty = ConstTy $ TyCon ty - --- | Split a TyCon Application in a TyCon and its arguments -splitTyConAppM :: Type - -> Maybe (TyConName,[Type]) -splitTyConAppM (tyView -> TyConApp tc args) = Just (tc,args) -splitTyConAppM _ = Nothing - --- | Is a type a Superkind? -isSuperKind :: HashMap TyConName TyCon -> Type -> Bool -isSuperKind tcMap (ConstTy (TyCon ((tcMap HashMap.!) -> SuperKindTyCon {}))) = True -isSuperKind _ _ = False - --- | Determine the kind of a type -typeKind :: HashMap TyConName TyCon -> Type -> Kind -typeKind _ (VarTy k _) = k -typeKind m (ForAllTy b) = let (_,ty) = runFreshM $ unbind b - in typeKind m ty -typeKind _ (LitTy (NumTy _)) = typeNatKind -typeKind _ (LitTy (SymTy _)) = typeSymbolKind -typeKind m (tyView -> FunTy _arg res) - | isSuperKind m k = k - | otherwise = liftedTypeKind - where k = typeKind m res - -typeKind m (tyView -> TyConApp tc args) = foldl kindFunResult (tyConKind (m HashMap.! tc)) args - -typeKind m (AppTy fun arg) = kindFunResult (typeKind m fun) arg -typeKind _ (ConstTy ct) = error $ $(curLoc) ++ "typeKind: naked ConstTy: " ++ show ct - -kindFunResult :: Kind -> KindOrType -> Kind -kindFunResult (tyView -> FunTy _ res) _ = res - -kindFunResult (ForAllTy b) arg = - let (kv,ki) = runFreshM . unbind $ b - in substKindWith (zip [varName kv] [arg]) ki - -kindFunResult k tys = - error $ $(curLoc) ++ "kindFunResult: " ++ show (k,tys) - --- | Is a type polymorphic? -isPolyTy :: Type -> Bool -isPolyTy (ForAllTy _) = True -isPolyTy (tyView -> FunTy _ res) = isPolyTy res -isPolyTy _ = False - --- | Split a function type in an argument and result type -splitFunTy :: HashMap TyConName TyCon - -> Type - -> Maybe (Type, Type) -splitFunTy m (coreView m -> Just ty) = splitFunTy m ty -splitFunTy _ (tyView -> FunTy arg res) = Just (arg,res) -splitFunTy _ _ = Nothing - -splitFunTys :: HashMap TyConName TyCon - -> Type - -> ([Type],Type) -splitFunTys m ty = go [] ty ty - where - go args orig_ty (coreView m -> Just ty') = go args orig_ty ty' - go args _ (tyView -> FunTy arg res) = go (arg:args) res res - go args orig_ty _ = (reverse args, orig_ty) - --- | Split a poly-function type in a: list of type-binders and argument types, --- and the result type -splitFunForallTy :: Type - -> ([Either TyVar Type],Type) -splitFunForallTy = go [] - where - go args (ForAllTy b) = let (tv,ty) = runFreshM $ unbind b - in go (Left tv:args) ty - go args (tyView -> FunTy arg res) = go (Right arg:args) res - go args ty = (reverse args,ty) - --- | Split a poly-function type in a: list of type-binders and argument types, --- and the result type. Looks through 'Signal' and type functions. -splitCoreFunForallTy :: HashMap TyConName TyCon - -> Type - -> ([Either TyVar Type], Type) -splitCoreFunForallTy tcm ty = go [] ty ty - where - go args orig_ty (coreView tcm -> Just ty') = go args orig_ty ty' - go args _ (ForAllTy b) = let (tv,res) = runFreshM $ unbind b - in go (Left tv:args) res res - go args _ (tyView -> FunTy arg res) = go (Right arg:args) res res - go args orig_ty _ = (reverse args,orig_ty) - --- | Is a type a polymorphic or function type? -isPolyFunTy :: Type - -> Bool -isPolyFunTy = not . null . fst . splitFunForallTy - --- | Is a type a polymorphic or function type under 'coreView'? -isPolyFunCoreTy :: HashMap TyConName TyCon - -> Type - -> Bool -isPolyFunCoreTy m (coreView m -> Just ty) = isPolyFunCoreTy m ty -isPolyFunCoreTy _ ty = case tyView ty of - FunTy _ _ -> True - OtherType (ForAllTy _) -> True - _ -> False - --- | Is a type a function type? -isFunTy :: HashMap TyConName TyCon - -> Type - -> Bool -isFunTy m = isJust . splitFunTy m - --- | Apply a function type to an argument type and get the result type -applyFunTy :: HashMap TyConName TyCon - -> Type - -> Type - -> Type -applyFunTy m (coreView m -> Just ty) arg = applyFunTy m ty arg -applyFunTy _ (tyView -> FunTy _ resTy) _ = resTy -applyFunTy _ _ _ = error $ $(curLoc) ++ "Report as bug: not a FunTy" - --- | Substitute the type variable of a type ('ForAllTy') with another type -applyTy :: Fresh m - => HashMap TyConName TyCon - -> Type - -> KindOrType - -> m Type -applyTy tcm (coreView tcm -> Just ty) arg = applyTy tcm ty arg -applyTy _ (ForAllTy b) arg = do - (tv,ty) <- unbind b - return (substTy (varName tv) arg ty) -applyTy _ ty arg = error ($(curLoc) ++ "applyTy: not a forall type:\n" ++ show ty ++ "\nArg:\n" ++ show arg) - --- | Split a type application in the applied type and the argument types -splitTyAppM :: Type - -> Maybe (Type, [Type]) -splitTyAppM = fmap (second reverse) . go [] - where - go args (AppTy ty1 ty2) = - case go args ty1 of - Nothing -> Just (ty1,ty2:args) - Just (ty1',ty1args) -> Just (ty1',ty2:ty1args ) - go _ _ = Nothing - --- Type function substitutions - --- Given a set of type functions, and list of argument types, get the first --- type function that matches, and return its substituted RHS type. -findFunSubst :: HashMap TyConName TyCon -> [([Type],Type)] -> [Type] -> Maybe Type -findFunSubst _ [] _ = Nothing -findFunSubst tcm (tcSubst:rest) args = case funSubsts tcm tcSubst args of - Just ty -> Just ty - Nothing -> findFunSubst tcm rest args - --- Given a ([LHS match type], RHS type) representing a type function, and --- a set of applied types. Match LHS with args, and when successful, return --- a substituted RHS -funSubsts :: HashMap TyConName TyCon -> ([Type],Type) -> [Type] -> Maybe Type -funSubsts tcm (tcSubstLhs,tcSubstRhs) args = do - tySubts <- foldl (funSubst tcm) (Just []) (zip tcSubstLhs args) - let tyRhs = substTys tySubts tcSubstRhs - return tyRhs - --- Given a LHS matching type, and a RHS to-match type, check if LHS and RHS --- are a match. If they do match, and the LHS is a variable, return a --- substitution -funSubst :: HashMap TyConName TyCon -> Maybe [(TyName,Type)] -> (Type,Type) -> Maybe [(TyName,Type)] -funSubst _ Nothing = const Nothing -funSubst tcm (Just s) = uncurry go - where - go (VarTy _ nmF) ty = case lookup nmF s of - Nothing -> Just ((nmF,ty):s) - -- Given, for example, the type family definition: - -- - -- > type family Max x y where - -- > Max 0 b = b - -- > Max a 0 = a - -- > Max n n = n - -- > Max a b = If (a <=? b) b a - -- - -- Then `Max 4 8` matches against the 4th clause. - -- - -- So this is why, whenever we match against a type variable, we first - -- check if there is already a substitution defined for this type variable, - -- and if so, the applied type, and the type in the substitution should match. - Just ty' | ty' == ty -> Just s - _ -> Nothing - go ty1 (reduceTypeFamily tcm -> Just ty2) = go ty1 ty2 -- See [Note: lazy type families] - go ty1@(LitTy _) ty2 = if ty1 == ty2 then Just s else Nothing - go (tyView -> TyConApp tc argTys) (tyView -> TyConApp tc' argTys') - | tc == tc' - = foldl (funSubst tcm) (Just s) (zip argTys argTys') - go _ _ = Nothing - -{- [Note: lazy type families] - -I don't know whether type families are evaluated strictly or lazily, but this -being Haskell, I assume type families are evaluated lazily. - -CLaSH hence follows the Haskell way, and only evaluates type family arguments -to (WH)NF when the formal parameter is _not_ a type variable. --} - -reduceTypeFamily :: HashMap TyConName TyCon -> Type -> Maybe Type -reduceTypeFamily tcm (tyView -> TyConApp tc tys) - | name2String tc == "GHC.TypeLits.+" - , [i1, i2] <- mapMaybe (litView tcm) tys - = Just (LitTy (NumTy (i1 + i2))) - - | name2String tc == "GHC.TypeLits.*" - , [i1, i2] <- mapMaybe (litView tcm) tys - = Just (LitTy (NumTy (i1 * i2))) - - | name2String tc == "GHC.TypeLits.^" - , [i1, i2] <- mapMaybe (litView tcm) tys - = Just (LitTy (NumTy (i1 ^ i2))) - - | name2String tc == "GHC.TypeLits.-" - , [i1, i2] <- mapMaybe (litView tcm) tys - = Just (LitTy (NumTy (i1 - i2))) - - | name2String tc == "GHC.TypeLits.<=?" - , [i1, i2] <- mapMaybe (litView tcm) tys - , Just (FunTyCon {tyConKind = tck}) <- HashMap.lookup tc tcm - , (_,tyView -> TyConApp boolTcNm []) <- splitFunTys tcm tck - , Just boolTc <- HashMap.lookup boolTcNm tcm - = let [falseTc,trueTc] = map ((\(Fn s i) -> Fn s i) . dcName) (tyConDataCons boolTc) - in if i1 <= i2 then Just (mkTyConApp trueTc [] ) - else Just (mkTyConApp falseTc []) - - | name2String tc == "GHC.TypeLits.Extra.FLog" - , [i1, i2] <- mapMaybe (litView tcm) tys - , i1 > 1 - , i2 > 0 - = Just (LitTy (NumTy (smallInteger (integerLogBase# i1 i2)))) - - | name2String tc == "GHC.TypeLits.Extra.CLog" - , [i1, i2] <- mapMaybe (litView tcm) tys - , Just k <- clogBase i1 i2 - = Just (LitTy (NumTy (toInteger k))) - - | name2String tc == "GHC.TypeLits.Extra.Log" - , [i1, i2] <- mapMaybe (litView tcm) tys - , i1 > 1 - , i2 > 0 - = if i2 == 1 - then Just (LitTy (NumTy 0)) - else let z1 = integerLogBase# i1 i2 - z2 = integerLogBase# i1 (i2-1) - in if isTrue# (z1 ==# z2) - then Nothing - else Just (LitTy (NumTy (smallInteger z1))) - - - | name2String tc == "GHC.TypeLits.Extra.GCD" - , [i1, i2] <- mapMaybe (litView tcm) tys - = Just (LitTy (NumTy (i1 `gcd` i2))) - - | name2String tc == "GHC.TypeLits.Extra.LCM" - , [i1, i2] <- mapMaybe (litView tcm) tys - = Just (LitTy (NumTy (i1 `lcm` i2))) - - | name2String tc == "GHC.TypeLits.Extra.Div" - , [i1, i2] <- mapMaybe (litView tcm) tys - , i2 > 0 - = Just (LitTy (NumTy (i1 `div` i2))) - - | name2String tc == "GHC.TypeLits.Extra.Mod" - , [i1, i2] <- mapMaybe (litView tcm) tys - , i2 > 0 - = Just (LitTy (NumTy (i1 `mod` i2))) - - | Just (FunTyCon {tyConSubst = tcSubst}) <- HashMap.lookup tc tcm - = findFunSubst tcm tcSubst tys - -reduceTypeFamily _ _ = Nothing - -litView :: HashMap TyConName TyCon -> Type -> Maybe Integer -litView _ (LitTy (NumTy i)) = Just i -litView m (reduceTypeFamily m -> Just ty') = litView m ty' -litView _ _ = Nothing - --- | The type of GHC.Err.undefined :: forall a . a -undefinedTy :: Type -undefinedTy = - let aNm = string2Name "a" - in ForAllTy (bind (TyVar aNm (embed liftedTypeKind)) (VarTy liftedTypeKind aNm)) diff --git a/src/CLaSH/Core/Type.hs-boot b/src/CLaSH/Core/Type.hs-boot deleted file mode 100644 --- a/src/CLaSH/Core/Type.hs-boot +++ /dev/null @@ -1,34 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij --} - -{-# LANGUAGE MultiParamTypeClasses #-} - -{-# OPTIONS_GHC -fno-warn-missing-methods #-} - -module CLaSH.Core.Type where - -import Control.DeepSeq (NFData) -import GHC.Generics (Generic) -import Unbound.Generics.LocallyNameless (Alpha,Name,Subst) - -import {-# SOURCE #-} CLaSH.Core.Term -import {-# SOURCE #-} CLaSH.Core.TyCon - -data Type - -type Kind = Type -type TyName = Name Type -type KiName = Name Kind - -instance Eq Type -instance Generic Type -instance Show Type -instance Alpha Type -instance Subst Type Type -instance Subst Term Type -instance NFData Type - -mkTyConTy :: TyConName -> Type diff --git a/src/CLaSH/Core/TysPrim.hs b/src/CLaSH/Core/TysPrim.hs deleted file mode 100644 --- a/src/CLaSH/Core/TysPrim.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Builtin Type and Kind definitions --} - -module CLaSH.Core.TysPrim - ( liftedTypeKind - , typeNatKind - , typeSymbolKind - , intPrimTy - , integerPrimTy - , charPrimTy - , stringPrimTy - , voidPrimTy - , wordPrimTy - , int64PrimTy - , word64PrimTy - , floatPrimTy - , doublePrimTy - , tysPrimMap - ) -where - -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Unbound.Generics.LocallyNameless (string2Name) - -import CLaSH.Core.TyCon -import {-# SOURCE #-} CLaSH.Core.Type - --- | Builtin Name -tySuperKindTyConName, liftedTypeKindTyConName, typeNatKindTyConName, typeSymbolKindTyConName :: TyConName -tySuperKindTyConName = string2Name "BOX" -liftedTypeKindTyConName = string2Name "*" -typeNatKindTyConName = string2Name "Nat" -typeSymbolKindTyConName = string2Name "Symbol" - --- | Builtin Kind -liftedTypeKindtc, tySuperKindtc, typeNatKindtc, typeSymbolKindtc :: TyCon -tySuperKindtc = SuperKindTyCon tySuperKindTyConName -liftedTypeKindtc = mkKindTyCon liftedTypeKindTyConName tySuperKind -typeNatKindtc = mkKindTyCon typeNatKindTyConName tySuperKind -typeSymbolKindtc = mkKindTyCon typeSymbolKindTyConName tySuperKind - -liftedTypeKind, tySuperKind, typeNatKind, typeSymbolKind :: Type -tySuperKind = mkTyConTy tySuperKindTyConName -liftedTypeKind = mkTyConTy liftedTypeKindTyConName -typeNatKind = mkTyConTy typeNatKindTyConName -typeSymbolKind = mkTyConTy typeSymbolKindTyConName - - -intPrimTyConName, integerPrimTyConName, charPrimTyConName, stringPrimTyConName, - voidPrimTyConName, wordPrimTyConName, int64PrimTyConName, - word64PrimTyConName, floatPrimTyConName, doublePrimTyConName :: TyConName -intPrimTyConName = string2Name "GHC.Prim.Int#" -integerPrimTyConName = string2Name "GHC.Integer.Type.Integer" -stringPrimTyConName = string2Name "String" -charPrimTyConName = string2Name "GHC.Prim.Char#" -voidPrimTyConName = string2Name "VOID" -wordPrimTyConName = string2Name "GHC.Prim.Word#" -int64PrimTyConName = string2Name "GHC.Prim.Int64#" -word64PrimTyConName = string2Name "GHC.Prim.Word64#" -floatPrimTyConName = string2Name "GHC.Prim.Float#" -doublePrimTyConName = string2Name "GHC.Prim.Double#" - -liftedPrimTC :: TyConName - -> TyCon -liftedPrimTC name = PrimTyCon name liftedTypeKind 0 - --- | Builtin Type -intPrimTc, integerPrimTc, charPrimTc, stringPrimTc, voidPrimTc, wordPrimTc, - int64PrimTc, word64PrimTc, floatPrimTc, doublePrimTc :: TyCon -intPrimTc = liftedPrimTC intPrimTyConName -integerPrimTc = liftedPrimTC integerPrimTyConName -charPrimTc = liftedPrimTC charPrimTyConName -stringPrimTc = liftedPrimTC stringPrimTyConName -voidPrimTc = liftedPrimTC voidPrimTyConName -wordPrimTc = liftedPrimTC wordPrimTyConName -int64PrimTc = liftedPrimTC int64PrimTyConName -word64PrimTc = liftedPrimTC word64PrimTyConName -floatPrimTc = liftedPrimTC floatPrimTyConName -doublePrimTc = liftedPrimTC doublePrimTyConName - -intPrimTy, integerPrimTy, charPrimTy, stringPrimTy, voidPrimTy, wordPrimTy, - int64PrimTy, word64PrimTy, floatPrimTy, doublePrimTy :: Type -intPrimTy = mkTyConTy intPrimTyConName -integerPrimTy = mkTyConTy integerPrimTyConName -charPrimTy = mkTyConTy charPrimTyConName -stringPrimTy = mkTyConTy stringPrimTyConName -voidPrimTy = mkTyConTy voidPrimTyConName -wordPrimTy = mkTyConTy wordPrimTyConName -int64PrimTy = mkTyConTy int64PrimTyConName -word64PrimTy = mkTyConTy word64PrimTyConName -floatPrimTy = mkTyConTy floatPrimTyConName -doublePrimTy = mkTyConTy doublePrimTyConName - -tysPrimMap :: HashMap TyConName TyCon -tysPrimMap = HashMap.fromList - [ (tySuperKindTyConName,tySuperKindtc) - , (liftedTypeKindTyConName,liftedTypeKindtc) - , (typeNatKindTyConName,typeNatKindtc) - , (typeSymbolKindTyConName,typeSymbolKindtc) - , (intPrimTyConName,intPrimTc) - , (integerPrimTyConName,integerPrimTc) - , (charPrimTyConName,charPrimTc) - , (stringPrimTyConName,stringPrimTc) - , (voidPrimTyConName,voidPrimTc) - , (wordPrimTyConName,wordPrimTc) - , (int64PrimTyConName,int64PrimTc) - , (word64PrimTyConName,word64PrimTc) - , (floatPrimTyConName,floatPrimTc) - , (doublePrimTyConName,doublePrimTc) - ] diff --git a/src/CLaSH/Core/Util.hs b/src/CLaSH/Core/Util.hs deleted file mode 100644 --- a/src/CLaSH/Core/Util.hs +++ /dev/null @@ -1,447 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Smart constructor and destructor functions for CoreHW --} - -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} - -module CLaSH.Core.Util where - -import Control.Monad.Trans.Except (Except, throwE) -import qualified Data.HashMap.Strict as HMS -import qualified Data.HashMap.Lazy as HashMap -import Data.HashMap.Lazy (HashMap) -import qualified Data.HashSet as HashSet -import Data.Maybe (fromJust, mapMaybe) -import Unbound.Generics.LocallyNameless (Fresh, bind, embed, rebind, - string2Name, unbind, unembed, - unrebind, unrec) -import Unbound.Generics.LocallyNameless.Name (name2String) -import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) - -import CLaSH.Core.DataCon (DataCon, dcType, dataConInstArgTys) -import CLaSH.Core.Literal (literalType) -import CLaSH.Core.Pretty (showDoc) -import CLaSH.Core.Term (LetBinding, Pat (..), Term (..), - TmName) -import CLaSH.Core.Type (Kind, LitTy (..), TyName, - Type (..), TypeView (..), applyTy, - coreView, isFunTy, isPolyFunCoreTy, - mkFunTy, splitFunTy, tyView) -import CLaSH.Core.TyCon (TyCon (..), TyConName, - tyConDataCons) -import CLaSH.Core.TysPrim (typeNatKind) -import CLaSH.Core.Var (Id, TyVar, Var (..), varType) -import CLaSH.Util - --- | Type environment/context -type Gamma = HashMap TmName Type --- | Kind environment/context -type Delta = HashMap TyName Kind - --- | Determine the type of a term -termType :: Fresh m - => HashMap TyConName TyCon - -> Term - -> m Type -termType m e = case e of - Var t _ -> return t - Data dc -> return $ dcType dc - Literal l -> return $ literalType l - Prim _ t -> return t - Lam b -> do (v,e') <- unbind b - mkFunTy (unembed $ varType v) <$> termType m e' - TyLam b -> do (tv,e') <- unbind b - ForAllTy <$> bind tv <$> termType m e' - App _ _ -> case collectArgs e of - (fun, args) -> termType m fun >>= - (flip (applyTypeToArgs m) args) - TyApp e' ty -> termType m e' >>= (\f -> applyTy m f ty) - Letrec b -> do (_,e') <- unbind b - termType m e' - Case _ ty _ -> return ty - --- | Split a (Type)Application in the applied term and it arguments -collectArgs :: Term - -> (Term, [Either Term Type]) -collectArgs = go [] - where - go args (App e1 e2) = go (Left e2:args) e1 - go args (TyApp e t) = go (Right t:args) e - go args e = (e, args) - --- | Split a (Type)Abstraction in the bound variables and the abstracted term -collectBndrs :: Fresh m - => Term - -> m ([Either Id TyVar], Term) -collectBndrs = go [] - where - go bs (Lam b) = do - (v,e') <- unbind b - go (Left v:bs) e' - go bs (TyLam b) = do - (tv,e') <- unbind b - go (Right tv:bs) e' - go bs e' = return (reverse bs,e') - --- | Get the result type of a polymorphic function given a list of arguments -applyTypeToArgs :: Fresh m - => HashMap TyConName TyCon - -> Type - -> [Either Term Type] - -> m Type -applyTypeToArgs _ opTy [] = return opTy -applyTypeToArgs m opTy (Right ty:args) = applyTy m opTy ty >>= - (flip (applyTypeToArgs m) args) -applyTypeToArgs m opTy (Left e:args) = case splitFunTy m opTy of - Just (_,resTy) -> applyTypeToArgs m resTy args - Nothing -> error $ - concat [ $(curLoc) - , "applyTypeToArgs splitFunTy: not a funTy:\n" - , "opTy: " - , showDoc opTy - , "\nTerm: " - , showDoc e - , "\nOtherArgs: " - , unlines (map (either showDoc showDoc) args) - ] - --- | Get the list of term-binders out of a DataType pattern -patIds :: Pat -> [Id] -patIds (DataPat _ ids) = snd $ unrebind ids -patIds _ = [] - --- | Make a type variable -mkTyVar :: Kind - -> TyName - -> TyVar -mkTyVar tyKind tyName = TyVar tyName (embed tyKind) - --- | Make a term variable -mkId :: Type - -> TmName - -> Id -mkId tmType tmName = Id tmName (embed tmType) - --- | Abstract a term over a list of term and type variables -mkAbstraction :: Term - -> [Either Id TyVar] - -> Term -mkAbstraction = foldr (either (Lam `dot` bind) (TyLam `dot` bind)) - --- | Abstract a term over a list of term variables -mkTyLams :: Term - -> [TyVar] - -> Term -mkTyLams tm = mkAbstraction tm . map Right - --- | Abstract a term over a list of type variables -mkLams :: Term - -> [Id] - -> Term -mkLams tm = mkAbstraction tm . map Left - --- | Apply a list of types and terms to a term -mkApps :: Term - -> [Either Term Type] - -> Term -mkApps = foldl (\e a -> either (App e) (TyApp e) a) - --- | Apply a list of terms to a term -mkTmApps :: Term - -> [Term] - -> Term -mkTmApps = foldl App - --- | Apply a list of types to a term -mkTyApps :: Term - -> [Type] - -> Term -mkTyApps = foldl TyApp - --- | Does a term have a function type? -isFun :: Fresh m - => HashMap TyConName TyCon - -> Term - -> m Bool -isFun m t = fmap (isFunTy m) $ (termType m) t - --- | Does a term have a function or polymorphic type? -isPolyFun :: Fresh m - => HashMap TyConName TyCon - -> Term - -> m Bool -isPolyFun m t = isPolyFunCoreTy m <$> termType m t - --- | Is a term a term-abstraction? -isLam :: Term - -> Bool -isLam (Lam _) = True -isLam _ = False - --- | Is a term a recursive let-binding? -isLet :: Term - -> Bool -isLet (Letrec _) = True -isLet _ = False - --- | Is a term a variable reference? -isVar :: Term - -> Bool -isVar (Var _ _) = True -isVar _ = False - --- | Is a term a datatype constructor? -isCon :: Term - -> Bool -isCon (Data _) = True -isCon _ = False - --- | Is a term a primitive? -isPrim :: Term - -> Bool -isPrim (Prim _ _) = True -isPrim _ = False - --- | Make variable reference out of term variable -idToVar :: Id - -> Term -idToVar (Id nm tyE) = Var (unembed tyE) nm -idToVar tv = error $ $(curLoc) ++ "idToVar: tyVar: " ++ showDoc tv - --- | Make a term variable out of a variable reference -varToId :: Term - -> Id -varToId (Var ty nm) = Id nm (embed ty) -varToId e = error $ $(curLoc) ++ "varToId: not a var: " ++ showDoc e - -termSize :: Term - -> Int -termSize (Var _ _) = 1 -termSize (Data _) = 1 -termSize (Literal _) = 1 -termSize (Prim _ _) = 1 -termSize (Lam b) = let (_,e) = unsafeUnbind b - in termSize e + 1 -termSize (TyLam b) = let (_,e) = unsafeUnbind b - in termSize e -termSize (App e1 e2) = termSize e1 + termSize e2 -termSize (TyApp e _) = termSize e -termSize (Letrec b) = let (bndrsR,body) = unsafeUnbind b - bndrSzs = map (termSize . unembed . snd) (unrec bndrsR) - bodySz = termSize body - in sum (bodySz:bndrSzs) -termSize (Case subj _ alts) = let subjSz = termSize subj - altSzs = map (termSize . snd . unsafeUnbind) alts - in sum (subjSz:altSzs) - --- | Create a vector of supplied elements -mkVec :: DataCon -- ^ The Nil constructor - -> DataCon -- ^ The Cons (:>) constructor - -> Type -- ^ Element type - -> Integer -- ^ Length of the vector - -> [Term] -- ^ Elements to put in the vector - -> Term -mkVec nilCon consCon resTy = go - where - go _ [] = mkApps (Data nilCon) [Right (LitTy (NumTy 0)) - ,Right resTy - ,Left (Prim "_CO_" nilCoTy) - ] - - go n (x:xs) = mkApps (Data consCon) [Right (LitTy (NumTy n)) - ,Right resTy - ,Right (LitTy (NumTy (n-1))) - ,Left (Prim "_CO_" (consCoTy n)) - ,Left x - ,Left (go (n-1) xs)] - - nilCoTy = head (fromJust $! dataConInstArgTys nilCon [(LitTy (NumTy 0)) - ,resTy]) - consCoTy n = head (fromJust $! dataConInstArgTys consCon - [(LitTy (NumTy n)) - ,resTy - ,(LitTy (NumTy (n-1)))]) - --- | Append elements to the supplied vector -appendToVec :: DataCon -- ^ The Cons (:>) constructor - -> Type -- ^ Element type - -> Term -- ^ The vector to append the elements to - -> Integer -- ^ Length of the vector - -> [Term] -- ^ Elements to append - -> Term -appendToVec consCon resTy vec = go - where - go _ [] = vec - go n (x:xs) = mkApps (Data consCon) [Right (LitTy (NumTy n)) - ,Right resTy - ,Right (LitTy (NumTy (n-1))) - ,Left (Prim "_CO_" (consCoTy n)) - ,Left x - ,Left (go (n-1) xs)] - - consCoTy n = head (fromJust $! dataConInstArgTys consCon - [(LitTy (NumTy n)) - ,resTy - ,(LitTy (NumTy (n-1)))]) - --- | Create let-bindings with case-statements that select elements out of a --- vector. Returns both the variables to which element-selections are bound --- and the let-bindings -extractElems :: DataCon -- ^ The Cons (:>) constructor - -> Type -- ^ The element type - -> Char -- ^ Char to append to the bound variable names - -> Integer -- ^ Length of the vector - -> Term -- ^ The vector - -> [(Term,[LetBinding])] -extractElems consCon resTy s maxN = go maxN - where - go :: Integer -> Term -> [(Term,[LetBinding])] - go 0 _ = [] - go n e = (elVar - ,[(Id elBNm (embed resTy) ,embed lhs) - ,(Id restBNm (embed restTy),embed rhs) - ] - ) : - go (n-1) (Var restTy restBNm) - - where - elBNm = string2Name ("el" ++ s:show (maxN-n)) - restBNm = string2Name ("rest" ++ s:show (maxN-n)) - elVar = Var resTy elBNm - pat = DataPat (embed consCon) (rebind [mTV] [co,el,rest]) - elPatNm = string2Name "el" - restPatNm = string2Name "rest" - lhs = Case e resTy [bind pat (Var resTy elPatNm)] - rhs = Case e restTy [bind pat (Var restTy restPatNm)] - - mName = string2Name "m" - mTV = TyVar mName (embed typeNatKind) - tys = [(LitTy (NumTy n)),resTy,(LitTy (NumTy (n-1)))] - (Just idTys) = dataConInstArgTys consCon tys - [co,el,rest] = zipWith Id [string2Name "_co_",elPatNm, restPatNm] - (map embed idTys) - restTy = last (fromJust (dataConInstArgTys consCon tys)) - - --- | Create let-bindings with case-statements that select elements out of a --- tree. Returns both the variables to which element-selections are bound --- and the let-bindings -extractTElems :: DataCon -- ^ The 'LR' constructor - -> DataCon -- ^ The 'BR' constructor - -> Type -- ^ The element type - -> Char -- ^ Char to append to the bound variable names - -> Integer -- ^ Depth of the tree - -> Term -- ^ The tree - -> ([Term],[LetBinding]) -extractTElems lrCon brCon resTy s maxN = go maxN [0..(2^(maxN+1))-2] [0..(2^maxN - 1)] - where - go :: Integer -> [Int] -> [Int] -> Term -> ([Term],[LetBinding]) - go 0 _ ks e = ([elVar],[(Id elBNm (embed resTy), embed lhs)]) - where - elBNm = string2Name ("el" ++ s:show (head ks)) - elVar = Var resTy elBNm - pat = DataPat (embed lrCon) (rebind [] [co,el]) - elPatNm = string2Name "el" - lhs = Case e resTy [bind pat (Var resTy elPatNm)] - - tys = [LitTy (NumTy 0),resTy] - (Just idTys) = dataConInstArgTys lrCon tys - [co,el] = zipWith Id [string2Name "_co_",elPatNm] - (map embed idTys) - - go n bs ks e = (lVars ++ rVars,(Id ltBNm (embed brTy),embed ltLhs): - (Id rtBNm (embed brTy),embed rtLhs): - (lBinds ++ rBinds)) - where - ltBNm = string2Name ("lt" ++ s:show b0) - rtBNm = string2Name ("rt" ++ s:show b1) - ltVar = Var brTy ltBNm - rtVar = Var brTy rtBNm - pat = DataPat (embed brCon) (rebind [mTV] [co,lt,rt]) - ltPatNm = string2Name "lt" - rtPatNm = string2Name "rt" - ltLhs = Case e brTy [bind pat (Var brTy ltPatNm)] - rtLhs = Case e brTy [bind pat (Var brTy rtPatNm)] - - mName = string2Name "m" - mTV = TyVar mName (embed typeNatKind) - tys = [LitTy (NumTy n),resTy,LitTy (NumTy (n-1))] - (Just idTys) = dataConInstArgTys brCon tys - [co,lt,rt] = zipWith Id [string2Name "_co_",ltPatNm,rtPatNm] - (map embed idTys) - brTy = last idTys - (kL,kR) = splitAt (length ks `div` 2) ks - (b0:bL,b1:bR) = splitAt (length bs `div` 2) bs - - (lVars,lBinds) = go (n-1) bL kL ltVar - (rVars,rBinds) = go (n-1) bR kR rtVar - --- | Create a vector of supplied elements -mkRTree :: DataCon -- ^ The LR constructor - -> DataCon -- ^ The BR constructor - -> Type -- ^ Element type - -> Integer -- ^ Depth of the tree - -> [Term] -- ^ Elements to put in the tree - -> Term -mkRTree lrCon brCon resTy = go - where - go _ [x] = mkApps (Data lrCon) [Right (LitTy (NumTy 0)) - ,Right resTy - ,Left (Prim "_CO_" lrCoTy) - ,Left x - ] - - go n xs = - let (xsL,xsR) = splitAt (length xs `div` 2) xs - in mkApps (Data brCon) [Right (LitTy (NumTy n)) - ,Right resTy - ,Right (LitTy (NumTy (n-1))) - ,Left (Prim "_CO_" (brCoTy n)) - ,Left (go (n-1) xsL) - ,Left (go (n-1) xsR)] - - lrCoTy = head (fromJust $! dataConInstArgTys lrCon [(LitTy (NumTy 0)) - ,resTy]) - brCoTy n = head (fromJust $! dataConInstArgTys brCon - [(LitTy (NumTy n)) - ,resTy - ,(LitTy (NumTy (n-1)))]) - --- | Determine whether a type is isomorphic to "CLaSH.Signal.Internal.Signal'" --- --- It is i.e.: --- --- * Signal' clk a --- * (Signal' clk a, Signal' clk b) --- * Vec n (Signal' clk a) --- * data Wrap = W (Signal clk' Int) --- * etc. -isSignalType :: HashMap TyConName TyCon -> Type -> Bool -isSignalType tcm ty = go HashSet.empty ty - where - go tcSeen (tyView -> TyConApp tcNm args) = case name2String tcNm of - "CLaSH.Signal.Internal.Signal'" -> True - _ | tcNm `HashSet.member` tcSeen -> False -- Do not follow rec types - | otherwise -> case HashMap.lookup tcNm tcm of - Just tc -> let dcs = tyConDataCons tc - dcInsArgTys = concat - $ mapMaybe (`dataConInstArgTys` args) dcs - tcSeen' = HashSet.insert tcNm tcSeen - in any (go tcSeen') dcInsArgTys - Nothing -> traceIf True ($(curLoc) ++ "isSignalType: " ++ show tcNm - ++ " not found.") False - - go _ _ = False - -tyNatSize :: HMS.HashMap TyConName TyCon - -> Type - -> Except String Integer -tyNatSize m (coreView m -> Just ty) = tyNatSize m ty -tyNatSize _ (LitTy (NumTy i)) = return i -tyNatSize _ ty = throwE $ $(curLoc) ++ "Cannot reduce an integer: " ++ show ty diff --git a/src/CLaSH/Core/Var.hs b/src/CLaSH/Core/Var.hs deleted file mode 100644 --- a/src/CLaSH/Core/Var.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Variables in CoreHW --} - -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module CLaSH.Core.Var - ( Var (..) - , Id - , TyVar - , modifyVarName - ) -where - -import Control.DeepSeq (NFData (..)) -import Data.Typeable (Typeable) -import GHC.Generics (Generic) -import Unbound.Generics.LocallyNameless (Alpha,Embed,Name,Subst(..)) -import Unbound.Generics.LocallyNameless.Extra () - -import {-# SOURCE #-} CLaSH.Core.Term (Term) -import {-# SOURCE #-} CLaSH.Core.Type (Kind, Type) - --- | Variables in CoreHW -data Var a - -- | Constructor for type variables - = TyVar - { varName :: Name a - , varKind :: Embed Kind - } - -- | Constructor for term variables - | Id - { varName :: Name a - , varType :: Embed Type - } - deriving (Eq,Show,Generic,NFData) - --- | Term variable -type Id = Var Term --- | Type variable -type TyVar = Var Type - -instance (Typeable a, Alpha a) => Alpha (Var a) -instance Generic b => Subst Term (Var b) -instance Generic b => Subst Type (Var b) - --- | Change the name of a variable -modifyVarName :: - (Name a -> Name a) - -> Var a - -> Var a -modifyVarName f (TyVar n k) = TyVar (f n) k -modifyVarName f (Id n t) = Id (f n) t diff --git a/src/CLaSH/Driver.hs b/src/CLaSH/Driver.hs deleted file mode 100644 --- a/src/CLaSH/Driver.hs +++ /dev/null @@ -1,214 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente, 2017, QBayLogic - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Module that connects all the parts of the CLaSH compiler library --} - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - -module CLaSH.Driver where - -import qualified Control.Concurrent.Supply as Supply -import Control.DeepSeq -import Control.Monad (when, unless) -import Control.Monad.State (evalState, get) -import qualified Data.HashMap.Lazy as HML -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HashSet -import Data.IntMap (IntMap) -import Data.Maybe (fromMaybe) -import Data.Text.Lazy (Text) -import qualified Data.Text.Lazy as Text -import qualified Data.Time.Clock as Clock -import qualified System.Directory as Directory -import System.FilePath ((), (<.>)) -import qualified System.FilePath as FilePath -import qualified System.IO as IO -import Text.PrettyPrint.Leijen.Text (Doc, hPutDoc) -import Unbound.Generics.LocallyNameless (name2String) - -import GHC.Extra () - -import CLaSH.Annotations.TopEntity (TopEntity (..)) -import CLaSH.Backend -import CLaSH.Core.Term (Term, TmName) -import CLaSH.Core.Type (Type) -import CLaSH.Core.TyCon (TyCon, TyConName) -import CLaSH.Driver.TestbenchGen -import CLaSH.Driver.TopWrapper -import CLaSH.Driver.Types -import CLaSH.Netlist (genComponentName, genNetlist) -import CLaSH.Netlist.BlackBox.Parser (runParse) -import CLaSH.Netlist.BlackBox.Types (BlackBoxTemplate) -import CLaSH.Netlist.Types (Component (..), HWType) -import CLaSH.Normalize (checkNonRecursive, cleanupGraph, - normalize, runNormalization) -import CLaSH.Normalize.Util (callGraph, mkRecursiveComponents) -import CLaSH.Primitives.Types -import CLaSH.Util (first, second) - --- | Create a set of target HDL files for a set of functions -generateHDL :: forall backend . Backend backend - => BindingMap -- ^ Set of functions - -> Maybe backend - -> PrimMap (Text.Text) -- ^ Primitive / BlackBox Definitions - -> HashMap TyConName TyCon -- ^ TyCon cache - -> IntMap TyConName -- ^ Tuple TyCon cache - -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -- ^ Hardcoded 'Type' -> 'HWType' translator - -> (HashMap TyConName TyCon -> Bool -> Term -> Term) -- ^ Hardcoded evaluator (delta-reduction) - -> (TmName,Maybe TopEntity) -- ^ topEntity bndr + (maybe) TopEntity annotation - -> Maybe TmName -- ^ testInput bndr - -> Maybe TmName -- ^ expectedOutput bndr - -> CLaSHOpts -- ^ Debug information level for the normalization process - -> (Clock.UTCTime,Clock.UTCTime) - -> IO () -generateHDL bindingsMap hdlState primMap tcm tupTcm typeTrans eval (topEntity,annM) testInpM expOutM opts (startTime,prepTime) = do - let primMap' = (HM.map parsePrimitive :: PrimMap Text.Text -> PrimMap BlackBoxTemplate) primMap - - (supplyN,supplyTB) <- Supply.splitSupply - . snd - . Supply.freshId - <$> Supply.newSupply - - let doNorm = do norm <- normalize [topEntity] - let normChecked = checkNonRecursive topEntity norm - cleanupGraph topEntity normChecked - cg = callGraph [] bindingsMap topEntity - rcs = concat $ mkRecursiveComponents cg - rcsMap = HML.fromList - $ map (\(t,_) -> (t,t `elem` rcs)) cg - transformedBindings = runNormalization opts supplyN bindingsMap typeTrans tcm tupTcm eval primMap' rcsMap doNorm - - normTime <- transformedBindings `deepseq` Clock.getCurrentTime - let prepNormDiff = Clock.diffUTCTime normTime prepTime - putStrLn $ "Normalisation took " ++ show prepNormDiff - - let modName = takeWhile (/= '.') (name2String topEntity) - iw = opt_intWidth opts - hdlsyn = opt_hdlSyn opts - hdlState' = setModName modName - $ fromMaybe (initBackend iw hdlsyn :: backend) hdlState - mkId = evalState mkBasicId hdlState' - topNm = maybe (mkId (Text.pack $ modName ++ "_topEntity")) - (Text.pack . t_name) - annM - - (netlist,dfiles,seen) <- genNetlist transformedBindings primMap' tcm - typeTrans Nothing modName [] iw mkId [topNm] topEntity - - netlistTime <- netlist `deepseq` Clock.getCurrentTime - let normNetDiff = Clock.diffUTCTime netlistTime normTime - putStrLn $ "Netlist generation took " ++ show normNetDiff - - let topComponent = head - $ filter (\(_,Component cName _ _ _ _) -> - Text.isSuffixOf (genComponentName [topNm] mkId modName topEntity) - cName) - netlist - - (testBench,dfiles') <- genTestBench opts supplyTB primMap' - typeTrans tcm tupTcm eval mkId seen bindingsMap - testInpM - expOutM - modName - dfiles - (snd topComponent) - - - testBenchTime <- testBench `seq` Clock.getCurrentTime - let netTBDiff = Clock.diffUTCTime testBenchTime netlistTime - putStrLn $ "Testbench generation took " ++ show netTBDiff - - let topWrapper = mkTopWrapper primMap' mkId annM modName iw (snd topComponent) - hdlDocs = createHDL hdlState' modName ((noSrcSpan,topWrapper) : netlist ++ testBench) - dir = fromMaybe "." (opt_hdlDir opts) - CLaSH.Backend.name hdlState' - takeWhile (/= '.') (name2String topEntity) - prepareDir (opt_cleanhdl opts) (extension hdlState') dir - mapM_ (writeHDL dir) hdlDocs - copyDataFiles (opt_importPaths opts) dir dfiles' - - endTime <- hdlDocs `seq` Clock.getCurrentTime - let startEndDiff = Clock.diffUTCTime endTime startTime - putStrLn $ "Total compilation took " ++ show startEndDiff - -parsePrimitive :: Primitive Text -> Primitive BlackBoxTemplate -parsePrimitive (BlackBox pNm libM imps inc templT) = - let (templ,err) = either (first Left . runParse) (first Right . runParse) templT - inc' = case fmap (second runParse) inc of - Just (x,(t,[])) -> Just (x,t) - _ -> Nothing - in case err of - [] -> BlackBox pNm libM imps inc' templ - _ -> error $ "Errors in template for: " ++ show pNm ++ ":\n" ++ show err -parsePrimitive (Primitive pNm typ) = Primitive pNm typ - --- | Pretty print Components to HDL Documents -createHDL :: Backend backend - => backend -- ^ Backend - -> String - -> [(SrcSpan,Component)] -- ^ List of components - -> [(String,Doc)] -createHDL backend modName components = flip evalState backend $ do - -- (hdlNms,hdlDocs) <- unzip <$> mapM genHDL components - -- let hdlNmDocs = zip hdlNms hdlDocs - (hdlNmDocs,incs) <- unzip <$> mapM (uncurry (genHDL modName)) components - hwtys <- HashSet.toList <$> extractTypes <$> get - typesPkg <- mkTyPackage modName hwtys - let hdl = map (first (<.> CLaSH.Backend.extension backend)) (typesPkg ++ hdlNmDocs) - qincs = map (first (<.> "qsys")) (concat incs) - return (hdl ++ qincs) - --- | Prepares the directory for writing HDL files. This means creating the --- dir if it does not exist and removing all existing .hdl files from it. -prepareDir :: Bool -- ^ Remove existing HDL files - -> String -- ^ File extension of the HDL files. - -> String - -> IO () -prepareDir cleanhdl ext dir = do - -- Create the dir if needed - Directory.createDirectoryIfMissing True dir - -- Clean the directory when needed - when cleanhdl $ do - -- Find all HDL files in the directory - files <- Directory.getDirectoryContents dir - let to_remove = filter ((==ext) . FilePath.takeExtension) files - -- Prepend the dirname to the filenames - let abs_to_remove = map (FilePath.combine dir) to_remove - -- Remove the files - mapM_ Directory.removeFile abs_to_remove - --- | Writes a HDL file to the given directory -writeHDL :: FilePath -> (String, Doc) -> IO () -writeHDL dir (cname, hdl) = do - handle <- IO.openFile (dir cname) IO.WriteMode - hPutDoc handle hdl - IO.hPutStr handle "\n" - IO.hClose handle - -copyDataFiles :: [FilePath] -> FilePath -> [(String,FilePath)] -> IO () -copyDataFiles idirs dir = mapM_ (copyFile' idirs) - where - copyFile' dirs (nm,old) = do - oldExists <- Directory.doesFileExist old - if oldExists - then Directory.copyFile old new - else goImports dirs - where - new = dir FilePath. nm - - goImports [] = do - oldExists <- Directory.doesFileExist old - if oldExists - then Directory.copyFile old new - else unless (null old) (putStrLn ("WARNING: file " ++ show old ++ " does not exist")) - goImports (d:ds) = do - let old2 = d FilePath. old - old2Exists <- Directory.doesFileExist old2 - if old2Exists - then Directory.copyFile old2 new - else goImports ds diff --git a/src/CLaSH/Driver/TestbenchGen.hs b/src/CLaSH/Driver/TestbenchGen.hs deleted file mode 100644 --- a/src/CLaSH/Driver/TestbenchGen.hs +++ /dev/null @@ -1,272 +0,0 @@ -{-| - Copyright : (C) 2013-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Generate a HDL testbench for a component given a set of stimuli and a set of - matching expected outputs --} - -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -module CLaSH.Driver.TestbenchGen - ( genTestBench ) -where - -import Control.Concurrent.Supply (Supply) -import Control.Lens ((.=)) -import Data.HashMap.Lazy (HashMap) -import qualified Data.HashMap.Lazy as HashMap -import Data.IntMap.Strict (IntMap) -import Data.List (find,nub) -import Data.Maybe (catMaybes,listToMaybe, - mapMaybe) -import Data.Text.Lazy (append,pack) -import Unbound.Generics.LocallyNameless (name2String) - -import CLaSH.Core.Term -import CLaSH.Core.TyCon -import CLaSH.Core.Type - -import CLaSH.Driver.Types - -import CLaSH.Netlist -import CLaSH.Netlist.BlackBox (prepareBlackBox) -import CLaSH.Netlist.BlackBox.Types (BlackBoxTemplate, Element (Err)) -import CLaSH.Netlist.Types as N -import CLaSH.Normalize (cleanupGraph, normalize, - runNormalization) -import CLaSH.Normalize.Util (callGraph, mkRecursiveComponents) -import CLaSH.Primitives.Types -import CLaSH.Rewrite.Types - -import CLaSH.Util - --- | Generate a HDL testbench for a component given a set of stimuli and a --- set of matching expected outputs -genTestBench :: CLaSHOpts - -> Supply - -> PrimMap BlackBoxTemplate -- ^ Primitives - -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) - -> HashMap TyConName TyCon - -> IntMap TyConName - -> (HashMap TyConName TyCon -> Bool -> Term -> Term) - -> (Identifier -> Identifier) - -> [Identifier] - -> HashMap TmName (Type,SrcSpan,Term) -- ^ Global binders - -> Maybe TmName -- ^ Stimuli - -> Maybe TmName -- ^ Expected output - -> String -- ^ Name of the module containing the @topEntity@ - -> [(String,FilePath)] -- ^ Set of collected data-files - -> Component -- ^ Component to generate TB for - -> IO ([(SrcSpan,Component)],[(String,FilePath)]) -genTestBench opts supply primMap typeTrans tcm tupTcm eval mkId seen globals stimuliNmM expectedNmM modName dfiles - c@(Component cName hidden inps [outp] _) = do - let inpM = listToMaybe inps - iw = opt_intWidth opts - ioDecl = maybe [] ((:[]) . uncurry NetDecl) inpM ++ - [uncurry NetDecl outp] - - (inpInstM,inpComps,seen',hidden',dfiles') <- case inpM of - Just inp -> case stimuliNmM of - Just stimuliNm - -> (\(v,w,x,y,z) -> (Just v,w,x,y,z)) <$> - genStimuli seen primMap globals typeTrans mkId tcm normalizeSignal hidden inp modName dfiles iw stimuliNm - Nothing -> let inpExpr = Assignment (fst inp) (BlackBoxE "" [] [] Nothing [Err Nothing] (emptyBBContext {bbResult = (undefined,snd inp)}) False) - in return (Just inpExpr,[],seen,hidden,dfiles) - Nothing -> return (Nothing,[],seen,hidden,dfiles) - - ((finDecl,finExpr),s) <- runNetlistMonad globals primMap tcm typeTrans modName dfiles' iw mkId ("finished":"done":seen') $ do - done <- genDone primMap - let finDecl' = [ NetDecl "finished" Bool - , done - ] - finExpr' <- genFinish primMap - return (finDecl',finExpr') - - (expInst,expComps,seen'',hidden'',dfiles'') <- maybe (return (finExpr,[],seen',hidden',dfiles')) - (genVerifier seen' primMap globals typeTrans mkId tcm normalizeSignal hidden' outp modName dfiles' iw) - expectedNmM - - let clkNms = mapMaybe (\hd -> case hd of (_,Clock _ _) -> Just hd; _ -> Nothing) hidden - rstNms = mapMaybe (\hd -> case hd of (_,Reset _ _) -> Just hd; _ -> Nothing) hidden - - ((clks,rsts),_) <- runNetlistMonad globals primMap tcm typeTrans modName dfiles'' iw mkId ("finished":"done":seen'') $ do - varCount .= (_varCount s) - clks' <- catMaybes <$> mapM (genClock primMap) hidden'' - rsts' <- catMaybes <$> mapM (genReset primMap) hidden'' - return (clks',rsts') - - let instDecl = InstDecl cName "totest" - (map (\(i,t) -> (i,In,t,Identifier i Nothing)) - (concat [ clkNms, rstNms, maybe [] (:[]) inpM ]) - ++ - [(\(i,t) -> (i,Out,t,Identifier i Nothing)) outp]) - - tbComp = Component (mkId (pack modName `append` "_testbench")) [] [] [("done",Bool)] - (concat [ finDecl - , concat clks - , concat rsts - , ioDecl - , catMaybes [Just instDecl,inpInstM,Just expInst] - ]) - - case inps of - (_:_:_) -> traceIf (opt_dbgLevel opts > DebugNone) ("Can't make testbench for: " ++ show c) $ return ([],dfiles) - _ -> return ((noSrcSpan,tbComp):(inpComps++expComps),dfiles'') - where - normalizeSignal :: HashMap TmName (Type,SrcSpan,Term) - -> TmName - -> HashMap TmName (Type,SrcSpan,Term) - normalizeSignal glbls bndr = do - let cg = callGraph [] glbls bndr - rcs = concat $ mkRecursiveComponents cg - rcsMap = HashMap.fromList - $ map (\(t,_) -> (t,t `elem` rcs)) cg - runNormalization opts supply glbls typeTrans tcm tupTcm eval primMap rcsMap (normalize [bndr] >>= cleanupGraph bndr) - -genTestBench opts _ _ _ _ _ _ _ _ _ _ _ _ dfiles c = traceIf (opt_dbgLevel opts > DebugNone) ("Can't make testbench for: " ++ show c) $ return ([],dfiles) - -genClock :: PrimMap BlackBoxTemplate - -> (Identifier,HWType) - -> NetlistMonad (Maybe [Declaration]) -genClock primMap (clkName,Clock clkSym rate) = - case HashMap.lookup "CLaSH.Driver.TestbenchGen.clockGen" primMap of - Just (BlackBox _ lib imps Nothing (Left templ)) -> do - let (rising,rest) = divMod (toInteger rate) 2 - falling = rising + rest - ctx = emptyBBContext - { bbResult = (Left (Identifier clkName Nothing), Clock clkSym rate) - , bbInputs = [ (Left (N.Literal Nothing (NumLit 3)),Signed 32,True) - , (Left (N.Literal Nothing (NumLit rising)),Signed 32,True) - , (Left (N.Literal Nothing (NumLit falling)),Signed 32,True) - ] - } - templ' <- prepareBlackBox "CLaSH.Driver.TestbenchGen.clockGen" templ ctx - let clkGenDecl = BlackBoxD "CLaSH.Driver.TestbenchGen.clockGen" lib imps Nothing templ' ctx - clkDecls = [ NetDecl clkName (Clock clkSym rate) - , clkGenDecl - ] - return (Just clkDecls) - pM -> error $ $(curLoc) ++ ("Can't make clock declaration for: " ++ show pM) - -genClock _ _ = return Nothing - -genReset :: PrimMap BlackBoxTemplate - -> (Identifier,HWType) - -> NetlistMonad (Maybe [Declaration]) -genReset primMap (rstName,Reset clkSym rate) = - case HashMap.lookup "CLaSH.Driver.TestbenchGen.resetGen" primMap of - Just (BlackBox _ lib imps Nothing (Left templ)) -> do - let ctx = emptyBBContext - { bbResult = (Left (Identifier rstName Nothing), Reset clkSym rate) - , bbInputs = [(Left (N.Literal Nothing (NumLit 2)),Signed 32,True)] - } - templ' <- prepareBlackBox "CLaSH.Driver.TestbenchGen.resetGen" templ ctx - let resetGenDecl = BlackBoxD "CLaSH.Driver.TestbenchGen.resetGen" lib imps Nothing templ' ctx - rstDecls = [ NetDecl rstName (Reset clkSym rate) - , resetGenDecl - ] - return (Just rstDecls) - - pM -> error $ $(curLoc) ++ ("Can't make reset declaration for: " ++ show pM) - -genReset _ _ = return Nothing - -genFinish :: PrimMap BlackBoxTemplate - -> NetlistMonad Declaration -genFinish primMap = case HashMap.lookup "CLaSH.Driver.TestbenchGen.finishedGen" primMap of - Just (BlackBox _ lib imps Nothing (Left templ)) -> do - let ctx = emptyBBContext - { bbResult = (Left (Identifier "finished" Nothing), Bool) - , bbInputs = [ (Left (N.Literal Nothing (NumLit 100)),Signed 32,True) ] - } - templ' <- prepareBlackBox "CLaSH.Driver.TestbenchGen.finishGen" templ ctx - return $ BlackBoxD "CLaSH.Driver.TestbenchGen.finishGen" lib imps Nothing templ' ctx - pM -> error $ $(curLoc) ++ ("Can't make finish declaration for: " ++ show pM) - -genDone :: PrimMap BlackBoxTemplate - -> NetlistMonad Declaration -genDone primMap = case HashMap.lookup "CLaSH.Driver.TestbenchGen.doneGen" primMap of - Just (BlackBox _ lib imps Nothing (Left templ)) -> do - let ctx = emptyBBContext - { bbResult = (Left (Identifier "done" Nothing), Bool) - , bbInputs = [(Left (Identifier "finished" Nothing),Bool,False)] - } - templ' <- prepareBlackBox "CLaSH.Driver.TestbenchGen.doneGen" templ ctx - return $ BlackBoxD "CLaSH.Driver.TestbenchGen.doneGen" lib imps Nothing templ' ctx - pM -> error $ $(curLoc) ++ ("Can't make done declaration for: " ++ show pM) - -genStimuli :: [Identifier] - -> PrimMap BlackBoxTemplate - -> HashMap TmName (Type,SrcSpan,Term) - -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) - -> (Identifier -> Identifier) - -> HashMap TyConName TyCon - -> ( HashMap TmName (Type,SrcSpan,Term) - -> TmName - -> HashMap TmName (Type,SrcSpan,Term) ) - -> [(Identifier,HWType)] - -> (Identifier,HWType) - -> String - -> [(String,FilePath)] - -> Int - -> TmName - -> IO (Declaration,[(SrcSpan,Component)],[Identifier],[(Identifier,HWType)],[(String,FilePath)]) -genStimuli seen primMap globals typeTrans mkId tcm normalizeSignal hidden inp modName dfiles iw signalNm = do - let stimNormal = normalizeSignal globals signalNm - (comps,dfiles',seen') <- genNetlist stimNormal primMap tcm typeTrans Nothing modName dfiles iw mkId seen signalNm - let sigNm = genComponentName seen mkId modName signalNm - sigComp = case find ((sigNm ==) . componentName . snd) comps of - Just c -> c - Nothing -> error $ $(curLoc) ++ "Can't locate component for stimuli gen: " ++ (show $ pack $ name2String signalNm) ++ show (map (componentName.snd) comps) - - (cName,hidden',outp) = case sigComp of - (_,Component a b [] [(c,_)] _) -> (a,b,c) - (_,Component a _ is _ _) -> error $ $(curLoc) ++ "Stimuli gen " ++ show a ++ " has unexpected inputs: " ++ show is - hidden'' = nub (hidden ++ hidden') - clkNms = mapMaybe (\hd -> case hd of (_,Clock _ _) -> Just hd; _ -> Nothing) hidden' - rstNms = mapMaybe (\hd -> case hd of (_,Reset _ _) -> Just hd; _ -> Nothing) hidden' - decl = InstDecl cName "stimuli" - (map (\(i,t) -> (i,In,t,Identifier i Nothing)) - (concat [ clkNms, rstNms ]) ++ - [(outp,Out,(snd inp),Identifier (fst inp) Nothing)] - ) - return (decl,comps,seen',hidden'',dfiles') - -genVerifier :: [Identifier] - -> PrimMap BlackBoxTemplate - -> HashMap TmName (Type,SrcSpan,Term) - -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) - -> (Identifier -> Identifier) - -> HashMap TyConName TyCon - -> ( HashMap TmName (Type,SrcSpan,Term) - -> TmName - -> HashMap TmName (Type,SrcSpan,Term) ) - -> [(Identifier,HWType)] - -> (Identifier,HWType) - -> String - -> [(String,FilePath)] - -> Int - -> TmName - -> IO (Declaration,[(SrcSpan,Component)],[Identifier],[(Identifier,HWType)],[(String,FilePath)]) -genVerifier seen primMap globals typeTrans mkId tcm normalizeSignal hidden outp modName dfiles iw signalNm = do - let stimNormal = normalizeSignal globals signalNm - (comps,dfiles',seen') <- genNetlist stimNormal primMap tcm typeTrans Nothing modName dfiles iw mkId seen signalNm - let sigNm = genComponentName seen mkId modName signalNm - sigComp = case find ((sigNm ==) . componentName . snd) comps of - Just c -> c - Nothing -> error $ $(curLoc) ++ "Can't locate component for Verifier: " ++ (show $ pack $ name2String signalNm) ++ show (map (componentName . snd) comps) - (cName,hidden',inp,fin) = case sigComp of - (_,Component a b [(c,_)] [(d,_)] _) -> (a,b,c,d) - (_,Component a _ is _ _) -> error $ $(curLoc) ++ "Verifier " ++ show a ++ " has unexpected inputs: " ++ show is - hidden'' = nub (hidden ++ hidden') - clkNms = mapMaybe (\hd -> case hd of (_,Clock _ _) -> Just hd; _ -> Nothing) hidden' - rstNms = mapMaybe (\hd -> case hd of (_,Reset _ _) -> Just hd; _ -> Nothing) hidden' - decl = InstDecl cName "verify" - (map (\(i,t) -> (i,In,t,Identifier i Nothing)) - (concat [ clkNms, rstNms ]) ++ - [(inp,In,snd outp,Identifier (fst outp) Nothing),(fin,Out,Bool,Identifier "finished" Nothing)] - ) - return (decl,comps,seen',hidden'',dfiles') diff --git a/src/CLaSH/Driver/TopWrapper.hs b/src/CLaSH/Driver/TopWrapper.hs deleted file mode 100644 --- a/src/CLaSH/Driver/TopWrapper.hs +++ /dev/null @@ -1,346 +0,0 @@ -{-| - Copyright : (C) 2015-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij --} - -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TemplateHaskell #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Driver.TopWrapper where - -import Data.Char (isDigit) -import qualified Data.HashMap.Lazy as HashMap -import Data.List (mapAccumL) -import Data.Maybe (mapMaybe) -import Data.Text.Lazy (Text, append, pack, unpack) -import System.IO.Unsafe (unsafePerformIO) - -import CLaSH.Annotations.TopEntity (TopEntity (..), ClockSource (..)) - -import CLaSH.Netlist (runNetlistMonad) -import CLaSH.Netlist.BlackBox (prepareBlackBox) -import CLaSH.Netlist.BlackBox.Types (BlackBoxTemplate) -import CLaSH.Netlist.Types (BlackBoxContext (..), Component (..), - Declaration (..), Expr (..), Identifier, - HWType (..), Modifier (..), NetlistMonad, - PortDirection(..), emptyBBContext) -import CLaSH.Primitives.Types (PrimMap, Primitive (..)) -import CLaSH.Util - --- | Create a wrapper around a component, potentially initiating clock sources -mkTopWrapper :: PrimMap BlackBoxTemplate - -> (Identifier -> Identifier) - -> Maybe TopEntity -- ^ TopEntity specifications - -> String -- ^ Name of the module containing the @topEntity@ - -> Int -- ^ Int/Word/Integer bit-width - -> Component -- ^ Entity to wrap - -> Component -mkTopWrapper primMap mkId teM modName iw topComponent - = Component - { componentName = maybe (mkId (pack modName `append` "_topEntity")) (pack . t_name) teM - , inputs = inputs'' ++ extraIn teM - , outputs = outputs'' ++ extraOut teM - , hiddenPorts = case maybe [] t_clocks teM of - [] -> originalHidden - _ -> filter (`notElem` (mapMaybe isNetDecl clkDecls)) - originalHidden - , declarations = concat [ clkDecls - , wrappers - , instDecl:unwrappers - ] - } - where - iNameSupply = maybe [] (map pack . t_inputs) teM - originalHidden = hiddenPorts topComponent - - clkDecls = mkClocks primMap originalHidden iw teM - - inputs' = map (first (const "input")) - (inputs topComponent) - (inputs'',(wrappers,idsI)) = (concat *** (first concat . unzip)) - . unzip - . snd - $ mapAccumL (\nm (i,c) -> mkInput nm i c) - iNameSupply - (zip inputs' [0..]) - - oNameSupply = maybe [] (map pack . t_outputs) teM - outputs' = map (first (const "output")) - (outputs topComponent) - (outputs'',(unwrappers,idsO)) = (concat *** (first concat . unzip)) - . unzip - . snd - $ mapAccumL (\nm (o,c) -> mkOutput nm o c) - oNameSupply - (zip outputs' [0..]) - - instDecl = InstDecl (componentName topComponent) - (append (componentName topComponent) (pack "_inst")) - (zipWith (\(p,t) i -> (p,In,t,Identifier i Nothing)) - (inputs topComponent) - idsI - ++ - map (\(p,t) -> (p,In,t,Identifier p Nothing)) - (hiddenPorts topComponent) - ++ - zipWith (\(p,t) i -> (p,Out,t,Identifier i Nothing)) - (outputs topComponent) - idsO) - - isNetDecl (NetDecl nm ty) = Just (nm,ty) - isNetDecl _ = Nothing - --- | Create extra input ports for the wrapper -extraIn :: Maybe TopEntity -> [(Identifier,HWType)] -extraIn = maybe [] ((map (pack *** BitVector)) . t_extraIn) - --- | Create extra output ports for the wrapper -extraOut :: Maybe TopEntity -> [(Identifier,HWType)] -extraOut = maybe [] ((map (pack *** BitVector)) . t_extraOut) - --- | Generate input port mappings -mkInput :: [Identifier] - -> (Identifier,HWType) - -> Int - -> ( [Identifier] - , ( [(Identifier,HWType)] - , ( [Declaration] - , Identifier - ) - ) - ) -mkInput nms (i,hwty) cnt = case hwty of - Vector sz hwty' -> - let (nms',(ports',(decls',ids))) - = second ( (concat *** (first concat . unzip)) - . unzip - ) - $ mapAccumL - (\nm c -> mkInput nm (iName,hwty') c) - nms [0..(sz-1)] - netdecl = NetDecl iName hwty - netassgn = Assignment iName (mkVectorChain sz hwty' ids) - in (nms',(ports',(netdecl:decls' ++ [netassgn],iName))) - RTree d hwty' -> - let (nms',(ports',(decls',ids))) - = second ( (concat *** (first concat . unzip)) - . unzip - ) - $ mapAccumL - (\nm c -> mkInput nm (iName,hwty') c) - nms [0..((2^d)-1)] - netdecl = NetDecl iName hwty - netassgn = Assignment iName (mkRTreeChain d hwty' ids) - in (nms',(ports',(netdecl:decls' ++ [netassgn],iName))) - Product _ hwtys -> - let (nms',(ports',(decls',ids))) - = second ( (concat *** (first concat . unzip)) - . unzip - ) - $ mapAccumL - (\nm (inp,c) -> mkInput nm inp c) - nms (zip (map (iName,) hwtys) [0..]) - netdecl = NetDecl iName hwty - ids' = map (`Identifier` Nothing) ids - netassgn = Assignment iName (DataCon hwty (DC (hwty,0)) ids') - in (nms',(ports',(netdecl:decls' ++ [netassgn],iName))) - _ -> case nms of - [] -> (nms,([(iName,hwty)],([],iName))) - (n:nms') -> (nms',([(n,hwty)],([],n))) - where - - iName = append i (pack ("_" ++ show cnt)) - --- | Create a Vector chain for a list of 'Identifier's -mkVectorChain :: Int - -> HWType - -> [Identifier] - -> Expr -mkVectorChain _ elTy [] = DataCon (Vector 0 elTy) VecAppend [] -mkVectorChain _ elTy [i] = DataCon (Vector 1 elTy) VecAppend - [Identifier i Nothing] -mkVectorChain sz elTy (i:is) = DataCon (Vector sz elTy) VecAppend - [ Identifier i Nothing - , mkVectorChain (sz-1) elTy is - ] - --- | Create a RTree chain for a list of 'Identifier's -mkRTreeChain :: Int - -> HWType - -> [Identifier] - -> Expr -mkRTreeChain _ elTy [i] = DataCon (RTree 0 elTy) RTreeAppend - [Identifier i Nothing] -mkRTreeChain d elTy is = - let (isL,isR) = splitAt (length is `div` 2) is - in DataCon (RTree d elTy) RTreeAppend - [ mkRTreeChain (d-1) elTy isL - , mkRTreeChain (d-1) elTy isR - ] - --- | Generate output port mappings -mkOutput :: [Identifier] - -> (Identifier,HWType) - -> Int - -> ( [Identifier] - , ( [(Identifier,HWType)] - , ( [Declaration] - , Identifier - ) - ) - ) -mkOutput nms (i,hwty) cnt = case hwty of - Vector sz hwty' -> - let (nms',(ports',(decls',ids))) - = second ( (concat *** (first concat . unzip)) - . unzip - ) - $ mapAccumL - (\nm c -> mkOutput nm (iName,hwty') c) - nms [0..(sz-1)] - netdecl = NetDecl iName hwty - assigns = zipWith - (\id_ n -> Assignment id_ - (Identifier iName (Just (Indexed (hwty,10,n))))) - ids - [0..] - in (nms',(ports',(netdecl:assigns ++ decls',iName))) - RTree d hwty' -> - let (nms',(ports',(decls',ids))) - = second ( (concat *** (first concat . unzip)) - . unzip - ) - $ mapAccumL - (\nm c -> mkOutput nm (iName,hwty') c) - nms [0..((2^d)-1)] - netdecl = NetDecl iName hwty - assigns = zipWith - (\id_ n -> Assignment id_ - (Identifier iName (Just (Indexed (hwty,10,n))))) - ids - [0..] - in (nms',(ports',(netdecl:assigns ++ decls',iName))) - Product _ hwtys -> - let (nms',(ports',(decls',ids))) - = second ( (concat *** (first concat . unzip)) - . unzip - ) - $ mapAccumL - (\nm (inp,c) -> mkOutput nm inp c) - nms (zip (map (iName,) hwtys) [0..]) - netdecl = NetDecl iName hwty - assigns = zipWith - (\id_ n -> Assignment id_ - (Identifier iName (Just (Indexed (hwty,0,n))))) - ids - [0..] - in (nms',(ports',(netdecl:assigns ++ decls',iName))) - _ -> case nms of - [] -> (nms,([(iName,hwty)],([],iName))) - (n:nms') -> (nms',([(n,hwty)],([],n))) - where - iName = append i (pack ("_" ++ show cnt)) - --- | Create clock generators -mkClocks :: PrimMap BlackBoxTemplate -> [(Identifier,HWType)] -> Int -> Maybe TopEntity -> [Declaration] -mkClocks primMap hidden iw teM = concat - [ clockGens - , resets - ] - where - (clockGens,clkLocks) = maybe ([],[]) - (first concat . unzip . map mkClock . t_clocks) - teM - resets = mkResets primMap hidden iw clkLocks - -stringToVar :: String -> Expr -stringToVar = (`Identifier` Nothing) . pack - --- | Create a single clock generator -mkClock :: ClockSource -> ([Declaration],(Identifier,[String],Bool)) -mkClock (ClockSource {..}) = (clkDecls ++ [lockedDecl,instDecl],(lockedName,clks,c_sync)) - where - c_nameT = pack c_name - lockedName = append c_nameT "_locked" - lockedDecl = NetDecl lockedName (Reset lockedName 0) - (ports,clks) = clockPorts c_inp c_outp - clkDecls = map mkClockDecl clks - instDecl = InstDecl c_nameT (append c_nameT "_inst") - $ concat [ ports - , maybe [] ((:[]) . (\(i,e) -> (pack i,In,Reset "" 0,stringToVar e))) - c_reset - , [(pack c_lock,Out,Reset "" 0,Identifier lockedName Nothing)] - ] - -mkClockDecl :: String -> Declaration -mkClockDecl s = NetDecl (pack s) (Clock (pack name) (read rate)) - where - (name,rate) = span (not . isDigit) s - - --- | Create a single clock path -clockPorts :: [(String,String)] -> [(String,String)] - -> ([(Identifier,PortDirection,HWType,Expr)],[String]) -clockPorts inp outp = (inPorts ++ outPorts,clks) - where - inPorts = map (\(i,e) -> (pack i,In,Clock "" 0,stringToVar e)) inp - outPorts = map (\(i,e) -> (pack i,Out,Clock "" 0,stringToVar e)) outp - clks = map snd outp - --- | Generate resets -mkResets :: PrimMap BlackBoxTemplate - -> [(Identifier,HWType)] - -> Int - -> [(Identifier,[String],Bool)] - -> [Declaration] -mkResets primMap hidden iw = unsafeRunNetlist iw . fmap concat . mapM assingReset - where - assingReset (lock,clks,doSync) = concat <$> mapM connectReset matched - where - matched = filter match hidden - match (_,(Reset nm r)) = elem (unpack nm ++ show r) clks - match _ = False - - connectReset (rst,(Reset nm r)) = if doSync - then return [NetDecl rst (Reset nm r), Assignment rst (Identifier lock Nothing)] - else genSyncReset primMap lock rst nm r - connectReset _ = return [] - --- | Generate a reset synchroniser that synchronously de-asserts an --- asynchronous reset signal -genSyncReset :: PrimMap BlackBoxTemplate - -> Identifier - -> Identifier - -> Text - -> Integer - -> NetlistMonad [Declaration] -genSyncReset primMap lock rst nm r = do - let resetType = Reset rst 0 - ctx = emptyBBContext - { bbResult = (Right ((Identifier rst Nothing),(nm,r)), resetType) - , bbInputs = [(Left (Identifier lock Nothing),resetType,False)] - } - bbName = "CLaSH.TopWrapper.syncReset" - resetGenDecl <- case HashMap.lookup bbName primMap of - Just (BlackBox _ lib imps Nothing (Left templ)) -> do - templ' <- prepareBlackBox bbName templ ctx - return (BlackBoxD bbName lib imps Nothing templ' ctx) - pM -> error $ $(curLoc) ++ ("Can't make reset sync for: " ++ show pM) - - return [NetDecl rst (Reset nm r),resetGenDecl] - --- | The 'NetListMonad' is a transformer stack with 'IO' at the bottom. --- So we must use 'unsafePerformIO'. -unsafeRunNetlist :: Int - -> NetlistMonad a - -> a -unsafeRunNetlist iw - = unsafePerformIO - . fmap fst - . runNetlistMonad HashMap.empty HashMap.empty - HashMap.empty (\_ _ -> Nothing) "" [] iw id [] diff --git a/src/CLaSH/Driver/Types.hs b/src/CLaSH/Driver/Types.hs deleted file mode 100644 --- a/src/CLaSH/Driver/Types.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-| - Copyright : (C) 2013-2016, University of Twente, 2017, QBayLogic - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Type definitions used by the Driver module --} - -module CLaSH.Driver.Types - (module CLaSH.Driver.Types - ,SrcSpan, noSrcSpan - ) -where - -import Control.Exception (Exception) -import Data.HashMap.Lazy (HashMap) - -import SrcLoc (SrcSpan, noSrcSpan) - -import CLaSH.Core.Term (Term,TmName) -import CLaSH.Core.Type (Type) - -import CLaSH.Rewrite.Types (DebugLevel) -import CLaSH.Netlist.BlackBox.Types (HdlSyn) - --- | Global function binders -type BindingMap = HashMap TmName (Type,SrcSpan,Term) - -data CLaSHOpts = CLaSHOpts { opt_inlineLimit :: Int - , opt_specLimit :: Int - , opt_inlineBelow :: Int - , opt_dbgLevel :: DebugLevel - , opt_cleanhdl :: Bool - , opt_intWidth :: Int - , opt_hdlDir :: Maybe String - , opt_hdlSyn :: HdlSyn - , opt_errorExtra :: Bool - , opt_floatSupport :: Bool - , opt_allowZero :: Bool - , opt_importPaths :: [FilePath] - , opt_errorInvalidCoercions :: Bool - } - -data CLaSHException = CLaSHException SrcSpan String (Maybe String) - -instance Show CLaSHException where - show (CLaSHException _ s eM) = s ++ "\n" ++ maybe "" id eM - -instance Exception CLaSHException diff --git a/src/CLaSH/Netlist.hs b/src/CLaSH/Netlist.hs deleted file mode 100644 --- a/src/CLaSH/Netlist.hs +++ /dev/null @@ -1,468 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Create Netlists out of normalized CoreHW Terms --} - -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} - -module CLaSH.Netlist where - -import Control.Exception (throw) -import Control.Lens ((.=),(^.),_1,_2) -import qualified Control.Lens as Lens -import Control.Monad.State.Strict (runStateT) -import Control.Monad.Writer.Strict (listen, runWriterT, tell) -import Data.Binary.IEEE754 (floatToWord, doubleToWord) -import Data.Char (ord) -import Data.Either (lefts,partitionEithers) -import Data.HashMap.Lazy (HashMap) -import qualified Data.HashMap.Lazy as HashMap -import Data.List (elemIndex) -import Data.Maybe (fromMaybe) -import Data.Set (toList,fromList) -import qualified Data.Text.Lazy as Text -import Unbound.Generics.LocallyNameless (Embed (..), name2String, - runFreshMT, unbind, unembed, - unrebind) - -import SrcLoc (SrcSpan,noSrcSpan) - -import CLaSH.Core.DataCon (DataCon (..)) -import CLaSH.Core.FreeVars (typeFreeVars) -import CLaSH.Core.Literal (Literal (..)) -import CLaSH.Core.Pretty (showDoc) -import CLaSH.Core.Term (Pat (..), Term (..), TmName) -import qualified CLaSH.Core.Term as Core -import CLaSH.Core.Type (Type (..)) -import CLaSH.Core.TyCon (TyConName, TyCon) -import CLaSH.Core.Util (collectArgs, isVar, termType) -import CLaSH.Core.Var (Id, Var (..)) -import CLaSH.Driver.Types (CLaSHException (..)) -import CLaSH.Netlist.BlackBox -import CLaSH.Netlist.BlackBox.Types (BlackBoxTemplate) -import CLaSH.Netlist.Id -import CLaSH.Netlist.Types as HW -import CLaSH.Netlist.Util -import CLaSH.Normalize.Util -import CLaSH.Primitives.Types as P -import CLaSH.Util - --- | Generate a hierarchical netlist out of a set of global binders with --- @topEntity@ at the top. -genNetlist :: HashMap TmName (Type,SrcSpan,Term) - -- ^ Global binders - -> PrimMap BlackBoxTemplate - -- ^ Primitive definitions - -> HashMap TyConName TyCon - -- ^ TyCon cache - -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) - -- ^ Hardcoded Type -> HWType translator - -> Maybe Int - -- ^ Symbol count - -> String - -- ^ Name of the module containing the @topEntity@ - -> [(String,FilePath)] - -- ^ Set of collected data-files - -> Int - -- ^ Int/Word/Integer bit-width - -> (Identifier -> Identifier) - -- ^ valid identifiers - -> [Identifier] - -- ^ Seen components - -> TmName - -- ^ Name of the @topEntity@ - -> IO ([(SrcSpan,Component)],[(String,FilePath)],[Identifier]) -genNetlist globals primMap tcm typeTrans mStart modName dfiles iw mkId seen topEntity = do - - (_,s) <- runNetlistMonad globals primMap tcm typeTrans modName dfiles iw mkId seen $ genComponent topEntity mStart - return (HashMap.elems $ _components s, _dataFiles s, _seenComps s) - --- | Run a NetlistMonad action in a given environment -runNetlistMonad :: HashMap TmName (Type,SrcSpan,Term) - -- ^ Global binders - -> PrimMap BlackBoxTemplate - -- ^ Primitive Definitions - -> HashMap TyConName TyCon - -- ^ TyCon cache - -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) - -- ^ Hardcode Type -> HWType translator - -> String - -- ^ Name of the module containing the @topEntity@ - -> [(String,FilePath)] - -- ^ Set of collected data-files - -> Int - -- ^ Int/Word/Integer bit-width - -> (Identifier -> Identifier) - -- ^ valid identifiers - -> [Identifier] - -- ^ Seen components - -> NetlistMonad a - -- ^ Action to run - -> IO (a, NetlistState) -runNetlistMonad s p tcm typeTrans modName dfiles iw mkId seen - = runFreshMT - . flip runStateT s' - . (fmap fst . runWriterT) - . runNetlist - where - s' = NetlistState s HashMap.empty 0 HashMap.empty p typeTrans tcm (Text.empty,noSrcSpan) dfiles iw mkId [] seen' names - (seen',names) = genNames mkId modName seen HashMap.empty (HashMap.keys s) - -genNames :: (Identifier -> Identifier) - -> String - -> [Identifier] - -> HashMap TmName Identifier - -> [TmName] - -> ([Identifier], HashMap TmName Identifier) -genNames mkId modName = go - where - go s m [] = (s,m) - go s m (nm:nms) = let nm' = genComponentName s mkId modName nm - s' = nm':s - m' = HashMap.insert nm nm' m - in go s' m' nms - --- | Generate a component for a given function (caching) -genComponent :: TmName -- ^ Name of the function - -> Maybe Int -- ^ Starting value of the unique counter - -> NetlistMonad (SrcSpan,Component) -genComponent compName mStart = do - compExprM <- fmap (HashMap.lookup compName) $ Lens.use bindings - case compExprM of - Nothing -> do - (_,sp) <- Lens.use curCompNm - throw (CLaSHException sp ($(curLoc) ++ "No normalized expression found for: " ++ show compName) Nothing) - Just (_,_,expr_) -> do - c@(_,Component _ clks _ _ _) <- makeCached compName components $ genComponentT compName expr_ mStart - -- This might seem redundant, because you think `genComponentT` already - -- added those clocks, right? wrong! - -- - -- `makeCached` stores the value returned by a monadic action, so when - -- we use a cached result, its clocks weren't added to the current - -- writer which is keeping track of used clock ports. - tell (fromList clks) - return c - --- | Generate a component for a given function -genComponentT :: TmName -- ^ Name of the function - -> Term -- ^ Corresponding term - -> Maybe Int -- ^ Starting value of the unique counter - -> NetlistMonad (SrcSpan,Component) -genComponentT compName componentExpr mStart = do - varCount .= fromMaybe 0 mStart - componentName' <- (HashMap.! compName) <$> Lens.use componentNames - sp <- ((^. _2) . (HashMap.! compName)) <$> Lens.use bindings - curCompNm .= (componentName',sp) - - tcm <- Lens.use tcCache - seenIds .= [] - (arguments,binders,result) <- do { normalizedM <- splitNormalized tcm componentExpr - ; case normalizedM of - Right normalized -> mkUniqueNormalized normalized - Left err -> throw (CLaSHException sp err Nothing) - } - - let ids = HashMap.fromList - $ map (\(Id v (Embed t)) -> (v,t)) - $ arguments ++ map fst binders - - gamma <- (ids `HashMap.union`) . HashMap.map (^. _1) - <$> Lens.use bindings - - varEnv .= gamma - - typeTrans <- Lens.use typeTranslator - let resType = unsafeCoreTypeToHWType $(curLoc) typeTrans tcm $ HashMap.lookupDefault (error $ $(curLoc) ++ "resType" ++ show (result,HashMap.keys ids)) result ids - argTypes = map (\(Id _ (Embed t)) -> unsafeCoreTypeToHWType $(curLoc) typeTrans tcm t) arguments - - let netDecls = map (\(id_,_) -> - NetDecl (Text.pack . name2String $ varName id_) - (unsafeCoreTypeToHWType $(curLoc) typeTrans tcm . unembed $ varType id_) - ) $ filter ((/= result) . varName . fst) binders - (decls,clks) <- listen $ concat <$> mapM (uncurry mkDeclarations . second unembed) binders - - let compInps = zip (map (Text.pack . name2String . varName) arguments) argTypes - compOutp = (Text.pack $ name2String result, resType) - component = Component componentName' (toList clks) compInps [compOutp] (netDecls ++ decls) - return (sp,component) - - -genComponentName :: [Identifier] -> (Identifier -> Identifier) -> String -> TmName -> Identifier -genComponentName seen mkId prefix nm = - let i = mkId . stripDollarPrefixes . last - . Text.splitOn (Text.pack ".") . Text.pack - $ name2String nm - i' = if Text.null i - then Text.pack "Component" - else i - i'' = mkId (Text.pack (prefix ++ "_") `Text.append` i') - in if i'' `elem` seen - then go 0 i'' - else i'' - where - go :: Integer -> Identifier -> Identifier - go n i = - let i' = mkId (i `Text.append` Text.pack ('_':show n)) - in if i' `elem` seen - then go (n+1) i - else i' - --- | Generate a list of Declarations for a let-binder -mkDeclarations :: Id -- ^ LHS of the let-binder - -> Term -- ^ RHS of the let-binder - -> NetlistMonad [Declaration] -mkDeclarations bndr (Var _ v) = mkFunApp bndr v [] - -mkDeclarations _ e@(Case _ _ []) = do - (_,sp) <- Lens.use curCompNm - throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: Case-decompositions with an empty list of alternatives not supported:\n\n" ++ showDoc e) Nothing) - -mkDeclarations bndr e@(Case scrut _ [alt]) = do - (pat,v) <- unbind alt - (_,sp) <- Lens.use curCompNm - (varTy,varTm) <- case v of - (Var t n) -> return (t,n) - _ -> throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: RHS of case-projection is not a variable:\n\n" ++ showDoc e) Nothing) - typeTrans <- Lens.use typeTranslator - tcm <- Lens.use tcCache - scrutTy <- termType tcm scrut - let sHwTy = unsafeCoreTypeToHWType $(curLoc) typeTrans tcm scrutTy - vHwTy = unsafeCoreTypeToHWType $(curLoc) typeTrans tcm varTy - (selId,decls) <- case scrut of - (Var _ scrutNm) -> return (Text.pack $ name2String scrutNm,[]) - _ -> do - let scrutId = Text.pack . (++ "_case_scrut") . name2String $ varName bndr - (newExpr, newDecls) <- mkExpr False (Left scrutId) scrutTy scrut - case newExpr of - (Identifier newId Nothing) -> return (newId,newDecls) - _ -> do - scrutId' <- mkUniqueIdentifier scrutId - let scrutDecl = NetDecl scrutId' sHwTy - scrutAssn = Assignment scrutId' newExpr - return (scrutId',newDecls ++ [scrutDecl,scrutAssn]) - let dstId = Text.pack . name2String $ varName bndr - altVarId = Text.pack $ name2String varTm - modifier = case pat of - DataPat (Embed dc) ids -> let (exts,tms) = unrebind ids - tmsTys = map (unembed . varType) tms - tmsFVs = concatMap (Lens.toListOf typeFreeVars) tmsTys - extNms = map varName exts - tms' = if any (`elem` tmsFVs) extNms - then throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: Pattern binds existential variables:\n\n" ++ showDoc e) Nothing) - else tms - in case elemIndex (Id varTm (Embed varTy)) tms' of - Nothing -> Nothing - Just fI - | sHwTy /= vHwTy -> Just (Indexed (sHwTy,dcTag dc - 1,fI)) - -- When element and subject have the same HW-type, - -- then the projections is just the identity - | otherwise -> Just (DC (Void,0)) - _ -> throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: Unexpected pattern in case-projection:\n\n" ++ showDoc e) Nothing) - extractExpr = Identifier (maybe altVarId (const selId) modifier) modifier - return (decls ++ [Assignment dstId extractExpr]) - -mkDeclarations bndr (Case scrut altTy alts) = do - alts' <- reorderPats <$> mapM unbind alts - tcm <- Lens.use tcCache - scrutTy <- termType tcm scrut - scrutHTy <- unsafeCoreTypeToHWTypeM $(curLoc) scrutTy - altHTy <- unsafeCoreTypeToHWTypeM $(curLoc) altTy - let scrutId = Text.pack . (++ "_case_scrut") . name2String $ varName bndr - (_,sp) <- Lens.use curCompNm - (scrutExpr,scrutDecls) <- first (mkScrutExpr sp scrutHTy (fst (head alts'))) <$> mkExpr True (Left scrutId) scrutTy scrut - (exprs,altsDecls) <- (second concat . unzip) <$> mapM (mkCondExpr scrutHTy) alts' - - let dstId = Text.pack . name2String $ varName bndr - return $! scrutDecls ++ altsDecls ++ [CondAssignment dstId altHTy scrutExpr scrutHTy exprs] - where - mkCondExpr :: HWType -> (Pat,Term) -> NetlistMonad ((Maybe HW.Literal,Expr),[Declaration]) - mkCondExpr scrutHTy (pat,alt) = do - let altId = Text.pack . (++ "_case_alt") . name2String $ varName bndr - (altExpr,altDecls) <- mkExpr False (Left altId) altTy alt - (,altDecls) <$> case pat of - DefaultPat -> return (Nothing,altExpr) - DataPat (Embed dc) _ -> return (Just (dcToLiteral scrutHTy (dcTag dc)),altExpr) - LitPat (Embed (IntegerLiteral i)) -> return (Just (NumLit i),altExpr) - LitPat (Embed (IntLiteral i)) -> return (Just (NumLit i), altExpr) - LitPat (Embed (WordLiteral w)) -> return (Just (NumLit w), altExpr) - LitPat (Embed (CharLiteral c)) -> return (Just (NumLit . toInteger $ ord c), altExpr) - LitPat (Embed (Int64Literal i)) -> return (Just (NumLit i), altExpr) - LitPat (Embed (Word64Literal w)) -> return (Just (NumLit w), altExpr) - _ -> do - (_,sp) <- Lens.use curCompNm - throw (CLaSHException sp ($(curLoc) ++ "Not an integer literal in LitPat:\n\n" ++ showDoc pat) Nothing) - - mkScrutExpr :: SrcSpan -> HWType -> Pat -> Expr -> Expr - mkScrutExpr sp scrutHTy pat scrutE = case pat of - DataPat (Embed dc) _ -> let modifier = Just (DC (scrutHTy,dcTag dc - 1)) - in case scrutE of - Identifier scrutId _ -> Identifier scrutId modifier - _ -> throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: Not a variable reference or primitive as subject of a case-statement:\n\n" ++ show scrutE) Nothing) - _ -> scrutE - - -- GHC puts default patterns in the first position, we want them in the - -- last position. - reorderPats :: [(Pat,Term)] -> [(Pat,Term)] - reorderPats ((DefaultPat,e):alts') = alts' ++ [(DefaultPat,e)] - reorderPats alts' = alts' - -mkDeclarations bndr app = - let (appF,(args,tyArgs)) = second partitionEithers $ collectArgs app - in case appF of - Var _ f - | null tyArgs -> mkFunApp bndr f args - | otherwise -> do - (_,sp) <- Lens.use curCompNm - throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: Var-application with Type arguments:\n\n" ++ showDoc app) Nothing) - _ -> do - (exprApp,declsApp) <- mkExpr False (Right bndr) (unembed $ varType bndr) app - let dstId = Text.pack . name2String $ varName bndr - assn = case exprApp of - Identifier _ Nothing -> [] - _ -> [Assignment dstId exprApp] - return (declsApp ++ assn) - --- | Generate a list of Declarations for a let-binder where the RHS is a function application -mkFunApp :: Id -- ^ LHS of the let-binder - -> TmName -- ^ Name of the applied function - -> [Term] -- ^ Function arguments - -> NetlistMonad [Declaration] -mkFunApp dst fun args = do - normalized <- Lens.use bindings - case HashMap.lookup fun normalized of - Just _ -> do - (_,Component compName hidden compInps [compOutp] _) <- preserveVarEnv $ genComponent fun Nothing - if length args == length compInps - then do tcm <- Lens.use tcCache - argTys <- mapM (termType tcm) args - let dstId = Text.pack . name2String $ varName dst - (argExprs,argDecls) <- fmap (second concat . unzip) $! mapM (\(e,t) -> mkExpr False (Left dstId) t e) (zip args argTys) - (argExprs',argDecls') <- (second concat . unzip) <$> mapM (toSimpleVar dst) (zip argExprs argTys) - let hiddenAssigns = map (\(i,t) -> (i,In,t,Identifier i Nothing)) hidden - inpAssigns = zipWith (\(i,t) e -> (i,In,t,e)) compInps argExprs' - outpAssign = (fst compOutp,Out,snd compOutp,Identifier dstId Nothing) - instLabel = Text.concat [compName, Text.pack "_", dstId] - instDecl = InstDecl compName instLabel (outpAssign:hiddenAssigns ++ inpAssigns) - tell (fromList hidden) - return (argDecls ++ argDecls' ++ [instDecl]) - else error $ $(curLoc) ++ "under-applied normalized function" - Nothing -> case args of - [] -> do - let dstId = Text.pack . name2String $ varName dst - return [Assignment dstId (Identifier (Text.pack $ name2String fun) Nothing)] - _ -> error $ $(curLoc) ++ "Unknown function: " ++ showDoc fun - -toSimpleVar :: Id - -> (Expr,Type) - -> NetlistMonad (Expr,[Declaration]) -toSimpleVar _ (e@(Identifier _ _),_) = return (e,[]) -toSimpleVar dst (e,ty) = do - let argNm = Text.pack . (++ "_app_arg") . name2String $ varName dst - argNm' <- mkUniqueIdentifier argNm - hTy <- unsafeCoreTypeToHWTypeM $(curLoc) ty - let argDecl = NetDecl argNm' hTy - argAssn = Assignment argNm' e - return (Identifier argNm' Nothing,[argDecl,argAssn]) - --- | Generate an expression for a term occurring on the RHS of a let-binder -mkExpr :: Bool -- ^ Treat BlackBox expression as declaration - -> (Either Identifier Id) -- ^ Id to assign the result to - -> Type -- ^ Type of the LHS of the let-binder - -> Term -- ^ Term to convert to an expression - -> NetlistMonad (Expr,[Declaration]) -- ^ Returned expression and a list of generate BlackBox declarations -mkExpr _ _ _ (Core.Literal l) = do - iw <- Lens.use intWidth - case l of - IntegerLiteral i -> return (HW.Literal (Just (Signed iw,iw)) $ NumLit i, []) - IntLiteral i -> return (HW.Literal (Just (Signed iw,iw)) $ NumLit i, []) - WordLiteral w -> return (HW.Literal (Just (Unsigned iw,iw)) $ NumLit w, []) - Int64Literal i -> return (HW.Literal (Just (Signed 64,64)) $ NumLit i, []) - Word64Literal w -> return (HW.Literal (Just (Unsigned 64,64)) $ NumLit w, []) - CharLiteral c -> return (HW.Literal (Just (Unsigned 21,21)) . NumLit . toInteger $ ord c, []) - FloatLiteral r -> let f = fromRational r :: Float - i = toInteger (floatToWord f) - in return (HW.Literal (Just (BitVector 32,32)) (NumLit i), []) - DoubleLiteral r -> let d = fromRational r :: Double - i = toInteger (doubleToWord d) - in return (HW.Literal (Just (BitVector 64,64)) (NumLit i), []) - _ -> error $ $(curLoc) ++ "not an integer or char literal" - -mkExpr bbEasD bndr ty app = do - let (appF,args) = collectArgs app - tmArgs = lefts args - hwTy <- unsafeCoreTypeToHWTypeM $(curLoc) ty - (_,sp) <- Lens.use curCompNm - case appF of - Data dc - | all (\e -> isConstant e || isVar e) tmArgs -> mkDcApplication hwTy bndr dc tmArgs - | otherwise -> - throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: DataCon-application with non-Simple arguments:\n\n" ++ showDoc app) Nothing) - Prim nm _ -> mkPrimitive False bbEasD bndr nm args ty - Var _ f - | null tmArgs -> return (Identifier (Text.pack $ name2String f) Nothing,[]) - | otherwise -> - throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: top-level binder in argument position:\n\n" ++ showDoc app) Nothing) - _ -> throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: application of a Let/Lam/Case:\n\n" ++ showDoc app) Nothing) - --- | Generate an expression for a DataCon application occurring on the RHS of a let-binder -mkDcApplication :: HWType -- ^ HWType of the LHS of the let-binder - -> (Either Identifier Id) -- ^ Id to assign the result to - -> DataCon -- ^ Applied DataCon - -> [Term] -- ^ DataCon Arguments - -> NetlistMonad (Expr,[Declaration]) -- ^ Returned expression and a list of generate BlackBox declarations -mkDcApplication dstHType bndr dc args = do - tcm <- Lens.use tcCache - argTys <- mapM (termType tcm) args - let isSP (SP _ _) = True - isSP _ = False - let argNm = either id (Text.pack . (++ "_app_arg") . name2String . varName) bndr - (argExprs,argDecls) <- fmap (second concat . unzip) $! mapM (\(e,t) -> mkExpr (isSP dstHType) (Left argNm) t e) (zip args argTys) - argHWTys <- mapM coreTypeToHWTypeM argTys - fmap (,argDecls) $! case (argHWTys,argExprs) of - -- Is the DC just a newtype wrapper? - ([Just argHwTy],[argExpr]) | argHwTy == dstHType -> - return (HW.DataCon dstHType (DC (Void,-1)) [argExpr]) - _ -> case dstHType of - SP _ dcArgPairs -> do - let dcI = dcTag dc - 1 - dcArgs = snd $ indexNote ($(curLoc) ++ "No DC with tag: " ++ show dcI) dcArgPairs dcI - case compare (length dcArgs) (length argExprs) of - EQ -> return (HW.DataCon dstHType (DC (dstHType,dcI)) argExprs) - LT -> error $ $(curLoc) ++ "Over-applied constructor" - GT -> error $ $(curLoc) ++ "Under-applied constructor" - Product _ dcArgs -> - case compare (length dcArgs) (length argExprs) of - EQ -> return (HW.DataCon dstHType (DC (dstHType,0)) argExprs) - LT -> error $ $(curLoc) ++ "Over-applied constructor" - GT -> error $ $(curLoc) ++ "Under-applied constructor" - Sum _ _ -> - return (HW.DataCon dstHType (DC (dstHType,dcTag dc - 1)) []) - Bool -> - let dc' = case dcTag dc of - 1 -> HW.Literal Nothing (BoolLit False) - 2 -> HW.Literal Nothing (BoolLit True) - tg -> error $ $(curLoc) ++ "unknown bool literal: " ++ showDoc dc ++ "(tag: " ++ show tg ++ ")" - in return dc' - Vector 0 _ -> return (HW.DataCon dstHType VecAppend []) - Vector 1 _ -> case argExprs of - [_,e,_] -> return (HW.DataCon dstHType VecAppend [e]) - _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `Cons`: " ++ showDoc args - Vector _ _ -> case argExprs of - [_,e1,e2] -> return (HW.DataCon dstHType VecAppend [e1,e2]) - _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `Cons`: " ++ showDoc args - RTree 0 _ -> case argExprs of - [_,e] -> return (HW.DataCon dstHType RTreeAppend [e]) - _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `LR`: " ++ showDoc args - RTree _ _ -> case argExprs of - [_,e1,e2] -> return (HW.DataCon dstHType RTreeAppend [e1,e2]) - _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `BR`: " ++ showDoc args - String -> - let dc' = case dcTag dc of - 1 -> HW.Literal Nothing (StringLit "") - _ -> error $ $(curLoc) ++ "mkDcApplication undefined for: " ++ show (dstHType,dc,dcTag dc,args,argHWTys) - in return dc' - _ -> error $ $(curLoc) ++ "mkDcApplication undefined for: " ++ show (dstHType,dc,args,argHWTys) diff --git a/src/CLaSH/Netlist.hs-boot b/src/CLaSH/Netlist.hs-boot deleted file mode 100644 --- a/src/CLaSH/Netlist.hs-boot +++ /dev/null @@ -1,31 +0,0 @@ -{-| - Copyright : (C) 2015-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij --} - -module CLaSH.Netlist (genComponent,mkExpr,mkDcApplication) where - -import CLaSH.Core.DataCon (DataCon) -import CLaSH.Core.Term (Term,TmName) -import CLaSH.Core.Type (Type) -import CLaSH.Core.Var (Id) -import CLaSH.Driver.Types (SrcSpan) -import CLaSH.Netlist.Types (Expr, HWType, Identifier, NetlistMonad, Component, - Declaration) - -genComponent :: TmName - -> Maybe Int - -> NetlistMonad (SrcSpan,Component) - -mkExpr :: Bool - -> Either Identifier Id - -> Type - -> Term - -> NetlistMonad (Expr,[Declaration]) - -mkDcApplication :: HWType - -> Either Identifier Id - -> DataCon - -> [Term] - -> NetlistMonad (Expr,[Declaration]) diff --git a/src/CLaSH/Netlist/BlackBox.hs b/src/CLaSH/Netlist/BlackBox.hs deleted file mode 100644 --- a/src/CLaSH/Netlist/BlackBox.hs +++ /dev/null @@ -1,319 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Functions to create BlackBox Contexts and fill in BlackBox templates --} - -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} - -module CLaSH.Netlist.BlackBox where - -import Control.Exception (throw) -import Control.Lens ((.=),(<<%=)) -import qualified Control.Lens as Lens -import Data.Char (ord) -import Data.Either (lefts) -import qualified Data.HashMap.Lazy as HashMap -import qualified Data.IntMap as IntMap -import Data.Text.Lazy (append,fromStrict, pack) -import qualified Data.Text.Lazy as Text -import Data.Text (unpack) -import qualified Data.Text as TextS -import Unbound.Generics.LocallyNameless (embed, name2String, string2Name, - unembed) - --- import CLaSH.Backend as N -import CLaSH.Core.DataCon as D (dcTag) -import CLaSH.Core.Literal as L (Literal (..)) -import CLaSH.Core.Pretty (showDoc) -import CLaSH.Core.Term as C (Term (..)) -import CLaSH.Core.Type as C (Type (..), ConstTy (..), - splitFunTys) -import CLaSH.Core.TyCon as C (tyConDataCons) -import CLaSH.Core.Util (collectArgs, isFun, termType) -import CLaSH.Core.Var as V (Id, Var (..)) -import CLaSH.Driver.Types (CLaSHException (..)) -import {-# SOURCE #-} CLaSH.Netlist (genComponent, mkDcApplication, - mkExpr) -import CLaSH.Netlist.BlackBox.Types as B -import CLaSH.Netlist.BlackBox.Util as B -import CLaSH.Netlist.Types as N -import CLaSH.Netlist.Util as N -import CLaSH.Normalize.Util (isConstant) -import CLaSH.Primitives.Types as P -import CLaSH.Util - --- | Generate the context for a BlackBox instantiation. -mkBlackBoxContext :: Id -- ^ Identifier binding the primitive/blackbox application - -> [Term] -- ^ Arguments of the primitive/blackbox application - -> NetlistMonad (BlackBoxContext,[Declaration]) -mkBlackBoxContext resId args = do - -- Make context inputs - tcm <- Lens.use tcCache - let resNm = Text.pack . name2String $ varName resId - (imps,impDecls) <- unzip <$> mapM (mkArgument resNm) args - (funs,funDecls) <- mapAccumLM (addFunction tcm) IntMap.empty (zip args [0..]) - - -- Make context result - res <- case synchronizedClk tcm (unembed $ V.varType resId) of - Just clk -> Right . (,clk) . (`N.Identifier` Nothing) <$> mkBasicId (pack $ name2String (V.varName resId)) - Nothing -> Left . (`N.Identifier` Nothing) <$> mkBasicId (pack $ name2String (V.varName resId)) - resTy <- unsafeCoreTypeToHWTypeM $(curLoc) (unembed $ V.varType resId) - - return ( Context (res,resTy) imps funs Nothing - , concat impDecls ++ concat funDecls - ) - where - addFunction tcm im (arg,i) = do - isF <- isFun tcm arg - if isF - then do (f,d) <- mkFunInput resId arg - let im' = IntMap.insert i f im - return (im',d) - else return (im,[]) - -prepareBlackBox :: TextS.Text - -> BlackBoxTemplate - -> BlackBoxContext - -> NetlistMonad BlackBoxTemplate -prepareBlackBox pNm templ bbCtx = - if verifyBlackBoxContext bbCtx templ - then instantiateCompName >=> - setSym >=> - setClocks bbCtx >=> - collectFilePaths bbCtx $ templ - else do - (_,sp) <- Lens.use curCompNm - templ' <- prettyBlackBox templ - let msg = $(curLoc) ++ "Can't match template for " ++ show pNm ++ " :\n\n" ++ Text.unpack templ' ++ - "\n\nwith context:\n\n" ++ show bbCtx - throw (CLaSHException sp msg Nothing) - -mkArgument :: Identifier -- ^ LHS of the original let-binder - -> Term - -> NetlistMonad ( (SyncExpr,HWType,Bool) - , [Declaration] - ) -mkArgument bndr e = do - tcm <- Lens.use tcCache - ty <- termType tcm e - iw <- Lens.use intWidth - hwTyM <- N.termHWTypeM e - ((e',t,l),d) <- case hwTyM of - Nothing -> return ((Identifier "__VOID__" Nothing,Void,False),[]) - Just hwTy -> case collectArgs e of - (Var _ v,[]) -> do vT <- (`Identifier` Nothing) <$> mkBasicId (pack $ name2String v) - return ((vT,hwTy,False),[]) - (C.Literal (IntegerLiteral i),[]) -> return ((N.Literal (Just (Signed iw,iw)) (N.NumLit i),hwTy,True),[]) - (C.Literal (IntLiteral i), []) -> return ((N.Literal (Just (Signed iw,iw)) (N.NumLit i),hwTy,True),[]) - (C.Literal (WordLiteral w), []) -> return ((N.Literal (Just (Unsigned iw,iw)) (N.NumLit w),hwTy,True),[]) - (C.Literal (CharLiteral c), []) -> return ((N.Literal (Just (Unsigned 21,21)) (N.NumLit . toInteger $ ord c),hwTy,True),[]) - (C.Literal (StringLiteral s),[]) -> return ((N.Literal Nothing (N.StringLit s),hwTy,True),[]) - (C.Literal (Int64Literal i), []) -> return ((N.Literal (Just (Signed 64,64)) (N.NumLit i),hwTy,True),[]) - (C.Literal (Word64Literal i), []) -> return ((N.Literal (Just (Unsigned 64,64)) (N.NumLit i),hwTy,True),[]) - (Prim f _,args) -> do - (e',d) <- mkPrimitive True False (Left bndr) f args ty - case e' of - (Identifier _ _) -> return ((e',hwTy,False), d) - _ -> return ((e',hwTy,isConstant e), d) - (Data dc, args) -> do - (exprN,dcDecls) <- mkDcApplication hwTy (Left bndr) dc (lefts args) - return ((exprN,hwTy,isConstant e),dcDecls) - _ -> return ((Identifier "__VOID__" Nothing,hwTy,False),[]) - return ((addClock tcm ty e',t,l),d) - where - addClock tcm ty e' = case synchronizedClk tcm ty of - Just clk -> Right (e',clk) - _ -> Left e' - -mkPrimitive :: Bool -- ^ Put BlackBox expression in parenthesis - -> Bool -- ^ Treat BlackBox expression as declaration - -> (Either Identifier Id) -- ^ Id to assign the result to - -> TextS.Text - -> [Either Term Type] - -> Type - -> NetlistMonad (Expr,[Declaration]) -mkPrimitive bbEParen bbEasD dst nm args ty = do - bbM <- HashMap.lookup nm <$> Lens.use primitives - case bbM of - Just p@(P.BlackBox {}) -> do - case template p of - (Left tempD) -> do - let pNm = name p - (dst',dstNm,dstDecl) <- resBndr True dst - (bbCtx,ctxDcls) <- mkBlackBoxContext dst' (lefts args) - bbDecl <- N.BlackBoxD pNm (library p) (imports p) (qsysInclude p) <$> prepareBlackBox pNm tempD bbCtx <*> pure bbCtx - return (Identifier dstNm Nothing,dstDecl ++ ctxDcls ++ [bbDecl]) - (Right tempE) -> do - let pNm = name p - if bbEasD - then do - (dst',dstNm,dstDecl) <- resBndr True dst - (bbCtx,ctxDcls) <- mkBlackBoxContext dst' (lefts args) - bbTempl <- prepareBlackBox pNm tempE bbCtx - let tmpAssgn = Assignment dstNm (BlackBoxE pNm (library p) (imports p) (qsysInclude p) bbTempl bbCtx bbEParen) - return (Identifier dstNm Nothing, dstDecl ++ ctxDcls ++ [tmpAssgn]) - else do - (dst',_,_) <- resBndr False dst - (bbCtx,ctxDcls) <- mkBlackBoxContext dst' (lefts args) - bbTempl <- prepareBlackBox pNm tempE bbCtx - return (BlackBoxE pNm (library p) (imports p) (qsysInclude p) bbTempl bbCtx bbEParen,ctxDcls) - Just (P.Primitive pNm _) - | pNm == "GHC.Prim.tagToEnum#" -> do - hwTy <- N.unsafeCoreTypeToHWTypeM $(curLoc) ty - case args of - [Right (ConstTy (TyCon tcN)), Left (C.Literal (IntLiteral i))] -> do - tcm <- Lens.use tcCache - let dcs = tyConDataCons (tcm HashMap.! tcN) - dc = dcs !! fromInteger i - (exprN,dcDecls) <- mkDcApplication hwTy dst dc [] - return (exprN,dcDecls) - [Right _, Left scrut] -> do - tcm <- Lens.use tcCache - scrutTy <- termType tcm scrut - (scrutExpr,scrutDecls) <- mkExpr False (Left "tte_rhs") scrutTy scrut - case scrutExpr of - Identifier id_ Nothing -> return (DataTag hwTy (Left id_),scrutDecls) - _ -> do - scrutHTy <- unsafeCoreTypeToHWTypeM $(curLoc) scrutTy - tmpRhs <- mkUniqueIdentifier (pack "tte_rhs") - let netDeclRhs = NetDecl tmpRhs scrutHTy - netAssignRhs = Assignment tmpRhs scrutExpr - return (DataTag hwTy (Left tmpRhs),[netDeclRhs,netAssignRhs] ++ scrutDecls) - _ -> error $ $(curLoc) ++ "tagToEnum: " ++ show (map (either showDoc showDoc) args) - | pNm == "GHC.Prim.dataToTag#" -> case args of - [Right _,Left (Data dc)] -> do - iw <- Lens.use intWidth - return (N.Literal (Just (Signed iw,iw)) (NumLit $ toInteger $ dcTag dc - 1),[]) - [Right _,Left scrut] -> do - tcm <- Lens.use tcCache - scrutTy <- termType tcm scrut - scrutHTy <- unsafeCoreTypeToHWTypeM $(curLoc) scrutTy - (scrutExpr,scrutDecls) <- mkExpr False (Left "dtt_rhs") scrutTy scrut - case scrutExpr of - Identifier id_ Nothing -> return (DataTag scrutHTy (Right id_),scrutDecls) - _ -> do - tmpRhs <- mkUniqueIdentifier "dtt_rhs" - let netDeclRhs = NetDecl tmpRhs scrutHTy - netAssignRhs = Assignment tmpRhs scrutExpr - return (DataTag scrutHTy (Right tmpRhs),[netDeclRhs,netAssignRhs] ++ scrutDecls) - _ -> error $ $(curLoc) ++ "dataToTag: " ++ show (map (either showDoc showDoc) args) - | otherwise -> return (BlackBoxE "" [] [] Nothing [C $ mconcat ["NO_TRANSLATION_FOR:",fromStrict pNm]] emptyBBContext False,[]) - _ -> do - (_,sp) <- Lens.use curCompNm - throw (CLaSHException sp ($(curLoc) ++ "No blackbox found for: " ++ unpack nm) Nothing) - where - resBndr :: Bool -> (Either Identifier Id) -> NetlistMonad (Id,Identifier,[Declaration]) - resBndr mkDec dst' = case dst' of - Left dstL -> case mkDec of - False -> do - let nm' = Text.unpack dstL - id_ = Id (string2Name nm') (embed ty) - return (id_,dstL,[]) - True -> do - let nm' = append dstL "_app_arg" - nm'' <- mkUniqueIdentifier nm' - hwTy <- N.unsafeCoreTypeToHWTypeM $(curLoc) ty - let id_ = Id (string2Name (Text.unpack nm'')) (embed ty) - idDecl = NetDecl nm'' hwTy - return (id_,nm'',[idDecl]) - Right dstR -> return (dstR,Text.pack . name2String . varName $ dstR,[]) - --- | Create an template instantiation text and a partial blackbox content for an --- argument term, given that the term is a function. Errors if the term is not --- a function -mkFunInput :: Id -- ^ Identifier binding the encompassing primitive/blackbox application - -> Term -- ^ The function argument term - -> NetlistMonad ((Either BlackBoxTemplate Declaration,BlackBoxContext),[Declaration]) -mkFunInput resId e = do - let (appE,args) = collectArgs e - (bbCtx,dcls) <- mkBlackBoxContext resId (lefts args) - templ <- case appE of - Prim nm _ -> do - bbM <- fmap (HashMap.lookup nm) $ Lens.use primitives - (_,sp) <- Lens.use curCompNm - let templ = case bbM of - Just p@(P.BlackBox {}) -> Left (name p, template p) - _ -> throw (CLaSHException sp ($(curLoc) ++ "No blackbox found for: " ++ unpack nm) Nothing) - return templ - Data dc -> do - tcm <- Lens.use tcCache - eTy <- termType tcm e - let (_,resTy) = splitFunTys tcm eTy - resHTyM <- coreTypeToHWTypeM resTy - case resHTyM of - Just resHTy@(SP _ dcArgPairs) -> do - let dcI = dcTag dc - 1 - dcArgs = snd $ indexNote ($(curLoc) ++ "No DC with tag: " ++ show dcI) dcArgPairs dcI - dcInps = [ Identifier (pack ("~ARG[" ++ show x ++ "]")) Nothing | x <- [(0::Int)..(length dcArgs - 1)]] - dcApp = DataCon resHTy (DC (resHTy,dcI)) dcInps - dcAss = Assignment (pack "~RESULT") dcApp - return (Right dcAss) - Just resHTy@(Product _ dcArgs) -> do - let dcInps = [ Identifier (pack ("~ARG[" ++ show x ++ "]")) Nothing | x <- [(0::Int)..(length dcArgs - 1)]] - dcApp = DataCon resHTy (DC (resHTy,0)) dcInps - dcAss = Assignment (pack "~RESULT") dcApp - return (Right dcAss) - Just resHTy@(Vector _ _) -> do - let dcInps = [ Identifier (pack ("~ARG[" ++ show x ++ "]")) Nothing | x <- [(1::Int)..2] ] - dcApp = DataCon resHTy (DC (resHTy,1)) dcInps - dcAss = Assignment (pack "~RESULT") dcApp - return (Right dcAss) - _ -> error $ $(curLoc) ++ "Cannot make function input for: " ++ showDoc e - Var _ fun -> do - normalized <- Lens.use bindings - case HashMap.lookup fun normalized of - Just _ -> do - (_,Component compName hidden compInps [compOutp] _) <- preserveVarEnv $ genComponent fun Nothing - let hiddenAssigns = map (\(i,t) -> (i,In,t,Identifier i Nothing)) hidden - inpAssigns = zipWith (\(i,t) e' -> (i,In,t,e')) compInps [ Identifier (pack ("~ARG[" ++ show x ++ "]")) Nothing | x <- [(0::Int)..] ] - outpAssign = (fst compOutp,Out,snd compOutp,Identifier (pack "~RESULT") Nothing) - i <- varCount <<%= (+1) - let instLabel = Text.concat [compName,pack ("_" ++ show i)] - instDecl = InstDecl compName instLabel (outpAssign:hiddenAssigns ++ inpAssigns) - return (Right instDecl) - Nothing -> error $ $(curLoc) ++ "Cannot make function input for: " ++ showDoc e - _ -> error $ $(curLoc) ++ "Cannot make function input for: " ++ showDoc e - case templ of - Left (_, Left templ') -> do - l <- instantiateCompName templ' - l' <- setSym l - l'' <- setClocks bbCtx l' - l3 <- collectFilePaths bbCtx l'' - return ((Left l3,bbCtx),dcls) - Left (_, Right templ') -> do - templ'' <- prettyBlackBox templ' - let ass = Assignment (pack "~RESULT") (Identifier templ'' Nothing) - return ((Right ass, bbCtx),dcls) - Right decl -> - return ((Right decl,bbCtx),dcls) - --- | Instantiate symbols references with a new symbol and increment symbol counter ---instantiateSym :: BlackBoxTemplate --- -> NetlistMonad BlackBoxTemplate ---instantiateSym l = do --- i <- Lens.use varCount --- ids <- Lens.use seenIds --- let (l',(ids',i')) = setSym ids i l --- varCount .= i' --- seenIds .= ids' --- return l' - -instantiateCompName :: BlackBoxTemplate - -> NetlistMonad BlackBoxTemplate -instantiateCompName l = do - (nm,_) <- Lens.use curCompNm - return (setCompName nm l) - -collectFilePaths :: BlackBoxContext - -> BlackBoxTemplate - -> NetlistMonad BlackBoxTemplate -collectFilePaths bbCtx l = do - fs <- Lens.use dataFiles - let (fs',l') = findAndSetDataFiles bbCtx fs l - dataFiles .= fs' - return l' diff --git a/src/CLaSH/Netlist/BlackBox/Parser.hs b/src/CLaSH/Netlist/BlackBox/Parser.hs deleted file mode 100644 --- a/src/CLaSH/Netlist/BlackBox/Parser.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Parser definitions for BlackBox templates --} - -module CLaSH.Netlist.BlackBox.Parser - (runParse) -where - -import Data.Text.Lazy (Text, pack) -import qualified Data.Text.Lazy as Text -import Text.ParserCombinators.UU -import Text.ParserCombinators.UU.BasicInstances hiding (Parser) -import qualified Text.ParserCombinators.UU.Core as PCC (parse) -import Text.ParserCombinators.UU.Utils hiding (pBrackets) - -import CLaSH.Netlist.BlackBox.Types - -type Parser a = P (Str Char Text LineColPos) a - - --- | Parse a text as a BlackBoxTemplate, returns a list of errors in case --- parsing fails -runParse :: Text -> (BlackBoxTemplate, [Error LineColPos]) -runParse = PCC.parse ((,) <$> pBlackBoxD <*> pEnd) - . createStr (LineColPos 0 0 0) - --- | Parse a BlackBoxTemplate (Declarations and Expressions) -pBlackBoxD :: Parser BlackBoxTemplate -pBlackBoxD = pSome pElement - --- | Parse a single Template Element -pElement :: Parser Element -pElement = pTagD - <|> C <$> pText - <|> C <$> (pack <$> pToken "~ ") - --- | Parse the Text part of a Template -pText :: Parser Text -pText = pack <$> pList1 (pRange ('\000','\125')) - --- | Parse a Declaration or Expression element -pTagD :: Parser Element -pTagD = IF <$> (pTokenWS "~IF" *> pTagE) - <*> (pSpaces *> (pToken "~THEN" *> pBlackBoxD)) - <*> (pToken "~ELSE" *> pBlackBoxD <* pToken "~FI") - <|> D <$> pDecl - <|> pTagE - --- | Parse a Declaration -pDecl :: Parser Decl -pDecl = Decl <$> (pTokenWS "~INST" *> pNatural) <*> - ((:) <$> pOutput <*> pList pInput) <* pToken "~INST" - --- | Parse the output tag of Declaration -pOutput :: Parser (BlackBoxTemplate,BlackBoxTemplate) -pOutput = pTokenWS "~OUTPUT" *> pTokenWS "<=" *> ((,) <$> (pBlackBoxE <* pTokenWS "~") <*> pBlackBoxE) <* pTokenWS "~" - --- | Parse the input tag of Declaration -pInput :: Parser (BlackBoxTemplate,BlackBoxTemplate) -pInput = pTokenWS "~INPUT" *> pTokenWS "<=" *> ((,) <$> (pBlackBoxE <* pTokenWS "~") <*> pBlackBoxE) <* pTokenWS "~" - --- | Parse an Expression element -pTagE :: Parser Element -pTagE = O <$ pToken "~RESULT" - <|> I <$> (pToken "~ARG" *> pBrackets pNatural) - <|> L <$> (pToken "~LIT" *> pBrackets pNatural) - <|> (Clk . Just) <$> (pToken "~CLK" *> pBrackets pNatural) - <|> Clk Nothing <$ pToken "~CLKO" - <|> (Rst . Just) <$> (pToken "~RST" *> pBrackets pNatural) - <|> Rst Nothing <$ pToken "~RSTO" - <|> (Sym Text.empty) <$> (pToken "~SYM" *> pBrackets pNatural) - <|> Typ Nothing <$ pToken "~TYPO" - <|> (Typ . Just) <$> (pToken "~TYP" *> pBrackets pNatural) - <|> TypM Nothing <$ pToken "~TYPMO" - <|> (TypM . Just) <$> (pToken "~TYPM" *> pBrackets pNatural) - <|> Err Nothing <$ pToken "~ERRORO" - <|> (Err . Just) <$> (pToken "~ERROR" *> pBrackets pNatural) - <|> TypElem <$> (pToken "~TYPEL" *> pBrackets pTagE) - <|> IndexType <$> (pToken "~INDEXTYPE" *> pBrackets pTagE) - <|> CompName <$ pToken "~COMPNAME" - <|> QSysIncludeName <$ pToken "~QSYSINCLUDENAME" - <|> Size <$> (pToken "~SIZE" *> pBrackets pTagE) - <|> Length <$> (pToken "~LENGTH" *> pBrackets pTagE) - <|> Depth <$> (pToken "~DEPTH" *> pBrackets pTagE) - <|> FilePath <$> (pToken "~FILE" *> pBrackets pTagE) - <|> Gen <$> (True <$ pToken "~GENERATE") - <|> Gen <$> (False <$ pToken "~ENDGENERATE") - <|> SigD <$> (pToken "~SIGD" *> pBrackets pSigD) <*> (Just <$> (pBrackets pNatural)) - <|> (`SigD` Nothing) <$> (pToken "~SIGDO" *> pBrackets pSigD) - <|> IW64 <$ pToken "~IW64" - <|> (HdlSyn Vivado) <$ pToken "~VIVADO" - <|> (HdlSyn Other) <$ pToken "~OTHERSYN" - <|> (BV True) <$> (pToken "~TOBV" *> pBrackets pSigD) <*> pBrackets pTagE - <|> (BV False) <$> (pToken "~FROMBV" *> pBrackets pSigD) <*> pBrackets pTagE - <|> IsLit <$> (pToken "~ISLIT" *> pBrackets pNatural) - <|> IsVar <$> (pToken "~ISVAR" *> pBrackets pNatural) - <|> GenSym <$> (pToken "~GENSYM" *> pBrackets pSigD) <*> pBrackets pNatural - <|> And <$> (pToken "~AND" *> listParser pTagE) - <|> Vars <$> (pToken "~VARS" *> pBrackets pNatural) - - --- | Parse a bracketed text -pBrackets :: Parser a -> Parser a -pBrackets p = pSym '[' *> p <* pSym ']' - --- | Parse a token and eat trailing whitespace -pTokenWS :: String -> Parser String -pTokenWS keyw = pToken keyw <* pSpaces - --- | Parse the expression part of Blackbox Templates -pBlackBoxE :: Parser BlackBoxTemplate -pBlackBoxE = pSome pElemE - --- | Parse an Expression or Text -pElemE :: Parser Element -pElemE = pTagE - <|> C <$> pText - --- | Parse SigD -pSigD :: Parser [Element] -pSigD = pSome (pTagE <|> (C (pack "[") <$ (pack <$> pToken "[\\")) - <|> (C (pack "]") <$ (pack <$> pToken "\\]")) - <|> (C <$> (pack <$> pList1 (pRange ('\000','\90')))) - <|> (C <$> (pack <$> pList1 (pRange ('\94','\125'))))) diff --git a/src/CLaSH/Netlist/BlackBox/Types.hs b/src/CLaSH/Netlist/BlackBox/Types.hs deleted file mode 100644 --- a/src/CLaSH/Netlist/BlackBox/Types.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Types used in BlackBox modules --} - -module CLaSH.Netlist.BlackBox.Types where - -import Data.Text.Lazy (Text) - --- | A BlackBox Template is a List of Elements -type BlackBoxTemplate = [Element] - --- | Elements of a blackbox context -data Element = C !Text -- ^ Constant - | D !Decl -- ^ Component instantiation hole - | O -- ^ Output hole - | I !Int -- ^ Input hole - | L !Int -- ^ Literal hole - | Sym !Text !Int -- ^ Symbol hole - | Clk !(Maybe Int) -- ^ Clock hole (Maybe clk corresponding to - -- input, clk corresponding to output if Nothing) - | Rst !(Maybe Int) -- ^ Reset hole - | Typ !(Maybe Int) -- ^ Type declaration hole - | TypM !(Maybe Int) -- ^ Type root hole - | Err !(Maybe Int) -- ^ Error value hole - | TypElem !Element -- ^ Select element type from a vector type - | CompName -- ^ Hole for the name of the component in which - -- the blackbox is instantiated - | QSysIncludeName - | IndexType !Element -- ^ Index data type hole, the field is the - -- (exclusive) maximum index - | Size !Element -- ^ Size of a type hole - | Length !Element -- ^ Length of a vector hole - | Depth !Element -- ^ Depth of a tree hole - | FilePath !Element -- ^ Hole containing a filepath for a data file - | Gen !Bool -- ^ Hole marking beginning (True) or end (False) - -- of a generative construct - | IF !Element [Element] [Element] - | And [Element] - | IW64 -- ^ Hole indicating whether Int/Word/Integer - -- are 64-Bit - | HdlSyn HdlSyn -- ^ Hole indicating which synthesis tool we're - -- generating HDL for - | BV !Bool [Element] !Element -- ^ Convert to (True)/from(False) a bit-vector - | IsLit !Int - | IsVar !Int - | Vars !Int - | GenSym [Element] !Int - | SigD [Element] !(Maybe Int) - deriving Show - --- | Component instantiation hole. First argument indicates which function argument --- to instantiate. Second argument corresponds to output and input assignments, --- where the first element is the output assignment, and the subsequent elements --- are the consecutive input assignments. --- --- The LHS of the tuple is the name of the signal, while the RHS of the tuple --- is the type of the signal -data Decl = Decl !Int [(BlackBoxTemplate,BlackBoxTemplate)] - deriving Show - -data HdlSyn = Vivado | Other - deriving (Eq,Show,Read) diff --git a/src/CLaSH/Netlist/BlackBox/Util.hs b/src/CLaSH/Netlist/BlackBox/Util.hs deleted file mode 100644 --- a/src/CLaSH/Netlist/BlackBox/Util.hs +++ /dev/null @@ -1,507 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Utilties to verify blackbox contexts against templates and rendering filled - in templates --} - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} - -module CLaSH.Netlist.BlackBox.Util where - ---import Control.Lens (at, use, (%=), (+=), _1, --- _2) -import Control.Exception (throw) -import Control.Monad.State (State, StateT, evalStateT, - lift, modify, get) -import Control.Monad.Writer.Strict (MonadWriter, tell) -import Data.Bool (bool) -import Data.Foldable (foldrM) -import qualified Data.IntMap as IntMap -import Data.List (mapAccumL, nub) -import Data.Set (Set,singleton) -import Data.Text.Lazy (Text) -import qualified Data.Text.Lazy as Text -import System.FilePath (replaceBaseName, - takeBaseName, - takeFileName) -import Text.PrettyPrint.Leijen.Text.Monadic (displayT, renderCompact, - renderOneLine, brackets, - int, (<>), text, (<+>), - vcat, (<$$>), nest) -import qualified Text.PrettyPrint.Leijen.Text.Monadic as PP - -import CLaSH.Backend (Backend (..)) -import CLaSH.Driver.Types (CLaSHException (..)) -import CLaSH.Netlist.BlackBox.Parser -import CLaSH.Netlist.BlackBox.Types -import CLaSH.Netlist.Types (HWType (..), Identifier, - BlackBoxContext (..), - SyncExpr, Expr (..), - Literal (..), NetlistMonad, - Modifier (..)) -import qualified CLaSH.Netlist.Types as N -import CLaSH.Netlist.Util (mkUniqueIdentifier,typeSize) -import CLaSH.Util - --- | Determine if the number of normal/literal/function inputs of a blackbox --- context at least matches the number of argument that is expected by the --- template. -verifyBlackBoxContext :: BlackBoxContext -- ^ Blackbox to verify - -> BlackBoxTemplate -- ^ Template to check against - -> Bool -verifyBlackBoxContext bbCtx = all verify' - where - verify' (I n) = n < length (bbInputs bbCtx) - verify' (L n) = case indexMaybe (bbInputs bbCtx) n of - Just (_,_,b) -> b - _ -> False - verify' (Clk (Just n)) = n < length (bbInputs bbCtx) - verify' (Rst (Just n)) = n < length (bbInputs bbCtx) - verify' (Typ (Just n)) = n < length (bbInputs bbCtx) - verify' (TypM (Just n)) = n < length (bbInputs bbCtx) - verify' (Err (Just n)) = n < length (bbInputs bbCtx) - verify' (D (Decl n l')) = case IntMap.lookup n (bbFunctions bbCtx) of - Just _ -> all (\(x,y) -> verifyBlackBoxContext bbCtx x && - verifyBlackBoxContext bbCtx y) l' - _ -> False - verify' _ = True - -extractLiterals :: BlackBoxContext - -> [Expr] -extractLiterals = map (\case (e,_,_) -> either id fst e) - . filter (\case (_,_,b) -> b) - . bbInputs - --- | Update all the symbol references in a template, and increment the symbol --- counter for every newly encountered symbol. -setSym :: BlackBoxTemplate - -> NetlistMonad BlackBoxTemplate ---setSym l = second fst --- $ runState (setSym' l) ((ids,i),IntMap.empty) -setSym l = evalStateT (mapM setSym' l) IntMap.empty - where - setSym' :: Element - -> StateT (IntMap.IntMap Identifier) - NetlistMonad - Element - setSym' e = case e of - Sym _ i -> do - symM <- IntMap.lookup i <$> get - case symM of - Nothing -> do - t <- lift (mkUniqueIdentifier (Text.pack "n")) - modify (IntMap.insert i t) - return (Sym t i) - Just t -> return (Sym t i) - GenSym t i -> do - symM <- IntMap.lookup i <$> get - case symM of - Nothing -> do - t' <- lift (mkUniqueIdentifier (concatT t)) - modify (IntMap.insert i t') - return (GenSym [C t'] i) - Just _ -> error ("Symbol #" ++ show (t,i) ++ " is already defined") - D (Decl n l') -> D <$> (Decl n <$> mapM (combineM (mapM setSym') (mapM setSym')) l') - IF c t f -> IF <$> pure c <*> mapM setSym' t <*> mapM setSym' f - SigD e' m -> SigD <$> (mapM setSym' e') <*> pure m - BV t e' m -> BV <$> pure t <*> mapM setSym' e' <*> pure m - _ -> pure e - - concatT :: [Element] -> Text - concatT = Text.concat - . map (\case {C t -> t; _ -> error "unexpected element in GENSYM"}) - -setCompName :: Identifier -> BlackBoxTemplate -> BlackBoxTemplate -setCompName nm = map setCompName' - where - setCompName' CompName = C nm - setCompName' (D (Decl n l)) = D (Decl n (map (setCompName nm *** setCompName nm) l)) - setCompName' (IF c t f) = IF c (setCompName nm t) (setCompName nm f) - setCompName' (GenSym es i) = GenSym (setCompName nm es) i - setCompName' (BV t e m) = BV t (setCompName nm e) (setCompName' m) - setCompName' e = e - -setClocks :: MonadWriter (Set (Identifier,HWType)) m - => BlackBoxContext - -> BlackBoxTemplate - -> m BlackBoxTemplate -setClocks bc bt = mapM setClocks' bt - where - setClocks' (D (Decl n l)) = D <$> (Decl n <$> mapM (combineM (setClocks bc) (setClocks bc)) l) - setClocks' (IF c t f) = IF <$> pure c <*> setClocks bc t <*> setClocks bc f - setClocks' (SigD e m) = SigD <$> (setClocks bc e) <*> pure m - setClocks' (BV t e m) = BV <$> pure t <*> setClocks bc e <*> pure m - - setClocks' (Clk Nothing) = let (clk,rate) = clkSyncId $ fst $ bbResult bc - clkName = Text.append clk (Text.pack (show rate)) - in tell (singleton (clkName,Clock clk rate)) >> return (C clkName) - setClocks' (Clk (Just n)) = let (e,_,_) = bbInputs bc !! n - (clk,rate) = clkSyncId e - clkName = Text.append clk (Text.pack (show rate)) - in tell (singleton (clkName,Clock clk rate)) >> return (C clkName) - - setClocks' (Rst Nothing) = let (rst,rate) = clkSyncId $ fst $ bbResult bc - rstName = Text.concat [rst,Text.pack (show rate),"_rstn"] - in tell (singleton (rstName,Reset rst rate)) >> return (C rstName) - setClocks' (Rst (Just n)) = let (e,_,_) = bbInputs bc !! n - (rst,rate) = clkSyncId e - rstName = Text.concat [rst,Text.pack (show rate),"_rstn"] - in tell (singleton (rstName,Reset rst rate)) >> return (C rstName) - - setClocks' e = return e - -findAndSetDataFiles :: BlackBoxContext -> [(String,FilePath)] -> BlackBoxTemplate -> ([(String,FilePath)],BlackBoxTemplate) -findAndSetDataFiles bbCtx fs = mapAccumL findAndSet fs - where - findAndSet fs' (FilePath e) = case e of - (L n) -> - let (s,_,_) = bbInputs bbCtx !! n - e' = either id fst s - in case e' of - BlackBoxE "GHC.CString.unpackCString#" _ _ _ _ bbCtx' _ -> case bbInputs bbCtx' of - [(Left (Literal Nothing (StringLit s')),_,_)] -> renderFilePath fs s' - _ -> (fs',FilePath e) - Literal Nothing (StringLit s') -> renderFilePath fs s' - _ -> (fs',FilePath e) - _ -> (fs',FilePath e) - findAndSet fs' l = (fs',l) - -renderFilePath :: [(String,FilePath)] -> String -> ([(String,FilePath)],Element) -renderFilePath fs f = ((f'',f):fs,C (Text.pack $ show f'')) - where - f' = takeFileName f - f'' = selectNewName (map fst fs) f' - - selectNewName as a - | elem a as = selectNewName as (replaceBaseName a (takeBaseName a ++ "_")) - | otherwise = a - - --- | Get the name of the clock of an identifier -clkSyncId :: SyncExpr -> (Identifier,Integer) -clkSyncId (Right (_,clk)) = clk -clkSyncId (Left i) = error $ $(curLoc) ++ "No clock for: " ++ show i - --- | Render a blackbox given a certain context. Returns a filled out template --- and a list of 'hidden' inputs that must be added to the encompassing component. -renderBlackBox :: Backend backend - => BlackBoxTemplate -- ^ Blackbox template - -> BlackBoxContext -- ^ Context used to fill in the hole - -> State backend Text -renderBlackBox l bbCtx - = fmap Text.concat - $ mapM (renderElem bbCtx) l - --- | Render a single template element -renderElem :: Backend backend - => BlackBoxContext - -> Element - -> State backend Text -renderElem b (D (Decl n (l:ls))) = do - (o,oTy,_) <- syncIdToSyncExpr <$> combineM (lineToIdentifier b) (return . lineToType b) l - is <- mapM (fmap syncIdToSyncExpr . combineM (lineToIdentifier b) (return . lineToType b)) ls - let Just (templ,pCtx) = IntMap.lookup n (bbFunctions b) - b' = pCtx { bbResult = (o,oTy), bbInputs = bbInputs pCtx ++ is } - templ' <- case templ of - Left t -> return t - Right d -> do Just inst' <- inst d - return . parseFail . displayT $ renderCompact inst' - if verifyBlackBoxContext b' templ' - then Text.concat <$> mapM (renderElem b') templ' - else do - sp <- getSrcSpan - throw (CLaSHException sp ($(curLoc) ++ "\nCan't match context:\n" ++ show b' ++ "\nwith template:\n" ++ show templ) Nothing) - -renderElem b (SigD e m) = do - e' <- Text.concat <$> mapM (renderElem b) e - let ty = case m of - Nothing -> snd $ bbResult b - Just n -> let (_,ty',_) = bbInputs b !! n - in ty' - t <- hdlSig e' ty - return (displayT $ renderOneLine t) - -renderElem b (IF c t f) = do - iw <- iwWidth - syn <- hdlSyn - let c' = check iw syn c - if c' > 0 then renderBlackBox t b else renderBlackBox f b - where - check iw syn c' = case c' of - (Size e) -> typeSize (lineToType b [e]) - (Length e) -> case lineToType b [e] of - (Vector n _) -> n - _ -> error $ $(curLoc) ++ "IF: veclen of a non-vector type" - (L n) -> case bbInputs b !! n of - (l,_,_) - | Literal _ l' <- either id fst l -> - case l' of - NumLit i -> fromInteger i - BitLit bl -> case bl of - N.H -> 1 - N.L -> 0 - _ -> error $ $(curLoc) ++ "IF: LIT bit literal must be high or low" - BoolLit bl -> bool 0 1 bl - _ -> error $ $(curLoc) ++ "IF: LIT must be a numeric lit" - | DataCon (Signed _) _ [Literal _ (NumLit i)] <- either id fst l - -> fromInteger i - k -> error $ $(curLoc) ++ ("IF: LIT must be a numeric lit:" ++ show k) - (Depth e) -> case lineToType b [e] of - (RTree n _) -> n - _ -> error $ $(curLoc) ++ "IF: treedepth of non-tree type" - IW64 -> if iw == 64 then 1 else 0 - (HdlSyn s) -> if s == syn then 1 else 0 - (IsVar n) -> let (s,_,_) = bbInputs b !! n - e = either id fst s - in case e of - Identifier _ Nothing -> 1 - _ -> 0 - (IsLit n) -> let (s,_,_) = bbInputs b !! n - e = either id fst s - in case e of - DataCon {} -> 1 - Literal {} -> 1 - BlackBoxE {} -> 1 - _ -> 0 - (And es) -> if all (==1) (map (check iw syn) es) - then 1 - else 0 - _ -> error $ $(curLoc) ++ "IF: condition must be: SIZE, LENGTH, IW64, LIT, ISLIT, or ISARG" - -renderElem b e = renderTag b e - -parseFail :: Text -> BlackBoxTemplate -parseFail t = case runParse t of - (templ,err) | null err -> templ - | otherwise -> error $ $(curLoc) ++ "\nTemplate:\n" ++ show t ++ "\nHas errors:\n" ++ show err - -syncIdToSyncExpr :: (Text,HWType) - -> (SyncExpr,HWType,Bool) -syncIdToSyncExpr (t,ty) = (Left (Identifier t Nothing),ty,False) - --- | Fill out the template corresponding to an output/input assignment of a --- component instantiation, and turn it into a single identifier so it can --- be used for a new blackbox context. -lineToIdentifier :: Backend backend - => BlackBoxContext - -> BlackBoxTemplate - -> State backend Text -lineToIdentifier b = foldrM (\e a -> do - e' <- renderTag b e - return (e' `Text.append` a) - ) Text.empty - -lineToType :: BlackBoxContext - -> BlackBoxTemplate - -> HWType -lineToType b [(Typ Nothing)] = snd $ bbResult b -lineToType b [(Typ (Just n))] = let (_,ty,_) = bbInputs b !! n - in ty -lineToType b [(TypElem t)] = case lineToType b [t] of - Vector _ elTy -> elTy - _ -> error $ $(curLoc) ++ "Element type selection of a non-vector type" -lineToType b [(IndexType (L n))] = - case bbInputs b !! n of - (Left (Literal _ (NumLit n')),_,_) -> Index (fromInteger n') - x -> error $ $(curLoc) ++ "Index type not given a literal: " ++ show x - -lineToType _ _ = error $ $(curLoc) ++ "Unexpected type manipulation" - --- | Give a context and a tagged hole (of a template), returns part of the --- context that matches the tag of the hole. -renderTag :: Backend backend - => BlackBoxContext - -> Element - -> State backend Text -renderTag _ (C t) = return t -renderTag b O = fmap (displayT . renderOneLine) . expr False . either id fst . fst $ bbResult b -renderTag b (I n) = let (s,_,_) = bbInputs b !! n - e = either id fst s - in (displayT . renderOneLine) <$> expr False e -renderTag b (L n) = let (s,_,_) = bbInputs b !! n - e = either id fst s - in (displayT . renderOneLine) <$> expr False (mkLit e) - where - mkLit (Literal (Just (Signed _,_)) i) = Literal Nothing i - mkLit (DataCon _ (DC (Void, _)) [Literal (Just (Signed _,_)) i]) = Literal Nothing i - mkLit i = i - -renderTag _ (Sym t _) = return t - -renderTag b (BV True es e) = do - e' <- Text.concat <$> mapM (renderElem b) es - let ty = lineToType b [e] - (displayT . renderOneLine) <$> toBV ty e' -renderTag b (BV False es e) = do - e' <- Text.concat <$> mapM (renderElem b) es - let ty = lineToType b [e] - (displayT . renderOneLine) <$> fromBV ty e' - -renderTag b (Typ Nothing) = fmap (displayT . renderOneLine) . hdlType . snd $ bbResult b -renderTag b (Typ (Just n)) = let (_,ty,_) = bbInputs b !! n - in (displayT . renderOneLine) <$> hdlType ty -renderTag b (TypM Nothing) = fmap (displayT . renderOneLine) . hdlTypeMark . snd $ bbResult b -renderTag b (TypM (Just n)) = let (_,ty,_) = bbInputs b !! n - in (displayT . renderOneLine) <$> hdlTypeMark ty -renderTag b (Err Nothing) = fmap (displayT . renderOneLine) . hdlTypeErrValue . snd $ bbResult b -renderTag b (Err (Just n)) = let (_,ty,_) = bbInputs b !! n - in (displayT . renderOneLine) <$> hdlTypeErrValue ty -renderTag b (Size e) = return . Text.pack . show . typeSize $ lineToType b [e] -renderTag b (Length e) = return . Text.pack . show . vecLen $ lineToType b [e] - where - vecLen (Vector n _) = n - vecLen _ = error $ $(curLoc) ++ "vecLen of a non-vector type" -renderTag b (Depth e) = return . Text.pack . show . treeDepth $ lineToType b [e] - where - treeDepth (RTree n _) = n - treeDepth _ = error $ $(curLoc) ++ "treeDepth of a non-tree type" -renderTag b e@(TypElem _) = let ty = lineToType b [e] - in (displayT . renderOneLine) <$> hdlType ty -renderTag _ (Gen b) = displayT . renderOneLine <$> genStmt b -renderTag _ (GenSym [C t] _) = return t -renderTag b (Vars n) = - let (s,_,_) = bbInputs b !! n - e = either id fst s - - go (Identifier i _) = [i] - go (DataCon _ _ es) = concatMap go es - go (DataTag _ e') = [either id id e'] - go _ = [] - - vars = go e - in case vars of - [] -> return Text.empty - _ -> return (Text.concat $ map (Text.cons ',') vars) -renderTag b (IndexType (L n)) = - case bbInputs b !! n of - (Left (Literal _ (NumLit n')),_,_) -> - let hty = Index (fromInteger n') - in fmap (displayT . renderOneLine) (hdlType hty) - x -> error $ $(curLoc) ++ "Index type not given a literal: " ++ show x -renderTag b (FilePath e) = case e of - L n -> do - let (s,_,_) = bbInputs b !! n - e' = either id fst s - e2 <- prettyElem e - case e' of - BlackBoxE "GHC.CString.unpackCString#" _ _ _ _ bbCtx' _ -> case bbInputs bbCtx' of - [(Left (Literal Nothing (StringLit _)),_,_)] -> error $ $(curLoc) ++ "argument of ~FILEPATH:" ++ show e2 ++ "does not reduce to a string" - _ -> error $ $(curLoc) ++ "argument of ~FILEPATH:" ++ show e2 ++ "does not reduce to a string" - _ -> error $ $(curLoc) ++ "argument of ~FILEPATH:" ++ show e2 ++ "does not reduce to a string" - _ -> do e' <- prettyElem e - error $ $(curLoc) ++ "~FILEPATH expects a ~LIT[N] argument, but got: " ++ show e' -renderTag b QSysIncludeName = case bbQsysIncName b of - Just nm -> return nm - _ -> error $ $(curLoc) ++ "~QSYSINCLUDENAME used where no 'qysInclude' was specified in the primitive definition" -renderTag _ e = do e' <- prettyElem e - error $ $(curLoc) ++ "Unable to evaluate: " ++ show e' - -prettyBlackBox :: Monad m - => BlackBoxTemplate - -> m Text -prettyBlackBox bbT = Text.concat <$> mapM prettyElem bbT - -prettyElem :: Monad m - => Element - -> m Text -prettyElem (C t) = return t -prettyElem (D (Decl i args)) = do - args' <- mapM (\(a,b) -> (,) <$> prettyBlackBox a <*> prettyBlackBox b) args - (displayT . renderOneLine) <$> - (nest 2 (text "~INST" <+> int i <$$> - text "~OUTPUT" <+> text "=>" <+> text (fst (head args')) <+> text (snd (head args')) <+> text "~" <$$> - vcat (mapM (\(a,b) -> text "~INPUT" <+> text "=>" <+> text a <+> text b <+> text "~") (tail args'))) - PP.<$$> text "~INST") -prettyElem O = return "~RESULT" -prettyElem (I i) = (displayT . renderOneLine) <$> (text "~ARG" <> brackets (int i)) -prettyElem (L i) = (displayT . renderOneLine) <$> (text "~LIT" <> brackets (int i)) -prettyElem (Sym _ i) = (displayT . renderOneLine) <$> (text "~SYM" <> brackets (int i)) -prettyElem (Clk Nothing) = return "~CLKO" -prettyElem (Clk (Just i)) = (displayT . renderOneLine) <$> (text "~CLK" <> brackets (int i)) -prettyElem (Rst Nothing) = return "~RSTO" -prettyElem (Rst (Just i)) = (displayT . renderOneLine) <$> (text "~RSTO" <> brackets (int i)) -prettyElem (Typ Nothing) = return "~TYPO" -prettyElem (Typ (Just i)) = (displayT . renderOneLine) <$> (text "~TYP" <> brackets (int i)) -prettyElem (TypM Nothing) = return "~TYPMO" -prettyElem (TypM (Just i)) = (displayT . renderOneLine) <$> (text "~TYPM" <> brackets (int i)) -prettyElem (Err Nothing) = return "~ERRORO" -prettyElem (Err (Just i)) = (displayT . renderOneLine) <$> (text "~ERROR" <> brackets (int i)) -prettyElem (TypElem e) = do - e' <- prettyElem e - (displayT . renderOneLine) <$> (text "~TYPEL" <> brackets (text e')) -prettyElem CompName = return "~COMPNAME" -prettyElem QSysIncludeName = return "~QSYSINCLUDENAME" -prettyElem (IndexType e) = do - e' <- prettyElem e - (displayT . renderOneLine) <$> (text "~INDEXTYPE" <> brackets (text e')) -prettyElem (Size e) = do - e' <- prettyElem e - (displayT . renderOneLine) <$> (text "~SIZE" <> brackets (text e')) -prettyElem (Length e) = do - e' <- prettyElem e - (displayT . renderOneLine) <$> (text "~LENGTH" <> brackets (text e')) -prettyElem (Depth e) = do - e' <- prettyElem e - (displayT . renderOneLine) <$> (text "~DEPTH" <> brackets (text e')) -prettyElem (FilePath e) = do - e' <- prettyElem e - (displayT . renderOneLine) <$> (text "~FILE" <> brackets (text e')) -prettyElem (Gen b) = if b then return "~GENERATE" else return "~ENDGENERATE" -prettyElem (IF b esT esF) = do - b' <- prettyElem b - esT' <- prettyBlackBox esT - esF' <- prettyBlackBox esF - (displayT . renderCompact) <$> - (text "~IF" <+> text b' <+> text "~THEN" <> - text esT' <> - text "~ELSE" <> - text esF' <> - text "~FI") -prettyElem (And es) = - (displayT . renderCompact) <$> - (PP.brackets (PP.tupled $ mapM (text <=< prettyElem) es)) -prettyElem IW64 = return "~IW64" -prettyElem (HdlSyn s) = case s of - Vivado -> return "~VIVADO" - _ -> return "~OTHERSYN" -prettyElem (BV b es e) = do - es' <- prettyBlackBox es - e' <- prettyBlackBox [e] - (displayT . renderOneLine) <$> - if b - then text "~TOBV" <> brackets (text es') <> brackets (text e') - else text "~FROMBV" <> brackets (text es') <> brackets (text e') -prettyElem (IsLit i) = (displayT . renderOneLine) <$> (text "~ISLIT" <> brackets (int i)) -prettyElem (IsVar i) = (displayT . renderOneLine) <$> (text "~ISVAR" <> brackets (int i)) -prettyElem (GenSym es i) = do - es' <- prettyBlackBox es - (displayT . renderOneLine) <$> (text "~GENSYM" <> brackets (text es') <> brackets (int i)) -prettyElem (SigD es mI) = do - es' <- prettyBlackBox es - (displayT . renderOneLine) <$> - (maybe (text "~SIGDO" <> brackets (text es')) - (((text "~SIGD" <> brackets (text es')) <>) . int) - mI) -prettyElem (Vars i) = (displayT . renderOneLine) <$> (text "~VARS" <> brackets (int i)) - -usedArguments :: BlackBoxTemplate - -> [Int] -usedArguments = nub . concatMap go - where - go x = case x of - D (Decl i args) -> i : concatMap (\(a,b) -> usedArguments a ++ usedArguments b) args - I i -> [i] - L i -> [i] - IndexType e -> go e - FilePath e -> go e - IF b esT esF -> go b ++ usedArguments esT ++ usedArguments esF - SigD es _ -> usedArguments es - BV _ es _ -> usedArguments es - _ -> [] diff --git a/src/CLaSH/Netlist/Id.hs b/src/CLaSH/Netlist/Id.hs deleted file mode 100644 --- a/src/CLaSH/Netlist/Id.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Transform/format a Netlist Identifier so that it is acceptable as a HDL identifier --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} - -module CLaSH.Netlist.Id - ( mkBasicId' - , stripDollarPrefixes - ) -where - -#ifndef MIN_VERSION_text -#error MIN_VERSION_text undefined -#endif - -import Data.Char (isAsciiLower,isAsciiUpper,isDigit) -import Data.Text.Lazy as Text - -mkBasicId' :: Bool - -> Text - -> Text -mkBasicId' tupEncode = stripMultiscore . stripLeading . zEncode tupEncode - where - stripLeading = Text.dropWhile (`elem` ('_':['0'..'9'])) - stripMultiscore = Text.concat - . Prelude.map (\cs -> case Text.head cs of - '_' -> "_" - _ -> cs - ) - . Text.group - -stripDollarPrefixes :: Text -> Text -stripDollarPrefixes = stripWorkerPrefix . stripSpecPrefix . stripConPrefix - . stripWorkerPrefix . stripDictFunPrefix - where - stripDictFunPrefix t = case Text.stripPrefix "$f" t of - Just k -> takeWhileEnd (/= '_') k - Nothing -> t - -#if !MIN_VERSION_text(1,2,2) - takeWhileEnd p = Text.reverse . Text.takeWhile p . Text.reverse -#endif - - stripWorkerPrefix t = case Text.stripPrefix "$w" t of - Just k -> k - Nothing -> t - - stripConPrefix t = case Text.stripPrefix "$c" t of - Just k -> k - Nothing -> t - - stripSpecPrefix t = case Text.stripPrefix "$s" t of - Just k -> k - Nothing -> t -- snd (Text.breakOnEnd "$s" t) - - -type UserString = Text -- As the user typed it -type EncodedString = Text -- Encoded form - -zEncode :: Bool -> UserString -> EncodedString -zEncode False cs = go (uncons cs) - where - go Nothing = empty - go (Just (c,cs')) = append (encodeDigitCh c) (go' $ uncons cs') - go' Nothing = empty - go' (Just (c,cs')) = append (encodeCh c) (go' $ uncons cs') - -zEncode True cs = case maybeTuple cs of - Just (n,cs') -> append n (go' (uncons cs')) - Nothing -> go (uncons cs) - where - go Nothing = empty - go (Just (c,cs')) = append (encodeDigitCh c) (go' $ uncons cs') - go' Nothing = empty - go' (Just (c,cs')) = case maybeTuple (cons c cs') of - Just (n,cs2) -> append n (go' $ uncons cs2) - Nothing -> append (encodeCh c) (go' $ uncons cs') - -encodeDigitCh :: Char -> EncodedString -encodeDigitCh c | isDigit c = Text.empty -- encodeAsUnicodeChar c -encodeDigitCh c = encodeCh c - -encodeCh :: Char -> EncodedString -encodeCh c | unencodedChar c = singleton c -- Common case first - | otherwise = Text.empty - -unencodedChar :: Char -> Bool -- True for chars that don't need encoding -unencodedChar c = or [ isAsciiLower c - , isAsciiUpper c - , isDigit c - , c == '_'] - -maybeTuple :: UserString -> Maybe (EncodedString,UserString) -maybeTuple "(# #)" = Just ("Unit",empty) -maybeTuple "()" = Just ("Unit",empty) -maybeTuple (uncons -> Just ('(',uncons -> Just ('#',cs))) = - case countCommas 0 cs of - (n,uncons -> Just ('#',uncons -> Just (')',cs'))) -> Just (pack ("Tup" ++ show (n+1)),cs') - _ -> Nothing -maybeTuple (uncons -> Just ('(',cs)) = - case countCommas 0 cs of - (n,uncons -> Just (')',cs')) -> Just (pack ("Tup" ++ show (n+1)),cs') - _ -> Nothing -maybeTuple _ = Nothing - -countCommas :: Int -> UserString -> (Int,UserString) -countCommas n (uncons -> Just (',',cs)) = countCommas (n+1) cs -countCommas n cs = (n,cs) diff --git a/src/CLaSH/Netlist/Types.hs b/src/CLaSH/Netlist/Types.hs deleted file mode 100644 --- a/src/CLaSH/Netlist/Types.hs +++ /dev/null @@ -1,196 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Type and instance definitions for Netlist modules --} - -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} - -module CLaSH.Netlist.Types where - -import Control.DeepSeq -import Control.Monad.State.Strict (MonadIO, MonadState, StateT) -import Control.Monad.Writer.Strict (MonadWriter, WriterT) -import Data.Hashable -import Data.HashMap.Lazy (HashMap) -import Data.IntMap.Lazy (IntMap, empty) -import Data.Set (Set) -import qualified Data.Text as S -import Data.Text.Lazy (Text, pack) -import GHC.Generics (Generic) -import Unbound.Generics.LocallyNameless (Fresh, FreshMT) - -import SrcLoc (SrcSpan) - -import CLaSH.Core.Term (Term, TmName) -import CLaSH.Core.Type (Type) -import CLaSH.Core.TyCon (TyCon, TyConName) -import CLaSH.Core.Util (Gamma) -import CLaSH.Netlist.BlackBox.Types -import CLaSH.Primitives.Types (PrimMap) -import CLaSH.Util - --- | Monad that caches generated components (StateT) and remembers hidden inputs --- of components that are being generated (WriterT) -newtype NetlistMonad a = - NetlistMonad { runNetlist :: WriterT - (Set (Identifier,HWType)) - (StateT NetlistState (FreshMT IO)) - a - } - deriving (Functor, Monad, Applicative, MonadWriter (Set (Identifier,HWType)), - MonadState NetlistState, Fresh, MonadIO) - --- | State of the NetlistMonad -data NetlistState - = NetlistState - { _bindings :: HashMap TmName (Type,SrcSpan,Term) -- ^ Global binders - , _varEnv :: Gamma -- ^ Type environment/context - , _varCount :: !Int -- ^ Number of signal declarations - , _components :: HashMap TmName (SrcSpan,Component) -- ^ Cached components - , _primitives :: PrimMap BlackBoxTemplate -- ^ Primitive Definitions - , _typeTranslator :: HashMap TyConName TyCon -> Type -> Maybe (Either String HWType) -- ^ Hardcoded Type -> HWType translator - , _tcCache :: HashMap TyConName TyCon -- ^ TyCon cache - , _curCompNm :: !(Identifier,SrcSpan) - , _dataFiles :: [(String,FilePath)] - , _intWidth :: Int - , _mkBasicIdFn :: Identifier -> Identifier - , _seenIds :: [Identifier] - , _seenComps :: [Identifier] - , _componentNames :: HashMap TmName Identifier - } - --- | Signal reference -type Identifier = Text - --- | Component: base unit of a Netlist -data Component - = Component - { componentName :: !Identifier -- ^ Name of the component - , hiddenPorts :: [(Identifier,HWType)] -- ^ Ports that have no correspondence the original function definition - , inputs :: [(Identifier,HWType)] -- ^ Input ports - , outputs :: [(Identifier,HWType)] -- ^ Output ports - , declarations :: [Declaration] -- ^ Internal declarations - } - deriving Show - -instance NFData Component where - rnf c = case c of - Component nm hi inps outps decls -> rnf nm `seq` rnf hi `seq` rnf inps `seq` - rnf outps `seq` rnf decls - --- | Size indication of a type (e.g. bit-size or number of elements) -type Size = Int - --- | Representable hardware types -data HWType - = Void -- ^ Empty type - | String -- ^ String type - | Bool -- ^ Boolean type - | BitVector !Size -- ^ BitVector of a specified size - | Index !Integer -- ^ Unsigned integer with specified (exclusive) upper bounder - | Signed !Size -- ^ Signed integer of a specified size - | Unsigned !Size -- ^ Unsigned integer of a specified size - | Vector !Size !HWType -- ^ Vector type - | RTree !Size !HWType -- ^ RTree type - | Sum !Identifier [Identifier] -- ^ Sum type: Name and Constructor names - | Product !Identifier [HWType] -- ^ Product type: Name and field types - | SP !Identifier [(Identifier,[HWType])] -- ^ Sum-of-Product type: Name and Constructor names + field types - | Clock !Identifier !Integer -- ^ Clock type with specified name and period - | Reset !Identifier !Integer -- ^ Reset type corresponding to clock with a specified name and period - deriving (Eq,Ord,Show,Generic) - -instance Hashable HWType -instance NFData HWType - --- | Internals of a Component -data Declaration - = Assignment !Identifier !Expr - -- ^ Signal assignment: - -- - -- * Signal to assign - -- - -- * Assigned expression - | CondAssignment !Identifier !HWType !Expr !HWType [(Maybe Literal,Expr)] - -- ^ Conditional signal assignment: - -- - -- * Signal to assign - -- - -- * Type of the result/alternatives - -- - -- * Scrutinized expression - -- - -- * Type of the scrutinee - -- - -- * List of: (Maybe expression scrutinized expression is compared with,RHS of alternative) - | InstDecl !Identifier !Identifier [(Identifier,PortDirection,HWType,Expr)] -- ^ Instantiation of another component - | BlackBoxD !S.Text [S.Text] [S.Text] (Maybe (S.Text,BlackBoxTemplate)) !BlackBoxTemplate BlackBoxContext -- ^ Instantiation of blackbox declaration - | NetDecl !Identifier !HWType -- ^ Signal declaration - deriving Show - -data PortDirection = In | Out - deriving Show - -instance NFData Declaration where - rnf a = a `seq` () - --- | Expression Modifier -data Modifier - = Indexed (HWType,Int,Int) -- ^ Index the expression: (Type of expression,DataCon tag,Field Tag) - | DC (HWType,Int) -- ^ See expression in a DataCon context: (Type of the expression, DataCon tag) - | VecAppend -- ^ See the expression in the context of a Vector append operation - | RTreeAppend -- ^ See the expression in the context of a Tree append operation - deriving Show - --- | Expression used in RHS of a declaration -data Expr - = Literal !(Maybe (HWType,Size)) !Literal -- ^ Literal expression - | DataCon !HWType !Modifier [Expr] -- ^ DataCon application - | Identifier !Identifier !(Maybe Modifier) -- ^ Signal reference - | DataTag !HWType !(Either Identifier Identifier) -- ^ @Left e@: tagToEnum#, @Right e@: dataToTag# - | BlackBoxE !S.Text [S.Text] [S.Text] (Maybe (S.Text,BlackBoxTemplate)) !BlackBoxTemplate !BlackBoxContext !Bool -- ^ Instantiation of a BlackBox expression - deriving Show - --- | Literals used in an expression -data Literal - = NumLit !Integer -- ^ Number literal - | BitLit !Bit -- ^ Bit literal - | BoolLit !Bool -- ^ Boolean literal - | VecLit [Literal] -- ^ Vector literal - | StringLit !String -- ^ String literal - deriving (Eq,Show) - --- | Bit literal -data Bit - = H -- ^ High - | L -- ^ Low - | U -- ^ Undefined - | Z -- ^ High-impedance - deriving (Eq,Show) - --- | Context used to fill in the holes of a BlackBox template -data BlackBoxContext - = Context - { bbResult :: (SyncExpr,HWType) -- ^ Result name and type - , bbInputs :: [(SyncExpr,HWType,Bool)] -- ^ Argument names, types, and whether it is a literal - , bbFunctions :: IntMap (Either BlackBoxTemplate Declaration,BlackBoxContext) - -- ^ Function arguments (subset of inputs): - -- - -- * (Blackbox Template,Partial Blackbox Concext) - , bbQsysIncName :: Maybe Identifier - } - deriving Show - -emptyBBContext :: BlackBoxContext -emptyBBContext = Context (Left $ Identifier (pack "__EMPTY__") Nothing, Void) [] empty Nothing - --- | Either the name of the identifier, or a tuple of the identifier and the --- corresponding clock -type SyncIdentifier = Either Identifier (Identifier,(Identifier,Int)) -type SyncExpr = Either Expr (Expr,(Identifier,Integer)) - -makeLenses ''NetlistState diff --git a/src/CLaSH/Netlist/Util.hs b/src/CLaSH/Netlist/Util.hs deleted file mode 100644 --- a/src/CLaSH/Netlist/Util.hs +++ /dev/null @@ -1,366 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Utilities for converting Core Type/Term to Netlist datatypes --} - -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} - -module CLaSH.Netlist.Util where - -import Control.Error (hush) -import Control.Lens ((.=),(%=)) -import qualified Control.Lens as Lens -import qualified Control.Monad as Monad -import Control.Monad.Trans.Except (runExcept) -import Data.Either (partitionEithers) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.Maybe (catMaybes,fromMaybe) -import Data.Text.Lazy (append,pack,unpack) -import qualified Data.Text.Lazy as Text -import Unbound.Generics.LocallyNameless (Embed, Fresh, bind, embed, makeName, - name2Integer, name2String, unbind, - unembed, unrec) - -import CLaSH.Core.DataCon (DataCon (..)) -import CLaSH.Core.FreeVars (termFreeIds, typeFreeVars) -import CLaSH.Core.Pretty (showDoc) -import CLaSH.Core.Subst (substTys) -import CLaSH.Core.Term (LetBinding, Term (..), TmName) -import CLaSH.Core.TyCon (TyCon (..), TyConName, tyConDataCons) -import CLaSH.Core.Type (Type (..), TypeView (..), LitTy (..), - coreView, splitTyConAppM, tyView) -import CLaSH.Core.Util (collectBndrs, termType, tyNatSize) -import CLaSH.Core.Var (Id, Var (..), modifyVarName) -import CLaSH.Netlist.Types as HW -import CLaSH.Util - -mkBasicId :: Identifier -> NetlistMonad Identifier -mkBasicId n = do - f <- Lens.use mkBasicIdFn - let n' = f n - if Text.null n' - then return (pack "x") - else return n' - --- | Split a normalized term into: a list of arguments, a list of let-bindings, --- and a variable reference that is the body of the let-binding. Returns a --- String containing the error is the term was not in a normalized form. -splitNormalized :: Fresh m - => HashMap TyConName TyCon - -> Term - -> m (Either String ([Id],[LetBinding],Id)) -splitNormalized tcm expr = do - (args,letExpr) <- fmap (first partitionEithers) $ collectBndrs expr - case letExpr of - Letrec b - | (tmArgs,[]) <- args -> do - (xes,e) <- unbind b - case e of - Var t v -> return $! Right (tmArgs,unrec xes,Id v (embed t)) - _ -> return $! Left ($(curLoc) ++ "Not in normal form: res not simple var") - | otherwise -> return $! Left ($(curLoc) ++ "Not in normal form: tyArgs") - _ -> do - ty <- termType tcm expr - return $! Left ($(curLoc) ++ "Not in normal from: no Letrec:\n\n" ++ showDoc expr ++ "\n\nWhich has type:\n\n" ++ showDoc ty) - --- | Converts a Core type to a HWType given a function that translates certain --- builtin types. Errors if the Core type is not translatable. -unsafeCoreTypeToHWType :: String - -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) - -> HashMap TyConName TyCon - -> Type - -> HWType -unsafeCoreTypeToHWType loc builtInTranslation m = either (error . (loc ++)) id . coreTypeToHWType builtInTranslation m - --- | Converts a Core type to a HWType within the NetlistMonad; errors on failure -unsafeCoreTypeToHWTypeM :: String - -> Type - -> NetlistMonad HWType -unsafeCoreTypeToHWTypeM loc ty = unsafeCoreTypeToHWType loc <$> Lens.use typeTranslator <*> Lens.use tcCache <*> pure ty - --- | Converts a Core type to a HWType within the NetlistMonad; 'Nothing' on failure -coreTypeToHWTypeM :: Type - -> NetlistMonad (Maybe HWType) -coreTypeToHWTypeM ty = hush <$> (coreTypeToHWType <$> Lens.use typeTranslator <*> Lens.use tcCache <*> pure ty) - --- | Returns the name and period of the clock corresponding to a type -synchronizedClk :: HashMap TyConName TyCon -- ^ TyCon cache - -> Type - -> Maybe (Identifier,Integer) -synchronizedClk tcm ty - | not . null . Lens.toListOf typeFreeVars $ ty = Nothing - | Just (tyCon,args) <- splitTyConAppM ty - = case name2String tyCon of - "CLaSH.Sized.Vector.Vec" -> synchronizedClk tcm (args!!1) - "CLaSH.Signal.Internal.SClock" -> case splitTyConAppM (head args) of - Just (_,[LitTy (SymTy s),litTy]) - | Right i <- runExcept (tyNatSize tcm litTy) -> Just (pack s,i) - _ -> error $ $(curLoc) ++ "Clock period not a simple literal: " ++ showDoc ty - "CLaSH.Signal.Internal.Signal'" -> case splitTyConAppM (head args) of - Just (_,[LitTy (SymTy s),litTy]) - | Right i <- runExcept (tyNatSize tcm litTy) -> Just (pack s,i) - _ -> error $ $(curLoc) ++ "Clock period not a simple literal: " ++ showDoc ty - _ -> case tyConDataCons (tcm HashMap.! tyCon) of - [dc] -> let argTys = dcArgTys dc - argTVs = dcUnivTyVars dc - argSubts = zip argTVs args - args' = map (substTys argSubts) argTys - in case args' of - (arg:_) -> synchronizedClk tcm arg - _ -> Nothing - _ -> Nothing - | otherwise - = Nothing - --- | Converts a Core type to a HWType given a function that translates certain --- builtin types. Returns a string containing the error message when the Core --- type is not translatable. -coreTypeToHWType :: (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) - -> HashMap TyConName TyCon - -> Type - -> Either String HWType -coreTypeToHWType builtInTranslation m (builtInTranslation m -> Just hty) = hty -coreTypeToHWType builtInTranslation m (coreView m -> Just ty) = coreTypeToHWType builtInTranslation m ty -coreTypeToHWType builtInTranslation m ty@(tyView -> TyConApp tc args) = mkADT builtInTranslation m (showDoc ty) tc args -coreTypeToHWType _ _ ty = Left $ "Can't translate non-tycon type: " ++ showDoc ty - --- | Converts an algebraic Core type (split into a TyCon and its argument) to a HWType. -mkADT :: (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -- ^ Hardcoded Type -> HWType translator - -> HashMap TyConName TyCon -- ^ TyCon cache - -> String -- ^ String representation of the Core type for error messages - -> TyConName -- ^ The TyCon - -> [Type] -- ^ Its applied arguments - -> Either String HWType -mkADT _ m tyString tc _ - | isRecursiveTy m tc - = Left $ $(curLoc) ++ "Can't translate recursive type: " ++ tyString - -mkADT builtInTranslation m tyString tc args = case tyConDataCons (m HashMap.! tc) of - [] -> Left $ $(curLoc) ++ "Can't translate empty type: " ++ tyString - dcs -> do - let tcName = pack $ name2String tc - argTyss = map dcArgTys dcs - argTVss = map dcUnivTyVars dcs - argSubts = map (`zip` args) argTVss - substArgTyss = zipWith (\s tys -> map (substTys s) tys) argSubts argTyss - argHTyss <- mapM (mapM (coreTypeToHWType builtInTranslation m)) substArgTyss - case (dcs,argHTyss) of - (_:[],[[elemTy]]) -> return elemTy - (_:[],[elemTys@(_:_)]) -> return $ Product tcName elemTys - (_ ,concat -> []) -> return $ Sum tcName $ map (pack . name2String . dcName) dcs - (_ ,elemHTys) -> return $ SP tcName - $ zipWith (\dc tys -> - ( pack . name2String $ dcName dc - , tys - ) - ) dcs elemHTys - --- | Simple check if a TyCon is recursively defined. -isRecursiveTy :: HashMap TyConName TyCon -> TyConName -> Bool -isRecursiveTy m tc = case tyConDataCons (m HashMap.! tc) of - [] -> False - dcs -> let argTyss = map dcArgTys dcs - argTycons = (map fst . catMaybes) $ (concatMap . map) splitTyConAppM argTyss - in tc `elem` argTycons - --- | Determines if a Core type is translatable to a HWType given a function that --- translates certain builtin types. -representableType :: (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) - -> Bool -- ^ Allow zero-bit things - -> HashMap TyConName TyCon - -> Type - -> Bool -representableType builtInTranslation allowZero m = either (const False) isRepresentable . coreTypeToHWType builtInTranslation m - where - isRepresentable hty = case hty of - String -> True - Bool -> True - BitVector n -> (n > 0) || allowZero - Index n -> (n > 0) || allowZero - Signed n -> (n > 0) || allowZero - Unsigned n -> (n > 0) || allowZero - Vector n elTy - | n > 0 || allowZero -> isRepresentable elTy - RTree _n elTy -> isRepresentable elTy - Sum {} -> True - Product _ elTys -> all isRepresentable elTys - SP _ elTyss -> all (all isRepresentable . snd) elTyss - Clock {} -> True - Reset {} -> True - _ -> False - --- | Determines the bitsize of a type -typeSize :: HWType - -> Int -typeSize Void = 0 -typeSize String = 1 -typeSize Bool = 1 -typeSize (Clock _ _) = 1 -typeSize (Reset _ _) = 1 -typeSize (BitVector i) = i -typeSize (Index 0) = 0 -typeSize (Index 1) = 1 -typeSize (Index u) = fromMaybe 0 (clogBase 2 u) -typeSize (Signed i) = i -typeSize (Unsigned i) = i -typeSize (Vector n el) = n * typeSize el -typeSize (RTree d el) = (2^d) * typeSize el -typeSize t@(SP _ cons) = conSize t + - maximum (map (sum . map typeSize . snd) cons) -typeSize (Sum _ dcs) = max 1 (fromMaybe 0 . clogBase 2 . toInteger $ length dcs) -typeSize (Product _ tys) = sum $ map typeSize tys - --- | Determines the bitsize of the constructor of a type -conSize :: HWType - -> Int -conSize (SP _ cons) = fromMaybe 0 . clogBase 2 . toInteger $ length cons -conSize t = typeSize t - --- | Gives the length of length-indexed types -typeLength :: HWType - -> Int -typeLength (Vector n _) = n -typeLength _ = 0 - --- | Gives the HWType corresponding to a term. Returns an error if the term has --- a Core type that is not translatable to a HWType. -termHWType :: String - -> Term - -> NetlistMonad HWType -termHWType loc e = do - m <- Lens.use tcCache - ty <- termType m e - unsafeCoreTypeToHWTypeM loc ty - --- | Gives the HWType corresponding to a term. Returns 'Nothing' if the term has --- a Core type that is not translatable to a HWType. -termHWTypeM :: Term - -> NetlistMonad (Maybe HWType) -termHWTypeM e = do - m <- Lens.use tcCache - ty <- termType m e - coreTypeToHWTypeM ty - --- | Uniquely rename all the variables and their references in a normalized --- term -mkUniqueNormalized :: ([Id],[LetBinding],Id) - -> NetlistMonad ([Id],[LetBinding],TmName) -mkUniqueNormalized (args,binds,res) = do - -- Make arguments unique - (args',subst) <- mkUnique [] args - -- Make result unique - ([res1],subst') <- mkUnique subst [res] - let bndrs = map fst binds - exprs = map (unembed . snd) binds - usesOutput = concatMap (filter (== varName res) . Lens.toListOf termFreeIds) exprs - -- If the let-binder carrying the result is used in a feedback loop - -- rename the let-binder to "_rec", and assign the "_rec" to - -- "". We do this because output ports in most HDLs cannot be read. - (res2,subst'',extraBndr) <- case usesOutput of - [] -> return (varName res1,(res,res1):subst',[] :: [(Id, Embed Term)]) - _ -> do - ([res3],_) <- mkUnique [] [modifyVarName (`appendToName` "_rec") res1] - return (varName res3,(res,res3):subst' - ,[(res1,embed $ Var (unembed $ varType res) (varName res3))]) - -- Replace occurences of "" by "_rec" - let resN = varName res - bndrs' = map (\i -> if varName i == resN then modifyVarName (const res2) i else i) bndrs - (bndrsL,r:bndrsR) = break ((== res2).varName) bndrs' - -- Make let-binders unique - (bndrsL',substL) <- mkUnique subst'' bndrsL - (bndrsR',substR) <- mkUnique substL bndrsR - -- Replace old IDs by update unique IDs in the RHSs of the let-binders - exprs' <- fmap (map embed) $ Monad.foldM subsBndrs exprs substR - -- Return the uniquely named arguments, let-binders, and result - return (args',zip (bndrsL' ++ r:bndrsR') exprs' ++ extraBndr,varName res1) - where - subsBndrs :: [Term] -> (Id,Id) -> NetlistMonad [Term] - subsBndrs es (f,r) = mapM (subsBndr f r) es - - subsBndr :: Id -> Id -> Term -> NetlistMonad Term - subsBndr f r e = case e of - Var t v | v == varName f -> return . Var t $ varName r - App e1 e2 -> App <$> subsBndr f r e1 - <*> subsBndr f r e2 - Case scrut ty alts -> Case <$> subsBndr f r scrut - <*> pure ty - <*> mapM ( return - . uncurry bind - <=< secondM (subsBndr f r) - <=< unbind - ) alts - _ -> return e - --- | Make a set of IDs unique; also returns a substitution from old ID to new --- updated unique ID. -mkUnique :: [(Id,Id)] -- ^ Existing substitution - -> [Id] -- ^ IDs to make unique - -> NetlistMonad ([Id],[(Id,Id)]) - -- ^ (Unique IDs, update substitution) -mkUnique = go [] - where - go :: [Id] -> [(Id,Id)] -> [Id] -> NetlistMonad ([Id],[(Id,Id)]) - go processed subst [] = return (reverse processed,subst) - go processed subst (i:is) = do - iN <- mkUniqueIdentifier . pack . name2String $ varName i - let iN_unpacked = unpack iN - i' = modifyVarName (repName iN_unpacked) i - go (i':processed) ((i,i'):subst) is - - repName s n = makeName s (name2Integer n) - -mkUniqueIdentifier :: Identifier - -> NetlistMonad Identifier -mkUniqueIdentifier nm = do - seen <- Lens.use seenIds - seenC <- Lens.use seenComps - i <- mkBasicId nm - let s = seenC ++ seen - if i `elem` s - then go 0 s i - else do - seenIds %= (i:) - return i - where - go :: Integer -> [Identifier] -> Identifier -> NetlistMonad Identifier - go n s i = do - i' <- mkBasicId (i `append` pack ('_':show n)) - if i' `elem` s - then go (n+1) s i - else do - seenIds %= (i':) - return i' - --- | Append a string to a name -appendToName :: TmName - -> String - -> TmName -appendToName n s = makeName (name2String n ++ s) (name2Integer n) - --- | Preserve the Netlist '_varEnv' and '_varCount' when executing a monadic action -preserveVarEnv :: NetlistMonad a - -> NetlistMonad a -preserveVarEnv action = do - -- store state - vCnt <- Lens.use varCount - vEnv <- Lens.use varEnv - vComp <- Lens.use curCompNm - vSeen <- Lens.use seenIds - -- perform action - val <- action - -- restore state - varCount .= vCnt - varEnv .= vEnv - curCompNm .= vComp - seenIds .= vSeen - return val - -dcToLiteral :: HWType -> Int -> Literal -dcToLiteral Bool 1 = BoolLit False -dcToLiteral Bool 2 = BoolLit True -dcToLiteral _ i = NumLit (toInteger i-1) diff --git a/src/CLaSH/Normalize.hs b/src/CLaSH/Normalize.hs deleted file mode 100644 --- a/src/CLaSH/Normalize.hs +++ /dev/null @@ -1,276 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Turn CoreHW terms into normalized CoreHW Terms --} - -{-# LANGUAGE TemplateHaskell #-} - -module CLaSH.Normalize where - -import Control.Concurrent.Supply (Supply) -import Control.Lens ((.=),(^.),_1,_3) -import qualified Control.Lens as Lens -import Data.Either (partitionEithers) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.IntMap.Strict (IntMap) -import Data.List (mapAccumL,intersect) -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import qualified Data.Set as Set -import qualified Data.Set.Lens as Lens -import Unbound.Generics.LocallyNameless (unembed) - -import SrcLoc (SrcSpan,noSrcSpan) - -import CLaSH.Core.FreeVars (termFreeIds) -import CLaSH.Core.Pretty (showDoc) -import CLaSH.Core.Subst (substTms) -import CLaSH.Core.Term (Term (..), TmName) -import CLaSH.Core.Type (Type, splitCoreFunForallTy) -import CLaSH.Core.TyCon (TyCon, TyConName) -import CLaSH.Core.Util (collectArgs, mkApps, termType) -import CLaSH.Core.Var (Id,varName) -import CLaSH.Driver.Types (CLaSHOpts (..)) -import CLaSH.Netlist.BlackBox.Types (BlackBoxTemplate) -import CLaSH.Netlist.Types (HWType) -import CLaSH.Netlist.Util (splitNormalized) -import CLaSH.Normalize.Strategy -import CLaSH.Normalize.Transformations (bindConstantVar, caseCon, - reduceConst, topLet ) -import CLaSH.Normalize.Types -import CLaSH.Normalize.Util -import CLaSH.Primitives.Types (PrimMap) -import CLaSH.Rewrite.Combinators ((>->),(!->),repeatR,topdownR) -import CLaSH.Rewrite.Types (DebugLevel (..), RewriteEnv (..), RewriteState (..), - bindings, curFun, dbgLevel, - tcCache, extra) -import CLaSH.Rewrite.Util (isUntranslatableType, - runRewrite, - runRewriteSession) -import CLaSH.Util - --- | Run a NormalizeSession in a given environment -runNormalization :: CLaSHOpts - -- ^ Level of debug messages to print - -> Supply - -- ^ UniqueSupply - -> HashMap TmName (Type,SrcSpan,Term) - -- ^ Global Binders - -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) - -- ^ Hardcoded Type -> HWType translator - -> HashMap TyConName TyCon - -- ^ TyCon cache - -> IntMap TyConName - -- ^ Tuple TyCon cache - -> (HashMap TyConName TyCon -> Bool -> Term -> Term) - -- ^ Hardcoded evaluator (delta-reduction) - -> PrimMap BlackBoxTemplate - -- ^ Primitive Definitions - -> HashMap TmName Bool - -- ^ Map telling whether a components is part of a recursive group - -> NormalizeSession a - -- ^ NormalizeSession to run - -> a -runNormalization opts supply globals typeTrans tcm tupTcm eval primMap rcsMap - = runRewriteSession rwEnv rwState - where - rwEnv = RewriteEnv - (opt_dbgLevel opts) - typeTrans - tcm - tupTcm - eval - (opt_allowZero opts) - - rwState = RewriteState - 0 - globals - supply - (error $ $(curLoc) ++ "Report as bug: no curFun",noSrcSpan) - 0 - normState - - normState = NormalizeState - HashMap.empty - Map.empty - HashMap.empty - (opt_specLimit opts) - HashMap.empty - (opt_inlineLimit opts) - (opt_inlineBelow opts) - primMap - rcsMap - - -normalize :: [TmName] - -> NormalizeSession (HashMap TmName (Type,SrcSpan,Term)) -normalize [] = return HashMap.empty -normalize top = do - (new,topNormalized) <- unzip <$> mapM normalize' top - newNormalized <- normalize (concat new) - return (HashMap.union (HashMap.fromList topNormalized) newNormalized) - -normalize' :: TmName - -> NormalizeSession ([TmName],(TmName,(Type,SrcSpan,Term))) -normalize' nm = do - exprM <- HashMap.lookup nm <$> Lens.use bindings - let nmS = showDoc nm - case exprM of - Just (ty,sp,tm) -> do - tcm <- Lens.view tcCache - let (_,resTy) = splitCoreFunForallTy tcm ty - resTyRep <- not <$> isUntranslatableType resTy - if resTyRep - then do - tmNorm <- makeCached nm (extra.normalized) $ do - curFun .= (nm,sp) - tm' <- rewriteExpr ("normalization",normalization) (nmS,tm) - ty' <- termType tcm tm' - return (ty',sp,tm') - let usedBndrs = Lens.toListOf termFreeIds (tmNorm ^. _3) - traceIf (nm `elem` usedBndrs) - (concat [ $(curLoc),"Expr belonging to bndr: ",nmS ," (:: " - , showDoc (tmNorm ^. _1) - , ") remains recursive after normalization:\n" - , showDoc (tmNorm ^. _3) ]) - (return ()) - prevNorm <- fmap HashMap.keys $ Lens.use (extra.normalized) - let toNormalize = filter (`notElem` (nm:prevNorm)) usedBndrs - return (toNormalize,(nm,tmNorm)) - else do - let usedBndrs = Lens.toListOf termFreeIds tm - prevNorm <- fmap HashMap.keys $ Lens.use (extra.normalized) - let toNormalize = filter (`notElem` (nm:prevNorm)) usedBndrs - lvl <- Lens.view dbgLevel - traceIf (lvl >= DebugFinal) - (concat [$(curLoc), "Expr belonging to bndr: ", nmS, " (:: " - , showDoc ty - , ") has a non-representable return type." - , " Not normalising:\n", showDoc tm] ) - (return (toNormalize,(nm,(ty,sp,tm)))) - Nothing -> error $ $(curLoc) ++ "Expr belonging to bndr: " ++ nmS ++ " not found" - --- | Rewrite a term according to the provided transformation -rewriteExpr :: (String,NormRewrite) -- ^ Transformation to apply - -> (String,Term) -- ^ Term to transform - -> NormalizeSession Term -rewriteExpr (nrwS,nrw) (bndrS,expr) = do - lvl <- Lens.view dbgLevel - let before = showDoc expr - let expr' = traceIf (lvl >= DebugFinal) - (bndrS ++ " before " ++ nrwS ++ ":\n\n" ++ before ++ "\n") - expr - rewritten <- runRewrite nrwS nrw expr' - let after = showDoc rewritten - traceIf (lvl >= DebugFinal) - (bndrS ++ " after " ++ nrwS ++ ":\n\n" ++ after ++ "\n") $ - return rewritten - --- | Check if the call graph (second argument), starting at the @topEnity@ --- (first argument) is non-recursive. Returns the list of normalized terms if --- call graph is indeed non-recursive, errors otherwise. -checkNonRecursive :: TmName -- ^ @topEntity@ - -> HashMap TmName (Type,SrcSpan,Term) -- ^ List of normalized binders - -> HashMap TmName (Type,SrcSpan,Term) -checkNonRecursive topEntity norm = - let cg = callGraph [] norm topEntity - in case mkRecursiveComponents cg of - [] -> norm - rcs -> error $ $(curLoc) ++ "Callgraph after normalisation contains following recursive cycles: " ++ show rcs - --- | Perform general \"clean up\" of the normalized (non-recursive) function --- hierarchy. This includes: --- --- * Inlining functions that simply \"wrap\" another function -cleanupGraph :: TmName - -> (HashMap TmName (Type,SrcSpan,Term)) - -> NormalizeSession (HashMap TmName (Type,SrcSpan,Term)) -cleanupGraph topEntity norm = do - let ct = mkCallTree [] norm topEntity - ctFlat <- flattenCallTree ct - return (HashMap.fromList $ snd $ callTreeToList [] ctFlat) - - -data CallTree = CLeaf (TmName,(Type,SrcSpan,Term)) - | CBranch (TmName,(Type,SrcSpan,Term)) [CallTree] - -mkCallTree :: [TmName] -- ^ Visited - -> HashMap TmName (Type,SrcSpan,Term) -- ^ Global binders - -> TmName -- ^ Root of the call graph - -> CallTree -mkCallTree visited bindingMap root = case used of - [] -> CLeaf (root,rootTm) - _ -> CBranch (root,rootTm) other - where - rootTm = Maybe.fromMaybe (error $ $(curLoc) ++ show root ++ " is not a global binder") $ HashMap.lookup root bindingMap - used = Set.toList $ Lens.setOf termFreeIds $ (rootTm ^. _3) - other = map (mkCallTree (root:visited) bindingMap) (filter (`notElem` visited) used) - -stripArgs :: [TmName] - -> [Id] - -> [Either Term Type] - -> Maybe [Either Term Type] -stripArgs _ (_:_) [] = Nothing -stripArgs allIds [] args = if any mentionsId args - then Nothing - else Just args - where - mentionsId t = not $ null (either (Lens.toListOf termFreeIds) (const []) t - `intersect` - allIds) - -stripArgs allIds (id_:ids) (Left (Var _ nm):args) - | varName id_ == nm = stripArgs allIds ids args - | otherwise = Nothing -stripArgs _ _ _ = Nothing - -flattenNode :: CallTree - -> NormalizeSession (Either CallTree ((TmName,Term),[CallTree])) -flattenNode c@(CLeaf (nm,(_,_,e))) = do - tcm <- Lens.view tcCache - norm <- splitNormalized tcm e - case norm of - Right (ids,[(_,bExpr)],_) -> do - let (fun,args) = collectArgs (unembed bExpr) - case stripArgs (map varName ids) (reverse ids) (reverse args) of - Just remainder -> return (Right ((nm,mkApps fun (reverse remainder)),[])) - Nothing -> return (Left c) - _ -> return (Left c) -flattenNode b@(CBranch (nm,(_,_,e)) us) = do - tcm <- Lens.view tcCache - norm <- splitNormalized tcm e - case norm of - Right (ids,[(_,bExpr)],_) -> do - let (fun,args) = collectArgs (unembed bExpr) - case stripArgs (map varName ids) (reverse ids) (reverse args) of - Just remainder -> return (Right ((nm,mkApps fun (reverse remainder)),us)) - Nothing -> return (Left b) - _ -> return (Left b) - -flattenCallTree :: CallTree - -> NormalizeSession CallTree -flattenCallTree c@(CLeaf _) = return c -flattenCallTree (CBranch (nm,(ty,sp,tm)) used) = do - flattenedUsed <- mapM flattenCallTree used - (newUsed,il_ct) <- partitionEithers <$> mapM flattenNode flattenedUsed - let (toInline,il_used) = unzip il_ct - newExpr <- case toInline of - [] -> return tm - _ -> rewriteExpr ("bindConstants",(repeatR (topdownR $ (bindConstantVar >-> caseCon >-> reduceConst))) !-> topdownSucR topLet) (showDoc nm, substTms toInline tm) - return (CBranch (nm,(ty,sp,newExpr)) (newUsed ++ (concat il_used))) - -callTreeToList :: [TmName] - -> CallTree - -> ([TmName],[(TmName,(Type,SrcSpan,Term))]) -callTreeToList visited (CLeaf (nm,(ty,sp,tm))) - | nm `elem` visited = (visited,[]) - | otherwise = (nm:visited,[(nm,(ty,sp,tm))]) -callTreeToList visited (CBranch (nm,(ty,sp,tm)) used) - | nm `elem` visited = (visited,[]) - | otherwise = (visited',(nm,(ty,sp,tm)):(concat others)) - where - (visited',others) = mapAccumL callTreeToList (nm:visited) used diff --git a/src/CLaSH/Normalize/DEC.hs b/src/CLaSH/Normalize/DEC.hs deleted file mode 100644 --- a/src/CLaSH/Normalize/DEC.hs +++ /dev/null @@ -1,471 +0,0 @@ -{-| - Copyright : (C) 2015-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Helper functions for the 'disjointExpressionConsolidation' transformation - - The 'disjointExpressionConsolidation' transformation lifts applications of - global binders out of alternatives of case-statements. - - e.g. It converts: - - > case x of - > A -> f 3 y - > B -> f x x - > C -> h x - - into: - - > let f_arg0 = case x of {A -> 3; B -> x} - > f_arg1 = case x of {A -> y; B -> x} - > f_out = f f_arg0 f_arg1 - > in case x of - > A -> f_out - > B -> f_out - > C -> h x --} - -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} - -module CLaSH.Normalize.DEC - (collectGlobals - ,isDisjoint - ,mkDisjointGroup - ) -where - --- external -import qualified Control.Lens as Lens -import Data.Bits ((.&.),complement) -import qualified Data.Either as Either -import qualified Data.Foldable as Foldable -import qualified Data.HashMap.Strict as HashMap -import qualified Data.IntMap.Strict as IM -import qualified Data.List as List -import qualified Data.Map.Strict as Map -import qualified Data.Maybe as Maybe -import Data.Set (Set) -import qualified Data.Set as Set -import qualified Data.Set.Lens as Lens - -import Unbound.Generics.LocallyNameless (Bind, bind, embed, fv, unbind, - unembed, unrec) -import qualified Unbound.Generics.LocallyNameless as Unbound - --- internal -import CLaSH.Core.DataCon (DataCon, dcTag) -import CLaSH.Core.FreeVars (termFreeIds, typeFreeVars) -import CLaSH.Core.Literal (Literal (..)) -import CLaSH.Core.Term (LetBinding, Pat (..), Term (..), TmName) -import CLaSH.Core.TyCon (tyConDataCons) -import CLaSH.Core.Type (Type, isPolyFunTy, mkTyConApp, splitFunForallTy) -import CLaSH.Core.Util (collectArgs, mkApps, termType) -import CLaSH.Normalize.Types (NormalizeState) -import CLaSH.Normalize.Util (isConstant) -import CLaSH.Rewrite.Types (RewriteMonad, evaluator, tcCache, tupleTcCache) -import CLaSH.Rewrite.Util (mkInternalVar, mkSelectorCase, - isUntranslatableType) -import CLaSH.Util - -data CaseTree a - = Leaf a - | LB [LetBinding] (CaseTree a) - | Branch Term [(Pat,CaseTree a)] - deriving (Eq,Show,Functor,Foldable) - --- | Test if a 'CaseTree' collected from an expression indicates that --- application of a global binder is disjoint: occur in separate branches of a --- case-expression. -isDisjoint :: CaseTree ([Either Term Type]) - -> Bool -isDisjoint (Branch _ [_]) = False -isDisjoint ct = go ct - where - go (Leaf _) = False - go (LB _ ct') = go ct' - go (Branch _ []) = False - go (Branch _ [(_,x)]) = go x - go b@(Branch _ (_:_:_)) = allEqual (map Either.rights (Foldable.toList b)) - --- Remove empty branches from a 'CaseTree' -removeEmpty :: Eq a => CaseTree [a] -> CaseTree [a] -removeEmpty l@(Leaf _) = l -removeEmpty (LB lb ct) = - case removeEmpty ct of - Leaf [] -> Leaf [] - ct' -> LB lb ct' -removeEmpty (Branch s bs) = - case filter ((/= (Leaf [])) . snd) (map (second removeEmpty) bs) of - [] -> Leaf [] - bs' -> Branch s bs' - --- | Test if all elements in a list are equal to each other. -allEqual :: Eq a => [a] -> Bool -allEqual [] = True -allEqual (x:xs) = all (== x) xs - --- | Collect 'CaseTree's for (potentially) disjoint applications of globals out --- of an expression. Also substitute truly disjoint applications of globals by a --- reference to a lifted out application. -collectGlobals :: - Set TmName - -> [(Term,Term)] -- ^ Substitution of (applications of) a global - -- binder by a reference to a lifted term. - -> [Term] -- ^ List of already seen global binders - -> Term -- ^ The expression - -> RewriteMonad NormalizeState - (Term,[(Term,([Term],CaseTree [(Either Term Type)]))]) -collectGlobals inScope substitution seen (Case scrut ty alts) = do - rec (alts' ,collected) <- collectGlobalsAlts inScope substitution seen scrut' - alts - (scrut',collected') <- collectGlobals inScope substitution - (map fst collected ++ seen) scrut - return (Case scrut' ty alts',collected ++ collected') - -collectGlobals inScope substitution seen e@(collectArgs -> (fun, args@(_:_))) - | not (isConstant e) = do - tcm <- Lens.view tcCache - eval <- Lens.view evaluator - eTy <- termType tcm e - untran <- isUntranslatableType eTy - case untran of - -- Don't lift out non-representable values, because they cannot be let-bound - -- in our desired normal form. - False -> case interestingToLift inScope (eval tcm False) fun args of - Just fun' | fun' `notElem` seen -> do - (args',collected) <- collectGlobalsArgs inScope substitution - (fun':seen) args - let e' = Maybe.fromMaybe (mkApps fun' args') (List.lookup fun' substitution) - -- This function is lifted out an environment with the currently 'seen' - -- binders. When we later apply substitution, we need to start with this - -- environment, otherwise we perform incorrect substitutions in the - -- arguments. - return (e',(fun',(seen,Leaf args')):collected) - _ -> do (args',collected) <- collectGlobalsArgs inScope substitution - seen args - return (mkApps fun args',collected) - _ -> return (e,[]) - --- FIXME: This duplicates A LOT of let-bindings, where I just pray that after --- the ANF, CSE, and DeadCodeRemoval pass all duplicates are removed. --- --- I think we should be able to do better, but perhaps we cannot fix it here. -collectGlobals inScope substitution seen (Letrec b) = do - (unrec -> lbs,body) <- unbind b - (body',collected) <- collectGlobals inScope substitution seen body - (lbs',collected') <- collectGlobalsLbs inScope substitution - (map fst collected ++ seen) - lbs - return (Letrec (bind (Unbound.rec lbs') body') - ,map (second (second (LB lbs'))) (collected ++ collected') - ) - -collectGlobals _ _ _ e = return (e,[]) - --- | Collect 'CaseTree's for (potentially) disjoint applications of globals out --- of a list of application arguments. Also substitute truly disjoint --- applications of globals by a reference to a lifted out application. -collectGlobalsArgs :: - Set TmName - -> [(Term,Term)] -- ^ Substitution of (applications of) a global - -- binder by a reference to a lifted term. - -> [Term] -- ^ List of already seen global binders - -> [Either Term Type] -- ^ The list of arguments - -> RewriteMonad NormalizeState - ([Either Term Type] - ,[(Term,([Term],CaseTree [(Either Term Type)]))] - ) -collectGlobalsArgs inScope substitution seen args = do - (_,(args',collected)) <- second unzip <$> mapAccumLM go seen args - return (args',concat collected) - where - go s (Left tm) = do - (tm',collected) <- collectGlobals inScope substitution s tm - return (map fst collected ++ s,(Left tm',collected)) - go s (Right ty) = return (s,(Right ty,[])) - --- | Collect 'CaseTree's for (potentially) disjoint applications of globals out --- of a list of alternatives. Also substitute truly disjoint applications of --- globals by a reference to a lifted out application. -collectGlobalsAlts :: - Set TmName - -> [(Term,Term)] -- ^ Substitution of (applications of) a global - -- binder by a reference to a lifted term. - -> [Term] -- ^ List of already seen global binders - -> Term -- ^ The subject term - -> [Bind Pat Term] -- ^ The list of alternatives - -> RewriteMonad NormalizeState - ([Bind Pat Term] - ,[(Term,([Term],CaseTree [(Either Term Type)]))] - ) -collectGlobalsAlts inScope substitution seen scrut alts = do - (alts',collected) <- unzip <$> mapM go alts - let collectedM = map (Map.fromList . map (second (second (:[])))) collected - collectedUN = Map.unionsWith (\(l1,r1) (l2,r2) -> (List.nub (l1 ++ l2),r1 ++ r2)) collectedM - collected' = map (second (second (Branch scrut))) (Map.toList collectedUN) - return (alts',collected') - where - go pe = do (p,e) <- unbind pe - (e',collected) <- collectGlobals inScope substitution seen e - return (bind p e',map (second (second (p,))) collected) - --- | Collect 'CaseTree's for (potentially) disjoint applications of globals out --- of a list of let-bindings. Also substitute truly disjoint applications of --- globals by a reference to a lifted out application. -collectGlobalsLbs :: - Set TmName - -> [(Term,Term)] -- ^ Substitution of (applications of) a global - -- binder by a reference to a lifted term. - -> [Term] -- ^ List of already seen global binders - -> [LetBinding] -- ^ The list let-bindings - -> RewriteMonad NormalizeState - ([LetBinding] - ,[(Term,([Term],CaseTree [(Either Term Type)]))] - ) -collectGlobalsLbs inScope substitution seen lbs = do - (_,(lbs',collected)) <- second unzip <$> mapAccumLM go seen lbs - return (lbs',concat collected) - where - go :: [Term] -> LetBinding - -> RewriteMonad NormalizeState - ([Term] - ,(LetBinding - ,[(Term,([Term],CaseTree [(Either Term Type)]))] - ) - ) - go s (id_,unembed -> e) = do - (e',collected) <- collectGlobals inScope substitution s e - return (map fst collected ++ s,((id_,embed e'),collected)) - --- | Given a case-tree corresponding to a disjoint interesting \"term-in-a- --- function-position\", return a let-expression: where the let-binding holds --- a case-expression selecting between the uncommon arguments of the case-tree, --- and the body is an application of the term applied to the common arguments of --- the case tree, and projections of let-binding corresponding to the uncommon --- argument positions. -mkDisjointGroup :: Set TmName -- ^ Current free variables. - -> (Term,([Term],CaseTree [(Either Term Type)])) - -- ^ Case-tree of arguments belonging to the applied term. - -> RewriteMonad NormalizeState (Term,[Term]) -mkDisjointGroup fvs (fun,(seen,cs)) = do - let argss = Foldable.toList cs - argssT = zip [0..] (List.transpose argss) - (commonT,uncommonT) = List.partition (isCommon fvs . snd) argssT - common = map (second head) commonT - uncommon = map (Either.lefts) (List.transpose (map snd uncommonT)) - cs' = fmap (zip [0..]) cs - cs'' = removeEmpty - $ fmap (Either.lefts . map snd) - (if null common - then cs' - else fmap (filter (`notElem` common)) cs') - tcm <- Lens.view tcCache - (uncommonCaseM,uncommonProjections) <- case uncommon of - -- only common arguments: do nothing. - [] -> return (Nothing,[]) - -- Create selectors and projections - (uc:_) -> do - argTys <- mapM (termType tcm) uc - disJointSelProj argTys cs'' - let newArgs = mkDJArgs 0 common uncommonProjections - case uncommonCaseM of - Just lb -> return (Letrec (bind (Unbound.rec [lb]) (mkApps fun newArgs)), seen) - Nothing -> return (mkApps fun newArgs, seen) - --- | Create a single selector for all the representable uncommon arguments by --- selecting between tuples. This selector is only ('Just') created when the --- number of representable uncommmon arguments is larger than one, otherwise it --- is not ('Nothing'). --- --- It also returns: --- --- * For all the non-representable uncommon arguments: a selector --- * For all the representable uncommon arguments: a projection out of the tuple --- created by the larger selector. If this larger selector does not exist, a --- single selector is created for the single representable uncommon argument. -disJointSelProj :: [Type] -- ^ Types of the arguments - -> CaseTree [Term] -- The case-tree of arguments - -> RewriteMonad NormalizeState (Maybe LetBinding,[Term]) -disJointSelProj _ (Leaf []) = return (Nothing,[]) -disJointSelProj argTys cs = do - let maxIndex = length argTys - 1 - css = map (\i -> fmap ((:[]) . (!!i)) cs) [0..maxIndex] - (untran,tran) <- partitionM (isUntranslatableType . snd) (zip [0..] argTys) - let untranCs = map (css!!) (map fst untran) - untranSels = zipWith (\(_,ty) cs' -> genCase ty Nothing [] cs') - untran untranCs - (lbM,projs) <- case tran of - [] -> return (Nothing,[]) - [(i,ty)] -> return (Nothing,[genCase ty Nothing [] (css!!i)]) - tys -> do - tcm <- Lens.view tcCache - tupTcm <- Lens.view tupleTcCache - let m = length tys - Just tupTcNm = IM.lookup m tupTcm - Just tupTc = HashMap.lookup tupTcNm tcm - [tupDc] = tyConDataCons tupTc - (tyIxs,tys') = unzip tys - tupTy = mkTyConApp tupTcNm tys' - cs' = fmap (\es -> map (es !!) tyIxs) cs - djCase = genCase tupTy (Just tupDc) tys' cs' - (scrutId,scrutVar) <- mkInternalVar "tupIn" tupTy - projections <- mapM (mkSelectorCase ($(curLoc) ++ "disJointSelProj") - tcm scrutVar (dcTag tupDc)) [0..m-1] - return (Just (scrutId,embed djCase),projections) - let selProjs = tranOrUnTran 0 (zip (map fst untran) untranSels) projs - - return (lbM,selProjs) - where - tranOrUnTran _ [] projs = projs - tranOrUnTran _ sels [] = map snd sels - tranOrUnTran n ((ut,s):uts) (p:projs) - | n == ut = s : tranOrUnTran (n+1) uts (p:projs) - | otherwise = p : tranOrUnTran (n+1) ((ut,s):uts) projs - - -isCommon :: Set TmName -> [Either Term Type] -> Bool -isCommon _ [] = True -isCommon _ (Right ty:tys) = Set.null (Lens.setOf typeFreeVars ty) && - allEqual (Right ty:tys) -isCommon fvs (Left tm:tms) = Set.null (Lens.setOf termFreeIds tm Set.\\ fvs) && - allEqual (Left tm:tms) - --- | Create a list of arguments given a map of positions to common arguments, --- and a list of arguments -mkDJArgs :: Int -- ^ Current position - -> [(Int,Either Term Type)] -- ^ map from position to common argument - -> [Term] -- ^ (projections for) uncommon arguments - -> [Either Term Type] -mkDJArgs _ cms [] = map snd cms -mkDJArgs _ [] uncms = map Left uncms -mkDJArgs n ((m,x):cms) (y:uncms) - | n == m = x : mkDJArgs (n+1) cms (y:uncms) - | otherwise = Left y : mkDJArgs (n+1) ((m,x):cms) uncms - --- | Create a case-expression that selects between the uncommon arguments given --- a case-tree -genCase :: Type -- ^ Type of the alternatives - -> Maybe DataCon -- ^ DataCon to pack multiple arguments - -> [Type] -- ^ Types of the arguments - -> CaseTree [Term] -- ^ CaseTree of arguments - -> Term -genCase ty dcM argTys = go - where - go (Leaf tms) = - case dcM of - Just dc -> mkApps (Data dc) (map Right argTys ++ map Left tms) - _ -> head tms - - go (LB lb ct) = - Letrec (bind (Unbound.rec lb) (go ct)) - - go (Branch scrut [(p,ct)]) = - let ct' = go ct - alt = bind p ct' - in case Lens.setOf termFreeIds ct' == Lens.setOf fv alt of - True -> ct' - _ -> Case scrut ty [alt] - - go (Branch scrut pats) = - Case scrut ty (map (\(p,ct) -> bind p (go ct)) pats) - --- | Determine if a term in a function position is interesting to lift out of --- of a case-expression. --- --- This holds for all global functions, and certain primitives. Currently those --- primitives are: --- --- * All non-power-of-two multiplications --- * All division-like operations with a non-power-of-two divisor -interestingToLift :: Set TmName -- ^ in scope - -> (Term -> Term) -- ^ Evaluator - -> Term -- ^ Term in function position - -> [Either Term Type] -- ^ Arguments - -> Maybe Term -interestingToLift inScope _ e@(Var _ nm) _ = - if nm `Set.member` inScope - then Just e - else Nothing -interestingToLift inScope eval e@(Prim nm pty) args = - case List.lookup nm interestingPrims of - Just t | t || not (all isConstant lArgs) -> Just e - _ -> if isHOTy pty - then if not . null . Maybe.catMaybes $ - map (uncurry (interestingToLift inScope eval) . - collectArgs - ) lArgs - then Just e - else Nothing - else Nothing - - where - interestingPrims = - [("CLaSH.Sized.Internal.BitVector.*#",tailNonPow2) - ,("CLaSH.Sized.Internal.BitVector.times#",tailNonPow2) - ,("CLaSH.Sized.Internal.BitVector.quot#",lastNotPow2) - ,("CLaSH.Sized.Internal.BitVector.rem#",lastNotPow2) - ,("CLaSH.Sized.Internal.Index.*#",tailNonPow2) - ,("CLaSH.Sized.Internal.Index.quot#",lastNotPow2) - ,("CLaSH.Sized.Internal.Index.rem#",lastNotPow2) - ,("CLaSH.Sized.Internal.Signed.*#",tailNonPow2) - ,("CLaSH.Sized.Internal.Signed.times#",tailNonPow2) - ,("CLaSH.Sized.Internal.Signed.rem#",lastNotPow2) - ,("CLaSH.Sized.Internal.Signed.quot#",lastNotPow2) - ,("CLaSH.Sized.Internal.Signed.div#",lastNotPow2) - ,("CLaSH.Sized.Internal.Signed.mod#",lastNotPow2) - ,("CLaSH.Sized.Internal.Unsigned.*#",tailNonPow2) - ,("CLaSH.Sized.Internal.Unsigned.times#",tailNonPow2) - ,("CLaSH.Sized.Internal.Unsigned.quot#",lastNotPow2) - ,("CLaSH.Sized.Internal.Unsigned.rem#",lastNotPow2) - ,("GHC.Base.quotInt",lastNotPow2) - ,("GHC.Base.remInt",lastNotPow2) - ,("GHC.Base.divInt",lastNotPow2) - ,("GHC.Base.modInt",lastNotPow2) - ,("GHC.Classes.divInt#",lastNotPow2) - ,("GHC.Classes.modInt#",lastNotPow2) - ,("GHC.Integer.Type.timesInteger",allNonPow2) - ,("GHC.Integer.Type.divInteger",lastNotPow2) - ,("GHC.Integer.Type.modInteger",lastNotPow2) - ,("GHC.Integer.Type.quotInteger",lastNotPow2) - ,("GHC.Integer.Type.remInteger",lastNotPow2) - ,("GHC.Prim.*#",allNonPow2) - ,("GHC.Prim.quotInt#",lastNotPow2) - ,("GHC.Prim.remInt#",lastNotPow2) - ] - - lArgs = Either.lefts args - - allNonPow2 = all (not . termIsPow2) lArgs - tailNonPow2 = case lArgs of - [] -> True - _ -> all (not . termIsPow2) (tail lArgs) - lastNotPow2 = case lArgs of - [] -> True - _ -> not (termIsPow2 (last lArgs)) - - termIsPow2 e' = case eval e' of - Literal (IntegerLiteral n) -> isPow2 n - a -> case collectArgs a of - (Prim nm' _,[Right _,Left _,Left (Literal (IntegerLiteral n))]) - | isFromInteger nm' -> isPow2 n - _ -> False - - isPow2 x = x /= 0 && (x .&. (complement x + 1)) == x - - isFromInteger x = x `elem` ["CLaSH.Sized.Internal.BitVector.fromInteger#" - ,"CLaSH.Sized.Integer.Index.fromInteger" - ,"CLaSH.Sized.Internal.Signed.fromInteger#" - ,"CLaSH.Sized.Internal.Unsigned.fromInteger#" - ] - - isHOTy t = case splitFunForallTy t of - (args',_) -> any isPolyFunTy (Either.rights args') - -interestingToLift _ _ _ _ = Nothing diff --git a/src/CLaSH/Normalize/PrimitiveReductions.hs b/src/CLaSH/Normalize/PrimitiveReductions.hs deleted file mode 100644 --- a/src/CLaSH/Normalize/PrimitiveReductions.hs +++ /dev/null @@ -1,678 +0,0 @@ -{-| - Copyright : (C) 2015-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Reductions of primitives - - Currently, it contains reductions for: - - * CLaSH.Sized.Vector.map - * CLaSH.Sized.Vector.zipWith - * CLaSH.Sized.Vector.traverse# - * CLaSH.Sized.Vector.foldr - * CLaSH.Sized.Vector.fold - * CLaSH.Sized.Vector.dfold - * CLaSH.Sized.Vector.(++) - * CLaSH.Sized.Vector.head - * CLaSH.Sized.Vector.tail - * CLaSH.Sized.Vector.unconcatBitVector# - * CLaSH.Sized.Vector.replicate - * CLaSH.Sized.Vector.imap - * CLaSH.Sized.Vector.dtfold - * CLaSH.Sized.RTree.tfold - - Partially handles: - - * CLaSH.Sized.Vector.unconcat - * CLaSH.Sized.Vector.transpose --} - -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} - -module CLaSH.Normalize.PrimitiveReductions where - -import qualified Control.Lens as Lens -import qualified Data.HashMap.Lazy as HashMap -import qualified Data.Maybe as Maybe -import Unbound.Generics.LocallyNameless (bind, embed, rec, rebind, - string2Name) - -import CLaSH.Core.DataCon (DataCon, dataConInstArgTys) -import CLaSH.Core.Literal (Literal (..)) -import CLaSH.Core.Pretty (showDoc) -import CLaSH.Core.Term (Term (..), Pat (..)) -import CLaSH.Core.Type (LitTy (..), Type (..), - TypeView (..), coreView, - mkFunTy, mkTyConApp, - splitFunForallTy, tyView, - undefinedTy) -import CLaSH.Core.TyCon (TyConName, tyConDataCons) -import CLaSH.Core.TysPrim (integerPrimTy, typeNatKind) -import CLaSH.Core.Util (appendToVec, extractElems, - extractTElems, idToVar, - mkApps, mkRTree, mkVec, - termType) -import CLaSH.Core.Var (Var (..)) - -import CLaSH.Normalize.Types -import CLaSH.Rewrite.Types -import CLaSH.Rewrite.Util -import CLaSH.Util - --- | Replace an application of the @CLaSH.Sized.Vector.zipWith@ primitive on --- vectors of a known length @n@, by the fully unrolled recursive "definition" --- of @CLaSH.Sized.Vector.zipWith@ -reduceZipWith :: Integer -- ^ Length of the vector(s) - -> Type -- ^ Type of the lhs of the function - -> Type -- ^ Type of the rhs of the function - -> Type -- ^ Type of the result of the function - -> Term -- ^ The zipWith'd functions - -> Term -- ^ The 1st vector argument - -> Term -- ^ The 2nd vector argument - -> NormalizeSession Term -reduceZipWith n lhsElTy rhsElTy resElTy fun lhsArg rhsArg = do - tcm <- Lens.view tcCache - ty <- termType tcm lhsArg - go tcm ty - where - go tcm (coreView tcm -> Just ty') = go tcm ty' - go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- HashMap.lookup vecTcNm tcm - , [nilCon,consCon] <- tyConDataCons vecTc - = let (varsL,elemsL) = second concat . unzip - $ extractElems consCon lhsElTy 'L' n lhsArg - (varsR,elemsR) = second concat . unzip - $ extractElems consCon rhsElTy 'R' n rhsArg - funApps = zipWith (\l r -> mkApps fun [Left l,Left r]) varsL varsR - lbody = mkVec nilCon consCon resElTy n funApps - lb = Letrec (bind (rec (init elemsL ++ init elemsR)) lbody) - in changed lb - go _ ty = error $ $(curLoc) ++ "reduceZipWith: argument does not have a vector type: " ++ showDoc ty - --- | Replace an application of the @CLaSH.Sized.Vector.map@ primitive on vectors --- of a known length @n@, by the fully unrolled recursive "definition" of --- @CLaSH.Sized.Vector.map@ -reduceMap :: Integer -- ^ Length of the vector - -> Type -- ^ Argument type of the function - -> Type -- ^ Result type of the function - -> Term -- ^ The map'd function - -> Term -- ^ The map'd over vector - -> NormalizeSession Term -reduceMap n argElTy resElTy fun arg = do - tcm <- Lens.view tcCache - ty <- termType tcm arg - go tcm ty - where - go tcm (coreView tcm -> Just ty') = go tcm ty' - go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- HashMap.lookup vecTcNm tcm - , [nilCon,consCon] <- tyConDataCons vecTc - = let (vars,elems) = second concat . unzip - $ extractElems consCon argElTy 'A' n arg - funApps = map (fun `App`) vars - lbody = mkVec nilCon consCon resElTy n funApps - lb = Letrec (bind (rec (init elems)) lbody) - in changed lb - go _ ty = error $ $(curLoc) ++ "reduceMap: argument does not have a vector type: " ++ showDoc ty - --- | Replace an application of the @CLaSH.Sized.Vector.imap@ primitive on vectors --- of a known length @n@, by the fully unrolled recursive "definition" of --- @CLaSH.Sized.Vector.imap@ -reduceImap :: Integer -- ^ Length of the vector - -> Type -- ^ Argument type of the function - -> Type -- ^ Result type of the function - -> Term -- ^ The imap'd function - -> Term -- ^ The imap'd over vector - -> NormalizeSession Term -reduceImap n argElTy resElTy fun arg = do - tcm <- Lens.view tcCache - ty <- termType tcm arg - go tcm ty - where - go tcm (coreView tcm -> Just ty') = go tcm ty' - go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- HashMap.lookup vecTcNm tcm - , [nilCon,consCon] <- tyConDataCons vecTc - = do - let (vars,elems) = second concat . unzip - $ extractElems consCon argElTy 'I' n arg - (Right idxTy:_,_) <- splitFunForallTy <$> termType tcm fun - let (TyConApp idxTcNm _) = tyView idxTy - nTv = string2Name "n" - -- fromInteger# :: KnownNat n => Integer -> Index n - idxFromIntegerTy = ForAllTy (bind (TyVar nTv (embed typeNatKind)) - (foldr mkFunTy - (mkTyConApp idxTcNm - [VarTy typeNatKind nTv]) - [integerPrimTy,integerPrimTy])) - idxFromInteger = Prim "CLaSH.Sized.Internal.Index.fromInteger#" - idxFromIntegerTy - idxs = map (App (App (TyApp idxFromInteger (LitTy (NumTy n))) - (Literal (IntegerLiteral (toInteger n)))) - . Literal . IntegerLiteral . toInteger) [0..(n-1)] - - funApps = zipWith (\i v -> App (App fun i) v) idxs vars - lbody = mkVec nilCon consCon resElTy n funApps - lb = Letrec (bind (rec (init elems)) lbody) - changed lb - go _ ty = error $ $(curLoc) ++ "reduceImap: argument does not have a vector type: " ++ showDoc ty - --- | Replace an application of the @CLaSH.Sized.Vector.traverse#@ primitive on --- vectors of a known length @n@, by the fully unrolled recursive "definition" --- of @CLaSH.Sized.Vector.traverse#@ -reduceTraverse :: Integer -- ^ Length of the vector - -> Type -- ^ Element type of the argument vector - -> Type -- ^ The type of the applicative - -> Type -- ^ Element type of the result vector - -> Term -- ^ The @Applicative@ dictionary - -> Term -- ^ The function to traverse with - -> Term -- ^ The argument vector - -> NormalizeSession Term -reduceTraverse n aTy fTy bTy dict fun arg = do - tcm <- Lens.view tcCache - (TyConApp apDictTcNm _) <- tyView <$> termType tcm dict - ty <- termType tcm arg - go tcm apDictTcNm ty - where - go tcm apDictTcNm (coreView tcm -> Just ty') = go tcm apDictTcNm ty' - go tcm apDictTcNm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- HashMap.lookup vecTcNm tcm - , [nilCon,consCon] <- tyConDataCons vecTc - = let (Just apDictTc) = HashMap.lookup apDictTcNm tcm - [apDictCon] = tyConDataCons apDictTc - (Just apDictIdTys) = dataConInstArgTys apDictCon [fTy] - apDictIds = zipWith Id (map string2Name ["functorDict" - ,"pure" - ,"ap" - ,"apConstL" - ,"apConstR"]) - (map embed apDictIdTys) - - (TyConApp funcDictTcNm _) = tyView (head apDictIdTys) - (Just funcDictTc) = HashMap.lookup funcDictTcNm tcm - [funcDictCon] = tyConDataCons funcDictTc - (Just funcDictIdTys) = dataConInstArgTys funcDictCon [fTy] - funcDicIds = zipWith Id (map string2Name ["fmap","fmapConst"]) - (map embed funcDictIdTys) - - apPat = DataPat (embed apDictCon) (rebind [] apDictIds) - fnPat = DataPat (embed funcDictCon) (rebind [] funcDicIds) - - -- Extract the 'pure' function from the Applicative dictionary - pureTy = apDictIdTys!!1 - pureTm = Case dict pureTy [bind apPat (Var pureTy (string2Name "pure"))] - - -- Extract the '<*>' function from the Applicative dictionary - apTy = apDictIdTys!!2 - apTm = Case dict apTy [bind apPat (Var apTy (string2Name "ap"))] - - -- Extract the Functor dictionary from the Applicative dictionary - funcTy = (head apDictIdTys) - funcTm = Case dict funcTy - [bind apPat (Var funcTy (string2Name "functorDict"))] - - -- Extract the 'fmap' function from the Functor dictionary - fmapTy = (head funcDictIdTys) - fmapTm = Case (Var funcTy (string2Name "functorDict")) fmapTy - [bind fnPat (Var fmapTy (string2Name "fmap"))] - - (vars,elems) = second concat . unzip - $ extractElems consCon aTy 'T' n arg - - funApps = map (fun `App`) vars - - lbody = mkTravVec vecTcNm nilCon consCon (idToVar (apDictIds!!1)) - (idToVar (apDictIds!!2)) - (idToVar (funcDicIds!!0)) - bTy n funApps - - lb = Letrec (bind (rec ([((apDictIds!!0),embed funcTm) - ,((apDictIds!!1),embed pureTm) - ,((apDictIds!!2),embed apTm) - ,((funcDicIds!!0),embed fmapTm) - ] ++ init elems)) lbody) - in changed lb - go _ _ ty = error $ $(curLoc) ++ "reduceTraverse: argument does not have a vector type: " ++ showDoc ty - --- | Create the traversable vector --- --- e.g. for a length '2' input vector, we get --- --- > (:>) <$> x0 <*> ((:>) <$> x1 <*> pure Nil) -mkTravVec :: TyConName -- ^ Vec tcon - -> DataCon -- ^ Nil con - -> DataCon -- ^ Cons con - -> Term -- ^ 'pure' term - -> Term -- ^ '<*>' term - -> Term -- ^ 'fmap' term - -> Type -- ^ 'b' ty - -> Integer -- ^ Length of the vector - -> [Term] -- ^ Elements of the vector - -> Term -mkTravVec vecTc nilCon consCon pureTm apTm fmapTm bTy = go - where - go :: Integer -> [Term] -> Term - go _ [] = mkApps pureTm [Right (mkTyConApp vecTc [LitTy (NumTy 0),bTy]) - ,Left (mkApps (Data nilCon) - [Right (LitTy (NumTy 0)) - ,Right bTy - ,Left (Prim "_CO_" nilCoTy)])] - - go n (x:xs) = mkApps apTm - [Right (mkTyConApp vecTc [LitTy (NumTy (n-1)),bTy]) - ,Right (mkTyConApp vecTc [LitTy (NumTy n),bTy]) - ,Left (mkApps fmapTm [Right bTy - ,Right (mkFunTy (mkTyConApp vecTc [LitTy (NumTy (n-1)),bTy]) - (mkTyConApp vecTc [LitTy (NumTy n),bTy])) - ,Left (mkApps (Data consCon) - [Right (LitTy (NumTy n)) - ,Right bTy - ,Right (LitTy (NumTy (n-1))) - ,Left (Prim "_CO_" (consCoTy n)) - ]) - ,Left x]) - ,Left (go (n-1) xs)] - - nilCoTy = head (Maybe.fromJust (dataConInstArgTys nilCon [(LitTy (NumTy 0)) - ,bTy])) - - consCoTy n = head (Maybe.fromJust (dataConInstArgTys consCon - [(LitTy (NumTy n)) - ,bTy - ,(LitTy (NumTy (n-1)))])) - --- | Replace an application of the @CLaSH.Sized.Vector.foldr@ primitive on --- vectors of a known length @n@, by the fully unrolled recursive "definition" --- of @CLaSH.Sized.Vector.foldr@ -reduceFoldr :: Integer -- ^ Length of the vector - -> Type -- ^ Element type of the argument vector - -> Term -- ^ The function to fold with - -> Term -- ^ The starting value - -> Term -- ^ The argument vector - -> NormalizeSession Term -reduceFoldr n aTy fun start arg = do - tcm <- Lens.view tcCache - ty <- termType tcm arg - go tcm ty - where - go tcm (coreView tcm -> Just ty') = go tcm ty' - go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- HashMap.lookup vecTcNm tcm - , [_,consCon] <- tyConDataCons vecTc - = let (vars,elems) = second concat . unzip - $ extractElems consCon aTy 'G' n arg - lbody = foldr (\l r -> mkApps fun [Left l,Left r]) start vars - lb = Letrec (bind (rec (init elems)) lbody) - in changed lb - go _ ty = error $ $(curLoc) ++ "reduceFoldr: argument does not have a vector type: " ++ showDoc ty - --- | Replace an application of the @CLaSH.Sized.Vector.fold@ primitive on --- vectors of a known length @n@, by the fully unrolled recursive "definition" --- of @CLaSH.Sized.Vector.fold@ -reduceFold :: Integer -- ^ Length of the vector - -> Type -- ^ Element type of the argument vector - -> Term -- ^ The function to fold with - -> Term -- ^ The argument vector - -> NormalizeSession Term -reduceFold n aTy fun arg = do - tcm <- Lens.view tcCache - ty <- termType tcm arg - go tcm ty - where - go tcm (coreView tcm -> Just ty') = go tcm ty' - go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- HashMap.lookup vecTcNm tcm - , [_,consCon] <- tyConDataCons vecTc - = let (vars,elems) = second concat . unzip - $ extractElems consCon aTy 'F' n arg - lbody = foldV vars - lb = Letrec (bind (rec (init elems)) lbody) - in changed lb - go _ ty = error $ $(curLoc) ++ "reduceFold: argument does not have a vector type: " ++ showDoc ty - - foldV [a] = a - foldV as = let (l,r) = splitAt (length as `div` 2) as - lF = foldV l - rF = foldV r - in mkApps fun [Left lF, Left rF] - --- | Replace an application of the @CLaSH.Sized.Vector.dfold@ primitive on --- vectors of a known length @n@, by the fully unrolled recursive "definition" --- of @CLaSH.Sized.Vector.dfold@ -reduceDFold :: Integer -- ^ Length of the vector - -> Type -- ^ Element type of the argument vector - -> Term -- ^ Function to fold with - -> Term -- ^ Starting value - -> Term -- ^ The vector to fold - -> NormalizeSession Term -reduceDFold n aTy fun start arg = do - tcm <- Lens.view tcCache - ty <- termType tcm arg - go tcm ty - where - go tcm (coreView tcm -> Just ty') = go tcm ty' - go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- HashMap.lookup vecTcNm tcm - , [_,consCon] <- tyConDataCons vecTc - = do - let (vars,elems) = second concat . unzip - $ extractElems consCon aTy 'D' n arg - (_ltv:Right snTy:_,_) <- splitFunForallTy <$> termType tcm fun - let (TyConApp snatTcNm _) = tyView snTy - (Just snatTc) = HashMap.lookup snatTcNm tcm - [snatDc] = tyConDataCons snatTc - buildSNat i = mkApps (Data snatDc) - [Right (LitTy (NumTy i)) - ,Left (Literal (IntegerLiteral (toInteger i))) - ] - lbody = doFold buildSNat (n-1) vars - lb = Letrec (bind (rec (init elems)) lbody) - changed lb - go _ ty = error $ $(curLoc) ++ "reduceDFold: argument does not have a vector type: " ++ showDoc ty - - doFold _ _ [] = start - doFold snDc k (x:xs) = mkApps fun - [Right (LitTy (NumTy k)) - ,Left (snDc k) - ,Left x - ,Left (doFold snDc (k-1) xs) - ] - --- | Replace an application of the @CLaSH.Sized.Vector.head@ primitive on --- vectors of a known length @n@, by a projection of the first element of a --- vector. -reduceHead :: Integer -- ^ Length of the vector - -> Type -- ^ Element type of the vector - -> Term -- ^ The argument vector - -> NormalizeSession Term -reduceHead n aTy vArg = do - tcm <- Lens.view tcCache - ty <- termType tcm vArg - go tcm ty - where - go tcm (coreView tcm -> Just ty') = go tcm ty' - go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- HashMap.lookup vecTcNm tcm - , [_,consCon] <- tyConDataCons vecTc - = let (vars,elems) = second concat . unzip - $ extractElems consCon aTy 'H' n vArg - lb = Letrec (bind (rec [head elems]) (head vars)) - in changed lb - go _ ty = error $ $(curLoc) ++ "reduceHead: argument does not have a vector type: " ++ showDoc ty - --- | Replace an application of the @CLaSH.Sized.Vector.tail@ primitive on --- vectors of a known length @n@, by a projection of the tail of a --- vector. -reduceTail :: Integer -- ^ Length of the vector - -> Type -- ^ Element type of the vector - -> Term -- ^ The argument vector - -> NormalizeSession Term -reduceTail n aTy vArg = do - tcm <- Lens.view tcCache - ty <- termType tcm vArg - go tcm ty - where - go tcm (coreView tcm -> Just ty') = go tcm ty' - go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- HashMap.lookup vecTcNm tcm - , [_,consCon] <- tyConDataCons vecTc - = let (_,elems) = second concat . unzip - $ extractElems consCon aTy 'L' n vArg - b@(tB,_) = elems !! 1 - lb = Letrec (bind (rec [b]) (idToVar tB)) - in changed lb - go _ ty = error $ $(curLoc) ++ "reduceTail: argument does not have a vector type: " ++ showDoc ty - --- | Replace an application of the @CLaSH.Sized.Vector.last@ primitive on --- vectors of a known length @n@, by a projection of the last element of a --- vector. -reduceLast :: Integer -- ^ Length of the vector - -> Type -- ^ Element type of the vector - -> Term -- ^ The argument vector - -> NormalizeSession Term -reduceLast n aTy vArg = do - tcm <- Lens.view tcCache - ty <- termType tcm vArg - go tcm ty - where - go tcm (coreView tcm -> Just ty') = go tcm ty' - go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- HashMap.lookup vecTcNm tcm - , [_,consCon] <- tyConDataCons vecTc - = let (_,elems) = unzip - $ extractElems consCon aTy 'L' n vArg - (tB,_) = head (last elems) - in case n of - 0 -> changed (mkApps (Prim "CLaSH.Transformations.undefined" undefinedTy) [Right aTy]) - _ -> changed (Letrec (bind (rec (init (concat elems))) (idToVar tB))) - go _ ty = error $ $(curLoc) ++ "reduceLast: argument does not have a vector type: " ++ showDoc ty - --- | Replace an application of the @CLaSH.Sized.Vector.init@ primitive on --- vectors of a known length @n@, by a projection of the init of a --- vector. -reduceInit :: Integer -- ^ Length of the vector - -> Type -- ^ Element type of the vector - -> Term -- ^ The argument vector - -> NormalizeSession Term -reduceInit n aTy vArg = do - tcm <- Lens.view tcCache - ty <- termType tcm vArg - go tcm ty - where - go tcm (coreView tcm -> Just ty') = go tcm ty' - go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- HashMap.lookup vecTcNm tcm - , [nilCon,consCon] <- tyConDataCons vecTc - = let (_,elems) = unzip - $ extractElems consCon aTy 'L' n vArg - in case n of - 0 -> changed (mkApps (Prim "CLaSH.Transformations.undefined" undefinedTy) [Right aTy]) - 1 -> changed (mkVec nilCon consCon aTy 0 []) - _ -> let el = init elems - iv = mkVec nilCon consCon aTy (n-1) (map (idToVar . fst . head) el) - lb = rec (init (concat el)) - in changed (Letrec (bind lb iv)) - - go _ ty = error $ $(curLoc) ++ "reduceInit: argument does not have a vector type: " ++ showDoc ty - --- | Replace an application of the @CLaSH.Sized.Vector.(++)@ primitive on --- vectors of a known length @n@, by the fully unrolled recursive "definition" --- of @CLaSH.Sized.Vector.(++)@ -reduceAppend :: Integer -- ^ Length of the LHS arg - -> Integer -- ^ Lenght of the RHS arg - -> Type -- ^ Element type of the vectors - -> Term -- ^ The LHS argument - -> Term -- ^ The RHS argument - -> NormalizeSession Term -reduceAppend n m aTy lArg rArg = do - tcm <- Lens.view tcCache - ty <- termType tcm lArg - go tcm ty - where - go tcm (coreView tcm -> Just ty') = go tcm ty' - go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- HashMap.lookup vecTcNm tcm - , [_,consCon] <- tyConDataCons vecTc - = let (vars,elems) = second concat . unzip - $ extractElems consCon aTy 'C' n lArg - lbody = appendToVec consCon aTy rArg (n+m) vars - lb = Letrec (bind (rec (init elems)) lbody) - in changed lb - go _ ty = error $ $(curLoc) ++ "reduceAppend: argument does not have a vector type: " ++ showDoc ty - --- | Replace an application of the @CLaSH.Sized.Vector.unconcat@ primitive on --- vectors of a known length @n@, by the fully unrolled recursive "definition" --- of @CLaSH.Sized.Vector.unconcat@ -reduceUnconcat :: Integer -- ^ Length of the result vector - -> Integer -- ^ Length of the elements of the result vector - -> Type -- ^ Element type - -> Term -- ^ Argument vector - -> NormalizeSession Term -reduceUnconcat n 0 aTy arg = do - tcm <- Lens.view tcCache - ty <- termType tcm arg - go tcm ty - where - go tcm (coreView tcm -> Just ty') = go tcm ty' - go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- HashMap.lookup vecTcNm tcm - , [nilCon,consCon] <- tyConDataCons vecTc - = let nilVec = mkVec nilCon consCon aTy 0 [] - innerVecTy = mkTyConApp vecTcNm [LitTy (NumTy 0), aTy] - retVec = mkVec nilCon consCon innerVecTy n (replicate (fromInteger n) nilVec) - in changed retVec - go _ ty = error $ $(curLoc) ++ "reduceUnconcat: argument does not have a vector type: " ++ showDoc ty - -reduceUnconcat _ _ _ _ = error $ $(curLoc) ++ "reduceUnconcat: unimplemented" - --- | Replace an application of the @CLaSH.Sized.Vector.transpose@ primitive on --- vectors of a known length @n@, by the fully unrolled recursive "definition" --- of @CLaSH.Sized.Vector.transpose@ -reduceTranspose :: Integer -- ^ Length of the result vector - -> Integer -- ^ Length of the elements of the result vector - -> Type -- ^ Element type - -> Term -- ^ Argument vector - -> NormalizeSession Term -reduceTranspose n 0 aTy arg = do - tcm <- Lens.view tcCache - ty <- termType tcm arg - go tcm ty - where - go tcm (coreView tcm -> Just ty') = go tcm ty' - go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- HashMap.lookup vecTcNm tcm - , [nilCon,consCon] <- tyConDataCons vecTc - = let nilVec = mkVec nilCon consCon aTy 0 [] - innerVecTy = mkTyConApp vecTcNm [LitTy (NumTy 0), aTy] - retVec = mkVec nilCon consCon innerVecTy n (replicate (fromInteger n) nilVec) - in changed retVec - go _ ty = error $ $(curLoc) ++ "reduceTranspose: argument does not have a vector type: " ++ showDoc ty - -reduceTranspose _ _ _ _ = error $ $(curLoc) ++ "reduceTranspose: unimplemented" - -reduceReplicate :: Integer - -> Type - -> Type - -> Term - -> NormalizeSession Term -reduceReplicate n aTy eTy arg = do - tcm <- Lens.view tcCache - go tcm eTy - where - go tcm (coreView tcm -> Just ty') = go tcm ty' - go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- HashMap.lookup vecTcNm tcm - , [nilCon,consCon] <- tyConDataCons vecTc - = let retVec = mkVec nilCon consCon aTy n (replicate (fromInteger n) arg) - in changed retVec - go _ ty = error $ $(curLoc) ++ "reduceReplicate: argument does not have a vector type: " ++ showDoc ty - --- | Replace an application of the @CLaSH.Sized.Vector.dtfold@ primitive on --- vectors of a known length @n@, by the fully unrolled recursive "definition" --- of @CLaSH.Sized.Vector.dtfold@ -reduceDTFold :: Integer -- ^ Length of the vector - -> Type -- ^ Element type of the argument vector - -> Term -- ^ Function to convert elements with - -> Term -- ^ Function to combine branches with - -> Term -- ^ The vector to fold - -> NormalizeSession Term -reduceDTFold n aTy lrFun brFun arg = do - tcm <- Lens.view tcCache - ty <- termType tcm arg - go tcm ty - where - go tcm (coreView tcm -> Just ty') = go tcm ty' - go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- HashMap.lookup vecTcNm tcm - , [_,consCon] <- tyConDataCons vecTc - = do let (vars,elems) = second concat . unzip - $ extractElems consCon aTy 'T' (2^n) arg - (_ltv:Right snTy:_,_) <- splitFunForallTy <$> termType tcm brFun - let (TyConApp snatTcNm _) = tyView snTy - (Just snatTc) = HashMap.lookup snatTcNm tcm - [snatDc] = tyConDataCons snatTc - buildSNat i = mkApps (Data snatDc) - [Right (LitTy (NumTy i)) - ,Left (Literal (IntegerLiteral i)) - ] - lbody = doFold buildSNat (n-1) vars - lb = Letrec (bind (rec (init elems)) lbody) - changed lb - go _ ty = error $ $(curLoc) ++ "reduceDTFold: argument does not have a vector type: " ++ showDoc ty - - doFold :: (Integer -> Term) -> Integer -> [Term] -> Term - doFold _ _ [x] = mkApps lrFun [Left x] - doFold snDc k xs = - let (xsL,xsR) = splitAt (2^k) xs - k' = k-1 - eL = doFold snDc k' xsL - eR = doFold snDc k' xsR - in mkApps brFun [Right (LitTy (NumTy k)) - ,Left (snDc k) - ,Left eL - ,Left eR - ] - --- | Replace an application of the @CLaSH.Sized.RTree.tdfold@ primitive on --- trees of a known depth @n@, by the fully unrolled recursive "definition" --- of @CLaSH.Sized.RTree.tdfold@ -reduceTFold :: Integer -- ^ Depth of the tree - -> Type -- ^ Element type of the argument tree - -> Term -- ^ Function to convert elements with - -> Term -- ^ Function to combine branches with - -> Term -- ^ The tree to fold - -> NormalizeSession Term -reduceTFold n aTy lrFun brFun arg = do - tcm <- Lens.view tcCache - ty <- termType tcm arg - go tcm ty - where - go tcm (coreView tcm -> Just ty') = go tcm ty' - go tcm (tyView -> TyConApp treeTcNm _) - | (Just treeTc) <- HashMap.lookup treeTcNm tcm - , [lrCon,brCon] <- tyConDataCons treeTc - = do let (vars,elems) = extractTElems lrCon brCon aTy 'T' n arg - (_ltv:Right snTy:_,_) <- splitFunForallTy <$> termType tcm brFun - let (TyConApp snatTcNm _) = tyView snTy - (Just snatTc) = HashMap.lookup snatTcNm tcm - [snatDc] = tyConDataCons snatTc - buildSNat i = mkApps (Data snatDc) - [Right (LitTy (NumTy i)) - ,Left (Literal (IntegerLiteral i)) - ] - lbody = doFold buildSNat (n-1) vars - lb = Letrec (bind (rec elems) lbody) - changed lb - go _ ty = error $ $(curLoc) ++ "reduceTFold: argument does not have a tree type: " ++ showDoc ty - - doFold _ _ [x] = mkApps lrFun [Left x] - doFold snDc k xs = - let (xsL,xsR) = splitAt (length xs `div` 2) xs - k' = k-1 - eL = doFold snDc k' xsL - eR = doFold snDc k' xsR - in mkApps brFun [Right (LitTy (NumTy k)) - ,Left (snDc k) - ,Left eL - ,Left eR - ] - -reduceTReplicate :: Integer -- ^ Depth of the tree - -> Type -- ^ Element type - -> Type -- ^ Result type - -> Term -- ^ Element - -> NormalizeSession Term -reduceTReplicate n aTy eTy arg = do - tcm <- Lens.view tcCache - go tcm eTy - where - go tcm (coreView tcm -> Just ty') = go tcm ty' - go tcm (tyView -> TyConApp treeTcNm _) - | (Just treeTc) <- HashMap.lookup treeTcNm tcm - , [lrCon,brCon] <- tyConDataCons treeTc - = let retVec = mkRTree lrCon brCon aTy n (replicate (2^n) arg) - in changed retVec - go _ ty = error $ $(curLoc) ++ "reduceTReplicate: argument does not have a vector type: " ++ showDoc ty diff --git a/src/CLaSH/Normalize/Strategy.hs b/src/CLaSH/Normalize/Strategy.hs deleted file mode 100644 --- a/src/CLaSH/Normalize/Strategy.hs +++ /dev/null @@ -1,218 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Transformation process for normalization --} - -module CLaSH.Normalize.Strategy where - -import CLaSH.Normalize.Transformations -import CLaSH.Normalize.Types -import CLaSH.Rewrite.Combinators -import CLaSH.Rewrite.Types -import CLaSH.Rewrite.Util - --- | Normalisation transformation -normalization :: NormRewrite -normalization = rmDeadcode >-> constantPropgation >-> etaTL >-> rmUnusedExpr >-!-> anf >-!-> rmDeadcode >-> - bindConst >-> letTL >-> evalConst >-!-> cse >-!-> recLetRec - where - etaTL = apply "etaTL" etaExpansionTL !-> innerMost (apply "applicationPropagation" appProp) - anf = topdownR (apply "nonRepANF" nonRepANF) >-> apply "ANF" makeANF - letTL = topdownSucR (apply "topLet" topLet) - recLetRec = apply "recToLetRec" recToLetRec - rmUnusedExpr = bottomupR (apply "removeUnusedExpr" removeUnusedExpr) - rmDeadcode = bottomupR (apply "deadcode" deadCode) - bindConst = topdownR (apply "bindConstantVar" bindConstantVar) - evalConst = topdownR (apply "evalConst" reduceConst) - cse = topdownR (apply "CSE" simpleCSE) - - -constantPropgation :: NormRewrite -constantPropgation = propagate >-> repeatR inlineAndPropagate >-> - caseFlattening >-> dec >-> spec >-> dec >-> - conSpec - where - propagate = innerMost (applyMany transPropagate) - inlineAndPropagate = (topdownR (applyMany transInlineSafe) >-> inlineNR) - !-> propagate - spec = bottomupR (applyMany specTransformations) - caseFlattening = repeatR (topdownR (apply "caseFlat" caseFlat)) - dec = repeatR (topdownR (apply "DEC" disjointExpressionConsolidation)) - conSpec = bottomupR (apply "constantSpec" constantSpec) - - transPropagate :: [(String,NormRewrite)] - transPropagate = - [ ("applicationPropagation", appProp ) - , ("bindConstantVar" , bindConstantVar) - , ("caseLet" , caseLet ) - , ("caseCase" , caseCase ) - , ("caseCon" , caseCon ) - ] - - -- These transformations can safely be applied in a top-down traversal as - -- they themselves check whether the to-be-inlined binder is recursive or not. - transInlineSafe :: [(String,NormRewrite)] - transInlineSafe = - [ ("inlineClosed" , inlineClosed) - , ("inlineSmall" , inlineSmall) - , ("bindOrLiftNonRep", inlineOrLiftNonRep) -- See: [Note] bindNonRep before liftNonRep - -- See: [Note] bottom-up traversal for liftNonRep - , ("reduceNonRepPrim", reduceNonRepPrim) - ] - - -- InlineNonRep cannot be applied in a top-down traversal, as the non-representable - -- binder might be recursive. The idea is, is that if the recursive - -- non-representable binder is inlined once, we can get rid of the recursive - -- aspect using the case-of-known-constructor - inlineNR :: NormRewrite - inlineNR = bottomupR (apply "inlineNonRep" inlineNonRep) - - specTransformations :: [(String,NormRewrite)] - specTransformations = - [ ("typeSpec" , typeSpec) - , ("nonRepSpec" , nonRepSpec) - ] - -{- [Note] bottom-up traversal for liftNonRep -We used to say: - -"The liftNonRep transformation must be applied in a topDown traversal because -of what CLaSH considers tail calls in its join-point analysis." - -Consider: - -> let fail = \x -> ... -> in case ... of -> A -> let fail1 = \y -> case ... of -> X -> fail ... -> Y -> ... -> in case ... of -> P -> fail1 ... -> Q -> ... -> B -> fail ... - -under "normal" tail call rules, the local 'fail' functions is not a join-point -because it is used in a let-binding. However, we apply "special" tail call rules -in CLaSH. Because 'fail' is used in a TC position within 'fail1', and 'fail1' is -only used in a TC position, in CLaSH, we consider 'tail' also only to be used -in a TC position. - -Now image we apply 'liftNonRep' in a bottom up traversal, we will end up with: - -> fail1 = \fail y -> case ... of -> X -> fail ... -> Y -> ... - -> let fail = \x -> ... -> in case ... of -> A -> case ... of -> P -> fail1 fail ... -> Q -> ... -> B -> fail ... - -Suddenly, 'fail' ends up in an argument position, because it occurred as a -_locally_ bound variable within 'fail1'. And because of that 'fail' stops being -a join-point. - -However, when we apply 'liftNonRep' in a top down traversal we end up with: - -> fail = \x -> ... -> -> fail1 = \y -> case ... of -> X -> fail ... -> Y -> ... -> -> let ... -> in case ... of -> A -> let -> in case ... of -> P -> fail1 ... -> Q -> ... -> B -> fail ... - -and all is well with the world. - -UPDATE: -We can now just perform liftNonRep in a bottom-up traversal again, because -liftNonRep no longer checks that if the binding that is lifted is a join-point. -However, for this to work, bindNonRep must always have been exhaustively applied -before liftNonRep. See also: [Note] bindNonRep before liftNonRep. --} - -{- [Note] bindNonRep before liftNonRep -The combination of liftNonRep and nonRepSpec can lead to non-termination in an -unchecked rewrite system (without termination measures in place) on the -following: - -> main = f not -> f = \a x -> (a x) && (f a x) - -nonRepSpec will lead to: - -> main = f' -> f = \a x -> (a x) && (f a x) -> f' = (\a x -> (a x) && (f a x)) not - -then lamApp leads to: - -> main = f' -> f = \a x -> (a x) && (f a x) -> f' = let a = not in (\x -> (a x) && (f a x)) - -then liftNonRep leads to: - -> main = f' -> f = \a x -> (a x) && (f a x) -> f' = \x -> (g x) && (f g x) -> g = not - -and nonRepSepc leads to: - -> main = f' -> f = \a x -> (a x) && (f a x) -> f' = \x -> (g x) && (f'' g x) -> g = not -> f'' = (\a x -> (a x) && (f a x)) g - -This cycle continues indefinitely, as liftNonRep creates a new global variable, -which is never alpha-equivalent to the previous global variable introduced by -liftNonRep. - -That is why bindNonRep must always be applied before liftNonRep. When we end up -in the situation after lamApp: - -> main = f' -> f = \a x -> (a x) && (f a x) -> f' = let a = not in (\x -> (a x) && (f a x)) - -bindNonRep will now lead to: - -> main = f' -> f = \a x -> (a x) && (f a x) -> f' = \x -> (not x) && (f not x) - -Because `f` has already been specialised on the alpha-equivalent-to-itself `not` -function, liftNonRep leads to: - -> main = f' -> f = \a x -> (a x) && (f a x) -> f' = \x -> (not x) && (f' x) - -And there is no non-terminating rewriting cycle. - -That is why bindNonRep must always be exhaustively applied before we apply -liftNonRep. --} - --- | Topdown traversal, stops upon first success -topdownSucR :: Rewrite extra -> Rewrite extra -topdownSucR r = r >-! (allR True (topdownSucR r)) - -innerMost :: Rewrite extra -> Rewrite extra -innerMost r = bottomupR (r !-> innerMost r) - -applyMany :: [(String,Rewrite extra)] -> Rewrite extra -applyMany = foldr1 (>->) . map (uncurry apply) diff --git a/src/CLaSH/Normalize/Transformations.hs b/src/CLaSH/Normalize/Transformations.hs deleted file mode 100644 --- a/src/CLaSH/Normalize/Transformations.hs +++ /dev/null @@ -1,1244 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Transformations of the Normalization process --} - -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} - -module CLaSH.Normalize.Transformations - ( appProp - , caseLet - , caseCon - , caseCase - , inlineNonRep - , inlineOrLiftNonRep - , typeSpec - , nonRepSpec - , etaExpansionTL - , nonRepANF - , bindConstantVar - , constantSpec - , makeANF - , deadCode - , topLet - , recToLetRec - , inlineClosed - , inlineHO - , inlineSmall - , simpleCSE - , reduceConst - , reduceNonRepPrim - , caseFlat - , disjointExpressionConsolidation - , removeUnusedExpr - ) -where - -import qualified Control.Lens as Lens -import qualified Control.Monad as Monad -import Control.Monad.Writer (WriterT (..), lift, tell) -import Control.Monad.Trans.Except (runExcept) -import Data.Bits ((.&.), complement) -import qualified Data.Either as Either -import qualified Data.HashMap.Lazy as HashMap -import qualified Data.List as List -import qualified Data.Maybe as Maybe -import qualified Data.Set as Set -import qualified Data.Set.Lens as Lens -import Data.Text (Text, unpack) -import Unbound.Generics.LocallyNameless (Bind, Embed (..), bind, embed, - rec, unbind, unembed, unrebind, - unrec, name2String) -import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) - -import CLaSH.Core.DataCon (DataCon (..)) -import CLaSH.Core.FreeVars (termFreeIds, termFreeTyVars, - typeFreeVars) -import CLaSH.Core.Pretty (showDoc) -import CLaSH.Core.Subst (substTm, substTms, substTyInTm, - substTysinTm) -import CLaSH.Core.Term (LetBinding, Pat (..), Term (..)) -import CLaSH.Core.Type (TypeView (..), applyFunTy, - applyTy, isPolyFunCoreTy, - splitFunTy, typeKind, - tyView, undefinedTy) -import CLaSH.Core.TyCon (tyConDataCons) -import CLaSH.Core.Util (collectArgs, idToVar, isCon, - isFun, isLet, isPolyFun, isPrim, - isSignalType, isVar, mkApps, - mkLams, mkTmApps, mkVec, - termSize, termType, tyNatSize) -import CLaSH.Core.Var (Id, Var (..)) -import CLaSH.Netlist.BlackBox.Util (usedArguments) -import CLaSH.Netlist.Util (representableType, - splitNormalized) -import CLaSH.Normalize.DEC -import CLaSH.Normalize.PrimitiveReductions -import CLaSH.Normalize.Types -import CLaSH.Normalize.Util -import CLaSH.Primitives.Types (Primitive (..)) -import CLaSH.Rewrite.Combinators -import CLaSH.Rewrite.Types -import CLaSH.Rewrite.Util -import CLaSH.Util - -inlineOrLiftNonRep :: NormRewrite -inlineOrLiftNonRep = inlineOrLiftBinders nonRepTest inlineTest - where - nonRepTest :: (Var Term, Embed Term) -> RewriteMonad extra Bool - nonRepTest ((Id _ tyE), _) - = not <$> (representableType <$> Lens.view typeTranslator - <*> Lens.view allowZero - <*> Lens.view tcCache - <*> pure (unembed tyE)) - nonRepTest _ = return False - - inlineTest :: Term -> (Var Term, Embed Term) -> RewriteMonad extra Bool - inlineTest e (id_@(Id idName _), exprE) - = let e' = unembed exprE - in not <$> ((||) <$> (elem idName <$> (Lens.toListOf <$> localFreeIds <*> pure e')) - -- See: [Note] join points and void wrappers - <*> pure (isJoinPointIn id_ e && not (isVoidWrapper e'))) - - inlineTest _ _ = return True - -{- [Note] join points and void wrappers -Join points are functions that only occur in tail-call positions within an -expression, and only when they occur in a tail-call position more than once. - -Normally bindNonRep binds/inlines all non-recursive local functions. However, -doing so for join points would significantly increase compilation time, so we -avoid it. The only exception to this rule are so-called void wrappers. Void -wrappers are functions of the form: - -> \(w :: Void) -> f a b c - -i.e. a wrapper around the function 'f' where the argument 'w' is not used. We -do bind/line these join-points because these void-wrappers interfere with the -'disjoint expression consolidation' (DEC) and 'common sub-expression elimination' -(CSE) transformation, sometimes resulting in circuits that are twice as big -as they'd need to be. --} - --- | Specialize functions on their type -typeSpec :: NormRewrite -typeSpec ctx e@(TyApp e1 ty) - | (Var _ _, args) <- collectArgs e1 - , null $ Lens.toListOf typeFreeVars ty - , (_, []) <- Either.partitionEithers args - = specializeNorm ctx e - -typeSpec _ e = return e - --- | Specialize functions on their non-representable argument -nonRepSpec :: NormRewrite -nonRepSpec ctx e@(App e1 e2) - | (Var _ _, args) <- collectArgs e1 - , (_, []) <- Either.partitionEithers args - , null $ Lens.toListOf termFreeTyVars e2 - = do tcm <- Lens.view tcCache - e2Ty <- termType tcm e2 - localVar <- isLocalVar e2 - nonRepE2 <- not <$> (representableType <$> Lens.view typeTranslator <*> Lens.view allowZero <*> Lens.view tcCache <*> pure e2Ty) - if nonRepE2 && not localVar - then specializeNorm ctx e - else return e - -nonRepSpec _ e = return e - --- | Lift the let-bindings out of the subject of a Case-decomposition -caseLet :: NormRewrite -caseLet _ (Case (Letrec b) ty alts) = do - (xes,e) <- unbind b - changed (Letrec (bind xes (Case e ty alts))) - -caseLet _ e = return e - --- | Move a Case-decomposition from the subject of a Case-decomposition to the alternatives -caseCase :: NormRewrite -caseCase _ e@(Case (Case scrut alts1Ty alts1) alts2Ty alts2) - = do - ty1Rep <- representableType <$> Lens.view typeTranslator <*> Lens.view allowZero <*> Lens.view tcCache <*> pure alts1Ty - if not ty1Rep - then do newAlts <- mapM ( return - . uncurry bind - . second (\altE -> Case altE alts2Ty alts2) - <=< unbind - ) alts1 - changed $ Case scrut alts2Ty newAlts - else return e - -caseCase _ e = return e - --- | Inline function with a non-representable result if it's the subject --- of a Case-decomposition -inlineNonRep :: NormRewrite -inlineNonRep _ e@(Case scrut altsTy alts) - | (Var _ f, args) <- collectArgs scrut - = do - (cf,_) <- Lens.use curFun - isInlined <- zoomExtra (alreadyInlined f cf) - limit <- Lens.use (extra.inlineLimit) - tcm <- Lens.view tcCache - scrutTy <- termType tcm scrut - let noException = not (exception tcm scrutTy) - if noException && (Maybe.fromMaybe 0 isInlined) > limit - then do - ty <- termType tcm scrut - traceIf True (concat [$(curLoc) ++ "InlineNonRep: " ++ show f - ," already inlined " ++ show limit ++ " times in:" - , show cf - , "\nType of the subject is: " ++ showDoc ty - , "\nFunction " ++ show cf - , " will not reach a normal form, and compilation" - , " might fail." - , "\nRun with '-clash-inline-limit=N' to increase" - , " the inlining limit to N." - ]) - (return e) - else do - bodyMaybe <- fmap (HashMap.lookup f) $ Lens.use bindings - nonRepScrut <- not <$> (representableType <$> Lens.view typeTranslator <*> Lens.view allowZero <*> Lens.view tcCache <*> pure scrutTy) - case (nonRepScrut, bodyMaybe) of - (True,Just (_,_,scrutBody)) -> do - Monad.when noException (zoomExtra (addNewInline f cf)) - changed $ Case (mkApps scrutBody args) altsTy alts - _ -> return e - where - exception tcm ((tyView . typeKind tcm) -> TyConApp (name2String -> "GHC.Types.Constraint") _) = True - exception _ _ = False - -inlineNonRep _ e = return e - --- | Specialize a Case-decomposition (replace by the RHS of an alternative) if --- the subject is (an application of) a DataCon; or if there is only a single --- alternative that doesn't reference variables bound by the pattern. -caseCon :: NormRewrite -caseCon _ (Case scrut ty alts) - | (Data dc, args) <- collectArgs scrut - = do - alts' <- mapM unbind alts - let dcAltM = List.find (equalCon dc . fst) alts' - case dcAltM of - Just (DataPat _ pxs, e) -> - let (tvs,xs) = unrebind pxs - fvs = Lens.toListOf termFreeIds e - (binds,_) = List.partition ((`elem` fvs) . varName . fst) - $ zip xs (Either.lefts args) - e' = case binds of - [] -> e - _ -> Letrec $ bind (rec $ map (second embed) binds) e - substTyMap = zip (map varName tvs) (drop (length $ dcUnivTyVars dc) (Either.rights args)) - in changed (substTysinTm substTyMap e') - _ -> case alts' of - ((DefaultPat,e):_) -> changed e - _ -> changed (mkApps (Prim "CLaSH.Transformations.undefined" undefinedTy) [Right ty]) - where - equalCon dc (DataPat dc' _) = dcTag dc == dcTag (unembed dc') - equalCon _ _ = False - -caseCon _ c@(Case (Literal l) _ alts) = do - alts' <- mapM unbind alts - let ltAltsM = List.find (equalLit . fst) alts' - case ltAltsM of - Just (LitPat _,e) -> changed e - _ -> case alts' of - ((DefaultPat,e):_) -> changed e - _ -> error $ $(curLoc) ++ "Report as bug: caseCon error: " ++ showDoc c - where - equalLit (LitPat l') = l == (unembed l') - equalLit _ = False - -caseCon ctx e@(Case subj ty alts) - | isConstant subj = do - tcm <- Lens.view tcCache - lvl <- Lens.view dbgLevel - reduceConstant <- Lens.view evaluator - case reduceConstant tcm True subj of - Literal l -> caseCon ctx (Case (Literal l) ty alts) - subj' -> case collectArgs subj' of - (Data _,_) -> caseCon ctx (Case subj' ty alts) - (Prim nm ty',repTy:_:msgOrCallStack:_) - | nm `elem` ["Control.Exception.Base.patError" - ,"Control.Exception.Base.absentError" - ,"GHC.Err.undefined"] -> - let e' = mkApps (Prim nm ty') [repTy,Right ty,msgOrCallStack] - in changed e' - (Prim nm ty',[_]) - | nm `elem` ["CLaSH.Transformations.undefined"] -> - let e' = mkApps (Prim nm ty') [Right ty] - in changed e' - (Prim nm _,[]) - | nm `elem` ["EmptyCase"] -> - changed (Prim nm ty) - _ -> traceIf (lvl > DebugNone) - ("Irreducible constant as case subject: " ++ showDoc subj ++ "\nCan be reduced to: " ++ showDoc subj') - (caseOneAlt e) - -caseCon _ e = caseOneAlt e - -caseOneAlt :: Term -> RewriteMonad extra Term -caseOneAlt e@(Case _ _ [alt]) = do - (pat,altE) <- unbind alt - case pat of - DefaultPat -> changed altE - LitPat _ -> changed altE - DataPat _ pxs -> let (tvs,xs) = unrebind pxs - ftvs = Lens.toListOf termFreeTyVars altE - fvs = Lens.toListOf termFreeIds altE - usedTvs = filter ((`elem` ftvs) . varName) tvs - usedXs = filter ((`elem` fvs) . varName) xs - in case (usedTvs,usedXs) of - ([],[]) -> changed altE - _ -> return e - -caseOneAlt e = return e - --- | Bring an application of a DataCon or Primitive in ANF, when the argument is --- is considered non-representable -nonRepANF :: NormRewrite -nonRepANF ctx e@(App appConPrim arg) - | (conPrim, _) <- collectArgs e - , isCon conPrim || isPrim conPrim - = do - untranslatable <- isUntranslatable arg - case (untranslatable,arg) of - (True,Letrec b) -> do (binds,body) <- unbind b - changed (Letrec (bind binds (App appConPrim body))) - (True,Case {}) -> specializeNorm ctx e - (True,Lam _) -> specializeNorm ctx e - (True,TyLam _) -> specializeNorm ctx e - _ -> return e - -nonRepANF _ e = return e - --- | Ensure that top-level lambda's eventually bind a let-expression of which --- the body is a variable-reference. -topLet :: NormRewrite -topLet ctx e - | all isLambdaBodyCtx ctx && not (isLet e) - = do - untranslatable <- isUntranslatable e - if untranslatable - then return e - else do tcm <- Lens.view tcCache - (argId,argVar) <- mkTmBinderFor tcm "result" e - changed . Letrec $ bind (rec [(argId,embed e)]) argVar - -topLet ctx e@(Letrec b) - | all isLambdaBodyCtx ctx - = do - (binds,body) <- unbind b - localVar <- isLocalVar body - untranslatable <- isUntranslatable body - if localVar || untranslatable - then return e - else do tcm <- Lens.view tcCache - (argId,argVar) <- mkTmBinderFor tcm "result" body - changed . Letrec $ bind (rec $ unrec binds ++ [(argId,embed body)]) argVar - -topLet _ e = return e - --- Misc rewrites - --- | Remove unused let-bindings -deadCode :: NormRewrite -deadCode _ e@(Letrec binds) = do - (xes, body) <- fmap (first unrec) $ unbind binds - let bodyFVs = Lens.toListOf termFreeIds body - (xesUsed,xesOther) = List.partition - ( (`elem` bodyFVs ) - . varName - . fst - ) xes - xesUsed' = findUsedBndrs [] xesUsed xesOther - if length xesUsed' /= length xes - then case xesUsed' of - [] -> changed body - _ -> changed . Letrec $ bind (rec xesUsed') body - else return e - where - findUsedBndrs :: [(Var Term, Embed Term)] -> [(Var Term, Embed Term)] - -> [(Var Term, Embed Term)] -> [(Var Term, Embed Term)] - findUsedBndrs used [] _ = used - findUsedBndrs used explore other = - let fvsUsed = concatMap (Lens.toListOf termFreeIds . unembed . snd) explore - (explore',other') = List.partition - ( (`elem` fvsUsed) - . varName - . fst - ) other - in findUsedBndrs (used ++ explore) explore' other' - -deadCode _ e = return e - -removeUnusedExpr :: NormRewrite -removeUnusedExpr _ e@(collectArgs -> (p@(Prim nm _),args)) = do - bbM <- HashMap.lookup nm <$> Lens.use (extra.primitives) - case bbM of - Just (BlackBox pNm _ _ inc templ) -> do - let usedArgs = if pNm `elem` ["CLaSH.Sized.Internal.Signed.fromInteger#" - ,"CLaSH.Sized.Internal.Unsigned.fromInteger#" - ,"CLaSH.Sized.Internal.BitVector.fromInteger#" - ,"CLaSH.Sized.Internal.Index.fromInteger#" - ] - then [0,1] - else either usedArguments usedArguments templ ++ - maybe [] (usedArguments . snd) inc - tcm <- Lens.view tcCache - args' <- go tcm 0 usedArgs args - if args == args' - then return e - else changed (mkApps p args') - _ -> return e - where - go _ _ _ [] = return [] - go tcm n used (Right ty:args') = do - args'' <- go tcm n used args' - return (Right ty : args'') - go tcm n used (Left tm : args') = do - args'' <- go tcm (n+1) used args' - ty <- termType tcm tm - let p' = mkApps (Prim "CLaSH.Transformations.removedArg" undefinedTy) [Right ty] - if n `elem` used - then return (Left tm : args'') - else return (Left p' : args'') - -removeUnusedExpr _ e@(Case _ _ [alt]) = do - (pat,altExpr) <- unbind alt - case pat of - DataPat _ (unrebind -> ([],xs)) -> do - let altFreeIds = Lens.setOf termFreeIds altExpr - if Set.null (Set.intersection (Set.fromList (map varName xs)) altFreeIds) - then changed altExpr - else return e - _ -> return e - --- Replace any expression that creates a Vector of size 0 within the application --- of the Cons constructor, by the Nil constructor. -removeUnusedExpr _ e@(collectArgs -> (Data dc, [_,Right aTy,Right nTy,_,Left a,Left nil])) - | name2String (dcName dc) == "CLaSH.Sized.Vector.Cons" - = do - tcm <- Lens.view tcCache - case runExcept (tyNatSize tcm nTy) of - Right 0 - | (con, _) <- collectArgs nil - , not (isCon con) - -> do eTy <- termType tcm e - let (TyConApp vecTcNm _) = tyView eTy - (Just vecTc) = HashMap.lookup vecTcNm tcm - [nilCon,consCon] = tyConDataCons vecTc - v = mkVec nilCon consCon aTy 1 [a] - changed v - _ -> return e - -removeUnusedExpr _ e = return e - --- | Inline let-bindings when the RHS is either a local variable reference or --- is constant -bindConstantVar :: NormRewrite -bindConstantVar = inlineBinders test - where - test _ (_,Embed e) = (||) <$> isLocalVar e <*> pure (isConstant e) - --- | Inline nullary/closed functions -inlineClosed :: NormRewrite -inlineClosed _ e@(collectArgs -> (Var _ f,args)) - | all (either isConstant (const True)) args - = do - tcm <- Lens.view tcCache - eTy <- termType tcm e - untranslatable <- isUntranslatableType eTy - let isSignal = isSignalType tcm eTy - if untranslatable || isSignal - then return e - else do - bndrs <- Lens.use bindings - case HashMap.lookup f bndrs of - -- Don't inline recursive expressions - Just (_,_,body) -> do - isRecBndr <- isRecursiveBndr f - if isRecBndr - then return e - else changed (mkApps body args) - _ -> return e - -inlineClosed _ e@(Var fTy f) = do - tcm <- Lens.view tcCache - let closed = not (isPolyFunCoreTy tcm fTy) - isSignal = isSignalType tcm fTy - untranslatable <- isUntranslatableType fTy - if closed && not untranslatable && not isSignal - then do - bndrs <- Lens.use bindings - case HashMap.lookup f bndrs of - -- Don't inline recursive expressions - Just (_,_,body) -> do - isRecBndr <- isRecursiveBndr f - if isRecBndr - then return e - else changed body - _ -> return e - else return e - -inlineClosed _ e = return e - --- | Inline small functions -inlineSmall :: NormRewrite -inlineSmall _ e@(collectArgs -> (Var _ f,args)) = do - untranslatable <- isUntranslatable e - if untranslatable - then return e - else do - bndrs <- Lens.use bindings - sizeLimit <- Lens.use (extra.inlineBelow) - case HashMap.lookup f bndrs of - -- Don't inline recursive expressions - Just (_,_,body) -> do - isRecBndr <- isRecursiveBndr f - if not isRecBndr && termSize body < sizeLimit - then changed (mkApps body args) - else return e - _ -> return e - -inlineSmall _ e = return e - --- | Specialise functions on arguments which are constant -constantSpec :: NormRewrite -constantSpec ctx e@(App e1 e2) - | (Var _ _, args) <- collectArgs e1 - , (_, []) <- Either.partitionEithers args - , null $ Lens.toListOf termFreeTyVars e2 - , isConstant e2 - = specializeNorm ctx e - -constantSpec _ e = return e - - --- Experimental - --- | Propagate arguments of application inwards; except for 'Lam' where the --- argument becomes let-bound. -appProp :: NormRewrite -appProp _ (App (Lam b) arg) = do - (v,e) <- unbind b - if isConstant arg || isVar arg - then changed $ substTm (varName v) arg e - else changed . Letrec $ bind (rec [(v,embed arg)]) e - -appProp _ (App (Letrec b) arg) = do - (v,e) <- unbind b - changed . Letrec $ bind v (App e arg) - -appProp ctx (App (Case scrut ty alts) arg) = do - tcm <- Lens.view tcCache - argTy <- termType tcm arg - let ty' = applyFunTy tcm ty argTy - if isConstant arg || isVar arg - then do - alts' <- mapM ( return - . uncurry bind - . second (`App` arg) - <=< unbind - ) alts - changed $ Case scrut ty' alts' - else do - (boundArg,argVar) <- mkTmBinderFor tcm (mkDerivedName ctx "app_arg") arg - alts' <- mapM ( return - . uncurry bind - . second (`App` argVar) - <=< unbind - ) alts - changed . Letrec $ bind (rec [(boundArg,embed arg)]) (Case scrut ty' alts') - -appProp _ (TyApp (TyLam b) t) = do - (tv,e) <- unbind b - changed $ substTyInTm (varName tv) t e - -appProp _ (TyApp (Letrec b) t) = do - (v,e) <- unbind b - changed . Letrec $ bind v (TyApp e t) - -appProp _ (TyApp (Case scrut altsTy alts) ty) = do - alts' <- mapM ( return - . uncurry bind - . second (`TyApp` ty) - <=< unbind - ) alts - tcm <- Lens.view tcCache - ty' <- applyTy tcm altsTy ty - changed $ Case scrut ty' alts' - -appProp _ e = return e - --- | Flatten ridiculous case-statements generated by GHC --- --- For case-statements in haskell of the form: --- --- @ --- f :: Unsigned 4 -> Unsigned 4 --- f x = case x of --- 0 -> 3 --- 1 -> 2 --- 2 -> 1 --- 3 -> 0 --- @ --- --- GHC generates Core that looks like: --- --- @ --- f = \(x :: Unsigned 4) -> case x == fromInteger 3 of --- False -> case x == fromInteger 2 of --- False -> case x == fromInteger 1 of --- False -> case x == fromInteger 0 of --- False -> error "incomplete case" --- True -> fromInteger 3 --- True -> fromInteger 2 --- True -> fromInteger 1 --- True -> fromInteger 0 --- @ --- --- Which would result in a priority decoder circuit where a normal decoder --- circuit was desired. --- --- This transformation transforms the above Core to the saner: --- --- @ --- f = \(x :: Unsigned 4) -> case x of --- _ -> error "incomplete case" --- 0 -> fromInteger 3 --- 1 -> fromInteger 2 --- 2 -> fromInteger 1 --- 3 -> fromInteger 0 --- @ -caseFlat :: NormRewrite -caseFlat _ e@(Case (collectArgs -> (Prim nm _,args)) ty _) - | isEq nm - = do let (Left scrut') = args !! 1 - case collectFlat scrut' e of - Just alts' -> changed (Case scrut' ty (last alts' : init alts')) - Nothing -> return e - -caseFlat _ e = return e - -collectFlat :: Term -> Term -> Maybe [Bind Pat Term] -collectFlat scrut (Case (collectArgs -> (Prim nm _,args)) _ty [lAlt,rAlt]) - | isEq nm - , scrut' == scrut - = case collectArgs val of - (Prim nm' _,args') | isFromInt nm' - -> case last args' of - Left (Literal i) -> case (unsafeUnbind lAlt,unsafeUnbind rAlt) of - ((pl,el),(pr,er)) - | isFalseDcPat pl || isTrueDcPat pr -> - case collectFlat scrut el of - Just alts' -> Just (bind (LitPat (embed i)) er : alts') - Nothing -> Just [bind (LitPat (embed i)) er - ,bind DefaultPat el - ] - | otherwise -> - case collectFlat scrut er of - Just alts' -> Just (bind (LitPat (embed i)) el : alts') - Nothing -> Just [bind (LitPat (embed i)) el - ,bind DefaultPat er - ] - _ -> Nothing - _ -> Nothing - where - (Left scrut') = args !! 1 - (Left val) = args !! 2 - - isFalseDcPat (DataPat p _) - = ((== "GHC.Types.False") . name2String . dcName . unembed) p - isFalseDcPat _ = False - - isTrueDcPat (DataPat p _) - = ((== "GHC.Types.True") . name2String . dcName . unembed) p - isTrueDcPat _ = False - -collectFlat _ _ = Nothing - -isEq :: Text -> Bool -isEq nm = nm == "CLaSH.Sized.Internal.BitVector.eq#" || - nm == "CLaSH.Sized.Internal.Index.eq#" || - nm == "CLaSH.Sized.Internal.Signed.eq#" || - nm == "CLaSH.Sized.Internal.Unsigned.eq#" - -isFromInt :: Text -> Bool -isFromInt nm = nm == "CLaSH.Sized.Internal.BitVector.fromInteger#" || - nm == "CLaSH.Sized.Internal.Index.fromInteger#" || - nm == "CLaSH.Sized.Internal.Signed.fromInteger#" || - nm == "CLaSH.Sized.Internal.Unsigned.fromInteger#" - -type NormRewriteW = Transform (WriterT [LetBinding] (RewriteMonad NormalizeState)) - --- NOTE [unsafeUnbind]: Use unsafeUnbind (which doesn't freshen pattern --- variables). Reason: previously collected expression still reference --- the 'old' variable names created by the traversal! - --- | Turn an expression into a modified ANF-form. As opposed to standard ANF, --- constants do not become let-bound. -makeANF :: NormRewrite -makeANF ctx (Lam b) = do - -- See NOTE [unsafeUnbind] - let (bndr,e) = unsafeUnbind b - e' <- makeANF (LamBody bndr:ctx) e - return $ Lam (bind bndr e') - -makeANF _ (TyLam b) = return (TyLam b) - -makeANF ctx e - = do - (e',bndrs) <- runWriterT $ bottomupR collectANF ctx e - case bndrs of - [] -> return e - _ -> changed . Letrec $ bind (rec bndrs) e' - -collectANF :: NormRewriteW -collectANF ctx e@(App appf arg) - | (conVarPrim, _) <- collectArgs e - , isCon conVarPrim || isPrim conVarPrim || isVar conVarPrim - = do - untranslatable <- lift (isUntranslatable arg) - localVar <- lift (isLocalVar arg) - case (untranslatable,localVar || isConstant arg,arg) of - (False,False,_) -> do tcm <- Lens.view tcCache - (argId,argVar) <- lift (mkTmBinderFor tcm (mkDerivedName ctx "app_arg") arg) - tell [(argId,embed arg)] - return (App appf argVar) - (True,False,Letrec b) -> do (binds,body) <- unbind b - tell (unrec binds) - return (App appf body) - _ -> return e - -collectANF _ (Letrec b) = do - -- See NOTE [unsafeUnbind] - let (binds,body) = unsafeUnbind b - tell (unrec binds) - untranslatable <- lift (isUntranslatable body) - localVar <- lift (isLocalVar body) - if localVar || untranslatable - then return body - else do - tcm <- Lens.view tcCache - (argId,argVar) <- lift (mkTmBinderFor tcm "result" body) - tell [(argId,embed body)] - return argVar - --- TODO: The code below special-cases ANF for the ':-' constructor for the --- 'Signal' type. The 'Signal' type is essentially treated as a "transparent" --- type by the CLaSH compiler, so observing its constructor leads to all kinds --- of problems. In this case that "CLaSH.Rewrite.Util.mkSelectorCase" will --- try to project the LHS and RHS of the ':-' constructor, however, --- 'mkSelectorCase' uses 'coreView' to find the "real" data-constructor. --- 'coreView' however looks through the 'Signal' type, and hence 'mkSelector' --- finds the data constructors for the element type of Signal. This resulted in --- error #24 (https://github.com/christiaanb/clash2/issues/24), where we --- try to get the first field out of the 'Vec's 'Nil' constructor. --- --- Ultimately we should stop treating Signal as a "transparent" type and deal --- handling of the Signal type, and the involved co-recursive functions, --- properly. At the moment, CLaSH cannot deal with this recursive type and the --- recursive functions involved, hence the need for special-casing code. After --- everything is done properly, we should remove the two lines below. -collectANF _ e@(Case _ _ [unsafeUnbind -> (DataPat dc _,_)]) - | name2String (dcName $ unembed dc) == "CLaSH.Signal.Internal.:-" = return e - -collectANF ctx (Case subj ty alts) = do - localVar <- lift (isLocalVar subj) - (bndr,subj') <- if localVar || isConstant subj - then return ([],subj) - else do tcm <- Lens.view tcCache - (argId,argVar) <- lift (mkTmBinderFor tcm (mkDerivedName ctx "case_scrut") subj) - return ([(argId,embed subj)],argVar) - - (binds,alts') <- fmap (first concat . unzip) $ mapM (lift . doAlt subj') alts - - tell (bndr ++ binds) - return (Case subj' ty alts') - where - doAlt :: Term -> Bind Pat Term -> RewriteMonad NormalizeState ([LetBinding],Bind Pat Term) - -- See NOTE [unsafeUnbind] - doAlt subj' = fmap (second (uncurry bind)) . doAlt' subj' . unsafeUnbind - - doAlt' :: Term -> (Pat,Term) -> RewriteMonad NormalizeState ([LetBinding],(Pat,Term)) - doAlt' subj' alt@(DataPat dc pxs@(unrebind -> ([],xs)),altExpr) = do - lv <- isLocalVar altExpr - patSels <- Monad.zipWithM (doPatBndr subj' (unembed dc)) xs [0..] - let usesXs (Var _ n) = any ((== n) . varName) xs - usesXs _ = False - if (lv && not (usesXs altExpr)) || isConstant altExpr - then return (patSels,alt) - else do tcm <- Lens.view tcCache - (altId,altVar) <- mkTmBinderFor tcm (mkDerivedName ctx "case_alt") altExpr - return ((altId,embed altExpr):patSels,(DataPat dc pxs,altVar)) - doAlt' _ alt@(DataPat _ _, _) = return ([],alt) - doAlt' _ alt@(pat,altExpr) = do - lv <- isLocalVar altExpr - if lv || isConstant altExpr - then return ([],alt) - else do tcm <- Lens.view tcCache - (altId,altVar) <- mkTmBinderFor tcm (mkDerivedName ctx "case_alt") altExpr - return ([(altId,embed altExpr)],(pat,altVar)) - - doPatBndr :: Term -> DataCon -> Id -> Int -> RewriteMonad NormalizeState LetBinding - doPatBndr subj' dc pId i - = do tcm <- Lens.view tcCache - patExpr <- mkSelectorCase ($(curLoc) ++ "doPatBndr") tcm subj' (dcTag dc) i - return (pId,embed patExpr) - -collectANF _ e = return e - --- | Eta-expand top-level lambda's (DON'T use in a traversal!) -etaExpansionTL :: NormRewrite -etaExpansionTL ctx (Lam b) = do - (bndr,e) <- unbind b - e' <- etaExpansionTL (LamBody bndr:ctx) e - return $ Lam (bind bndr e') - -etaExpansionTL ctx (Letrec b) = do - (xesR,e) <- unbind b - let xes = unrec xesR - bndrs = map fst xes - e' <- etaExpansionTL (LetBody bndrs:ctx) e - e'' <- stripLambda e' - case e'' of - (bs@(_:_),e2) -> do - let e3 = Letrec (bind xesR e2) - changed (mkLams e3 bs) - _ -> return (Letrec (bind xesR e')) - where - stripLambda :: Term -> RewriteMonad NormalizeState ([Id],Term) - stripLambda (Lam b') = do - (bndr,e) <- unbind b' - (bndrs,e') <- stripLambda e - return (bndr:bndrs,e') - stripLambda e = return ([],e) - -etaExpansionTL ctx e - = do - tcm <- Lens.view tcCache - isF <- isFun tcm e - if isF - then do - argTy <- ( return - . fst - . Maybe.fromMaybe (error $ $(curLoc) ++ "etaExpansion splitFunTy") - . splitFunTy tcm - <=< termType tcm - ) e - (newIdB,newIdV) <- mkInternalVar "arg" argTy - e' <- etaExpansionTL (LamBody newIdB:ctx) (App e newIdV) - changed . Lam $ bind newIdB e' - else return e - --- | Turn a normalized recursive function, where the recursive calls only pass --- along the unchanged original arguments, into let-recursive function. This --- means that all recursive calls are replaced by the same variable reference as --- found in the body of the top-level let-expression. -recToLetRec :: NormRewrite -recToLetRec [] e = do - (fn,_) <- Lens.use curFun - bodyM <- fmap (HashMap.lookup fn) $ Lens.use bindings - tcm <- Lens.view tcCache - normalizedE <- splitNormalized tcm e - case (normalizedE,bodyM) of - (Right (args,bndrs,res), Just (bodyTy,_,_)) -> do - let appF = mkTmApps (Var bodyTy fn) (map idToVar args) - (toInline,others) = List.partition ((==) appF . unembed . snd) bndrs - resV = idToVar res - case (toInline,others) of - (_:_,_:_) -> do - let substsInline = map (\(id_,_) -> (varName id_,resV)) toInline - others' = map (second (embed . substTms substsInline . unembed)) others - changed $ mkLams (Letrec $ bind (rec others') resV) args - _ -> return e - _ -> return e - -recToLetRec _ e = return e - --- | Inline a function with functional arguments -inlineHO :: NormRewrite -inlineHO _ e@(App _ _) - | (Var _ f, args) <- collectArgs e - = do - tcm <- Lens.view tcCache - hasPolyFunArgs <- or <$> mapM (either (isPolyFun tcm) (const (return False))) args - if hasPolyFunArgs - then do (cf,_) <- Lens.use curFun - isInlined <- zoomExtra (alreadyInlined f cf) - limit <- Lens.use (extra.inlineLimit) - if (Maybe.fromMaybe 0 isInlined) > limit - then do - lvl <- Lens.view dbgLevel - traceIf (lvl > DebugNone) ($(curLoc) ++ "InlineHO: " ++ show f ++ " already inlined " ++ show limit ++ " times in:" ++ show cf) (return e) - else do - bodyMaybe <- fmap (HashMap.lookup f) $ Lens.use bindings - case bodyMaybe of - Just (_,_,body) -> do - zoomExtra (addNewInline f cf) - changed (mkApps body args) - _ -> return e - else return e - -inlineHO _ e = return e - --- | Simplified CSE, only works on let-bindings, works from top to bottom -simpleCSE :: NormRewrite -simpleCSE _ e@(Letrec b) = do - (binders,body) <- first unrec <$> unbind b - let (reducedBindings,body') = reduceBindersFix binders body - if length binders /= length reducedBindings - then changed (Letrec (bind (rec reducedBindings) body')) - else return e - -simpleCSE _ e = return e - -reduceBindersFix :: [LetBinding] - -> Term - -> ([LetBinding],Term) -reduceBindersFix binders body = if length binders /= length reduced - then reduceBindersFix reduced body' - else (binders,body) - where - (reduced,body') = reduceBinders [] body binders - -reduceBinders :: [LetBinding] - -> Term - -> [LetBinding] - -> ([LetBinding],Term) -reduceBinders processed body [] = (processed,body) -reduceBinders processed body ((id_,expr):binders) = case List.find ((== expr) . snd) processed of - Just (id2,_) -> - let var = Var (unembed (varType id2)) (varName id2) - idName = varName id_ - processed' = map (second (Embed . (substTm idName var) . unembed)) processed - binders' = map (second (Embed . (substTm idName var) . unembed)) binders - body' = substTm idName var body - in reduceBinders processed' body' binders' - Nothing -> reduceBinders ((id_,expr):processed) body binders - -reduceConst :: NormRewrite -reduceConst _ e@(App _ _) - | isConstant e - , (conPrim, _) <- collectArgs e - , isPrim conPrim - = do - tcm <- Lens.view tcCache - reduceConstant <- Lens.view evaluator - case reduceConstant tcm False e of - e'@(Literal _) -> changed e' - e'@(collectArgs -> (Data _,_)) -> changed e' - _ -> return e - -reduceConst _ e = return e - --- | Replace primitives by their "definition" if they would lead to let-bindings --- with a non-representable type when a function is in ANF. This happens for --- example when CLaSH.Size.Vector.map consumes or produces a vector of --- non-representable elements. --- --- Basically what this transformation does is replace a primitive the completely --- unrolled recursive definition that it represents. e.g. --- --- > zipWith ($) (xs :: Vec 2 (Int -> Int)) (ys :: Vec 2 Int) --- --- is replaced by: --- --- > let (x0 :: (Int -> Int)) = case xs of (:>) _ x xr -> x --- > (xr0 :: Vec 1 (Int -> Int)) = case xs of (:>) _ x xr -> xr --- > (x1 :: (Int -> Int)( = case xr0 of (:>) _ x xr -> x --- > (y0 :: Int) = case ys of (:>) _ y yr -> y --- > (yr0 :: Vec 1 Int) = case ys of (:>) _ y yr -> xr --- > (y1 :: Int = case yr0 of (:>) _ y yr -> y --- > in (($) x0 y0 :> ($) x1 y1 :> Nil) --- --- Currently, it only handles the following functions: --- --- * CLaSH.Sized.Vector.map --- * CLaSH.Sized.Vector.zipWith --- * CLaSH.Sized.Vector.traverse# --- * CLaSH.Sized.Vector.foldr --- * CLaSH.Sized.Vector.fold --- * CLaSH.Sized.Vector.dfold --- * CLaSH.Sized.Vector.(++) --- * CLaSH.Sized.Vector.head --- * CLaSH.Sized.Vector.tail --- * CLaSH.Sized.Vector.unconcat --- * CLaSH.Sized.Vector.transpose --- * CLaSH.Sized.Vector.replicate --- * CLaSH.Sized.Vector.dtfold -reduceNonRepPrim :: NormRewrite -reduceNonRepPrim _ e@(App _ _) | (Prim f _, args) <- collectArgs e = do - tcm <- Lens.view tcCache - eTy <- termType tcm e - case tyView eTy of - (TyConApp vecTcNm@(name2String -> "CLaSH.Sized.Vector.Vec") - [runExcept . tyNatSize tcm -> Right 0, aTy]) -> do - let (Just vecTc) = HashMap.lookup vecTcNm tcm - [nilCon,consCon] = tyConDataCons vecTc - nilE = mkVec nilCon consCon aTy 0 [] - changed nilE - tv -> case f of - "CLaSH.Sized.Vector.zipWith" | length args == 7 -> do - let [lhsElTy,rhsElty,resElTy,nTy] = Either.rights args - case runExcept (tyNatSize tcm nTy) of - Right n -> do - untranslatableTys <- mapM isUntranslatableType_not_poly [lhsElTy,rhsElty,resElTy] - if or untranslatableTys - then let [fun,lhsArg,rhsArg] = Either.lefts args - in reduceZipWith n lhsElTy rhsElty resElTy fun lhsArg rhsArg - else return e - _ -> return e - "CLaSH.Sized.Vector.map" | length args == 5 -> do - let [argElTy,resElTy,nTy] = Either.rights args - case runExcept (tyNatSize tcm nTy) of - Right n -> do - untranslatableTys <- mapM isUntranslatableType_not_poly [argElTy,resElTy] - if or untranslatableTys - then let [fun,arg] = Either.lefts args - in reduceMap n argElTy resElTy fun arg - else return e - _ -> return e - "CLaSH.Sized.Vector.traverse#" | length args == 7 -> - let [aTy,fTy,bTy,nTy] = Either.rights args - in case runExcept (tyNatSize tcm nTy) of - Right n -> - let [dict,fun,arg] = Either.lefts args - in reduceTraverse n aTy fTy bTy dict fun arg - _ -> return e - "CLaSH.Sized.Vector.fold" | length args == 4 -> do - let [aTy,nTy] = Either.rights args - isPow2 x = x /= 0 && (x .&. (complement x + 1)) == x - untranslatableTy <- isUntranslatableType_not_poly aTy - case runExcept (tyNatSize tcm nTy) of - Right n | not (isPow2 (n + 1)) || untranslatableTy -> - let [fun,arg] = Either.lefts args - in reduceFold (n + 1) aTy fun arg - _ -> return e - "CLaSH.Sized.Vector.foldr" | length args == 6 -> - let [aTy,bTy,nTy] = Either.rights args - in case runExcept (tyNatSize tcm nTy) of - Right n -> do - untranslatableTys <- mapM isUntranslatableType_not_poly [aTy,bTy] - if or untranslatableTys - then let [fun,start,arg] = Either.lefts args - in reduceFoldr n aTy fun start arg - else return e - _ -> return e - "CLaSH.Sized.Vector.dfold" | length args == 8 -> - let ([_kn,_motive,fun,start,arg],[_mTy,nTy,aTy]) = Either.partitionEithers args - in case runExcept (tyNatSize tcm nTy) of - Right n -> reduceDFold n aTy fun start arg - _ -> return e - "CLaSH.Sized.Vector.++" | length args == 5 -> - let [nTy,aTy,mTy] = Either.rights args - [lArg,rArg] = Either.lefts args - in case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of - (Right n, Right m) - | n == 0 -> changed rArg - | m == 0 -> changed lArg - | otherwise -> do - untranslatableTy <- isUntranslatableType_not_poly aTy - if untranslatableTy - then reduceAppend n m aTy lArg rArg - else return e - _ -> return e - "CLaSH.Sized.Vector.head" | length args == 3 -> do - let [nTy,aTy] = Either.rights args - [vArg] = Either.lefts args - case runExcept (tyNatSize tcm nTy) of - Right n -> do - untranslatableTy <- isUntranslatableType_not_poly aTy - if untranslatableTy - then reduceHead n aTy vArg - else return e - _ -> return e - "CLaSH.Sized.Vector.tail" | length args == 3 -> do - let [nTy,aTy] = Either.rights args - [vArg] = Either.lefts args - case runExcept (tyNatSize tcm nTy) of - Right n -> do - untranslatableTy <- isUntranslatableType_not_poly aTy - if untranslatableTy - then reduceTail n aTy vArg - else return e - _ -> return e - "CLaSH.Sized.Vector.last" | length args == 3 -> do - let [nTy,aTy] = Either.rights args - [vArg] = Either.lefts args - case runExcept (tyNatSize tcm nTy) of - Right n -> do - untranslatableTy <- isUntranslatableType_not_poly aTy - if untranslatableTy - then reduceLast n aTy vArg - else return e - _ -> return e - "CLaSH.Sized.Vector.init" | length args == 3 -> do - let [nTy,aTy] = Either.rights args - [vArg] = Either.lefts args - case runExcept (tyNatSize tcm nTy) of - Right n -> do - untranslatableTy <- isUntranslatableType_not_poly aTy - if untranslatableTy - then reduceInit n aTy vArg - else return e - _ -> return e - "CLaSH.Sized.Vector.unconcat" | length args == 6 -> do - let ([_knN,_sm,arg],[mTy,nTy,aTy]) = Either.partitionEithers args - case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of - (Right n, Right 0) -> reduceUnconcat n 0 aTy arg - _ -> return e - "CLaSH.Sized.Vector.transpose" | length args == 5 -> do - let ([_knN,arg],[mTy,nTy,aTy]) = Either.partitionEithers args - case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of - (Right n, Right 0) -> reduceTranspose n 0 aTy arg - _ -> return e - "CLaSH.Sized.Vector.replicate" | length args == 4 -> do - let ([_sArg,vArg],[nTy,aTy]) = Either.partitionEithers args - case runExcept (tyNatSize tcm nTy) of - Right n -> do - untranslatableTy <- isUntranslatableType_not_poly aTy - if untranslatableTy - then reduceReplicate n aTy eTy vArg - else return e - _ -> return e - "CLaSH.Sized.Vector.imap" | length args == 6 -> do - let [nTy,argElTy,resElTy] = Either.rights args - case runExcept (tyNatSize tcm nTy) of - Right n -> do - untranslatableTys <- mapM isUntranslatableType_not_poly [argElTy,resElTy] - if or untranslatableTys - then let [_,fun,arg] = Either.lefts args - in reduceImap n argElTy resElTy fun arg - else return e - _ -> return e - "CLaSH.Sized.Vector.dtfold" | length args == 8 -> - let ([_kn,_motive,lrFun,brFun,arg],[_mTy,nTy,aTy]) = Either.partitionEithers args - in case runExcept (tyNatSize tcm nTy) of - Right n -> reduceDTFold n aTy lrFun brFun arg - _ -> return e - "CLaSH.Sized.RTree.tdfold" | length args == 8 -> - let ([_kn,_motive,lrFun,brFun,arg],[_mTy,nTy,aTy]) = Either.partitionEithers args - in case runExcept (tyNatSize tcm nTy) of - Right n -> reduceTFold n aTy lrFun brFun arg - _ -> return e - "CLaSH.Sized.RTree.treplicate" | length args == 4 -> do - let ([_sArg,vArg],[nTy,aTy]) = Either.partitionEithers args - case runExcept (tyNatSize tcm nTy) of - Right n -> do - untranslatableTy <- isUntranslatableType aTy - if untranslatableTy - then reduceReplicate n aTy eTy vArg - else return e - _ -> return e - "CLaSH.Sized.Internal.BitVector.split#" | length args == 4 -> do - let ([_knArg,bvArg],[nTy,mTy]) = Either.partitionEithers args - case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy), tv) of - (Right n, Right m, TyConApp tupTcNm [lTy,rTy]) - | n == 0 -> do - let (Just tupTc) = HashMap.lookup tupTcNm tcm - [tupDc] = tyConDataCons tupTc - tup = mkApps (Data tupDc) - [Right lTy - ,Right rTy - ,Left bvArg - ,Left (mkApps (Prim "CLaSH.Transformations.removedArg" undefinedTy) - [Right rTy]) - ] - - changed tup - | m == 0 -> do - let (Just tupTc) = HashMap.lookup tupTcNm tcm - [tupDc] = tyConDataCons tupTc - tup = mkApps (Data tupDc) - [Right lTy - ,Right rTy - ,Left (mkApps (Prim "CLaSH.Transformations.removedArg" undefinedTy) - [Right lTy]) - ,Left bvArg - ] - - changed tup - _ -> return e - "CLaSH.Sized.Internal.BitVector.eq#" - | ([_,_],[nTy]) <- Either.partitionEithers args - , Right 0 <- runExcept (tyNatSize tcm nTy) - , TyConApp boolTcNm [] <- tv - -> let (Just boolTc) = HashMap.lookup boolTcNm tcm - [_falseDc,trueDc] = tyConDataCons boolTc - in changed (Data trueDc) - _ -> return e - where - isUntranslatableType_not_poly t = do - u <- isUntranslatableType t - if u - then return (null $ Lens.toListOf typeFreeVars t) - else return False - -reduceNonRepPrim _ e = return e - --- | This transformation lifts applications of global binders out of --- alternatives of case-statements. --- --- e.g. It converts: --- --- @ --- case x of --- A -> f 3 y --- B -> f x x --- C -> h x --- @ --- --- into: --- --- @ --- let f_arg0 = case x of {A -> 3; B -> x} --- f_arg1 = case x of {A -> y; B -> x} --- f_out = f f_arg0 f_arg1 --- in case x of --- A -> f_out --- B -> f_out --- C -> h x --- @ -disjointExpressionConsolidation :: NormRewrite -disjointExpressionConsolidation ctx e@(Case _scrut _ty _alts@(_:_:_)) = do - let eFreeIds = Lens.setOf termFreeIds e - (_,collected) <- collectGlobals eFreeIds [] [] e - let disJoint = filter (isDisjoint . snd. snd) collected - if null disJoint - then return e - else do - exprs <- mapM (mkDisjointGroup eFreeIds) disJoint - tcm <- Lens.view tcCache - (lids,lvs) <- unzip <$> Monad.zipWithM (mkFunOut tcm) disJoint exprs - let substitution = zip (map fst disJoint) lvs - subsMatrix = l2m substitution - (exprs',_) <- unzip <$> Monad.zipWithM (\s (e',seen) -> collectGlobals eFreeIds s seen e') - subsMatrix - exprs - (e',_) <- collectGlobals eFreeIds substitution [] e - let lb = Letrec (bind (rec (zip lids (map embed exprs'))) e') - lb' <- bottomupR deadCode ctx lb - changed lb' - where - mkFunOut tcm (fun,_) (e',_) = do - ty <- termType tcm e' - let nm = case collectArgs fun of - (Var _ nm',_) -> name2String nm' - (Prim nm' _,_) -> unpack nm' - _ -> "complex_expression_" - nm'' = (reverse . List.takeWhile (/='.') . reverse) nm ++ "Out" - mkInternalVar nm'' ty - - l2m = go [] - where - go _ [] = [] - go xs (y:ys) = (xs ++ ys) : go (xs ++ [y]) ys - -disjointExpressionConsolidation _ e = return e diff --git a/src/CLaSH/Normalize/Types.hs b/src/CLaSH/Normalize/Types.hs deleted file mode 100644 --- a/src/CLaSH/Normalize/Types.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Types used in Normalize modules --} - -{-# LANGUAGE TemplateHaskell #-} - -module CLaSH.Normalize.Types where - -import Control.Monad.State.Strict (State) -import Data.HashMap.Strict (HashMap) -import Data.Map (Map) - -import SrcLoc (SrcSpan) - -import CLaSH.Core.Term (Term, TmName) -import CLaSH.Core.Type (Type) -import CLaSH.Netlist.BlackBox.Types (BlackBoxTemplate) -import CLaSH.Primitives.Types (PrimMap) -import CLaSH.Rewrite.Types (Rewrite, RewriteMonad) -import CLaSH.Util - --- | State of the 'NormalizeMonad' -data NormalizeState - = NormalizeState - { _normalized :: HashMap TmName (Type,SrcSpan,Term) - -- ^ Global binders - , _specialisationCache :: Map (TmName,Int,Either Term Type) (TmName,Type) - -- ^ Cache of previously specialised functions: - -- - -- * Key: (name of the original function, argument position, specialised term/type) - -- - -- * Elem: (name of specialised function,type of specialised function) - , _specialisationHistory :: HashMap TmName Int - -- ^ Cache of how many times a function was specialized - , _specialisationLimit :: !Int - -- ^ Number of time a function 'f' can be specialized - , _inlineHistory :: HashMap TmName (HashMap TmName Int) - -- ^ Cache of function where inlining took place: - -- - -- * Key: function where inlining took place - -- - -- * Elem: (functions which were inlined, number of times inlined) - , _inlineLimit :: !Int - -- ^ Number of times a function 'f' can be inlined in a function 'g' - , _inlineBelow :: !Int - -- ^ Size of a function below which it is always inlined if it is not - -- recursive - , _primitives :: PrimMap BlackBoxTemplate -- ^ Primitive Definitions - , _recursiveComponents :: HashMap TmName Bool - -- ^ Map telling whether a components is part of a recursive group - } - -makeLenses ''NormalizeState - --- | State monad that stores specialisation and inlining information -type NormalizeMonad = State NormalizeState - --- | RewriteSession with extra Normalisation information -type NormalizeSession = RewriteMonad NormalizeState - --- | A 'Transform' action in the context of the 'RewriteMonad' and 'NormalizeMonad' -type NormRewrite = Rewrite NormalizeState diff --git a/src/CLaSH/Normalize/Util.hs b/src/CLaSH/Normalize/Util.hs deleted file mode 100644 --- a/src/CLaSH/Normalize/Util.hs +++ /dev/null @@ -1,167 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Utility functions used by the normalisation transformations --} - -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TemplateHaskell #-} - -module CLaSH.Normalize.Util where - -import Control.Lens ((%=),(^.),_3) -import qualified Control.Lens as Lens -import Data.Function (on) -import qualified Data.Graph as Graph -import Data.Graph.Inductive (Gr,LNode,lsuc,mkGraph,iDom) -import Data.HashMap.Lazy (HashMap) -import qualified Data.HashMap.Lazy as HashMap -import qualified Data.List as List -import qualified Data.Maybe as Maybe -import qualified Data.Set as Set -import qualified Data.Set.Lens as Lens -import Unbound.Generics.LocallyNameless (Fresh, bind, embed, rec) - -import SrcLoc (SrcSpan) - -import CLaSH.Core.FreeVars (termFreeIds) -import CLaSH.Core.Var (Var (Id)) -import CLaSH.Core.Term (Term (..), TmName) -import CLaSH.Core.Type (Type) -import CLaSH.Core.TyCon (TyCon, TyConName) -import CLaSH.Core.Util (collectArgs, isPolyFun) -import CLaSH.Normalize.Types -import CLaSH.Rewrite.Types (bindings,extra) -import CLaSH.Rewrite.Util (specialise) -import CLaSH.Util (curLoc) - --- | Determine if a function is already inlined in the context of the 'NetlistMonad' -alreadyInlined :: TmName -- ^ Function we want to inline - -> TmName -- ^ Function in which we want to perform the inlining - -> NormalizeMonad (Maybe Int) -alreadyInlined f cf = do - inlinedHM <- Lens.use inlineHistory - case HashMap.lookup cf inlinedHM of - Nothing -> return Nothing - Just inlined' -> return (HashMap.lookup f inlined') - -addNewInline :: TmName -- ^ Function we want to inline - -> TmName -- ^ Function in which we want to perform the inlining - -> NormalizeMonad () -addNewInline f cf = - inlineHistory %= HashMap.insertWith - (\_ hm -> HashMap.insertWith (+) f 1 hm) - cf - (HashMap.singleton f 1) - --- | Specialize under the Normalization Monad -specializeNorm :: NormRewrite -specializeNorm = specialise specialisationCache specialisationHistory specialisationLimit - --- | Determine if a term is closed -isClosed :: Fresh m - => HashMap TyConName TyCon - -> Term - -> m Bool -isClosed tcm = fmap not . isPolyFun tcm - --- | Determine if a term represents a constant -isConstant :: Term -> Bool -isConstant e = case collectArgs e of - (Data _, args) -> all (either isConstant (const True)) args - (Prim _ _, args) -> all (either isConstant (const True)) args - (Literal _,_) -> True - _ -> False - -isRecursiveBndr :: TmName -> NormalizeSession Bool -isRecursiveBndr f = do - cg <- Lens.use (extra.recursiveComponents) - case HashMap.lookup f cg of - Just isR -> return isR - Nothing -> do - bndrs <- Lens.use bindings - let cg' = callGraph [] bndrs f - rcs = concat $ mkRecursiveComponents cg' - isR = f `elem` rcs - cg'' = HashMap.fromList - $ map (\(t,_) -> (t,t `elem` rcs)) cg' - (extra.recursiveComponents) %= HashMap.union cg'' - return isR - --- | Create a call graph for a set of global binders, given a root -callGraph :: [TmName] -- ^ List of functions that should not be inspected - -> HashMap TmName (Type,SrcSpan,Term) -- ^ Global binders - -> TmName -- ^ Root of the call graph - -> [(TmName,[TmName])] -callGraph visited bindingMap root = node:other - where - rootTm = Maybe.fromMaybe (error $ show root ++ " is not a global binder") $ HashMap.lookup root bindingMap - used = Set.toList $ Lens.setOf termFreeIds (rootTm ^. _3) - node = (root,used) - other = concatMap (callGraph (root:visited) bindingMap) (filter (`notElem` visited) used) - --- | Determine the sets of recursive components given the edges of a callgraph -mkRecursiveComponents :: [(TmName,[TmName])] -- ^ [(calling function,[called function])] - -> [[TmName]] -mkRecursiveComponents cg = map (List.sortBy (compare `on` (`List.elemIndex` fs))) - . Maybe.catMaybes - . map (\case {Graph.CyclicSCC vs -> Just vs; _ -> Nothing}) - . Graph.stronglyConnComp - $ map (\(n,es) -> (n,n,es)) cg - where - fs = map fst cg - -lambdaDropPrep :: HashMap TmName (Type,SrcSpan,Term) - -> TmName - -> HashMap TmName (Type,SrcSpan,Term) -lambdaDropPrep bndrs topEntity = bndrs' - where - depGraph = callGraph [] bndrs topEntity - used = HashMap.fromList depGraph - rcs = mkRecursiveComponents depGraph - dropped = map (lambdaDrop bndrs used) rcs - bndrs' = foldr (\(k,v) b -> HashMap.insert k v b) bndrs dropped - -lambdaDrop :: HashMap TmName (Type,SrcSpan,Term) -- ^ Original Binders - -> HashMap TmName [TmName] -- ^ Dependency Graph - -> [TmName] -- ^ Recursive block - -> (TmName,(Type,SrcSpan,Term)) -- ^ Lambda-dropped Binders -lambdaDrop bndrs depGraph cyc@(root:_) = block - where - doms = dominator depGraph cyc - block = blockSink bndrs doms (0,root) - -lambdaDrop _ _ [] = error $ $(curLoc) ++ "Can't lambdadrop empty cycle" - -dominator :: HashMap TmName [TmName] -- ^ Dependency Graph - -> [TmName] -- ^ Recursive block - -> Gr TmName TmName -- ^ Recursive block dominator -dominator cfg cyc = mkGraph nodes (map (\(e,b) -> (b,e,nodesM HashMap.! e)) doms) - where - nodes = zip [0..] cyc - nodesM = HashMap.fromList nodes - nodesI = HashMap.fromList $ zip cyc [0..] - cycEdges = HashMap.map ( map (nodesI HashMap.!) - . filter (`elem` cyc) - ) - $ HashMap.filterWithKey (\k _ -> k `elem` cyc) cfg - edges = concatMap (\(i,n) -> zip3 (repeat i) (cycEdges HashMap.! n) (repeat ()) - ) nodes - graph = mkGraph nodes edges :: Gr TmName () - doms = iDom graph 0 - -blockSink :: HashMap TmName (Type,SrcSpan,Term) -- ^ Original Binders - -> Gr TmName TmName -- ^ Recursive block dominator - -> LNode TmName -- ^ Recursive block dominator root - -> (TmName,(Type,SrcSpan,Term)) -- ^ Block sank binder -blockSink bndrs doms (nId,tmName) = (tmName,(ty,sp,newTm)) - where - (ty,sp,tm) = bndrs HashMap.! tmName - sucTm = lsuc doms nId - tmS = map (blockSink bndrs doms) sucTm - bnds = map (\(tN,(ty',_,tm')) -> (Id tN (embed ty'),embed tm')) tmS - newTm = case sucTm of - [] -> tm - _ -> Letrec (bind (rec bnds) tm) diff --git a/src/CLaSH/Primitives/Types.hs b/src/CLaSH/Primitives/Types.hs deleted file mode 100644 --- a/src/CLaSH/Primitives/Types.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Type and instance definitions for Primitive --} - -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -module CLaSH.Primitives.Types where - -import Control.Applicative ((<|>)) -import Data.Aeson (FromJSON (..), Value (..), (.:), (.:?), (.!=)) -import Data.HashMap.Lazy (HashMap) -import qualified Data.HashMap.Strict as H -import qualified Data.Text as S -import Data.Text.Lazy (Text) - --- | Primitive Definitions -type PrimMap a = HashMap S.Text (Primitive a) - --- | Externally defined primitive -data Primitive a - -- | A primitive that has a template that can be filled out by the backend render - = BlackBox - { name :: !S.Text -- ^ Name of the primitive - , library :: [S.Text] - , imports :: [S.Text] - , qsysInclude :: Maybe (S.Text,a) - , template :: !(Either a a) -- ^ Either a /declaration/ or an /expression/ template. - } - -- | A primitive that carries additional information - | Primitive - { name :: !S.Text -- ^ Name of the primitive - , primType :: !Text -- ^ Additional information - } - deriving Show - -instance FromJSON (Primitive Text) where - parseJSON (Object v) = case H.toList v of - [(conKey,Object conVal)] -> case conKey of - "BlackBox" -> BlackBox <$> conVal .: "name" - <*> conVal .:? "libraries" .!= [] - <*> conVal .:? "imports" .!= [] - <*> (conVal .:? "qsysInclude" >>= parseInclude) - <*> ((Left <$> conVal .: "templateD") <|> (Right <$> conVal .: "templateE")) - "Primitive" -> Primitive <$> conVal .: "name" <*> conVal .: "primType" - _ -> error "Expected: BlackBox or Primitive object" - _ -> error "Expected: BlackBox or Primitive object" - where - parseInclude Nothing = pure Nothing - parseInclude (Just c) = - Just <$> ((,) <$> c .: "name" <*> c .: "content") - parseJSON _ = error "Expected: BlackBox or Primitive object" diff --git a/src/CLaSH/Primitives/Util.hs b/src/CLaSH/Primitives/Util.hs deleted file mode 100644 --- a/src/CLaSH/Primitives/Util.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Utility functions to generate Primitives --} - -module CLaSH.Primitives.Util where - -import Data.Aeson.Extra (decodeAndReport) -import qualified Data.ByteString.Lazy as LZ -import qualified Data.HashMap.Lazy as HashMap -import Data.List (isSuffixOf) -import Data.Maybe (fromMaybe) -import Data.Text.Lazy (Text) -import qualified System.Directory as Directory -import qualified System.FilePath as FilePath - -import CLaSH.Primitives.Types -import CLaSH.Util - --- | Generate a set of primitives that are found in the primitive definition --- files in the given directories. -generatePrimMap :: [FilePath] -- ^ Directories to search for primitive definitions - -> IO (PrimMap Text) -generatePrimMap filePaths = do - primitiveFiles <- fmap concat $ mapM - (\filePath -> do - fpExists <- Directory.doesDirectoryExist filePath - if fpExists - then - fmap ( map (FilePath.combine filePath) - . filter (isSuffixOf ".json") - ) (Directory.getDirectoryContents filePath) - else - return [] - ) filePaths - - primitives <- fmap concat $ mapM - ( return - . fromMaybe [] - . decodeAndReport - <=< LZ.readFile - ) primitiveFiles - - let primMap = HashMap.fromList $ zip (map name primitives) primitives - - return primMap diff --git a/src/CLaSH/Rewrite/Combinators.hs b/src/CLaSH/Rewrite/Combinators.hs deleted file mode 100644 --- a/src/CLaSH/Rewrite/Combinators.hs +++ /dev/null @@ -1,150 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Rewriting combinators and traversals --} - -{-# LANGUAGE ScopedTypeVariables #-} - -module CLaSH.Rewrite.Combinators where - -import Control.DeepSeq (deepseq) -import Control.Monad ((<=<), (>=>)) -import qualified Control.Monad.Writer as Writer -import qualified Data.Monoid as Monoid -import Unbound.Generics.LocallyNameless (Embed, Fresh, bind, embed, - rec, unbind, unembed, unrec) -import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) - -import CLaSH.Core.Term (Pat, Term (..)) -import CLaSH.Core.Util (patIds) -import CLaSH.Core.Var (Id) -import CLaSH.Rewrite.Types - --- | Apply a transformation on the subtrees of an term -allR :: forall m . (Monad m, Fresh m) - => Bool -- ^ Freshen variable references in abstracted terms - -> Transform m -- ^ The transformation to apply to the subtrees - -> Transform m -allR _ _ _ (Var t x) = return (Var t x) -allR _ _ _ (Data dc) = return (Data dc) -allR _ _ _ (Literal l) = return (Literal l) -allR _ _ _ (Prim nm t) = return (Prim nm t) - -allR rf trans c (Lam b) = do - (v,e) <- if rf then unbind b else return (unsafeUnbind b) - e' <- trans (LamBody v:c) e - return . Lam $ bind v e' - -allR rf trans c (TyLam b) = do - (tv, e) <- if rf then unbind b else return (unsafeUnbind b) - e' <- trans (TyLamBody tv:c) e - return . TyLam $ bind tv e' - -allR _ trans c (App e1 e2) = do - e1' <- trans (AppFun:c) e1 - e2' <- trans (AppArg:c) e2 - return $ App e1' e2' - -allR _ trans c (TyApp e ty) = do - e' <- trans (TyAppC:c) e - return $ TyApp e' ty - -allR rf trans c (Letrec b) = do - (xesR,e) <- if rf then unbind b else return (unsafeUnbind b) - let xes = unrec xesR - let bndrs = map fst xes - e' <- trans (LetBody bndrs:c) e - xes' <- mapM (rewriteBind bndrs) xes - return . Letrec $ bind (rec xes') e' - where - rewriteBind :: [Id] -> (Id,Embed Term) -> m (Id,Embed Term) - rewriteBind bndrs (b', e) = do - e' <- trans (LetBinding b' bndrs:c) (unembed e) - return (b',embed e') - -allR rf trans c (Case scrut ty alts) = do - scrut' <- trans (CaseScrut:c) scrut - alts' <- if rf then mapM (fmap (uncurry bind) . rewriteAlt <=< unbind) alts - else mapM (fmap (uncurry bind) . rewriteAlt . unsafeUnbind) alts - return $ Case scrut' ty alts' - where - rewriteAlt :: (Pat, Term) -> m (Pat, Term) - rewriteAlt (p,e) = do - e' <- trans (CaseAlt (patIds p):c) e - return (p,e') - -infixr 6 >-> --- | Apply two transformations in succession -(>->) :: Monad m => Transform m -> Transform m -> Transform m -(>->) r1 r2 c = r1 c >=> r2 c - -infixr 6 >-!-> --- | Apply two transformations in succession, and perform a deepseq in between. -(>-!->) :: Monad m => Transform m -> Transform m -> Transform m -(>-!->) r1 r2 c e = do - e' <- r1 c e - deepseq e' (r2 c e') - --- | Apply a transformation in a topdown traversal -topdownR :: Fresh m => Transform m -> Transform m -topdownR r = r >-> allR True (topdownR r) - --- | Apply a transformation in a topdown traversal. Doesn't freshen bound --- variables -unsafeTopdownR :: Fresh m => Transform m -> Transform m -unsafeTopdownR r = r >-> allR False (unsafeTopdownR r) - --- | Apply a transformation in a bottomup traversal -bottomupR :: Fresh m => Transform m -> Transform m -bottomupR r = allR True (bottomupR r) >-> r - --- | Apply a transformation in a bottomup traversal. Doesn't freshen bound --- variables -unsafeBottomupR :: Fresh m => Transform m -> Transform m -unsafeBottomupR r = allR False (unsafeBottomupR r) >-> r - -infixr 5 !-> --- | Only apply the second transformation if the first one succeeds. -(!->) :: Rewrite m -> Rewrite m -> Rewrite m -(!->) r1 r2 c expr = do - (expr',changed) <- Writer.listen $ r1 c expr - if Monoid.getAny changed - then r2 c expr' - else return expr' - -infixr 5 >-! --- | Only apply the second transformation if the first one fails. -(>-!) :: Rewrite m -> Rewrite m -> Rewrite m -(>-!) r1 r2 c expr = do - (expr',changed) <- Writer.listen $ r1 c expr - if Monoid.getAny changed - then return expr' - else r2 c expr' - --- | Keep applying a transformation until it fails. -repeatR :: Rewrite m -> Rewrite m -repeatR r = r !-> repeatR r - -whenR :: Monad m - => ([CoreContext] -> Term -> m Bool) - -> Transform m - -> Transform m -whenR f r1 ctx expr = do - b <- f ctx expr - if b - then r1 ctx expr - else return expr - --- | Only traverse downwards when the assertion evaluates to true -bottomupWhenR :: Fresh m - => ([CoreContext] -> Term -> m Bool) - -> Transform m - -> Transform m -bottomupWhenR f r ctx expr = do - b <- f ctx expr - if b - then (allR True (bottomupWhenR f r) >-> r) ctx expr - else r ctx expr diff --git a/src/CLaSH/Rewrite/Types.hs b/src/CLaSH/Rewrite/Types.hs deleted file mode 100644 --- a/src/CLaSH/Rewrite/Types.hs +++ /dev/null @@ -1,158 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Type and instance definitions for Rewrite modules --} - -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} - -module CLaSH.Rewrite.Types where - -import Control.Concurrent.Supply (Supply, freshId) -import Control.Lens (use, (.=), (<<%=)) -import Control.Monad -import Control.Monad.Fix (MonadFix (..), fix) -import Control.Monad.Reader (MonadReader (..)) -import Control.Monad.State (MonadState (..)) -import Control.Monad.Writer (MonadWriter (..)) -import Data.HashMap.Strict (HashMap) -import Data.IntMap.Strict (IntMap) -import Data.Monoid (Any) -import Unbound.Generics.LocallyNameless (Fresh (..)) -import Unbound.Generics.LocallyNameless.Name (Name (..)) - -import SrcLoc (SrcSpan) - -import CLaSH.Core.Term (Term, TmName) -import CLaSH.Core.Type (Type) -import CLaSH.Core.TyCon (TyCon, TyConName) -import CLaSH.Core.Var (Id, TyVar) -import CLaSH.Netlist.Types (HWType) -import CLaSH.Util - --- | Context in which a term appears -data CoreContext - = AppFun -- ^ Function position of an application - | AppArg -- ^ Argument position of an application - | TyAppC -- ^ Function position of a type application - | LetBinding Id [Id] -- ^ RHS of a Let-binder with the sibling LHS' - | LetBody [Id] -- ^ Body of a Let-binding with the bound LHS' - | LamBody Id -- ^ Body of a lambda-term with the abstracted variable - | TyLamBody TyVar -- ^ Body of a TyLambda-term with the abstracted - -- type-variable - | CaseAlt [Id] -- ^ RHS of a case-alternative with the variables bound by - -- the pattern on the LHS - | CaseScrut -- ^ Subject of a case-decomposition - deriving (Eq,Show) - --- | State of a rewriting session -data RewriteState extra - = RewriteState - { _transformCounter :: {-# UNPACK #-} !Int - -- ^ Number of applied transformations - , _bindings :: !(HashMap TmName (Type,SrcSpan,Term)) - -- ^ Global binders - , _uniqSupply :: !Supply - -- ^ Supply of unique numbers - , _curFun :: (TmName,SrcSpan) -- Initially set to undefined: no strictness annotation - -- ^ Function which is currently normalized - , _nameCounter :: {-# UNPACK #-} !Int - -- ^ Used for 'Fresh' - , _extra :: !extra - -- ^ Additional state - } - -makeLenses ''RewriteState - --- | Debug Message Verbosity -data DebugLevel - = DebugNone -- ^ Don't show debug messages - | DebugFinal -- ^ Show completely normalized expressions - | DebugName -- ^ Names of applied transformations - | DebugApplied -- ^ Show sub-expressions after a successful rewrite - | DebugAll -- ^ Show all sub-expressions on which a rewrite is attempted - deriving (Eq,Ord,Read) - --- | Read-only environment of a rewriting session -data RewriteEnv - = RewriteEnv - { _dbgLevel :: DebugLevel - -- ^ Lvl at which we print debugging messages - , _typeTranslator :: HashMap TyConName TyCon -> Type - -> Maybe (Either String HWType) - -- ^ Hardcode Type -> HWType translator - , _tcCache :: HashMap TyConName TyCon - -- ^ TyCon cache - , _tupleTcCache :: IntMap TyConName - -- ^ Tuple TyCon cache - , _evaluator :: HashMap TyConName TyCon -> Bool -> Term -> Term - -- ^ Hardcoded evaluator (delta-reduction)} - , _allowZero :: Bool - -- ^ Zero bit wide things are representable - } - -makeLenses ''RewriteEnv - --- | Monad that keeps track how many transformations have been applied and can --- generate fresh variables and unique identifiers. In addition, it keeps track --- if a transformation/rewrite has been successfully applied. -newtype RewriteMonad extra a = R - { runR :: RewriteEnv -> RewriteState extra -> (a,RewriteState extra,Any) } - -instance Functor (RewriteMonad extra) where - fmap f m = R (\r s -> case runR m r s of (a,s',w) -> (f a,s',w)) - -instance Applicative (RewriteMonad extra) where - pure = return - (<*>) = ap - -instance Monad (RewriteMonad extra) where - return a = R (\_ s -> (a, s, mempty)) - m >>= k = R (\r s -> case runR m r s of - (a,s',w) -> case runR (k a) r s' of - (b,s'',w') -> let w'' = mappend w w' - in seq w'' (b,s'',w'')) - -instance MonadState (RewriteState extra) (RewriteMonad extra) where - get = R (\_ s -> (s,s,mempty)) - put s = R (\_ _ -> ((),s,mempty)) - state f = R (\_ s -> case f s of (a,s') -> (a,s',mempty)) - -instance Fresh (RewriteMonad extra) where - fresh (Fn s _) = do - n <- nameCounter <<%= (+1) - let n' = toInteger n - n' `seq` return (Fn s n') - fresh nm@(Bn {}) = return nm - -instance MonadUnique (RewriteMonad extra) where - getUniqueM = do - sup <- use uniqSupply - let (a,sup') = freshId sup - uniqSupply .= sup' - a `seq` return a - -instance MonadWriter Any (RewriteMonad extra) where - writer (a,w) = R (\_ s -> (a,s,w)) - tell w = R (\_ s -> ((),s,w)) - listen m = R (\r s -> case runR m r s of (a,s',w) -> ((a,w),s',w)) - pass m = R (\r s -> case runR m r s of ((a,f),s',w) -> (a, s', f w)) - -instance MonadReader RewriteEnv (RewriteMonad extra) where - ask = R (\r s -> (r,s,mempty)) - local f m = R (\r s -> runR m (f r) s) - reader f = R (\r s -> (f r,s,mempty)) - -instance MonadFix (RewriteMonad extra) where - mfix f = R (\r s -> fix $ \ ~(a,_,_) -> runR (f a) r s) - --- | Monadic action that transforms a term given a certain context -type Transform m = [CoreContext] -> Term -> m Term - --- | A 'Transform' action in the context of the 'RewriteMonad' -type Rewrite extra = Transform (RewriteMonad extra) diff --git a/src/CLaSH/Rewrite/Util.hs b/src/CLaSH/Rewrite/Util.hs deleted file mode 100644 --- a/src/CLaSH/Rewrite/Util.hs +++ /dev/null @@ -1,638 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Utilities for rewriting: e.g. inlining, specialisation, etc. --} - -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} - -module CLaSH.Rewrite.Util where - -import Control.DeepSeq -import Control.Exception (throw) -import Control.Lens (Lens', (%=), (+=), (^.),_1,_3) -import qualified Control.Lens as Lens -import qualified Control.Monad as Monad -import qualified Control.Monad.State.Strict as State -import qualified Control.Monad.Writer as Writer -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Lazy as HML -import qualified Data.HashMap.Strict as HMS -import qualified Data.List as List -import qualified Data.Map as Map -import Data.Maybe (catMaybes,isJust,mapMaybe) -import qualified Data.Monoid as Monoid -import qualified Data.Set as Set -import qualified Data.Set.Lens as Lens -import Unbound.Generics.LocallyNameless (Fresh, bind, - embed, makeName, name2String, - rebind, rec, string2Name, unbind, - unembed, unrec) -import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) - -import SrcLoc (SrcSpan) - -import CLaSH.Core.DataCon (dataConInstArgTys) -import CLaSH.Core.FreeVars (termFreeIds, termFreeTyVars, - typeFreeVars) -import CLaSH.Core.Pretty (showDoc) -import CLaSH.Core.Subst (substTm) -import CLaSH.Core.Term (LetBinding, Pat (..), Term (..), - TmName) -import CLaSH.Core.TyCon (TyCon, TyConName, tyConDataCons) -import CLaSH.Core.Type (KindOrType, Type (..), - TypeView (..), coreView, - typeKind, tyView) -import CLaSH.Core.Util (Delta, Gamma, collectArgs, - mkAbstraction, mkApps, mkId, - mkLams, mkTmApps, mkTyApps, - mkTyLams, mkTyVar, termType) -import CLaSH.Core.Var (Id, TyVar, Var (..)) -import CLaSH.Driver.Types (CLaSHException (..)) -import CLaSH.Netlist.Util (representableType) -import CLaSH.Rewrite.Types -import CLaSH.Util - --- | Lift an action working in the '_extra' state to the 'RewriteMonad' -zoomExtra :: State.State extra a - -> RewriteMonad extra a -zoomExtra m = R (\_ s -> case State.runState m (s ^. extra) of - (a,s') -> (a,s {_extra = s'},mempty)) - --- | Record if a transformation is succesfully applied -apply :: String -- ^ Name of the transformation - -> Rewrite extra -- ^ Transformation to be applied - -> Rewrite extra -apply name rewrite ctx expr = do - lvl <- Lens.view dbgLevel - let before = showDoc expr - (expr', anyChanged) <- traceIf (lvl >= DebugAll) ("Trying: " ++ name ++ " on:\n" ++ before) $ Writer.listen $ rewrite ctx expr - let hasChanged = Monoid.getAny anyChanged - Monad.when hasChanged $ transformCounter += 1 - let after = showDoc expr' - let expr'' = if hasChanged then expr' else expr - - Monad.when (lvl > DebugNone && hasChanged) $ do - tcm <- Lens.view tcCache - beforeTy <- termType tcm expr - let beforeFTV = Lens.setOf termFreeTyVars expr - beforeFV <- Lens.setOf <$> localFreeIds <*> pure expr - afterTy <- termType tcm expr' - let afterFTV = Lens.setOf termFreeTyVars expr - afterFV <- Lens.setOf <$> localFreeIds <*> pure expr' - let newFV = Set.size afterFTV > Set.size beforeFTV || - Set.size afterFV > Set.size beforeFV - Monad.when newFV $ - error ( concat [ $(curLoc) - , "Error when applying rewrite ", name - , " to:\n" , before - , "\nResult:\n" ++ after ++ "\n" - , "Changes free variables from: ", show (beforeFTV,beforeFV) - , "\nto: ", show (afterFTV,afterFV) - ] - ) - traceIf ( beforeTy /= afterTy) - ( concat [ $(curLoc) - , "Error when applying rewrite ", name - , " to:\n" , before - , "\nResult:\n" ++ after ++ "\n" - , "Changes type from:\n", showDoc beforeTy - , "\nto:\n", showDoc afterTy - ] - ) (return ()) - - Monad.when (lvl >= DebugApplied && not hasChanged && expr /= expr') $ - error $ $(curLoc) ++ "Expression changed without notice(" ++ name ++ "): before" ++ before ++ "\nafter:\n" ++ after - - traceIf (lvl >= DebugName && hasChanged) name $ - traceIf (lvl >= DebugApplied && hasChanged) ("Changes when applying rewrite to:\n" ++ before ++ "\nResult:\n" ++ after ++ "\n") $ - traceIf (lvl >= DebugAll && not hasChanged) ("No changes when applying rewrite " ++ name ++ " to:\n" ++ after ++ "\n") $ - return expr'' - --- | Perform a transformation on a Term -runRewrite :: String -- ^ Name of the transformation - -> Rewrite extra -- ^ Transformation to perform - -> Term -- ^ Term to transform - -> RewriteMonad extra Term -runRewrite name rewrite expr = apply name rewrite [] expr - --- | Evaluate a RewriteSession to its inner monad -runRewriteSession :: RewriteEnv - -> RewriteState extra - -> RewriteMonad extra a - -> a -runRewriteSession r s m = traceIf True ("Applied " ++ - show (s' ^. transformCounter) ++ - " transformations") - a - where - (a,s',_) = runR m r s - --- | Notify that a transformation has changed the expression -setChanged :: RewriteMonad extra () -setChanged = Writer.tell (Monoid.Any True) - --- | Identity function that additionally notifies that a transformation has --- changed the expression -changed :: a -> RewriteMonad extra a -changed val = do - Writer.tell (Monoid.Any True) - return val - --- | Create a type and kind context out of a transformation context -contextEnv :: [CoreContext] - -> (Gamma, Delta) -contextEnv = go HML.empty HML.empty - where - go gamma delta [] = (gamma,delta) - go gamma delta (LetBinding _ ids:ctx) = go gamma' delta ctx - where - gamma' = foldl addToGamma gamma ids - - go gamma delta (LetBody ids:ctx) = go gamma' delta ctx - where - gamma' = foldl addToGamma gamma ids - - go gamma delta (LamBody lId:ctx) = go gamma' delta ctx - where - gamma' = addToGamma gamma lId - - go gamma delta (TyLamBody tv:ctx) = go gamma delta' ctx - where - delta' = addToDelta delta tv - - go gamma delta (CaseAlt ids:ctx) = go gamma' delta ctx - where - gamma' = foldl addToGamma gamma ids - - go gamma delta (_:ctx) = go gamma delta ctx - - addToGamma gamma (Id idName ty) = HML.insert idName (unembed ty) gamma - addToGamma _ _ = error $ $(curLoc) ++ "Adding TyVar to Gamma" - - addToDelta delta (TyVar tvName ki) = HML.insert tvName (unembed ki) delta - addToDelta _ _ = error $ $(curLoc) ++ "Adding Id to Delta" - -closestLetBinder :: [CoreContext] -> Maybe Id -closestLetBinder [] = Nothing -closestLetBinder (LetBinding id_ _:_) = Just id_ -closestLetBinder (_:ctx) = closestLetBinder ctx - -mkDerivedName :: [CoreContext] -> String -> String -mkDerivedName ctx sf = case closestLetBinder ctx of - Just id_ -> ((++ ('_':sf)) . name2String . varName) id_ - _ -> sf - --- | Create a complete type and kind context out of the global binders and the --- transformation context -mkEnv :: [CoreContext] - -> RewriteMonad extra (Gamma, Delta) -mkEnv ctx = do - let (gamma,delta) = contextEnv ctx - tsMap <- fmap (HML.map (^. _1)) $ Lens.use bindings - let gamma' = tsMap `HML.union` gamma - return (gamma',delta) - --- | Make a new binder and variable reference for a term -mkTmBinderFor :: (Fresh m, MonadUnique m) - => HashMap TyConName TyCon -- ^ TyCon cache - -> String -- ^ Name of the new binder - -> Term -- ^ Term to bind - -> m (Id, Term) -mkTmBinderFor tcm name e = do - (Left r) <- mkBinderFor tcm name (Left e) - return r - --- | Make a new binder and variable reference for either a term or a type -mkBinderFor :: (Monad m, MonadUnique m, Fresh m) - => HashMap TyConName TyCon -- ^ TyCon cache - -> String -- ^ Name of the new binder - -> Either Term Type -- ^ Type or Term to bind - -> m (Either (Id,Term) (TyVar,Type)) -mkBinderFor tcm name (Left term) = - Left <$> (mkInternalVar name =<< termType tcm term) - -mkBinderFor tcm name (Right ty) = do - name' <- fmap (makeName name . toInteger) getUniqueM - let kind = typeKind tcm ty - return $ Right (TyVar name' (embed kind), VarTy kind name') - --- | Make a new, unique, identifier and corresponding variable reference -mkInternalVar :: (Monad m, MonadUnique m) - => String -- ^ Name of the identifier - -> KindOrType - -> m (Id,Term) -mkInternalVar name ty = do - name' <- fmap (makeName name . toInteger) getUniqueM - return (Id name' (embed ty),Var ty name') - --- | Inline the binders in a let-binding that have a certain property -inlineBinders :: (Term -> LetBinding -> RewriteMonad extra Bool) -- ^ Property test - -> Rewrite extra -inlineBinders condition _ expr@(Letrec b) = do - (xes,res) <- unbind b - let expr' = Letrec (bind xes res) - (replace,others) <- partitionM (condition expr') (unrec xes) - case replace of - [] -> return expr - _ -> do - let (others',res') = substituteBinders replace others res - newExpr = case others' of - [] -> res' - _ -> Letrec (bind (rec others') res') - - changed newExpr - -inlineBinders _ _ e = return e - --- | Determine whether a binder is a join-point created for a complex case --- expression. --- --- A join-point is when a local function only occurs in tail-call positions, --- and when it does, more than once. -isJoinPointIn :: Id -- ^ 'Id' of the local binder - -> Term -- ^ Expression in which the binder is bound - -> Bool -isJoinPointIn id_ e = case tailCalls id_ e of - Just n | n > 1 -> True - _ -> False - --- | Count the number of (only) tail calls of a function in an expression. --- 'Nothing' indicates that the function was used in a non-tail call position. -tailCalls :: Id -- ^ Function to check - -> Term -- ^ Expression to check it in - -> Maybe Int -tailCalls id_ expr = case expr of - Var _ nm | varName id_ == nm -> Just 1 - | otherwise -> Just 0 - Lam b -> let (_,expr') = unsafeUnbind b - in tailCalls id_ expr' - TyLam b -> let (_,expr') = unsafeUnbind b - in tailCalls id_ expr' - App l r -> case tailCalls id_ r of - Just 0 -> tailCalls id_ l - _ -> Nothing - TyApp l _ -> tailCalls id_ l - Letrec b -> - let (bsR,expr') = unsafeUnbind b - (bsIds,bsExprs) = unzip (unrec bsR) - bsTls = map (tailCalls id_ . unembed) bsExprs - bsIdsUsed = mapMaybe (\(l,r) -> pure l <* r) (zip bsIds bsTls) - bsIdsTls = map (`tailCalls` expr') bsIdsUsed - bsCount = pure . sum $ catMaybes bsTls - in case (all isJust bsTls) of - False -> Nothing - True -> case (all (==0) $ catMaybes bsTls) of - False -> case all isJust bsIdsTls of - False -> Nothing - True -> (+) <$> bsCount <*> tailCalls id_ expr' - True -> tailCalls id_ expr' - Case scrut _ alts -> - let scrutTl = tailCalls id_ scrut - altsTl = map (tailCalls id_ . snd . unsafeUnbind) alts - in case scrutTl of - Just 0 | all (/= Nothing) altsTl -> Just (sum (catMaybes altsTl)) - _ -> Nothing - _ -> Just 0 - --- | Determines whether a function has the following shape: --- --- > \(w :: Void) -> f a b c --- --- i.e. is a wrapper around a (partially) applied function 'f', where the --- introduced argument 'w' is not used by 'f' -isVoidWrapper :: Term -> Bool -isVoidWrapper (Lam b) = case unsafeUnbind b of - (bndr,e@(collectArgs -> (Var _ _,_))) -> varName bndr `notElem` Lens.toListOf termFreeIds e - _ -> False -isVoidWrapper _ = False - --- | Substitute the RHS of the first set of Let-binders for references to the --- first set of Let-binders in: the second set of Let-binders and the additional --- term -substituteBinders :: [LetBinding] -- ^ Let-binders to substitute - -> [LetBinding] -- ^ Let-binders where substitution takes place - -> Term -- ^ Expression where substitution takes place - -> ([LetBinding],Term) -substituteBinders [] others res = (others,res) -substituteBinders ((bndr,valE):rest) others res = substituteBinders rest' others' res' - where - val = unembed valE - bndrName = varName bndr - selfRef = bndrName `elem` Lens.toListOf termFreeIds val - (res',rest',others') = if selfRef - then (res,rest,(bndr,valE):others) - else ( substTm (varName bndr) val res - , map (second ( embed - . substTm bndrName val - . unembed) - ) rest - , map (second ( embed - . substTm bndrName val - . unembed) - ) others - ) - --- | Calculate the /local/ free variable of an expression: the free variables --- that are not bound in the global environment. -localFreeIds :: (Applicative f, Lens.Contravariant f) - => RewriteMonad extra ((TmName -> f TmName) -> Term -> f Term) -localFreeIds = do - globalBndrs <- Lens.use bindings - return ((termFreeIds . Lens.filtered (not . (`HML.member` globalBndrs)))) - -inlineOrLiftBinders :: (LetBinding -> RewriteMonad extra Bool) -- ^ Property test - -> (Term -> LetBinding -> RewriteMonad extra Bool) - -- ^ Test whether to lift or inline - -- - -- * True: inline - -- * False: lift - -> Rewrite extra -inlineOrLiftBinders condition inlineOrLift ctx expr@(Letrec b) = do - (xesR,res) <- unbind b - let xes = unrec xesR - (replace,others) <- partitionM condition xes - case replace of - [] -> return expr - _ -> do - -- Because 'unbind b' refreshes binders in xes, we must recreate - -- the let expression, and _not_ reuse 'expr' - let expr' = Letrec (bind xesR res) - (doInline,doLift) <- partitionM (inlineOrLift expr') replace - -- We first substitute the binders that we can inline both the binders - -- that we intend to lift, the other binders, and the body - let (others',res') = substituteBinders doInline (doLift ++ others) res - (doLift',others'') = splitAt (length doLift) others' - (gamma,delta) <- mkEnv (LetBinding undefined (map fst xes) : ctx) - doLift'' <- mapM (liftBinding gamma delta) doLift' - -- We then substitute the lifted binders in the other binders and the body - let (others3,res'') = substituteBinders doLift'' others'' res' - newExpr = case others3 of - [] -> res'' - _ -> Letrec (bind (rec others3) res'') - changed newExpr - -inlineOrLiftBinders _ _ _ e = return e - --- | Create a global function for a Let-binding and return a Let-binding where --- the RHS is a reference to the new global function applied to the free --- variables of the original RHS -liftBinding :: Gamma - -> Delta - -> LetBinding - -> RewriteMonad extra LetBinding -liftBinding gamma delta (Id idName tyE,eE) = do - let e = unembed eE - -- Get all local FVs, excluding the 'idName' from the let-binding - let localFTVs = List.nub $ Lens.toListOf termFreeTyVars e - localFVs <- List.nub <$> (Lens.toListOf <$> localFreeIds <*> pure e) - let localFTVkinds = map (\k -> HML.lookupDefault (error $ $(curLoc) ++ show k ++ " not found") k delta) localFTVs - localFVs' = filter (/= idName) localFVs - localFVtys' = map (\k -> HML.lookupDefault (error $ $(curLoc) ++ show k ++ " not found") k gamma) localFVs' - -- Abstract expression over its local FVs - boundFTVs = zipWith mkTyVar localFTVkinds localFTVs - boundFVs = zipWith mkId localFVtys' localFVs' - -- Make a new global ID - tcm <- Lens.view tcCache - newBodyTy <- termType tcm $ mkTyLams (mkLams e boundFVs) boundFTVs - (cf,sp) <- Lens.use curFun - newBodyId <- fmap (makeName (name2String cf ++ "_" ++ name2String idName) . toInteger) getUniqueM - -- Make a new expression, consisting of the the lifted function applied to - -- its free variables - let newExpr = mkTmApps - (mkTyApps (Var newBodyTy newBodyId) - (zipWith VarTy localFTVkinds localFTVs)) - (zipWith Var localFVtys' localFVs') - -- Substitute the recursive calls by the new expression - e' = substTm idName newExpr e - -- Create a new body that abstracts over the free variables - newBody = mkTyLams (mkLams e' boundFVs) boundFTVs - - -- Check if an alpha-equivalent global binder already exists - aeqExisting <- (HMS.toList . HMS.filter ((== newBody) . (^. _3))) <$> Lens.use bindings - case aeqExisting of - -- If it doesn't, create a new binder - [] -> do -- Add the created function to the list of global bindings - bindings %= HMS.insert newBodyId (newBodyTy,sp,newBody) - -- Return the new binder - return (Id idName tyE, embed newExpr) - -- If it does, use the existing binder - ((k,(aeqTy,_,_)):_) -> - let newExpr' = mkTmApps - (mkTyApps (Var aeqTy k) - (zipWith VarTy localFTVkinds localFTVs)) - (zipWith Var localFVtys' localFVs') - in return (Id idName tyE, embed newExpr') - -liftBinding _ _ _ = error $ $(curLoc) ++ "liftBinding: invalid core, expr bound to tyvar" - --- | Make a global function for a name-term tuple -mkFunction :: TmName -- ^ Name of the function - -> SrcSpan - -> Term -- ^ Term bound to the function - -> RewriteMonad extra (TmName,Type) -- ^ Name with a proper unique and the type of the function -mkFunction bndr sp body = do - tcm <- Lens.view tcCache - bodyTy <- termType tcm body - bodyId <- cloneVar bndr - addGlobalBind bodyId bodyTy sp body - return (bodyId,bodyTy) - --- | Add a function to the set of global binders -addGlobalBind :: TmName - -> Type - -> SrcSpan - -> Term - -> RewriteMonad extra () -addGlobalBind vId ty sp body = (ty,body) `deepseq` bindings %= HMS.insert vId (ty,sp,body) - --- | Create a new name out of the given name, but with another unique -cloneVar :: TmName - -> RewriteMonad extra TmName -cloneVar name = fmap (makeName (name2String name) . toInteger) getUniqueM - - --- | Test whether a term is a variable reference to a local binder -isLocalVar :: Term - -> RewriteMonad extra Bool -isLocalVar (Var _ name) - = fmap (not . HML.member name) - $ Lens.use bindings -isLocalVar _ = return False - -{-# INLINE isUntranslatable #-} --- | Determine if a term cannot be represented in hardware -isUntranslatable :: Term - -> RewriteMonad extra Bool -isUntranslatable tm = do - tcm <- Lens.view tcCache - not <$> (representableType <$> Lens.view typeTranslator - <*> Lens.view allowZero - <*> pure tcm - <*> termType tcm tm) - -{-# INLINE isUntranslatableType #-} --- | Determine if a type cannot be represented in hardware -isUntranslatableType :: Type - -> RewriteMonad extra Bool -isUntranslatableType ty = - not <$> (representableType <$> Lens.view typeTranslator - <*> Lens.view allowZero - <*> Lens.view tcCache - <*> pure ty) - --- | Is the Context a Lambda/Term-abstraction context? -isLambdaBodyCtx :: CoreContext - -> Bool -isLambdaBodyCtx (LamBody _) = True -isLambdaBodyCtx _ = False - --- | Make a binder that should not be referenced -mkWildValBinder :: (Monad m, MonadUnique m) - => Type - -> m Id -mkWildValBinder = fmap fst . mkInternalVar "wild" - --- | Make a case-decomposition that extracts a field out of a (Sum-of-)Product type -mkSelectorCase :: (Functor m, Monad m, MonadUnique m, Fresh m) - => String -- ^ Name of the caller of this function - -> HashMap TyConName TyCon -- ^ TyCon cache - -> Term -- ^ Subject of the case-composition - -> Int -- n'th DataCon - -> Int -- n'th field - -> m Term -mkSelectorCase caller tcm scrut dcI fieldI = do - scrutTy <- termType tcm scrut - go scrutTy - where - go (coreView tcm -> Just ty') = go ty' - go scrutTy@(tyView -> TyConApp tc args) = - case tyConDataCons (tcm HMS.! tc) of - [] -> cantCreate $(curLoc) ("TyCon has no DataCons: " ++ show tc ++ " " ++ showDoc tc) scrutTy - dcs | dcI > length dcs -> cantCreate $(curLoc) "DC index exceeds max" scrutTy - | otherwise -> do - let dc = indexNote ($(curLoc) ++ "No DC with tag: " ++ show (dcI-1)) dcs (dcI-1) - let (Just fieldTys) = dataConInstArgTys dc args - if fieldI >= length fieldTys - then cantCreate $(curLoc) "Field index exceed max" scrutTy - else do - wildBndrs <- mapM mkWildValBinder fieldTys - let ty = indexNote ($(curLoc) ++ "No DC field#: " ++ show fieldI) fieldTys fieldI - selBndr <- mkInternalVar "sel" ty - let bndrs = take fieldI wildBndrs ++ [fst selBndr] ++ drop (fieldI+1) wildBndrs - pat = DataPat (embed dc) (rebind [] bndrs) - retVal = Case scrut ty [ bind pat (snd selBndr) ] - return retVal - go scrutTy = cantCreate $(curLoc) ("Type of subject is not a datatype: " ++ showDoc scrutTy) scrutTy - - cantCreate loc info scrutTy = error $ loc ++ "Can't create selector " ++ show (caller,dcI,fieldI) ++ " for: (" ++ showDoc scrut ++ " :: " ++ showDoc scrutTy ++ ")\nAdditional info: " ++ info - --- | Specialise an application on its argument -specialise :: Lens' extra (Map.Map (TmName, Int, Either Term Type) (TmName,Type)) -- ^ Lens into previous specialisations - -> Lens' extra (HashMap TmName Int) -- ^ Lens into the specialisation history - -> Lens' extra Int -- ^ Lens into the specialisation limit - -> Rewrite extra -specialise specMapLbl specHistLbl specLimitLbl ctx e = case e of - (TyApp e1 ty) -> specialise' specMapLbl specHistLbl specLimitLbl ctx e (collectArgs e1) (Right ty) - (App e1 e2) -> specialise' specMapLbl specHistLbl specLimitLbl ctx e (collectArgs e1) (Left e2) - _ -> return e - --- | Specialise an application on its argument -specialise' :: Lens' extra (Map.Map (TmName, Int, Either Term Type) (TmName,Type)) -- ^ Lens into previous specialisations - -> Lens' extra (HashMap TmName Int) -- ^ Lens into specialisation history - -> Lens' extra Int -- ^ Lens into the specialisation limit - -> [CoreContext] -- Transformation context - -> Term -- ^ Original term - -> (Term, [Either Term Type]) -- ^ Function part of the term, split into root and applied arguments - -> Either Term Type -- ^ Argument to specialize on - -> RewriteMonad extra Term -specialise' specMapLbl specHistLbl specLimitLbl ctx e (Var _ f, args) specArg = do - lvl <- Lens.view dbgLevel - -- Create binders and variable references for free variables in 'specArg' - (specBndrs,specVars) <- specArgBndrsAndVars ctx specArg - let argLen = length args - specAbs = either (Left . (`mkAbstraction` specBndrs)) (Right . id) specArg - -- Determine if 'f' has already been specialized on 'specArg' - specM <- Map.lookup (f,argLen,specAbs) <$> Lens.use (extra.specMapLbl) - case specM of - -- Use previously specialized function - Just (fname,fty) -> - traceIf (lvl >= DebugApplied) ("Using previous specialization of " ++ showDoc f ++ " on " ++ (either showDoc showDoc) specAbs ++ ": " ++ showDoc fname) $ - changed $ mkApps (Var fty fname) (args ++ specVars) - -- Create new specialized function - Nothing -> do - -- Determine if we can specialize f - bodyMaybe <- fmap (HML.lookup f) $ Lens.use bindings - case bodyMaybe of - Just (_,sp,bodyTm) -> do - -- Determine if we see a sequence of specialisations on a growing argument - specHistM <- HML.lookup f <$> Lens.use (extra.specHistLbl) - specLim <- Lens.use (extra . specLimitLbl) - if maybe False (> specLim) specHistM - then throw (CLaSHException - sp - (unlines [ "Hit specialisation limit " ++ show specLim ++ " on function `" ++ showDoc f ++ "'.\n" - , "The function `" ++ showDoc f ++ "' is most likely recursive, and looks like it is being indefinitely specialized on a growing argument.\n" - , "Body of `" ++ showDoc f ++ "':\n" ++ showDoc bodyTm ++ "\n" - , "Argument (in position: " ++ show argLen ++ ") that triggered termination:\n" ++ (either showDoc showDoc) specArg - , "Run with '-clash-spec-limit=N' to increase the specialisation limit to N." - ]) - Nothing) - else do - -- Make new binders for existing arguments - tcm <- Lens.view tcCache - (boundArgs,argVars) <- fmap (unzip . map (either (Left *** Left) (Right *** Right))) $ - mapM (mkBinderFor tcm "pTS") args - -- Create specialized functions - let newBody = mkAbstraction (mkApps bodyTm (argVars ++ [specArg])) (boundArgs ++ specBndrs) - newf <- mkFunction f sp newBody - -- Remember specialization - (extra.specHistLbl) %= HML.insertWith (+) f 1 - (extra.specMapLbl) %= Map.insert (f,argLen,specAbs) newf - -- use specialized function - let newExpr = mkApps ((uncurry . flip) Var newf) (args ++ specVars) - newf `deepseq` changed newExpr - Nothing -> return e - -specialise' _ _ _ ctx _ (appE,args) (Left specArg) = do - -- Create binders and variable references for free variables in 'specArg' - (specBndrs,specVars) <- specArgBndrsAndVars ctx (Left specArg) - -- Create specialized function - let newBody = mkAbstraction specArg specBndrs - -- See if there's an existing binder that's alpha-equivalent to the - -- specialised function - existing <- HML.filter ((== newBody) . (^. _3)) <$> Lens.use bindings - -- Create a new function if an alpha-equivalent binder doesn't exist - newf <- case HML.toList existing of - [] -> do (cf,sp) <- Lens.use curFun - mkFunction (string2Name (name2String cf ++ "_" ++ "specF")) sp newBody - ((k,(kTy,_,_)):_) -> return (k,kTy) - -- cf <- Lens.use curFun - -- newf <- mkFunction (string2Name (name2String cf ++ "_" ++ "specF")) newBody - -- Create specialized argument - let newArg = Left $ mkApps ((uncurry . flip) Var newf) specVars - -- Use specialized argument - let newExpr = mkApps appE (args ++ [newArg]) - changed newExpr - -specialise' _ _ _ _ e _ _ = return e - --- | Create binders and variable references for free variables in 'specArg' -specArgBndrsAndVars :: [CoreContext] - -> Either Term Type - -> RewriteMonad extra ([Either Id TyVar],[Either Term Type]) -specArgBndrsAndVars ctx specArg = do - let specFTVs = List.nub $ either (Lens.toListOf termFreeTyVars) (Lens.toListOf typeFreeVars) specArg - specFVs <- List.nub <$> either ((Lens.toListOf <$> localFreeIds <*>) . pure) (const (pure [])) specArg - (gamma,delta) <- mkEnv ctx - let (specTyBndrs,specTyVars) = unzip - $ map (\tv -> let ki = HML.lookupDefault (error $ $(curLoc) ++ show tv ++ " not found") tv delta - in (Right $ TyVar tv (embed ki), Right $ VarTy ki tv)) specFTVs - (specTmBndrs,specTmVars) = unzip - $ map (\tm -> let ty = HML.lookupDefault (error $ $(curLoc) ++ show tm ++ " not found") tm gamma - in (Left $ Id tm (embed ty), Left $ Var ty tm)) specFVs - return (specTyBndrs ++ specTmBndrs,specTyVars ++ specTmVars) diff --git a/src/CLaSH/Util.hs b/src/CLaSH/Util.hs deleted file mode 100644 --- a/src/CLaSH/Util.hs +++ /dev/null @@ -1,243 +0,0 @@ -{-| - Copyright : (C) 2012-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Assortment of utility function used in the CLaSH library --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TupleSections #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module CLaSH.Util - ( module CLaSH.Util - , module X - , makeLenses - ) -where - -import Control.Applicative as X (Applicative,(<$>),(<*>),pure) -import Control.Arrow as X ((***),first,second) -import Control.DeepSeq -import Control.Monad as X ((<=<),(>=>)) -import Control.Monad.State (MonadState,State,StateT,runState) -import qualified Control.Monad.State as State -import Control.Monad.Trans.Class (MonadTrans,lift) -import Data.Function as X (on) -import Data.Hashable (Hashable) -import Data.HashMap.Lazy (HashMap) -import qualified Data.HashMap.Lazy as HashMapL -import qualified Data.HashMap.Strict as HashMapS -import Data.Maybe (fromMaybe) -import Data.Version (Version) -import Control.Lens -import Debug.Trace (trace) -import GHC.Base (Int(..),isTrue#,(==#),(+#)) -import GHC.Integer.Logarithms (integerLogBase#) -import qualified Language.Haskell.TH as TH - -#ifdef CABAL -import qualified Paths_clash_lib (version) -#endif - --- | A class that can generate unique numbers -class MonadUnique m where - -- | Get a new unique - getUniqueM :: m Int - -instance Monad m => MonadUnique (StateT Int m) where - getUniqueM = do - supply <- State.get - State.modify (+1) - return supply - --- | Create a TH expression that returns the a formatted string containing the --- name of the module 'curLoc' is spliced into, and the line where it was spliced. -curLoc :: TH.Q TH.Exp -curLoc = do - (TH.Loc _ _ modName (startPosL,_) _) <- TH.location - TH.litE (TH.StringL $ modName ++ "(" ++ show startPosL ++ "): ") - --- | Cache the result of a monadic action -makeCached :: (MonadState s m, Hashable k, Eq k) - => k -- ^ The key the action is associated with - -> Lens' s (HashMap k v) -- ^ The Lens to the HashMap that is the cache - -> m v -- ^ The action to cache - -> m v -makeCached key l create = do - cache <- use l - case HashMapL.lookup key cache of - Just value -> return value - Nothing -> do - value <- create - l %= HashMapL.insert key value - return value - --- | Cache the result of a monadic action in a State 3 transformer layers down -makeCachedT3 :: ( MonadTrans t2, MonadTrans t1, MonadTrans t - , Eq k, Hashable k - , MonadState s m - , Monad (t2 m), Monad (t1 (t2 m)), Monad (t (t1 (t2 m)))) - => k -- ^ The key the action is associated with - -> Lens' s (HashMap k v) -- ^ The Lens to the HashMap that is the cache - -> (t (t1 (t2 m))) v -- ^ The action to cache - -> (t (t1 (t2 m))) v -makeCachedT3 key l create = do - cache <- (lift . lift . lift) $ use l - case HashMapL.lookup key cache of - Just value -> return value - Nothing -> do - value <- create - (lift . lift . lift) $ l %= HashMapL.insert key value - return value - --- | Spine-strict cache variant of 'mkCachedT3' -makeCachedT3S :: ( MonadTrans t2, MonadTrans t1, MonadTrans t - , Eq k, Hashable k - , MonadState s m - , Monad (t2 m), Monad (t1 (t2 m)), Monad (t (t1 (t2 m))) - , NFData v) - => k - -> Lens' s (HashMap k v) - -> (t (t1 (t2 m))) v - -> (t (t1 (t2 m))) v -makeCachedT3S key l create = do - cache <- (lift . lift . lift) $ use l - case HashMapS.lookup key cache of - Just value -> return value - Nothing -> do - value <- create - value `deepseq` ((lift . lift . lift) $ l %= HashMapS.insert key value) - return value - --- | Run a State-action using the State that is stored in a higher-layer Monad -liftState :: (MonadState s m) - => Lens' s s' -- ^ Lens to the State in the higher-layer monad - -> State s' a -- ^ The State-action to perform - -> m a -liftState l m = do - s <- use l - let (a,s') = runState m s - l .= s' - return a - --- | Functorial version of 'Control.Arrow.first' -firstM :: Functor f - => (a -> f c) - -> (a, b) - -> f (c, b) -firstM f (x,y) = (,y) <$> f x - --- | Functorial version of 'Control.Arrow.second' -secondM :: Functor f - => (b -> f c) - -> (a, b) - -> f (a, c) -secondM f (x,y) = (x,) <$> f y - -combineM :: (Applicative f) - => (a -> f b) - -> (c -> f d) - -> (a,c) - -> f (b,d) -combineM f g (x,y) = (,) <$> f x <*> g y - --- | Performs trace when first argument evaluates to 'True' -traceIf :: Bool -> String -> a -> a -traceIf True msg = trace msg -traceIf False _ = id - --- | Monadic version of 'Data.List.partition' -partitionM :: Monad m - => (a -> m Bool) - -> [a] - -> m ([a], [a]) -partitionM _ [] = return ([], []) -partitionM p (x:xs) = do - test <- p x - (ys, ys') <- partitionM p xs - return $ if test then (x:ys, ys') else (ys, x:ys') - --- | Monadic version of 'Data.List.mapAccumL' -mapAccumLM :: (Monad m) - => (acc -> x -> m (acc,y)) - -> acc - -> [x] - -> m (acc,[y]) -mapAccumLM _ acc [] = return (acc,[]) -mapAccumLM f acc (x:xs) = do - (acc',y) <- f acc x - (acc'',ys) <- mapAccumLM f acc' xs - return (acc'',y:ys) - --- | Composition of a unary function with a binary function -dot :: (c -> d) -> (a -> b -> c) -> a -> b -> d -dot = (.) . (.) - --- | if-then-else as a function on an argument -ifThenElse :: (a -> Bool) - -> (a -> b) - -> (a -> b) - -> a - -> b -ifThenElse t f g a = if t a then f a else g a - -infixr 5 <:> --- | Applicative version of 'GHC.Types.(:)' -(<:>) :: Applicative f - => f a - -> f [a] - -> f [a] -x <:> xs = (:) <$> x <*> xs - --- | Safe indexing, returns a 'Nothing' if the index does not exist -indexMaybe :: [a] - -> Int - -> Maybe a -indexMaybe [] _ = Nothing -indexMaybe (x:_) 0 = Just x -indexMaybe (_:xs) n = indexMaybe xs (n-1) - --- | Unsafe indexing, return a custom error message when indexing fails -indexNote :: String - -> [a] - -> Int - -> a -indexNote note = fromMaybe (error note) `dot` indexMaybe - --- | Split the second list at the length of the first list -splitAtList :: [b] -> [a] -> ([a], [a]) -splitAtList [] xs = ([], xs) -splitAtList _ xs@[] = (xs, xs) -splitAtList (_:xs) (y:ys) = (y:ys', ys'') - where - (ys', ys'') = splitAtList xs ys - -clashLibVersion :: Version -#ifdef CABAL -clashLibVersion = Paths_clash_lib.version -#else -clashLibVersion = error "development version" -#endif - --- | \x y -> floor (logBase x y), x > 1 && y > 0 -flogBase :: Integer -> Integer -> Maybe Int -flogBase x y | x > 1 && y > 0 = Just (I# (integerLogBase# x y)) -flogBase _ _ = Nothing - --- | \x y -> ceiling (logBase x y), x > 1 && y > 0 -clogBase :: Integer -> Integer -> Maybe Int -clogBase x y | x > 1 && y > 0 = - case y of - 1 -> Just 0 - _ -> let z1 = integerLogBase# x y - z2 = integerLogBase# x (y-1) - in if isTrue# (z1 ==# z2) - then Just (I# (z1 +# 1#)) - else Just (I# z1) -clogBase _ _ = Nothing diff --git a/src/Clash/Annotations/TopEntity/Extra.hs b/src/Clash/Annotations/TopEntity/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Annotations/TopEntity/Extra.hs @@ -0,0 +1,24 @@ +{-| + Copyright : (C) 2017, Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij +-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Clash.Annotations.TopEntity.Extra where + +import Clash.Annotations.TopEntity (TopEntity, PortName) +import Language.Haskell.TH.Syntax + (ModName, Name, NameFlavour, NameSpace, PkgName, OccName) +import Data.Hashable (Hashable) + +instance Hashable TopEntity +instance Hashable PortName + +instance Hashable ModName +instance Hashable Name +instance Hashable NameFlavour +instance Hashable NameSpace +instance Hashable PkgName +instance Hashable OccName diff --git a/src/Clash/Backend.hs b/src/Clash/Backend.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Backend.hs @@ -0,0 +1,155 @@ +{-| + Copyright : (C) 2015-2016, University of Twente, + 2017 , Myrtle Software Ltd, Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij +-} + +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} + +module Clash.Backend where + +import Data.HashSet (HashSet) +import Data.Maybe (fromMaybe) +import Data.Semigroup.Monad (Mon) +import qualified Data.Text.Lazy as T +import Data.Text.Lazy (Text) +import Control.Monad.State (State) +import Data.Text.Prettyprint.Doc.Extra (Doc) + +import SrcLoc (SrcSpan) + +import Clash.Netlist.Id +import Clash.Netlist.Types +import Clash.Netlist.BlackBox.Types + +import Clash.Annotations.Primitive (HDL) + +type ModName = String + +-- | Is a type used for internal or external use +data Usage + = Internal + -- ^ Internal use + | External Text + -- ^ External use, field indicates the library name + +class Backend state where + -- | Initial state for state monad + initBackend :: Int -> HdlSyn -> state + + -- | What HDL is the backend generating + hdlKind :: state -> HDL + + -- | Location for the primitive definitions + primDirs :: state -> IO [FilePath] + + -- | Name of backend, used for directory to put output files in. Should be + -- | constant function / ignore argument. + name :: state -> String + + -- | File extension for target langauge + extension :: state -> String + + -- | Get the set of types out of state + extractTypes :: state -> HashSet HWType + + -- | Generate HDL for a Netlist component + genHDL :: String -> SrcSpan -> Component -> Mon (State state) ((String, Doc),[(String,Doc)]) + -- | Generate a HDL package containing type definitions for the given HWTypes + mkTyPackage :: String -> [HWType] -> Mon (State state) [(String, Doc)] + -- | Convert a Netlist HWType to a target HDL type + hdlType :: Usage -> HWType -> Mon (State state) Doc + -- | Convert a Netlist HWType to an HDL error value for that type + hdlTypeErrValue :: HWType -> Mon (State state) Doc + -- | Convert a Netlist HWType to the root of a target HDL type + hdlTypeMark :: HWType -> Mon (State state) Doc + -- | Create a signal declaration from an identifier (Text) and Netlist HWType + hdlSig :: Text -> HWType -> Mon (State state) Doc + -- | Create a generative block statement marker + genStmt :: Bool -> State state Doc + -- | Turn a Netlist Declaration to a HDL concurrent block + inst :: Declaration -> Mon (State state) (Maybe Doc) + -- | Turn a Netlist expression into a HDL expression + expr :: Bool -> Expr -> Mon (State state) Doc + -- | Bit-width of Int/Word/Integer + iwWidth :: State state Int + -- | Convert to a bit-vector + toBV :: HWType -> Text -> Mon (State state) Doc + -- | Convert from a bit-vector + fromBV :: HWType -> Text -> Mon (State state) Doc + -- | Synthesis tool we're generating HDL for + hdlSyn :: State state HdlSyn + -- | mkIdentifier + mkIdentifier :: State state (IdType -> Identifier -> Identifier) + -- | mkIdentifier + extendIdentifier :: State state (IdType -> Identifier -> Identifier -> Identifier) + -- | setModName + setModName :: ModName -> state -> state + -- | setSrcSpan + setSrcSpan :: SrcSpan -> State state () + -- | getSrcSpan + getSrcSpan :: State state SrcSpan + -- | Block of declarations + blockDecl :: Text -> [Declaration] -> Mon (State state) Doc + -- | unextend/unescape identifier + unextend :: State state (Identifier -> Identifier) + addInclude :: (String, Doc) -> State state () + addLibraries :: [Text] -> State state () + addImports :: [Text] -> State state () + +-- | Try to merge nested modifiers into a single modifier, needed by the VHDL +-- and SystemVerilog backend. +nestM :: Modifier -> Modifier -> Maybe Modifier +nestM (Nested a b) m2 + | Just m1 <- nestM a b = maybe (Just (Nested m1 m2)) Just (nestM m1 m2) + | Just m2' <- nestM b m2 = maybe (Just (Nested a m2')) Just (nestM a m2') + +nestM (Indexed (Vector n t1,1,1)) (Indexed (Vector _ t2,1,0)) + | t1 == t2 = Just (Indexed (Vector n t1,10,1)) + +nestM (Indexed (Vector n t1,1,1)) (Indexed (Vector _ t2,10,k)) + | t1 == t2 = Just (Indexed (Vector n t1,10,k+1)) + +nestM (Indexed (RTree d1 t1,1,n)) (Indexed (RTree d2 t2,0,0)) + | t1 == t2 + , d1 >= 0 + , d2 >= 0 + = Just (Indexed (RTree d1 t1,10,n)) + +nestM (Indexed (RTree d1 t1,1,n)) (Indexed (RTree d2 t2,1,m)) + | t1 == t2 + , d1 >= 0 + , d2 >= 0 + = if | n == 1 && m == 1 -> let r = 2 ^ d1 + l = r - (2 ^ (d1-1) `div` 2) + in Just (Indexed (RTree (-1) t1, l, r)) + | n == 1 && m == 0 -> let l = 2 ^ (d1-1) + r = l + (l `div` 2) + in Just (Indexed (RTree (-1) t1, l, r)) + | n == 0 && m == 1 -> let l = (2 ^ (d1-1)) `div` 2 + r = 2 ^ (d1-1) + in Just (Indexed (RTree (-1) t1, l, r)) + | n == 0 && m == 0 -> let l = 0 + r = (2 ^ (d1-1)) `div` 2 + in Just (Indexed (RTree (-1) t1, l, r)) +nestM (Indexed (RTree (-1) t1,l,_)) (Indexed (RTree d t2,10,k)) + | t1 == t2 + , d >= 0 + = Just (Indexed (RTree d t1,10,l+k)) + +nestM _ _ = Nothing + +-- | Replace a normal HDL template placeholder with an unescaped/unextended +-- template placeholder. +-- +-- Needed when the the place-holder is filled with an escaped/extended identifier +-- inside an escaped/extended identifier and we want to strip the escape +-- /extension markers. Otherwise we end up with illegal identifiers. +escapeTemplate :: Identifier -> Identifier +escapeTemplate "~RESULT" = "~ERESULT" +escapeTemplate t = fromMaybe t $ do + t1 <- T.stripPrefix "~ARG[" t + n <- T.stripSuffix "]" t1 + pure (T.concat ["~EARG[",n,"]"]) diff --git a/src/Clash/Backend/SystemVerilog.hs b/src/Clash/Backend/SystemVerilog.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Backend/SystemVerilog.hs @@ -0,0 +1,1008 @@ +{-| + Copyright : (C) 2015-2016, University of Twente, + 2017, Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Generate SystemVerilog for assorted Netlist datatypes +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +module Clash.Backend.SystemVerilog (SystemVerilogState) where + +import qualified Control.Applicative as A +import Control.Lens hiding (Indexed) +import Control.Monad (forM,liftM,zipWithM) +import Control.Monad.State (State) +import Data.Graph.Inductive (Gr, mkGraph, topsort') +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Lazy as HashMap +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet +import Data.List (nub, nubBy) +import Data.Maybe (catMaybes,fromMaybe,mapMaybe) +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid hiding (Sum, Product) +#endif +import Data.Semigroup.Monad +import Data.Text.Lazy (pack,unpack) +import qualified Data.Text.Lazy as Text +import Data.Text.Prettyprint.Doc.Extra +#ifdef CABAL +import qualified Data.Version +#endif +import qualified System.FilePath + +import Clash.Annotations.Primitive (HDL (..)) +import Clash.Backend +import Clash.Backend.Verilog (include) +import Clash.Driver.Types (SrcSpan, noSrcSpan) +import Clash.Netlist.BlackBox.Types (HdlSyn (..)) +import Clash.Netlist.BlackBox.Util (extractLiterals, renderBlackBox) +import Clash.Netlist.Id (IdType (..), mkBasicId') +import Clash.Netlist.Types hiding (_intWidth, intWidth) +import Clash.Netlist.Util hiding (mkIdentifier, extendIdentifier) +import Clash.Signal.Internal (ClockKind (..)) +import Clash.Util (curLoc, makeCached, (<:>)) + +#ifdef CABAL +import qualified Paths_clash_lib +#endif + +-- | State for the 'Clash.Backend.SystemVerilog.SystemVerilogM' monad: +data SystemVerilogState = + SystemVerilogState + { _tyCache :: HashSet HWType -- ^ Previously encountered HWTypes + , _tySeen :: [Identifier] -- ^ Product type counter + , _nameCache :: HashMap HWType Doc -- ^ Cache for previously generated product type names + , _genDepth :: Int -- ^ Depth of current generative block + , _modNm :: String + , _idSeen :: [Identifier] + , _oports :: [Identifier] + , _srcSpan :: SrcSpan + , _includes :: [(String,Doc)] + , _imports :: [Text.Text] + , _intWidth :: Int -- ^ Int/Word/Integer bit-width + , _hdlsyn :: HdlSyn + } + +makeLenses ''SystemVerilogState + +primsRoot :: IO FilePath +#ifdef CABAL +primsRoot = Paths_clash_lib.getDataFileName "prims" +#else +primsRoot = return ("clash-lib" System.FilePath. "prims") +#endif + +instance Backend SystemVerilogState where + initBackend = SystemVerilogState HashSet.empty [] HashMap.empty 0 "" [] [] noSrcSpan [] [] + hdlKind = const SystemVerilog + primDirs = const $ do root <- primsRoot + return [ root System.FilePath. "common" + , root System.FilePath. "commonverilog" + , root System.FilePath. "systemverilog" + ] + extractTypes = _tyCache + name = const "systemverilog" + extension = const ".sv" + + genHDL = genVerilog + mkTyPackage = mkTyPackage_ + hdlType _ = verilogType + hdlTypeErrValue = verilogTypeErrValue + hdlTypeMark = verilogTypeMark + hdlSig t ty = sigDecl (string t) ty + genStmt True = do cnt <- use genDepth + genDepth += 1 + if cnt > 0 + then emptyDoc + else "generate" + genStmt False = do genDepth -= 1 + cnt <- use genDepth + if cnt > 0 + then emptyDoc + else "endgenerate" + inst = inst_ + expr = expr_ + iwWidth = use intWidth + toBV hty id_ = toSLV hty (Identifier id_ Nothing) + fromBV hty id_ = simpleFromSLV hty id_ + hdlSyn = use hdlsyn + mkIdentifier = return go + where + go Basic nm = filterReserved (mkBasicId' True nm) + go Extended (rmSlash . escapeTemplate -> nm) = case go Basic nm of + nm' | nm /= nm' -> Text.concat ["\\",nm," "] + |otherwise -> nm' + extendIdentifier = return go + where + go Basic nm ext = filterReserved (mkBasicId' True (nm `Text.append` ext)) + go Extended (rmSlash -> nm) ext = + let nmExt = nm `Text.append` ext + in case go Basic nm ext of + nm' | nm' /= nmExt -> case Text.head nmExt of + '#' -> Text.concat ["\\",nmExt," "] + _ -> Text.concat ["\\#",nmExt," "] + | otherwise -> nm' + + setModName nm s = s {_modNm = nm} + setSrcSpan = (srcSpan .=) + getSrcSpan = use srcSpan + blockDecl _ ds = do + decs <- decls ds + if isEmpty decs + then insts ds + else + pure decs <> line <> + insts ds + unextend = return rmSlash + addInclude inc = includes %= (inc:) + addLibraries _ = return () + addImports inps = imports %= (inps ++) + +rmSlash :: Identifier -> Identifier +rmSlash nm = fromMaybe nm $ do + nm1 <- Text.stripPrefix "\\" nm + pure (Text.filter (not . (== ' ')) nm1) + +type SystemVerilogM a = Mon (State SystemVerilogState) a + +-- List of reserved SystemVerilog-2012 keywords +reservedWords :: [Identifier] +reservedWords = ["accept_on","alias","always","always_comb","always_ff" + ,"always_latch","and","assert","assign","assume","automatic","before","begin" + ,"bind","bins","binsof","bit","break","buf","bufif0","bufif1","byte","case" + ,"casex","casez","cell","chandle","checker","class","clocking","cmos","config" + ,"const","constraint","context","continue","cover","covergroup","coverpoint" + ,"cross","deassign","default","defparam","design","disable","dist","do","edge" + ,"else","end","endcase","endchecker","endclass","endclocking","endconfig" + ,"endfunction","endgenerate","endgroup","endinterface","endmodule","endpackage" + ,"endprimitive","endprogram","endproperty","endspecify","endsequence" + ,"endtable","endtask","enum","event","eventually","expect","export","extends" + ,"extern","final","first_match","for","force","foreach","forever","fork" + ,"forkjoin","function","generate","genvar","global","highz0","highz1","if" + ,"iff","ifnone","ignore_bins","illegal_bins","implements","implies","import" + ,"incdir","include","initial","inout","input","inside","instance","int" + ,"integer","interconnect","interface","intersect","join","join_any" + ,"join_none","large","let","liblist","library","local","localparam","logic" + ,"longint","macromodule","matches","medium","modport","module","nand" + ,"negedge","nettype","new","nexttime","nmos","nor","noshowcancelled","not" + ,"notif0","notif1","null","or","output","package","packed","parameter","pmos" + ,"posedge","primitive","priority","program","property","protected","pull0" + ,"pull1","pulldown","pullup","pulsestyle_ondetect","pulsestyle_onevent" + ,"pure","rand","randc","randcase","randsequence","rcmos","real","realtime" + ,"ref","reg","reject_on","release","repeat","restrict","return","rnmos" + ,"rpmos","rtran","rtranif0","rtranif1","s_always","s_eventually","s_nexttime" + ,"s_until","s_until_with","scalared","sequence","shortint","shortreal" + ,"showcancelled","signed","small","soft","solve","specify","specparam" + ,"static","string","strong","strong0","strong1","struct","super","supply0" + ,"supply1","sync_accept_on","sync_reject_on","table","tagged","task","this" + ,"throughout","time","timeprecision","timeunit","tran","tranif0","tranif1" + ,"tri","tri0","tri1","triand","trior","trireg","type","typedef","union" + ,"unique","unique0","unsigned","until","until_with","untyped","use","uwire" + ,"var","vectored","virtual","void","wait","wait_order","wand","weak","weak0" + ,"weak1","while","wildcard","wire","with","within","wor","xnor","xor"] + +filterReserved :: Identifier -> Identifier +filterReserved s = if s `elem` reservedWords + then s `Text.append` "_r" + else s + +-- | Generate VHDL for a Netlist component +genVerilog :: String -> SrcSpan -> Component -> SystemVerilogM ((String,Doc),[(String,Doc)]) +genVerilog _ sp c = do + Mon $ setSrcSpan sp + v <- verilog + incs <- Mon $ use includes + return ((unpack cName,v),incs) + where + cName = componentName c + verilog = commentHeader <> line <> + module_ c +#ifdef CABAL + clashVer = Data.Version.showVersion Paths_clash_lib.version +#else + clashVer = "development" +#endif + commentHeader + = "/* AUTOMATICALLY GENERATED SYSTEMVERILOG-2005 SOURCE CODE." + <> line <> "** GENERATED BY CLASH " <> string (Text.pack clashVer) <> ". DO NOT MODIFY." + <> line <> "*/" + +-- | Generate a SystemVerilog package containing type definitions for the given HWTypes +mkTyPackage_ :: String + -> [HWType] + -> SystemVerilogM [(String,Doc)] +mkTyPackage_ modName hwtys = + (:[]) A.<$> (modName ++ "_types",) A.<$> + "package" <+> modNameD <> "_types" <> semi <> line <> + indent 2 packageDec <> line <> + indent 2 funDecs <> line <> + "endpackage" <+> colon <+> modNameD <> "_types" + where + modNameD = string (pack modName) + usedTys = concatMap mkUsedTys hwtys + needsDec = nubBy eqReprTy $ (hwtys ++ usedTys) + hwTysSorted = topSortHWTys needsDec + packageDec = vcat $ fmap catMaybes $ mapM tyDec hwTysSorted + funDecs = vcat $ fmap catMaybes $ mapM funDec hwTysSorted + + eqReprTy :: HWType -> HWType -> Bool + eqReprTy (Vector n ty1) (Vector m ty2) + | m == n = eqReprTy ty1 ty2 + | otherwise = False + eqReprTy (RTree n ty1) (RTree m ty2) + | m == n = eqReprTy ty1 ty2 + | otherwise = False + eqReprTy Bit ty2 = ty2 `elem` [Bit,Bool] + eqReprTy Bool ty2 = ty2 `elem` [Bit,Bool] + eqReprTy ty1 ty2 + | isUnsigned ty1 && isUnsigned ty2 = typeSize ty1 == typeSize ty2 + | otherwise = ty1 == ty2 + + isUnsigned :: HWType -> Bool + isUnsigned (Unsigned _) = True + isUnsigned (BitVector _) = True + isUnsigned (Index _) = True + isUnsigned (Sum _ _) = True + isUnsigned (SP _ _) = True + isUnsigned _ = False + +mkUsedTys :: HWType + -> [HWType] +mkUsedTys v@(Vector _ elTy) = v : mkUsedTys elTy +mkUsedTys t@(RTree _ elTy) = t : mkUsedTys elTy +mkUsedTys p@(Product _ elTys) = p : concatMap mkUsedTys elTys +mkUsedTys sp@(SP _ elTys) = sp : concatMap mkUsedTys (concatMap snd elTys) +mkUsedTys c@(Clock _ _ Gated) = [c,Bit,Bool] +mkUsedTys t = [t] + +topSortHWTys :: [HWType] + -> [HWType] +topSortHWTys hwtys = sorted + where + nodes = zip [0..] hwtys + nodesI = HashMap.fromList (zip hwtys [0..]) + edges = concatMap edge hwtys + graph = mkGraph nodes edges :: Gr HWType () + sorted = reverse $ topsort' graph + + edge t@(Vector _ elTy) = maybe [] ((:[]) . (HashMap.lookupDefault (error $ $(curLoc) ++ "Vector") t nodesI,,())) + (HashMap.lookup elTy nodesI) + edge t@(RTree _ elTy) = maybe [] ((:[]) . (HashMap.lookupDefault (error $ $(curLoc) ++ "RTree") t nodesI,,())) + (HashMap.lookup elTy nodesI) + edge t@(Product _ tys) = let ti = HashMap.lookupDefault (error $ $(curLoc) ++ "Product") t nodesI + in mapMaybe (\ty -> liftM (ti,,()) (HashMap.lookup ty nodesI)) tys + edge t@(SP _ ctys) = let ti = HashMap.lookupDefault (error $ $(curLoc) ++ "SP") t nodesI + in concatMap (\(_,tys) -> mapMaybe (\ty -> liftM (ti,,()) (HashMap.lookup ty nodesI)) tys) ctys + edge _ = [] + +range :: Either Int Int -> SystemVerilogM Doc +range (Left n) = brackets (int (n-1) <> colon <> int 0) +range (Right n) = brackets (int 0 <> colon <> int (n-1)) + +tyDec :: HWType -> SystemVerilogM (Maybe Doc) +tyDec ty@(Vector n elTy) | typeSize ty > 0 = Just A.<$> do + syn <- Mon hdlSyn + case syn of + Vivado -> case splitVecTy ty of + Just ([Right n',Left n''],elTy') -> + "typedef" <+> elTy' <+> brackets (int (n''-1) <> colon <> int 0) <+> + tyName ty <+> brackets (int 0 <> colon <> int (n'-1)) <> semi + _ -> + "typedef" <+> "logic" <+> brackets (int (typeSize elTy - 1) <> colon <> int 0) <+> + tyName ty <+> brackets (int 0 <> colon <> int (n-1)) <> semi + _ -> case splitVecTy ty of + Just (Right n':ns,elTy') -> + "typedef" <+> elTy' <+> hcat (mapM range ns) <+> tyName ty <+> + brackets (int 0 <> colon <> int (n' - 1)) <> semi + _ -> error $ $(curLoc) ++ "impossible" +tyDec ty@(RTree n elTy) | typeSize elTy > 0 = Just A.<$> do + syn <- Mon hdlSyn + case syn of + Vivado -> case splitVecTy ty of + Just ([Right n',Left n''],elTy') -> -- n' == 2^n + "typedef" <+> elTy' <+> brackets (int 0 <> colon <> int (n''-1)) <+> + tyName ty <+> brackets (int 0 <> colon <> int (n'-1)) <> semi + _ -> + "typedef" <+> "logic" <+> brackets (int (typeSize elTy - 1) <> colon <> int 0) <+> + tyName ty <+> brackets (int 0 <> colon <> int (2^n-1)) <> semi + _ -> case splitVecTy ty of + Just (Right n':ns,elTy') -> -- n' == 2^n + "typedef" <+> elTy' <+> hcat (mapM range ns) <+> tyName ty <+> + brackets (int 0 <> colon <> int (n' - 1)) <> semi + _ -> error $ $(curLoc) ++ "impossible" +tyDec ty@(Product _ tys) | typeSize ty > 0 = Just A.<$> prodDec + where + prodDec = "typedef struct packed {" <> line <> + indent 2 (vcat $ fmap catMaybes $ zipWithM combineM selNames tys) <> line <> + "}" <+> tName <> semi + + combineM x y = do + yM <- lvType y + case yM of + Nothing -> pure Nothing + Just y' -> Just A.<$> (pure y' <+> x <> semi) + tName = tyName ty + selNames = map (\i -> tName <> "_sel" <> int i) [0..] + +tyDec _ = pure Nothing + +gatedClockType :: HWType -> HWType +gatedClockType (Clock nm rt Gated) = Product ("GatedClock" `Text.append` (pack (show (nm,rt)))) [Bit,Bool] +gatedClockType ty = ty +{-# INLINE gatedClockType #-} + +splitVecTy :: HWType -> Maybe ([Either Int Int],SystemVerilogM Doc) +splitVecTy = fmap splitElemTy . go + where + splitElemTy (ns,t) = case t of + Product _ _ -> (ns, verilogType t) + Vector _ _ -> error $ $(curLoc) ++ "impossible" + Clock {} -> (ns, verilogType t) + Reset {} -> (ns, "logic") + Bool -> (ns, "logic") + Bit -> (ns, "logic") + String -> (ns, "string") + Signed n -> (ns ++ [Left n],"logic signed") + _ -> (ns ++ [Left (typeSize t)], "logic") + + go (Vector n elTy) = case go elTy of + Just (ns,elTy') -> Just (Right n:ns,elTy') + _ -> Just ([Right n],elTy) + + go (RTree n elTy) = let n' = 2^n in case go elTy of + Just (ns,elTy') -> Just (Right n':ns,elTy') + _ -> Just ([Right n'],elTy) + + go _ = Nothing + +lvType :: HWType -> SystemVerilogM (Maybe Doc) +lvType ty@(Vector n elTy) | typeSize ty > 0 = Just A.<$> do + syn <- Mon hdlSyn + case syn of + Vivado -> "logic" <+> brackets (int 0 <> colon <> int (n-1)) <> brackets (int (typeSize elTy - 1) <> colon <> int 0) + _ -> case splitVecTy ty of + Just (ns,elTy') -> elTy' <> hcat (mapM range ns) + _ -> error $ $(curLoc) ++ "impossible" +lvType ty@(RTree n elTy) | typeSize elTy > 0 = Just A.<$> do + syn <- Mon hdlSyn + case syn of + Vivado -> "logic" <+> brackets (int 0 <> colon <> int (2^n-1)) <> brackets (int (typeSize elTy - 1) <> colon <> int 0) + _ -> case splitVecTy ty of + Just (ns,elTy') -> elTy' <> hcat (mapM range ns) + _ -> error $ $(curLoc) ++ "impossible" +lvType ty | typeSize ty > 0 = Just A.<$> verilogType ty +lvType _ = pure Nothing + +funDec :: HWType -> SystemVerilogM (Maybe Doc) +funDec ty@(Vector n elTy) | typeSize ty > 0 = Just A.<$> + "function" <+> "logic" <+> ranges <+> tName <> "_to_lv" <> parens (sigDecl "i" ty) <> semi <> line <> + indent 2 + ("for" <+> parens ("int n = 0" <> semi <+> "n <" <+> int n <> semi <+> "n=n+1") <> line <> + indent 2 (tName <> "_to_lv" <> brackets "n" <+> "=" <+> "i[n]" <> semi)) <> line <> + "endfunction" <> line <> + "function" <+> tName <+> tName <> "_from_lv" <> parens ("logic" <+> ranges <+> "i") <> semi <> line <> + indent 2 + ("for" <+> parens ("int n = 0" <> semi <+> "n <" <+> int n <> semi <+> "n=n+1") <> line <> + indent 2 (tName <> "_from_lv" <> brackets "n" <+> "=" <+> "i[n]" <> semi)) <> line <> + "endfunction" <> line <> + if n > 1 then + "function" <+> tName <+> tName <> "_cons" <> parens (sigDecl "x" elTy <> comma <> vecSigDecl "xs") <> semi <> line <> + indent 2 + (tName <> "_cons" <> brackets (int 0) <+> "=" <+> (toSLV elTy (Identifier "x" Nothing)) <> semi <> line <> + tName <> "_cons" <> brackets (int 1 <> colon <> int (n-1)) <+> "=" <+> "xs" <> semi) <> line <> + "endfunction" + else + "function" <+> tName <+> tName <> "_cons" <> parens (sigDecl "x" elTy) <> semi <> line <> + indent 2 + (tName <> "_cons" <> brackets (int 0) <+> "=" <+> (toSLV elTy (Identifier "x" Nothing)) <> semi) <> line <> + "endfunction" + where + tName = tyName ty + ranges = brackets (int 0 <> colon <> int (n-1)) <> + brackets (int (typeSize elTy - 1) <> colon <> int 0) + + vecSigDecl :: SystemVerilogM Doc -> SystemVerilogM Doc + vecSigDecl d = do + syn <- Mon hdlSyn + case syn of + Vivado -> case splitVecTy ty of + Just ([Right n',Left n''],elTy') -> + elTy' <+> brackets (int 0 <> colon <> int (n''-1)) <+> + d <+> brackets (int 0 <> colon <> int (n'-2)) + _ -> + "logic" <+> brackets (int (typeSize elTy - 1) <> colon <> int 0) <+> + d <+> brackets (int 0 <> colon <> int (n-2)) + _ -> case splitVecTy ty of + Just (Right n':ns,elTy') -> + elTy' <+> hcat (mapM range ns) <+> d <+> + brackets (int 0 <> colon <> int (n' - 2)) + _ -> error $ $(curLoc) ++ "impossible" + + +funDec ty@(RTree n elTy) | typeSize elTy > 0 = Just A.<$> + "function" <+> "logic" <+> ranges <+> tName <> "_to_lv" <> parens (sigDecl "i" ty) <> semi <> line <> + indent 2 + ("for" <+> parens ("int n = 0" <> semi <+> "n <" <+> int (2^n) <> semi <+> "n=n+1") <> line <> + indent 2 (tName <> "_to_lv" <> brackets "n" <+> "=" <+> "i[n]" <> semi)) <> line <> + "endfunction" <> line <> + "function" <+> tName <+> tName <> "_from_lv" <> parens ("logic" <+> ranges <+> "i") <> semi <> line <> + indent 2 + ("for" <+> parens ("int n = 0" <> semi <+> "n <" <+> int (2^n) <> semi <+> "n=n+1") <> line <> + indent 2 (tName <> "_from_lv" <> brackets "n" <+> "=" <+> "i[n]" <> semi)) <> line <> + "endfunction" <> line <> + (if n > 0 + then + "function" <+> tName <+> tName <> "_br" <> parens (treeSigDecl "l" <> comma <> treeSigDecl "r") <> semi <> line <> + indent 2 + (tName <> "_br" <> brackets (int 0 <> colon <> int (2^(n-1)-1)) <+> "=" <+> "l" <> semi <> line <> + tName <> "_br" <> brackets (int (2^(n-1)) <> colon <> int (2^n-1)) <+> "=" <+> "r" <> semi) <> line <> + "endfunction" + else + emptyDoc) + where + treeSigDecl :: SystemVerilogM Doc -> SystemVerilogM Doc + treeSigDecl d = do + syn <- Mon hdlSyn + case syn of + Vivado -> case splitVecTy (RTree (n-1) elTy) of + Just ([Right n',Left n''],elTy') -> -- n' == 2 ^ (n-1) + elTy' <+> brackets (int 0 <> colon <> int (n''-1)) <+> + d <+> brackets (int 0 <> colon <> int (n' - 1)) + _ -> + "logic" <+> brackets (int (typeSize elTy - 1) <> colon <> int 0) <+> + d <+> brackets (int 0 <> colon <> int (2^(n-1)-1)) + _ -> case splitVecTy (RTree (n-1) elTy) of + Just (Right n':ns,elTy') -> -- n' == 2 ^ (n-1) + elTy' <+> hcat (mapM range ns) <+> d <+> + brackets (int 0 <> colon <> int (n' - 1)) + _ -> error $ $(curLoc) ++ "impossible" + + tName = tyName ty + ranges = brackets (int 0 <> colon <> int (2^n-1)) <> + brackets (int (typeSize elTy - 1) <> colon <> int 0) + +funDec _ = pure Nothing + +module_ :: Component -> SystemVerilogM Doc +module_ c = + addSeen c *> modVerilog <* Mon (idSeen .= [] >> imports .= [] >> oports .= []) + where + modVerilog = do + body <- modBody + imps <- Mon $ use imports + modHeader <> line <> modPorts <> line <> include (nub imps) <> pure body <> line <> modEnding + + modHeader = "module" <+> string (componentName c) + modPorts = indent 4 (tupleInputs inPorts <> line <> tupleOutputs outPorts <> semi) + modBody = indent 2 (decls (declarations c)) <> line <> line <> insts (declarations c) + modEnding = "endmodule" + + inPorts = sequence [ sigPort Nothing p | p <- inputs c ] + outPorts = sequence [ sigPort (Just wr) p | (wr, p) <- outputs c ] + + wr2ty Nothing = "input" + wr2ty (Just Wire) = "output" + wr2ty (Just Reg) = "output" + + -- map a port to its verilog type, port name, and any encoding notes + sigPort (wr2ty -> portTy) (nm, hwTy) + = portTy <+> sigDecl (string nm) hwTy <+> encodingNote hwTy + -- slightly more readable than 'tupled', makes the output Haskell-y-er + commafy v = (comma <> space) <> pure v + + tupleInputs v = v >>= \case + [] -> lparen <+> string "// No inputs" <> line + (x:xs) -> lparen <+> string "// Inputs" + <> line <> (string " " <> pure x) + <> line <> vcat (forM xs commafy) + <> line + + tupleOutputs v = v >>= \case + [] -> string " // No outputs" <> line <> rparen + (x:xs) -> string " // Outputs" + <> line <> (if (length (inputs c)) > 0 + then comma <> space <> pure x + else string " " <> pure x) + <> (if null xs then emptyDoc else line <> vcat (forM xs commafy)) + <> line <> rparen + +addSeen :: Component -> SystemVerilogM () +addSeen c = do + let iport = map fst $ inputs c + oport = map (fst.snd) $ outputs c + nets = mapMaybe (\case {NetDecl' _ _ i _ -> Just i; _ -> Nothing}) $ declarations c + Mon (idSeen .= concat [iport,oport,nets]) + Mon (oports .= oport) + +mkUniqueId :: Identifier -> SystemVerilogM Identifier +mkUniqueId i = do + mkId <- Mon (mkIdentifier <*> pure Extended) + seen <- Mon $ use idSeen + let i' = mkId i + case i `elem` seen of + True -> go mkId seen i' 0 + False -> do Mon (idSeen %= (i':)) + return i' + where + go :: (Identifier -> Identifier) -> [Identifier] -> Identifier + -> Int -> SystemVerilogM Identifier + go mkId seen i' n = do + let i'' = mkId (Text.append i' (Text.pack ('_':show n))) + case i'' `elem` seen of + True -> go mkId seen i' (n+1) + False -> do Mon (idSeen %= (i'':)) + return i'' + +verilogType :: HWType -> SystemVerilogM Doc +verilogType t = do + Mon (tyCache %= HashSet.insert t) + case t of + Product _ _ -> do + nm <- Mon $ use modNm + string (pack nm) <> "_types::" <> tyName t + Vector _ _ -> do + nm <- Mon $ use modNm + string (pack nm) <> "_types::" <> tyName t + RTree _ _ -> do + nm <- Mon $ use modNm + string (pack nm) <> "_types::" <> tyName t + Signed n -> "logic signed" <+> brackets (int (n-1) <> colon <> int 0) + Clock _ _ Gated -> verilogType (gatedClockType t) + Clock {} -> "logic" + Reset {} -> "logic" + Bit -> "logic" + Bool -> "logic" + String -> "string" + _ -> "logic" <+> brackets (int (typeSize t -1) <> colon <> int 0) + +sigDecl :: SystemVerilogM Doc -> HWType -> SystemVerilogM Doc +sigDecl d t = verilogType t <+> d + +-- | Convert a Netlist HWType to the root of a Verilog type +verilogTypeMark :: HWType -> SystemVerilogM Doc +verilogTypeMark t = do + Mon (tyCache %= HashSet.insert t) + nm <- Mon $ use modNm + let m = tyName t + case t of + Product _ _ -> string (pack nm) <> "_types::" <> m + Vector _ _ -> string (pack nm) <> "_types::" <> m + RTree _ _ -> string (pack nm) <> "_types::" <> m + _ -> emptyDoc + +tyName :: HWType -> SystemVerilogM Doc +tyName Bool = "logic" +tyName Bit = "logic" +tyName (Vector n elTy) = "array_of_" <> int n <> "_" <> tyName elTy +tyName (RTree n elTy) = "tree_of_" <> int n <> "_" <> tyName elTy +tyName (BitVector n) = "logic_vector_" <> int n +tyName t@(Index _) = "logic_vector_" <> int (typeSize t) +tyName (Signed n) = "signed_" <> int n +tyName (Unsigned n) = "logic_vector_" <> int n +tyName t@(Sum _ _) = "logic_vector_" <> int (typeSize t) +tyName t@(Product nm _) = Mon (makeCached t nameCache prodName) + where + prodName = do + seen <- use tySeen + mkId <- mkIdentifier <*> pure Basic + let nm' = (mkId . last . Text.splitOn ".") nm + nm'' = if Text.null nm' + then "product" + else nm' + nm3 = if nm'' `elem` seen + then go mkId seen (0::Integer) nm'' + else nm'' + tySeen %= (nm3:) + string nm3 + + go mkId s i n = + let n' = n `Text.append` Text.pack ('_':show i) + in if n' `elem` s + then go mkId s (i+1) n + else n' +tyName t@(SP _ _) = "logic_vector_" <> int (typeSize t) +tyName t@(Clock _ _ Gated) = tyName (gatedClockType t) +tyName (Clock {}) = "logic" +tyName (Reset {}) = "logic" +tyName t = error $ $(curLoc) ++ "tyName: " ++ show t + +-- | Convert a Netlist HWType to an error VHDL value for that type +verilogTypeErrValue :: HWType -> SystemVerilogM Doc +verilogTypeErrValue (Vector n elTy) = do + syn <- Mon hdlSyn + case syn of + Vivado -> char '\'' <> braces (int n <+> braces (braces (int (typeSize elTy) <+> braces "1'bx"))) + _ -> char '\'' <> braces (int n <+> braces (verilogTypeErrValue elTy)) +verilogTypeErrValue (RTree n elTy) = do + syn <- Mon hdlSyn + case syn of + Vivado -> char '\'' <> braces (int (2^n) <+> braces (braces (int (typeSize elTy) <+> braces "1'bx"))) + _ -> char '\'' <> braces (int (2^n) <+> braces (verilogTypeErrValue elTy)) +verilogTypeErrValue String = "\"ERROR\"" +verilogTypeErrValue ty = braces (int (typeSize ty) <+> braces "1'bx") + +decls :: [Declaration] -> SystemVerilogM Doc +decls [] = emptyDoc +decls ds = do + dsDoc <- catMaybes A.<$> mapM decl ds + case dsDoc of + [] -> emptyDoc + _ -> punctuate' semi (A.pure dsDoc) + +decl :: Declaration -> SystemVerilogM (Maybe Doc) +decl (NetDecl' noteM _ id_ tyE) = + Just A.<$> maybe id addNote noteM (typ tyE) + where + typ (Left ty) = string ty <+> string id_ + typ (Right ty) = sigDecl (string id_) ty + addNote n = mappend ("//" <+> string n <> line) + +decl _ = return Nothing + +insts :: [Declaration] -> SystemVerilogM Doc +insts [] = emptyDoc +insts is = indent 2 . vcat . punctuate line . fmap catMaybes $ mapM inst_ is + +-- | Turn a Netlist Declaration to a SystemVerilog concurrent block +inst_ :: Declaration -> SystemVerilogM (Maybe Doc) +inst_ (Assignment id_ e) = fmap Just $ + "assign" <+> string id_ <+> equals <+> align (expr_ False e <> semi) + +inst_ (CondAssignment id_ ty scrut _ [(Just (BoolLit b), l),(_,r)]) = fmap Just $ do + { syn <- Mon hdlSyn + ; p <- Mon $ use oports + ; if syn == Vivado && id_ `elem` p + then do + { regId <- mkUniqueId =<< Mon (extendIdentifier <*> pure Extended <*> pure id_ <*> pure "_reg") + ; verilogType ty <+> string regId <> semi <> line <> + "always_comb begin" <> line <> + indent 2 ("if" <> parens (expr_ True scrut) <> line <> + (indent 2 $ string regId <+> equals <+> expr_ False t <> semi) <> line <> + "else" <> line <> + (indent 2 $ string regId <+> equals <+> expr_ False f <> semi)) <> line <> + "end" <> line <> + "assign" <+> string id_ <+> equals <+> string regId <> semi + } + else "always_comb begin" <> line <> + indent 2 ("if" <> parens (expr_ True scrut) <> line <> + (indent 2 $ string id_ <+> equals <+> expr_ False t <> semi) <> line <> + "else" <> line <> + (indent 2 $ string id_ <+> equals <+> expr_ False f <> semi)) <> line <> + "end" + } + where + (t,f) = if b then (l,r) else (r,l) + +inst_ (CondAssignment id_ ty scrut scrutTy es) = fmap Just $ do + { syn <- Mon hdlSyn + ; p <- Mon $ use oports + ; if syn == Vivado && id_ `elem` p + then do + { regId <- mkUniqueId =<< Mon (extendIdentifier <*> pure Extended <*> pure id_ <*> pure "_reg") + ; verilogType ty <+> string regId <> semi <> line <> + "always_comb begin" <> line <> + indent 2 ("case" <> parens (expr_ True scrut) <> line <> + (indent 2 $ vcat $ punctuate semi (conds regId es)) <> semi <> line <> + "endcase") <> line <> + "end" <> line <> + "assign" <+> string id_ <+> equals <+> string regId <> semi + } + else "always_comb begin" <> line <> + indent 2 ("case" <> parens (expr_ True scrut) <> line <> + (indent 2 $ vcat $ punctuate semi (conds id_ es)) <> semi <> line <> + "endcase") <> line <> + "end" + } + where + conds :: Identifier -> [(Maybe Literal,Expr)] -> SystemVerilogM [Doc] + conds _ [] = return [] + conds i [(_,e)] = ("default" <+> colon <+> string i <+> equals <+> expr_ False e) <:> return [] + conds i ((Nothing,e):_) = ("default" <+> colon <+> string i <+> equals <+> expr_ False e) <:> return [] + conds i ((Just c ,e):es') = (exprLit (Just (scrutTy,conSize scrutTy)) c <+> colon <+> string i <+> equals <+> expr_ False e) <:> conds i es' + +inst_ (InstDecl _ nm lbl pms) = fmap Just $ + nest 2 (string nm <+> string lbl <> line <> pms' <> semi) + where + pms' = tupled $ sequence [dot <> expr_ False i <+> parens (expr_ False e) | (i,_,_,e) <- pms] + +inst_ (BlackBoxD _ libs imps inc bs bbCtx) = + fmap Just (Mon (column (renderBlackBox libs imps inc bs bbCtx))) + +inst_ (NetDecl' _ _ _ _) = return Nothing + +-- | Turn a Netlist expression into a SystemVerilog expression +expr_ :: Bool -- ^ Enclose in parenthesis? + -> Expr -- ^ Expr to convert + -> SystemVerilogM Doc +expr_ _ (Literal sizeM lit) = exprLit sizeM lit +expr_ _ (Identifier id_ Nothing) = string id_ +expr_ _ (Identifier id_ (Just (Indexed (ty@(SP _ args),dcI,fI)))) = fromSLV argTy id_ start end + where + argTys = snd $ args !! dcI + argTy = argTys !! fI + argSize = typeSize argTy + other = otherSize argTys (fI-1) + start = typeSize ty - 1 - conSize ty - other + end = start - argSize + 1 + +expr_ _ (Identifier id_ (Just (Indexed (ty@(Product _ tys),_,fI)))) = do + id'<- fmap renderOneLine (string id_ <> dot <> tyName ty <> "_sel" <> int fI) + simpleFromSLV (tys !! fI) id' + +expr_ _ (Identifier id_ (Just (Indexed (ty@(Clock _ _ Gated),_,fI)))) = do + let tys = [Bit, Bool] + ty' = gatedClockType ty + id'<- fmap renderOneLine (string id_ <> dot <> tyName ty' <> "_sel" <> int fI) + simpleFromSLV (tys !! fI) id' + +expr_ _ (Identifier id_ (Just (Indexed ((Vector _ elTy),1,0)))) = do + id' <- fmap renderOneLine (string id_ <> brackets (int 0)) + simpleFromSLV elTy id' + +expr_ _ (Identifier id_ (Just (Indexed ((Vector n _),1,1)))) = string id_ <> brackets (int 1 <> colon <> int (n-1)) + +-- This is a "Hack", we cannot construct trees with a negative depth. This is +-- here so that we can recognise merged RTree modifiers. See the code in +-- @Clash.Backend.nestM@ which construct these tree modifiers. +expr_ _ (Identifier id_ (Just (Indexed (RTree (-1) _,l,r)))) = + string id_ <> brackets (int l <> colon <> int (r-1)) + +expr_ _ (Identifier id_ (Just (Indexed ((RTree 0 elTy),0,0)))) = do + id' <- fmap renderOneLine (string id_ <> brackets (int 0)) + simpleFromSLV elTy id' + +expr_ _ (Identifier id_ (Just (Indexed ((RTree n _),1,0)))) = + let z = 2^(n-1) + in string id_ <> brackets (int 0 <> colon <> int (z-1)) + +expr_ _ (Identifier id_ (Just (Indexed ((RTree n _),1,1)))) = + let z = 2^(n-1) + z' = 2^n + in string id_ <> brackets (int z <> colon <> int (z'-1)) + +-- This is a HACK for Clash.Driver.TopWrapper.mkOutput +-- Vector's don't have a 10'th constructor, this is just so that we can +-- recognize the particular case +expr_ _ (Identifier id_ (Just (Indexed ((Vector _ elTy),10,fI)))) = do + id' <- fmap renderOneLine (string id_ <> brackets (int fI)) + simpleFromSLV elTy id' + +-- This is a HACK for Clash.Driver.TopWrapper.mkOutput +-- RTree's don't have a 10'th constructor, this is just so that we can +-- recognize the particular case +expr_ _ (Identifier id_ (Just (Indexed ((RTree _ elTy),10,fI)))) = do + id' <- fmap renderOneLine (string id_ <> brackets (int fI)) + simpleFromSLV elTy id' + +expr_ _ (Identifier id_ (Just (DC (ty@(SP _ _),_)))) = string id_ <> brackets (int start <> colon <> int end) + where + start = typeSize ty - 1 + end = typeSize ty - conSize ty + +expr_ b (Identifier id_ (Just (Nested m1 m2))) = case nestM m1 m2 of + Just m3 -> expr_ b (Identifier id_ (Just m3)) + _ -> do + k <- expr_ b (Identifier id_ (Just m1)) + expr_ b (Identifier (renderOneLine k) (Just m2)) + +expr_ _ (Identifier id_ (Just _)) = string id_ + +expr_ b (DataCon _ (DC (Void {}, -1)) [e]) = expr_ b e + +expr_ _ (DataCon ty@(Vector 0 _) _ _) = verilogTypeErrValue ty + +expr_ _ (DataCon (Vector 1 elTy) _ [e]) = "'" <> braces (toSLV elTy e) + +expr_ _ e@(DataCon ty@(Vector _ elTy) _ [e1,e2]) = case vectorChain e of + Just es -> "'" <> listBraces (mapM (toSLV elTy) es) + Nothing -> verilogTypeMark ty <> "_cons" <> parens (expr_ False e1 <> comma <+> expr_ False e2) + +expr_ _ (DataCon (RTree 0 elTy) _ [e]) = "'" <> braces (toSLV elTy e) + +expr_ _ e@(DataCon ty@(RTree _ elTy) _ [e1,e2]) = case rtreeChain e of + Just es -> "'" <> listBraces (mapM (toSLV elTy) es) + Nothing -> verilogTypeMark ty <> "_br" <> parens (expr_ False e1 <> comma <+> expr_ False e2) + +expr_ _ (DataCon ty@(SP _ args) (DC (_,i)) es) = assignExpr + where + argTys = snd $ args !! i + dcSize = conSize ty + sum (map typeSize argTys) + dcExpr = expr_ False (dcToExpr ty i) + argExprs = zipWith toSLV argTys es + extraArg = case typeSize ty - dcSize of + 0 -> [] + n -> [int n <> "'b" <> bits (replicate n U)] + assignExpr = braces (hcat $ punctuate comma $ sequence (dcExpr:argExprs ++ extraArg)) + +expr_ _ (DataCon ty@(Sum _ _) (DC (_,i)) []) = int (typeSize ty) <> "'d" <> int i +expr_ _ (DataCon (Product _ tys) _ es) = listBraces (zipWithM toSLV tys es) +expr_ _ (DataCon (Clock nm rt Gated) _ es) = + listBraces (zipWithM toSLV [Clock nm rt Source,Bool] es) + +expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) + | pNm == "Clash.Sized.Internal.Signed.fromInteger#" + , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx + = exprLit (Just (Signed (fromInteger n),fromInteger n)) i + +expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) + | pNm == "Clash.Sized.Internal.Unsigned.fromInteger#" + , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx + = exprLit (Just (Unsigned (fromInteger n),fromInteger n)) i + +expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) + | pNm == "Clash.Sized.Internal.BitVector.fromInteger#" + , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx + = exprLit (Just (BitVector (fromInteger n),fromInteger n)) i + +expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) + | pNm == "Clash.Sized.Internal.BitVector.fromInteger##" + , [Literal _ i] <- extractLiterals bbCtx + = exprLit (Just (Bit,1)) i + +expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) + | pNm == "Clash.Sized.Internal.Index.fromInteger#" + , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx + = exprLit (Just (Index (fromInteger n),fromInteger n)) i + +expr_ b (BlackBoxE _ libs imps inc bs bbCtx b') = + parenIf (b || b') (Mon (renderBlackBox libs imps inc bs bbCtx <*> pure 0)) + +expr_ _ (DataTag Bool (Left id_)) = string id_ <> brackets (int 0) +expr_ _ (DataTag Bool (Right id_)) = do + iw <- Mon $ use intWidth + "$unsigned" <> parens (listBraces (sequence [braces (int (iw-1) <+> braces "1'b0"),string id_])) + +expr_ _ (DataTag (Sum _ _) (Left id_)) = "$unsigned" <> parens (string id_) +expr_ _ (DataTag (Sum _ _) (Right id_)) = "$unsigned" <> parens (string id_) + +expr_ _ (DataTag (Product _ _) (Right _)) = do + iw <- Mon $ use intWidth + int iw <> "'sd0" + +expr_ _ (DataTag hty@(SP _ _) (Right id_)) = "$unsigned" <> parens + (string id_ <> brackets + (int start <> colon <> int end)) + where + start = typeSize hty - 1 + end = typeSize hty - conSize hty + +expr_ _ (DataTag (Vector 0 _) (Right _)) = do + iw <- Mon $ use intWidth + int iw <> "'sd0" +expr_ _ (DataTag (Vector _ _) (Right _)) = do + iw <- Mon $ use intWidth + int iw <> "'sd1" + +expr_ _ (DataTag (RTree 0 _) (Right _)) = do + iw <- Mon $ use intWidth + int iw <> "'sd0" +expr_ _ (DataTag (RTree _ _) (Right _)) = do + iw <- Mon $ use intWidth + int iw <> "'sd1" + +expr_ b (ConvBV topM t True e) = do + nm <- Mon $ use modNm + let nm' = string (pack nm) + case t of + Vector {} -> do + Mon (tyCache %= HashSet.insert t) + maybe (nm' <> "_types::" ) ((<> "_types::") . string) topM <> + tyName t <> "_to_lv" <> parens (expr_ False e) + RTree {} -> do + Mon (tyCache %= HashSet.insert t) + maybe (nm' <> "_types::" ) ((<> "_types::") . string) topM <> + tyName t <> "_to_lv" <> parens (expr_ False e) + _ -> expr b e + +expr_ b (ConvBV topM t False e) = do + nm <- Mon $ use modNm + let nm' = string (pack nm) + case t of + Vector {} -> do + Mon (tyCache %= HashSet.insert t) + maybe (nm' <> "_types::" ) ((<> "_types::") . string) topM <> + tyName t <> "_from_lv" <> parens (expr_ False e) + RTree {} -> do + Mon (tyCache %= HashSet.insert t) + maybe (nm' <> "_types::" ) ((<> "_types::") . string) topM <> + tyName t <> "_from_lv" <> parens (expr_ False e) + _ -> expr b e + +expr_ _ e = error $ $(curLoc) ++ (show e) -- empty + +otherSize :: [HWType] -> Int -> Int +otherSize _ n | n < 0 = 0 +otherSize [] _ = 0 +otherSize (a:as) n = typeSize a + otherSize as (n-1) + +vectorChain :: Expr -> Maybe [Expr] +vectorChain (DataCon (Vector 0 _) _ _) = Just [] +vectorChain (DataCon (Vector 1 _) _ [e]) = Just [e] +vectorChain (DataCon (Vector _ _) _ [e1,e2]) = Just e1 <:> vectorChain e2 +vectorChain _ = Nothing + +rtreeChain :: Expr -> Maybe [Expr] +rtreeChain (DataCon (RTree 0 _) _ [e]) = Just [e] +rtreeChain (DataCon (RTree _ _) _ [e1,e2]) = A.liftA2 (++) (rtreeChain e1) + (rtreeChain e2) +rtreeChain _ = Nothing + +exprLit :: Maybe (HWType,Size) -> Literal -> SystemVerilogM Doc +exprLit Nothing (NumLit i) = integer i + +exprLit (Just (hty,sz)) (NumLit i) = case hty of + Unsigned _ -> int sz <> "'d" <> integer i + Index _ -> int (typeSize hty) <> "'d" <> integer i + Signed _ + | i < 0 -> "-" <> int sz <> "'sd" <> integer (abs i) + | otherwise -> int sz <> "'sd" <> integer i + _ -> int sz <> "'b" <> blit + where + blit = bits (toBits sz i) +exprLit _ (BoolLit t) = if t then "1'b1" else "1'b0" +exprLit _ (BitLit b) = "1'b" <> bit_char b +exprLit _ (StringLit s) = string . pack $ show s +exprLit _ l = error $ $(curLoc) ++ "exprLit: " ++ show l + +toBits :: Integral a => Int -> a -> [Bit] +toBits size val = map (\x -> if odd x then H else L) + $ reverse + $ take size + $ map (`mod` 2) + $ iterate (`div` 2) val + +bits :: [Bit] -> SystemVerilogM Doc +bits = hcat . mapM bit_char + +bit_char :: Bit -> SystemVerilogM Doc +bit_char H = char '1' +bit_char L = char '0' +bit_char U = char 'x' +bit_char Z = char 'z' + +toSLV :: HWType -> Expr -> SystemVerilogM Doc +toSLV t e = case t of + Vector _ _ -> braces (verilogTypeMark t <> "_to_lv" <> parens (expr_ False e)) + RTree _ _ -> braces (verilogTypeMark t <> "_to_lv" <> parens (expr_ False e)) + _ -> expr_ False e + +fromSLV :: HWType -> Identifier -> Int -> Int -> SystemVerilogM Doc +fromSLV t@(Vector _ _) id_ start end = verilogTypeMark t <> "_from_lv" <> parens (string id_ <> brackets (int start <> colon <> int end)) +fromSLV t@(RTree _ _) id_ start end = verilogTypeMark t <> "_from_lv" <> parens (string id_ <> brackets (int start <> colon <> int end)) +fromSLV (Signed _) id_ start end = "$signed" <> parens (string id_ <> brackets (int start <> colon <> int end)) +fromSLV _ id_ start end = string id_ <> brackets (int start <> colon <> int end) + +simpleFromSLV :: HWType -> Identifier -> SystemVerilogM Doc +simpleFromSLV t@(Vector _ _) id_ = verilogTypeMark t <> "_from_lv" <> parens (string id_) +simpleFromSLV t@(RTree _ _) id_ = verilogTypeMark t <> "_from_lv" <> parens (string id_) +simpleFromSLV (Signed _) id_ = "$signed" <> parens (string id_) +simpleFromSLV _ id_ = string id_ + +dcToExpr :: HWType -> Int -> Expr +dcToExpr ty i = Literal (Just (ty,conSize ty)) (NumLit (toInteger i)) + +listBraces :: Monad m => m [Doc] -> m Doc +listBraces = align . encloseSep lbrace rbrace comma + +parenIf :: Monad m => Bool -> m Doc -> m Doc +parenIf True = parens +parenIf False = id + +punctuate' :: Monad m => Mon m Doc -> Mon m [Doc] -> Mon m Doc +punctuate' s d = vcat (punctuate s d) <> s + +encodingNote :: HWType -> SystemVerilogM Doc +encodingNote (Clock _ _ Gated) = "// gated clock" +encodingNote (Clock {}) = "// clock" +encodingNote (Reset {}) = "// asynchronous reset: active high" +encodingNote _ = emptyDoc diff --git a/src/Clash/Backend/VHDL.hs b/src/Clash/Backend/VHDL.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Backend/VHDL.hs @@ -0,0 +1,1201 @@ +{-| + Copyright : (C) 2015-2016, University of Twente, + 2017, Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Generate VHDL for assorted Netlist datatypes +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +module Clash.Backend.VHDL (VHDLState) where + +import Control.Applicative (liftA2) +import Control.Lens hiding (Indexed) +import Control.Monad (forM,join,liftM,zipWithM) +import Control.Monad.State (State) +import Data.Graph.Inductive (Gr, mkGraph, topsort') +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Lazy as HashMap +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet +import Data.List (mapAccumL,nub,nubBy) +import Data.Maybe (catMaybes,fromMaybe,mapMaybe) +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid hiding (Sum, Product) +#endif +import Data.Semigroup.Monad.Extra +import Data.Text.Lazy (unpack) +import qualified Data.Text.Lazy as T +import Data.Text.Prettyprint.Doc.Extra +import qualified System.FilePath +import Text.Printf + +import Clash.Annotations.Primitive (HDL (..)) +import Clash.Backend +import Clash.Driver.Types (SrcSpan, noSrcSpan) +import Clash.Netlist.BlackBox.Types (HdlSyn (..)) +import Clash.Netlist.BlackBox.Util (extractLiterals, renderBlackBox) +import Clash.Netlist.Id (IdType (..), mkBasicId') +import Clash.Netlist.Types hiding (_intWidth, intWidth) +import Clash.Netlist.Util hiding (mkIdentifier) +import Clash.Signal.Internal (ClockKind (..)) +import Clash.Util (clogBase, curLoc, first, makeCached, on, (<:>)) + +#ifdef CABAL +import qualified Paths_clash_lib +#endif + +-- | State for the 'Clash.Netlist.VHDL.VHDLM' monad: +data VHDLState = + VHDLState + { _tyCache :: (HashSet HWType) -- ^ Previously encountered HWTypes + , _tySeen :: [Identifier] -- ^ Generated product types + , _nameCache :: (HashMap HWType Doc) -- ^ Cache for previously generated product type names + , _modNm :: String + , _srcSpan :: SrcSpan + , _libraries :: [T.Text] + , _packages :: [T.Text] + , _includes :: [(String,Doc)] + , _intWidth :: Int -- ^ Int/Word/Integer bit-width + , _hdlsyn :: HdlSyn -- ^ For which HDL synthesis tool are we generating VHDL + } + +makeLenses ''VHDLState + +primsRoot :: IO FilePath +#ifdef CABAL +primsRoot = Paths_clash_lib.getDataFileName "prims" +#else +primsRoot = return ("clash-lib" System.FilePath. "prims") +#endif + +instance Backend VHDLState where + initBackend = VHDLState HashSet.empty [] HashMap.empty "" noSrcSpan [] [] [] + hdlKind = const VHDL + primDirs = const $ do root <- primsRoot + return [ root System.FilePath. "common" + , root System.FilePath. "vhdl" + ] + extractTypes = _tyCache + name = const "vhdl" + extension = const ".vhdl" + + genHDL = genVHDL + mkTyPackage = mkTyPackage_ + hdlType Internal ty = vhdlType ty + hdlType (External nm) ty = case ty of + Vector _ _ -> pretty nm <> dot <> vhdlType ty + RTree _ _ -> pretty nm <> dot <> vhdlType ty + Product _ _ -> pretty nm <> dot <> vhdlType ty + _ -> vhdlType ty + hdlTypeErrValue = vhdlTypeErrValue + hdlTypeMark = vhdlTypeMark + hdlSig t ty = sigDecl (pretty t) ty + genStmt = const emptyDoc + inst = inst_ + expr = expr_ + iwWidth = use intWidth + toBV _ id_ = do + nm <- Mon $ use modNm + pretty (T.toLower $ T.pack nm) <> "_types.toSLV" <> parens (pretty id_) + fromBV _ id_ = do + nm <- Mon $ use modNm + pretty (T.toLower $ T.pack nm) <> "_types.fromSLV" <> parens (pretty id_) + hdlSyn = use hdlsyn + mkIdentifier = return go + where + go Basic nm = filterReserved (T.toLower (mkBasicId' True nm)) + go Extended (rmSlash -> nm) = case go Basic nm of + nm' | nm /= nm' -> T.concat ["\\",nm,"\\"] + |otherwise -> nm' + extendIdentifier = return go + where + go Basic nm ext = filterReserved (T.toLower (mkBasicId' True (nm `T.append` ext))) + go Extended ((rmSlash . escapeTemplate) -> nm) ext = + let nmExt = nm `T.append` ext + in case go Basic nm ext of + nm' | nm' /= nmExt -> case T.head nmExt of + '#' -> T.concat ["\\",nmExt,"\\"] + _ -> T.concat ["\\#",nmExt,"\\"] + | otherwise -> nm' + + setModName nm s = s {_modNm = nm} + setSrcSpan = (srcSpan .=) + getSrcSpan = use srcSpan + blockDecl nm ds = do + decs <- decls ds + if isEmpty decs + then insts ds + else nest 2 + (pretty nm <+> colon <+> "block" <> line <> + pure decs) <> line <> + nest 2 + ("begin" <> line <> + insts ds) <> line <> + "end block" <> semi + unextend = return rmSlash + addInclude inc = includes %= (inc:) + addLibraries libs = libraries %= (libs ++) + addImports imps = packages %= (imps ++) + +rmSlash :: Identifier -> Identifier +rmSlash nm = fromMaybe nm $ do + nm1 <- T.stripPrefix "\\" nm + pure (T.filter (not . (== '\\')) nm1) + +type VHDLM a = Mon (State VHDLState) a + +-- List of reserved VHDL-2008 keywords +-- + used internal names: toslv, fromslv, tagtoenum, datatotag +-- + used IEEE library names: integer, boolean, std_logic, std_logic_vector, +-- signed, unsigned, to_integer, to_signed, to_unsigned, string +reservedWords :: [Identifier] +reservedWords = ["abs","access","after","alias","all","and","architecture" + ,"array","assert","assume","assume_guarantee","attribute","begin","block" + ,"body","buffer","bus","case","component","configuration","constant","context" + ,"cover","default","disconnect","downto","else","elsif","end","entity","exit" + ,"fairness","file","for","force","function","generate","generic","group" + ,"guarded","if","impure","in","inertial","inout","is","label","library" + ,"linkage","literal","loop","map","mod","nand","new","next","nor","not","null" + ,"of","on","open","or","others","out","package","parameter","port","postponed" + ,"procedure","process","property","protected","pure","range","record" + ,"register","reject","release","rem","report","restrict","restrict_guarantee" + ,"return","rol","ror","select","sequence","severity","signal","shared","sla" + ,"sll","sra","srl","strong","subtype","then","to","transport","type" + ,"unaffected","units","until","use","variable","vmode","vprop","vunit","wait" + ,"when","while","with","xnor","xor","toslv","fromslv","tagtoenum","datatotag" + ,"integer", "boolean", "std_logic", "std_logic_vector", "signed", "unsigned" + ,"to_integer", "to_signed", "to_unsigned", "string"] + +filterReserved :: Identifier -> Identifier +filterReserved s = if s `elem` reservedWords + then s `T.append` "_r" + else s + +-- | Generate VHDL for a Netlist component +genVHDL :: String -> SrcSpan -> Component -> VHDLM ((String,Doc),[(String,Doc)]) +genVHDL nm sp c = do + Mon $ setSrcSpan sp + v <- vhdl + i <- Mon $ use includes + Mon $ libraries .= [] + Mon $ packages .= [] + return ((unpack cName,v),i) + where + cName = componentName c + vhdl = do + ent <- entity c + arch <- architecture c + imps <- tyImports nm + ("-- Automatically generated VHDL-93" <> line <> + pure imps <> line <> line <> + pure ent <> line <> line <> + pure arch) + +-- | Generate a VHDL package containing type definitions for the given HWTypes +mkTyPackage_ :: String + -> [HWType] + -> VHDLM [(String,Doc)] +mkTyPackage_ modName hwtys = do + { syn <- Mon hdlSyn + ; mkId <- Mon (mkIdentifier <*> pure Basic) + ; let usedTys = concatMap mkUsedTys hwtys + ; normTys <- nub <$> mapM (fmap mkVecZ . normaliseType) (hwtys ++ usedTys) + ; let sortedTys = topSortHWTys normTys + packageDec = vcat $ mapM tyDec sortedTys + (funDecs,funBodies) = unzip . mapMaybe (funDec syn) $ nubBy eqTypM sortedTys + + ; (:[]) <$> (unpack $ mkId (T.pack modName `T.append` "_types"),) <$> + "library IEEE;" <> line <> + "use IEEE.STD_LOGIC_1164.ALL;" <> line <> + "use IEEE.NUMERIC_STD.ALL;" <> line <> line <> + "package" <+> pretty (mkId (T.pack modName `T.append` "_types")) <+> "is" <> line <> + indent 2 ( packageDec <> line <> + vcat (sequence funDecs) + ) <> line <> + "end" <> semi <> packageBodyDec funBodies + } + where + packageBodyDec :: [VHDLM Doc] -> VHDLM Doc + packageBodyDec funBodies = case funBodies of + [] -> emptyDoc + _ -> do + { mkId <- Mon (mkIdentifier <*> pure Basic) + ; line <> line <> + "package" <+> "body" <+> pretty (mkId (T.pack modName `T.append` "_types")) <+> "is" <> line <> + indent 2 (vcat (sequence funBodies)) <> line <> + "end" <> semi + } + + eqTypM :: HWType -> HWType -> Bool + eqTypM (Signed _) (Signed _) = True + eqTypM (Unsigned _) (Unsigned _) = True + eqTypM (BitVector _) (BitVector _) = True + eqTypM (Clock _ _ g) (Clock _ _ g') = g == g' + eqTypM ty1 ty2 = ty1 == ty2 + +mkUsedTys :: HWType + -> [HWType] +mkUsedTys v@(Vector _ elTy) = v : mkUsedTys elTy +mkUsedTys v@(RTree _ elTy) = v : mkUsedTys elTy +mkUsedTys p@(Product _ elTys) = p : concatMap mkUsedTys elTys +mkUsedTys sp@(SP _ elTys) = sp : concatMap mkUsedTys (concatMap snd elTys) +mkUsedTys t = [t] + +topSortHWTys :: [HWType] + -> [HWType] +topSortHWTys hwtys = sorted + where + nodes = zip [0..] hwtys + nodesI = HashMap.fromList (zip hwtys [0..]) + edges = concatMap edge hwtys + graph = mkGraph nodes edges :: Gr HWType () + sorted = reverse $ topsort' graph + + edge t@(Vector _ elTy) = maybe [] ((:[]) . (HashMap.lookupDefault (error $ $(curLoc) ++ "Vector") t nodesI,,())) + (HashMap.lookup (mkVecZ elTy) nodesI) + edge t@(RTree _ elTy) = maybe [] ((:[]) . (HashMap.lookupDefault (error $ $(curLoc) ++ "RTree") t nodesI,,())) + (HashMap.lookup (mkVecZ elTy) nodesI) + edge t@(Product _ tys) = let ti = HashMap.lookupDefault (error $ $(curLoc) ++ "Product") t nodesI + in mapMaybe (\ty -> liftM (ti,,()) (HashMap.lookup (mkVecZ ty) nodesI)) tys + edge _ = [] + +normaliseType :: HWType -> VHDLM HWType +normaliseType (Vector n ty) = Vector n <$> (normaliseType ty) +normaliseType (RTree d ty) = RTree d <$> (normaliseType ty) +normaliseType (Product nm tys) = Product nm <$> (mapM normaliseType tys) +normaliseType ty@(SP _ elTys) = do + Mon $ mapM_ ((tyCache %=) . HashSet.insert) (concatMap snd elTys) + return (BitVector (typeSize ty)) +normaliseType ty@(Index _) = return (Unsigned (typeSize ty)) +normaliseType ty@(Sum _ _) = return (BitVector (typeSize ty)) +normaliseType (Clock _ _ Gated) = + return (Product "GatedClock" [Bit,Bool]) +normaliseType (Clock {}) = return Bit +normaliseType (Reset {}) = return Bit +normaliseType ty = return ty + +mkVecZ :: HWType -> HWType +mkVecZ (Vector _ elTy) = Vector 0 elTy +mkVecZ (RTree _ elTy) = RTree 0 elTy +mkVecZ t = t + +tyDec :: HWType -> VHDLM Doc +tyDec (Vector _ elTy) = do + syn <- Mon hdlSyn + case syn of + Vivado -> "type" <+> "array_of_" <> tyName elTy <+> "is array (integer range <>) of" + <+> "std_logic_vector" <> parens (int (typeSize elTy - 1) <+> "downto 0") <> semi + _ -> "type" <+> "array_of_" <> tyName elTy <+> "is array (integer range <>) of" + <+> vhdlType elTy <> semi + +tyDec (RTree _ elTy) = do + syn <- Mon hdlSyn + case syn of + Vivado -> "type" <+> "tree_of_" <> tyName elTy <+> "is array (integer range <>) of" + <+> "std_logic_vector" <> parens (int (typeSize elTy - 1) <+> "downto 0") <> semi + _ -> "type" <+> "tree_of_" <> tyName elTy <+> "is array (integer range <>) of" <+> vhdlType elTy <> semi + +tyDec ty@(Product _ tys@(_:_:_)) = prodDec + where + prodDec = "type" <+> tName <+> "is record" <> line <> + indent 2 (vcat $ zipWithM (\x y -> x <+> colon <+> y <> semi) selNames selTys) <> line <> + "end record" <> semi + + tName = tyName ty + selNames = map (\i -> tName <> "_sel" <> int i) [0..] + selTys = map vhdlType tys + +tyDec _ = emptyDoc + + +funDec :: HdlSyn -> HWType -> Maybe (VHDLM Doc,VHDLM Doc) +funDec _ Bool = Just + ( "function" <+> "toSLV" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "std_logic_vector" <> semi <> line <> + "function" <+> "fromSLV" <+> parens ("sl" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "boolean" <> semi <> line <> + "function" <+> "tagToEnum" <+> parens ("s" <+> colon <+> "in" <+> "signed") <+> "return" <+> "boolean" <> semi <> line <> + "function" <+> "dataToTag" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "signed" <> semi + , "function" <+> "toSLV" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "std_logic_vector" <+> "is" <> line <> + "begin" <> line <> + indent 2 (vcat $ sequence ["if" <+> "b" <+> "then" + , indent 2 ("return" <+> dquotes (int 1) <> semi) + ,"else" + , indent 2 ("return" <+> dquotes (int 0) <> semi) + ,"end" <+> "if" <> semi + ]) <> line <> + "end" <> semi <> line <> + "function" <+> "fromSLV" <+> parens ("sl" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "boolean" <+> "is" <> line <> + "begin" <> line <> + indent 2 (vcat $ sequence ["if" <+> "sl" <+> "=" <+> dquotes (int 1) <+> "then" + , indent 2 ("return" <+> "true" <> semi) + ,"else" + , indent 2 ("return" <+> "false" <> semi) + ,"end" <+> "if" <> semi + ]) <> line <> + "end" <> semi <> line <> + "function" <+> "tagToEnum" <+> parens ("s" <+> colon <+> "in" <+> "signed") <+> "return" <+> "boolean" <+> "is" <> line <> + "begin" <> line <> + indent 2 (vcat $ sequence ["if" <+> "s" <+> "=" <+> "to_signed" <> parens (int 0 <> comma <> (Mon (use intWidth) >>= int)) <+> "then" + , indent 2 ("return" <+> "false" <> semi) + ,"else" + , indent 2 ("return" <+> "true" <> semi) + ,"end" <+> "if" <> semi + ]) <> line <> + "end" <> semi <> line <> + "function" <+> "dataToTag" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "signed" <+> "is" <> line <> + "begin" <> line <> + indent 2 (vcat $ sequence ["if" <+> "b" <+> "then" + , indent 2 ("return" <+> "to_signed" <> parens (int 1 <> comma <> (Mon (use intWidth) >>= int)) <> semi) + ,"else" + , indent 2 ("return" <+> "to_signed" <> parens (int 0 <> comma <> (Mon (use intWidth) >>= int)) <> semi) + ,"end" <+> "if" <> semi + ]) <> line <> + "end" <> semi + ) + +funDec _ Bit = Just + ( "function" <+> "toSLV" <+> parens ("sl" <+> colon <+> "in" <+> "std_logic") <+> "return" <+> "std_logic_vector" <> semi <> line <> + "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "std_logic" <> semi + , "function" <+> "toSLV" <+> parens ("sl" <+> colon <+> "in" <+> "std_logic") <+> "return" <+> "std_logic_vector" <+> "is" <> line <> + "begin" <> line <> + indent 2 ("return" <+> "std_logic_vector'" <> parens (int 0 <+> rarrow <+> "sl") <> semi) <> line <> + "end" <> semi <> line <> + "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "std_logic" <+> "is" <> line <> + indent 2 + ( "alias islv : std_logic_vector (0 to slv'length - 1) is slv;" + ) <> line <> + "begin" <> line <> + indent 2 ("return" <+> "islv" <> parens (int 0) <> semi) <> line <> + "end" <> semi + ) + +funDec _ (Signed _) = Just + ( "function" <+> "toSLV" <+> parens ("s" <+> colon <+> "in" <+> "signed") <+> "return" <+> "std_logic_vector" <> semi <> line <> + "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "signed" <> semi + , "function" <+> "toSLV" <+> parens ("s" <+> colon <+> "in" <+> "signed") <+> "return" <+> "std_logic_vector" <+> "is" <> line <> + "begin" <> line <> + indent 2 ("return" <+> "std_logic_vector" <> parens ("s") <> semi) <> line <> + "end" <> semi <> line <> + "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "signed" <+> "is" <> line <> + "begin" <> line <> + indent 2 ("return" <+> "signed" <> parens ("slv") <> semi) <> line <> + "end" <> semi + ) + +funDec _ (Unsigned _) = Just + ( "function" <+> "toSLV" <+> parens ("u" <+> colon <+> "in" <+> "unsigned") <+> "return" <+> "std_logic_vector" <> semi <> line <> + "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "unsigned" <> semi + , "function" <+> "toSLV" <+> parens ("u" <+> colon <+> "in" <+> "unsigned") <+> "return" <+> "std_logic_vector" <+> "is" <> line <> + "begin" <> line <> + indent 2 ("return" <+> "std_logic_vector" <> parens ("u") <> semi) <> line <> + "end" <> semi <> line <> + "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "unsigned" <+> "is" <> line <> + "begin" <> line <> + indent 2 ("return" <+> "unsigned" <> parens ("slv") <> semi) <> line <> + "end" <> semi + + ) + +funDec _ t@(Product _ elTys) = Just + ( "function" <+> "toSLV" <+> parens ("p :" <+> vhdlType t) <+> "return std_logic_vector" <> semi <> line <> + "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> vhdlType t <> semi + , "function" <+> "toSLV" <+> parens ("p :" <+> vhdlType t) <+> "return std_logic_vector" <+> "is" <> line <> + "begin" <> line <> + indent 2 ("return" <+> parens (hcat (punctuate " & " elTyToSLV)) <> semi) <> line <> + "end" <> semi <> line <> + "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> vhdlType t <+> "is" <> line <> + "alias islv : std_logic_vector(0 to slv'length - 1) is slv;" <> line <> + "begin" <> line <> + indent 2 ("return" <+> parens (hcat (punctuate "," elTyFromSLV)) <> semi) <> line <> + "end" <> semi + ) + where + elTyToSLV = forM [0..(length elTys - 1)] + (\i -> "toSLV" <> + parens ("p." <> tyName t <> "_sel" <> int i)) + + argLengths = map typeSize elTys + starts = 0 : snd (mapAccumL ((join (,) .) . (+)) 0 argLengths) + ends = map (subtract 1) (tail starts) + + elTyFromSLV = forM (zip starts ends) + (\(s,e) -> "fromSLV" <> + parens ("islv" <> parens (int s <+> "to" <+> int e))) + +funDec syn t@(Vector _ elTy) = Just + ( "function" <+> "toSLV" <+> parens ("value : " <+> vhdlTypeMark t) <+> "return std_logic_vector" <> semi <> line <> + "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> vhdlTypeMark t <> semi + , "function" <+> "toSLV" <+> parens ("value : " <+> vhdlTypeMark t) <+> "return std_logic_vector" <+> "is" <> line <> + indent 2 + ( "alias ivalue :" <+> vhdlTypeMark t <> "(1 to value'length) is value;" <> line <> + "variable result :" <+> "std_logic_vector" <> parens ("1 to value'length * " <> int (typeSize elTy)) <> semi + ) <> line <> + "begin" <> line <> + indent 2 + ("for i in ivalue'range loop" <> line <> + indent 2 + ( "result" <> parens (parens ("(i - 1) * " <> int (typeSize elTy)) <+> "+ 1" <+> + "to i*" <> int (typeSize elTy)) <+> + ":=" <+> (case syn of + Vivado -> "ivalue" <> parens ("i") + _ -> "toSLV" <> parens ("ivalue" <> parens ("i"))) <> semi + ) <> line <> + "end" <+> "loop" <> semi <> line <> + "return" <+> "result" <> semi + ) <> line <> + "end" <> semi <> line <> + "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> vhdlTypeMark t <+> "is" <> line <> + indent 2 + ( "alias islv :" <+> "std_logic_vector" <> "(0 to slv'length - 1) is slv;" <> line <> + "variable result :" <+> vhdlTypeMark t <> parens ("0 to slv'length / " <> eSz <+> "- 1") <> semi + ) <> line <> + "begin" <> line <> + indent 2 + ("for i in result'range loop" <> line <> + indent 2 + ( "result" <> parens "i" <+> ":=" <+> case syn of + Vivado -> getElem <> semi + _ | BitVector _ <- elTy -> getElem <> semi + | otherwise -> "fromSLV" <> parens getElem <> semi + + ) <> line <> + "end" <+> "loop" <> semi <> line <> + "return" <+> "result" <> semi + ) <> line <> + "end" <> semi + ) + where + eSz = int (typeSize elTy) + getElem = "islv" <> parens ("i * " <> eSz <+> "to (i+1) * " <> eSz <+> "- 1") + +funDec _ (BitVector _) = Just + ( "function" <+> "toSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "std_logic_vector" <> semi <> line <> + "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "std_logic_vector" <> semi + , "function" <+> "toSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "std_logic_vector" <+> "is" <> line <> + "begin" <> line <> + indent 2 ("return" <+> "slv" <> semi) <> line <> + "end" <> semi <> line <> + "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "std_logic_vector" <+> "is" <> line <> + "begin" <> line <> + indent 2 ("return" <+> "slv" <> semi) <> line <> + "end" <> semi + ) + +funDec syn t@(RTree _ elTy) = Just + ( "function" <+> "toSLV" <+> parens ("value : " <+> vhdlTypeMark t) <+> "return std_logic_vector" <> semi <> line <> + "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> vhdlTypeMark t <> semi + , "function" <+> "toSLV" <+> parens ("value : " <+> vhdlTypeMark t) <+> "return std_logic_vector" <+> "is" <> line <> + indent 2 + ( "alias ivalue :" <+> vhdlTypeMark t <> "(1 to value'length) is value;" <> line <> + "variable result :" <+> "std_logic_vector" <> parens ("1 to value'length * " <> int (typeSize elTy)) <> semi + ) <> line <> + "begin" <> line <> + indent 2 + ("for i in ivalue'range loop" <> line <> + indent 2 + ( "result" <> parens (parens ("(i - 1) * " <> int (typeSize elTy)) <+> "+ 1" <+> + "to i*" <> int (typeSize elTy)) <+> + ":=" <+> (case syn of + Vivado -> "ivalue" <> parens ("i") + _ -> "toSLV" <> parens ("ivalue" <> parens ("i"))) <> semi + ) <> line <> + "end" <+> "loop" <> semi <> line <> + "return" <+> "result" <> semi + ) <> line <> + "end" <> semi <> line <> + "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> vhdlTypeMark t <+> "is" <> line <> + indent 2 + ( "alias islv :" <+> "std_logic_vector" <> "(0 to slv'length - 1) is slv;" <> line <> + "variable result :" <+> vhdlTypeMark t <> parens ("0 to slv'length / " <> eSz <+> "- 1") <> semi + ) <> line <> + "begin" <> line <> + indent 2 + ("for i in result'range loop" <> line <> + indent 2 + ( "result" <> parens "i" <+> ":=" <+> case syn of + Vivado -> getElem <> semi + _ | BitVector _ <- elTy -> getElem <> semi + | otherwise -> "fromSLV" <> parens getElem <> semi + + ) <> line <> + "end" <+> "loop" <> semi <> line <> + "return" <+> "result" <> semi + ) <> line <> + "end" <> semi + ) + where + eSz = int (typeSize elTy) + getElem = "islv" <> parens ("i * " <> eSz <+> "to (i+1) * " <> eSz <+> "- 1") + +funDec _ _ = Nothing + +tyImports :: String -> VHDLM Doc +tyImports nm = do + mkId <- Mon (mkIdentifier <*> pure Basic) + libs <- Mon $ use libraries + packs <- Mon $ use packages + punctuate' semi $ sequence + ([ "library IEEE" + , "use IEEE.STD_LOGIC_1164.ALL" + , "use IEEE.NUMERIC_STD.ALL" + , "use IEEE.MATH_REAL.ALL" + , "use std.textio.all" + , "use work.all" + , "use work." <> pretty (mkId (T.pack nm `T.append` "_types")) <> ".all" + ] ++ (map (("library" <+>) . pretty) (nub libs)) + ++ (map (("use" <+>) . pretty) (nub packs))) + +entity :: Component -> VHDLM Doc +entity c = do + rec (p,ls) <- fmap unzip (ports (maximum ls)) + "entity" <+> pretty (componentName c) <+> "is" <> line <> + (case p of + [] -> emptyDoc + _ -> indent 2 ("port" <> + parens (align $ vcat $ punctuate semi (pure p)) <> + semi) + ) <> line <> + "end" <> semi + where + ports l = sequence + $ [ (,fromIntegral $ T.length i) <$> (encodingNote ty <> fill l (pretty i) <+> colon <+> "in" <+> vhdlType ty) + | (i,ty) <- inputs c ] ++ + [ (,fromIntegral $ T.length i) <$> (encodingNote ty <> fill l (pretty i) <+> colon <+> "out" <+> vhdlType ty) + | (_,(i,ty)) <- outputs c ] + +architecture :: Component -> VHDLM Doc +architecture c = + nest 2 + ("architecture structural of" <+> pretty (componentName c) <+> "is" <> line <> + decls (declarations c)) <> line <> + nest 2 + ("begin" <> line <> + insts (declarations c)) <> line <> + "end" <> semi + +-- | Convert a Netlist HWType to a VHDL type +vhdlType :: HWType -> VHDLM Doc +vhdlType hwty = do + hwty' <- normaliseType hwty + Mon (tyCache %= HashSet.insert hwty') + go hwty' + where + go :: HWType -> VHDLM Doc + go Bool = "boolean" + go Bit = "std_logic" + go (Clock {}) = "std_logic" + go (Reset {}) = "std_logic" + go (BitVector n) = case n of + 0 -> "std_logic_vector (0 downto 1)" + _ -> "std_logic_vector" <> parens (int (n-1) <+> "downto 0") + go (Signed n) = case n of + 0 -> "signed (0 downto 1)" + _ -> "signed" <> parens (int (n-1) <+> "downto 0") + go (Unsigned n) = case n of + 0 -> "unsigned (0 downto 1)" + _ -> "unsigned" <> parens ( int (n-1) <+> "downto 0") + go (Vector n elTy) = do + nm <- Mon $ use modNm + pretty (T.toLower $ T.pack nm) <> "_types.array_of_" <> tyName elTy <> parens ("0 to " <> int (n-1)) + go (RTree d elTy) = do + nm <- Mon $ use modNm + pretty (T.toLower $ T.pack nm) <> "_types.tree_of_" <> tyName elTy <> parens ("0 to " <> int ((2^d)-1)) + go t@(Product _ _) = do + nm <- Mon $ use modNm + pretty (T.toLower $ T.pack nm) <> "_types." <> tyName t + go (Void {}) = "std_logic_vector (0 downto 1)" + go String = "string" + go ty = error $ $(curLoc) ++ "vhdlType: type is not normalised: " ++ show ty + +sigDecl :: VHDLM Doc -> HWType -> VHDLM Doc +sigDecl d t = d <+> colon <+> vhdlType t + +-- | Convert a Netlist HWType to the root of a VHDL type +vhdlTypeMark :: HWType -> VHDLM Doc +vhdlTypeMark hwty = do + hwty' <- normaliseType hwty + Mon (tyCache %= HashSet.insert hwty') + go hwty' + where + go Bool = "boolean" + go Bit = "std_logic" + go (Clock {}) = "std_logic" + go (Reset {}) = "std_logic" + go (BitVector _) = "std_logic_vector" + go (Signed _) = "signed" + go (Unsigned _) = "unsigned" + go (Vector _ elTy) = do + nm <- Mon $ use modNm + pretty (T.toLower $ T.pack nm) <> "_types.array_of_" <> tyName elTy + go (RTree _ elTy) = do + nm <- Mon $ use modNm + pretty (T.toLower $ T.pack nm) <> "_types.tree_of_" <> tyName elTy + go t@(Product _ _) = do + nm <- Mon $ use modNm + pretty (T.toLower $ T.pack nm) <> "_types." <> tyName t + go t = error $ $(curLoc) ++ "vhdlTypeMark: " ++ show t + +tyName :: HWType -> VHDLM Doc +tyName Bool = "boolean" +tyName Bit = "std_logic" +tyName (Clock {}) = "std_logic" +tyName (Reset {}) = "std_logic" +tyName (Vector n elTy) = "array_of_" <> int n <> "_" <> tyName elTy +tyName (RTree n elTy) = "tree_of_" <> int n <> "_" <> tyName elTy +tyName (BitVector n) = "std_logic_vector_" <> int n +tyName t@(Index _) = "unsigned_" <> int (typeSize t) +tyName (Signed n) = "signed_" <> int n +tyName (Unsigned n) = "unsigned_" <> int n +tyName t@(Sum _ _) = "std_logic_vector_" <> int (typeSize t) +tyName t@(Product nm _) = do + tN <- normaliseType t + Mon $ makeCached tN nameCache prodName + where + prodName = do + tyCache %= HashSet.insert t + seen <- use tySeen + mkId <- mkIdentifier <*> pure Basic + let nm' = (mkId . last . T.splitOn ".") nm + nm'' = if T.null nm' + then "product" + else nm' + nm3 = if nm'' `elem` seen + then go mkId seen (0::Integer) nm'' + else nm'' + tySeen %= (nm3:) + pretty nm3 + + go mkId s i n = + let n' = n `T.append` T.pack ('_':show i) + in if n' `elem` s + then go mkId s (i+1) n + else n' +tyName t@(SP _ _) = "std_logic_vector_" <> int (typeSize t) +tyName _ = emptyDoc + +-- | Convert a Netlist HWType to an error VHDL value for that type +vhdlTypeErrValue :: HWType -> VHDLM Doc +vhdlTypeErrValue Bool = "true" +vhdlTypeErrValue Bit = "'-'" +vhdlTypeErrValue t@(Vector n elTy) = do + syn <-Mon hdlSyn + case syn of + Vivado -> vhdlTypeMark t <> "'" <> parens (int 0 <+> "to" <+> int (n-1) <+> rarrow <+> + "std_logic_vector'" <> parens (int 0 <+> "to" <+> int (typeSize elTy - 1) <+> + rarrow <+> "'-'")) + _ -> vhdlTypeMark t <> "'" <> parens (int 0 <+> "to" <+> int (n-1) <+> rarrow <+> vhdlTypeErrValue elTy) +vhdlTypeErrValue t@(RTree n elTy) = do + syn <-Mon hdlSyn + case syn of + Vivado -> vhdlTypeMark t <> "'" <> parens (int 0 <+> "to" <+> int (2^n - 1) <+> rarrow <+> + "std_logic_vector'" <> parens (int 0 <+> "to" <+> int (typeSize elTy - 1) <+> + rarrow <+> "'-'")) + _ -> vhdlTypeMark t <> "'" <> parens (int 0 <+> "to" <+> int (2^n - 1) <+> rarrow <+> vhdlTypeErrValue elTy) +vhdlTypeErrValue t@(Product _ elTys) = vhdlTypeMark t <> "'" <> tupled (mapM vhdlTypeErrValue elTys) +vhdlTypeErrValue (Reset {}) = "'-'" +vhdlTypeErrValue (Clock _ _ Source) = "'-'" +vhdlTypeErrValue (Clock _ _ Gated) = "('-',false)" +vhdlTypeErrValue (Void {}) = "std_logic_vector'(0 downto 1 => '-')" +vhdlTypeErrValue String = "\"ERROR\"" +vhdlTypeErrValue t = vhdlTypeMark t <> "'" <> parens (int 0 <+> "to" <+> int (typeSize t - 1) <+> rarrow <+> "'-'") + +decls :: [Declaration] -> VHDLM Doc +decls [] = emptyDoc +decls ds = do + rec (dsDoc,ls) <- fmap (unzip . catMaybes) $ mapM (decl (maximum ls)) ds + case dsDoc of + [] -> emptyDoc + _ -> punctuate' semi (pure dsDoc) + +decl :: Int -> Declaration -> VHDLM (Maybe (Doc,Int)) +decl l (NetDecl' noteM _ id_ ty) = Just <$> (,fromIntegral (T.length id_)) <$> + maybe id addNote noteM ("signal" <+> fill l (pretty id_) <+> colon <+> either pretty vhdlType ty) + where + addNote n = mappend ("--" <+> pretty n <> line) + +decl _ _ = return Nothing + +insts :: [Declaration] -> VHDLM Doc +insts [] = emptyDoc +insts is = vcat . punctuate line . fmap catMaybes $ mapM inst_ is + +-- | Turn a Netlist Declaration to a VHDL concurrent block +inst_ :: Declaration -> VHDLM (Maybe Doc) +inst_ (Assignment id_ e) = fmap Just $ + pretty id_ <+> larrow <+> align (expr_ False e) <> semi + +inst_ (CondAssignment id_ _ scrut _ [(Just (BoolLit b), l),(_,r)]) = fmap Just $ + pretty id_ <+> larrow + <+> align (vsep (sequence [expr_ False t <+> "when" <+> + expr_ False scrut <+> "else" + ,expr_ False f <> semi + ])) + where + (t,f) = if b then (l,r) else (r,l) + +inst_ (CondAssignment id_ _ scrut scrutTy es) = fmap Just $ + "with" <+> parens (expr_ True scrut) <+> "select" <> line <> + indent 2 (pretty id_ <+> larrow <+> align (vcat (punctuate comma (conds esNub)) <> semi)) + where + esMod = map (first (fmap (patMod scrutTy))) es + esNub = nubBy ((==) `on` fst) esMod + + conds :: [(Maybe Literal,Expr)] -> VHDLM [Doc] + conds [] = return [] + conds [(_,e)] = expr_ False e <+> "when" <+> "others" <:> return [] + conds ((Nothing,e):_) = expr_ False e <+> "when" <+> "others" <:> return [] + conds ((Just c ,e):es') = expr_ False e <+> "when" <+> patLit scrutTy c <:> conds es' + +inst_ (InstDecl libM nm lbl pms) = do + maybe (return ()) (\lib -> Mon (libraries %= (lib:))) libM + fmap Just $ + nest 2 $ pretty lbl <+> colon <+> "entity" + <+> maybe emptyDoc ((<> ".") . pretty) libM <> pretty nm <> line <> pms' <> semi + where + pms' = do + rec (p,ls) <- fmap unzip $ sequence [ (,formalLength i) <$> fill (maximum ls) (expr_ False i) <+> "=>" <+> expr_ False e | (i,_,_,e) <- pms] + nest 2 $ "port map" <> line <> tupled (pure p) + formalLength (Identifier i _) = fromIntegral (T.length i) + formalLength _ = 0 + +inst_ (BlackBoxD _ libs imps inc bs bbCtx) = + fmap Just (Mon (column (renderBlackBox libs imps inc bs bbCtx))) + +inst_ _ = return Nothing + +-- | Turn a Netlist expression into a VHDL expression +expr_ :: Bool -- ^ Enclose in parenthesis? + -> Expr -- ^ Expr to convert + -> VHDLM Doc +expr_ _ (Literal sizeM lit) = exprLit sizeM lit +expr_ _ (Identifier id_ Nothing) = pretty id_ +expr_ _ (Identifier id_ (Just (Indexed (ty@(SP _ args),dcI,fI)))) = fromSLV argTy id_ start end + where + argTys = snd $ args !! dcI + argTy = argTys !! fI + argSize = typeSize argTy + other = otherSize argTys (fI-1) + start = typeSize ty - 1 - conSize ty - other + end = start - argSize + 1 + +expr_ _ (Identifier id_ (Just (Indexed (ty@(Product _ _),_,fI)))) = + pretty id_ <> dot <> tyName ty <> "_sel" <> int fI + +expr_ _ (Identifier id_ (Just (Indexed (ty@(Clock _ _ Gated),_,fI)))) = do + ty' <- normaliseType ty + pretty id_ <> dot <> tyName ty' <> "_sel" <> int fI + +expr_ _ (Identifier id_ (Just (Indexed ((Vector _ elTy),1,0)))) = do + syn <- Mon hdlSyn + case syn of + Vivado -> do + id' <- fmap renderOneLine (pretty id_ <> parens (int 0)) + fromSLV elTy id' (typeSize elTy - 1) 0 + _ -> pretty id_ <> parens (int 0) +expr_ _ (Identifier id_ (Just (Indexed ((Vector n _),1,1)))) = pretty id_ <> parens (int 1 <+> "to" <+> int (n-1)) + +-- This is a "Hack", we cannot construct trees with a negative depth. This is +-- here so that we can recognise merged RTree modifiers. See the code in +-- @Clash.Backend.nestM@ which construct these tree modifiers. +expr_ _ (Identifier id_ (Just (Indexed (RTree (-1) _,l,r)))) = + pretty id_ <> parens (int l <+> "to" <+> int (r-1)) + +expr_ _ (Identifier id_ (Just (Indexed ((RTree 0 elTy),0,0)))) = do + syn <- Mon hdlSyn + case syn of + Vivado -> do + id' <- fmap renderOneLine (pretty id_ <> parens (int 0)) + fromSLV elTy id' (typeSize elTy - 1) 0 + _ -> pretty id_ <> parens (int 0) +expr_ _ (Identifier id_ (Just (Indexed ((RTree n _),1,0)))) = + let z = 2^(n-1) + in pretty id_ <> parens (int 0 <+> "to" <+> int (z-1)) +expr_ _ (Identifier id_ (Just (Indexed ((RTree n _),1,1)))) = + let z = 2^(n-1) + z' = 2^n + in pretty id_ <> parens (int z <+> "to" <+> int (z'-1)) + +-- This is a HACK for Clash.Driver.TopWrapper.mkOutput +-- Vector's don't have a 10'th constructor, this is just so that we can +-- recognize the particular case +expr_ _ (Identifier id_ (Just (Indexed ((Vector _ elTy),10,fI)))) = do + syn <- Mon hdlSyn + case syn of + Vivado -> do + id' <- fmap renderOneLine (pretty id_ <> parens (int fI)) + fromSLV elTy id' (typeSize elTy - 1) 0 + _ -> pretty id_ <> parens (int fI) + +-- This is a HACK for Clash.Driver.TopWrapper.mkOutput +-- RTree's don't have a 10'th constructor, this is just so that we can +-- recognize the particular case +expr_ _ (Identifier id_ (Just (Indexed ((RTree _ elTy),10,fI)))) = do + syn <- Mon hdlSyn + case syn of + Vivado -> do + id' <- fmap renderOneLine (pretty id_ <> parens (int fI)) + fromSLV elTy id' (typeSize elTy - 1) 0 + _ -> pretty id_ <> parens (int fI) + +expr_ _ (Identifier id_ (Just (DC (ty@(SP _ _),_)))) = pretty id_ <> parens (int start <+> "downto" <+> int end) + where + start = typeSize ty - 1 + end = typeSize ty - conSize ty + +expr_ _ (Identifier id_ (Just (Indexed ((Signed _ ),_,_)))) = do + iw <- Mon $ use intWidth + "resize" <> parens (pretty id_ <> "," <> int iw) +expr_ _ (Identifier id_ (Just (Indexed ((Unsigned _),_,_)))) = do + iw <- Mon $ use intWidth + "resize" <> parens (pretty id_ <> "," <> int iw) + +expr_ b (Identifier id_ (Just (Nested m1 m2))) = case nestM m1 m2 of + Just m3 -> expr_ b (Identifier id_ (Just m3)) + _ -> do + k <- expr_ b (Identifier id_ (Just m1)) + expr_ b (Identifier (renderOneLine k) (Just m2)) + +expr_ _ (Identifier id_ (Just _)) = pretty id_ + +expr_ b (DataCon _ (DC (Void {}, -1)) [e]) = expr_ b e + +expr_ _ (DataCon ty@(Vector 0 _) _ _) = vhdlTypeErrValue ty + +expr_ _ (DataCon ty@(Vector 1 elTy) _ [e]) = do + syn <- Mon hdlSyn + case syn of + Vivado -> vhdlTypeMark ty <> "'" <> parens (int 0 <+> rarrow <+> toSLV elTy e) + _ -> vhdlTypeMark ty <> "'" <> parens (int 0 <+> rarrow <+> expr_ False e) +expr_ _ e@(DataCon ty@(Vector _ elTy) _ [e1,e2]) = do + syn <- Mon hdlSyn + case syn of + Vivado -> vhdlTypeMark ty <> "'" <> case vectorChain e of + Just es -> align (tupled (mapM (toSLV elTy) es)) + Nothing -> parens ("std_logic_vector'" <> parens (toSLV elTy e1) <+> "&" <+> expr_ False e2) + _ -> vhdlTypeMark ty <> "'" <> case vectorChain e of + Just es -> align (tupled (mapM (expr_ False) es)) + Nothing -> parens (vhdlTypeMark elTy <> "'" <> parens (expr_ False e1) <+> "&" <+> expr_ False e2) + +expr_ _ (DataCon ty@(RTree 0 elTy) _ [e]) = do + syn <- Mon hdlSyn + case syn of + Vivado -> vhdlTypeMark ty <> "'" <> parens (int 0 <+> rarrow <+> toSLV elTy e) + _ -> vhdlTypeMark ty <> "'" <> parens (int 0 <+> rarrow <+> expr_ False e) +expr_ _ e@(DataCon ty@(RTree d elTy) _ [e1,e2]) = vhdlTypeMark ty <> "'" <> case rtreeChain e of + Just es -> tupled (mapM (expr_ False) es) + Nothing -> parens (vhdlTypeMark (RTree (d-1) elTy) <> "'" <> parens (expr_ False e1) <+> + "&" <+> expr_ False e2) + +expr_ _ (DataCon ty@(SP _ args) (DC (_,i)) es) = assignExpr + where + argTys = snd $ args !! i + dcSize = conSize ty + sum (map typeSize argTys) + dcExpr = expr_ False (dcToExpr ty i) + argExprs = map parens (zipWith toSLV argTys es) + extraArg = case typeSize ty - dcSize of + 0 -> [] + n -> [bits (replicate n U)] + assignExpr = "std_logic_vector'" <> parens (hcat $ punctuate " & " $ sequence (dcExpr:argExprs ++ extraArg)) + +expr_ _ (DataCon ty@(Sum _ _) (DC (_,i)) []) = expr_ False (dcToExpr ty i) +expr_ _ (DataCon ty@(Product _ _) _ es) = + tupled $ zipWithM (\i e' -> tyName ty <> "_sel" <> int i <+> rarrow <+> expr_ False e') [0..] es + +expr_ _ (DataCon ty@(Clock _ _ Gated) _ es) = do + ty' <- normaliseType ty + tupled $ zipWithM (\i e' -> tyName ty' <> "_sel" <> int i <+> rarrow <+> expr_ False e') [0..] es + +expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) + | pNm == "Clash.Sized.Internal.Signed.fromInteger#" + , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx + = exprLit (Just (Signed (fromInteger n),fromInteger n)) i + +expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) + | pNm == "Clash.Sized.Internal.Unsigned.fromInteger#" + , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx + = exprLit (Just (Unsigned (fromInteger n),fromInteger n)) i + +expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) + | pNm == "Clash.Sized.Internal.BitVector.fromInteger#" + , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx + = exprLit (Just (BitVector (fromInteger n),fromInteger n)) i + +expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) + | pNm == "Clash.Sized.Internal.BitVector.fromInteger##" + , [Literal _ i] <- extractLiterals bbCtx + = exprLit (Just (Bit,1)) i + +expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) + | pNm == "Clash.Sized.Internal.Index.fromInteger#" + , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx + , Just k <- clogBase 2 n + , let k' = max 1 k + = exprLit (Just (Unsigned k',k')) i + +expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) + | pNm == "Clash.Sized.Internal.Index.maxBound#" + , [Literal _ (NumLit n)] <- extractLiterals bbCtx + , n > 0 + , Just k <- clogBase 2 n + , let k' = max 1 k + = exprLit (Just (Unsigned k',k')) (NumLit (n-1)) + +expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) + | pNm == "GHC.Types.I#" + , [Literal _ (NumLit n)] <- extractLiterals bbCtx + = do iw <- Mon $ use intWidth + exprLit (Just (Signed iw,iw)) (NumLit n) + +expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) + | pNm == "GHC.Types.W#" + , [Literal _ (NumLit n)] <- extractLiterals bbCtx + = do iw <- Mon $ use intWidth + exprLit (Just (Unsigned iw,iw)) (NumLit n) + +expr_ b (BlackBoxE _ libs imps inc bs bbCtx b') = do + parenIf (b || b') (Mon (renderBlackBox libs imps inc bs bbCtx <*> pure 0)) + +expr_ _ (DataTag Bool (Left id_)) = "tagToEnum" <> parens (pretty id_) +expr_ _ (DataTag Bool (Right id_)) = "dataToTag" <> parens (pretty id_) + +expr_ _ (DataTag hty@(Sum _ _) (Left id_)) = + "std_logic_vector" <> parens ("resize" <> parens ("unsigned" <> parens ("std_logic_vector" <> parens (pretty id_)) <> "," <> int (typeSize hty))) +expr_ _ (DataTag (Sum _ _) (Right id_)) = do + iw <- Mon $ use intWidth + "signed" <> parens ("std_logic_vector" <> parens ("resize" <> parens ("unsigned" <> parens (pretty id_) <> "," <> int iw))) + +expr_ _ (DataTag (Product _ _) (Right _)) = do + iw <- Mon $ use intWidth + "to_signed" <> parens (int 0 <> "," <> int iw) +expr_ _ (DataTag hty@(SP _ _) (Right id_)) = do { + ; iw <- Mon $ use intWidth + ; "signed" <> parens ("std_logic_vector" <> parens ( + "resize" <> parens ("unsigned" <> parens (pretty id_ <> parens (int start <+> "downto" <+> int end)) + <> "," <> int iw))) + } + where + start = typeSize hty - 1 + end = typeSize hty - conSize hty + +expr_ _ (DataTag (Vector 0 _) (Right _)) = do + iw <- Mon $ use intWidth + "to_signed" <> parens (int 0 <> "," <> int iw) +expr_ _ (DataTag (Vector _ _) (Right _)) = do + iw <- Mon $ use intWidth + "to_signed" <> parens (int 1 <> "," <> int iw) + +expr_ _ (DataTag (RTree 0 _) (Right _)) = do + iw <- Mon $ use intWidth + "to_signed" <> parens (int 0 <> "," <> int iw) +expr_ _ (DataTag (RTree _ _) (Right _)) = do + iw <- Mon $ use intWidth + "to_signed" <> parens (int 1 <> "," <> int iw) + +expr_ _ (ConvBV topM hwty True e) = do + nm <- Mon $ use modNm + case topM of + Nothing -> pretty (T.pack nm) <> "_types" <> dot <> "toSLV" <> + parens (vhdlTypeMark hwty <> "'" <> parens (expr_ False e)) + Just t -> pretty t <> dot <> pretty t <> "_types" <> dot <> "toSLV" <> parens (expr_ False e) + +expr_ _ (ConvBV topM _ False e) = do + nm <- Mon $ use modNm + maybe (pretty (T.pack nm) <> "_types" ) (\t -> pretty t <> dot <> pretty t <> "_types") topM <> dot <> + "fromSLV" <> parens (expr_ False e) + +expr_ _ e = error $ $(curLoc) ++ (show e) -- empty + +otherSize :: [HWType] -> Int -> Int +otherSize _ n | n < 0 = 0 +otherSize [] _ = 0 +otherSize (a:as) n = typeSize a + otherSize as (n-1) + +vectorChain :: Expr -> Maybe [Expr] +vectorChain (DataCon (Vector 0 _) _ _) = Just [] +vectorChain (DataCon (Vector 1 _) _ [e]) = Just [e] +vectorChain (DataCon (Vector _ _) _ [e1,e2]) = Just e1 <:> vectorChain e2 +vectorChain _ = Nothing + +rtreeChain :: Expr -> Maybe [Expr] +rtreeChain (DataCon (RTree 1 _) _ [e]) = Just [e] +rtreeChain (DataCon (RTree _ _) _ [e1,e2]) = liftA2 (++) (rtreeChain e1) (rtreeChain e2) +rtreeChain _ = Nothing + +exprLit :: Maybe (HWType,Size) -> Literal -> VHDLM Doc +exprLit Nothing (NumLit i) = integer i + +exprLit (Just (hty,sz)) (NumLit i) = case hty of + Unsigned n + | i < 2^(31 :: Integer) -> "to_unsigned" <> parens (integer i <> "," <> int n) + | otherwise -> "unsigned'" <> parens lit + Signed n + | i < 2^(31 :: Integer) && i > (-2^(31 :: Integer)) -> "to_signed" <> parens (integer i <> "," <> int n) + | otherwise -> "signed'" <> parens lit + BitVector _ -> "std_logic_vector'" <> parens lit + Bit -> squotes (int (fromInteger i `mod` 2)) + _ -> blit + + where + validHexLit = sz `mod` 4 == 0 && sz /= 0 + lit = if validHexLit then hlit else blit + blit = bits (toBits sz i) + i' = case hty of + Signed _ -> let mask = 2^(sz-1) in case divMod i mask of + (s,i'') | even s -> i'' + | otherwise -> i'' - mask + _ -> i `mod` 2^sz + hlit = (if i' < 0 then "-" else emptyDoc) <> hex (toHex sz i') +exprLit _ (BoolLit t) = if t then "true" else "false" +exprLit _ (BitLit b) = squotes $ bit_char b +exprLit _ (StringLit s) = pretty . T.pack $ show s +exprLit _ l = error $ $(curLoc) ++ "exprLit: " ++ show l + +patLit :: HWType -> Literal -> VHDLM Doc +patLit Bit (NumLit i) = if i == 0 then "'0'" else "'1'" +patLit hwTy (NumLit i) = + let sz = conSize hwTy + in case sz `mod` 4 of + 0 -> hex (toHex sz i) + _ -> bits (toBits sz i) +patLit _ l = exprLit Nothing l + +patMod :: HWType -> Literal -> Literal +patMod hwTy (NumLit i) = NumLit (i `mod` (2 ^ typeSize hwTy)) +patMod _ l = l + +toBits :: Integral a => Int -> a -> [Bit] +toBits size val = map (\x -> if odd x then H else L) + $ reverse + $ take size + $ map (`mod` 2) + $ iterate (`div` 2) val + +bits :: [Bit] -> VHDLM Doc +bits = dquotes . hcat . mapM bit_char + +toHex :: Int -> Integer -> String +toHex sz i = + let Just d = clogBase 16 (2^sz) + in printf ("%0" ++ show d ++ "X") (abs i) + +hex :: String -> VHDLM Doc +hex s = char 'x' <> dquotes (pretty (T.pack s)) + +bit_char :: Bit -> VHDLM Doc +bit_char H = char '1' +bit_char L = char '0' +bit_char U = char '-' +bit_char Z = char 'Z' + +toSLV :: HWType -> Expr -> VHDLM Doc +toSLV Bool e = do + nm <- Mon $ use modNm + pretty (T.toLower $ T.pack nm) <> "_types.toSLV" <> parens (expr_ False e) +toSLV Bit e = do + nm <- Mon $ use modNm + pretty (T.toLower $ T.pack nm) <> "_types.toSLV" <> parens (expr_ False e) +toSLV (Clock {}) e = do + nm <- Mon $ use modNm + pretty (T.toLower $ T.pack nm) <> "_types.toSLV" <> parens (expr_ False e) +toSLV (Reset {}) e = do + nm <- Mon $ use modNm + pretty (T.toLower $ T.pack nm) <> "_types.toSLV" <> parens (expr_ False e) +toSLV (BitVector _) e = expr_ False e +toSLV (Signed _) e = "std_logic_vector" <> parens (expr_ False e) +toSLV (Unsigned _) e = "std_logic_vector" <> parens (expr_ False e) +toSLV (Index _) e = "std_logic_vector" <> parens (expr_ False e) +toSLV (Sum _ _) e = expr_ False e +toSLV t@(Product _ tys) (Identifier id_ Nothing) = do + selIds' <- sequence selIds + encloseSep lparen rparen " & " (zipWithM toSLV tys selIds') + where + tName = tyName t + selNames = map (fmap renderOneLine ) [pretty id_ <> dot <> tName <> "_sel" <> int i | i <- [0..(length tys)-1]] + selIds = map (fmap (\n -> Identifier n Nothing)) selNames +toSLV (Product _ tys) (DataCon _ _ es) = do + encloseSep lparen rparen " & " (zipWithM toSLV tys es) +toSLV (Product _ _) e = do + nm <- Mon $ use modNm + pretty (T.toLower $ T.pack nm) <> "_types.toSLV" <> parens (expr_ False e) +toSLV (SP _ _) e = expr_ False e +toSLV (Vector n elTy) (Identifier id_ Nothing) = do + selIds' <- sequence selIds + syn <- Mon hdlSyn + parens (vcat $ punctuate " & " + (case syn of + Vivado -> mapM (expr_ False) selIds' + _ -> mapM (toSLV elTy) selIds')) + where + selNames = map (fmap renderOneLine ) $ [pretty id_ <> parens (int i) | i <- [0 .. (n-1)]] + selIds = map (fmap (`Identifier` Nothing)) selNames +toSLV (Vector n elTy) (DataCon _ _ es) = parens $ vcat $ punctuate " & " (zipWithM toSLV [elTy,Vector (n-1) elTy] es) +toSLV (Vector _ _) e = do + nm <- Mon $ use modNm + pretty (T.toLower $ T.pack nm) <> "_types.toSLV" <> parens (expr_ False e) +toSLV hty e = error $ $(curLoc) ++ "toSLV: ty:" ++ show hty ++ "\n expr: " ++ show e + +fromSLV :: HWType -> Identifier -> Int -> Int -> VHDLM Doc +fromSLV Bool id_ start _ = do + nm <- Mon $ use modNm + pretty (T.toLower $ T.pack nm) <> "_types.fromSLV" <> parens (pretty id_ <> parens (int start <+> "downto" <+> int start)) +fromSLV Bit id_ start _ = pretty id_ <> parens (int start) +fromSLV (BitVector _) id_ start end = pretty id_ <> parens (int start <+> "downto" <+> int end) +fromSLV (Index _) id_ start end = "unsigned" <> parens (pretty id_ <> parens (int start <+> "downto" <+> int end)) +fromSLV (Signed _) id_ start end = "signed" <> parens (pretty id_ <> parens (int start <+> "downto" <+> int end)) +fromSLV (Unsigned _) id_ start end = "unsigned" <> parens (pretty id_ <> parens (int start <+> "downto" <+> int end)) +fromSLV (Sum _ _) id_ start end = pretty id_ <> parens (int start <+> "downto" <+> int end) +fromSLV t@(Product _ tys) id_ start _ = do + tupled $ zipWithM (\s e -> s <+> rarrow <+> e) selNames args + where + tName = tyName t + selNames = [tName <> "_sel" <> int i | i <- [0..]] + argLengths = map typeSize tys + starts = start : snd (mapAccumL ((join (,) .) . (-)) start argLengths) + ends = map (+1) (tail starts) + args = zipWith3 (`fromSLV` id_) tys starts ends + +fromSLV (SP _ _) id_ start end = pretty id_ <> parens (int start <+> "downto" <+> int end) +fromSLV (Vector n elTy) id_ start _ = + if n > 1 then tupled args + else parens (int 0 <+> rarrow <+> fmap head args) + where + argLength = typeSize elTy + starts = take (n + 1) $ iterate (subtract argLength) start + ends = map (+1) (tail starts) + args = do syn <- Mon hdlSyn + let elTy' = case syn of + Vivado -> BitVector (argLength - 1) + _ -> elTy + zipWithM (fromSLV elTy' id_) starts ends +fromSLV (Clock {}) id_ start _ = pretty id_ <> parens (int start) +fromSLV (Reset {}) id_ start _ = pretty id_ <> parens (int start) +fromSLV hty _ _ _ = error $ $(curLoc) ++ "fromSLV: " ++ show hty + +dcToExpr :: HWType -> Int -> Expr +dcToExpr ty i = Literal (Just (ty,conSize ty)) (NumLit (toInteger i)) + +larrow :: VHDLM Doc +larrow = "<=" + +rarrow :: VHDLM Doc +rarrow = "=>" + +parenIf :: Monad m => Bool -> Mon m Doc -> Mon m Doc +parenIf True = parens +parenIf False = id + +punctuate' :: Monad m => Mon m Doc -> Mon m [Doc] -> Mon m Doc +punctuate' s d = vcat (punctuate s d) <> s + +encodingNote :: HWType -> VHDLM Doc +encodingNote (Clock _ _ Gated) = "-- gated clock" <> line +encodingNote (Clock {}) = "-- clock" <> line +encodingNote (Reset {}) = "-- asynchronous reset: active high" <> line +encodingNote _ = emptyDoc diff --git a/src/Clash/Backend/Verilog.hs b/src/Clash/Backend/Verilog.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Backend/Verilog.hs @@ -0,0 +1,627 @@ +{-| + Copyright : (C) 2015-2016, University of Twente, + 2017, Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Generate Verilog for assorted Netlist datatypes +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +module Clash.Backend.Verilog (VerilogState, include) where + +import Control.Applicative ((<*), (*>)) +import qualified Control.Applicative as A +import Control.Lens ((+=),(-=),(.=),(%=), makeLenses, use) +import Control.Monad (forM) +import Control.Monad.State (State) +import qualified Data.HashSet as HashSet +import Data.Maybe (catMaybes,fromMaybe,mapMaybe) +import Data.List (nub) +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid hiding (Product, Sum) +#endif +import Data.Semigroup.Monad +import Data.Text.Lazy (pack, unpack) +import qualified Data.Text.Lazy as Text +import Data.Text.Prettyprint.Doc.Extra +#ifdef CABAL +import qualified Data.Version +#endif +import qualified System.FilePath + +import Clash.Annotations.Primitive (HDL (..)) +import Clash.Backend +import Clash.Driver.Types (SrcSpan, noSrcSpan) +import Clash.Netlist.BlackBox.Types (HdlSyn) +import Clash.Netlist.BlackBox.Util (extractLiterals, renderBlackBox) +import Clash.Netlist.Id (IdType (..), mkBasicId') +import Clash.Netlist.Types hiding (_intWidth, intWidth) +import Clash.Netlist.Util hiding (mkIdentifier, extendIdentifier) +import Clash.Signal.Internal (ClockKind (..)) +import Clash.Util (curLoc, (<:>)) + +#ifdef CABAL +import qualified Paths_clash_lib +#endif + +-- | State for the 'Clash.Backend.Verilog.VerilogM' monad: +data VerilogState = + VerilogState + { _genDepth :: Int -- ^ Depth of current generative block + , _idSeen :: [Identifier] + , _srcSpan :: SrcSpan + , _includes :: [(String,Doc)] + , _imports :: [Text.Text] + , _intWidth :: Int -- ^ Int/Word/Integer bit-width + , _hdlsyn :: HdlSyn + } + +makeLenses ''VerilogState + +primsRoot :: IO FilePath +#ifdef CABAL +primsRoot = Paths_clash_lib.getDataFileName "prims" +#else +primsRoot = return ("clash-lib" System.FilePath. "prims") +#endif + +instance Backend VerilogState where + initBackend = VerilogState 0 [] noSrcSpan [] [] + hdlKind = const Verilog + primDirs = const $ do root <- primsRoot + return [ root System.FilePath. "common" + , root System.FilePath. "commonverilog" + , root System.FilePath. "verilog" + ] + extractTypes = const HashSet.empty + name = const "verilog" + extension = const ".v" + + genHDL = const genVerilog + mkTyPackage _ _ = return [] + hdlType _ = verilogType + hdlTypeErrValue = verilogTypeErrValue + hdlTypeMark = verilogTypeMark + hdlSig t ty = sigDecl (string t) ty + genStmt True = do cnt <- use genDepth + genDepth += 1 + if cnt > 0 + then emptyDoc + else "generate" + genStmt False = do genDepth -= 1 + cnt <- use genDepth + if cnt > 0 + then emptyDoc + else "endgenerate" + inst = inst_ + expr = expr_ + iwWidth = use intWidth + toBV _ = string + fromBV _ = string + hdlSyn = use hdlsyn + mkIdentifier = return go + where + go Basic nm = filterReserved (mkBasicId' True nm) + go Extended (rmSlash -> nm) = case go Basic nm of + nm' | nm /= nm' -> Text.concat ["\\",nm," "] + |otherwise -> nm' + extendIdentifier = return go + where + go Basic nm ext = filterReserved (mkBasicId' True (nm `Text.append` ext)) + go Extended (rmSlash . escapeTemplate -> nm) ext = + let nmExt = nm `Text.append` ext + in case go Basic nm ext of + nm' | nm' /= nmExt -> case Text.head nmExt of + '#' -> Text.concat ["\\",nmExt," "] + _ -> Text.concat ["\\#",nmExt," "] + | otherwise -> nm' + + setModName _ = id + setSrcSpan = (srcSpan .=) + getSrcSpan = use srcSpan + blockDecl _ ds = do + decs <- decls ds + if isEmpty decs + then insts ds + else + pure decs <> line <> + insts ds + unextend = return rmSlash + addInclude inc = includes %= (inc:) + addLibraries _ = return () + addImports inps = imports %= (inps ++) + +rmSlash :: Identifier -> Identifier +rmSlash nm = fromMaybe nm $ do + nm1 <- Text.stripPrefix "\\" nm + pure (Text.filter (not . (== ' ')) nm1) + +type VerilogM a = Mon (State VerilogState) a + +-- List of reserved Verilog-2005 keywords +reservedWords :: [Identifier] +reservedWords = ["always","and","assign","automatic","begin","buf","bufif0" + ,"bufif1","case","casex","casez","cell","cmos","config","deassign","default" + ,"defparam","design","disable","edge","else","end","endcase","endconfig" + ,"endfunction","endgenerate","endmodule","endprimitive","endspecify" + ,"endtable","endtask","event","for","force","forever","fork","function" + ,"generate","genvar","highz0","highz1","if","ifnone","incdir","include" + ,"initial","inout","input","instance","integer","join","large","liblist" + ,"library","localparam","macromodule","medium","module","nand","negedge" + ,"nmos","nor","noshowcancelled","not","notif0","notif1","or","output" + ,"parameter","pmos","posedge","primitive","pull0","pull1","pulldown","pullup" + ,"pulsestyle_onevent","pulsestyle_ondetect","rcmos","real","realtime","reg" + ,"release","repeat","rnmos","rpmos","rtran","rtranif0","rtranif1","scalared" + ,"showcancelled","signed","small","specify","specparam","strong0","strong1" + ,"supply0","supply1","table","task","time","tran","tranif0","tranif1","tri" + ,"tri0","tri1","triand","trior","trireg","unsigned","use","uwire","vectored" + ,"wait","wand","weak0","weak1","while","wire","wor","xnor","xor"] + +filterReserved :: Identifier -> Identifier +filterReserved s = if s `elem` reservedWords + then s `Text.append` "_r" + else s + +-- | Generate VHDL for a Netlist component +genVerilog :: SrcSpan -> Component -> VerilogM ((String,Doc),[(String,Doc)]) +genVerilog sp c = do + Mon (setSrcSpan sp) + v <- commentHeader <> line <> module_ c + incs <- Mon $ use includes + return ((unpack cName,v),incs) + where +#ifdef CABAL + clashVer = Data.Version.showVersion Paths_clash_lib.version +#else + clashVer = "development" +#endif + cName = componentName c + commentHeader + = "/* AUTOMATICALLY GENERATED VERILOG-2001 SOURCE CODE." + <> line <> "** GENERATED BY CLASH " <> string (Text.pack clashVer) <> ". DO NOT MODIFY." + <> line <> "*/" + +module_ :: Component -> VerilogM Doc +module_ c = addSeen c *> modVerilog <* Mon (idSeen .= [] >> imports .= []) + where + modVerilog = do + body <- modBody + imps <- Mon $ use imports + modHeader <> line <> modPorts <> line <> include (nub imps) <> pure body <> line <> modEnding + + modHeader = "module" <+> string (componentName c) + modPorts = indent 4 (tupleInputs inPorts <> line <> tupleOutputs outPorts <> semi) + modBody = indent 2 (decls (declarations c)) <> line <> line <> insts (declarations c) + modEnding = "endmodule" + + inPorts = sequence [ sigPort Nothing p | p <- inputs c ] + outPorts = sequence [ sigPort (Just wr) p | (wr, p) <- outputs c ] + + wr2ty Nothing = "input" + wr2ty (Just Wire) = "output" <+> "wire" + wr2ty (Just Reg) = "output" <+> "reg" + + -- map a port to its verilog type, port name, and any encoding notes + sigPort (wr2ty -> portTy) (nm, hwTy) + = portTy <+> verilogType' True hwTy <+> string nm <+> encodingNote hwTy + + -- slightly more readable than 'tupled', makes the output Haskell-y-er + commafy v = (comma <> space) <> pure v + + tupleInputs v = v >>= \case + [] -> lparen <+> string "// No inputs" <> line + (x:xs) -> lparen <+> string "// Inputs" + <> line <> (string " " <> pure x) + <> line <> vcat (forM xs commafy) + <> line + + tupleOutputs v = v >>= \case + [] -> string " // No outputs" <> line <> rparen + (x:xs) -> string " // Outputs" + <> line <> (if (length (inputs c)) > 0 + then comma <> space <> pure x + else string " " <> pure x) + <> (if null xs then emptyDoc else line <> vcat (forM xs commafy)) + <> line <> rparen + +include :: Monad m => [Text.Text] -> Mon m Doc +include [] = emptyDoc +include xs = line <> + indent 2 (vcat (mapM (\i -> string "`include" <+> dquotes (string i)) xs)) + <> line <> line + +wireOrReg :: WireOrReg -> VerilogM Doc +wireOrReg Wire = "wire" +wireOrReg Reg = "reg" + +addSeen :: Component -> VerilogM () +addSeen c = do + let iport = map fst $ inputs c + oport = map (fst.snd) $ outputs c + nets = mapMaybe (\case {NetDecl' _ _ i _ -> Just i; _ -> Nothing}) $ declarations c + Mon $ idSeen .= concat [iport,oport,nets] + +-- render a type; by default, removing zero-sizes is an aesthetic operation +-- and is only valid for decls (e.g. when rendering module ports), so don't +-- do it by default to be safe +verilogType :: HWType -> VerilogM Doc +verilogType = verilogType' False + +verilogType' :: Bool -> HWType -> VerilogM Doc +verilogType' isDecl t = + let -- if the size is zero, it's single bit, so if we're + -- emitting a decl, then we can skip it - but we can't + -- skip it when selecting other values (e.g a slice) + renderVerilogTySize l + | l == 0 && isDecl = emptyDoc + | otherwise = brackets (int l <> colon <> int 0) + + -- signed types have to be rendered specially + getVerilogTy (Signed n) = ("signed" <> space, n) + getVerilogTy _ = (emptyDoc, typeSize t) + + in case t of + -- special case: Bit, Bool, clocks and resets + Clock _ _ Gated -> verilogType' isDecl (gatedClockType t) + Clock {} -> emptyDoc + Reset {} -> emptyDoc + Bit -> emptyDoc + Bool -> emptyDoc + + -- otherwise, print the type and prefix + ty | (prefix, sz) <- getVerilogTy ty + -> prefix <> renderVerilogTySize (sz-1) + +gatedClockType :: HWType -> HWType +gatedClockType (Clock _ _ Gated) = Product "GatedClock" [Bit,Bool] +gatedClockType ty = ty +{-# INLINE gatedClockType #-} + +sigDecl :: VerilogM Doc -> HWType -> VerilogM Doc +sigDecl d t = verilogType t <+> d + +-- | Convert a Netlist HWType to the root of a Verilog type +verilogTypeMark :: HWType -> VerilogM Doc +verilogTypeMark = const emptyDoc + +-- | Convert a Netlist HWType to an error VHDL value for that type +verilogTypeErrValue :: HWType -> VerilogM Doc +verilogTypeErrValue ty = braces (int (typeSize ty) <+> braces "1'bx") + +decls :: [Declaration] -> VerilogM Doc +decls [] = emptyDoc +decls ds = do + dsDoc <- catMaybes <$> (mapM decl ds) + case dsDoc of + [] -> emptyDoc + _ -> punctuate' semi (A.pure dsDoc) + +decl :: Declaration -> VerilogM (Maybe Doc) +decl (NetDecl' noteM wr id_ tyE) = + Just <$> maybe id addNote noteM (wireOrReg wr <+> tyDec tyE) + where + tyDec (Left ty) = string ty <+> string id_ + tyDec (Right ty) = sigDecl (string id_) ty + addNote n = mappend ("//" <+> string n <> line) + +decl _ = return Nothing + +insts :: [Declaration] -> VerilogM Doc +insts [] = emptyDoc +insts is = indent 2 . vcat . punctuate line . fmap catMaybes $ mapM inst_ is + +-- | Turn a Netlist Declaration to a SystemVerilog concurrent block +inst_ :: Declaration -> VerilogM (Maybe Doc) +inst_ (Assignment id_ e) = fmap Just $ + "assign" <+> string id_ <+> equals <+> expr_ False e <> semi + +inst_ (CondAssignment id_ _ scrut _ [(Just (BoolLit b), l),(_,r)]) = fmap Just $ + "always @(*) begin" <> line <> + indent 2 ("if" <> parens (expr_ True scrut) <> line <> + (indent 2 $ string id_ <+> equals <+> expr_ False t <> semi) <> line <> + "else" <> line <> + (indent 2 $ string id_ <+> equals <+> expr_ False f <> semi)) <> line <> + "end" + where + (t,f) = if b then (l,r) else (r,l) + + +inst_ (CondAssignment id_ _ scrut scrutTy es) = fmap Just $ + "always @(*) begin" <> line <> + indent 2 ("case" <> parens (expr_ True scrut) <> line <> + (indent 2 $ vcat $ punctuate semi (conds id_ es)) <> semi <> line <> + "endcase") <> line <> + "end" + where + conds :: Identifier -> [(Maybe Literal,Expr)] -> VerilogM [Doc] + conds _ [] = return [] + conds i [(_,e)] = ("default" <+> colon <+> string i <+> equals <+> expr_ False e) <:> return [] + conds i ((Nothing,e):_) = ("default" <+> colon <+> string i <+> equals <+> expr_ False e) <:> return [] + conds i ((Just c ,e):es') = (exprLit (Just (scrutTy,conSize scrutTy)) c <+> colon <+> string i <+> equals <+> expr_ False e) <:> conds i es' + +inst_ (InstDecl _ nm lbl pms) = fmap Just $ + nest 2 (string nm <+> string lbl <> line <> pms' <> semi) + where + pms' = tupled $ sequence [dot <> expr_ False i <+> parens (expr_ False e) | (i,_,_,e) <- pms] + +inst_ (BlackBoxD _ libs imps inc bs bbCtx) = + fmap Just (Mon (column (renderBlackBox libs imps inc bs bbCtx))) + +inst_ (NetDecl' _ _ _ _) = return Nothing + +-- | Calculate the beginning and end index into a variable, to get the +-- desired field. +modifier + :: Int + -- ^ Offset, only used when we have nested modifiers + -> Modifier + -> Maybe (Int,Int) +modifier offset (Indexed (ty@(SP _ args),dcI,fI)) = Just (start+offset,end+offset) + where + argTys = snd $ args !! dcI + argTy = argTys !! fI + argSize = typeSize argTy + other = otherSize argTys (fI-1) + start = typeSize ty - 1 - conSize ty - other + end = start - argSize + 1 + +modifier offset (Indexed (ty@(Product _ argTys),_,fI)) = Just (start+offset,end+offset) + where + argTy = argTys !! fI + argSize = typeSize argTy + otherSz = otherSize argTys (fI - 1) + start = typeSize ty - 1 - otherSz + end = start - argSize + 1 + +modifier offset (Indexed (ty@(Clock _ _ Gated),_,fI)) = Just (start+offset,end+offset) + where + argTys = [Bit, Bool] + argTy = argTys !! fI + argSize = typeSize argTy + otherSz = otherSize argTys (fI - 1) + start = typeSize ty - 1 - otherSz + end = start - argSize + 1 + +modifier offset (Indexed (ty@(Vector _ argTy),1,0)) = Just (start+offset,end+offset) + where + argSize = typeSize argTy + start = typeSize ty - 1 + end = start - argSize + 1 + +modifier offset (Indexed (ty@(Vector _ argTy),1,1)) = Just (start+offset,offset) + where + argSize = typeSize argTy + start = typeSize ty - argSize - 1 + +modifier offset (Indexed (ty@(RTree 0 _),0,0)) = Just (start+offset,offset) + where + start = typeSize ty - 1 + +modifier offset (Indexed (ty@(RTree _ _),1,0)) = Just (start+offset,end+offset) + where + start = typeSize ty - 1 + end = typeSize ty `div` 2 + +modifier offset (Indexed (ty@(RTree _ _),1,1)) = Just (start+offset,offset) + where + start = (typeSize ty `div` 2) - 1 + +-- This is a HACK for Clash.Driver.TopWrapper.mkOutput +-- Vector's don't have a 10'th constructor, this is just so that we can +-- recognize the particular case +modifier offset (Indexed (ty@(Vector _ argTy),10,fI)) = Just (start+offset,end+offset) + where + argSize = typeSize argTy + start = typeSize ty - (fI * argSize) - 1 + end = start - argSize + 1 + +-- This is a HACK for Clash.Driver.TopWrapper.mkOutput +-- RTree's don't have a 10'th constructor, this is just so that we can +-- recognize the particular case +modifier offset (Indexed (ty@(RTree _ argTy),10,fI)) = Just (start+offset,end+offset) + where + argSize = typeSize argTy + start = typeSize ty - (fI * argSize) - 1 + end = start - argSize + 1 + +modifier offset (DC (ty@(SP _ _),_)) = Just (start+offset,end+offset) + where + start = typeSize ty - 1 + end = typeSize ty - conSize ty + +modifier offset (Nested m1 m2) = do + case modifier offset m1 of + Nothing -> modifier offset m2 + Just (s,e) -> case modifier e m2 of + -- In case the second modifier is `Nothing` that means we want the entire + -- thing calculated by the first modifier + Nothing -> Just (s,e) + m -> m + +modifier _ _ = Nothing + +-- | Turn a Netlist expression into a SystemVerilog expression +expr_ :: Bool -- ^ Enclose in parenthesis? + -> Expr -- ^ Expr to convert + -> VerilogM Doc +expr_ _ (Literal sizeM lit) = exprLit sizeM lit + +expr_ _ (Identifier id_ Nothing) = string id_ + +expr_ _ (Identifier id_ (Just m)) = case modifier 0 m of + Nothing -> string id_ + Just (start,end) -> string id_ <> brackets (int start <> colon <> int end) + +expr_ b (DataCon _ (DC (Void {}, -1)) [e]) = expr_ b e + +expr_ _ (DataCon ty@(Vector 0 _) _ _) = verilogTypeErrValue ty + +expr_ _ (DataCon (Vector 1 _) _ [e]) = expr_ False e +expr_ _ e@(DataCon (Vector _ _) _ es@[_,_]) = + case vectorChain e of + Just es' -> listBraces (mapM (expr_ False) es') + Nothing -> listBraces (mapM (expr_ False) es) + +expr_ _ (DataCon (RTree 0 _) _ [e]) = expr_ False e +expr_ _ e@(DataCon (RTree _ _) _ es@[_,_]) = + case rtreeChain e of + Just es' -> listBraces (mapM (expr_ False) es') + Nothing -> listBraces (mapM (expr_ False) es) + +expr_ _ (DataCon ty@(SP _ args) (DC (_,i)) es) = assignExpr + where + argTys = snd $ args !! i + dcSize = conSize ty + sum (map typeSize argTys) + dcExpr = expr_ False (dcToExpr ty i) + argExprs = map (expr_ False) es + extraArg = case typeSize ty - dcSize of + 0 -> [] + n -> [int n <> "'b" <> bits (replicate n U)] + assignExpr = braces (hcat $ punctuate comma $ sequence (dcExpr:argExprs ++ extraArg)) + +expr_ _ (DataCon ty@(Sum _ _) (DC (_,i)) []) = int (typeSize ty) <> "'d" <> int i + +expr_ _ (DataCon (Product _ _) _ es) = listBraces (mapM (expr_ False) es) + +expr_ _ (DataCon (Clock _ _ Gated) _ es) = listBraces (mapM (expr_ False) es) + +expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) + | pNm == "Clash.Sized.Internal.Signed.fromInteger#" + , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx + = exprLit (Just (Signed (fromInteger n),fromInteger n)) i + +expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) + | pNm == "Clash.Sized.Internal.Unsigned.fromInteger#" + , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx + = exprLit (Just (Unsigned (fromInteger n),fromInteger n)) i + +expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) + | pNm == "Clash.Sized.Internal.BitVector.fromInteger#" + , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx + = exprLit (Just (BitVector (fromInteger n),fromInteger n)) i + +expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) + | pNm == "Clash.Sized.Internal.BitVector.fromInteger##" + , [Literal _ i] <- extractLiterals bbCtx + = exprLit (Just (Bit,1)) i + +expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) + | pNm == "Clash.Sized.Internal.Index.fromInteger#" + , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx + = exprLit (Just (Index (fromInteger n),fromInteger n)) i + +expr_ b (BlackBoxE _ libs imps inc bs bbCtx b') = do + parenIf (b || b') (Mon (renderBlackBox libs imps inc bs bbCtx <*> pure 0)) + +expr_ _ (DataTag Bool (Left id_)) = string id_ <> brackets (int 0) +expr_ _ (DataTag Bool (Right id_)) = do + iw <- Mon (use intWidth) + "$unsigned" <> parens (listBraces (sequence [braces (int (iw-1) <+> braces "1'b0"),string id_])) + +expr_ _ (DataTag (Sum _ _) (Left id_)) = "$unsigned" <> parens (string id_) +expr_ _ (DataTag (Sum _ _) (Right id_)) = "$unsigned" <> parens (string id_) + +expr_ _ (DataTag (Product _ _) (Right _)) = do + iw <- Mon (use intWidth) + int iw <> "'sd0" + +expr_ _ (DataTag hty@(SP _ _) (Right id_)) = "$unsigned" <> parens + (string id_ <> brackets + (int start <> colon <> int end)) + where + start = typeSize hty - 1 + end = typeSize hty - conSize hty + +expr_ _ (DataTag (Vector 0 _) (Right _)) = do + iw <- Mon $ use intWidth + int iw <> "'sd0" +expr_ _ (DataTag (Vector _ _) (Right _)) = do + iw <- Mon $ use intWidth + int iw <> "'sd1" + +expr_ _ (DataTag (RTree 0 _) (Right _)) = do + iw <- Mon $ use intWidth + int iw <> "'sd0" +expr_ _ (DataTag (RTree _ _) (Right _)) = do + iw <- Mon $ use intWidth + int iw <> "'sd1" + +expr_ b (ConvBV _ _ _ e) = expr_ b e + +expr_ _ e = error $ $(curLoc) ++ (show e) -- empty + +otherSize :: [HWType] -> Int -> Int +otherSize _ n | n < 0 = 0 +otherSize [] _ = 0 +otherSize (a:as) n = typeSize a + otherSize as (n-1) + +vectorChain :: Expr -> Maybe [Expr] +vectorChain (DataCon (Vector 0 _) _ _) = Just [] +vectorChain (DataCon (Vector 1 _) _ [e]) = Just [e] +vectorChain (DataCon (Vector _ _) _ [e1,e2]) = Just e1 <:> vectorChain e2 +vectorChain _ = Nothing + +rtreeChain :: Expr -> Maybe [Expr] +rtreeChain (DataCon (RTree 0 _) _ [e]) = Just [e] +rtreeChain (DataCon (RTree _ _) _ [e1,e2]) = Just e1 <:> rtreeChain e2 +rtreeChain _ = Nothing + +exprLit :: Maybe (HWType,Size) -> Literal -> VerilogM Doc +exprLit Nothing (NumLit i) = integer i + +exprLit (Just (hty,sz)) (NumLit i) = case hty of + Unsigned _ -> int sz <> "'d" <> integer i + Index _ -> int (typeSize hty) <> "'d" <> integer i + Signed _ + | i < 0 -> "-" <> int sz <> "'sd" <> integer (abs i) + | otherwise -> int sz <> "'sd" <> integer i + _ -> int sz <> "'b" <> blit + where + blit = bits (toBits sz i) +exprLit _ (BoolLit t) = if t then "1'b1" else "1'b0" +exprLit _ (BitLit b) = "1'b" <> bit_char b +exprLit _ (StringLit s) = string . pack $ show s +exprLit _ l = error $ $(curLoc) ++ "exprLit: " ++ show l + +toBits :: Integral a => Int -> a -> [Bit] +toBits size val = map (\x -> if odd x then H else L) + $ reverse + $ take size + $ map (`mod` 2) + $ iterate (`div` 2) val + +bits :: [Bit] -> VerilogM Doc +bits = hcat . mapM bit_char + +bit_char :: Bit -> VerilogM Doc +bit_char H = char '1' +bit_char L = char '0' +bit_char U = char 'x' +bit_char Z = char 'z' + +dcToExpr :: HWType -> Int -> Expr +dcToExpr ty i = Literal (Just (ty,conSize ty)) (NumLit (toInteger i)) + +listBraces :: Monad m => m [Doc] -> m Doc +listBraces = align . encloseSep lbrace rbrace comma + +parenIf :: Monad m => Bool -> m Doc -> m Doc +parenIf True = parens +parenIf False = id + +punctuate' :: Monad m => Mon m Doc -> Mon m [Doc] -> Mon m Doc +punctuate' s d = vcat (punctuate s d) <> s + +encodingNote :: HWType -> VerilogM Doc +encodingNote (Clock _ _ Gated) = "// gated clock" +encodingNote (Clock {}) = "// clock" +encodingNote (Reset {}) = "// asynchronous reset: active high" +encodingNote _ = emptyDoc diff --git a/src/Clash/Core/DataCon.hs b/src/Clash/Core/DataCon.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Core/DataCon.hs @@ -0,0 +1,121 @@ +{-| + Copyright : (C) 2012-2016, University of Twente, + 2017, Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Data Constructors in CoreHW +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} + +module Clash.Core.DataCon + ( DataCon (..) + , DcName + , ConTag + , dataConInstArgTys + ) +where + +#ifndef MIN_VERSION_unbound_generics +#define MIN_VERSION_unbound_generics(x,y,z)(1) +#endif + +import Control.DeepSeq (NFData(..)) +import Data.Hashable (Hashable) +import GHC.Generics (Generic) +import Unbound.Generics.LocallyNameless (Alpha(..),Subst(..)) +import Unbound.Generics.LocallyNameless.Extra () +#if MIN_VERSION_unbound_generics(0,3,0) +import Data.Monoid (All (..)) +import Unbound.Generics.LocallyNameless (NthPatFind (..), + NamePatFind (..)) +#endif + +import Clash.Core.Name (Name (..)) +import {-# SOURCE #-} Clash.Core.Type (TyName, Type) +import Clash.Util + +-- | Data Constructor +data DataCon + = MkData + { dcName :: !DcName -- ^ Name of the DataCon + , dcTag :: !ConTag -- ^ Syntactical position in the type definition + , dcType :: !Type -- ^ Type of the 'DataCon + , dcUnivTyVars :: [TyName] -- ^ Universally quantified type-variables, + -- these type variables are also part of the + -- result type of the DataCon + , dcExtTyVars :: [TyName] -- ^ Existentially quantified type-variables, + -- these type variables are not part of the result + -- of the DataCon, but only of the arguments. + , dcArgTys :: [Type] -- ^ Argument types + } deriving (Generic,NFData,Hashable) + +instance Show DataCon where + show = show . dcName + +instance Eq DataCon where + (==) = (==) `on` dcName + +instance Ord DataCon where + compare = compare `on` dcName + +-- | Syntactical position of the DataCon in the type definition +type ConTag = Int +-- | DataCon reference +type DcName = Name DataCon + +instance Alpha DataCon where + aeq' c dc1 dc2 = aeq' c (dcName dc1) (dcName dc2) + + fvAny' _ _ dc = pure dc + + close _ _ dc = dc + open _ _ dc = dc + + isPat _ = mempty + +#if MIN_VERSION_unbound_generics(0,3,0) + isTerm _ = All True + nthPatFind _ = NthPatFind Left + namePatFind _ = NamePatFind (const (Left 0)) +#else + isTerm _ = True + nthPatFind _ = Left + namePatFind _ _ = Left 0 +#endif + + swaps' _ _ dc = dc + lfreshen' _ dc cont = cont dc mempty + freshen' _ dc = return (dc,mempty) + + acompare' c dc1 dc2 = acompare' c (dcName dc1) (dcName dc2) + +instance Subst a DataCon where + subst _ _ dc = dc + substs _ dc = dc + +-- | Given a DataCon and a list of types, the type variables of the DataCon +-- type are substituted for the list of types. The argument types are returned. +-- +-- The list of types should be equal to the number of type variables, otherwise +-- @Nothing@ is returned. +dataConInstArgTys :: DataCon -> [Type] -> Maybe [Type] +dataConInstArgTys (MkData { dcArgTys = arg_tys + , dcUnivTyVars = univ_tvs + , dcExtTyVars = ex_tvs + }) + inst_tys + | length tyvars == length inst_tys + = Just (map (substs (zip tyvars inst_tys)) arg_tys) + + | otherwise + = Nothing + + where + tyvars = map nameOcc (univ_tvs ++ ex_tvs) diff --git a/src/Clash/Core/Evaluator.hs b/src/Clash/Core/Evaluator.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Core/Evaluator.hs @@ -0,0 +1,500 @@ +{-| + Copyright : (C) 2017, Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Call-by-need evaluator based on the evaluator described in: + + Maximilian Bolingbroke, Simon Peyton Jones, "Supercompilation by evaluation", + Haskell '10, Baltimore, Maryland, USA. + +-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +module Clash.Core.Evaluator where + +import Control.Arrow (second) +import Control.Concurrent.Supply (Supply, freshId) +import Data.Either (lefts,rights) +import qualified Data.HashMap.Lazy as HM +import Data.List + (foldl',mapAccumL,uncons) +import Data.Map + (Map,delete,fromList,insert,lookup,union) +import qualified Data.Map as M +import Data.Text (Text) +import Data.Text.Prettyprint.Doc (hsep) +import Debug.Trace (trace) +import Clash.Core.DataCon +import Clash.Core.Literal +import Clash.Core.Name +import Clash.Core.Pretty +import Clash.Core.Subst +import Clash.Core.Term +import Clash.Core.TyCon +import Clash.Core.Type +import Clash.Core.Util +import Clash.Core.Var +import Clash.Driver.Types (BindingMap) +import Prelude hiding (lookup) +import Clash.Util (curLoc) +import Unbound.Generics.LocallyNameless as Unbound +import Unbound.Generics.LocallyNameless.Unsafe + +-- | The heap +data Heap = Heap PureHeap Supply + deriving (Show) + +type PureHeap = Map TmOccName Term + +-- | The stack +type Stack = [StackFrame] + +data StackFrame + = Update Id + | Apply Id + | Instantiate Type + | PrimApply Text Type [Type] [Value] [Term] + | Scrutinise Type [Alt] + deriving Show + +instance Pretty StackFrame where + pprPrec _ (Update i) = do + i' <- ppr i + pure (hsep ["Update", i']) + pprPrec _ (Apply i) = do + i' <- ppr i + pure (hsep ["Apply", i']) + pprPrec _ (Instantiate t) = do + t' <- ppr t + pure (hsep ["Instantiate", t']) + pprPrec _ (PrimApply a b c d e) = do + a' <- ppr a + b' <- ppr b + c' <- ppr c + d' <- ppr (map valToTerm d) + e' <- ppr e + pure $ hsep ["PrimApply", a', "::", b', + "; type args=", c', + "; val args=", d', + "term args=", e'] + pprPrec _ (Scrutinise a b) = do + a' <- ppr a + b' <- ppr (Case (Literal (CharLiteral '_')) a b) + pure $ hsep ["Scrutinise ", a', b'] + +-- Values +data Value + = Lambda (Bind Id Term) + -- ^ Functions + | TyLambda (Bind TyVar Term) + -- ^ Type abstractions + | DC DataCon [Either Term Type] + -- ^ Data constructors + | Lit Literal + -- ^ Literals + | PrimVal Text Type [Type] [Value] + -- ^ Clash's number types are represented by their "fromInteger#" primitive + -- function. So some primitives are values. + deriving Show + +-- | State of the evaluator +type State = (Heap, Stack, Term) + +-- | Function that can evaluator primitives, i.e., perform delta-reduction +type PrimEvaluator = + Bool -> -- Force special primitives? See [Note: forcing special primitives] + BindingMap -> -- Global binders + TyConMap -> -- Type constructors + Heap -> + Stack -> + Text -> -- Name of the primitive + Type -> -- Type of the primitive + [Type] -> -- Type arguments of the primitive + [Value] -> -- Value arguments of the primitive + Maybe State -- Delta-reduction can get stuck, so Nothing is an option + +-- | Evaluate to WHNF starting with an empty Heap and Stack +whnf' + :: PrimEvaluator + -> BindingMap + -> TyConMap + -> Supply + -> Bool + -> Term + -> Term +whnf' eval gbl tcm ids isSubj e + = case whnf eval gbl tcm isSubj (Heap (fromList []) ids,[],e) of + (_,_,e') -> e' + +-- | Evaluate to WHNF given an existing Heap and Stack +whnf + :: PrimEvaluator + -> BindingMap + -> TyConMap + -> Bool + -> State + -> State +whnf eval gbl tcm isSubj (h,k,e) = + if isSubj + then go (h,Scrutinise ty []:k,e) -- See [Note: empty case expressions] + else go (h,k,e) + where + ty = runFreshM $ termType tcm e + + go s = case step eval gbl tcm s of + Just s' -> go s' + Nothing + | Just e' <- unwindStack s + -> e' + | otherwise + -> error $ showDoc e + +-- | Are we in a context where special primitives must be forced. +-- +-- See [Note: forcing special primitives] +isScrut :: Stack -> Bool +isScrut (Scrutinise {}:_) = True +isScrut (PrimApply {} :_) = True +isScrut _ = False + +-- | Completely unwind the stack to get back the complete term +unwindStack :: State -> Maybe State +unwindStack s@(_,[],_) = Just s +unwindStack (h@(Heap h' _),(kf:k'),e) = case kf of + PrimApply nm ty tys vs tms -> + unwindStack + (h,k' + ,foldl' App + (foldl' App (foldl' TyApp (Prim nm ty) tys) (map valToTerm vs)) + (e:tms)) + Instantiate ty -> + unwindStack (h,k',TyApp e ty) + Apply id_ -> do + case lookup (nameOcc (varName id_)) h' of + Just e' -> unwindStack (h,k',App e e') + Nothing -> error $ unlines + $ [ "Clash.Core.Evaluator.unwindStack:" + , "Stack:" + ] ++ + [ " "++showDoc frame | frame <- kf:k'] ++ + [ "" + , "Expression:" + , showDoc e + , "" + , "Heap:" + ] ++ + [ " "++show name ++ " === " ++ showDoc value + | (name,value) <- M.toList h' + ] + Scrutinise _ [] -> + unwindStack (h,k',e) + Scrutinise ty alts -> + unwindStack (h,k',Case e ty alts) + Update _ -> + unwindStack (h,k',e) + +{- [Note: forcing special primitives] +Clash uses the `whnf` function in two places (for now): + + 1. The case-of-known-constructor transformation + 2. The reduceConstant transformation + +The first transformation is needed to reach the required normal form. The +second transformation is more of cleanup transformation, so non-essential. + +Normally, `whnf` would force the evaluation of all primitives, which is needed +in the `case-of-known-constructor` transformation. However, there are some +primitives which we want to leave unevaluated in the `reduceConstant` +transformation. Such primitives are: + + - Primitives such as `Clash.Sized.Vector.transpose`, `Clash.Sized.Vector.map`, + etc. that do not reduce to an expression in normal form. Where the + `reduceConstant` transformation is supposed to be normal-form preserving. + - Primitives such as `GHC.Int.I8#`, `GHC.Word.W32#`, etc. which seem like + wrappers around a 64-bit literal, but actually perform truncation to the + desired bit-size. + +This is why the Primitive Evaluator gets a flag telling whether it should +evaluate these special primitives. +-} + +-- | Small-step operational semantics. +step + :: PrimEvaluator + -> BindingMap + -> TyConMap + -> State + -> Maybe State +step eval gbl tcm (h, k, e) = case e of + Var ty nm -> force gbl h k (Id nm (embed ty)) + (Lam b) -> unwind eval gbl tcm h k (Lambda b) + (TyLam b) -> unwind eval gbl tcm h k (TyLambda b) + (Literal l) -> unwind eval gbl tcm h k (Lit l) + (App e1 e2) + | (Data dc,args) <- collectArgs e + , (tys,_) <- splitFunForallTy (dcType dc) + -> case compare (length args) (length tys) of + EQ -> unwind eval gbl tcm h k (DC dc args) + LT -> let (h2,e') = mkAbstr (h,e) (drop (length args) tys) + in step eval gbl tcm (h2,k,e') + GT -> error "Overapplied DC" + | (Prim nm ty,args) <- collectArgs e + , (tys,_) <- splitFunForallTy ty + -> case compare (length args) (length tys) of + EQ -> let (e':es) = lefts args + in Just (h,PrimApply nm ty (rights args) [] es:k,e') + LT -> let (h2,e') = mkAbstr (h,e) (drop (length args) tys) + in step eval gbl tcm (h2,k,e') + GT -> let (h2,id_) = newLetBinding tcm h e2 + in Just (h2,Apply id_:k,e1) + (TyApp e1 ty) + | (Data dc,args) <- collectArgs e + , (tys,_) <- splitFunForallTy (dcType dc) + -> case compare (length args) (length tys) of + EQ -> unwind eval gbl tcm h k (DC dc args) + LT -> let (h2,e') = mkAbstr (h,e) (drop (length args) tys) + in step eval gbl tcm (h2,k,e') + GT -> error "Overapplied DC" + | (Prim nm ty',args) <- collectArgs e + , (tys,_) <- splitFunForallTy ty' + -> case compare (length args) (length tys) of + EQ -> case lefts args of + [] | nm `elem` ["Clash.Transformations.removedArg"] + -- The above primitives are actually values, and not operations. + -> unwind eval gbl tcm h k (PrimVal nm ty' (rights args) []) + | otherwise + -> eval (isScrut k) gbl tcm h k nm ty' (rights args) [] + (e':es) -> Just (h,PrimApply nm ty' (rights args) [] es:k,e') + LT -> let (h2,e') = mkAbstr (h,e) (drop (length args) tys) + in step eval gbl tcm (h2,k,e') + GT -> Just (h,Instantiate ty:k,e1) + (Data dc) -> unwind eval gbl tcm h k (DC dc []) + (Prim nm ty') -> eval (isScrut k) gbl tcm h k nm ty' [] [] + (App e1 e2) -> let (h2,id_) = newLetBinding tcm h e2 + in Just (h2,Apply id_:k,e1) + (TyApp e1 ty) -> Just (h,Instantiate ty:k,e1) + (Case scrut ty alts) -> Just (h,Scrutinise ty alts:k,scrut) + (Letrec bs) -> Just (allocate h k bs) + Cast _ _ _ -> trace (unlines ["WARNING: " ++ $(curLoc) ++ "Clash currently can't symbolically evaluate casts" + ,"If you have testcase that produces this message, please open an issue about it."]) Nothing + +newLetBinding + :: TyConMap + -> Heap + -> Term + -> (Heap,Id) +newLetBinding tcm h@(Heap h' ids) e + | Var ty' nm' <- e + , Just _ <- lookup (nameOcc nm') h' + = (h, Id nm' (embed ty')) + | otherwise + = (Heap (insert (nameOcc nm) e h') ids',Id nm (embed ty)) + where + (i,ids') = freshId ids + nm = makeSystemName "x" (toInteger i) + ty = runFreshM (termType tcm e) + +newLetBindings' + :: TyConMap + -> Heap + -> [Either Term Type] + -> (Heap,[Either Term Type]) +newLetBindings' tcm = + (second (map (either (Left . toVar) (Right . id))) .) . mapAccumL go + where + go h (Left tm) = second Left (newLetBinding tcm h tm) + go h (Right ty) = (h,Right ty) + +mkAbstr + :: (Heap,Term) + -> [Either TyVar Type] + -> (Heap,Term) +mkAbstr = foldr go + where + go (Left tv) (h,e) = + (h,TyLam (bind tv (TyApp e (VarTy (unembed (varKind tv)) (varName tv))))) + go (Right ty) (Heap h ids,e) = + let (i,ids') = freshId ids + nm = makeSystemName "x" (toInteger i) + id_ = Id nm (embed ty) + in (Heap h ids',Lam (bind id_ (App e (Var ty nm)))) + +-- | Force the evaluation of a variable. +force :: BindingMap -> Heap -> Stack -> Id -> Maybe State +force gbl (Heap h ids) k x' = case lookup nm h of + Nothing -> case HM.lookup nm gbl of + Nothing -> Nothing + Just (_,_,_,_,e) -> Just (Heap h ids,k,e) + Just e -> Just (Heap (delete nm h) ids,Update x':k,e) + -- Removing the heap-bound value on a force ensures we do not get stuck on + -- expressions such as: "let x = x in x" + where + nm = nameOcc (varName x') + +-- | Unwind the stack by 1 +unwind + :: PrimEvaluator + -> BindingMap + -> TyConMap + -> Heap -> Stack -> Value -> Maybe State +unwind eval gbl tcm h k v = do + (kf,k') <- uncons k + case kf of + Update x -> return (update h k' x v) + Apply x -> return (apply h k' v x) + Instantiate ty -> return (instantiate h k' v ty) + PrimApply nm ty tys vals tms -> primop eval gbl tcm h k' nm ty tys vals v tms + Scrutinise _ alts -> return (scrutinise h k' v alts) + +-- | Update the Heap with the evaluated term +update :: Heap -> Stack -> Id -> Value -> State +update (Heap h ids) k x v = (Heap (insert (nameOcc (varName x)) v' h) ids,k,v') + where + v' = valToTerm v + +valToTerm :: Value -> Term +valToTerm v = case v of + Lambda b -> Lam b + TyLambda b -> TyLam b + DC dc pxs -> foldl' (\e a -> either (App e) (TyApp e) a) + (Data dc) pxs + Lit l -> Literal l + PrimVal nm ty tys vs -> foldl' App (foldl' TyApp (Prim nm ty) tys) + (map valToTerm vs) + +toVar :: Id -> Term +toVar x = Var (unembed (varType x)) (varName x) + +toType :: TyVar -> Type +toType x = VarTy (unembed (varKind x)) (varName x) + +-- | Apply a value to a function +apply :: Heap -> Stack -> Value -> Id -> State +apply h k (Lambda b) x = (h,k,subst nm (toVar x) e) + where + (x',e) = unsafeUnbind b + nm = nameOcc (varName x') +apply _ _ _ _ = error "not a lambda" + +-- | Instantiate a type-abstraction +instantiate :: Heap -> Stack -> Value -> Type -> State +instantiate h k (TyLambda b) ty = (h,k,subst nm ty e) + where + (x,e) = unsafeUnbind b + nm = nameOcc (varName x) +instantiate _ _ _ _ = error "not a ty lambda" + +-- | Evaluation of primitive operations +primop + :: PrimEvaluator + -> BindingMap + -> TyConMap + -> Heap + -> Stack + -> Text + -- ^ Name of the primitive + -> Type + -- ^ Type of the primitive + -> [Type] + -- ^ Applied types + -> [Value] + -- ^ Applied values + -> Value + -- ^ The current value + -> [Term] + -- ^ The remaining terms which must be evaluated to a value + -> Maybe State +primop eval gbl tcm h k nm ty tys vs v [] + | nm `elem` ["Clash.Sized.Internal.BitVector.fromInteger#" + ,"Clash.Sized.Internal.BitVector.fromInteger##" + ,"Clash.Sized.Internal.Index.fromInteger#" + ,"Clash.Sized.Internal.Signed.fromInteger#" + ,"Clash.Sized.Internal.Unsigned.fromInteger#" + ,"GHC.CString.unpackCString#" + ,"Clash.Transformations.removedArg" + ] + -- The above primitives are actually values, and not operations. + = unwind eval gbl tcm h k (PrimVal nm ty tys (vs ++ [v])) + | otherwise = eval (isScrut k) gbl tcm h k nm ty tys (vs ++ [v]) +primop _ _ _ h k nm ty tys vs v (e:es) = + Just (h,PrimApply nm ty tys (vs ++ [v]) es:k,e) + +-- | Evaluate a case-expression +scrutinise :: Heap -> Stack -> Value -> [Alt] -> State +scrutinise h k (Lit l) (map unsafeUnbind -> alts) + | altE:_ <- + [altE | (LitPat (unembed -> altL),altE) <- alts, altL == l ] ++ + [altE | (DataPat (unembed -> altDc) _,altE) <- alts, matchLit altDc l ] ++ + [altE | (DefaultPat,altE) <- alts ] + = (h,k,altE) +scrutinise h k (DC dc xs) (map unsafeUnbind -> alts) + | altE:_ <- [substAlt altDc pxs xs altE + | (DataPat (unembed -> altDc) pxs,altE) <- alts, altDc == dc ] ++ + [altE | (DefaultPat,altE) <- alts ] + = (h,k,altE) +scrutinise h k v [] = (h,k,valToTerm v) +-- [Note: empty case expressions] +-- +-- Clash does not have empty case-expressions; instead, empty case-expressions +-- are used to indicate that the `whnf` function was called the context of a +-- case-expression, which means certain special primitives must be forced. +-- See also [Note: forcing special primitives] +scrutinise _ _ _ _ = error "scrutinise" + +matchLit :: DataCon -> Literal -> Bool +matchLit dc (IntegerLiteral l) + | dcTag dc == 1 + = l < 2^(63::Int) +matchLit dc (NaturalLiteral l) + | dcTag dc == 1 + = l < 2^(64::Int) +matchLit _ _ = False + +substAlt :: DataCon -> Rebind [TyVar] [Id] -> [Either Term Type] -> Term -> Term +substAlt dc pxs args e = + let (tvs,xs) = unrebind pxs + substTyMap = zip (map (nameOcc.varName) tvs) + (drop (length (dcUnivTyVars dc)) (rights args)) + substTmMap = zip (map (nameOcc.varName) xs) (lefts args) + in substTysinTm substTyMap (substTms substTmMap e) + +-- | Allocate let-bindings on the heap +allocate :: Heap -> Stack -> (Bind (Rec [LetBinding]) Term) -> State +allocate (Heap h ids) k b = + (Heap (h `union` fromList xes') ids',k,e') + where + (xesR,e) = unsafeUnbind b + xes = unrec xesR + (ids',s) = mapAccumL (letSubst h) ids (map fst xes) + (nms,s') = unzip s + xes' = zip nms (map (substTms s' . unembed . snd) xes) + e' = substTms s' e + +-- | Create a unique name and substitution for a let-binder +letSubst + :: PureHeap + -> Supply + -> Id + -> ( Supply + , (TmOccName,(TmOccName,Term))) +letSubst h acc id_ = + let nm = nameOcc (varName id_) + (acc',nm') = uniqueInHeap h acc nm + in (acc',(nameOcc nm',(nm,Var (unembed (varType id_)) nm'))) + +-- | Create a name that's unique in the heap +uniqueInHeap + :: PureHeap + -> Supply + -> TmOccName + -> (Supply, TmName) +uniqueInHeap h ids nm = + let (i,ids') = freshId ids + nm' = makeSystemName (Unbound.name2String nm) (toInteger i) + in case nameOcc nm' `M.member` h of + True -> uniqueInHeap h ids' nm + _ -> (ids',nm') diff --git a/src/Clash/Core/FreeVars.hs b/src/Clash/Core/FreeVars.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Core/FreeVars.hs @@ -0,0 +1,27 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Free variable calculations +-} + +module Clash.Core.FreeVars where + +import Control.Lens.Fold (Fold) +import Unbound.Generics.LocallyNameless (fv) + +import Clash.Core.Term (Term, TmOccName) +import Clash.Core.Type (TyOccName, Type) + +-- | Gives the free type-variables in a Type +typeFreeVars :: Fold Type TyOccName +typeFreeVars = fv + +-- | Gives the free term-variables of a Term +termFreeIds :: Fold Term TmOccName +termFreeIds = fv + +-- | Gives the free type-variables of a Term +termFreeTyVars :: Fold Term TyOccName +termFreeTyVars = fv diff --git a/src/Clash/Core/Literal.hs b/src/Clash/Core/Literal.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Core/Literal.hs @@ -0,0 +1,69 @@ +{-| + Copyright : (C) 2012-2016, University of Twente, + 2016 , Myrtle Software Ltd, + 2017 , Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Term Literal +-} + +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Clash.Core.Literal + ( Literal (..) + , literalType + ) +where + +import Control.DeepSeq (NFData (..)) +import Data.Hashable (Hashable) +import GHC.Generics (Generic) +import Unbound.Generics.LocallyNameless.Extra () +import Unbound.Generics.LocallyNameless (Alpha (..), Subst (..)) + +import {-# SOURCE #-} Clash.Core.Type (Type) +import Clash.Core.TysPrim (intPrimTy, integerPrimTy, + charPrimTy, stringPrimTy, + wordPrimTy, + int64PrimTy, word64PrimTy, + floatPrimTy, doublePrimTy, + naturalPrimTy) + +-- | Term Literal +data Literal + = IntegerLiteral !Integer + | IntLiteral !Integer + | WordLiteral !Integer + | Int64Literal !Integer + | Word64Literal !Integer + | StringLiteral !String + | FloatLiteral !Rational + | DoubleLiteral !Rational + | CharLiteral !Char + | NaturalLiteral !Integer + deriving (Eq,Ord,Show,Generic,NFData,Hashable) + +instance Alpha Literal where + fvAny' _ _ l = pure l + +instance Subst a Literal where + subst _ _ l = l + substs _ l = l + +-- | Determines the Type of a Literal +literalType :: Literal + -> Type +literalType (IntegerLiteral _) = integerPrimTy +literalType (IntLiteral _) = intPrimTy +literalType (WordLiteral _) = wordPrimTy +literalType (StringLiteral _) = stringPrimTy +literalType (FloatLiteral _) = floatPrimTy +literalType (DoubleLiteral _) = doublePrimTy +literalType (CharLiteral _) = charPrimTy +literalType (Int64Literal _) = int64PrimTy +literalType (Word64Literal _) = word64PrimTy +literalType (NaturalLiteral _) = naturalPrimTy diff --git a/src/Clash/Core/Name.hs b/src/Clash/Core/Name.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Core/Name.hs @@ -0,0 +1,99 @@ +{-| + Copyright : (C) 2017, Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Names +-} + +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} + +module Clash.Core.Name + ( module Clash.Core.Name + , noSrcSpan + ) +where + +import Control.DeepSeq (NFData) +import Data.Function (on) +import Data.Hashable (Hashable) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import GHC.SrcLoc.Extra () +import Unbound.Generics.LocallyNameless hiding + (Name, name2String, string2Name) +import qualified Unbound.Generics.LocallyNameless as Unbound +import qualified Unbound.Generics.LocallyNameless.Name as Unbound +import Unbound.Generics.LocallyNameless.TH +import Unbound.Generics.LocallyNameless.Extra () +import SrcLoc (SrcSpan, noSrcSpan) + +data Name a + = Name + { nameSort :: NameSort + , nameOcc :: OccName a + , nameLoc :: !SrcSpan + } + deriving (Show,Generic,NFData,Hashable) + +instance Eq (Name a) where + (==) = (==) `on` nameOcc + +instance Ord (Name a) where + compare = compare `on` nameOcc + +type OccName a = Unbound.Name a + +data NameSort + = User + | System + | Internal + deriving (Eq,Ord,Show,Generic,NFData,Hashable) + +instance Typeable a => Alpha (Name a) where + aeq' ctx (Name _ nm1 _) (Name _ nm2 _) = aeq' ctx nm1 nm2 + acompare' ctx (Name _ nm1 _) (Name _ nm2 _) = acompare' ctx nm1 nm2 + +makeClosedAlpha ''NameSort + +instance Subst b (Name a) where subst _ _ = id; substs _ = id + +name2String :: Name a -> String +name2String = Unbound.name2String . nameOcc +{-# INLINE name2String #-} + +name2Integer :: Name a -> Integer +name2Integer = Unbound.name2Integer . nameOcc + +string2OccName :: String -> OccName a +string2OccName = Unbound.string2Name +{-# INLINE string2OccName #-} + +string2SystemName :: String -> Name a +string2SystemName nm = Name System (string2OccName nm) noSrcSpan + +string2InternalName :: String -> Name a +string2InternalName nm = Name Internal (string2OccName ('#':nm)) noSrcSpan + +makeOccName :: String -> Integer -> OccName a +makeOccName = Unbound.makeName + +makeSystemName :: String -> Integer -> Name a +makeSystemName s i = Name System (makeOccName s i) noSrcSpan + +coerceName :: Name a -> Name b +coerceName nm = nm {nameOcc = go (nameOcc nm)} + where + go (Unbound.Fn s i) = Unbound.Fn s i + go _ = error "Trying to coerce bound name" + +appendToName :: Name a -> String -> Name a +appendToName (Name sort nm loc) s = Name Internal nm' loc + where + n = Unbound.name2String nm + n' = case sort of {Internal -> n; _ -> '#':n} + nm' = Unbound.makeName (n' ++ s) (Unbound.name2Integer nm) diff --git a/src/Clash/Core/Pretty.hs b/src/Clash/Core/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Core/Pretty.hs @@ -0,0 +1,377 @@ +{-| + Copyright : (C) 2012-2016, University of Twente, + 2016 , Myrtle Software Ltd + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Pretty printing class and instances for CoreHW +-} + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +module Clash.Core.Pretty + ( Pretty (..) + , showDoc + ) +where + +import Data.Char (isSymbol, isUpper, ord) +import Data.Text (Text) +import Data.Text.Prettyprint.Doc hiding (Doc, Pretty) +import qualified Data.Text.Prettyprint.Doc as PP +import Data.Text.Prettyprint.Doc.Render.String +import GHC.Show (showMultiLineString) +import Numeric (fromRat) +import Unbound.Generics.LocallyNameless + (Embed (..), LFresh, lunbind, runLFreshM, unembed, unrebind, unrec) + +import Clash.Core.DataCon (DataCon (..)) +import Clash.Core.Literal (Literal (..)) +import Clash.Core.Name (Name (..), OccName, name2String) +import Clash.Core.Term (Pat (..), Term (..)) +import Clash.Core.TyCon (TyCon (..), TyConName, isTupleTyConLike) +import Clash.Core.Type (ConstTy (..), Kind, LitTy (..), + Type (..), TypeView (..), tyView) +import Clash.Core.Var (Id, TyVar, Var, varKind, varName, + varType) +import Clash.Util + +type Doc = PP.Doc () + +-- | Pretty printing Show-like typeclass +class Pretty p where + ppr :: LFresh m => p -> m Doc + ppr = pprPrec 0 + + pprPrec :: LFresh m => Rational -> p -> m Doc + +noPrec, opPrec, appPrec :: Num a => a +noPrec = 0 +opPrec = 1 +appPrec = 2 + +-- | Print a Pretty thing to a String +showDoc :: Pretty p => p -> String +showDoc = renderString . layoutPretty (LayoutOptions (AvailablePerLine 80 0.6)) . runLFreshM . ppr + +prettyParen :: Bool -> Doc -> Doc +prettyParen False = id +prettyParen True = parens + +instance Pretty (OccName a) where + pprPrec _ = return . PP.pretty . show + +instance Pretty (Name a) where + pprPrec p = pprPrec p . nameOcc + +instance Pretty a => Pretty [a] where + pprPrec prec xs = do + xs' <- mapM (pprPrec prec) xs + return $ vcat xs' + +instance Pretty (Id, Term) where + pprPrec _ = pprTopLevelBndr + +pprTopLevelBndr :: LFresh m => (Id,Term) -> m Doc +pprTopLevelBndr (bndr,expr) = do + bndr' <- ppr bndr + bndrName <- ppr (varName bndr) + expr' <- ppr expr + return $ bndr' <> line <> hang 2 (sep [(bndrName <+> equals), expr']) <> line + +dcolon :: Doc +dcolon = PP.pretty "::" + +rarrow :: Doc +rarrow = PP.pretty "->" + +instance Pretty Text where + pprPrec _ = pure . PP.pretty + +instance Pretty Type where + pprPrec _ = pprType + +instance Pretty (Var Type) where + pprPrec _ v = ppr $ varName v + +instance Pretty TyCon where + pprPrec _ tc = return . PP.pretty . name2String $ tyConName tc + +instance Pretty LitTy where + pprPrec _ (NumTy i) = return $ PP.pretty i + pprPrec _ (SymTy s) = return $ PP.pretty s + +instance Pretty Term where + pprPrec prec e = case e of + Var _ x -> pprPrec prec x + Data dc -> pprPrec prec dc + Literal l -> pprPrec prec l + Prim nm _ -> return $ PP.pretty nm + Lam b -> lunbind b $ \(v,e') -> pprPrecLam prec [v] e' + TyLam b -> lunbind b $ \(tv,e') -> pprPrecTyLam prec [tv] e' + App fun arg -> pprPrecApp prec fun arg + TyApp e' ty -> pprPrecTyApp prec e' ty + Letrec b -> lunbind b $ \(xes,e') -> pprPrecLetrec prec (unrec xes) e' + Case e' _ alts -> pprPrecCase prec e' =<< mapM (`lunbind` return) alts + Cast e' ty1 ty2-> pprPrecCast prec e' ty1 ty2 + +data BindingSite + = LambdaBind + | CaseBind + | LetBind + +instance Pretty (Var Term) where + pprPrec _ v = do + v' <- ppr (varName v) + ty' <- ppr (unembed $ varType v) + return $ v' <+> dcolon <+> ty' + +instance Pretty DataCon where + pprPrec _ dc = return . PP.pretty . name2String $ dcName dc + +instance Pretty Literal where + pprPrec _ l = case l of + IntegerLiteral i + | i < 0 -> return $ parens (PP.pretty i) + | otherwise -> return $ PP.pretty i + IntLiteral i + | i < 0 -> return $ parens (PP.pretty i) + | otherwise -> return $ PP.pretty i + Int64Literal i + | i < 0 -> return $ parens (PP.pretty i) + | otherwise -> return $ PP.pretty i + WordLiteral w -> return $ PP.pretty w + Word64Literal w -> return $ PP.pretty w + FloatLiteral r -> return $ PP.pretty (fromRat r :: Float) + DoubleLiteral r -> return $ PP.pretty (fromRat r :: Double) + CharLiteral c -> return $ PP.pretty c + StringLiteral s -> return $ vcat $ map PP.pretty $ showMultiLineString s + NaturalLiteral n -> return $ PP.pretty n + +instance Pretty Pat where + pprPrec prec pat = case pat of + DataPat dc pxs -> do + let (txs,xs) = unrebind pxs + dc' <- ppr (unembed dc) + txs' <- mapM (pprBndr LetBind) txs + xs' <- mapM (pprBndr CaseBind) xs + return $ prettyParen (prec >= appPrec) $ dc' <+> hsep txs' <> softline <> (nest 2 (vcat xs')) + LitPat l -> ppr (unembed l) + DefaultPat -> return $ PP.pretty '_' + +pprPrecLam :: LFresh m => Rational -> [Id] -> Term -> m Doc +pprPrecLam prec xs e = do + xs' <- mapM (pprBndr LambdaBind) xs + e' <- pprPrec noPrec e + return $ prettyParen (prec > noPrec) $ + PP.pretty 'λ' <> hsep xs' <+> rarrow <> line <> e' + +pprPrecTyLam :: LFresh m => Rational -> [TyVar] -> Term -> m Doc +pprPrecTyLam prec tvs e = do + tvs' <- mapM ppr tvs + e' <- pprPrec noPrec e + return $ prettyParen (prec > noPrec) $ + PP.pretty 'Λ' <> hsep tvs' <+> rarrow <> line <> e' + +pprPrecApp :: LFresh m => Rational -> Term -> Term -> m Doc +pprPrecApp prec e1 e2 = do + e1' <- pprPrec opPrec e1 + e2' <- pprPrec appPrec e2 + return $ prettyParen (prec >= appPrec) $ + hang 2 (vsep [e1',e2']) + +pprPrecTyApp :: LFresh m => Rational -> Term -> Type -> m Doc +pprPrecTyApp prec e ty = do + e' <- pprPrec opPrec e + ty' <- pprParendType ty + return $ prettyParen (prec >= appPrec) $ + hang 2 (sep [e', (PP.pretty '@' <> ty')]) + +-- TODO use more conventional cast operator (|> or ▷) ? +pprPrecCast :: LFresh m => Rational -> Term -> Type -> Type -> m Doc +pprPrecCast prec e ty1 ty2 = do + e' <- pprPrec appPrec e + ty1' <- pprType ty1 + ty2' <- pprType ty2 + return $ prettyParen (prec >= appPrec) $ + parens (PP.pretty "cast" <> softline <> nest 5 (vcat [dcolon <+> ty1', rarrow <+> ty2'])) + <> softline <> nest 2 e' + +pprPrecLetrec :: LFresh m => Rational -> [(Id, Embed Term)] -> Term -> m Doc +pprPrecLetrec prec xes body = do + body' <- pprPrec noPrec body + xes' <- mapM (\(x,e) -> do + x' <- pprBndr LetBind x + e' <- pprPrec noPrec (unembed e) + return $ x' <> line <> equals <+> e' + ) xes + let xes'' = case xes' of + [] -> [PP.pretty "EmptyLetrec"] + _ -> xes' + return $ prettyParen (prec > noPrec) $ + hang 2 (vcat ((PP.pretty "letrec"):xes'')) <> line <> PP.pretty "in" <+> body' + +pprPrecCase :: LFresh m => Rational -> Term -> [(Pat,Term)] -> m Doc +pprPrecCase prec e alts = do + e' <- pprPrec prec e + alts' <- mapM (pprPrecAlt noPrec) alts + return $ prettyParen (prec > noPrec) $ + hang 2 (vcat ((PP.pretty "case" <+> e' <+> PP.pretty "of"):alts')) + +pprPrecAlt :: LFresh m => Rational -> (Pat,Term) -> m Doc +pprPrecAlt _ (altPat, altE) = do + altPat' <- pprPrec noPrec altPat + altE' <- pprPrec noPrec altE + return $ hang 2 (vcat [(altPat' <+> rarrow), altE']) + +pprBndr :: (LFresh m, Pretty a) => BindingSite -> a -> m Doc +pprBndr bs x = prettyParen needsParen <$> ppr x + where + needsParen = case bs of + LambdaBind -> True + CaseBind -> True + LetBind -> False + +data TypePrec + = TopPrec + | FunPrec + | TyConPrec + deriving (Eq,Ord) + +maybeParen :: TypePrec -> TypePrec -> Doc -> Doc +maybeParen ctxt_prec inner_prec = prettyParen (ctxt_prec >= inner_prec) + +pprType :: LFresh m => Type -> m Doc +pprType = ppr_type TopPrec + +pprParendType :: LFresh m => Type -> m Doc +pprParendType = ppr_type TyConPrec + +ppr_type :: LFresh m => TypePrec -> Type -> m Doc +ppr_type _ (VarTy _ tv) = ppr tv +ppr_type _ (LitTy tyLit) = ppr tyLit +ppr_type p ty@(ForAllTy _) = pprForAllType p ty +ppr_type p (ConstTy (TyCon tc)) = pprTcApp p ppr_type tc [] +ppr_type p (tyView -> TyConApp tc args) = pprTcApp p ppr_type tc args +ppr_type p (tyView -> FunTy ty1 ty2) = pprArrowChain p <$> ppr_type FunPrec ty1 <:> pprFunTail ty2 + where + pprFunTail (tyView -> FunTy ty1' ty2') = ppr_type FunPrec ty1' <:> pprFunTail ty2' + pprFunTail otherTy = ppr_type TopPrec otherTy <:> pure [] + +ppr_type p (AppTy ty1 ty2) = maybeParen p TyConPrec <$> ((<+>) <$> pprType ty1 <*> ppr_type TyConPrec ty2) +ppr_type _ (ConstTy Arrow) = return (parens rarrow) + +pprForAllType :: LFresh m => TypePrec -> Type -> m Doc +pprForAllType p ty = maybeParen p FunPrec <$> pprSigmaType True ty + +pprSigmaType :: LFresh m => Bool -> Type -> m Doc +pprSigmaType showForalls ty = do + (tvs, rho) <- split1 [] ty + sep <$> sequenceA [ if showForalls then pprForAll tvs else pure emptyDoc + , pprType rho + ] + where + split1 tvs (ForAllTy b) = + lunbind b $ \(tv,resTy) -> split1 (tv:tvs) resTy + split1 tvs resTy = return (reverse tvs,resTy) + +pprForAll :: LFresh m => [TyVar] -> m Doc +pprForAll [] = return emptyDoc +pprForAll tvs = do + tvs' <- mapM pprTvBndr tvs + return $ PP.pretty '∀' <+> sep tvs' <> PP.dot + +pprTvBndr :: LFresh m => TyVar -> m Doc +pprTvBndr tv + = do + tv' <- ppr tv + kind' <- pprKind kind + return $ parens (tv' <+> dcolon <+> kind') + where + kind = unembed $ varKind tv + +pprKind :: LFresh m => Kind -> m Doc +pprKind = pprType + +pprTcApp :: LFresh m => TypePrec -> (TypePrec -> Type -> m Doc) + -> TyConName -> [Type] -> m Doc +pprTcApp _ _ tc [] + = return . PP.pretty $ name2String tc + +pprTcApp p pp tc tys + | isTupleTyConLike tc + = do + tys' <- mapM (pp TopPrec) tys + return $ parens $ sep $ punctuate comma tys' + + | otherwise + = pprTypeNameApp p pp tc tys + +pprTypeNameApp :: LFresh m => TypePrec -> (TypePrec -> Type -> m Doc) + -> Name a -> [Type] -> m Doc +pprTypeNameApp p pp name tys + | isSym + , [ty1,ty2] <- tys + = pprInfixApp p pp name ty1 ty2 + | otherwise + = do + tys' <- mapM (pp TyConPrec) tys + let name' = PP.pretty $ name2String name + return $ pprPrefixApp p (pprPrefixVar isSym name') tys' + where + isSym = isSymName name + +pprInfixApp :: LFresh m => TypePrec -> (TypePrec -> Type -> m Doc) + -> Name a -> Type -> Type -> m Doc +pprInfixApp p pp name ty1 ty2 = do + ty1' <- pp FunPrec ty1 + ty2' <- pp FunPrec ty2 + let name' = PP.pretty $ name2String name + return $ maybeParen p FunPrec $ sep [ty1', pprInfixVar True name' <+> ty2'] + +pprPrefixApp :: TypePrec -> Doc -> [Doc] -> Doc +pprPrefixApp p pp_fun pp_tys = maybeParen p TyConPrec $ + hang 2 (sep (pp_fun:pp_tys)) + +pprPrefixVar :: Bool -> Doc -> Doc +pprPrefixVar is_operator pp_v + | is_operator = parens pp_v + | otherwise = pp_v + +pprInfixVar :: Bool -> Doc -> Doc +pprInfixVar is_operator pp_v + | is_operator = pp_v + | otherwise = PP.pretty '`' <> pp_v <> PP.pretty '`' + +pprArrowChain :: TypePrec -> [Doc] -> Doc +pprArrowChain _ [] = emptyDoc +pprArrowChain p (arg:args) = maybeParen p FunPrec $ + sep [arg, sep (map (rarrow <+>) args)] + +isSymName :: Name a -> Bool +isSymName n = go (name2String n) + where + go s | null s = False + | isUpper $ head s = isLexConSym s + | otherwise = isLexSym s + +isLexSym :: String -> Bool +isLexSym cs = isLexConSym cs || isLexVarSym cs + +isLexConSym :: String -> Bool +isLexConSym "->" = True +isLexConSym cs = startsConSym (head cs) + +isLexVarSym :: String -> Bool +isLexVarSym cs = startsVarSym (head cs) + +startsConSym :: Char -> Bool +startsConSym c = c == ':' + +startsVarSym :: Char -> Bool +startsVarSym c = isSymbolASCII c || (ord c > 0x7f && isSymbol c) + +isSymbolASCII :: Char -> Bool +isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-" diff --git a/src/Clash/Core/Subst.hs b/src/Clash/Core/Subst.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Core/Subst.hs @@ -0,0 +1,66 @@ +{-| + Copyright : (C) 2012-2016, University of Twente, + 2017, Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Capture-free substitution function for CoreHW +-} + +{-# LANGUAGE ViewPatterns #-} + +module Clash.Core.Subst where + +import Unbound.Generics.LocallyNameless (embed, subst, substs, unembed) + +import Clash.Core.Term (LetBinding, Term, TmOccName) +import {-# SOURCE #-} Clash.Core.Type (KiOccName, Kind, TyOccName, Type) + +-- | Substitutes types in a type +substTys :: [(TyOccName,Type)] + -> Type + -> Type +substTys = substs + +-- | Substitutes a type in a type +substTy :: TyOccName + -> Type + -> Type + -> Type +substTy = subst + +-- | Substitutes kinds in a kind +substKindWith :: [(KiOccName,Kind)] + -> Kind + -> Kind +substKindWith = substs + +-- | Substitutes a type in a term +substTyInTm :: TyOccName + -> Type + -> Term + -> Term +substTyInTm = subst + +-- | Substitutes types in a term +substTysinTm :: [(TyOccName,Type)] + -> Term + -> Term +substTysinTm = substs + +-- | Substitutes a term in a term +substTm :: TmOccName + -> Term + -> Term + -> Term +substTm = subst + +-- | Substitutes terms in a term +substTms :: [(TmOccName,Term)] + -> Term + -> Term +substTms = substs + +-- | Substitutes a term in a let-binding +substBndr :: TmOccName -> Term -> LetBinding -> LetBinding +substBndr nm tm (id_,unembed -> tm') = (id_,embed (substTm nm tm tm')) diff --git a/src/Clash/Core/Term.hs b/src/Clash/Core/Term.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Core/Term.hs @@ -0,0 +1,98 @@ +{-| + Copyright : (C) 2012-2016, University of Twente, + 2017, Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Term representation in the CoreHW language: System F + LetRec + Case +-} + +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} + +module Clash.Core.Term + ( Term (..) + , TmName + , TmOccName + , LetBinding + , Pat (..) + , Alt + ) +where + +-- External Modules +import Control.DeepSeq +import Data.Hashable (Hashable) +import Data.Text (Text) +import GHC.Generics +import Unbound.Generics.LocallyNameless hiding (Name) +import Unbound.Generics.LocallyNameless.Extra () + +-- Internal Modules +import Clash.Core.DataCon (DataCon) +import Clash.Core.Literal (Literal) +import Clash.Core.Name (Name (..), OccName) +import {-# SOURCE #-} Clash.Core.Type (Type) +import Clash.Core.Var (Id, TyVar) + +-- | Term representation in the CoreHW language: System F + LetRec + Case +data Term + = Var !Type !TmName -- ^ Variable reference + | Data !DataCon -- ^ Datatype constructor + | Literal !Literal -- ^ Literal + | Prim !Text !Type -- ^ Primitive + | Lam !(Bind Id Term) -- ^ Term-abstraction + | TyLam !(Bind TyVar Term) -- ^ Type-abstraction + | App !Term !Term -- ^ Application + | TyApp !Term !Type -- ^ Type-application + | Letrec !(Bind (Rec [LetBinding]) Term) -- ^ Recursive let-binding + | Case !Term !Type [Alt] -- ^ Case-expression: subject, type of + -- alternatives, list of alternatives + | Cast !Term !Type !Type -- ^ Cast a term from one type to another + deriving (Show,Generic,NFData,Hashable) + +-- | Term reference +type TmName = Name Term +type TmOccName = OccName Term +-- | Binding in a LetRec construct +type LetBinding = (Id, Embed Term) + +-- | Patterns in the LHS of a case-decomposition +data Pat + = DataPat !(Embed DataCon) !(Rebind [TyVar] [Id]) + -- ^ Datatype pattern, '[TyVar]' bind existentially-quantified + -- type-variables of a DataCon + | LitPat !(Embed Literal) + -- ^ Literal pattern + | DefaultPat + -- ^ Default pattern + deriving (Eq,Show,Generic,NFData,Alpha,Hashable) + +type Alt = Bind Pat Term + +instance Eq Term where + (==) = aeq + +instance Ord Term where + compare = acompare + +instance Alpha Term where + aeq' c (Var _ n) (Var _ m) = aeq' c n m + aeq' _ (Prim t1 _) (Prim t2 _) = t1 == t2 + aeq' c t1 t2 = gaeq c (from t1) (from t2) + + acompare' c (Var _ n) (Var _ m) = acompare' c n m + acompare' _ (Prim t1 _) (Prim t2 _) = compare t1 t2 + acompare' c t1 t2 = gacompare c (from t1) (from t2) + +instance Subst Type Pat +instance Subst Term Pat + +instance Subst Term Term where + isvar (Var _ x) = Just (SubstName (nameOcc x)) + isvar _ = Nothing + +instance Subst Type Term diff --git a/src/Clash/Core/Term.hs-boot b/src/Clash/Core/Term.hs-boot new file mode 100644 --- /dev/null +++ b/src/Clash/Core/Term.hs-boot @@ -0,0 +1,17 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij +-} + +{-# OPTIONS_GHC -fno-warn-missing-methods #-} + +module Clash.Core.Term where + +import GHC.Generics (Generic) +import Clash.Core.Name (Name) + +data Term +type TmName = Name Term + +instance Generic Term diff --git a/src/Clash/Core/TyCon.hs b/src/Clash/Core/TyCon.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Core/TyCon.hs @@ -0,0 +1,156 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Type Constructors in CoreHW +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Clash.Core.TyCon + ( TyCon (..) + , TyConName + , TyConOccName + , TyConMap + , AlgTyConRhs (..) + , mkKindTyCon + , isTupleTyConLike + , tyConDataCons + ) +where + +#ifndef MIN_VERSION_unbound_generics +#define MIN_VERSION_unbound_generics(x,y,z)(1) +#endif + +-- External Import +import Control.DeepSeq +import Data.HashMap.Lazy (HashMap) +import GHC.Generics +import Unbound.Generics.LocallyNameless (Alpha(..)) +import Unbound.Generics.LocallyNameless.Extra () +#if MIN_VERSION_unbound_generics(0,3,0) +import Data.Monoid (All (..)) +import Unbound.Generics.LocallyNameless (NthPatFind (..), + NamePatFind (..)) +#endif + +-- Internal Imports +import Clash.Core.DataCon (DataCon) +import Clash.Core.Name +import {-# SOURCE #-} Clash.Core.Type (Kind, TyName, Type) +import Clash.Util + +-- | Type Constructor +data TyCon + -- | Algorithmic DataCons + = AlgTyCon + { tyConName :: !TyConName -- ^ Name of the TyCon + , tyConKind :: !Kind -- ^ Kind of the TyCon + , tyConArity :: !Int -- ^ Number of type arguments + , algTcRhs :: !AlgTyConRhs -- ^ DataCon definitions + } + -- | Function TyCons (e.g. type families) + | FunTyCon + { tyConName :: !TyConName -- ^ Name of the TyCon + , tyConKind :: !Kind -- ^ Kind of the TyCon + , tyConArity :: !Int -- ^ Number of type arguments + , tyConSubst :: [([Type],Type)] -- ^ List of: ([LHS match types], RHS type) + } + -- | Primitive TyCons + | PrimTyCon + { tyConName :: !TyConName -- ^ Name of the TyCon + , tyConKind :: !Kind -- ^ Kind of the TyCon + , tyConArity :: !Int -- ^ Number of type arguments + } + -- | To close the loop on the type hierarchy + | SuperKindTyCon + { tyConName :: !TyConName -- ^ Name of the TyCon + } + deriving (Generic,NFData) + +instance Show TyCon where + show (AlgTyCon {tyConName = n}) = "AlgTyCon: " ++ show n + show (FunTyCon {tyConName = n}) = "FunTyCon: " ++ show n + show (PrimTyCon {tyConName = n}) = "PrimTyCon: " ++ show n + show (SuperKindTyCon {tyConName = n}) = "SuperKindTyCon: " ++ show n + +instance Eq TyCon where + (==) = (==) `on` tyConName + +instance Ord TyCon where + compare = compare `on` tyConName + +-- | TyCon reference +type TyConName = Name TyCon +type TyConOccName = OccName TyCon +type TyConMap = HashMap TyConOccName TyCon + +-- | The RHS of an Algebraic Datatype +data AlgTyConRhs + = DataTyCon + { dataCons :: [DataCon] -- ^ The DataCons of a TyCon + } + | NewTyCon + { dataCon :: !DataCon -- ^ The newtype DataCon + , ntEtadRhs :: ([TyName],Type) -- ^ The argument type of the newtype + -- DataCon in eta-reduced form, which is + -- just the representation of the TyCon. + -- The TyName's are the type-variables from + -- the corresponding TyCon. + } + deriving (Show,Generic,NFData,Alpha) + +instance Alpha TyCon where + aeq' c tc1 tc2 = aeq' c (tyConName tc1) (tyConName tc2) + + fvAny' _ _ tc = pure tc + + close _ _ tc = tc + open _ _ tc = tc + + isPat _ = mempty + +#if MIN_VERSION_unbound_generics(0,3,0) + isTerm _ = All True + nthPatFind _ = NthPatFind Left + namePatFind _ = NamePatFind (const (Left 0)) +#else + isTerm _ = True + nthPatFind _ = Left + namePatFind _ _ = Left 0 +#endif + + swaps' _ _ tc = tc + lfreshen' _ tc cont = cont tc mempty + freshen' _ tc = return (tc,mempty) + + acompare' c tc1 tc2 = acompare' c (tyConName tc1) (tyConName tc2) + +-- | Create a Kind out of a TyConName +mkKindTyCon :: TyConName + -> Kind + -> TyCon +mkKindTyCon name kind + = PrimTyCon name kind 0 + +-- | Does the TyCon look like a tuple TyCon +isTupleTyConLike :: TyConName -> Bool +isTupleTyConLike nm = tupleName (name2String nm) + where + tupleName nm' + | '(' <- head nm' + , ')' <- last nm' + = all (== ',') (init $ tail nm') + tupleName _ = False + +-- | Get the DataCons belonging to a TyCon +tyConDataCons :: TyCon -> [DataCon] +tyConDataCons (AlgTyCon {algTcRhs = DataTyCon { dataCons = cons}}) = cons +tyConDataCons (AlgTyCon {algTcRhs = NewTyCon { dataCon = con }}) = [con] +tyConDataCons _ = [] diff --git a/src/Clash/Core/TyCon.hs-boot b/src/Clash/Core/TyCon.hs-boot new file mode 100644 --- /dev/null +++ b/src/Clash/Core/TyCon.hs-boot @@ -0,0 +1,13 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij +-} + +module Clash.Core.TyCon where + +import Clash.Core.Name (Name, OccName) + +data TyCon +type TyConName = Name TyCon +type TyConOccName = OccName TyCon diff --git a/src/Clash/Core/Type.hs b/src/Clash/Core/Type.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Core/Type.hs @@ -0,0 +1,558 @@ +{-| + Copyright : (C) 2012-2016, University of Twente, + 2016 , Myrtle Software Ltd, + 2017 , Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Types in CoreHW +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +module Clash.Core.Type + ( Type (..) + , TypeView (..) + , ConstTy (..) + , LitTy (..) + , Kind + , KindOrType + , KiName + , KiOccName + , TyName + , TyOccName + , TyVar + , tyView + , coreView + , typeKind + , mkTyConTy + , mkFunTy + , mkTyConApp + , splitFunTy + , splitFunTys + , splitFunForallTy + , splitCoreFunForallTy + , splitTyConAppM + , isPolyFunTy + , isPolyFunCoreTy + , isPolyTy + , isFunTy + , applyFunTy + , applyTy + , findFunSubst + , reduceTypeFamily + , undefinedTy + , isIntegerTy + , normalizeType + ) +where + +-- External import +import Control.DeepSeq as DS +import Data.Hashable (Hashable) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.List (foldl',isPrefixOf) +import Data.Maybe (isJust, mapMaybe) +import GHC.Base (isTrue#,(==#)) +import GHC.Generics (Generic(..)) +import GHC.Integer (smallInteger) +import GHC.Integer.Logarithms (integerLogBase#) +import Unbound.Generics.LocallyNameless (Alpha(..),Bind,Fresh, + Subst(..),SubstName(..), + acompare,aeq,bind,embed, + gacompare,gaeq,gfvAny, + runFreshM,unbind) +import Unbound.Generics.LocallyNameless.Extra () +import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) + +-- Local imports +import Clash.Core.DataCon +import Clash.Core.Name +import Clash.Core.Subst +import {-# SOURCE #-} Clash.Core.Term +import Clash.Core.TyCon +import Clash.Core.TysPrim +import Clash.Core.Var +import Clash.Util + +-- | Types in CoreHW: function and polymorphic types +data Type + = VarTy !Kind !TyName -- ^ Type variable + | ConstTy !ConstTy -- ^ Type constant + | ForAllTy !(Bind TyVar Type) -- ^ Polymorphic Type + | AppTy !Type !Type -- ^ Type Application + | LitTy !LitTy -- ^ Type literal + deriving (Show,Generic,NFData,Hashable) + +-- | An easier view on types +data TypeView + = FunTy !Type !Type -- ^ Function type + | TyConApp !TyConName [Type] -- ^ Applied TyCon + | OtherType !Type -- ^ Neither of the above + deriving Show + +-- | Type Constants +data ConstTy + = TyCon !TyConName -- ^ TyCon type + | Arrow -- ^ Function type + deriving (Show,Generic,NFData,Alpha,Hashable) + +-- | Literal Types +data LitTy + = NumTy !Integer + | SymTy !String + deriving (Show,Generic,NFData,Alpha,Hashable) + +-- | The level above types +type Kind = Type +-- | Either a Kind or a Type +type KindOrType = Type + +-- | Reference to a Type +type TyName = Name Type +type TyOccName = OccName Type +-- | Reference to a Kind +type KiName = Name Kind +type KiOccName = OccName Kind + +instance Alpha Type where + fvAny' c nfn (VarTy t n) = fmap (VarTy t) $ fvAny' c nfn n + fvAny' c nfn t = fmap to . gfvAny c nfn $ from t + + aeq' c (VarTy _ n) (VarTy _ m) = aeq' c n m + aeq' c t1 t2 = gaeq c (from t1) (from t2) + + acompare' c (VarTy _ n) (VarTy _ m) = acompare' c n m + acompare' c t1 t2 = gacompare c (from t1) (from t2) + +instance Subst a LitTy where + subst _ _ lt = lt + substs _ lt = lt + +instance Subst a ConstTy where + subst _ _ ct = ct + substs _ ct = ct + +instance Subst Term Type +instance Subst Type Type where + isvar (VarTy _ v) = Just (SubstName (nameOcc v)) + isvar _ = Nothing + +instance Eq Type where + (==) = aeq + +instance Ord Type where + compare = acompare + +-- | An easier view on types +tyView :: Type -> TypeView +tyView ty@(AppTy _ _) = case splitTyAppM ty of + Just (ConstTy Arrow, [ty1,ty2]) -> FunTy ty1 ty2 + Just (ConstTy (TyCon tc), args) -> TyConApp tc args + _ -> OtherType ty +tyView (ConstTy (TyCon tc)) = TyConApp tc [] +tyView t = OtherType t + +-- | A view on types in which newtypes are transparent, the Signal type is +-- transparent, and type functions are evaluated to WHNF (when possible). +-- +-- Only strips away one "layer". +coreView :: HashMap TyConOccName TyCon -> Type -> Maybe Type +coreView tcMap ty = case tyView ty of + TyConApp tcNm args + | name2String tcNm == "Clash.Signal.Internal.Signal" + , [_,elTy] <- args + -> Just elTy + | otherwise + -> case tcMap HashMap.! nameOcc tcNm of + AlgTyCon {algTcRhs = (NewTyCon _ nt)} + -> newTyConInstRhs nt args + _ -> reduceTypeFamily tcMap ty + _ -> Nothing + +-- | Instantiate and Apply the RHS/Original of a NewType with the given +-- list of argument types +-- +-- Returns /Nothing/ when under-applied +newTyConInstRhs :: ([TyName],Type) -> [Type] -> Maybe Type +newTyConInstRhs (tvs,ty) tys + | length tvs <= length tys + = Just (foldl AppTy (substTys (zip tvs' tys1) ty) tys2) + | otherwise + = Nothing + where + (tys1, tys2) = splitAtList tvs tys + tvs' = map nameOcc tvs + +-- | Make a function type of an argument and result type +mkFunTy :: Type -> Type -> Type +mkFunTy t1 = AppTy (AppTy (ConstTy Arrow) t1) + +-- | Make a TyCon Application out of a TyCon and a list of argument types +mkTyConApp :: TyConName -> [Type] -> Type +mkTyConApp tc = foldl AppTy (ConstTy $ TyCon tc) + +-- | Make a Type out of a TyCon +mkTyConTy :: TyConName -> Type +mkTyConTy ty = ConstTy $ TyCon ty + +-- | Split a TyCon Application in a TyCon and its arguments +splitTyConAppM :: Type + -> Maybe (TyConName,[Type]) +splitTyConAppM (tyView -> TyConApp tc args) = Just (tc,args) +splitTyConAppM _ = Nothing + +-- | Is a type a Superkind? +isSuperKind :: HashMap TyConOccName TyCon -> Type -> Bool +isSuperKind tcMap (ConstTy (TyCon (((tcMap HashMap.!) . nameOcc) -> SuperKindTyCon {}))) = True +isSuperKind _ _ = False + +-- | Determine the kind of a type +typeKind :: HashMap TyConOccName TyCon -> Type -> Kind +typeKind _ (VarTy k _) = k +typeKind m (ForAllTy b) = let (_,ty) = runFreshM $ unbind b + in typeKind m ty +typeKind _ (LitTy (NumTy _)) = typeNatKind +typeKind _ (LitTy (SymTy _)) = typeSymbolKind +typeKind m (tyView -> FunTy _arg res) + | isSuperKind m k = k + | otherwise = liftedTypeKind + where k = typeKind m res + +typeKind m (tyView -> TyConApp tc args) = foldl' kindFunResult (tyConKind (m HashMap.! nameOcc tc)) args + +typeKind m (AppTy fun arg) = kindFunResult (typeKind m fun) arg +typeKind _ (ConstTy ct) = error $ $(curLoc) ++ "typeKind: naked ConstTy: " ++ show ct + +kindFunResult :: Kind -> KindOrType -> Kind +kindFunResult (tyView -> FunTy _ res) _ = res + +kindFunResult (ForAllTy b) arg = + let (kv,ki) = runFreshM . unbind $ b + in substKindWith (zip [nameOcc (varName kv)] [arg]) ki + +kindFunResult k tys = + error $ $(curLoc) ++ "kindFunResult: " ++ show (k,tys) + +-- | Is a type polymorphic? +isPolyTy :: Type -> Bool +isPolyTy (ForAllTy _) = True +isPolyTy (tyView -> FunTy _ res) = isPolyTy res +isPolyTy _ = False + +-- | Split a function type in an argument and result type +splitFunTy :: HashMap TyConOccName TyCon + -> Type + -> Maybe (Type, Type) +splitFunTy m (coreView m -> Just ty) = splitFunTy m ty +splitFunTy _ (tyView -> FunTy arg res) = Just (arg,res) +splitFunTy _ _ = Nothing + +splitFunTys :: HashMap TyConOccName TyCon + -> Type + -> ([Type],Type) +splitFunTys m ty = go [] ty ty + where + go args orig_ty (coreView m -> Just ty') = go args orig_ty ty' + go args _ (tyView -> FunTy arg res) = go (arg:args) res res + go args orig_ty _ = (reverse args, orig_ty) + +-- | Split a poly-function type in a: list of type-binders and argument types, +-- and the result type +splitFunForallTy :: Type + -> ([Either TyVar Type],Type) +splitFunForallTy = go [] + where + go args (ForAllTy b) = let (tv,ty) = runFreshM $ unbind b + in go (Left tv:args) ty + go args (tyView -> FunTy arg res) = go (Right arg:args) res + go args ty = (reverse args,ty) + +-- | Split a poly-function type in a: list of type-binders and argument types, +-- and the result type. Looks through 'Signal' and type functions. +splitCoreFunForallTy :: HashMap TyConOccName TyCon + -> Type + -> ([Either TyVar Type], Type) +splitCoreFunForallTy tcm ty = go [] ty ty + where + go args orig_ty (coreView tcm -> Just ty') = go args orig_ty ty' + go args _ (ForAllTy b) = let (tv,res) = runFreshM $ unbind b + in go (Left tv:args) res res + go args _ (tyView -> FunTy arg res) = go (Right arg:args) res res + go args orig_ty _ = (reverse args,orig_ty) + +-- | Is a type a polymorphic or function type? +isPolyFunTy :: Type + -> Bool +isPolyFunTy = not . null . fst . splitFunForallTy + +-- | Is a type a polymorphic or function type under 'coreView'? +isPolyFunCoreTy :: HashMap TyConOccName TyCon + -> Type + -> Bool +isPolyFunCoreTy m (coreView m -> Just ty) = isPolyFunCoreTy m ty +isPolyFunCoreTy _ ty = case tyView ty of + FunTy _ _ -> True + OtherType (ForAllTy _) -> True + _ -> False + +-- | Is a type a function type? +isFunTy :: HashMap TyConOccName TyCon + -> Type + -> Bool +isFunTy m = isJust . splitFunTy m + +-- | Apply a function type to an argument type and get the result type +applyFunTy :: HashMap TyConOccName TyCon + -> Type + -> Type + -> Type +applyFunTy m (coreView m -> Just ty) arg = applyFunTy m ty arg +applyFunTy _ (tyView -> FunTy _ resTy) _ = resTy +applyFunTy _ _ _ = error $ $(curLoc) ++ "Report as bug: not a FunTy" + +-- | Substitute the type variable of a type ('ForAllTy') with another type +applyTy :: Fresh m + => HashMap TyConOccName TyCon + -> Type + -> KindOrType + -> m Type +applyTy tcm (coreView tcm -> Just ty) arg = applyTy tcm ty arg +applyTy _ (ForAllTy b) arg = do + (tv,ty) <- unbind b + return (substTy (nameOcc (varName tv)) arg ty) +applyTy _ ty arg = error ($(curLoc) ++ "applyTy: not a forall type:\n" ++ show ty ++ "\nArg:\n" ++ show arg) + +-- | Split a type application in the applied type and the argument types +splitTyAppM :: Type + -> Maybe (Type, [Type]) +splitTyAppM = fmap (second reverse) . go [] + where + go args (AppTy ty1 ty2) = + case go args ty1 of + Nothing -> Just (ty1,ty2:args) + Just (ty1',ty1args) -> Just (ty1',ty2:ty1args ) + go _ _ = Nothing + +-- Type function substitutions + +-- Given a set of type functions, and list of argument types, get the first +-- type function that matches, and return its substituted RHS type. +findFunSubst :: HashMap TyConOccName TyCon -> [([Type],Type)] -> [Type] -> Maybe Type +findFunSubst _ [] _ = Nothing +findFunSubst tcm (tcSubst:rest) args = case funSubsts tcm tcSubst args of + Just ty -> Just ty + Nothing -> findFunSubst tcm rest args + +-- Given a ([LHS match type], RHS type) representing a type function, and +-- a set of applied types. Match LHS with args, and when successful, return +-- a substituted RHS +funSubsts :: HashMap TyConOccName TyCon -> ([Type],Type) -> [Type] -> Maybe Type +funSubsts tcm (tcSubstLhs,tcSubstRhs) args = do + tySubts <- foldl' (funSubst tcm) (Just []) (zip tcSubstLhs args) + let tyRhs = substTys tySubts tcSubstRhs + -- Type functions can return higher-kinded types + case drop (length tcSubstLhs) args of + [] -> return tyRhs + -- So don't forget to apply the arguments not consumed by the type + -- function application! + -- + -- Forgetting leads to: #232 + args' -> return (foldl' AppTy tyRhs args') + +-- Given a LHS matching type, and a RHS to-match type, check if LHS and RHS +-- are a match. If they do match, and the LHS is a variable, return a +-- substitution +funSubst + :: HashMap TyConOccName TyCon + -> Maybe [(TyOccName,Type)] + -> (Type,Type) + -> Maybe [(TyOccName,Type)] +funSubst _ Nothing = const Nothing +funSubst tcm (Just s) = uncurry go + where + go (VarTy _ (nameOcc -> nmF)) ty = case lookup nmF s of + Nothing -> Just ((nmF,ty):s) + -- Given, for example, the type family definition: + -- + -- > type family Max x y where + -- > Max 0 b = b + -- > Max a 0 = a + -- > Max n n = n + -- > Max a b = If (a <=? b) b a + -- + -- Then `Max 4 8` matches against the 4th clause. + -- + -- So this is why, whenever we match against a type variable, we first + -- check if there is already a substitution defined for this type variable, + -- and if so, the applied type, and the type in the substitution should match. + Just ty' | ty' == ty -> Just s + _ -> Nothing + go ty1 (reduceTypeFamily tcm -> Just ty2) = go ty1 ty2 -- See [Note: lazy type families] + go ty1@(LitTy _) ty2 = if ty1 == ty2 then Just s else Nothing + go (tyView -> TyConApp tc argTys) (tyView -> TyConApp tc' argTys') + | tc == tc' + = foldl' (funSubst tcm) (Just s) (zip argTys argTys') + go _ _ = Nothing + +{- [Note: lazy type families] + +I don't know whether type families are evaluated strictly or lazily, but this +being Haskell, I assume type families are evaluated lazily. + +Clash hence follows the Haskell way, and only evaluates type family arguments +to (WH)NF when the formal parameter is _not_ a type variable. +-} + +reduceTypeFamily :: HashMap TyConOccName TyCon -> Type -> Maybe Type +reduceTypeFamily tcm (tyView -> TyConApp tc tys) +#if MIN_VERSION_ghc(8,2,0) + | name2String tc == "GHC.TypeNats.+" +#else + | name2String tc == "GHC.TypeLits.+" +#endif + , [i1, i2] <- mapMaybe (litView tcm) tys + = Just (LitTy (NumTy (i1 + i2))) + +#if MIN_VERSION_ghc(8,2,0) + | name2String tc == "GHC.TypeNats.*" +#else + | name2String tc == "GHC.TypeLits.*" +#endif + , [i1, i2] <- mapMaybe (litView tcm) tys + = Just (LitTy (NumTy (i1 * i2))) + +#if MIN_VERSION_ghc(8,2,0) + | name2String tc == "GHC.TypeNats.^" +#else + | name2String tc == "GHC.TypeLits.^" +#endif + , [i1, i2] <- mapMaybe (litView tcm) tys + = Just (LitTy (NumTy (i1 ^ i2))) + +#if MIN_VERSION_ghc(8,2,0) + | name2String tc == "GHC.TypeNats.-" +#else + | name2String tc == "GHC.TypeLits.-" +#endif + , [i1, i2] <- mapMaybe (litView tcm) tys + = Just (LitTy (NumTy (i1 - i2))) + +#if MIN_VERSION_ghc(8,2,0) + | name2String tc == "GHC.TypeNats.<=?" +#else + | name2String tc == "GHC.TypeLits.<=?" +#endif + , [i1, i2] <- mapMaybe (litView tcm) tys + , Just (FunTyCon {tyConKind = tck}) <- HashMap.lookup (nameOcc tc) tcm + , (_,tyView -> TyConApp boolTcNm []) <- splitFunTys tcm tck + , Just boolTc <- HashMap.lookup (nameOcc boolTcNm) tcm + = let [falseTc,trueTc] = map (coerceName . dcName) (tyConDataCons boolTc) + in if i1 <= i2 then Just (mkTyConApp trueTc [] ) + else Just (mkTyConApp falseTc []) + + | name2String tc == "GHC.TypeLits.Extra.FLog" + , [i1, i2] <- mapMaybe (litView tcm) tys + , i1 > 1 + , i2 > 0 + = Just (LitTy (NumTy (smallInteger (integerLogBase# i1 i2)))) + + | name2String tc == "GHC.TypeLits.Extra.CLog" + , [i1, i2] <- mapMaybe (litView tcm) tys + , Just k <- clogBase i1 i2 + = Just (LitTy (NumTy (toInteger k))) + + | name2String tc == "GHC.TypeLits.Extra.Log" + , [i1, i2] <- mapMaybe (litView tcm) tys + , i1 > 1 + , i2 > 0 + = if i2 == 1 + then Just (LitTy (NumTy 0)) + else let z1 = integerLogBase# i1 i2 + z2 = integerLogBase# i1 (i2-1) + in if isTrue# (z1 ==# z2) + then Nothing + else Just (LitTy (NumTy (smallInteger z1))) + + + | name2String tc == "GHC.TypeLits.Extra.GCD" + , [i1, i2] <- mapMaybe (litView tcm) tys + = Just (LitTy (NumTy (i1 `gcd` i2))) + + | name2String tc == "GHC.TypeLits.Extra.LCM" + , [i1, i2] <- mapMaybe (litView tcm) tys + = Just (LitTy (NumTy (i1 `lcm` i2))) + + | name2String tc == "GHC.TypeLits.Extra.Div" + , [i1, i2] <- mapMaybe (litView tcm) tys + , i2 > 0 + = Just (LitTy (NumTy (i1 `div` i2))) + + | name2String tc == "GHC.TypeLits.Extra.Mod" + , [i1, i2] <- mapMaybe (litView tcm) tys + , i2 > 0 + = Just (LitTy (NumTy (i1 `mod` i2))) + + | Just (FunTyCon {tyConSubst = tcSubst}) <- HashMap.lookup (nameOcc tc) tcm + = findFunSubst tcm tcSubst tys + +reduceTypeFamily _ _ = Nothing + +litView :: HashMap TyConOccName TyCon -> Type -> Maybe Integer +litView _ (LitTy (NumTy i)) = Just i +litView m (reduceTypeFamily m -> Just ty') = litView m ty' +litView _ _ = Nothing + +-- | The type of GHC.Err.undefined :: forall a . a +undefinedTy :: Type +undefinedTy = + let aNm = string2SystemName "a" + in ForAllTy (bind (TyVar aNm (embed liftedTypeKind)) (VarTy liftedTypeKind aNm)) + +isIntegerTy :: Type -> Bool +isIntegerTy (ConstTy (TyCon (nm))) + | "GHC.Integer.Type.Integer" `isPrefixOf` (name2String nm) = True +isIntegerTy _ = False + +-- Normalize a type, looking through Signals and newtypes +-- +-- For example: Vec (6-1) (Unsigned (3+1)) normalizes to Vec 5 (Unsigned 4) +normalizeType :: HashMap TyConOccName TyCon -> Type -> Type +normalizeType tcMap = go + where + go ty = case tyView ty of + TyConApp tcNm args + | name2String tcNm == "Clash.Signal.Internal.Signal" + , [_,elTy] <- args + -> go elTy + -- These Clash types are implemented with newtypes. + -- We need to keep these newtypes because they define the width of the numbers. + | name2String tcNm == "Clash.Sized.Internal.BitVector.Bit" || + name2String tcNm == "Clash.Sized.Internal.BitVector.BitVector" || + name2String tcNm == "Clash.Sized.Internal.Index.Index" || + name2String tcNm == "Clash.Sized.Internal.Signed.Signed" || + name2String tcNm == "Clash.Sized.Internal.Unsigned.Unsigned" + -> mkTyConApp tcNm (map go args) + | otherwise + -> case tcMap HashMap.! nameOcc tcNm of + AlgTyCon {algTcRhs = (NewTyCon _ nt)} + -> case newTyConInstRhs nt args of + Just ty' -> go ty' + Nothing -> ty + _ -> let args' = map go args + ty' = mkTyConApp tcNm args' + in case reduceTypeFamily tcMap ty' of + Just ty'' -> ty'' + Nothing -> ty' + FunTy ty1 ty2 -> mkFunTy (go ty1) (go ty2) + (OtherType (ForAllTy (unsafeUnbind -> (tyvar,ty')))) + -> ForAllTy (bind tyvar (go ty')) + _ -> ty diff --git a/src/Clash/Core/Type.hs-boot b/src/Clash/Core/Type.hs-boot new file mode 100644 --- /dev/null +++ b/src/Clash/Core/Type.hs-boot @@ -0,0 +1,40 @@ +{-| + Copyright : (C) 2012-2016, University of Twente, + 2017, Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij +-} + +{-# LANGUAGE MultiParamTypeClasses #-} + +{-# OPTIONS_GHC -fno-warn-missing-methods #-} + +module Clash.Core.Type where + +import Control.DeepSeq (NFData) +import Data.Hashable (Hashable) +import GHC.Generics (Generic) +import Unbound.Generics.LocallyNameless (Alpha,Subst) + +import Clash.Core.Name +import {-# SOURCE #-} Clash.Core.Term +import {-# SOURCE #-} Clash.Core.TyCon + +data Type + +type Kind = Type +type TyName = Name Type +type TyOccName = OccName Type +type KiName = Name Kind +type KiOccName = OccName Kind + +instance Eq Type +instance Generic Type +instance Show Type +instance Alpha Type +instance Subst Type Type +instance Subst Term Type +instance NFData Type +instance Hashable Type + +mkTyConTy :: TyConName -> Type diff --git a/src/Clash/Core/TysPrim.hs b/src/Clash/Core/TysPrim.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Core/TysPrim.hs @@ -0,0 +1,144 @@ +{-| + Copyright : (C) 2012-2016, University of Twente, + 2016 , Myrtle Software Ltd + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Builtin Type and Kind definitions +-} + +{-# LANGUAGE CPP #-} + +module Clash.Core.TysPrim + ( liftedTypeKind + , typeNatKind + , typeSymbolKind + , intPrimTy + , integerPrimTy + , charPrimTy + , stringPrimTy + , voidPrimTy + , wordPrimTy + , int64PrimTy + , word64PrimTy + , floatPrimTy + , doublePrimTy + , naturalPrimTy + , tysPrimMap + ) +where + +import Control.Arrow (first) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap + +import PrelNames +import Unique (Unique, getKey) + +import Clash.Core.Name +import Clash.Core.TyCon +import {-# SOURCE #-} Clash.Core.Type + +-- | Builtin Name +tySuperKindTyConName, liftedTypeKindTyConName, typeNatKindTyConName, typeSymbolKindTyConName :: TyConName +tySuperKindTyConName = string2SystemName "BOX" +liftedTypeKindTyConName = string2SystemName "*" +typeNatKindTyConName = string2SystemName "Nat" +typeSymbolKindTyConName = string2SystemName "Symbol" + +-- | Builtin Kind +liftedTypeKindtc, tySuperKindtc, typeNatKindtc, typeSymbolKindtc :: TyCon +tySuperKindtc = SuperKindTyCon tySuperKindTyConName +liftedTypeKindtc = mkKindTyCon liftedTypeKindTyConName tySuperKind +typeNatKindtc = mkKindTyCon typeNatKindTyConName tySuperKind +typeSymbolKindtc = mkKindTyCon typeSymbolKindTyConName tySuperKind + +liftedTypeKind, tySuperKind, typeNatKind, typeSymbolKind :: Type +tySuperKind = mkTyConTy tySuperKindTyConName +liftedTypeKind = mkTyConTy liftedTypeKindTyConName +typeNatKind = mkTyConTy typeNatKindTyConName +typeSymbolKind = mkTyConTy typeSymbolKindTyConName + +uniqueToInteger :: Unique -> Integer +uniqueToInteger = toInteger . getKey + +intPrimTyConName, integerPrimTyConName, charPrimTyConName, stringPrimTyConName, + voidPrimTyConName, wordPrimTyConName, int64PrimTyConName, + word64PrimTyConName, floatPrimTyConName, doublePrimTyConName, + naturalPrimTyConName :: TyConName +intPrimTyConName = makeSystemName "GHC.Prim.Int#" + (uniqueToInteger intPrimTyConKey) +integerPrimTyConName = makeSystemName "GHC.Integer.Type.Integer" + (uniqueToInteger integerTyConKey) +stringPrimTyConName = string2SystemName "String" +charPrimTyConName = makeSystemName "GHC.Prim.Char#" + (uniqueToInteger charPrimTyConKey) +voidPrimTyConName = string2SystemName "VOID" +wordPrimTyConName = makeSystemName "GHC.Prim.Word#" + (uniqueToInteger wordPrimTyConKey) +int64PrimTyConName = makeSystemName "GHC.Prim.Int64#" + (uniqueToInteger int64PrimTyConKey) +word64PrimTyConName = makeSystemName "GHC.Prim.Word64#" + (uniqueToInteger word64PrimTyConKey) +floatPrimTyConName = makeSystemName "GHC.Prim.Float#" + (uniqueToInteger floatPrimTyConKey) +doublePrimTyConName = makeSystemName "GHC.Prim.Double#" + (uniqueToInteger doublePrimTyConKey) +#if MIN_VERSION_ghc(8,2,0) +naturalPrimTyConName = makeSystemName "GHC.Natural.Natural" + (uniqueToInteger naturalTyConKey) +#else +naturalPrimTyConName = string2SystemName "GHC.Natural.Natural" +#endif + +liftedPrimTC :: TyConName + -> TyCon +liftedPrimTC name = PrimTyCon name liftedTypeKind 0 + +-- | Builtin Type +intPrimTc, integerPrimTc, charPrimTc, stringPrimTc, voidPrimTc, wordPrimTc, + int64PrimTc, word64PrimTc, floatPrimTc, doublePrimTc, naturalPrimTc :: TyCon +intPrimTc = liftedPrimTC intPrimTyConName +integerPrimTc = liftedPrimTC integerPrimTyConName +charPrimTc = liftedPrimTC charPrimTyConName +stringPrimTc = liftedPrimTC stringPrimTyConName +voidPrimTc = liftedPrimTC voidPrimTyConName +wordPrimTc = liftedPrimTC wordPrimTyConName +int64PrimTc = liftedPrimTC int64PrimTyConName +word64PrimTc = liftedPrimTC word64PrimTyConName +floatPrimTc = liftedPrimTC floatPrimTyConName +doublePrimTc = liftedPrimTC doublePrimTyConName +naturalPrimTc = liftedPrimTC naturalPrimTyConName + +intPrimTy, integerPrimTy, charPrimTy, stringPrimTy, voidPrimTy, wordPrimTy, + int64PrimTy, word64PrimTy, floatPrimTy, doublePrimTy, naturalPrimTy :: Type +intPrimTy = mkTyConTy intPrimTyConName +integerPrimTy = mkTyConTy integerPrimTyConName +charPrimTy = mkTyConTy charPrimTyConName +stringPrimTy = mkTyConTy stringPrimTyConName +voidPrimTy = mkTyConTy voidPrimTyConName +wordPrimTy = mkTyConTy wordPrimTyConName +int64PrimTy = mkTyConTy int64PrimTyConName +word64PrimTy = mkTyConTy word64PrimTyConName +floatPrimTy = mkTyConTy floatPrimTyConName +doublePrimTy = mkTyConTy doublePrimTyConName +naturalPrimTy = mkTyConTy naturalPrimTyConName + +tysPrimMap :: HashMap TyConOccName TyCon +tysPrimMap = HashMap.fromList $ map (first nameOcc) + [ (tySuperKindTyConName,tySuperKindtc) + , (liftedTypeKindTyConName,liftedTypeKindtc) + , (typeNatKindTyConName,typeNatKindtc) + , (typeSymbolKindTyConName,typeSymbolKindtc) + , (intPrimTyConName,intPrimTc) + , (integerPrimTyConName,integerPrimTc) + , (charPrimTyConName,charPrimTc) + , (stringPrimTyConName,stringPrimTc) + , (voidPrimTyConName,voidPrimTc) + , (wordPrimTyConName,wordPrimTc) + , (int64PrimTyConName,int64PrimTc) + , (word64PrimTyConName,word64PrimTc) + , (floatPrimTyConName,floatPrimTc) + , (doublePrimTyConName,doublePrimTc) + , (naturalPrimTyConName,naturalPrimTc) + ] diff --git a/src/Clash/Core/Util.hs b/src/Clash/Core/Util.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Core/Util.hs @@ -0,0 +1,459 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Smart constructor and destructor functions for CoreHW +-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +module Clash.Core.Util where + +import Control.Monad.Trans.Except (Except, throwE) +import qualified Data.HashMap.Strict as HMS +import qualified Data.HashMap.Lazy as HashMap +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashSet as HashSet +import Data.Maybe (fromJust, mapMaybe) +import Unbound.Generics.LocallyNameless + (Fresh, bind, embed, rebind, unbind, unembed, unrebind, unrec) +import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) + +import Clash.Core.DataCon (DataCon, dcType, dataConInstArgTys) +import Clash.Core.Literal (literalType) +import Clash.Core.Name + (Name (..), name2String, string2SystemName) +import Clash.Core.Pretty (showDoc) +import Clash.Core.Term + (LetBinding, Pat (..), Term (..), TmName, TmOccName) +import Clash.Core.Type + (Kind, LitTy (..), TyName, TyOccName, Type (..), TypeView (..), applyTy, + coreView, isFunTy, isPolyFunCoreTy, mkFunTy, splitFunTy, tyView) +import Clash.Core.TyCon + (TyCon (..), TyConOccName, tyConDataCons) +import Clash.Core.TysPrim (typeNatKind) +import Clash.Core.Var (Id, TyVar, Var (..), varType) +import Clash.Util + +-- | Type environment/context +type Gamma = HashMap TmOccName Type +-- | Kind environment/context +type Delta = HashMap TyOccName Kind + +-- | Determine the type of a term +termType :: Fresh m + => HashMap TyConOccName TyCon + -> Term + -> m Type +termType m e = case e of + Var t _ -> return t + Data dc -> return $ dcType dc + Literal l -> return $ literalType l + Prim _ t -> return t + Lam b -> do (v,e') <- unbind b + mkFunTy (unembed $ varType v) <$> termType m e' + TyLam b -> do (tv,e') <- unbind b + ForAllTy <$> bind tv <$> termType m e' + App _ _ -> case collectArgs e of + (fun, args) -> termType m fun >>= + (flip (applyTypeToArgs m) args) + TyApp e' ty -> termType m e' >>= (\f -> applyTy m f ty) + Letrec b -> do (_,e') <- unbind b + termType m e' + Case _ ty _ -> return ty + Cast _ _ ty2 -> return ty2 + +-- | Split a (Type)Application in the applied term and it arguments +collectArgs :: Term + -> (Term, [Either Term Type]) +collectArgs = go [] + where + go args (App e1 e2) = go (Left e2:args) e1 + go args (TyApp e t) = go (Right t:args) e + go args e = (e, args) + +-- | Split a (Type)Abstraction in the bound variables and the abstracted term +collectBndrs :: Fresh m + => Term + -> m ([Either Id TyVar], Term) +collectBndrs = go [] + where + go bs (Lam b) = do + (v,e') <- unbind b + go (Left v:bs) e' + go bs (TyLam b) = do + (tv,e') <- unbind b + go (Right tv:bs) e' + go bs e' = return (reverse bs,e') + +-- | Get the result type of a polymorphic function given a list of arguments +applyTypeToArgs :: Fresh m + => HashMap TyConOccName TyCon + -> Type + -> [Either Term Type] + -> m Type +applyTypeToArgs _ opTy [] = return opTy +applyTypeToArgs m opTy (Right ty:args) = applyTy m opTy ty >>= + (flip (applyTypeToArgs m) args) +applyTypeToArgs m opTy (Left e:args) = case splitFunTy m opTy of + Just (_,resTy) -> applyTypeToArgs m resTy args + Nothing -> error $ + concat [ $(curLoc) + , "applyTypeToArgs splitFunTy: not a funTy:\n" + , "opTy: " + , showDoc opTy + , "\nTerm: " + , showDoc e + , "\nOtherArgs: " + , unlines (map (either showDoc showDoc) args) + ] + +-- | Get the list of term-binders out of a DataType pattern +patIds :: Pat -> [Id] +patIds (DataPat _ ids) = snd $ unrebind ids +patIds _ = [] + +-- | Make a type variable +mkTyVar :: Kind + -> TyName + -> TyVar +mkTyVar tyKind tyName = TyVar tyName (embed tyKind) + +-- | Make a term variable +mkId :: Type + -> TmName + -> Id +mkId tmType tmName = Id tmName (embed tmType) + +-- | Abstract a term over a list of term and type variables +mkAbstraction :: Term + -> [Either Id TyVar] + -> Term +mkAbstraction = foldr (either (Lam `dot` bind) (TyLam `dot` bind)) + +-- | Abstract a term over a list of term variables +mkTyLams :: Term + -> [TyVar] + -> Term +mkTyLams tm = mkAbstraction tm . map Right + +-- | Abstract a term over a list of type variables +mkLams :: Term + -> [Id] + -> Term +mkLams tm = mkAbstraction tm . map Left + +-- | Apply a list of types and terms to a term +mkApps :: Term + -> [Either Term Type] + -> Term +mkApps = foldl (\e a -> either (App e) (TyApp e) a) + +-- | Apply a list of terms to a term +mkTmApps :: Term + -> [Term] + -> Term +mkTmApps = foldl App + +-- | Apply a list of types to a term +mkTyApps :: Term + -> [Type] + -> Term +mkTyApps = foldl TyApp + +-- | Does a term have a function type? +isFun :: Fresh m + => HashMap TyConOccName TyCon + -> Term + -> m Bool +isFun m t = fmap (isFunTy m) $ (termType m) t + +-- | Does a term have a function or polymorphic type? +isPolyFun :: Fresh m + => HashMap TyConOccName TyCon + -> Term + -> m Bool +isPolyFun m t = isPolyFunCoreTy m <$> termType m t + +-- | Is a term a term-abstraction? +isLam :: Term + -> Bool +isLam (Lam _) = True +isLam _ = False + +-- | Is a term a recursive let-binding? +isLet :: Term + -> Bool +isLet (Letrec _) = True +isLet _ = False + +-- | Is a term a variable reference? +isVar :: Term + -> Bool +isVar (Var _ _) = True +isVar _ = False + +-- | Is a term a datatype constructor? +isCon :: Term + -> Bool +isCon (Data _) = True +isCon _ = False + +-- | Is a term a primitive? +isPrim :: Term + -> Bool +isPrim (Prim _ _) = True +isPrim _ = False + +-- | Make variable reference out of term variable +idToVar :: Id + -> Term +idToVar (Id nm tyE) = Var (unembed tyE) nm +idToVar tv = error $ $(curLoc) ++ "idToVar: tyVar: " ++ showDoc tv + +-- | Make a term variable out of a variable reference +varToId :: Term + -> Id +varToId (Var ty nm) = Id nm (embed ty) +varToId e = error $ $(curLoc) ++ "varToId: not a var: " ++ showDoc e + +termSize :: Term + -> Word +termSize (Var _ _) = 1 +termSize (Data _) = 1 +termSize (Literal _) = 1 +termSize (Prim _ _) = 1 +termSize (Lam b) = let (_,e) = unsafeUnbind b + in termSize e + 1 +termSize (TyLam b) = let (_,e) = unsafeUnbind b + in termSize e +termSize (App e1 e2) = termSize e1 + termSize e2 +termSize (TyApp e _) = termSize e +termSize (Cast e _ _)= termSize e +termSize (Letrec b) = let (bndrsR,body) = unsafeUnbind b + bndrSzs = map (termSize . unembed . snd) (unrec bndrsR) + bodySz = termSize body + in sum (bodySz:bndrSzs) +termSize (Case subj _ alts) = let subjSz = termSize subj + altSzs = map (termSize . snd . unsafeUnbind) alts + in sum (subjSz:altSzs) + +-- | Create a vector of supplied elements +mkVec :: DataCon -- ^ The Nil constructor + -> DataCon -- ^ The Cons (:>) constructor + -> Type -- ^ Element type + -> Integer -- ^ Length of the vector + -> [Term] -- ^ Elements to put in the vector + -> Term +mkVec nilCon consCon resTy = go + where + go _ [] = mkApps (Data nilCon) [Right (LitTy (NumTy 0)) + ,Right resTy + ,Left (Prim "_CO_" nilCoTy) + ] + + go n (x:xs) = mkApps (Data consCon) [Right (LitTy (NumTy n)) + ,Right resTy + ,Right (LitTy (NumTy (n-1))) + ,Left (Prim "_CO_" (consCoTy n)) + ,Left x + ,Left (go (n-1) xs)] + + nilCoTy = head (fromJust $! dataConInstArgTys nilCon [(LitTy (NumTy 0)) + ,resTy]) + consCoTy n = head (fromJust $! dataConInstArgTys consCon + [(LitTy (NumTy n)) + ,resTy + ,(LitTy (NumTy (n-1)))]) + +-- | Append elements to the supplied vector +appendToVec :: DataCon -- ^ The Cons (:>) constructor + -> Type -- ^ Element type + -> Term -- ^ The vector to append the elements to + -> Integer -- ^ Length of the vector + -> [Term] -- ^ Elements to append + -> Term +appendToVec consCon resTy vec = go + where + go _ [] = vec + go n (x:xs) = mkApps (Data consCon) [Right (LitTy (NumTy n)) + ,Right resTy + ,Right (LitTy (NumTy (n-1))) + ,Left (Prim "_CO_" (consCoTy n)) + ,Left x + ,Left (go (n-1) xs)] + + consCoTy n = head (fromJust $! dataConInstArgTys consCon + [(LitTy (NumTy n)) + ,resTy + ,(LitTy (NumTy (n-1)))]) + +-- | Create let-bindings with case-statements that select elements out of a +-- vector. Returns both the variables to which element-selections are bound +-- and the let-bindings +extractElems :: DataCon -- ^ The Cons (:>) constructor + -> Type -- ^ The element type + -> Char -- ^ Char to append to the bound variable names + -> Integer -- ^ Length of the vector + -> Term -- ^ The vector + -> [(Term,[LetBinding])] +extractElems consCon resTy s maxN = go maxN + where + go :: Integer -> Term -> [(Term,[LetBinding])] + go 0 _ = [] + go n e = (elVar + ,[(Id elBNm (embed resTy) ,embed lhs) + ,(Id restBNm (embed restTy),embed rhs) + ] + ) : + go (n-1) (Var restTy restBNm) + + where + elBNm = string2SystemName ("el" ++ s:show (maxN-n)) + restBNm = string2SystemName ("rest" ++ s:show (maxN-n)) + elVar = Var resTy elBNm + pat = DataPat (embed consCon) (rebind [mTV] [co,el,rest]) + elPatNm = string2SystemName "el" + restPatNm = string2SystemName "rest" + lhs = Case e resTy [bind pat (Var resTy elPatNm)] + rhs = Case e restTy [bind pat (Var restTy restPatNm)] + + mName = string2SystemName "m" + mTV = TyVar mName (embed typeNatKind) + tys = [(LitTy (NumTy n)),resTy,(LitTy (NumTy (n-1)))] + (Just idTys) = dataConInstArgTys consCon tys + [co,el,rest] = zipWith Id [string2SystemName "_co_",elPatNm, restPatNm] + (map embed idTys) + restTy = last (fromJust (dataConInstArgTys consCon tys)) + + +-- | Create let-bindings with case-statements that select elements out of a +-- tree. Returns both the variables to which element-selections are bound +-- and the let-bindings +extractTElems :: DataCon -- ^ The 'LR' constructor + -> DataCon -- ^ The 'BR' constructor + -> Type -- ^ The element type + -> Char -- ^ Char to append to the bound variable names + -> Integer -- ^ Depth of the tree + -> Term -- ^ The tree + -> ([Term],[LetBinding]) +extractTElems lrCon brCon resTy s maxN = go maxN [0..(2^(maxN+1))-2] [0..(2^maxN - 1)] + where + go :: Integer -> [Int] -> [Int] -> Term -> ([Term],[LetBinding]) + go 0 _ ks e = ([elVar],[(Id elBNm (embed resTy), embed lhs)]) + where + elBNm = string2SystemName ("el" ++ s:show (head ks)) + elVar = Var resTy elBNm + pat = DataPat (embed lrCon) (rebind [] [co,el]) + elPatNm = string2SystemName "el" + lhs = Case e resTy [bind pat (Var resTy elPatNm)] + + tys = [LitTy (NumTy 0),resTy] + (Just idTys) = dataConInstArgTys lrCon tys + [co,el] = zipWith Id [string2SystemName "_co_",elPatNm] + (map embed idTys) + + go n bs ks e = (lVars ++ rVars,(Id ltBNm (embed brTy),embed ltLhs): + (Id rtBNm (embed brTy),embed rtLhs): + (lBinds ++ rBinds)) + where + ltBNm = string2SystemName ("lt" ++ s:show b0) + rtBNm = string2SystemName ("rt" ++ s:show b1) + ltVar = Var brTy ltBNm + rtVar = Var brTy rtBNm + pat = DataPat (embed brCon) (rebind [mTV] [co,lt,rt]) + ltPatNm = string2SystemName "lt" + rtPatNm = string2SystemName "rt" + ltLhs = Case e brTy [bind pat (Var brTy ltPatNm)] + rtLhs = Case e brTy [bind pat (Var brTy rtPatNm)] + + mName = string2SystemName "m" + mTV = TyVar mName (embed typeNatKind) + tys = [LitTy (NumTy n),resTy,LitTy (NumTy (n-1))] + (Just idTys) = dataConInstArgTys brCon tys + [co,lt,rt] = zipWith Id [string2SystemName "_co_",ltPatNm,rtPatNm] + (map embed idTys) + brTy = last idTys + (kL,kR) = splitAt (length ks `div` 2) ks + (b0:bL,b1:bR) = splitAt (length bs `div` 2) bs + + (lVars,lBinds) = go (n-1) bL kL ltVar + (rVars,rBinds) = go (n-1) bR kR rtVar + +-- | Create a vector of supplied elements +mkRTree :: DataCon -- ^ The LR constructor + -> DataCon -- ^ The BR constructor + -> Type -- ^ Element type + -> Integer -- ^ Depth of the tree + -> [Term] -- ^ Elements to put in the tree + -> Term +mkRTree lrCon brCon resTy = go + where + go _ [x] = mkApps (Data lrCon) [Right (LitTy (NumTy 0)) + ,Right resTy + ,Left (Prim "_CO_" lrCoTy) + ,Left x + ] + + go n xs = + let (xsL,xsR) = splitAt (length xs `div` 2) xs + in mkApps (Data brCon) [Right (LitTy (NumTy n)) + ,Right resTy + ,Right (LitTy (NumTy (n-1))) + ,Left (Prim "_CO_" (brCoTy n)) + ,Left (go (n-1) xsL) + ,Left (go (n-1) xsR)] + + lrCoTy = head (fromJust $! dataConInstArgTys lrCon [(LitTy (NumTy 0)) + ,resTy]) + brCoTy n = head (fromJust $! dataConInstArgTys brCon + [(LitTy (NumTy n)) + ,resTy + ,(LitTy (NumTy (n-1)))]) + +-- | Determine whether a type is isomorphic to "Clash.Signal.Internal.Signal'" +-- +-- It is i.e.: +-- +-- * Signal' clk a +-- * (Signal' clk a, Signal' clk b) +-- * Vec n (Signal' clk a) +-- * data Wrap = W (Signal clk' Int) +-- * etc. +isSignalType :: HashMap TyConOccName TyCon -> Type -> Bool +isSignalType tcm ty = go HashSet.empty ty + where + go tcSeen (tyView -> TyConApp tcNm args) = case name2String tcNm of + "Clash.Signal.Internal.Signal" -> True + _ | tcNm `HashSet.member` tcSeen -> False -- Do not follow rec types + | otherwise -> case HashMap.lookup (nameOcc tcNm) tcm of + Just tc -> let dcs = tyConDataCons tc + dcInsArgTys = concat + $ mapMaybe (`dataConInstArgTys` args) dcs + tcSeen' = HashSet.insert tcNm tcSeen + in any (go tcSeen') dcInsArgTys + Nothing -> traceIf True ($(curLoc) ++ "isSignalType: " ++ show tcNm + ++ " not found.") False + + go _ _ = False + +isClockOrReset + :: HashMap TyConOccName TyCon + -> Type + -> Bool +isClockOrReset m (coreView m -> Just ty) = isClockOrReset m ty +isClockOrReset _ (tyView -> TyConApp tcNm _) = case name2String tcNm of + "Clash.Signal.Internal.Clock" -> True + "Clash.Signal.Internal.Reset" -> True + _ -> False +isClockOrReset _ _ = False + +tyNatSize :: HMS.HashMap TyConOccName TyCon + -> Type + -> Except String Integer +tyNatSize m (coreView m -> Just ty) = tyNatSize m ty +tyNatSize _ (LitTy (NumTy i)) = return i +tyNatSize _ ty = throwE $ $(curLoc) ++ "Cannot reduce an integer: " ++ show ty diff --git a/src/Clash/Core/Var.hs b/src/Clash/Core/Var.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Core/Var.hs @@ -0,0 +1,61 @@ +{-| + Copyright : (C) 2012-2016, University of Twente, + 2017, Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Variables in CoreHW +-} + +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Clash.Core.Var + ( Var (..) + , Id + , TyVar + , modifyVarName + ) +where + +import Control.DeepSeq (NFData (..)) +import Data.Hashable (Hashable) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Unbound.Generics.LocallyNameless (Alpha,Embed,Subst(..)) + +import Clash.Core.Name (Name) +import {-# SOURCE #-} Clash.Core.Term (Term) +import {-# SOURCE #-} Clash.Core.Type (Kind, Type) + +-- | Variables in CoreHW +data Var a + -- | Constructor for type variables + = TyVar + { varName :: Name a + , varKind :: Embed Kind + } + -- | Constructor for term variables + | Id + { varName :: Name a + , varType :: Embed Type + } + deriving (Eq,Show,Generic,NFData,Hashable) + +-- | Term variable +type Id = Var Term +-- | Type variable +type TyVar = Var Type + +instance (Typeable a, Alpha a) => Alpha (Var a) +instance Generic b => Subst Term (Var b) +instance Generic b => Subst Type (Var b) + +-- | Change the name of a variable +modifyVarName :: + (Name a -> Name a) + -> Var a + -> Var a +modifyVarName f (TyVar n k) = TyVar (f n) k +modifyVarName f (Id n t) = Id (f n) t diff --git a/src/Clash/Driver.hs b/src/Clash/Driver.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Driver.hs @@ -0,0 +1,403 @@ +{-| + Copyright : (C) 2012-2016, University of Twente, + 2016-2017, Myrtle Software Ltd, + 2017 , QBayLogic, Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Module that connects all the parts of the Clash compiler library +-} + +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +module Clash.Driver where + +import qualified Control.Concurrent.Supply as Supply +import Control.DeepSeq +import Control.Exception (tryJust, bracket) +import Control.Lens ((^.), _5) +import Control.Monad (guard, when, unless) +import Control.Monad.State (evalState, get) +import Data.Hashable (hash) +import qualified Data.HashMap.Lazy as HML +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HashSet +import Data.IntMap (IntMap) +import Data.Maybe (fromMaybe) +import Data.Semigroup.Monad +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as Text +import qualified Data.Text.Lazy.IO as Text +import Data.Text.Prettyprint.Doc (pretty) +import Data.Text.Prettyprint.Doc.Extra + (Doc, LayoutOptions (..), PageWidth (..) , layoutPretty, renderLazy, + renderOneLine) +import qualified Data.Time.Clock as Clock +import qualified System.Directory as Directory +import System.FilePath ((), (<.>)) +import qualified System.FilePath as FilePath +import qualified System.IO as IO +import System.IO.Error (isDoesNotExistError) +import qualified Text.PrettyPrint.ANSI.Leijen as ANSI +import Text.Trifecta.Result +import Text.Read (readMaybe) + +import GHC.BasicTypes.Extra () + +import Clash.Annotations.TopEntity (TopEntity (..)) +import Clash.Annotations.TopEntity.Extra () +import Clash.Backend +import Clash.Core.Evaluator (PrimEvaluator) +import Clash.Core.Name (Name (..), name2String) +import Clash.Core.Term (Term, TmName, TmOccName) +import Clash.Core.Type (Type) +import Clash.Core.TyCon (TyCon, TyConName, TyConOccName) +import Clash.Driver.Types +import Clash.Netlist (genNetlist) +import Clash.Netlist.Util (genComponentName) +import Clash.Netlist.BlackBox.Parser (runParse) +import Clash.Netlist.BlackBox.Types (BlackBoxTemplate) +import Clash.Netlist.Types (Component (..), HWType) +import Clash.Normalize (checkNonRecursive, cleanupGraph, + normalize, runNormalization) +import Clash.Normalize.Util (callGraph) +import Clash.Primitives.Types +import Clash.Util (first, second) + +-- | Create a set of target HDL files for a set of functions +generateHDL + :: forall backend . Backend backend + => BindingMap + -- ^ Set of functions + -> Maybe backend + -> PrimMap (Text.Text) + -- ^ Primitive / BlackBox Definitions + -> HashMap TyConOccName TyCon + -- ^ TyCon cache + -> IntMap TyConName + -- ^ Tuple TyCon cache + -> (HashMap TyConOccName TyCon -> Bool -> Type -> Maybe (Either String HWType)) + -- ^ Hardcoded 'Type' -> 'HWType' translator + -> PrimEvaluator + -- ^ Hardcoded evaluator (delta-reduction) + -> [( TmName + , Type + , Maybe TopEntity + , Maybe TmName + )] + -- ^ topEntity bndr + -- + (maybe) TopEntity annotation + -- + (maybe) testBench bndr + -> ClashOpts + -- ^ Debug information level for the normalization process + -> (Clock.UTCTime,Clock.UTCTime) + -> IO () +generateHDL bindingsMap hdlState primMap tcm tupTcm typeTrans eval topEntities + opts (startTime,prepTime) = go prepTime [] topEntities where + + primMap' = HM.map parsePrimitive primMap + + -- No more TopEntities to process + go prevTime _ [] = putStrLn $ "Total compilation took " ++ + show (Clock.diffUTCTime prevTime startTime) + + -- Process the next TopEntity + go prevTime seen ((topEntity,_,annM,benchM):topEntities') = do + putStrLn $ "Compiling: " ++ name2String topEntity + + -- Some initial setup + let modName = maybe (takeWhile (/= '.') (name2String topEntity)) t_name annM + iw = opt_intWidth opts + hdlsyn = opt_hdlSyn opts + hdlState' = setModName modName + $ fromMaybe (initBackend iw hdlsyn :: backend) hdlState + hdlDir = fromMaybe "." (opt_hdlDir opts) + Clash.Backend.name hdlState' + takeWhile (/= '.') (name2String topEntity) + mkId = evalState mkIdentifier hdlState' + extId = evalState extendIdentifier hdlState' + topName = genComponentName [] mkId topEntity + topNm = maybe topName + (Text.pack . t_name) + annM + + unless (opt_cachehdl opts) $ putStrLn "Ignoring .manifest files" + + -- Calculate the hash over the callgraph and the topEntity annotation + (sameTopHash,sameBenchHash,manifest) <- do + let topHash = hash (annM,callGraphBindings bindingsMap (nameOcc topEntity)) + benchHashM = fmap (hash . (annM,) . callGraphBindings bindingsMap . nameOcc) benchM + manifestI = Manifest (topHash,benchHashM) [] [] [] [] [] + + manFile = maybe (hdlDir Text.unpack topNm <.> "manifest") + (\ann -> hdlDir t_name ann t_name ann <.> "manifest") + annM + manM <- if not (opt_cachehdl opts) + then return Nothing -- ignore manifest file because -fclash-nocache + else (>>= readMaybe) . either (const Nothing) Just <$> + tryJust (guard . isDoesNotExistError) (readFile manFile) + return (maybe (False,False,manifestI) + (\man -> (fst (manifestHash man) == topHash + ,snd (manifestHash man) == benchHashM + ,man {manifestHash = (topHash,benchHashM)} + )) + manM) + + (supplyN,supplyTB) <- Supply.splitSupply + . snd + . Supply.freshId + <$> Supply.newSupply + let topEntityNames = map (\(x,_,_,_) -> nameOcc x) topEntities + + (topTime,manifest',seen') <- if sameTopHash + then do + putStrLn ("Using cached result for: " ++ name2String topEntity) + topTime <- Clock.getCurrentTime + return (topTime,manifest,componentNames manifest ++ seen) + else do + -- 1. Normalise topEntity + let transformedBindings = normalizeEntity bindingsMap primMap' tcm tupTcm + typeTrans eval topEntityNames opts supplyN + (nameOcc topEntity) + + normTime <- transformedBindings `deepseq` Clock.getCurrentTime + let prepNormDiff = Clock.diffUTCTime normTime prevTime + putStrLn $ "Normalisation took " ++ show prepNormDiff + + -- 2. Generate netlist for topEntity + (netlist,dfiles,seen') <- genNetlist transformedBindings topEntities primMap' + tcm typeTrans [] iw mkId extId seen + hdlDir (nameOcc topEntity) + + netlistTime <- netlist `deepseq` Clock.getCurrentTime + let normNetDiff = Clock.diffUTCTime netlistTime normTime + putStrLn $ "Netlist generation took " ++ show normNetDiff + + -- 3. Generate topEntity wrapper + let topComponent = snd . head $ + filter (\(_,Component cName _ _ _) -> maybe + (Text.isSuffixOf (genComponentName [] mkId topEntity)) + (\te n -> n == Text.pack (t_name te)) annM + cName) + netlist + (hdlDocs,manifest') = createHDL hdlState' modName netlist topComponent + (Text.unpack topNm, Right manifest) + dir = hdlDir maybe "" t_name annM + prepareDir (opt_cleanhdl opts) (extension hdlState') dir + mapM_ (writeHDL dir) hdlDocs + copyDataFiles (opt_importPaths opts) dir dfiles + + topTime <- hdlDocs `seq` Clock.getCurrentTime + return (topTime,manifest',seen') + + benchTime <- case benchM of + Just tb | not sameBenchHash -> do + putStrLn $ "Compiling: " ++ name2String tb + + let modName' = Text.unpack (genComponentName [] mkId tb) + hdlState2 = setModName modName' hdlState' + + -- 1. Normalise testBench + let transformedBindings = normalizeEntity bindingsMap primMap' tcm tupTcm + typeTrans eval topEntityNames opts supplyTB (nameOcc tb) + normTime <- transformedBindings `deepseq` Clock.getCurrentTime + let prepNormDiff = Clock.diffUTCTime normTime topTime + putStrLn $ "Testbench normalisation took " ++ show prepNormDiff + + -- 2. Generate netlist for topEntity + (netlist,dfiles,_) <- genNetlist transformedBindings topEntities primMap' + tcm typeTrans [] iw mkId extId seen' + hdlDir (nameOcc tb) + + netlistTime <- netlist `deepseq` Clock.getCurrentTime + let normNetDiff = Clock.diffUTCTime netlistTime normTime + putStrLn $ "Testbench netlist generation took " ++ show normNetDiff + + -- 3. Write HDL + let (hdlDocs,_) = createHDL hdlState2 modName' netlist undefined + (Text.unpack topNm, Left manifest') + dir = hdlDir maybe "" t_name annM modName' + prepareDir (opt_cleanhdl opts) (extension hdlState2) dir + writeHDL (hdlDir maybe "" t_name annM) (head hdlDocs) + mapM_ (writeHDL dir) (tail hdlDocs) + copyDataFiles (opt_importPaths opts) dir dfiles + + hdlDocs `seq` Clock.getCurrentTime + + Just tb -> do + let tb' = name2String tb + putStrLn ("Compiling: " ++ tb') + putStrLn ("Using cached result for: " ++ tb') + return topTime + + Nothing -> return topTime + + go benchTime seen' topEntities' + +parsePrimitive :: Primitive Text -> Primitive BlackBoxTemplate +parsePrimitive (BlackBox pNm oReg libM imps inc templT) = + case either (fmap Left . runParse) (fmap Right . runParse) templT of + Failure errInfo + -> error (ANSI.displayS (ANSI.renderCompact (_errDoc errInfo)) "") + Success templ + -> BlackBox pNm oReg (map parseBB libM) (map parseBB imps) inc' templ + where + inc' = case fmap (second runParse) inc of + Just (x,Success t) -> Just (x,t) + _ -> Nothing + + parseBB :: Text -> BlackBoxTemplate + parseBB t = case runParse t of + Failure errInfo + -> error (ANSI.displayS (ANSI.renderCompact (_errDoc errInfo)) "") + Success templ + -> templ + +parsePrimitive (Primitive pNm typ) = Primitive pNm typ + +-- | Pretty print Components to HDL Documents +createHDL + :: Backend backend + => backend + -- ^ Backend + -> String + -- ^ Module hierarchy root + -> [(SrcSpan,Component)] + -- ^ List of components + -> Component + -- ^ Top component + -> (String, Either Manifest Manifest) + -- ^ Name of the manifest file + -- + Either: + -- * Left manifest: Only write/update the hashes of the @manifest@ + -- * Right manifest: Update all fields of the @manifest@ + -> ([(String,Doc)],Manifest) + -- ^ The pretty-printed HDL documents + -- + The update manifest file +createHDL backend modName components top (topName,manifestE) = flip evalState backend $ getMon $ do + (hdlNmDocs,incs) <- unzip <$> mapM (uncurry (genHDL modName)) components + hwtys <- HashSet.toList <$> extractTypes <$> Mon get + typesPkg <- mkTyPackage modName hwtys + let hdl = map (first (<.> Clash.Backend.extension backend)) (typesPkg ++ hdlNmDocs) + qincs = concat incs + topFiles = hdl ++ qincs + manifest <- either return (\m -> do + let topName' = Text.pack topName + let topInNames = map fst (inputs top) + topInTypes <- mapM (fmap renderOneLine . hdlType (External topName') . snd) (inputs top) + let topOutNames = map (fst . snd) (outputs top) + topOutTypes <- mapM (fmap renderOneLine . hdlType (External topName') . snd . snd) (outputs top) + let compNames = map (componentName.snd) components + return (m { portInNames = topInNames + , portInTypes = topInTypes + , portOutNames = topOutNames + , portOutTypes = topOutTypes + , componentNames = compNames + }) + ) manifestE + let manDoc = ( topName <.> "manifest" + , pretty (Text.pack (show manifest))) + return (manDoc:topFiles,manifest) + +-- | Prepares the directory for writing HDL files. This means creating the +-- dir if it does not exist and removing all existing .hdl files from it. +prepareDir :: Bool -- ^ Remove existing HDL files + -> String -- ^ File extension of the HDL files. + -> String + -> IO () +prepareDir cleanhdl ext dir = do + -- Create the dir if needed + Directory.createDirectoryIfMissing True dir + -- Clean the directory when needed + when cleanhdl $ do + -- Find all HDL files in the directory + files <- Directory.getDirectoryContents dir + let to_remove = filter ((==ext) . FilePath.takeExtension) files + -- Prepend the dirname to the filenames + let abs_to_remove = map (FilePath.combine dir) to_remove + -- Remove the files + mapM_ Directory.removeFile abs_to_remove + +-- | Writes a HDL file to the given directory +writeHDL :: FilePath -> (String, Doc) -> IO () +writeHDL dir (cname, hdl) = do + let rendered = renderLazy (layoutPretty (LayoutOptions (AvailablePerLine 120 0.4)) hdl) + -- remove blank lines to keep things clean + clean = Text.unlines + . map (\t -> if Text.all (==' ') t then Text.empty else t) + . Text.lines + bracket (IO.openFile (dir cname) IO.WriteMode) IO.hClose $ \h -> do + Text.hPutStr h (clean rendered) + Text.hPutStr h (Text.pack "\n") + +copyDataFiles :: [FilePath] -> FilePath -> [(String,FilePath)] -> IO () +copyDataFiles idirs dir = mapM_ (copyFile' idirs) + where + copyFile' dirs (nm,old) = do + oldExists <- Directory.doesFileExist old + if oldExists + then Directory.copyFile old new + else goImports dirs + where + new = dir FilePath. nm + + goImports [] = do + oldExists <- Directory.doesFileExist old + if oldExists + then Directory.copyFile old new + else unless (null old) (putStrLn ("WARNING: file " ++ show old ++ " does not exist")) + goImports (d:ds) = do + let old2 = d FilePath. old + old2Exists <- Directory.doesFileExist old2 + if old2Exists + then Directory.copyFile old2 new + else goImports ds + +-- | Get all the terms corresponding to a call graph +callGraphBindings + :: BindingMap + -- ^ All bindings + -> TmOccName + -- ^ Root of the call graph + -> [Term] +callGraphBindings bindingsMap tm = + map ((^. _5) . (bindingsMap HM.!)) (HM.keys cg) + where + cg = callGraph bindingsMap tm + +-- | Normalize a complete hierarchy +normalizeEntity + :: BindingMap + -- ^ All bindings + -> PrimMap BlackBoxTemplate + -- ^ BlackBox HDL templates + -> HashMap TyConOccName TyCon + -- ^ TyCon cache + -> IntMap TyConName + -- ^ Tuple TyCon cache + -> (HashMap TyConOccName TyCon -> Bool -> Type -> Maybe (Either String HWType)) + -- ^ Hardcoded 'Type' -> 'HWType' translator + -> PrimEvaluator + -- ^ Hardcoded evaluator (delta-reduction) + -> [TmOccName] + -- ^ TopEntities + -> ClashOpts + -- ^ Debug information level for the normalization process + -> Supply.Supply + -- ^ Unique supply + -> TmOccName + -- ^ root of the hierarchy + -> BindingMap +normalizeEntity bindingsMap primMap tcm tupTcm typeTrans eval topEntities + opts supply tm = transformedBindings + where + doNorm = do norm <- normalize [tm] + let normChecked = checkNonRecursive norm + cleanupGraph tm normChecked + transformedBindings = runNormalization opts supply bindingsMap + typeTrans tcm tupTcm eval primMap HML.empty + topEntities doNorm diff --git a/src/Clash/Driver/Types.hs b/src/Clash/Driver/Types.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Driver/Types.hs @@ -0,0 +1,89 @@ +{-| + Copyright : (C) 2013-2016, University of Twente, + 2016-2017, Myrtle Software Ltd, + 2017 , QBayLogic, Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Type definitions used by the Driver module +-} + +module Clash.Driver.Types + (module Clash.Driver.Types + ,SrcSpan, noSrcSpan + ) +where + +import Control.Exception (Exception) +import Data.HashMap.Lazy (HashMap) +import Data.Text.Lazy (Text) + +import BasicTypes (InlineSpec) +import SrcLoc (SrcSpan, noSrcSpan) + +import Clash.Core.Term (Term,TmName,TmOccName) +import Clash.Core.Type (Type) + +import Clash.Netlist.BlackBox.Types (HdlSyn) + +-- | Global function binders +-- +-- Global functions cannot be mutually recursive, only self-recursive +type BindingMap = HashMap TmOccName (TmName,Type,SrcSpan,InlineSpec,Term) + +-- | Debug Message Verbosity +data DebugLevel + = DebugNone -- ^ Don't show debug messages + | DebugFinal -- ^ Show completely normalized expressions + | DebugName -- ^ Names of applied transformations + | DebugApplied -- ^ Show sub-expressions after a successful rewrite + | DebugAll -- ^ Show all sub-expressions on which a rewrite is attempted + deriving (Eq,Ord,Read) + +data ClashOpts = ClashOpts { opt_inlineLimit :: Int + , opt_specLimit :: Int + , opt_inlineFunctionLimit :: Word + , opt_inlineConstantLimit :: Word + , opt_dbgLevel :: DebugLevel + , opt_cachehdl :: Bool + , opt_cleanhdl :: Bool + , opt_intWidth :: Int + , opt_hdlDir :: Maybe String + , opt_hdlSyn :: HdlSyn + , opt_errorExtra :: Bool + , opt_floatSupport :: Bool + , opt_allowZero :: Bool + , opt_importPaths :: [FilePath] + } + +data ClashException = ClashException SrcSpan String (Maybe String) + +instance Show ClashException where + show (ClashException _ s eM) = s ++ "\n" ++ maybe "" id eM + +instance Exception ClashException + +-- | Information about the generated HDL between (sub)runs of the compiler +data Manifest + = Manifest + { manifestHash :: (Int,Maybe Int) + -- ^ Hash of the TopEntity and all its dependencies + -- + (maybe) Hash of the TestBench and all its dependencies + , portInNames :: [Text] + , portInTypes :: [Text] + -- ^ The rendered versions of the types of the input ports of the TopEntity + -- + -- Used when dealing with multiple @TopEntity@s who have different names + -- for types which are structurally equal + , portOutNames :: [Text] + , portOutTypes :: [Text] + -- ^ The rendered versions of the types of the output ports of the TopEntity + -- + -- Used when dealing with multiple @TopEntity@s who have different names + -- for types which are structurally equal + , componentNames :: [Text] + -- ^ Names of all the generated components for the @TopEntity@ (does not + -- include the names of the components of the @TestBench@ accompanying + -- the @TopEntity@). + } + deriving (Show,Read) diff --git a/src/Clash/Netlist.hs b/src/Clash/Netlist.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Netlist.hs @@ -0,0 +1,596 @@ +{-| + Copyright : (C) 2012-2016, University of Twente, + 2016-2017, Myrtle Software Ltd, + 2017 , Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Create Netlists out of normalized CoreHW Terms +-} + +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +module Clash.Netlist where + +import Control.Exception (throw) +import Control.Lens ((.=),(^.),_1,_3) +import qualified Control.Lens as Lens +import Control.Monad.IO.Class (liftIO) +import Control.Monad.State.Strict (runStateT) +import Data.Binary.IEEE754 (floatToWord, doubleToWord) +import Data.Char (ord) +import Data.Either (lefts,partitionEithers) +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Lazy as HashMap +import Data.List (elemIndex) +import Data.Maybe (catMaybes) +import qualified Data.Text.Lazy as Text +import System.FilePath ((), (<.>)) +import Text.Read (readMaybe) +import Unbound.Generics.LocallyNameless + (Embed (..), runFreshMT, unbind, unembed, unrebind) + +import Outputable (ppr, showSDocUnsafe) +import SrcLoc (SrcSpan,isGoodSrcSpan,noSrcSpan) + +import Clash.Annotations.TopEntity (TopEntity (..)) +import Clash.Core.DataCon (DataCon (..)) +import Clash.Core.FreeVars (typeFreeVars) +import Clash.Core.Literal (Literal (..)) +import Clash.Core.Name (Name(..), name2String) +import Clash.Core.Pretty (showDoc) +import Clash.Core.Term + (Alt, Pat (..), Term (..), TmName, TmOccName) +import qualified Clash.Core.Term as Core +import Clash.Core.Type (Type (..), splitFunTys) +import Clash.Core.TyCon + (TyCon, TyConOccName) +import Clash.Core.Util (collectArgs, termType) +import Clash.Core.Var (Id, Var (..)) +import Clash.Driver.Types + (BindingMap, ClashException (..)) +import Clash.Netlist.BlackBox +import Clash.Netlist.BlackBox.Types (BlackBoxTemplate) +import Clash.Netlist.Id +import Clash.Netlist.Types as HW +import Clash.Netlist.Util +import Clash.Primitives.Types as P +import Clash.Util + +-- | Generate a hierarchical netlist out of a set of global binders with +-- @topEntity@ at the top. +genNetlist :: BindingMap + -- ^ Global binders + -> [(TmName,Type,Maybe TopEntity,Maybe TmName)] + -- ^ All the TopEntities + -> PrimMap BlackBoxTemplate + -- ^ Primitive definitions + -> HashMap TyConOccName TyCon + -- ^ TyCon cache + -> (HashMap TyConOccName TyCon -> Bool -> Type -> Maybe (Either String HWType)) + -- ^ Hardcoded Type -> HWType translator + -> [(String,FilePath)] + -- ^ Set of collected data-files + -> Int + -- ^ Int/Word/Integer bit-width + -> (IdType -> Identifier -> Identifier) + -- ^ valid identifiers + -> (IdType -> Identifier -> Identifier -> Identifier) + -- ^ extend valid identifiers + -> [Identifier] + -- ^ Seen components + -> FilePath + -- ^ HDL dir + -> TmOccName + -- ^ Name of the @topEntity@ + -> IO ([(SrcSpan,Component)],[(String,FilePath)],[Identifier]) +genNetlist globals tops primMap tcm typeTrans dfiles iw mkId extId seen env topEntity = do + (_,s) <- runNetlistMonad globals (mkTopEntityMap tops) primMap tcm typeTrans + dfiles iw mkId extId seen env $ genComponent topEntity + return (HashMap.elems $ _components s, _dataFiles s, _seenComps s) + where + mkTopEntityMap + :: [(TmName,Type,Maybe TopEntity,Maybe TmName)] + -> HashMap TmOccName (Type, Maybe TopEntity) + mkTopEntityMap = HashMap.fromList . map (\(a,b,c,_) -> (nameOcc a,(b,c))) + +-- | Run a NetlistMonad action in a given environment +runNetlistMonad :: BindingMap + -- ^ Global binders + -> HashMap TmOccName (Type, Maybe TopEntity) + -- ^ TopEntity annotations + -> PrimMap BlackBoxTemplate + -- ^ Primitive Definitions + -> HashMap TyConOccName TyCon + -- ^ TyCon cache + -> (HashMap TyConOccName TyCon -> Bool -> Type -> Maybe (Either String HWType)) + -- ^ Hardcode Type -> HWType translator + -> [(String,FilePath)] + -- ^ Set of collected data-files + -> Int + -- ^ Int/Word/Integer bit-width + -> (IdType -> Identifier -> Identifier) + -- ^ valid identifiers + -> (IdType -> Identifier -> Identifier -> Identifier) + -- ^ extend valid identifiers + -> [Identifier] + -- ^ Seen components + -> FilePath + -- ^ HDL dir + -> NetlistMonad a + -- ^ Action to run + -> IO (a, NetlistState) +runNetlistMonad s tops p tcm typeTrans dfiles iw mkId extId seenIds_ env + = runFreshMT + . flip runStateT s' + . runNetlist + where + s' = NetlistState s 0 HashMap.empty p typeTrans tcm (Text.empty,noSrcSpan) dfiles iw mkId extId [] seenIds' names tops env + (seenIds',names) = genNames mkId seenIds_ HashMap.empty (HashMap.elems (HashMap.map (^. _1) s)) + +genNames :: (IdType -> Identifier -> Identifier) + -> [Identifier] + -> HashMap TmOccName Identifier + -> [TmName] + -> ([Identifier], HashMap TmOccName Identifier) +genNames mkId = go + where + go s m [] = (s,m) + go s m (nm:nms) = let nm' = genComponentName s mkId nm + s' = nm':s + m' = HashMap.insert (nameOcc nm) nm' m + in go s' m' nms + +-- | Generate a component for a given function (caching) +genComponent + :: TmOccName + -- ^ Name of the function + -> NetlistMonad (SrcSpan,Component) +genComponent compName = do + compExprM <- fmap (HashMap.lookup compName) $ Lens.use bindings + case compExprM of + Nothing -> do + (_,sp) <- Lens.use curCompNm + throw (ClashException sp ($(curLoc) ++ "No normalized expression found for: " ++ show compName) Nothing) + Just (_,_,_,_,expr_) -> do + makeCached compName components $ genComponentT compName expr_ + +-- | Generate a component for a given function +genComponentT + :: TmOccName + -- ^ Name of the function + -> Term + -- ^ Corresponding term + -> NetlistMonad (SrcSpan,Component) +genComponentT compName componentExpr = do + varCount .= 0 + componentName1 <- (HashMap.! compName) <$> Lens.use componentNames + topEntMM <- fmap snd . HashMap.lookup compName <$> Lens.use topEntityAnns + let componentName2 = maybe componentName1 + (maybe componentName1 (Text.pack . t_name)) + topEntMM + sp <- ((^. _3) . (HashMap.! compName)) <$> Lens.use bindings + curCompNm .= (componentName2,sp) + + tcm <- Lens.use tcCache + + seenIds .= [] + (compInps,argWrappers,compOutps,resUnwrappers,binders,result) <- do + normalizedM <- splitNormalized tcm componentExpr + case normalizedM of + Right normalized -> mkUniqueNormalized topEntMM normalized + Left err -> throw (ClashException sp err Nothing) + + netDecls <- fmap catMaybes . mapM mkNetDecl $ filter ((/= result) . varName . fst) binders + decls <- concat <$> mapM (uncurry mkDeclarations . second unembed) binders + + Just (NetDecl' _ rw _ _) <- mkNetDecl . head $ filter ((==result) . varName . fst) binders + + let (compOutps',resUnwrappers') = case compOutps of + [oport] -> ([(rw,oport)],resUnwrappers) + _ -> let NetDecl n res resTy = head resUnwrappers + in (map (Wire,) compOutps + ,NetDecl' n rw res (Right resTy):tail resUnwrappers + ) + component = Component componentName2 compInps compOutps' + (netDecls ++ argWrappers ++ decls ++ resUnwrappers') + return (sp,component) + +mkNetDecl :: (Id, Embed Term) -> NetlistMonad (Maybe Declaration) +mkNetDecl (id_,tm) = do + hwTy <- unsafeCoreTypeToHWTypeM $(curLoc) (unembed (varType id_)) + wr <- wireOrReg (unembed tm) + if isVoid hwTy + then return Nothing + else return . Just $ NetDecl' (addSrcNote (nameLoc nm)) + wr + (Text.pack (name2String nm)) + (Right hwTy) + + where + nm = varName id_ + + wireOrReg :: Term -> NetlistMonad WireOrReg + wireOrReg (Case _ _ (_:_:_)) = return Reg + wireOrReg (collectArgs -> (Prim nm' _,_)) = do + bbM <- HashMap.lookup nm' <$> Lens.use primitives + case bbM of + Just (BlackBox {..}) | outputReg -> return Reg + _ -> return Wire + wireOrReg _ = return Wire + + addSrcNote loc = if isGoodSrcSpan loc + then Just (Text.pack (showSDocUnsafe (ppr loc))) + else Nothing + +-- | Generate a list of Declarations for a let-binder, return an empty list +-- if the bound expression is represented by 0 bits +mkDeclarations + :: Id + -- ^ LHS of the let-binder + -> Term + -- ^ RHS of the let-binder + -> NetlistMonad [Declaration] +mkDeclarations bndr e = do + hty <- unsafeCoreTypeToHWTypeM $(curLoc) (unembed (varType bndr)) + case hty of + Void {} -> return [] + _ -> mkDeclarations' bndr e + +-- | Generate a list of Declarations for a let-binder +mkDeclarations' + :: Id + -- ^ LHS of the let-binder + -> Term + -- ^ RHS of the let-binder + -> NetlistMonad [Declaration] +mkDeclarations' bndr (Var _ v) = mkFunApp bndr v [] + +mkDeclarations' _ e@(Case _ _ []) = do + (_,sp) <- Lens.use curCompNm + throw (ClashException sp ($(curLoc) ++ "Not in normal form: Case-decompositions with an empty list of alternatives not supported:\n\n" ++ showDoc e) Nothing) + +mkDeclarations' bndr (Case scrut altTy alts@(_:_:_)) = + mkSelection bndr scrut altTy alts + +mkDeclarations' bndr app = + let (appF,(args,tyArgs)) = second partitionEithers $ collectArgs app + in case appF of + Var _ f + | null tyArgs -> mkFunApp bndr f args + | otherwise -> do + (_,sp) <- Lens.use curCompNm + throw (ClashException sp ($(curLoc) ++ "Not in normal form: Var-application with Type arguments:\n\n" ++ showDoc app) Nothing) + _ -> do + (exprApp,declsApp) <- mkExpr False (Right bndr) (unembed $ varType bndr) app + let dstId = Text.pack . name2String $ varName bndr + assn = case exprApp of + Identifier _ Nothing -> [] + _ -> [Assignment dstId exprApp] + return (declsApp ++ assn) + +-- | Generate a declaration that selects an alternative based on the value of +-- the scrutinee +mkSelection + :: Id + -> Term + -> Type + -> [Alt] + -> NetlistMonad [Declaration] +mkSelection bndr scrut altTy alts = do + alts' <- reorderPats <$> mapM unbind alts + tcm <- Lens.use tcCache + scrutTy <- termType tcm scrut + scrutHTy <- unsafeCoreTypeToHWTypeM $(curLoc) scrutTy + altHTy <- unsafeCoreTypeToHWTypeM $(curLoc) altTy + scrutId <- extendIdentifier Extended + (Text.pack (name2String (varName bndr))) + (Text.pack "_selection") + (_,sp) <- Lens.use curCompNm + (scrutExpr,scrutDecls) <- first (mkScrutExpr sp scrutHTy (fst (head alts'))) <$> mkExpr True (Left scrutId) scrutTy scrut + (exprs,altsDecls) <- (second concat . unzip) <$> mapM (mkCondExpr scrutHTy) alts' + + let dstId = Text.pack . name2String $ varName bndr + return $! scrutDecls ++ altsDecls ++ [CondAssignment dstId altHTy scrutExpr scrutHTy exprs] + where + mkCondExpr :: HWType -> (Pat,Term) -> NetlistMonad ((Maybe HW.Literal,Expr),[Declaration]) + mkCondExpr scrutHTy (pat,alt) = do + altId <- extendIdentifier Extended + (Text.pack (name2String (varName bndr))) + (Text.pack "_sel_alt") + (altExpr,altDecls) <- mkExpr False (Left altId) altTy alt + (,altDecls) <$> case pat of + DefaultPat -> return (Nothing,altExpr) + DataPat (Embed dc) _ -> return (Just (dcToLiteral scrutHTy (dcTag dc)),altExpr) + LitPat (Embed (IntegerLiteral i)) -> return (Just (NumLit i),altExpr) + LitPat (Embed (IntLiteral i)) -> return (Just (NumLit i), altExpr) + LitPat (Embed (WordLiteral w)) -> return (Just (NumLit w), altExpr) + LitPat (Embed (CharLiteral c)) -> return (Just (NumLit . toInteger $ ord c), altExpr) + LitPat (Embed (Int64Literal i)) -> return (Just (NumLit i), altExpr) + LitPat (Embed (Word64Literal w)) -> return (Just (NumLit w), altExpr) + LitPat (Embed (NaturalLiteral n)) -> return (Just (NumLit n), altExpr) + _ -> do + (_,sp) <- Lens.use curCompNm + throw (ClashException sp ($(curLoc) ++ "Not an integer literal in LitPat:\n\n" ++ showDoc pat) Nothing) + + mkScrutExpr :: SrcSpan -> HWType -> Pat -> Expr -> Expr + mkScrutExpr sp scrutHTy pat scrutE = case pat of + DataPat (Embed dc) _ -> let modifier = Just (DC (scrutHTy,dcTag dc - 1)) + in case scrutE of + Identifier scrutId Nothing -> Identifier scrutId modifier + _ -> throw (ClashException sp ($(curLoc) ++ "Not in normal form: Not a variable reference or primitive as subject of a case-statement:\n\n" ++ show scrutE) Nothing) + _ -> scrutE + + -- GHC puts default patterns in the first position, we want them in the + -- last position. + reorderPats :: [(Pat,Term)] -> [(Pat,Term)] + reorderPats ((DefaultPat,e):alts') = alts' ++ [(DefaultPat,e)] + reorderPats alts' = alts' + +-- | Generate a list of Declarations for a let-binder where the RHS is a function application +mkFunApp + :: Id -- ^ LHS of the let-binder + -> TmName -- ^ Name of the applied function + -> [Term] -- ^ Function arguments + -> NetlistMonad [Declaration] +mkFunApp dst fun args = do + topAnns <- Lens.use topEntityAnns + tcm <- Lens.use tcCache + case HashMap.lookup (nameOcc fun) topAnns of + Just (ty,annM) + | let (fArgTys,fResTy) = splitFunTys tcm ty + , length fArgTys == length args + -> do + let dstId = Text.pack . name2String $ varName dst + argHWTys <- mapM (unsafeCoreTypeToHWTypeM $(curLoc)) fArgTys + -- Filter out the arguments of hwtype `Void` and only translate them + -- to the intermediate HDL afterwards + let argsBundled = zip argHWTys (zip args fArgTys) + argsFiltered = filter (not . isVoid . fst) argsBundled + argsFiltered' = map snd argsFiltered + hWTysFiltered = filter (not . isVoid) argHWTys + (argExprs,argDecls) <- second concat . unzip <$> + mapM (\(e,t) -> mkExpr False (Left dstId) t e) + argsFiltered' + dstHWty <- unsafeCoreTypeToHWTypeM $(curLoc) fResTy + env <- Lens.use hdlDir + manFile <- case annM of + Just ann -> return (env t_name ann t_name ann <.> "manifest") + Nothing -> do + mkId <- Lens.use mkIdentifierFn + let topName = genComponentName [] mkId fun + return (env (Text.unpack topName) <.> "manifest") + Just man <- readMaybe <$> liftIO (readFile manFile) + instDecls <- mkTopUnWrapper fun annM man (dstId,dstHWty) + (zip argExprs hWTysFiltered) + return (argDecls ++ instDecls) + + | otherwise -> error $ $(curLoc) ++ "under-applied TopEntity" + _ -> do + normalized <- Lens.use bindings + case HashMap.lookup (nameOcc fun) normalized of + Just _ -> do + (_,Component compName compInps [snd -> compOutp] _) <- preserveVarEnv $ genComponent (nameOcc fun) + if length args == length compInps + then do + argTys <- mapM (termType tcm) args + argHWTys <- mapM coreTypeToHWTypeM argTys + -- Filter out the arguments of hwtype `Void` and only translate + -- them to the intermediate HDL afterwards + let argsBundled = zip argHWTys (zip args argTys) + argsFiltered = filter (maybe True (not . isVoid) . fst) argsBundled + argsFiltered' = map snd argsFiltered + tysFiltered = map snd argsFiltered' + let dstId = Text.pack . name2String $ varName dst + (argExprs,argDecls) <- fmap (second concat . unzip) $! mapM (\(e,t) -> mkExpr False (Left dstId) t e) argsFiltered' + (argExprs',argDecls') <- (second concat . unzip) <$> mapM (toSimpleVar dst) (zip argExprs tysFiltered) + let inpAssigns = zipWith (\(i,t) e -> (Identifier i Nothing,In,t,e)) compInps argExprs' + outpAssign = (Identifier (fst compOutp) Nothing,Out,snd compOutp,Identifier dstId Nothing) + instLabel <- extendIdentifier Basic compName (Text.pack "_" `Text.append` dstId) + let instDecl = InstDecl Nothing compName instLabel (outpAssign:inpAssigns) + return (argDecls ++ argDecls' ++ [instDecl]) + else error $ $(curLoc) ++ "under-applied normalized function" + Nothing -> case args of + [] -> do + let dstId = Text.pack . name2String $ varName dst + return [Assignment dstId (Identifier (Text.pack $ name2String fun) Nothing)] + _ -> error $ $(curLoc) ++ "Unknown function: " ++ showDoc fun + +toSimpleVar :: Id + -> (Expr,Type) + -> NetlistMonad (Expr,[Declaration]) +toSimpleVar _ (e@(Identifier _ _),_) = return (e,[]) +toSimpleVar dst (e,ty) = do + argNm <- extendIdentifier Extended + (Text.pack (name2String (varName dst))) + (Text.pack "_fun_arg") + argNm' <- mkUniqueIdentifier Extended argNm + hTy <- unsafeCoreTypeToHWTypeM $(curLoc) ty + let argDecl = NetDecl Nothing argNm' hTy + argAssn = Assignment argNm' e + return (Identifier argNm' Nothing,[argDecl,argAssn]) + +-- | Generate an expression for a term occurring on the RHS of a let-binder +mkExpr :: Bool -- ^ Treat BlackBox expression as declaration + -> (Either Identifier Id) -- ^ Id to assign the result to + -> Type -- ^ Type of the LHS of the let-binder + -> Term -- ^ Term to convert to an expression + -> NetlistMonad (Expr,[Declaration]) -- ^ Returned expression and a list of generate BlackBox declarations +mkExpr _ _ _ (Core.Literal l) = do + iw <- Lens.use intWidth + case l of + IntegerLiteral i -> return (HW.Literal (Just (Signed iw,iw)) $ NumLit i, []) + IntLiteral i -> return (HW.Literal (Just (Signed iw,iw)) $ NumLit i, []) + WordLiteral w -> return (HW.Literal (Just (Unsigned iw,iw)) $ NumLit w, []) + Int64Literal i -> return (HW.Literal (Just (Signed 64,64)) $ NumLit i, []) + Word64Literal w -> return (HW.Literal (Just (Unsigned 64,64)) $ NumLit w, []) + CharLiteral c -> return (HW.Literal (Just (Unsigned 21,21)) . NumLit . toInteger $ ord c, []) + FloatLiteral r -> let f = fromRational r :: Float + i = toInteger (floatToWord f) + in return (HW.Literal (Just (BitVector 32,32)) (NumLit i), []) + DoubleLiteral r -> let d = fromRational r :: Double + i = toInteger (doubleToWord d) + in return (HW.Literal (Just (BitVector 64,64)) (NumLit i), []) + NaturalLiteral n -> return (HW.Literal (Just (Unsigned iw,iw)) $ NumLit n, []) + _ -> error $ $(curLoc) ++ "not an integer or char literal" + +mkExpr bbEasD bndr ty app = do + let (appF,args) = collectArgs app + tmArgs = lefts args + hwTy <- unsafeCoreTypeToHWTypeM $(curLoc) ty + (_,sp) <- Lens.use curCompNm + case appF of + Data dc -> mkDcApplication hwTy bndr dc tmArgs + Prim nm _ -> mkPrimitive False bbEasD bndr nm args ty + Var _ f + | null tmArgs -> return (Identifier (Text.pack $ name2String f) Nothing,[]) + | otherwise -> + throw (ClashException sp ($(curLoc) ++ "Not in normal form: top-level binder in argument position:\n\n" ++ showDoc app) Nothing) + Case scrut ty' [alt] -> mkProjection bbEasD bndr scrut ty' alt + _ -> throw (ClashException sp ($(curLoc) ++ "Not in normal form: application of a Let/Lam/Case:\n\n" ++ showDoc app) Nothing) + +-- | Generate an expression that projects a field out of a data-constructor. +-- +-- Works for both product types, as sum-of-product types. +mkProjection + :: Bool + -- ^ Projection must bind to a simple variable + -> Either Identifier Id + -- ^ The signal to which the projection is (potentially) assigned + -> Term + -- ^ The subject/scrutinee of the projection + -> Type + -- ^ The type of the result + -> Alt + -- ^ The field to be projected + -> NetlistMonad (Expr, [Declaration]) +mkProjection mkDec bndr scrut altTy alt = do + tcm <- Lens.use tcCache + scrutTy <- termType tcm scrut + let e = Case scrut scrutTy [alt] + (pat,v) <- unbind alt + (_,sp) <- Lens.use curCompNm + varTm <- case v of + (Var _ n) -> return n + _ -> throw (ClashException sp ($(curLoc) ++ + "Not in normal form: RHS of case-projection is not a variable:\n\n" + ++ showDoc e) Nothing) + sHwTy <- unsafeCoreTypeToHWTypeM $(curLoc) scrutTy + vHwTy <- unsafeCoreTypeToHWTypeM $(curLoc) altTy + (selId,modM,decls) <- do + scrutNm <- either return + (\b -> extendIdentifier Extended + (Text.pack (name2String (varName b))) + (Text.pack ("_projection"))) + bndr + (scrutExpr,newDecls) <- mkExpr False (Left scrutNm) scrutTy scrut + case scrutExpr of + Identifier newId modM -> return (newId,modM,newDecls) + _ -> do + scrutNm' <- mkUniqueIdentifier Extended scrutNm + let scrutDecl = NetDecl Nothing scrutNm' sHwTy + scrutAssn = Assignment scrutNm' scrutExpr + return (scrutNm',Nothing,newDecls ++ [scrutDecl,scrutAssn]) + + let altVarId = Text.pack $ name2String varTm + modifier <- case pat of + DataPat (Embed dc) ids -> do + let (exts,tms) = unrebind ids + tmsTys = map (unembed . varType) tms + tmsFVs = concatMap (Lens.toListOf typeFreeVars) tmsTys + extNms = map (nameOcc.varName) exts + tms' = if any (`elem` tmsFVs) extNms + then throw (ClashException sp ($(curLoc) ++ "Not in normal form: Pattern binds existential variables:\n\n" ++ showDoc e) Nothing) + else tms + argHWTys <- mapM coreTypeToHWTypeM tmsTys + let tmsBundled = zip argHWTys tms' + tmsFiltered = filter (maybe False (not . isVoid) . fst) tmsBundled + tmsFiltered' = map snd tmsFiltered + case elemIndex (Id varTm (Embed altTy)) tmsFiltered' of + Nothing -> pure Nothing + Just fI + | sHwTy /= vHwTy -> pure $ nestModifier modM (Just (Indexed (sHwTy,dcTag dc - 1,fI))) + -- When element and subject have the same HW-type, + -- then the projections is just the identity + | otherwise -> pure $ nestModifier modM (Just (DC (Void Nothing,0))) + _ -> throw (ClashException sp ($(curLoc) ++ "Not in normal form: Unexpected pattern in case-projection:\n\n" ++ showDoc e) Nothing) + let extractExpr = Identifier (maybe altVarId (const selId) modifier) modifier + case bndr of + Left scrutNm | mkDec -> do + scrutNm' <- mkUniqueIdentifier Extended scrutNm + let scrutDecl = NetDecl Nothing scrutNm' vHwTy + scrutAssn = Assignment scrutNm' extractExpr + return (Identifier scrutNm' Nothing,scrutDecl:scrutAssn:decls) + _ -> return (extractExpr,decls) + where + nestModifier Nothing m = m + nestModifier m Nothing = m + nestModifier (Just m1) (Just m2) = Just (Nested m1 m2) + + +-- | Generate an expression for a DataCon application occurring on the RHS of a let-binder +mkDcApplication :: HWType -- ^ HWType of the LHS of the let-binder + -> (Either Identifier Id) -- ^ Id to assign the result to + -> DataCon -- ^ Applied DataCon + -> [Term] -- ^ DataCon Arguments + -> NetlistMonad (Expr,[Declaration]) -- ^ Returned expression and a list of generate BlackBox declarations +mkDcApplication dstHType bndr dc args = do + tcm <- Lens.use tcCache + argTys <- mapM (termType tcm) args + argNm <- either return (\b -> extendIdentifier Extended (Text.pack (name2String (varName b))) (Text.pack "_dc_arg")) bndr + argHWTys <- mapM coreTypeToHWTypeM argTys + -- Filter out the arguments of hwtype `Void` and only translate + -- them to the intermediate HDL afterwards + let argsBundled = zip argHWTys (zip args argTys) + argsFiltered = filter (maybe True (not . isVoid) . fst) argsBundled + argsFiltered' = map snd argsFiltered + hWTysFiltered = filter (maybe True (not . isVoid)) argHWTys + (argExprs,argDecls) <- fmap (second concat . unzip) $! mapM (\(e,t) -> mkExpr False (Left argNm) t e) argsFiltered' + fmap (,argDecls) $! case (hWTysFiltered,argExprs) of + -- Is the DC just a newtype wrapper? + ([Just argHwTy],[argExpr]) | argHwTy == dstHType -> + return (HW.DataCon dstHType (DC (Void Nothing,-1)) [argExpr]) + _ -> case dstHType of + SP _ dcArgPairs -> do + let dcI = dcTag dc - 1 + dcArgs = snd $ indexNote ($(curLoc) ++ "No DC with tag: " ++ show dcI) dcArgPairs dcI + case compare (length dcArgs) (length argExprs) of + EQ -> return (HW.DataCon dstHType (DC (dstHType,dcI)) argExprs) + LT -> error $ $(curLoc) ++ "Over-applied constructor" + GT -> error $ $(curLoc) ++ "Under-applied constructor" + Product _ dcArgs -> + case compare (length dcArgs) (length argExprs) of + EQ -> return (HW.DataCon dstHType (DC (dstHType,0)) argExprs) + LT -> error $ $(curLoc) ++ "Over-applied constructor" + GT -> error $ $(curLoc) ++ "Under-applied constructor" + Sum _ _ -> + return (HW.DataCon dstHType (DC (dstHType,dcTag dc - 1)) []) + Bool -> + let dc' = case dcTag dc of + 1 -> HW.Literal Nothing (BoolLit False) + 2 -> HW.Literal Nothing (BoolLit True) + tg -> error $ $(curLoc) ++ "unknown bool literal: " ++ showDoc dc ++ "(tag: " ++ show tg ++ ")" + in return dc' + Vector 0 _ -> return (HW.DataCon dstHType VecAppend []) + Vector 1 _ -> case argExprs of + [e] -> return (HW.DataCon dstHType VecAppend [e]) + _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `Cons`: " ++ showDoc args + Vector _ _ -> case argExprs of + [e1,e2] -> return (HW.DataCon dstHType VecAppend [e1,e2]) + _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `Cons`: " ++ showDoc args + RTree 0 _ -> case argExprs of + [e] -> return (HW.DataCon dstHType RTreeAppend [e]) + _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `LR`: " ++ showDoc args + RTree _ _ -> case argExprs of + [e1,e2] -> return (HW.DataCon dstHType RTreeAppend [e1,e2]) + _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `BR`: " ++ showDoc args + String -> + let dc' = case dcTag dc of + 1 -> HW.Literal Nothing (StringLit "") + _ -> error $ $(curLoc) ++ "mkDcApplication undefined for: " ++ show (dstHType,dc,dcTag dc,args,argHWTys) + in return dc' + Void {} -> return (Identifier (Text.pack "__VOID__") Nothing) + _ -> error $ $(curLoc) ++ "mkDcApplication undefined for: " ++ show (dstHType,dc,args,argHWTys) diff --git a/src/Clash/Netlist.hs-boot b/src/Clash/Netlist.hs-boot new file mode 100644 --- /dev/null +++ b/src/Clash/Netlist.hs-boot @@ -0,0 +1,57 @@ +{-| + Copyright : (C) 2015-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij +-} + +module Clash.Netlist + (genComponent + ,mkExpr + ,mkDcApplication + ,mkDeclarations + ,mkNetDecl + ,mkProjection + ,mkSelection + ) where + +import Clash.Core.DataCon (DataCon) +import Clash.Core.Term (Alt,LetBinding,Term,TmOccName) +import Clash.Core.Type (Type) +import Clash.Core.Var (Id) +import Clash.Driver.Types (SrcSpan) +import Clash.Netlist.Types (Expr, HWType, Identifier, NetlistMonad, Component, + Declaration) + +genComponent :: TmOccName + -> NetlistMonad (SrcSpan,Component) + +mkExpr :: Bool + -> Either Identifier Id + -> Type + -> Term + -> NetlistMonad (Expr,[Declaration]) + +mkDcApplication :: HWType + -> Either Identifier Id + -> DataCon + -> [Term] + -> NetlistMonad (Expr,[Declaration]) + +mkProjection + :: Bool + -> Either Identifier Id + -> Term + -> Type + -> Alt + -> NetlistMonad (Expr, [Declaration]) + +mkSelection + :: Id + -> Term + -> Type + -> [Alt] + -> NetlistMonad [Declaration] + +mkNetDecl :: LetBinding -> NetlistMonad (Maybe Declaration) + +mkDeclarations :: Id -> Term -> NetlistMonad [Declaration] diff --git a/src/Clash/Netlist/BlackBox.hs b/src/Clash/Netlist/BlackBox.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Netlist/BlackBox.hs @@ -0,0 +1,420 @@ +{-| + Copyright : (C) 2012-2016, University of Twente, + 2016-2017, Myrtle Software Ltd, + 2017 , Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Functions to create BlackBox Contexts and fill in BlackBox templates +-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +module Clash.Netlist.BlackBox where + +import Control.Exception (throw) +import Control.Lens ((.=),(<<%=)) +import qualified Control.Lens as Lens +import Data.Char (ord) +import Data.Either (lefts) +import qualified Data.HashMap.Lazy as HashMap +import qualified Data.IntMap as IntMap +import Data.Maybe (catMaybes) +import Data.Semigroup.Monad +import Data.Text.Lazy (fromStrict, pack) +import qualified Data.Text.Lazy as Text +import Data.Text (unpack) +import qualified Data.Text as TextS +import Unbound.Generics.LocallyNameless (embed, unbind, unembed) + +-- import Clash.Backend as N +import Clash.Core.DataCon as D (dcTag) +import Clash.Core.Literal as L (Literal (..)) +import Clash.Core.Name + (Name (..), NameSort (..), name2String, string2SystemName) +import Clash.Core.Pretty (showDoc) +import Clash.Core.Subst (substTm) +import Clash.Core.Term as C (Term (..)) +import Clash.Core.Type as C (Type (..), ConstTy (..), + splitFunTys) +import Clash.Core.TyCon as C (tyConDataCons) +import Clash.Core.Util (collectArgs, isFun, termType) +import Clash.Core.Var as V (Id, Var (..)) +import Clash.Driver.Types (ClashException (..)) +import {-# SOURCE #-} Clash.Netlist + (genComponent, mkDcApplication, mkDeclarations, mkExpr, mkNetDecl, + mkProjection, mkSelection) +import Clash.Netlist.BlackBox.Types as B +import Clash.Netlist.BlackBox.Util as B +import Clash.Netlist.Id (IdType (..)) +import Clash.Netlist.Types as N +import Clash.Netlist.Util as N +import Clash.Normalize.Util (isConstant) +import Clash.Primitives.Types as P +import Clash.Util + +-- | Generate the context for a BlackBox instantiation. +mkBlackBoxContext :: Id -- ^ Identifier binding the primitive/blackbox application + -> [Term] -- ^ Arguments of the primitive/blackbox application + -> NetlistMonad (BlackBoxContext,[Declaration]) +mkBlackBoxContext resId args = do + -- Make context inputs + tcm <- Lens.use tcCache + let resNm = Text.pack . name2String $ varName resId + (imps,impDecls) <- unzip <$> mapM (mkArgument resNm) args + (funs,funDecls) <- mapAccumLM (addFunction tcm) IntMap.empty (zip args [0..]) + + -- Make context result + let res = Identifier resNm Nothing + resTy <- unsafeCoreTypeToHWTypeM $(curLoc) (unembed $ V.varType resId) + + return ( Context (res,resTy) imps funs Nothing + , concat impDecls ++ concat funDecls + ) + where + addFunction tcm im (arg,i) = do + isF <- isFun tcm arg + if isF + then do (f,d) <- mkFunInput resId arg + let im' = IntMap.insert i f im + return (im',d) + else return (im,[]) + +prepareBlackBox :: TextS.Text + -> BlackBoxTemplate + -> BlackBoxContext + -> NetlistMonad (BlackBoxTemplate,[Declaration]) +prepareBlackBox pNm templ bbCtx = + if verifyBlackBoxContext bbCtx templ + then do + t1 <- instantiateCompName templ + (t2,decls) <- setSym bbCtx t1 + t3 <- collectFilePaths bbCtx t2 + return (t3,decls) + else do + (_,sp) <- Lens.use curCompNm + templ' <- getMon (prettyBlackBox templ) + let msg = $(curLoc) ++ "Can't match template for " ++ show pNm ++ " :\n\n" ++ Text.unpack templ' ++ + "\n\nwith context:\n\n" ++ show bbCtx + throw (ClashException sp msg Nothing) + +mkArgument :: Identifier -- ^ LHS of the original let-binder + -> Term + -> NetlistMonad ( (Expr,HWType,Bool) + , [Declaration] + ) +mkArgument bndr e = do + tcm <- Lens.use tcCache + ty <- termType tcm e + iw <- Lens.use intWidth + hwTyM <- N.termHWTypeM e + let eTyMsg = "(" ++ showDoc e ++ " :: " ++ showDoc ty ++ ")" + ((e',t,l),d) <- case hwTyM of + Nothing -> + return ((Identifier (error ($(curLoc) ++ "Forced to evaluate untranslatable type: " ++ eTyMsg)) Nothing + ,Void Nothing,False),[]) + Just hwTy -> case collectArgs e of + (C.Var _ v,[]) -> return ((Identifier (pack (name2String v)) Nothing,hwTy,False),[]) + (C.Literal (IntegerLiteral i),[]) -> return ((N.Literal (Just (Signed iw,iw)) (N.NumLit i),hwTy,True),[]) + (C.Literal (IntLiteral i), []) -> return ((N.Literal (Just (Signed iw,iw)) (N.NumLit i),hwTy,True),[]) + (C.Literal (WordLiteral w), []) -> return ((N.Literal (Just (Unsigned iw,iw)) (N.NumLit w),hwTy,True),[]) + (C.Literal (CharLiteral c), []) -> return ((N.Literal (Just (Unsigned 21,21)) (N.NumLit . toInteger $ ord c),hwTy,True),[]) + (C.Literal (StringLiteral s),[]) -> return ((N.Literal Nothing (N.StringLit s),hwTy,True),[]) + (C.Literal (Int64Literal i), []) -> return ((N.Literal (Just (Signed 64,64)) (N.NumLit i),hwTy,True),[]) + (C.Literal (Word64Literal i), []) -> return ((N.Literal (Just (Unsigned 64,64)) (N.NumLit i),hwTy,True),[]) + (C.Literal (NaturalLiteral n), []) -> return ((N.Literal (Just (Unsigned iw,iw)) (N.NumLit n),hwTy,True),[]) + (Prim f _,args) -> do + (e',d) <- mkPrimitive True False (Left bndr) f args ty + case e' of + (Identifier _ _) -> return ((e',hwTy,False), d) + _ -> return ((e',hwTy,isConstant e), d) + (Data dc, args) -> do + (exprN,dcDecls) <- mkDcApplication hwTy (Left bndr) dc (lefts args) + return ((exprN,hwTy,isConstant e),dcDecls) + (Case scrut ty' [alt],[]) -> do + (projection,decls) <- mkProjection False (Left bndr) scrut ty' alt + return ((projection,hwTy,False),decls) + _ -> + return ((Identifier (error ($(curLoc) ++ "Forced to evaluate unexpected function argument: " ++ eTyMsg)) Nothing + ,hwTy,False),[]) + return ((e',t,l),d) + +mkPrimitive :: Bool -- ^ Put BlackBox expression in parenthesis + -> Bool -- ^ Treat BlackBox expression as declaration + -> (Either Identifier Id) -- ^ Id to assign the result to + -> TextS.Text + -> [Either Term Type] + -> Type + -> NetlistMonad (Expr,[Declaration]) +mkPrimitive bbEParen bbEasD dst nm args ty = do + bbM <- HashMap.lookup nm <$> Lens.use primitives + case bbM of + Just p@(P.BlackBox {outputReg = wr}) -> do + case template p of + (Left tempD) -> do + let pNm = name p + wr' = if wr then Reg else Wire + resM <- resBndr True wr' dst + case resM of + Just (dst',dstNm,dstDecl) -> do + (bbCtx,ctxDcls) <- mkBlackBoxContext dst' (lefts args) + (templ,templDecl) <- prepareBlackBox pNm tempD bbCtx + let bbDecl = N.BlackBoxD pNm (library p) (imports p) + (include p) templ bbCtx + return (Identifier dstNm Nothing,dstDecl ++ ctxDcls ++ templDecl ++ [bbDecl]) + Nothing -> return (Identifier "__VOID__" Nothing,[]) + (Right tempE) -> do + let pNm = name p + if bbEasD + then do + resM <- resBndr True Wire dst + case resM of + Just (dst',dstNm,dstDecl) -> do + (bbCtx,ctxDcls) <- mkBlackBoxContext dst' (lefts args) + (bbTempl,templDecl) <- prepareBlackBox pNm tempE bbCtx + let tmpAssgn = Assignment dstNm + (BlackBoxE pNm (library p) (imports p) + (include p) bbTempl bbCtx + bbEParen) + return (Identifier dstNm Nothing, dstDecl ++ ctxDcls ++ templDecl ++ [tmpAssgn]) + Nothing -> return (Identifier "__VOID__" Nothing,[]) + else do + resM <- resBndr False Wire dst + case resM of + Just (dst',_,_) -> do + (bbCtx,ctxDcls) <- mkBlackBoxContext dst' (lefts args) + (bbTempl,templDecl) <- prepareBlackBox pNm tempE bbCtx + return (BlackBoxE pNm (library p) (imports p) (include p) bbTempl bbCtx bbEParen,ctxDcls ++ templDecl) + Nothing -> return (Identifier "__VOID__" Nothing,[]) + Just (P.Primitive pNm _) + | pNm == "GHC.Prim.tagToEnum#" -> do + hwTy <- N.unsafeCoreTypeToHWTypeM $(curLoc) ty + case args of + [Right (ConstTy (TyCon tcN)), Left (C.Literal (IntLiteral i))] -> do + tcm <- Lens.use tcCache + let dcs = tyConDataCons (tcm HashMap.! nameOcc tcN) + dc = dcs !! fromInteger i + (exprN,dcDecls) <- mkDcApplication hwTy dst dc [] + return (exprN,dcDecls) + [Right _, Left scrut] -> do + tcm <- Lens.use tcCache + scrutTy <- termType tcm scrut + (scrutExpr,scrutDecls) <- mkExpr False (Left "#tte_rhs") scrutTy scrut + case scrutExpr of + Identifier id_ Nothing -> return (DataTag hwTy (Left id_),scrutDecls) + _ -> do + scrutHTy <- unsafeCoreTypeToHWTypeM $(curLoc) scrutTy + tmpRhs <- mkUniqueIdentifier Extended (pack "#tte_rhs") + let netDeclRhs = NetDecl Nothing tmpRhs scrutHTy + netAssignRhs = Assignment tmpRhs scrutExpr + return (DataTag hwTy (Left tmpRhs),[netDeclRhs,netAssignRhs] ++ scrutDecls) + _ -> error $ $(curLoc) ++ "tagToEnum: " ++ show (map (either showDoc showDoc) args) + | pNm == "GHC.Prim.dataToTag#" -> case args of + [Right _,Left (Data dc)] -> do + iw <- Lens.use intWidth + return (N.Literal (Just (Signed iw,iw)) (NumLit $ toInteger $ dcTag dc - 1),[]) + [Right _,Left scrut] -> do + tcm <- Lens.use tcCache + scrutTy <- termType tcm scrut + scrutHTy <- unsafeCoreTypeToHWTypeM $(curLoc) scrutTy + (scrutExpr,scrutDecls) <- mkExpr False (Left "#dtt_rhs") scrutTy scrut + case scrutExpr of + Identifier id_ Nothing -> return (DataTag scrutHTy (Right id_),scrutDecls) + _ -> do + tmpRhs <- mkUniqueIdentifier Extended "#dtt_rhs" + let netDeclRhs = NetDecl Nothing tmpRhs scrutHTy + netAssignRhs = Assignment tmpRhs scrutExpr + return (DataTag scrutHTy (Right tmpRhs),[netDeclRhs,netAssignRhs] ++ scrutDecls) + _ -> error $ $(curLoc) ++ "dataToTag: " ++ show (map (either showDoc showDoc) args) + | otherwise -> return (BlackBoxE "" [] [] Nothing [C $ mconcat ["NO_TRANSLATION_FOR:",fromStrict pNm]] emptyBBContext False,[]) + _ -> do + (_,sp) <- Lens.use curCompNm + throw (ClashException sp ($(curLoc) ++ "No blackbox found for: " ++ unpack nm) Nothing) + where + resBndr + :: Bool + -> WireOrReg + -> (Either Identifier Id) + -> NetlistMonad (Maybe (Id,Identifier,[Declaration])) + -- Nothing when the binder would have type `Void` + resBndr mkDec wr dst' = case dst' of + Left dstL -> case mkDec of + False -> do + let nm' = Text.unpack dstL + id_ = Id (string2SystemName nm') (embed ty) + return (Just (id_,dstL,[])) + True -> do + nm' <- extendIdentifier Extended dstL "_res" + nm'' <- mkUniqueIdentifier Extended nm' + let nm3 = (string2SystemName (Text.unpack nm'')) { nameSort = Internal } + hwTy <- N.unsafeCoreTypeToHWTypeM $(curLoc) ty + let id_ = Id nm3 (embed ty) + idDecl = NetDecl' Nothing wr nm'' (Right hwTy) + case hwTy of + Void {} -> return Nothing + _ -> return (Just (id_,nm'',[idDecl])) + Right dstR -> return (Just (dstR,Text.pack . name2String . varName $ dstR,[])) + +-- | Create an template instantiation text and a partial blackbox content for an +-- argument term, given that the term is a function. Errors if the term is not +-- a function +mkFunInput + :: Id + -- ^ Identifier binding the encompassing primitive/blackbox application + -> Term + -- ^ The function argument term + -> NetlistMonad + ((Either BlackBoxTemplate (Identifier,[Declaration]) + ,WireOrReg + ,[BlackBoxTemplate] + ,[BlackBoxTemplate] + ,Maybe ((TextS.Text,TextS.Text),BlackBoxTemplate) + ,BlackBoxContext) + ,[Declaration]) +mkFunInput resId e = do + let (appE,args) = collectArgs e + (bbCtx,dcls) <- mkBlackBoxContext resId (lefts args) + templ <- case appE of + Prim nm _ -> do + bbM <- fmap (HashMap.lookup nm) $ Lens.use primitives + (_,sp) <- Lens.use curCompNm + let templ = case bbM of + Just (P.BlackBox {..}) -> Left (outputReg,library,imports,include,template) + _ -> throw (ClashException sp ($(curLoc) ++ "No blackbox found for: " ++ unpack nm) Nothing) + return templ + Data dc -> do + tcm <- Lens.use tcCache + eTy <- termType tcm e + let (_,resTy) = splitFunTys tcm eTy + resHTyM <- coreTypeToHWTypeM resTy + case resHTyM of + Just resHTy@(SP _ dcArgPairs) -> do + let dcI = dcTag dc - 1 + dcArgs = snd $ indexNote ($(curLoc) ++ "No DC with tag: " ++ show dcI) dcArgPairs dcI + dcInps = [ Identifier (pack ("~ARG[" ++ show x ++ "]")) Nothing | x <- [(0::Int)..(length dcArgs - 1)]] + dcApp = DataCon resHTy (DC (resHTy,dcI)) dcInps + dcAss = Assignment (pack "~RESULT") dcApp + return (Right (("",[dcAss]),Wire)) + Just resHTy@(Product _ dcArgs) -> do + let dcInps = [ Identifier (pack ("~ARG[" ++ show x ++ "]")) Nothing | x <- [(0::Int)..(length dcArgs - 1)]] + dcApp = DataCon resHTy (DC (resHTy,0)) dcInps + dcAss = Assignment (pack "~RESULT") dcApp + return (Right (("",[dcAss]),Wire)) + Just resHTy@(Vector _ _) -> do + let dcInps = [ Identifier (pack ("~ARG[" ++ show x ++ "]")) Nothing | x <- [(1::Int)..2] ] + dcApp = DataCon resHTy (DC (resHTy,1)) dcInps + dcAss = Assignment (pack "~RESULT") dcApp + return (Right (("",[dcAss]),Wire)) + -- The following happens for things like `Maybe ()` + Just resHTy@(Sum _ _) -> do + let dcI = dcTag dc - 1 + dcApp = DataCon resHTy (DC (resHTy,dcI)) [] + dcAss = Assignment (pack "~RESULT") dcApp + return (Right (("",[dcAss]),Wire)) + -- The following happens for things like `(1,())` + Just _ -> do + let inp = Identifier (pack ("~ARG[0]")) Nothing + assgn = Assignment (pack "~RESULT") inp + return (Right (("",[assgn]),Wire)) + _ -> error $ $(curLoc) ++ "Cannot make function input for: " ++ showDoc e + C.Var _ (nameOcc -> fun) -> do + normalized <- Lens.use bindings + case HashMap.lookup fun normalized of + Just _ -> do + (_,Component compName compInps [snd -> compOutp] _) <- preserveVarEnv $ genComponent fun + let inpAssigns = zipWith (\(i,t) e' -> (Identifier i Nothing,In,t,e')) compInps [ Identifier (pack ("~ARG[" ++ show x ++ "]")) Nothing | x <- [(0::Int)..] ] + outpAssign = (Identifier (fst compOutp) Nothing,Out,snd compOutp,Identifier (pack "~RESULT") Nothing) + i <- varCount <<%= (+1) + let instLabel = Text.concat [compName,pack ("_" ++ show i)] + instDecl = InstDecl Nothing compName instLabel (outpAssign:inpAssigns) + return (Right (("",[instDecl]),Wire)) + Nothing -> error $ $(curLoc) ++ "Cannot make function input for: " ++ showDoc e + C.Lam _ -> go 0 appE + _ -> error $ $(curLoc) ++ "Cannot make function input for: " ++ showDoc e + case templ of + Left (oreg,libs,imps,incM,Left templ') -> do + l <- instantiateCompName templ' + (l',templDecl) <- setSym bbCtx l + l'' <- collectFilePaths bbCtx l' + return ((Left l'',if oreg then Reg else Wire,libs,imps,incM,bbCtx),dcls ++ templDecl) + Left (_,libs,imps,incM,Right templ') -> do + templ'' <- getMon $ prettyBlackBox templ' + let ass = Assignment (pack "~RESULT") (Identifier templ'' Nothing) + return ((Right ("",[ass]),Wire,libs,imps,incM,bbCtx),dcls) + Right (decl,wr) -> + return ((Right decl,wr,[],[],Nothing,bbCtx),dcls) + where + go n (Lam b) = do + (id_,e') <- unbind b + let nm = varName id_ + e'' = substTm (nameOcc nm) + (C.Var (unembed (varType id_)) + (string2SystemName ("~ARG[" ++ show n ++ "]"))) + e' + go (n+(1::Int)) e'' + + go _ (C.Var _ nm) = do + let assn = Assignment (pack "~RESULT") (Identifier (pack (name2String nm)) Nothing) + return (Right (("",[assn]),Wire)) + + go _ (Case scrut ty [alt]) = do + (projection,decls) <- mkProjection False (Left "#bb_res") scrut ty alt + let assn = Assignment (pack "~RESULT") projection + nm <- if null decls + then return "" + else mkUniqueIdentifier Basic "projection" + return (Right ((nm,decls ++ [assn]),Wire)) + + go _ (Case scrut ty alts@(_:_:_)) = do + let resId' = resId {varName = string2SystemName "~RESULT"} + selectionDecls <- mkSelection resId' scrut ty alts + nm <- mkUniqueIdentifier Basic "selection" + return (Right ((nm,selectionDecls),Reg)) + + go _ e'@(App _ _) = do + tcm <- Lens.use tcCache + eType <- termType tcm e' + (appExpr,appDecls) <- mkExpr False (Left "#bb_res") eType e' + let assn = Assignment (pack "~RESULT") appExpr + nm <- if null appDecls + then return "" + else mkUniqueIdentifier Basic "block" + return (Right ((nm,appDecls ++ [assn]),Wire)) + + go _ e'@(Letrec _) = do + tcm <- Lens.use tcCache + normE <- splitNormalized tcm e' + ([],[],_,[],binders,result) <- case normE of + Right norm -> mkUniqueNormalized Nothing norm + Left err -> error err + let binders' = map (\(id_,tm) -> (goR result id_,tm)) binders + netDecls <- fmap catMaybes . mapM mkNetDecl $ filter ((/= result) . varName . fst) binders + decls <- concat <$> mapM (uncurry mkDeclarations . second unembed) binders' + Just (NetDecl' _ rw _ _) <- mkNetDecl . head $ filter ((==result) . varName . fst) binders + nm <- mkUniqueIdentifier Basic "fun" + return (Right ((nm,netDecls ++ decls),rw)) + where + goR r id_ | varName id_ == r = id_ {varName = string2SystemName "~RESULT"} + | otherwise = id_ + + go _ e' = error $ $(curLoc) ++ "Cannot make function input for: " ++ showDoc e' + + +instantiateCompName :: BlackBoxTemplate + -> NetlistMonad BlackBoxTemplate +instantiateCompName l = do + (nm,_) <- Lens.use curCompNm + return (setCompName nm l) + +collectFilePaths :: BlackBoxContext + -> BlackBoxTemplate + -> NetlistMonad BlackBoxTemplate +collectFilePaths bbCtx l = do + fs <- Lens.use dataFiles + let (fs',l') = findAndSetDataFiles bbCtx fs l + dataFiles .= fs' + return l' diff --git a/src/Clash/Netlist/BlackBox/Parser.hs b/src/Clash/Netlist/BlackBox/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Netlist/BlackBox/Parser.hs @@ -0,0 +1,132 @@ +{-| + Copyright : (C) 2012-2016, University of Twente, + 2017 , Myrtle Software Ltd + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Parser definitions for BlackBox templates +-} + +{-# LANGUAGE OverloadedStrings #-} + +module Clash.Netlist.BlackBox.Parser + (runParse) +where + +import Control.Applicative +import Data.Text.Lazy (Text, pack, unpack) +import qualified Data.Text.Lazy as Text +import Text.Parser.Combinators +import Text.Trifecta hiding (Err) +import Text.Trifecta.Delta + +import Clash.Netlist.BlackBox.Types + +-- | Parse a text as a BlackBoxTemplate, returns a list of errors in case +-- parsing fails +-- runParse :: Text -> (BlackBoxTemplate, [Error LineColPos]) +-- runParse = PCC.parse ((,) <$> pBlackBoxD <*> pEnd) +-- . createStr (LineColPos 0 0 0) +runParse :: Text -> Result BlackBoxTemplate +runParse = parseString pBlackBoxD (Directed "" 0 0 0 0) . unpack + +-- | Parse a BlackBoxTemplate (Declarations and Expressions) +pBlackBoxD :: Parser BlackBoxTemplate +pBlackBoxD = some pElement + +-- | Parse a single Template Element +pElement :: Parser Element +pElement = pTagD + <|> C <$> pText + <|> C <$> (pack <$> string "~ ") + +-- | Parse the Text part of a Template +pText :: Parser Text +pText = pack <$> some (satisfyRange '\000' '\125') + +-- | Parse a Declaration or Expression element +pTagD :: Parser Element +pTagD = IF <$> (symbol "~IF" *> pTagE) + <*> (spaces *> (string "~THEN" *> pBlackBoxD)) + <*> (string "~ELSE" *> pBlackBoxD <* string "~FI") + <|> D <$> pDecl + <|> pTagE + +-- | Parse a Declaration +pDecl :: Parser Decl +pDecl = Decl <$> (symbol "~INST" *> natural') <*> + ((:) <$> pOutput <*> many pInput) <* string "~INST" + +-- | Parse the output tag of Declaration +pOutput :: Parser (BlackBoxTemplate,BlackBoxTemplate) +pOutput = symbol "~OUTPUT" *> symbol "<=" *> ((,) <$> (pBlackBoxE <* symbol "~") <*> pBlackBoxE) <* symbol "~" + +-- | Parse the input tag of Declaration +pInput :: Parser (BlackBoxTemplate,BlackBoxTemplate) +pInput = symbol "~INPUT" *> symbol "<=" *> ((,) <$> (pBlackBoxE <* symbol "~") <*> pBlackBoxE) <* symbol "~" + +-- | Parse an Expression element +pTagE :: Parser Element +pTagE = O True <$ string "~ERESULT" + <|> O False <$ string "~RESULT" + <|> I True <$> (string "~EARG" *> brackets' natural') + <|> I False <$> (string "~ARG" *> brackets' natural') + <|> L <$> (string "~LIT" *> brackets' natural') + <|> N <$> (string "~NAME" *> brackets' natural') + <|> Var <$> try (string "~VAR" *> brackets' pSigD) <*> brackets' natural' + <|> (Sym Text.empty) <$> (string "~SYM" *> brackets' natural') + <|> Typ Nothing <$ string "~TYPO" + <|> (Typ . Just) <$> try (string "~TYP" *> brackets' natural') + <|> TypM Nothing <$ string "~TYPMO" + <|> (TypM . Just) <$> (string "~TYPM" *> brackets' natural') + <|> Err Nothing <$ string "~ERRORO" + <|> (Err . Just) <$> (string "~ERROR" *> brackets' natural') + <|> TypElem <$> (string "~TYPEL" *> brackets' pTagE) + <|> IndexType <$> (string "~INDEXTYPE" *> brackets' pTagE) + <|> CompName <$ string "~COMPNAME" + <|> IncludeName <$ string "~INCLUDENAME" + <|> Size <$> (string "~SIZE" *> brackets' pTagE) + <|> Length <$> (string "~LENGTH" *> brackets' pTagE) + <|> Depth <$> (string "~DEPTH" *> brackets' pTagE) + <|> FilePath <$> (string "~FILE" *> brackets' pTagE) + <|> Gen <$> (True <$ string "~GENERATE") + <|> Gen <$> (False <$ string "~ENDGENERATE") + <|> (`SigD` Nothing) <$> (string "~SIGDO" *> brackets' pSigD) + <|> SigD <$> (string "~SIGD" *> brackets' pSigD) <*> (Just <$> (brackets' natural')) + <|> IW64 <$ string "~IW64" + <|> (HdlSyn Vivado) <$ string "~VIVADO" + <|> (HdlSyn Other) <$ string "~OTHERSYN" + <|> (BV True) <$> (string "~TOBV" *> brackets' pSigD) <*> brackets' pTagE + <|> (BV False) <$> (string "~FROMBV" *> brackets' pSigD) <*> brackets' pTagE + <|> IsLit <$> (string "~ISLIT" *> brackets' natural') + <|> IsVar <$> (string "~ISVAR" *> brackets' natural') + <|> IsGated <$> (string "~ISGATED" *> brackets' natural') + <|> IsSync <$> (string "~ISSYNC" *> brackets' natural') + <|> StrCmp <$> (string "~STRCMP" *> brackets' pSigD) <*> brackets' natural' + <|> OutputWireReg <$> (string "~OUTPUTWIREREG" *> brackets' natural') + <|> GenSym <$> (string "~GENSYM" *> brackets' pSigD) <*> brackets' natural' + <|> And <$> (string "~AND" *> brackets' (commaSep pTagE)) + <|> Vars <$> (string "~VARS" *> brackets' natural') + +natural' :: TokenParsing m => m Int +natural' = fmap fromInteger natural + +-- | Parse a bracketed text +brackets' :: Parser a -> Parser a +brackets' p = char '[' *> p <* char ']' + +-- | Parse the expression part of Blackbox Templates +pBlackBoxE :: Parser BlackBoxTemplate +pBlackBoxE = some pElemE + +-- | Parse an Expression or Text +pElemE :: Parser Element +pElemE = pTagE + <|> C <$> pText + +-- | Parse SigD +pSigD :: Parser [Element] +pSigD = some (pTagE <|> (C (pack "[") <$ (pack <$> string "[\\")) + <|> (C (pack "]") <$ (pack <$> string "\\]")) + <|> (C <$> (pack <$> some (satisfyRange '\000' '\90'))) + <|> (C <$> (pack <$> some (satisfyRange '\94' '\125')))) diff --git a/src/Clash/Netlist/BlackBox/Types.hs b/src/Clash/Netlist/BlackBox/Types.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Netlist/BlackBox/Types.hs @@ -0,0 +1,72 @@ +{-| + Copyright : (C) 2012-2016, University of Twente, + 2017 , Myrtle Software Ltd + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Types used in BlackBox modules +-} + +module Clash.Netlist.BlackBox.Types where + +import Data.Text.Lazy (Text) + +-- | A BlackBox Template is a List of Elements +type BlackBoxTemplate = [Element] + +-- | Elements of a blackbox context +data Element = C !Text -- ^ Constant + | D !Decl -- ^ Component instantiation hole + | O !Bool + -- ^ Output hole; @Bool@ asserts escape marker stripping + | I !Bool !Int + -- ^ Input hole; @Bool@ asserts escape marker stripping + | N !Int -- ^ Name hole + | L !Int -- ^ Literal hole + | Var [Element] !Int -- + | Sym !Text !Int -- ^ Symbol hole + | Typ !(Maybe Int) -- ^ Type declaration hole + | TypM !(Maybe Int) -- ^ Type root hole + | Err !(Maybe Int) -- ^ Error value hole + | TypElem !Element -- ^ Select element type from a vector type + | CompName -- ^ Hole for the name of the component in which + -- the blackbox is instantiated + | IncludeName + | IndexType !Element -- ^ Index data type hole, the field is the + -- (exclusive) maximum index + | Size !Element -- ^ Size of a type hole + | Length !Element -- ^ Length of a vector hole + | Depth !Element -- ^ Depth of a tree hole + | FilePath !Element -- ^ Hole containing a filepath for a data file + | Gen !Bool -- ^ Hole marking beginning (True) or end (False) + -- of a generative construct + | IF !Element [Element] [Element] + | And [Element] + | IW64 -- ^ Hole indicating whether Int/Word/Integer + -- are 64-Bit + | HdlSyn HdlSyn -- ^ Hole indicating which synthesis tool we're + -- generating HDL for + | BV !Bool [Element] !Element -- ^ Convert to (True)/from(False) a bit-vector + | IsLit !Int + | IsVar !Int + | IsGated !Int + | IsSync !Int + | StrCmp [Element] !Int + | OutputWireReg !Int + | Vars !Int + | GenSym [Element] !Int + | SigD [Element] !(Maybe Int) + deriving Show + +-- | Component instantiation hole. First argument indicates which function argument +-- to instantiate. Second argument corresponds to output and input assignments, +-- where the first element is the output assignment, and the subsequent elements +-- are the consecutive input assignments. +-- +-- The LHS of the tuple is the name of the signal, while the RHS of the tuple +-- is the type of the signal +data Decl = Decl !Int [(BlackBoxTemplate,BlackBoxTemplate)] + deriving Show + +data HdlSyn = Vivado | Other + deriving (Eq,Show,Read) diff --git a/src/Clash/Netlist/BlackBox/Util.hs b/src/Clash/Netlist/BlackBox/Util.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Netlist/BlackBox/Util.hs @@ -0,0 +1,612 @@ +{-| + Copyright : (C) 2012-2016, University of Twente, + 2016-2017, Myrtle Software Ltd, + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Utilties to verify blackbox contexts against templates and rendering filled + in templates +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +module Clash.Netlist.BlackBox.Util where + +import Control.Exception (throw) +import Control.Lens (_1,_2,(%=),use) +import Control.Monad.State (State, StateT (..), lift) +import Data.Bool (bool) +import Data.Foldable (foldrM) +import Data.Hashable (Hashable (..)) +import qualified Data.IntMap as IntMap +import Data.List (mapAccumL, nub) +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid +#endif +import Data.Semigroup.Monad +import qualified Data.Text +import qualified Data.Text.Prettyprint.Doc as PP +import Data.Text.Prettyprint.Doc.Extra +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as Text +import System.FilePath (replaceBaseName, + takeBaseName, + takeFileName, + (<.>)) +import qualified Text.PrettyPrint.ANSI.Leijen as ANSI +import Text.Printf +import Text.Trifecta.Result hiding (Err) + +import Clash.Backend (Backend (..), Usage (..)) +import Clash.Driver.Types (ClashException (..)) +import Clash.Netlist.BlackBox.Parser +import Clash.Netlist.BlackBox.Types +import Clash.Netlist.Id (IdType (..)) +import Clash.Netlist.Types + (HWType (..), Identifier, BlackBoxContext (..), Expr (..), Literal (..), + NetlistMonad, Modifier (..)) +import qualified Clash.Netlist.Types as N +import Clash.Netlist.Util (mkUniqueIdentifier,typeSize) +import Clash.Signal.Internal + (ClockKind (Gated), ResetKind (Synchronous)) +import Clash.Util + +-- | Determine if the number of normal/literal/function inputs of a blackbox +-- context at least matches the number of argument that is expected by the +-- template. +verifyBlackBoxContext :: BlackBoxContext -- ^ Blackbox to verify + -> BlackBoxTemplate -- ^ Template to check against + -> Bool +verifyBlackBoxContext bbCtx = all verify' + where + verify' (I _ n) = n < length (bbInputs bbCtx) + verify' (L n) = case indexMaybe (bbInputs bbCtx) n of + Just (_,_,b) -> b + _ -> False + verify' (Typ (Just n)) = n < length (bbInputs bbCtx) + verify' (TypM (Just n)) = n < length (bbInputs bbCtx) + verify' (Err (Just n)) = n < length (bbInputs bbCtx) + verify' (D (Decl n l')) = case IntMap.lookup n (bbFunctions bbCtx) of + Just _ -> all (\(x,y) -> verifyBlackBoxContext bbCtx x && + verifyBlackBoxContext bbCtx y) l' + _ -> False + verify' _ = True + +extractLiterals :: BlackBoxContext + -> [Expr] +extractLiterals = map (\case (e,_,_) -> e) + . filter (\case (_,_,b) -> b) + . bbInputs + +-- | Update all the symbol references in a template, and increment the symbol +-- counter for every newly encountered symbol. +setSym + :: BlackBoxContext + -> BlackBoxTemplate + -> NetlistMonad (BlackBoxTemplate,[N.Declaration]) +setSym bbCtx l = do + (a,(_,decls)) <- runStateT (mapM setSym' l) (IntMap.empty,IntMap.empty) + return (a,concatMap snd (IntMap.elems decls)) + where + setSym' :: Element + -> StateT ( IntMap.IntMap Identifier + , IntMap.IntMap (Identifier,[N.Declaration])) + NetlistMonad + Element + setSym' e = case e of + Var nm i | i < length (bbInputs bbCtx) -> case bbInputs bbCtx !! i of + (Identifier nm' Nothing,_,_) -> return (Var [C nm'] i) + (e',hwTy,_) -> do + varM <- IntMap.lookup i <$> use _2 + case varM of + Nothing -> do + nm' <- lift (mkUniqueIdentifier Extended (concatT (C "#":nm))) + let decls = [N.NetDecl Nothing nm' hwTy + ,N.Assignment nm' e' + ] + _2 %= (IntMap.insert i (nm',decls)) + return (Var [C nm'] i) + Just (nm',_) -> return (Var [C nm'] i) + Sym _ i -> do + symM <- IntMap.lookup i <$> use _1 + case symM of + Nothing -> do + t <- lift (mkUniqueIdentifier Extended (Text.pack "#n")) + _1 %= (IntMap.insert i t) + return (Sym t i) + Just t -> return (Sym t i) + GenSym t i -> do + symM <- IntMap.lookup i <$> use _1 + case symM of + Nothing -> do + t' <- lift (mkUniqueIdentifier Basic (concatT t)) + _1 %= (IntMap.insert i t') + return (GenSym [C t'] i) + Just _ -> error ("Symbol #" ++ show (t,i) ++ " is already defined") + D (Decl n l') -> D <$> (Decl n <$> mapM (combineM (mapM setSym') (mapM setSym')) l') + IF c t f -> IF <$> pure c <*> mapM setSym' t <*> mapM setSym' f + SigD e' m -> SigD <$> (mapM setSym' e') <*> pure m + BV t e' m -> BV <$> pure t <*> mapM setSym' e' <*> pure m + _ -> pure e + + concatT :: [Element] -> Text + concatT = Text.concat + . map (\case { C t -> t + ; O _ | Identifier t _ <- fst (bbResult bbCtx) + -> t + ; _ -> error "unexpected element in GENSYM"}) + +setCompName :: Identifier -> BlackBoxTemplate -> BlackBoxTemplate +setCompName nm = map setCompName' + where + setCompName' CompName = C nm + setCompName' (D (Decl n l)) = D (Decl n (map (setCompName nm *** setCompName nm) l)) + setCompName' (IF c t f) = IF c (setCompName nm t) (setCompName nm f) + setCompName' (GenSym es i) = GenSym (setCompName nm es) i + setCompName' (BV t e m) = BV t (setCompName nm e) (setCompName' m) + setCompName' e = e + +findAndSetDataFiles :: BlackBoxContext -> [(String,FilePath)] -> BlackBoxTemplate -> ([(String,FilePath)],BlackBoxTemplate) +findAndSetDataFiles bbCtx fs = mapAccumL findAndSet fs + where + findAndSet fs' (FilePath e) = case e of + (L n) -> + let (e',_,_) = bbInputs bbCtx !! n + in case e' of + BlackBoxE "GHC.CString.unpackCString#" _ _ _ _ bbCtx' _ -> case bbInputs bbCtx' of + [(Literal Nothing (StringLit s'),_,_)] -> renderFilePath fs s' + _ -> (fs',FilePath e) + Literal Nothing (StringLit s') -> renderFilePath fs s' + _ -> (fs',FilePath e) + _ -> (fs',FilePath e) + findAndSet fs' l = (fs',l) + +renderFilePath :: [(String,FilePath)] -> String -> ([(String,FilePath)],Element) +renderFilePath fs f = ((f'',f):fs,C (Text.pack $ show f'')) + where + f' = takeFileName f + f'' = selectNewName (map fst fs) f' + + selectNewName as a + | elem a as = selectNewName as (replaceBaseName a (takeBaseName a ++ "_")) + | otherwise = a + +-- | Render a blackbox given a certain context. Returns a filled out template +-- and a list of 'hidden' inputs that must be added to the encompassing component. +renderTemplate + :: Backend backend + => BlackBoxContext -- ^ Context used to fill in the hole + -> BlackBoxTemplate -- ^ Blackbox template + -> State backend (Int -> Text) +renderTemplate bbCtx l = do + l' <- mapM (renderElem bbCtx) l + return (\col -> Text.concat (map ($ col) l')) + +renderBlackBox + :: Backend backend + => [BlackBoxTemplate] + -> [BlackBoxTemplate] + -> Maybe ((Data.Text.Text,Data.Text.Text), BlackBoxTemplate) + -> BlackBoxTemplate + -> BlackBoxContext + -> State backend (Int -> Doc) +renderBlackBox libs imps Nothing bs bbCtx = do + libs' <- mapM (fmap ($ 0) . renderTemplate bbCtx) libs + imps' <- mapM (fmap ($ 0) . renderTemplate bbCtx) imps + addLibraries libs' + addImports imps' + t <- renderTemplate bbCtx bs + return (\col -> PP.nest (col-2) (PP.pretty (t (col+2)))) + +renderBlackBox libs imps (Just ((nm,ext),inc)) bs bbCtx = do + incForHash <- renderTemplate (bbCtx {bbQsysIncName = Just "~INCLUDENAME"}) inc + iw <- iwWidth + let incHash = hash (incForHash 0) + nm' = Text.concat + [ Text.fromStrict nm + , Text.pack (printf ("%0" ++ show (iw `div` 4) ++ "X") incHash) + ] + bbNamedCtx = bbCtx {bbQsysIncName = Just nm'} + + inc' <-renderTemplate bbNamedCtx inc + t <- renderTemplate bbNamedCtx bs + inc'' <- pretty (inc' 0) + addInclude (Text.unpack nm' <.> Data.Text.unpack ext, inc'') + libs' <- mapM (fmap ($ 0) . renderTemplate bbNamedCtx) libs + imps' <- mapM (fmap ($ 0) . renderTemplate bbNamedCtx) imps + addLibraries libs' + addImports imps' + return (\col -> PP.nest (col-2) (PP.pretty (t (col+2)))) + +-- | Assign @Var@ holes in the context of a primitive HDL template that is +-- passed as an argument of a higher-order HDL template. For the general case, +-- use 'setSym' +-- +-- This functions errors when the @Var@ hole cannot be filled with a variable, +-- as it is (currently) impossible to create unique names this late in the +-- pipeline. +setSimpleVar + :: BlackBoxContext + -> BlackBoxTemplate + -> BlackBoxTemplate +setSimpleVar bbCtx = map go + where + go e = case e of + Var _ i + | i < length (bbInputs bbCtx) + , (Identifier nm' Nothing,_,_) <- bbInputs bbCtx !! i + -> Var [C nm'] i + | otherwise + -> error $ $(curLoc) ++ "You can only pass variables to function arguments in a higher-order primitive" + D (Decl n l') -> D (Decl n (map (map go *** map go) l')) + IF c t f -> IF c (map go t) (map go f) + SigD e' m -> SigD (map go e') m + BV t e' m -> BV t (map go e') m + _ -> e + +-- | Render a single template element +renderElem :: Backend backend + => BlackBoxContext + -> Element + -> State backend (Int -> Text) +renderElem b (D (Decl n (l:ls))) = do + (o,oTy,_) <- idToExpr <$> combineM (lineToIdentifier b) (return . lineToType b) l + is <- mapM (fmap idToExpr . combineM (lineToIdentifier b) (return . lineToType b)) ls + -- let Just (templ,libs,imps,incM,pCtx) + let Just (templ,_,libs,imps,incM,pCtx) = IntMap.lookup n (bbFunctions b) + b' = pCtx { bbResult = (o,oTy), bbInputs = bbInputs pCtx ++ is } + templ' <- case templ of + Left t -> return t + Right (nm,ds) -> do block <- getMon $ blockDecl nm ds + return . parseFail . renderLazy $ (layoutPretty (LayoutOptions (AvailablePerLine 120 0.4)) block) + let t2 = setSimpleVar b' templ' + if verifyBlackBoxContext b' t2 + then do + bb <- renderBlackBox libs imps incM t2 b' + return (renderLazy . layoutPretty (LayoutOptions (AvailablePerLine 120 0.4)) . bb) + else do + sp <- getSrcSpan + throw (ClashException sp ($(curLoc) ++ "\nCan't match context:\n" ++ show b' ++ "\nwith template:\n" ++ show templ) Nothing) + +renderElem b (SigD e m) = do + e' <- Text.concat <$> mapM (fmap ($ 0) . renderElem b) e + let ty = case m of + Nothing -> snd $ bbResult b + Just n -> let (_,ty',_) = bbInputs b !! n + in ty' + t <- getMon (hdlSig e' ty) + return (const (renderOneLine t)) + +renderElem b (IF c t f) = do + iw <- iwWidth + syn <- hdlSyn + let c' = check iw syn c + if c' > 0 then renderTemplate b t else renderTemplate b f + where + check iw syn c' = case c' of + (Size e) -> typeSize (lineToType b [e]) + (Length e) -> case lineToType b [e] of + (Vector n _) -> n + Void (Just (Vector n _)) -> n + _ -> 0 -- HACK: So we can test in splitAt if one of the + -- vectors in the tuple had a zero length + (L n) -> case bbInputs b !! n of + (l,_,_) + | Literal _ l' <- l -> + case l' of + NumLit i -> fromInteger i + BitLit bl -> case bl of + N.H -> 1 + N.L -> 0 + _ -> error $ $(curLoc) ++ "IF: LIT bit literal must be high or low" + BoolLit bl -> bool 0 1 bl + _ -> error $ $(curLoc) ++ "IF: LIT must be a numeric lit" + | DataCon (Signed _) _ [Literal _ (NumLit i)] <- l + -> fromInteger i + | DataCon (Unsigned _) _ [Literal _ (NumLit i)] <- l + -> fromInteger i + k -> error $ $(curLoc) ++ ("IF: LIT must be a numeric lit:" ++ show k) + (Depth e) -> case lineToType b [e] of + (RTree n _) -> n + _ -> error $ $(curLoc) ++ "IF: treedepth of non-tree type" + IW64 -> if iw == 64 then 1 else 0 + (HdlSyn s) -> if s == syn then 1 else 0 + (IsVar n) -> let (e,_,_) = bbInputs b !! n + in case e of + Identifier _ Nothing -> 1 + _ -> 0 + (IsLit n) -> let (e,_,_) = bbInputs b !! n + in case e of + DataCon {} -> 1 + Literal {} -> 1 + BlackBoxE {} -> 1 + _ -> 0 + (IsGated n) -> let (_,ty,_) = bbInputs b !! n + in case ty of + Clock _ _ Gated -> 1 + _ -> 0 + (IsSync n) -> let (_,ty,_) = bbInputs b !! n + in case ty of + Reset _ _ Synchronous -> 1 + _ -> 0 + (StrCmp [C t1] n) -> + let (e,_,_) = bbInputs b !! n + in case exprToText e of + Just t2 + | t1 == t2 -> 1 + | otherwise -> 0 + Nothing -> error $ $(curLoc) ++ "Expected a string literal: " ++ show e + (And es) -> if all (==1) (map (check iw syn) es) + then 1 + else 0 + _ -> error $ $(curLoc) ++ "IF: condition must be: SIZE, LENGTH, IW64, LIT, ISLIT, or ISARG" + +renderElem b e = fmap const (renderTag b e) + +parseFail :: Text -> BlackBoxTemplate +parseFail t = case runParse t of + Failure errInfo -> + error (ANSI.displayS (ANSI.renderCompact (_errDoc errInfo)) "") + Success templ -> templ + +idToExpr + :: (Text,HWType) + -> (Expr,HWType,Bool) +idToExpr (t,ty) = (Identifier t Nothing,ty,False) + +-- | Fill out the template corresponding to an output/input assignment of a +-- component instantiation, and turn it into a single identifier so it can +-- be used for a new blackbox context. +lineToIdentifier :: Backend backend + => BlackBoxContext + -> BlackBoxTemplate + -> State backend Text +lineToIdentifier b = foldrM (\e a -> do + e' <- renderTag b e + return (e' `Text.append` a) + ) Text.empty + +lineToType :: BlackBoxContext + -> BlackBoxTemplate + -> HWType +lineToType b [(Typ Nothing)] = snd $ bbResult b +lineToType b [(Typ (Just n))] = let (_,ty,_) = bbInputs b !! n + in ty +lineToType b [(TypElem t)] = case lineToType b [t] of + Vector _ elTy -> elTy + _ -> error $ $(curLoc) ++ "Element type selection of a non-vector type" +lineToType b [(IndexType (L n))] = + case bbInputs b !! n of + (Literal _ (NumLit n'),_,_) -> Index (fromInteger n') + x -> error $ $(curLoc) ++ "Index type not given a literal: " ++ show x + +lineToType _ _ = error $ $(curLoc) ++ "Unexpected type manipulation" + +-- | Give a context and a tagged hole (of a template), returns part of the +-- context that matches the tag of the hole. +renderTag :: Backend backend + => BlackBoxContext + -> Element + -> State backend Text +renderTag _ (C t) = return t +renderTag b (O esc) = do + escape <- if esc then unextend else pure id + fmap (escape . renderOneLine) . getMon . expr False . fst $ bbResult b +renderTag b (I esc n) = do + let (e,_,_) = bbInputs b !! n + escape <- if esc then unextend else pure id + (escape . renderOneLine) <$> getMon (expr False e) +renderTag b (N n) = let (e,_,_) = bbInputs b !! n + in case exprToText e of + Just t -> return t + _ -> error $ $(curLoc) ++ "Expected a string literal: " ++ show e + +renderTag b (L n) = let (e,_,_) = bbInputs b !! n + in renderOneLine <$> getMon (expr False (mkLit e)) + where + mkLit (Literal (Just (Signed _,_)) i) = Literal Nothing i + mkLit (Literal (Just (Unsigned _,_)) i) = Literal Nothing i + mkLit (DataCon _ (DC (Void {}, _)) [Literal (Just (Signed _,_)) i]) = Literal Nothing i + mkLit (DataCon _ (DC (Void {}, _)) [Literal (Just (Unsigned _,_)) i]) = Literal Nothing i + mkLit i = i + +renderTag _ (Var [C t] _) = return t +renderTag _ (Sym t _) = return t + +renderTag b (BV True es e) = do + e' <- Text.concat <$> mapM (fmap ($ 0) . renderElem b) es + let ty = lineToType b [e] + renderOneLine <$> getMon (toBV ty e') +renderTag b (BV False es e) = do + e' <- Text.concat <$> (mapM (fmap ($ 0) . renderElem b) es) + let ty = lineToType b [e] + renderOneLine <$> getMon (fromBV ty e') + +renderTag b (Typ Nothing) = fmap renderOneLine . getMon . hdlType Internal . snd $ bbResult b +renderTag b (Typ (Just n)) = let (_,ty,_) = bbInputs b !! n + in renderOneLine <$> getMon (hdlType Internal ty) +renderTag b (TypM Nothing) = fmap renderOneLine . getMon . hdlTypeMark . snd $ bbResult b +renderTag b (TypM (Just n)) = let (_,ty,_) = bbInputs b !! n + in renderOneLine <$> getMon (hdlTypeMark ty) +renderTag b (Err Nothing) = fmap renderOneLine . getMon . hdlTypeErrValue . snd $ bbResult b +renderTag b (Err (Just n)) = let (_,ty,_) = bbInputs b !! n + in renderOneLine <$> getMon (hdlTypeErrValue ty) +renderTag b (Size e) = return . Text.pack . show . typeSize $ lineToType b [e] +renderTag b (Length e) = return . Text.pack . show . vecLen $ lineToType b [e] + where + vecLen (Vector n _) = n + vecLen _ = error $ $(curLoc) ++ "vecLen of a non-vector type" +renderTag b (Depth e) = return . Text.pack . show . treeDepth $ lineToType b [e] + where + treeDepth (RTree n _) = n + treeDepth _ = error $ $(curLoc) ++ "treeDepth of a non-tree type" +renderTag b e@(TypElem _) = let ty = lineToType b [e] + in renderOneLine <$> getMon (hdlType Internal ty) +renderTag _ (Gen b) = renderOneLine <$> genStmt b +renderTag _ (GenSym [C t] _) = return t +renderTag b (Vars n) = + let (e,_,_) = bbInputs b !! n + + go (Identifier i _) = [i] + go (DataCon _ _ es) = concatMap go es + go (DataTag _ e') = [either id id e'] + go _ = [] + + vars = go e + in case vars of + [] -> return Text.empty + _ -> return (Text.concat $ map (Text.cons ',') vars) +renderTag b (IndexType (L n)) = + case bbInputs b !! n of + (Literal _ (NumLit n'),_,_) -> + let hty = Index (fromInteger n') + in fmap renderOneLine (getMon (hdlType Internal hty)) + x -> error $ $(curLoc) ++ "Index type not given a literal: " ++ show x +renderTag b (FilePath e) = case e of + L n -> do + let (e',_,_) = bbInputs b !! n + e2 <- getMon (prettyElem e) + case e' of + BlackBoxE "GHC.CString.unpackCString#" _ _ _ _ bbCtx' _ -> case bbInputs bbCtx' of + [(Literal Nothing (StringLit _),_,_)] -> error $ $(curLoc) ++ "argument of ~FILEPATH:" ++ show e2 ++ "does not reduce to a string" + _ -> error $ $(curLoc) ++ "argument of ~FILEPATH:" ++ show e2 ++ "does not reduce to a string" + _ -> error $ $(curLoc) ++ "argument of ~FILEPATH:" ++ show e2 ++ "does not reduce to a string" + _ -> do e' <- getMon (prettyElem e) + error $ $(curLoc) ++ "~FILEPATH expects a ~LIT[N] argument, but got: " ++ show e' +renderTag b IncludeName = case bbQsysIncName b of + Just nm -> return nm + _ -> error $ $(curLoc) ++ "~INCLUDENAME used where no 'qysInclude' was specified in the primitive definition" +renderTag b (OutputWireReg n) = case IntMap.lookup n (bbFunctions b) of + Just (_,rw,_,_,_,_) -> case rw of {N.Wire -> return "wire"; N.Reg -> return "reg"} + _ -> error $ $(curLoc) ++ "~OUTPUTWIREREG[" ++ show n ++ "] used where argument " ++ show n ++ " is not a function" +renderTag _ e = do e' <- getMon (prettyElem e) + error $ $(curLoc) ++ "Unable to evaluate: " ++ show e' + +exprToText + :: Expr + -> Maybe Text +exprToText (Literal _ (StringLit l)) = Just (Text.pack l) +exprToText (BlackBoxE "Clash.Promoted.Symbol.SSymbol" _ _ _ _ ctx _) = + let (e',_,_) = head (bbInputs ctx) + in exprToText e' +exprToText (BlackBoxE "GHC.CString.unpackCString#" _ _ _ _ ctx _) = + let (e',_,_) = head (bbInputs ctx) + in exprToText e' +exprToText _ = Nothing + +prettyBlackBox :: Monad m + => BlackBoxTemplate + -> Mon m Text +prettyBlackBox bbT = Text.concat <$> mapM prettyElem bbT + +prettyElem :: Monad m + => Element + -> Mon m Text +prettyElem (C t) = return t +prettyElem (D (Decl i args)) = do + args' <- mapM (\(a,b) -> (,) <$> prettyBlackBox a <*> prettyBlackBox b) args + renderOneLine <$> + (nest 2 (string "~INST" <+> int i <> line <> + string "~OUTPUT" <+> string "=>" <+> string (fst (head args')) <+> string (snd (head args')) <+> string "~" <> line <> + vcat (mapM (\(a,b) -> string "~INPUT" <+> string "=>" <+> string a <+> string b <+> string "~") (tail args'))) + <> line <> string "~INST") +prettyElem (O b) = if b then return "~ERESULT" else return "~RESULT" +prettyElem (I b i) = renderOneLine <$> (if b then string "~EARG" else string "~ARG" <> brackets (int i)) +prettyElem (L i) = renderOneLine <$> (string "~LIT" <> brackets (int i)) +prettyElem (N i) = renderOneLine <$> (string "~NAME" <> brackets (int i)) +prettyElem (Var es i) = do + es' <- prettyBlackBox es + renderOneLine <$> (string "~VAR" <> brackets (string es') <> brackets (int i)) +prettyElem (Sym _ i) = renderOneLine <$> (string "~SYM" <> brackets (int i)) +prettyElem (Typ Nothing) = return "~TYPO" +prettyElem (Typ (Just i)) = renderOneLine <$> (string "~TYP" <> brackets (int i)) +prettyElem (TypM Nothing) = return "~TYPMO" +prettyElem (TypM (Just i)) = renderOneLine <$> (string "~TYPM" <> brackets (int i)) +prettyElem (Err Nothing) = return "~ERRORO" +prettyElem (Err (Just i)) = renderOneLine <$> (string "~ERROR" <> brackets (int i)) +prettyElem (TypElem e) = do + e' <- prettyElem e + renderOneLine <$> (string "~TYPEL" <> brackets (string e')) +prettyElem CompName = return "~COMPNAME" +prettyElem IncludeName = return "~INCLUDENAME" +prettyElem (IndexType e) = do + e' <- prettyElem e + renderOneLine <$> (string "~INDEXTYPE" <> brackets (string e')) +prettyElem (Size e) = do + e' <- prettyElem e + renderOneLine <$> (string "~SIZE" <> brackets (string e')) +prettyElem (Length e) = do + e' <- prettyElem e + renderOneLine <$> (string "~LENGTH" <> brackets (string e')) +prettyElem (Depth e) = do + e' <- prettyElem e + renderOneLine <$> (string "~DEPTH" <> brackets (string e')) +prettyElem (FilePath e) = do + e' <- prettyElem e + renderOneLine <$> (string "~FILE" <> brackets (string e')) +prettyElem (Gen b) = if b then return "~GENERATE" else return "~ENDGENERATE" +prettyElem (IF b esT esF) = do + b' <- prettyElem b + esT' <- prettyBlackBox esT + esF' <- prettyBlackBox esF + (renderLazy . layoutCompact) <$> + (string "~IF" <+> string b' <+> string "~THEN" <> + string esT' <> + string "~ELSE" <> + string esF' <> + string "~FI") +prettyElem (And es) = + (renderLazy . layoutCompact) <$> + (brackets (tupled $ mapM (string <=< prettyElem) es)) +prettyElem IW64 = return "~IW64" +prettyElem (HdlSyn s) = case s of + Vivado -> return "~VIVADO" + _ -> return "~OTHERSYN" +prettyElem (BV b es e) = do + es' <- prettyBlackBox es + e' <- prettyBlackBox [e] + renderOneLine <$> + if b + then string "~TOBV" <> brackets (string es') <> brackets (string e') + else string "~FROMBV" <> brackets (string es') <> brackets (string e') +prettyElem (IsLit i) = renderOneLine <$> (string "~ISLIT" <> brackets (int i)) +prettyElem (IsVar i) = renderOneLine <$> (string "~ISVAR" <> brackets (int i)) +prettyElem (IsGated i) = renderOneLine <$> (string "~ISGATED" <> brackets (int i)) +prettyElem (IsSync i) = renderOneLine <$> (string "~ISSYNC" <> brackets (int i)) +prettyElem (StrCmp es i) = do + es' <- prettyBlackBox es + renderOneLine <$> (string "~STRCMP" <> brackets (string es') <> brackets (int i)) +prettyElem (GenSym es i) = do + es' <- prettyBlackBox es + renderOneLine <$> (string "~GENSYM" <> brackets (string es') <> brackets (int i)) +prettyElem (SigD es mI) = do + es' <- prettyBlackBox es + renderOneLine <$> + (maybe (string "~SIGDO" <> brackets (string es')) + (((string "~SIGD" <> brackets (string es')) <>) . int) + mI) +prettyElem (Vars i) = renderOneLine <$> (string "~VARS" <> brackets (int i)) +prettyElem (OutputWireReg i) = renderOneLine <$> (string "~RESULTWIREREG" <> brackets (int i)) + +usedArguments :: BlackBoxTemplate + -> [Int] +usedArguments = nub . concatMap go + where + go x = case x of + D (Decl i args) -> i : concatMap (\(a,b) -> usedArguments a ++ usedArguments b) args + I _ i -> [i] + L i -> [i] + N i -> [i] + Var _ i -> [i] + IndexType e -> go e + FilePath e -> go e + IF b esT esF -> go b ++ usedArguments esT ++ usedArguments esF + SigD es _ -> usedArguments es + BV _ es _ -> usedArguments es + StrCmp _ i -> [i] + _ -> [] diff --git a/src/Clash/Netlist/Id.hs b/src/Clash/Netlist/Id.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Netlist/Id.hs @@ -0,0 +1,118 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Transform/format a Netlist Identifier so that it is acceptable as a HDL identifier +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module Clash.Netlist.Id + ( IdType (..) + , mkBasicId' + , stripDollarPrefixes + ) +where + +#ifndef MIN_VERSION_text +#error MIN_VERSION_text undefined +#endif + +import Data.Char (isAsciiLower,isAsciiUpper,isDigit) +import Data.Text.Lazy as Text + +data IdType = Basic | Extended + +mkBasicId' :: Bool + -> Text + -> Text +mkBasicId' tupEncode = stripMultiscore . stripLeading . zEncode tupEncode + where + stripLeading = Text.dropWhile (`elem` ('_':['0'..'9'])) + stripMultiscore = Text.concat + . Prelude.map (\cs -> case Text.head cs of + '_' -> "_" + _ -> cs + ) + . Text.group + +stripDollarPrefixes :: Text -> Text +stripDollarPrefixes = stripWorkerPrefix . stripSpecPrefix . stripConPrefix + . stripWorkerPrefix . stripDictFunPrefix + where + stripDictFunPrefix t = case Text.stripPrefix "$f" t of + Just k -> takeWhileEnd (/= '_') k + Nothing -> t + +#if !MIN_VERSION_text(1,2,2) + takeWhileEnd p = Text.reverse . Text.takeWhile p . Text.reverse +#endif + + stripWorkerPrefix t = case Text.stripPrefix "$w" t of + Just k -> k + Nothing -> t + + stripConPrefix t = case Text.stripPrefix "$c" t of + Just k -> k + Nothing -> t + + stripSpecPrefix t = case Text.stripPrefix "$s" t of + Just k -> k + Nothing -> t -- snd (Text.breakOnEnd "$s" t) + + +type UserString = Text -- As the user typed it +type EncodedString = Text -- Encoded form + +zEncode :: Bool -> UserString -> EncodedString +zEncode False cs = go (uncons cs) + where + go Nothing = empty + go (Just (c,cs')) = append (encodeDigitCh c) (go' $ uncons cs') + go' Nothing = empty + go' (Just (c,cs')) = append (encodeCh c) (go' $ uncons cs') + +zEncode True cs = case maybeTuple cs of + Just (n,cs') -> append n (go' (uncons cs')) + Nothing -> go (uncons cs) + where + go Nothing = empty + go (Just (c,cs')) = append (encodeDigitCh c) (go' $ uncons cs') + go' Nothing = empty + go' (Just (c,cs')) = case maybeTuple (cons c cs') of + Just (n,cs2) -> append n (go' $ uncons cs2) + Nothing -> append (encodeCh c) (go' $ uncons cs') + +encodeDigitCh :: Char -> EncodedString +encodeDigitCh c | isDigit c = Text.empty -- encodeAsUnicodeChar c +encodeDigitCh c = encodeCh c + +encodeCh :: Char -> EncodedString +encodeCh c | unencodedChar c = singleton c -- Common case first + | otherwise = Text.empty + +unencodedChar :: Char -> Bool -- True for chars that don't need encoding +unencodedChar c = or [ isAsciiLower c + , isAsciiUpper c + , isDigit c + , c == '_'] + +maybeTuple :: UserString -> Maybe (EncodedString,UserString) +maybeTuple "(# #)" = Just ("Unit",empty) +maybeTuple "()" = Just ("Unit",empty) +maybeTuple (uncons -> Just ('(',uncons -> Just ('#',cs))) = + case countCommas 0 cs of + (n,uncons -> Just ('#',uncons -> Just (')',cs'))) -> Just (pack ("Tup" ++ show (n+1)),cs') + _ -> Nothing +maybeTuple (uncons -> Just ('(',cs)) = + case countCommas 0 cs of + (n,uncons -> Just (')',cs')) -> Just (pack ("Tup" ++ show (n+1)),cs') + _ -> Nothing +maybeTuple _ = Nothing + +countCommas :: Int -> UserString -> (Int,UserString) +countCommas n (uncons -> Just (',',cs)) = countCommas (n+1) cs +countCommas n cs = (n,cs) diff --git a/src/Clash/Netlist/Types.hs b/src/Clash/Netlist/Types.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Netlist/Types.hs @@ -0,0 +1,221 @@ +{-| + Copyright : (C) 2012-2016, University of Twente, + 2017 , Myrtle Software Ltd, Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Type and instance definitions for Netlist modules +-} + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Clash.Netlist.Types + (Declaration (..,NetDecl), module Clash.Netlist.Types) +where + +import Control.DeepSeq +import Control.Monad.State.Strict (MonadIO, MonadState, StateT) +import Data.Hashable +import Data.HashMap.Lazy (HashMap) +import Data.IntMap.Lazy (IntMap, empty) +import qualified Data.Text as S +import Data.Text.Lazy (Text, pack) +import GHC.Generics (Generic) +import Unbound.Generics.LocallyNameless (Fresh, FreshMT) + +import SrcLoc (SrcSpan) + +import Clash.Annotations.TopEntity (TopEntity) +import Clash.Core.Term (TmOccName) +import Clash.Core.Type (Type) +import Clash.Core.TyCon (TyCon, TyConOccName) +import Clash.Driver.Types (BindingMap) +import Clash.Netlist.BlackBox.Types +import Clash.Netlist.Id (IdType) +import Clash.Primitives.Types (PrimMap) +import Clash.Signal.Internal (ClockKind, ResetKind) +import Clash.Util + +-- | Monad that caches generated components (StateT) and remembers hidden inputs +-- of components that are being generated (WriterT) +newtype NetlistMonad a = + NetlistMonad { runNetlist :: StateT NetlistState (FreshMT IO) a } + deriving (Functor, Monad, Applicative, MonadState NetlistState, Fresh, MonadIO) + +-- | State of the NetlistMonad +data NetlistState + = NetlistState + { _bindings :: BindingMap -- ^ Global binders + , _varCount :: !Int -- ^ Number of signal declarations + , _components :: HashMap TmOccName (SrcSpan,Component) -- ^ Cached components + , _primitives :: PrimMap BlackBoxTemplate -- ^ Primitive Definitions + , _typeTranslator :: HashMap TyConOccName TyCon -> Bool -> Type -> Maybe (Either String HWType) + -- ^ Hardcoded Type -> HWType translator + , _tcCache :: HashMap TyConOccName TyCon -- ^ TyCon cache + , _curCompNm :: !(Identifier,SrcSpan) + , _dataFiles :: [(String,FilePath)] + , _intWidth :: Int + , _mkIdentifierFn :: IdType -> Identifier -> Identifier + , _extendIdentifierFn :: IdType -> Identifier -> Identifier -> Identifier + , _seenIds :: [Identifier] + , _seenComps :: [Identifier] + , _componentNames :: HashMap TmOccName Identifier + , _topEntityAnns :: HashMap TmOccName (Type, Maybe TopEntity) + , _hdlDir :: FilePath + } + +-- | Signal reference +type Identifier = Text + +-- | Component: base unit of a Netlist +data Component + = Component + { componentName :: !Identifier -- ^ Name of the component + , inputs :: [(Identifier,HWType)] -- ^ Input ports + , outputs :: [(WireOrReg,(Identifier,HWType))] -- ^ Output ports + , declarations :: [Declaration] -- ^ Internal declarations + } + deriving Show + +instance NFData Component where + rnf c = case c of + Component nm inps outps decls -> rnf nm `seq` rnf inps `seq` + rnf outps `seq` rnf decls + +-- | Size indication of a type (e.g. bit-size or number of elements) +type Size = Int + +-- | Representable hardware types +data HWType + = Void (Maybe HWType) + -- ^ Empty type. @Just Size@ for "empty" Vectors so we can still have + -- primitives that can traverse e.g. Vectors of unit and know the lenght of + -- that vector. + | String -- ^ String type + | Bool -- ^ Boolean type + | Bit -- ^ Bit type + | BitVector !Size -- ^ BitVector of a specified size + | Index !Integer -- ^ Unsigned integer with specified (exclusive) upper bounder + | Signed !Size -- ^ Signed integer of a specified size + | Unsigned !Size -- ^ Unsigned integer of a specified size + | Vector !Size !HWType -- ^ Vector type + | RTree !Size !HWType -- ^ RTree type + | Sum !Identifier [Identifier] -- ^ Sum type: Name and Constructor names + | Product !Identifier [HWType] -- ^ Product type: Name and field types + | SP !Identifier [(Identifier,[HWType])] -- ^ Sum-of-Product type: Name and Constructor names + field types + | Clock !Identifier !Integer !ClockKind -- ^ Clock type with specified name and period + | Reset !Identifier !Integer !ResetKind -- ^ Reset type corresponding to clock with a specified name and period + deriving (Eq,Ord,Show,Generic) + +instance Hashable ClockKind +instance Hashable ResetKind + +instance Hashable HWType +instance NFData HWType + +-- | Internals of a Component +data Declaration + = Assignment !Identifier !Expr + -- ^ Signal assignment: + -- + -- * Signal to assign + -- + -- * Assigned expression + | CondAssignment !Identifier !HWType !Expr !HWType [(Maybe Literal,Expr)] + -- ^ Conditional signal assignment: + -- + -- * Signal to assign + -- + -- * Type of the result/alternatives + -- + -- * Scrutinized expression + -- + -- * Type of the scrutinee + -- + -- * List of: (Maybe expression scrutinized expression is compared with,RHS of alternative) + | InstDecl (Maybe Identifier) !Identifier !Identifier [(Expr,PortDirection,HWType,Expr)] -- ^ Instantiation of another component + | BlackBoxD !S.Text [BlackBoxTemplate] [BlackBoxTemplate] (Maybe ((S.Text,S.Text),BlackBoxTemplate)) !BlackBoxTemplate BlackBoxContext -- ^ Instantiation of blackbox declaration + | NetDecl' (Maybe Identifier) WireOrReg !Identifier (Either Identifier HWType) -- ^ Signal declaration + deriving Show + +data WireOrReg = Wire | Reg + deriving (Show,Generic) + +instance NFData WireOrReg + +pattern NetDecl :: Maybe Identifier -> Identifier -> HWType -> Declaration +pattern NetDecl note d ty <- NetDecl' note Wire d (Right ty) + where + NetDecl note d ty = NetDecl' note Wire d (Right ty) + +data PortDirection = In | Out + deriving Show + +instance NFData Declaration where + rnf a = a `seq` () + +-- | Expression Modifier +data Modifier + = Indexed (HWType,Int,Int) -- ^ Index the expression: (Type of expression,DataCon tag,Field Tag) + | DC (HWType,Int) -- ^ See expression in a DataCon context: (Type of the expression, DataCon tag) + | VecAppend -- ^ See the expression in the context of a Vector append operation + | RTreeAppend -- ^ See the expression in the context of a Tree append operation + | Nested Modifier Modifier + deriving Show + +-- | Expression used in RHS of a declaration +data Expr + = Literal !(Maybe (HWType,Size)) !Literal -- ^ Literal expression + | DataCon !HWType !Modifier [Expr] -- ^ DataCon application + | Identifier !Identifier !(Maybe Modifier) -- ^ Signal reference + | DataTag !HWType !(Either Identifier Identifier) -- ^ @Left e@: tagToEnum#, @Right e@: dataToTag# + | BlackBoxE !S.Text [BlackBoxTemplate] [BlackBoxTemplate] (Maybe ((S.Text,S.Text),BlackBoxTemplate)) !BlackBoxTemplate !BlackBoxContext !Bool -- ^ Instantiation of a BlackBox expression + | ConvBV (Maybe Identifier) HWType Bool Expr + deriving Show + +-- | Literals used in an expression +data Literal + = NumLit !Integer -- ^ Number literal + | BitLit !Bit -- ^ Bit literal + | BoolLit !Bool -- ^ Boolean literal + | VecLit [Literal] -- ^ Vector literal + | StringLit !String -- ^ String literal + deriving (Eq,Show) + +-- | Bit literal +data Bit + = H -- ^ High + | L -- ^ Low + | U -- ^ Undefined + | Z -- ^ High-impedance + deriving (Eq,Show) + +-- | Context used to fill in the holes of a BlackBox template +data BlackBoxContext + = Context + { bbResult :: (Expr,HWType) -- ^ Result name and type + , bbInputs :: [(Expr,HWType,Bool)] -- ^ Argument names, types, and whether it is a literal + , bbFunctions :: IntMap (Either BlackBoxTemplate (Identifier,[Declaration]) + ,WireOrReg + ,[BlackBoxTemplate] + ,[BlackBoxTemplate] + ,Maybe ((S.Text,S.Text),BlackBoxTemplate),BlackBoxContext) + -- ^ Function arguments (subset of inputs): + -- + -- * ( Blackbox Template + -- , Whether the result should be /reg/ or a /wire/ (Verilog only) + -- , Partial Blackbox Context + -- ) + , bbQsysIncName :: Maybe Identifier + } + deriving Show + +emptyBBContext :: BlackBoxContext +emptyBBContext = Context (Identifier (pack "__EMPTY__") Nothing, Void Nothing) [] empty Nothing + +makeLenses ''NetlistState diff --git a/src/Clash/Netlist/Util.hs b/src/Clash/Netlist/Util.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Netlist/Util.hs @@ -0,0 +1,1123 @@ +{-| + Copyright : (C) 2012-2016, University of Twente, + 2017 , Google Inc., Myrtle Software Ltd + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Utilities for converting Core Type/Term to Netlist datatypes +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +module Clash.Netlist.Util where + +import Control.Error (hush) +import Control.Exception (throw) +import Control.Lens ((.=),(%=)) +import qualified Control.Lens as Lens +import Control.Monad (zipWithM) +import Control.Monad.Trans.Except (runExcept) +import Data.Either (partitionEithers) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.List (intersperse, unzip4) +import Data.Maybe (catMaybes,fromMaybe) +import Data.Text.Lazy (append,pack,unpack) +import qualified Data.Text.Lazy as Text +import Unbound.Generics.LocallyNameless + (Embed, Fresh, embed, unbind, unembed, unrec) +import qualified Unbound.Generics.LocallyNameless as Unbound + +import Clash.Annotations.TopEntity (PortName (..), TopEntity (..)) +import Clash.Driver.Types + (ClashException (..), Manifest (..), SrcSpan) +import Clash.Core.DataCon (DataCon (..)) +import Clash.Core.FreeVars (termFreeIds, typeFreeVars) +import Clash.Core.Name (Name (..), appendToName, name2String) +import Clash.Core.Pretty (showDoc) +import Clash.Core.Subst (substTms, substTys) +import Clash.Core.Term (LetBinding, Term (..), TmName, TmOccName) +import Clash.Core.TyCon + (TyCon (..), TyConName, TyConOccName, tyConDataCons) +import Clash.Core.Type (Type (..), TypeView (..), LitTy (..), + coreView, splitTyConAppM, tyView) +import Clash.Core.Util (collectBndrs, termType, tyNatSize) +import Clash.Core.Var (Id, Var (..), modifyVarName) +import Clash.Netlist.Id (IdType (..), stripDollarPrefixes) +import Clash.Netlist.Types as HW +import Clash.Signal.Internal (ClockKind (..)) +import Clash.Util + +isVoid :: HWType -> Bool +isVoid (Void {}) = True +isVoid _ = False + +mkIdentifier :: IdType -> Identifier -> NetlistMonad Identifier +mkIdentifier typ nm = Lens.use mkIdentifierFn <*> pure typ <*> pure nm + +extendIdentifier + :: IdType + -> Identifier + -> Identifier + -> NetlistMonad Identifier +extendIdentifier typ nm ext = + Lens.use extendIdentifierFn <*> pure typ <*> pure nm <*> pure ext + +-- | Split a normalized term into: a list of arguments, a list of let-bindings, +-- and a variable reference that is the body of the let-binding. Returns a +-- String containing the error is the term was not in a normalized form. +splitNormalized :: Fresh m + => HashMap TyConOccName TyCon + -> Term + -> m (Either String ([Id],[LetBinding],Id)) +splitNormalized tcm expr = do + (args,letExpr) <- fmap (first partitionEithers) $ collectBndrs expr + case letExpr of + Letrec b + | (tmArgs,[]) <- args -> do + (xes,e) <- unbind b + case e of + Var t v -> return $! Right (tmArgs,unrec xes,Id v (embed t)) + _ -> return $! Left ($(curLoc) ++ "Not in normal form: res not simple var") + | otherwise -> return $! Left ($(curLoc) ++ "Not in normal form: tyArgs") + _ -> do + ty <- termType tcm expr + return $! Left ($(curLoc) ++ "Not in normal form: no Letrec:\n\n" ++ showDoc expr ++ "\n\nWhich has type:\n\n" ++ showDoc ty) + +-- | Converts a Core type to a HWType given a function that translates certain +-- builtin types. Errors if the Core type is not translatable. +unsafeCoreTypeToHWType + :: SrcSpan + -> String + -> (HashMap TyConOccName TyCon -> Bool -> Type -> Maybe (Either String HWType)) + -> HashMap TyConOccName TyCon + -> Bool + -> Type + -> HWType +unsafeCoreTypeToHWType sp loc builtInTranslation m keepVoid = + either (\msg -> throw (ClashException sp (loc ++ msg) Nothing)) id . + coreTypeToHWType builtInTranslation m keepVoid + +-- | Converts a Core type to a HWType within the NetlistMonad; errors on failure +unsafeCoreTypeToHWTypeM + :: String + -> Type + -> NetlistMonad HWType +unsafeCoreTypeToHWTypeM loc ty = + unsafeCoreTypeToHWType + <$> (snd <$> Lens.use curCompNm) + <*> pure loc + <*> Lens.use typeTranslator + <*> Lens.use tcCache + <*> pure False + <*> pure ty + +-- | Converts a Core type to a HWType within the NetlistMonad; 'Nothing' on failure +coreTypeToHWTypeM + :: Type + -> NetlistMonad (Maybe HWType) +coreTypeToHWTypeM ty = hush <$> (coreTypeToHWType <$> Lens.use typeTranslator <*> Lens.use tcCache <*> pure False <*> pure ty) + +-- | Returns the name and period of the clock corresponding to a type +synchronizedClk :: HashMap TyConOccName TyCon -- ^ TyCon cache + -> Type + -> Maybe (Identifier,Integer) +synchronizedClk tcm ty + | not . null . Lens.toListOf typeFreeVars $ ty = Nothing + | Just (tyCon,args) <- splitTyConAppM ty + = case name2String tyCon of + "Clash.Sized.Vector.Vec" -> synchronizedClk tcm (args!!1) + "Clash.Signal.Internal.SClock" -> case splitTyConAppM (head args) of + Just (_,[LitTy (SymTy s),litTy]) + | Right i <- runExcept (tyNatSize tcm litTy) -> Just (pack s,i) + _ -> error $ $(curLoc) ++ "Clock period not a simple literal: " ++ showDoc ty + "Clash.Signal.Internal.Signal" -> case splitTyConAppM (head args) of + Just (_,[LitTy (SymTy s),litTy]) + | Right i <- runExcept (tyNatSize tcm litTy) -> Just (pack s,i) + _ -> error $ $(curLoc) ++ "Clock period not a simple literal: " ++ showDoc ty + _ -> case tyConDataCons (tcm HashMap.! nameOcc tyCon) of + [dc] -> let argTys = dcArgTys dc + argTVs = map nameOcc (dcUnivTyVars dc) + argSubts = zip argTVs args + args' = map (substTys argSubts) argTys + in case args' of + (arg:_) -> synchronizedClk tcm arg + _ -> Nothing + _ -> Nothing + | otherwise + = Nothing + +-- | Converts a Core type to a HWType given a function that translates certain +-- builtin types. Returns a string containing the error message when the Core +-- type is not translatable. +coreTypeToHWType + :: (HashMap TyConOccName TyCon -> Bool -> Type -> Maybe (Either String HWType)) + -> HashMap TyConOccName TyCon + -> Bool + -> Type + -> Either String HWType +coreTypeToHWType builtInTranslation m keepVoid (builtInTranslation m keepVoid -> Just hty) = + hty +coreTypeToHWType builtInTranslation m keepVoid (coreView m -> Just ty) = + coreTypeToHWType builtInTranslation m keepVoid ty +coreTypeToHWType builtInTranslation m keepVoid ty@(tyView -> TyConApp tc args) = + mkADT builtInTranslation m (showDoc ty) keepVoid tc args +coreTypeToHWType _ _ _ ty = Left $ "Can't translate non-tycon type: " ++ showDoc ty + +-- | Converts an algebraic Core type (split into a TyCon and its argument) to a HWType. +mkADT + :: (HashMap TyConOccName TyCon -> Bool -> Type -> Maybe (Either String HWType)) + -- ^ Hardcoded Type -> HWType translator + -> HashMap TyConOccName TyCon + -- ^ TyCon cache + -> String + -- ^ String representation of the Core type for error messages + -> Bool + -- ^ Keep Void + -> TyConName + -- ^ The TyCon + -> [Type] + -- ^ Its applied arguments + -> Either String HWType +mkADT _ m tyString _ tc _ + | isRecursiveTy m tc + = Left $ $(curLoc) ++ "Can't translate recursive type: " ++ tyString + +mkADT builtInTranslation m tyString keepVoid tc args = case tyConDataCons (m HashMap.! nameOcc tc) of + [] -> Left $ $(curLoc) ++ "Can't translate empty type: " ++ tyString + dcs -> do + let tcName = pack $ name2String tc + argTyss = map dcArgTys dcs + argTVss = map dcUnivTyVars dcs + argSubts = map ((`zip` args) . map nameOcc) argTVss + substArgTyss = zipWith (\s tys -> map (substTys s) tys) argSubts argTyss + argHTyss <- mapM (mapM (coreTypeToHWType builtInTranslation m keepVoid)) substArgTyss + let argHTyss' = if keepVoid + then argHTyss + else map (filter (not . isVoid)) argHTyss + case (dcs,argHTyss') of + (_:[],[[elemTy]]) -> return elemTy + (_:[],[elemTys@(_:_)]) -> return $ Product tcName elemTys + (_ ,concat -> []) + | length dcs < 2 -> return (Void Nothing) + | otherwise -> return $ Sum tcName $ map (pack . name2String . dcName) dcs + (_ ,elemHTys) -> return $ SP tcName + $ zipWith (\dc tys -> + ( pack . name2String $ dcName dc + , tys + ) + ) dcs elemHTys + +-- | Simple check if a TyCon is recursively defined. +isRecursiveTy :: HashMap TyConOccName TyCon -> TyConName -> Bool +isRecursiveTy m tc = case tyConDataCons (m HashMap.! nameOcc tc) of + [] -> False + dcs -> let argTyss = map dcArgTys dcs + argTycons = (map fst . catMaybes) $ (concatMap . map) splitTyConAppM argTyss + in tc `elem` argTycons + +-- | Determines if a Core type is translatable to a HWType given a function that +-- translates certain builtin types. +representableType + :: (HashMap TyConOccName TyCon -> Bool -> Type -> Maybe (Either String HWType)) + -> Bool + -- ^ Allow zero-bit things + -> Bool + -- ^ String considered representable + -> HashMap TyConOccName TyCon + -> Type + -> Bool +representableType builtInTranslation _allowZero stringRepresentable m = + either (const False) isRepresentable . coreTypeToHWType builtInTranslation m False + where + isRepresentable hty = case hty of + String -> stringRepresentable + Vector _ elTy -> isRepresentable elTy + RTree _ elTy -> isRepresentable elTy + Product _ elTys -> all isRepresentable elTys + SP _ elTyss -> all (all isRepresentable . snd) elTyss + _ -> True + +-- | Determines the bitsize of a type +typeSize :: HWType + -> Int +typeSize (Void {}) = 0 +typeSize String = 1 +typeSize Bool = 1 +typeSize Bit = 1 +typeSize (Clock {}) = 1 +typeSize (Reset {}) = 1 +typeSize (BitVector i) = i +typeSize (Index 0) = 0 +typeSize (Index 1) = 1 +typeSize (Index u) = fromMaybe 0 (clogBase 2 u) +typeSize (Signed i) = i +typeSize (Unsigned i) = i +typeSize (Vector n el) = n * typeSize el +typeSize (RTree d el) = (2^d) * typeSize el +typeSize t@(SP _ cons) = conSize t + + maximum (map (sum . map typeSize . snd) cons) +typeSize (Sum _ dcs) = fromMaybe 0 . clogBase 2 . toInteger $ length dcs +typeSize (Product _ tys) = sum $ map typeSize tys + +-- | Determines the bitsize of the constructor of a type +conSize :: HWType + -> Int +conSize (SP _ cons) = fromMaybe 0 . clogBase 2 . toInteger $ length cons +conSize t = typeSize t + +-- | Gives the length of length-indexed types +typeLength :: HWType + -> Int +typeLength (Vector n _) = n +typeLength _ = 0 + +-- | Gives the HWType corresponding to a term. Returns an error if the term has +-- a Core type that is not translatable to a HWType. +termHWType :: String + -> Term + -> NetlistMonad HWType +termHWType loc e = do + m <- Lens.use tcCache + ty <- termType m e + unsafeCoreTypeToHWTypeM loc ty + +-- | Gives the HWType corresponding to a term. Returns 'Nothing' if the term has +-- a Core type that is not translatable to a HWType. +termHWTypeM :: Term + -> NetlistMonad (Maybe HWType) +termHWTypeM e = do + m <- Lens.use tcCache + ty <- termType m e + coreTypeToHWTypeM ty + +-- | Uniquely rename all the variables and their references in a normalized +-- term +mkUniqueNormalized + :: Maybe (Maybe TopEntity) + -> ([Id],[LetBinding],Id) + -> NetlistMonad + ([(Identifier,HWType)] + ,[Declaration] + ,[(Identifier,HWType)] + ,[Declaration] + ,[LetBinding] + ,TmName) +mkUniqueNormalized topMM (args,binds,res) = do + -- Make arguments unique + (iports,iwrappers,substArgs) <- mkUniqueArguments topMM args + -- Make result unique + (oports,owrappers,res1,substRes) <- mkUniqueResult topMM res + let subst' = substRes:substArgs + bndrs = map fst binds + exprs = map (unembed . snd) binds + usesOutput = concatMap (filter ( == (nameOcc . varName) res) + . Lens.toListOf termFreeIds + ) exprs + -- If the let-binder carrying the result is used in a feedback loop + -- rename the let-binder to "_rec", and assign the "_rec" to + -- "". We do this because output ports in most HDLs cannot be read. + (res2,subst'',extraBndr) <- case usesOutput of + [] -> return (varName res1 + ,(nameOcc $ varName res, Var (unembed $ varType res1) (varName res1)):subst' + ,[] :: [(Id, Embed Term)]) + _ -> do + ([res3],_) <- mkUnique [] [modifyVarName (`appendToName` "_rec") res] + return (varName res3,(nameOcc $ varName res,Var (unembed $ varType res3) (varName res3)):subst' + ,[(res1,embed $ Var (unembed $ varType res) (varName res3))]) + -- Replace occurences of "" by "_rec" + let resN = varName res + bndrs' = map (\i -> if varName i == resN then modifyVarName (const res2) i else i) bndrs + (bndrsL,r:bndrsR) = break ((== res2).varName) bndrs' + -- Make let-binders unique + (bndrsL',substL) <- mkUnique subst'' bndrsL + (bndrsR',substR) <- mkUnique substL bndrsR + -- Replace old IDs by updated unique IDs in the RHSs of the let-binders + let exprs' = map (embed . substTms substR) exprs + -- Return the uniquely named arguments, let-binders, and result + return (iports,iwrappers,oports,owrappers,zip (bndrsL' ++ r:bndrsR') exprs' ++ extraBndr,varName res1) + +mkUniqueArguments + :: Maybe (Maybe TopEntity) + -> [Id] + -> NetlistMonad + ([(Identifier,HWType)] + ,[Declaration] + ,[(TmOccName,Term)] + ) +mkUniqueArguments Nothing args = do + (args',subst) <- mkUnique [] args + ports <- mapM idToPort args' + return (ports,[],subst) + +mkUniqueArguments (Just teM) args = do + let iPortSupply = maybe (repeat Nothing) (extendPorts . t_inputs) teM + (ports,decls,subst) <- unzip3 . catMaybes <$> zipWithM go iPortSupply args + let ports' = concat ports + return (ports', concat decls, subst) + where + go pM var = do + tcm <- Lens.use tcCache + typeTrans <- Lens.use typeTranslator + (_,sp) <- Lens.use curCompNm + let i = varName var + i' = pack (name2String i) + ty = unembed (varType var) + hwty = unsafeCoreTypeToHWType sp $(curLoc) typeTrans tcm True ty + (ports,decls,_,pN) <- mkInput pM (i',hwty) + if isVoid hwty + then return Nothing + else return (Just (ports,decls,(nameOcc i, Var ty (repName (unpack pN) i)))) + +mkUniqueResult + :: Maybe (Maybe TopEntity) + -> Id + -> NetlistMonad ([(Identifier,HWType)],[Declaration],Id,(TmOccName,Term)) +mkUniqueResult Nothing res = do + ([res'],[subst]) <- mkUnique [] [res] + port <- idToPort res' + return ([port],[],res',subst) + +mkUniqueResult (Just teM) res = do + tcm <- Lens.use tcCache + typeTrans <- Lens.use typeTranslator + (_,sp) <- Lens.use curCompNm + let o = varName res + o' = pack (name2String o) + ty = unembed (varType res) + hwty = unsafeCoreTypeToHWType sp $(curLoc) typeTrans tcm True ty + oPortSupply = fmap t_output teM + (ports,decls,pN) <- mkOutput oPortSupply (o',hwty) + let pO = repName (unpack pN) o + return (ports,decls,Id pO (embed ty),(nameOcc o,Var ty pO)) + +idToPort :: Id -> NetlistMonad (Identifier,HWType) +idToPort var = do + tcm <- Lens.use tcCache + typeTrans <- Lens.use typeTranslator + (_,sp) <- Lens.use curCompNm + let i = varName var + ty = unembed (varType var) + return + ( pack $ name2String i + , unsafeCoreTypeToHWType sp $(curLoc) typeTrans tcm False ty + ) + +repName :: String -> Name a -> Name a +repName s (Name sort _ loc) = Name sort (Unbound.string2Name s) loc + +-- | Make a set of IDs unique; also returns a substitution from old ID to new +-- updated unique ID. +mkUnique + :: [(TmOccName,Term)] + -- ^ Existing substitution + -> [Id] + -- ^ IDs to make unique + -> NetlistMonad ([Id],[(TmOccName,Term)]) + -- ^ (Unique IDs, update substitution) +mkUnique = go [] + where + go :: [Id] -> [(TmOccName,Term)] -> [Id] -> NetlistMonad ([Id],[(TmOccName,Term)]) + go processed subst [] = return (reverse processed,subst) + go processed subst (i:is) = do + iN <- mkUniqueIdentifier Extended . pack . name2String $ varName i + let iN_unpacked = unpack iN + i' = modifyVarName (repName iN_unpacked) i + go (i':processed) + ((nameOcc . varName $ i,Var (unembed $ varType i') (varName i')):subst) + is + +mkUniqueIdentifier + :: IdType + -> Identifier + -> NetlistMonad Identifier +mkUniqueIdentifier typ nm = do + seen <- Lens.use seenIds + seenC <- Lens.use seenComps + i <- mkIdentifier typ nm + let s = seenC ++ seen + if i `elem` s + then go 0 s i + else do + seenIds %= (i:) + return i + where + go :: Integer -> [Identifier] -> Identifier -> NetlistMonad Identifier + go n s i = do + i' <- extendIdentifier typ i (pack ('_':show n)) + if i' `elem` s + then go (n+1) s i + else do + seenIds %= (i':) + return i' + +-- | Preserve the Netlist '_varEnv' and '_varCount' when executing a monadic action +preserveVarEnv :: NetlistMonad a + -> NetlistMonad a +preserveVarEnv action = do + -- store state + vCnt <- Lens.use varCount + vComp <- Lens.use curCompNm + vSeen <- Lens.use seenIds + -- perform action + val <- action + -- restore state + varCount .= vCnt + curCompNm .= vComp + seenIds .= vSeen + return val + +dcToLiteral :: HWType -> Int -> Literal +dcToLiteral Bool 1 = BoolLit False +dcToLiteral Bool 2 = BoolLit True +dcToLiteral _ i = NumLit (toInteger i-1) + +-- * TopEntity Annotations + +extendPorts :: [PortName] -> [Maybe PortName] +extendPorts ps = map Just ps ++ repeat Nothing + +appendNumber + :: (Identifier,HWType) + -> Int + -> (Identifier,HWType) +appendNumber (nm,hwty) i = + (nm `append` "_" `append` pack (show i),hwty) + +portName + :: String + -> Identifier + -> Identifier +portName [] i = i +portName x _ = pack x + +appendIdentifier + :: (Identifier,HWType) + -> Int + -> NetlistMonad (Identifier,HWType) +appendIdentifier (nm,hwty) i = + (,hwty) <$> extendIdentifier Extended nm (pack ('_':show i)) + +uniquePortName + :: String + -> Identifier + -> NetlistMonad Identifier +uniquePortName [] i = mkUniqueIdentifier Extended i +uniquePortName x _ = do + let x' = pack x + seenIds %= (x':) + return x' + +mkInput + :: Maybe PortName + -> (Identifier,HWType) + -> NetlistMonad ([(Identifier,HWType)],[Declaration],Expr,Identifier) +mkInput pM = case pM of + Nothing -> go + Just p -> go' p + where + go (i,hwty) = do + i' <- mkUniqueIdentifier Extended i + case hwty of + Vector sz hwty' -> do + arguments <- mapM (appendIdentifier (i',hwty')) [0..sz-1] + (ports,_,exprs,_) <- unzip4 <$> mapM (mkInput Nothing) arguments + let hwty2 = filterVoid hwty' + netdecl = NetDecl Nothing i' (Vector sz hwty2) + vecExpr = mkVectorChain sz hwty2 exprs + netassgn = Assignment i' vecExpr + return (concat ports,[netdecl,netassgn],vecExpr,i') + + RTree d hwty' -> do + arguments <- mapM (appendIdentifier (i',hwty')) [0..2^d-1] + (ports,_,exprs,_) <- unzip4 <$> mapM (mkInput Nothing) arguments + let hwty2 = filterVoid hwty' + netdecl = NetDecl Nothing i' (RTree d hwty2) + trExpr = mkRTreeChain d hwty2 exprs + netassgn = Assignment i' trExpr + return (concat ports,[netdecl,netassgn],trExpr,i') + + Product _ hwtys -> do + arguments <- zipWithM appendIdentifier (map (i',) hwtys) [0..] + let argumentsBundled = zip hwtys arguments + argumentsFiltered = filter (not . isVoid . fst) argumentsBundled + argumentsFiltered' = map snd argumentsFiltered + (ports,_,exprs,_) <- unzip4 <$> mapM (mkInput Nothing) argumentsFiltered' + case exprs of + [expr] -> + let hwty' = filterVoid hwty + netdecl = NetDecl Nothing i' hwty' + dcExpr = expr + netassgn = Assignment i' expr + in return (concat ports,[netdecl,netassgn],dcExpr,i') + _ -> + let hwty' = filterVoid hwty + netdecl = NetDecl Nothing i' hwty' + dcExpr = DataCon hwty' (DC (hwty',0)) exprs + netassgn = Assignment i' dcExpr + in return (concat ports,[netdecl,netassgn],dcExpr,i') + + Clock nm rt Gated -> do + let hwtys = [Clock nm rt Source,Bool] + arguments <- zipWithM appendIdentifier (map (i',) hwtys) [0..] + (ports,_,exprs,_) <- unzip4 <$> mapM (mkInput Nothing) arguments + let netdecl = NetDecl Nothing i' hwty + dcExpr = DataCon hwty (DC (hwty,0)) exprs + netassgn = Assignment i' dcExpr + return (concat ports,[netdecl,netassgn],dcExpr,i') + + _ -> return ([(i',hwty)],[],Identifier i' Nothing,i') + + + go' (PortName p) (i,hwty) = do + pN <- uniquePortName p i + return ([(pN,hwty)],[],Identifier pN Nothing,pN) + + go' (PortProduct p ps) (i,hwty) = do + pN <- uniquePortName p i + case hwty of + Vector sz hwty' -> do + arguments <- mapM (appendIdentifier (pN,hwty')) [0..sz-1] + (ports,_,exprs,_) <- unzip4 <$> zipWithM mkInput (extendPorts ps) arguments + let hwty2 = filterVoid hwty' + netdecl = NetDecl Nothing pN (Vector sz hwty2) + vecExpr = mkVectorChain sz hwty2 exprs + netassgn = Assignment pN vecExpr + return (concat ports,[netdecl,netassgn],vecExpr,pN) + + RTree d hwty' -> do + arguments <- mapM (appendIdentifier (pN,hwty')) [0..2^d-1] + (ports,_,exprs,_) <- unzip4 <$> zipWithM mkInput (extendPorts ps) arguments + let hwty2 = filterVoid hwty' + netdecl = NetDecl Nothing pN (RTree d hwty2) + trExpr = mkRTreeChain d hwty2 exprs + netassgn = Assignment pN trExpr + return (concat ports,[netdecl,netassgn],trExpr,pN) + + Product _ hwtys -> do + arguments <- zipWithM appendIdentifier (map (pN,) hwtys) [0..] + let argumentsBundled = zip hwtys (zip (extendPorts ps) arguments) + argumentsFiltered = filter (not . isVoid . fst) argumentsBundled + argumentsFiltered' = unzip (map snd argumentsFiltered) + (ports,_,exprs,_) <- unzip4 <$> uncurry (zipWithM mkInput) argumentsFiltered' + case exprs of + [expr] -> + let hwty' = filterVoid hwty + netdecl = NetDecl Nothing pN hwty' + dcExpr = expr + netassgn = Assignment pN expr + in return (concat ports,[netdecl,netassgn],dcExpr,pN) + _ -> let hwty' = filterVoid hwty + netdecl = NetDecl Nothing pN hwty' + dcExpr = DataCon hwty' (DC (hwty',0)) exprs + netassgn = Assignment pN dcExpr + in return (concat ports,[netdecl,netassgn],dcExpr,pN) + + Clock nm rt Gated -> do + let hwtys = [Clock nm rt Source, Bool] + arguments <- zipWithM appendIdentifier (map (pN,) hwtys) [0..] + (ports,_,exprs,_) <- unzip4 <$> zipWithM mkInput (extendPorts ps) arguments + let netdecl = NetDecl Nothing pN hwty + dcExpr = DataCon hwty (DC (hwty,0)) exprs + netassgn = Assignment pN dcExpr + return (concat ports,[netdecl,netassgn],dcExpr,pN) + + _ -> return ([(pN,hwty)],[],Identifier pN Nothing,pN) + +filterVoid + :: HWType + -> HWType +filterVoid t = case t of + Product nm hwtys + | null hwtys' -> Void Nothing + | length hwtys' == 1 -> head hwtys' + | otherwise -> Product nm hwtys' + where + hwtys' = filter (not . isVoid) (map filterVoid hwtys) + _ -> t + +-- | Create a Vector chain for a list of 'Identifier's +mkVectorChain :: Int + -> HWType + -> [Expr] + -> Expr +mkVectorChain _ elTy [] = DataCon (Vector 0 elTy) VecAppend [] +mkVectorChain _ elTy [e] = DataCon (Vector 1 elTy) VecAppend + [e] +mkVectorChain sz elTy (e:es) = DataCon (Vector sz elTy) VecAppend + [ e + , mkVectorChain (sz-1) elTy es + ] + +-- | Create a RTree chain for a list of 'Identifier's +mkRTreeChain :: Int + -> HWType + -> [Expr] + -> Expr +mkRTreeChain _ elTy [e] = DataCon (RTree 0 elTy) RTreeAppend + [e] +mkRTreeChain d elTy es = + let (esL,esR) = splitAt (length es `div` 2) es + in DataCon (RTree d elTy) RTreeAppend + [ mkRTreeChain (d-1) elTy esL + , mkRTreeChain (d-1) elTy esR + ] + +genComponentName :: [Identifier] -> (IdType -> Identifier -> Identifier) -> TmName -> Identifier +genComponentName seen mkId nm = + let nm' = Text.splitOn (Text.pack ".") (Text.pack (name2String nm)) + fn = mkId Basic (stripDollarPrefixes (last nm')) + fn' = if Text.null fn then Text.pack "Component" else fn + nm2 = Text.concat (intersperse (Text.pack "_") (init nm' ++ [fn'])) + nm3 = mkId Basic nm2 + in if nm3 `elem` seen then go 0 nm3 else nm3 + where + go :: Integer -> Identifier -> Identifier + go n i = + let i' = mkId Basic (i `Text.append` Text.pack ('_':show n)) + in if i' `elem` seen + then go (n+1) i + else i' + +-- | Generate output port mappings +mkOutput + :: Maybe PortName + -> (Identifier,HWType) + -> NetlistMonad ([(Identifier,HWType)],[Declaration],Identifier) +mkOutput pM = case pM of + Nothing -> go + Just p -> go' p + where + go (o,hwty) = do + o' <- mkUniqueIdentifier Extended o + case hwty of + Vector sz hwty' -> do + results <- mapM (appendIdentifier (o',hwty')) [0..sz-1] + (ports,decls,ids) <- unzip3 <$> mapM (mkOutput Nothing) results + let hwty2 = Vector sz (filterVoid hwty') + netdecl = NetDecl Nothing o' hwty2 + assigns = zipWith (assignId o' hwty2 10) ids [0..] + return (concat ports,netdecl:assigns ++ concat decls,o') + + RTree d hwty' -> do + results <- mapM (appendIdentifier (o',hwty')) [0..2^d-1] + (ports,decls,ids) <- unzip3 <$> mapM (mkOutput Nothing) results + let hwty2 = RTree d (filterVoid hwty') + netdecl = NetDecl Nothing o' hwty2 + assigns = zipWith (assignId o' hwty2 10) ids [0..] + return (concat ports,netdecl:assigns ++ concat decls,o') + + Product _ hwtys -> do + results <- zipWithM appendIdentifier (map (o,) hwtys) [0..] + let resultsBundled = zip hwtys results + resultsFiltered = filter (not . isVoid . fst) resultsBundled + resultsFiltered' = map snd resultsFiltered + (ports,decls,ids) <- unzip3 <$> mapM (mkOutput Nothing) resultsFiltered' + case ids of + [i] -> + let hwty' = filterVoid hwty + netdecl = NetDecl Nothing o' hwty' + assign = Assignment i (Identifier o' Nothing) + in return (concat ports,netdecl:assign:concat decls,o') + _ -> + let hwty' = filterVoid hwty + netdecl = NetDecl Nothing o' hwty' + assigns = zipWith (assignId o' hwty' 0) ids [0..] + in return (concat ports,netdecl:assigns ++ concat decls,o') + + _ -> return ([(o',hwty)],[],o') + + go' (PortName p) (o,hwty) = do + pN <- uniquePortName p o + return ([(pN,hwty)],[],pN) + + go' (PortProduct p ps) (o,hwty) = do + pN <- uniquePortName p o + case hwty of + Vector sz hwty' -> do + results <- mapM (appendIdentifier (pN,hwty')) [0..sz-1] + (ports,decls,ids) <- unzip3 <$> zipWithM mkOutput (extendPorts ps) results + let hwty2 = Vector sz (filterVoid hwty') + netdecl = NetDecl Nothing pN hwty2 + assigns = zipWith (assignId pN hwty2 10) ids [0..] + return (concat ports,netdecl:assigns ++ concat decls,pN) + + RTree d hwty' -> do + results <- mapM (appendIdentifier (pN,hwty')) [0..2^d-1] + (ports,decls,ids) <- unzip3 <$> zipWithM mkOutput (extendPorts ps) results + let hwty2 = RTree d (filterVoid hwty') + netdecl = NetDecl Nothing pN hwty2 + assigns = zipWith (assignId pN hwty2 10) ids [0..] + return (concat ports,netdecl:assigns ++ concat decls,pN) + + Product _ hwtys -> do + results <- zipWithM appendIdentifier (map (pN,) hwtys) [0..] + let resultsBundled = zip hwtys (zip (extendPorts ps) results) + resultsFiltered = filter (not . isVoid . fst) resultsBundled + resultsFiltered' = unzip (map snd resultsFiltered) + (ports,decls,ids) <- unzip3 <$> uncurry (zipWithM mkOutput) resultsFiltered' + case ids of + [i] -> let hwty' = filterVoid hwty + netdecl = NetDecl Nothing pN hwty' + assign = Assignment i (Identifier pN Nothing) + in return (concat ports,netdecl:assign:concat decls,pN) + _ -> let hwty' = filterVoid hwty + netdecl = NetDecl Nothing pN hwty' + assigns = zipWith (assignId pN hwty' 0) ids [0..] + in return (concat ports,netdecl:assigns ++ concat decls,pN) + + _ -> return ([(pN,hwty)],[],pN) + + assignId p hwty con i n = + Assignment i (Identifier p (Just (Indexed (hwty,con,n)))) + +-- | Instantiate a TopEntity, and add the proper type-conversions where needed +mkTopUnWrapper + :: TmName + -- ^ Name of the TopEntity component + -> Maybe TopEntity + -- ^ (maybe) a corresponding @TopEntity@ annotation + -> Manifest + -- ^ a corresponding @Manifest@ + -> (Identifier,HWType) + -- ^ The name and type of the signal to which to assign the result + -> [(Expr,HWType)] + -- ^ The arguments + -> NetlistMonad [Declaration] +mkTopUnWrapper topEntity annM man dstId args = do + let inTys = portInTypes man + outTys = portOutTypes man + inNames = portInNames man + outNames = portOutNames man + + -- component name + mkId <- Lens.use mkIdentifierFn + let topName = genComponentName [] mkId topEntity + topName' = maybe topName (pack . t_name) annM + topM = fmap (const topName') annM + + -- inputs + let iPortSupply = maybe (repeat Nothing) + (extendPorts . t_inputs) + annM + arguments <- zipWithM appendIdentifier (map (first (const "input")) args) [0..] + (_,arguments1) <- mapAccumLM (\acc (p,i) -> mkTopInput topM acc p i) + (zip inNames inTys) + (zip iPortSupply arguments) + let (iports,wrappers,idsI) = unzip3 arguments1 + inpAssigns = zipWith (argBV topM) idsI (map fst args) + + -- output + let oPortSupply = maybe (repeat Nothing) + (extendPorts . (:[]) . t_output) + annM + + result = ("result",snd dstId) + (_,(oports,unwrappers,idsO)) <- mkTopOutput topM (zip outNames outTys) + (head oPortSupply) result + let outpAssign = Assignment (fst dstId) (resBV topM idsO) + + instLabel <- extendIdentifier Basic topName' ("_" `append` fst dstId) + let topCompDecl = + InstDecl + (Just topName') + topName' + instLabel + (map (\(p,i,t) -> (Identifier p Nothing,In, t,Identifier i Nothing)) (concat iports) ++ + map (\(p,o,t) -> (Identifier p Nothing,Out,t,Identifier o Nothing)) oports) + + + return (inpAssigns ++ concat wrappers ++ (topCompDecl:unwrappers) ++ [outpAssign]) + +-- | Convert between BitVector for an argument +argBV + :: Maybe Identifier + -- ^ (maybe) Name of the _TopEntity_ + -> Either Identifier (Identifier, HWType) + -- ^ Either: + -- * A /normal/ argument + -- * An argument with a @PortName@ + -> Expr + -> Declaration +argBV _ (Left i) e = Assignment i e +argBV topM (Right (i,t)) e = Assignment i + . doConv t (fmap Just topM) False + $ doConv t (fmap (const Nothing) topM) True e + +-- | Convert between BitVector for the result +resBV + :: Maybe Identifier + -- ^ (mabye) Name of the _TopEntity_ + -> Either Identifier (Identifier, HWType) + -- ^ Either: + -- * A /normal/ result + -- * A result with a @PortName@ + -> Expr +resBV _ (Left i) = Identifier i Nothing +resBV topM (Right (i,t)) = doConv t (fmap (const Nothing) topM) False + . doConv t (fmap Just topM) True + $ Identifier i Nothing + + +-- | Add to/from-BitVector conversion logic +doConv + :: HWType + -- ^ We only need it for certain types + -> Maybe (Maybe Identifier) + -- ^ + -- * Nothing: No _given_ TopEntity, no need for conversion, this + -- happens when we have a _TestBench_, but no + -- _TopEntity_ annotation. + -- * Just Nothing: Converting to/from a BitVector for one of the + -- internally defined types. + -- * Just (Just top): Converting to/from a BitVector for one of the + -- types defined by @top@. + -> Bool + -- ^ + -- * True: convert to a BitVector + -- * False: convert from a BitVector + -> Expr + -- ^ The expression on top of which we have to add conversion logic + -> Expr +doConv _ Nothing _ e = e +doConv hwty (Just topM) b e = case hwty of + Vector {} -> ConvBV topM hwty b e + RTree {} -> ConvBV topM hwty b e + Product {} -> ConvBV topM hwty b e + Clock _ _ Gated -> ConvBV topM hwty b e + _ -> e + +-- | Generate input port mappings for the TopEntity +mkTopInput + :: Maybe Identifier + -- ^ (maybe) Name of the _TopEntity_ + -> [(Identifier,Identifier)] + -- ^ /Rendered/ input port names and types + -> Maybe PortName + -- ^ (maybe) The @PortName@ of a _TopEntity_ annotation for this input + -> (Identifier,HWType) + -> NetlistMonad ([(Identifier,Identifier)] + ,([(Identifier,Identifier,HWType)] + ,[Declaration] + ,Either Identifier (Identifier,HWType))) +mkTopInput topM inps pM = case pM of + Nothing -> go inps + Just p -> go' p inps + where + -- No @PortName@ + go inps'@((iN,_):rest) (i,hwty) = do + i' <- mkUniqueIdentifier Basic i + let iDecl = NetDecl Nothing i' hwty + case hwty of + Vector sz hwty' -> do + arguments <- mapM (appendIdentifier (i',hwty')) [0..sz-1] + (inps'',arguments1) <- mapAccumLM go inps' arguments + let (ports,decls,ids) = unzip3 arguments1 + assigns = zipWith (argBV topM) ids + [ Identifier i' (Just (Indexed (hwty,10,n))) + | n <- [0..]] + return (inps'',(concat ports,iDecl:assigns++concat decls,Left i')) + + RTree d hwty' -> do + arguments <- mapM (appendIdentifier (i',hwty')) [0..2^d-1] + (inps'',arguments1) <- mapAccumLM go inps' arguments + let (ports,decls,ids) = unzip3 arguments1 + assigns = zipWith (argBV topM) ids + [ Identifier i' (Just (Indexed (hwty,10,n))) + | n <- [0..]] + return (inps'',(concat ports,iDecl:assigns++concat decls,Left i')) + + Product _ hwtys -> do + arguments <- zipWithM appendIdentifier (map (i,) hwtys) [0..] + (inps'',arguments1) <- mapAccumLM go inps' arguments + let (ports,decls,ids) = unzip3 arguments1 + assigns = zipWith (argBV topM) ids + [ Identifier i' (Just (Indexed (hwty,0,n))) + | n <- [0..]] + return (inps'',(concat ports,iDecl:assigns++concat decls,Left i')) + + Clock nm rt Gated -> do + let hwtys = [Clock nm rt Source,Bool] + arguments <- zipWithM appendIdentifier (map (i,) hwtys) [0..] + (inps'',arguments1) <- mapAccumLM go inps' arguments + let (ports,decls,ids) = unzip3 arguments1 + assigns = zipWith (argBV topM) ids + [ Identifier i' (Just (Indexed (hwty,0,n))) + | n <- [0..]] + return (inps'',(concat ports,iDecl:assigns++concat decls,Left i')) + + _ -> return (rest,([(iN,i',hwty)],[iDecl],Left i')) + + go [] _ = error "This shouldn't happen" + + -- With a @PortName@ + go' (PortName _) ((iN,iTy):inps') (_,hwty) = do + iN' <- mkUniqueIdentifier Extended iN + return (inps',([(iN,iN',hwty)] + ,[NetDecl' Nothing Wire iN' (Left iTy)] + ,Right (iN',hwty))) + + go' (PortName _) [] _ = error "This shouldnt happen" + + go' (PortProduct p ps) inps' (i,hwty) = do + let pN = portName p i + pN' <- mkUniqueIdentifier Extended pN + let pDecl = NetDecl Nothing pN' hwty + case hwty of + Vector sz hwty' -> do + arguments <- mapM (appendIdentifier (pN',hwty')) [0..sz-1] + (inps'',arguments1) <- + mapAccumLM (\acc (p',o') -> mkTopInput topM acc p' o') inps' + (zip (extendPorts ps) arguments) + let (ports,decls,ids) = unzip3 arguments1 + assigns = zipWith (argBV topM) ids + [ Identifier pN' (Just (Indexed (hwty,10,n))) + | n <- [0..]] + return (inps'',(concat ports,pDecl:assigns ++ concat decls,Left pN')) + + RTree d hwty' -> do + arguments <- mapM (appendIdentifier (pN',hwty')) [0..2^d-1] + (inps'',arguments1) <- + mapAccumLM (\acc (p',o') -> mkTopInput topM acc p' o') inps' + (zip (extendPorts ps) arguments) + let (ports,decls,ids) = unzip3 arguments1 + assigns = zipWith (argBV topM) ids + [ Identifier pN' (Just (Indexed (hwty,10,n))) + | n <- [0..]] + return (inps'',(concat ports,pDecl:assigns ++ concat decls,Left pN')) + + Product _ hwtys -> do + arguments <- zipWithM appendIdentifier (map (pN',) hwtys) [0..] + (inps'',arguments1) <- + mapAccumLM (\acc (p',o') -> mkTopInput topM acc p' o') inps' + (zip (extendPorts ps) arguments) + let (ports,decls,ids) = unzip3 arguments1 + assigns = zipWith (argBV topM) ids + [ Identifier pN' (Just (Indexed (hwty,0,n))) + | n <- [0..]] + return (inps'',(concat ports,pDecl:assigns ++ concat decls,Left pN')) + + Clock nm rt Gated -> do + let hwtys = [Clock nm rt Source,Bool] + arguments <- zipWithM appendIdentifier (map (pN',) hwtys) [0..] + (inps'',arguments1) <- + mapAccumLM (\acc (p',o') -> mkTopInput topM acc p' o') inps' + (zip (extendPorts ps) arguments) + let (ports,decls,ids) = unzip3 arguments1 + assigns = zipWith (argBV topM) ids + [ Identifier pN' (Just (Indexed (hwty,0,n))) + | n <- [0..]] + return (inps'',(concat ports,pDecl:assigns ++ concat decls,Left pN')) + + _ -> return (tail inps',([(pN,pN',hwty)],[pDecl],Left pN')) + +-- | Generate output port mappings for the TopEntity +mkTopOutput + :: Maybe Identifier + -- ^ (maybe) Name of the _TopEntity_ + -> [(Identifier,Identifier)] + -- ^ /Rendered/ output port names and types + -> Maybe PortName + -- ^ (maybe) The @PortName@ of a _TopEntity_ annotation for this output + -> (Identifier,HWType) + -> NetlistMonad ([(Identifier,Identifier)] + ,([(Identifier,Identifier,HWType)] + ,[Declaration] + ,Either Identifier (Identifier,HWType)) + ) +mkTopOutput topM outps pM = case pM of + Nothing -> go outps + Just p -> go' p outps + where + -- No @PortName@ + go outps'@((oN,_):rest) (o,hwty) = do + o' <- mkUniqueIdentifier Extended o + let oDecl = NetDecl Nothing o' hwty + case hwty of + Vector sz hwty' -> do + results <- mapM (appendIdentifier (o',hwty')) [0..sz-1] + (outps'',results1) <- mapAccumLM go outps' results + let (ports,decls,ids) = unzip3 results1 + ids' = map (resBV topM) ids + netassgn = Assignment o' (mkVectorChain sz hwty' ids') + return (outps'',(concat ports,oDecl:netassgn:concat decls,Left o')) + + RTree d hwty' -> do + results <- mapM (appendIdentifier (o',hwty')) [0..2^d-1] + (outps'',results1) <- mapAccumLM go outps' results + let (ports,decls,ids) = unzip3 results1 + ids' = map (resBV topM) ids + netassgn = Assignment o' (mkRTreeChain d hwty' ids') + return (outps'',(concat ports,oDecl:netassgn:concat decls,Left o')) + + Product _ hwtys -> do + results <- zipWithM appendIdentifier (map (o',) hwtys) [0..] + (outps'',results1) <- mapAccumLM go outps' results + let (ports,decls,ids) = unzip3 results1 + ids' = map (resBV topM) ids + netassgn = Assignment o' (DataCon hwty (DC (hwty,0)) ids') + return (outps'',(concat ports,oDecl:netassgn:concat decls,Left o')) + + _ -> return (rest,([(oN,o',hwty)],[oDecl],Left o')) + + go [] _ = error "This shouldn't happen" + + -- With a @PortName@ + go' (PortName _) ((oN,oTy):outps') (_,hwty) = do + oN' <- mkUniqueIdentifier Extended oN + return (outps',([(oN,oN',hwty)] + ,[NetDecl' Nothing Wire oN' (Left oTy)] + ,Right (oN',hwty))) + + go' (PortName _) [] _ = error "This shouldnt happen" + + go' (PortProduct p ps) outps' (o,hwty) = do + let pN = portName p o + pN' <- mkUniqueIdentifier Extended pN + let pDecl = NetDecl Nothing pN' hwty + case hwty of + Vector sz hwty' -> do + results <- mapM (appendIdentifier (pN',hwty')) [0..sz-1] + (outps'',results1) <- + mapAccumLM (\acc (p',o') -> mkTopOutput topM acc p' o') outps' + (zip (extendPorts ps) results) + let (ports,decls,ids) = unzip3 results1 + ids' = map (resBV topM) ids + netassgn = Assignment pN' (mkVectorChain sz hwty' ids') + return (outps'',(concat ports,pDecl:netassgn:concat decls,Left pN')) + + RTree d hwty' -> do + results <- mapM (appendIdentifier (pN',hwty')) [0..2^d-1] + (outps'',results1) <- + mapAccumLM (\acc (p',o') -> mkTopOutput topM acc p' o') outps' + (zip (extendPorts ps) results) + let (ports,decls,ids) = unzip3 results1 + ids' = map (resBV topM) ids + netassgn = Assignment pN' (mkRTreeChain d hwty' ids') + return (outps'',(concat ports,pDecl:netassgn:concat decls,Left pN')) + + Product _ hwtys -> do + results <- zipWithM appendIdentifier (map (pN',) hwtys) [0..] + (outps'',results1) <- + mapAccumLM (\acc (p',o') -> mkTopOutput topM acc p' o') outps' + (zip (extendPorts ps) results) + let (ports,decls,ids) = unzip3 results1 + ids' = map (resBV topM) ids + netassgn = Assignment pN' (DataCon hwty (DC (hwty,0)) ids') + return (outps'',(concat ports,pDecl:netassgn:concat decls,Left pN')) + + _ -> return (tail outps',([(pN,pN',hwty)],[pDecl],Left pN')) + +concatPortDecls3 + :: [([(Identifier,Identifier,HWType)] + ,[Declaration] + ,Either Identifier (Identifier,HWType))] + -> ([(Identifier,Identifier,HWType)] + ,[Declaration] + ,[Either Identifier (Identifier,HWType)]) +concatPortDecls3 portDecls = case unzip3 portDecls of + (ps,decls,ids) -> (concat ps, concat decls, ids) diff --git a/src/Clash/Normalize.hs b/src/Clash/Normalize.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Normalize.hs @@ -0,0 +1,406 @@ +{-| + Copyright : (C) 2012-2016, University of Twente, + 2016 , Myrtle Software Ltd, + 2017 , Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Turn CoreHW terms into normalized CoreHW Terms +-} + +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +module Clash.Normalize where + +import Control.Concurrent.Supply (Supply) +import Control.Lens ((.=),(^.),_2,_5) +import qualified Control.Lens as Lens +import Data.Either (partitionEithers) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashSet as HashSet +import Data.IntMap.Strict (IntMap) +import Data.List + (groupBy, intersect, mapAccumL, sortBy) +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Set as Set +import qualified Data.Set.Lens as Lens +import Data.Semigroup ((<>)) +import Data.Text.Prettyprint.Doc (vcat) +import Unbound.Generics.LocallyNameless (unembed, runLFreshM) + +import BasicTypes (InlineSpec (..)) +import SrcLoc (SrcSpan,noSrcSpan) + +import Clash.Core.Evaluator (PrimEvaluator) +import Clash.Core.FreeVars (termFreeIds) +import Clash.Core.Name (Name (..), NameSort (..)) +import Clash.Core.Pretty (showDoc, ppr) +import Clash.Core.Subst (substTms) +import Clash.Core.Term (Term (..), TmName, TmOccName) +import Clash.Core.Type (Type, splitCoreFunForallTy) +import Clash.Core.TyCon + (TyCon, TyConName, TyConOccName) +import Clash.Core.Util (collectArgs, mkApps, termType) +import Clash.Core.Var (Id,varName) +import Clash.Driver.Types + (BindingMap, ClashOpts (..), DebugLevel (..)) +import Clash.Netlist.BlackBox.Types (BlackBoxTemplate) +import Clash.Netlist.Types (HWType (..)) +import Clash.Netlist.Util + (splitNormalized, unsafeCoreTypeToHWType) +import Clash.Normalize.Strategy +import Clash.Normalize.Transformations + (appProp, bindConstantVar, caseCon, flattenLet, reduceConst, topLet) +import Clash.Normalize.Types +import Clash.Normalize.Util +import Clash.Primitives.Types (PrimMap) +import Clash.Rewrite.Combinators ((>->),(!->)) +import Clash.Rewrite.Types + (RewriteEnv (..), RewriteState (..), bindings, curFun, dbgLevel, extra, + tcCache, topEntities, typeTranslator) +import Clash.Rewrite.Util (isUntranslatableType, + runRewrite, + runRewriteSession) +import Clash.Signal.Internal (ResetKind (..)) +import Clash.Util + +-- | Run a NormalizeSession in a given environment +runNormalization + :: ClashOpts + -- ^ Level of debug messages to print + -> Supply + -- ^ UniqueSupply + -> BindingMap + -- ^ Global Binders + -> (HashMap TyConOccName TyCon -> Bool -> Type -> Maybe (Either String HWType)) + -- ^ Hardcoded Type -> HWType translator + -> HashMap TyConOccName TyCon + -- ^ TyCon cache + -> IntMap TyConName + -- ^ Tuple TyCon cache + -> PrimEvaluator + -- ^ Hardcoded evaluator (delta-reduction) + -> PrimMap BlackBoxTemplate + -- ^ Primitive Definitions + -> HashMap TmOccName Bool + -- ^ Map telling whether a components is part of a recursive group + -> [TmOccName] + -- ^ topEntities + -> NormalizeSession a + -- ^ NormalizeSession to run + -> a +runNormalization opts supply globals typeTrans tcm tupTcm eval primMap rcsMap topEnts + = runRewriteSession rwEnv rwState + where + rwEnv = RewriteEnv + (opt_dbgLevel opts) + typeTrans + tcm + tupTcm + eval + (opt_allowZero opts) + (HashSet.fromList topEnts) + + rwState = RewriteState + 0 + globals + supply + (error $ $(curLoc) ++ "Report as bug: no curFun",noSrcSpan) + 0 + normState + + normState = NormalizeState + HashMap.empty + Map.empty + HashMap.empty + (opt_specLimit opts) + HashMap.empty + (opt_inlineLimit opts) + (opt_inlineFunctionLimit opts) + (opt_inlineConstantLimit opts) + primMap + rcsMap + + +normalize + :: [TmOccName] + -> NormalizeSession BindingMap +normalize [] = return HashMap.empty +normalize top = do + (new,topNormalized) <- unzip <$> mapM normalize' top + newNormalized <- normalize (concat new) + return (HashMap.union (HashMap.fromList topNormalized) newNormalized) + +normalize' + :: TmOccName + -> NormalizeSession ([TmOccName],(TmOccName,(TmName,Type,SrcSpan,InlineSpec,Term))) +normalize' nm = do + exprM <- HashMap.lookup nm <$> Lens.use bindings + let nmS = showDoc nm + case exprM of + Just (nm',ty,sp,inl,tm) -> do + tcm <- Lens.view tcCache + let (_,resTy) = splitCoreFunForallTy tcm ty + resTyRep <- not <$> isUntranslatableType False resTy + if resTyRep + then do + tmNorm <- makeCached nm (extra.normalized) $ do + curFun .= (nm',sp) + tm' <- rewriteExpr ("normalization",normalization) (nmS,tm) + ty' <- termType tcm tm' + return (nm',ty',sp,inl,tm') + let usedBndrs = Lens.toListOf termFreeIds (tmNorm ^. _5) + traceIf (nm `elem` usedBndrs) + (concat [ $(curLoc),"Expr belonging to bndr: ",nmS ," (:: " + , showDoc (tmNorm ^. _2) + , ") remains recursive after normalization:\n" + , showDoc (tmNorm ^. _5) ]) + (return ()) + tyTrans <- Lens.view typeTranslator + case clockResetErrors sp tyTrans tcm ty of + msgs@(_:_) -> traceIf True (concat (nmS:" (:: ":showDoc (tmNorm ^. _2) + :")\nhas potentially dangerous meta-stability issues:\n\n" + :msgs)) + (return ()) + _ -> return () + prevNorm <- fmap HashMap.keys $ Lens.use (extra.normalized) + topEnts <- Lens.view topEntities + let toNormalize = filter (not . (`HashSet.member` topEnts)) + $ filter (`notElem` (nm:prevNorm)) usedBndrs + return (toNormalize,(nm,tmNorm)) + else do + let usedBndrs = Lens.toListOf termFreeIds tm + prevNorm <- fmap HashMap.keys $ Lens.use (extra.normalized) + topEnts <- Lens.view topEntities + let toNormalize = filter (not . (`HashSet.member` topEnts)) + $ filter (`notElem` (nm:prevNorm)) usedBndrs + lvl <- Lens.view dbgLevel + traceIf (lvl >= DebugFinal) + (concat [$(curLoc), "Expr belonging to bndr: ", nmS, " (:: " + , showDoc ty + , ") has a non-representable return type." + , " Not normalising:\n", showDoc tm] ) + (return (toNormalize,(nm,(nm',ty,sp,inl,tm)))) + Nothing -> error $ $(curLoc) ++ "Expr belonging to bndr: " ++ nmS ++ " not found" + +-- | Rewrite a term according to the provided transformation +rewriteExpr :: (String,NormRewrite) -- ^ Transformation to apply + -> (String,Term) -- ^ Term to transform + -> NormalizeSession Term +rewriteExpr (nrwS,nrw) (bndrS,expr) = do + lvl <- Lens.view dbgLevel + let before = showDoc expr + let expr' = traceIf (lvl >= DebugFinal) + (bndrS ++ " before " ++ nrwS ++ ":\n\n" ++ before ++ "\n") + expr + rewritten <- runRewrite nrwS nrw expr' + let after = showDoc rewritten + traceIf (lvl >= DebugFinal) + (bndrS ++ " after " ++ nrwS ++ ":\n\n" ++ after ++ "\n") $ + return rewritten + +-- | Check whether the normalized bindings are non-recursive. Errors when one +-- of the components is recursive. +checkNonRecursive + :: BindingMap + -- ^ List of normalized binders + -> BindingMap +checkNonRecursive norm = case Maybe.mapMaybe go (HashMap.toList norm) of + [] -> norm + rcs -> error $ $(curLoc) ++ "Callgraph after normalisation contains following recursive components: " + ++ show (vcat $ runLFreshM $ sequence [ do a' <- ppr a + b' <- ppr b + return $ a' <> b' + | (a,b ) <- rcs + ]) + where + go (nm,(_,_,_,_,tm)) = + let used = Lens.toListOf termFreeIds tm + in if nm `elem` used + then Just (nm,tm) + else Nothing + +-- | Perform general \"clean up\" of the normalized (non-recursive) function +-- hierarchy. This includes: +-- +-- * Inlining functions that simply \"wrap\" another function +cleanupGraph + :: TmOccName + -> BindingMap + -> NormalizeSession BindingMap +cleanupGraph topEntity norm + | Just ct <- mkCallTree [] norm topEntity + = do ctFlat <- flattenCallTree ct + return (HashMap.fromList $ snd $ callTreeToList [] ctFlat) +cleanupGraph _ norm = return norm + +data CallTree = CLeaf (TmOccName,(TmName,Type,SrcSpan,InlineSpec,Term)) + | CBranch (TmOccName,(TmName,Type,SrcSpan,InlineSpec,Term)) [CallTree] + +mkCallTree + :: [TmOccName] + -- ^ Visited + -> BindingMap + -- ^ Global binders + -> TmOccName + -- ^ Root of the call graph + -> Maybe CallTree +mkCallTree visited bindingMap root + | Just rootTm <- HashMap.lookup root bindingMap + = let used = Set.toList $ Lens.setOf termFreeIds $ (rootTm ^. _5) + other = Maybe.mapMaybe (mkCallTree (root:visited) bindingMap) (filter (`notElem` visited) used) + in case used of + [] -> Just (CLeaf (root,rootTm)) + _ -> Just (CBranch (root,rootTm) other) +mkCallTree _ _ _ = Nothing + +stripArgs + :: [TmOccName] + -> [Id] + -> [Either Term Type] + -> Maybe [Either Term Type] +stripArgs _ (_:_) [] = Nothing +stripArgs allIds [] args = if any mentionsId args + then Nothing + else Just args + where + mentionsId t = not $ null (either (Lens.toListOf termFreeIds) (const []) t + `intersect` + allIds) + +stripArgs allIds (id_:ids) (Left (Var _ nm):args) + | varName id_ == nm = stripArgs allIds ids args + | otherwise = Nothing +stripArgs _ _ _ = Nothing + +flattenNode + :: CallTree + -> NormalizeSession (Either CallTree ((TmOccName,Term),[CallTree])) +flattenNode (CLeaf (nm,(nameSort -> Internal,_,_,_,e))) = + return (Right ((nm,e),[])) +flattenNode c@(CLeaf (nm,(_,_,_,_,e))) = do + tcm <- Lens.view tcCache + norm <- splitNormalized tcm e + case norm of + Right (ids,[(_,bExpr)],_) -> do + let (fun,args) = collectArgs (unembed bExpr) + case stripArgs (map (nameOcc.varName) ids) (reverse ids) (reverse args) of + Just remainder -> return (Right ((nm,mkApps fun (reverse remainder)),[])) + Nothing -> return (Right ((nm,e),[])) + _ | isCheapFunction e -> return (Right ((nm,e),[])) + | otherwise -> return (Left c) +flattenNode (CBranch (nm,(nameSort -> Internal,_,_,_,e)) us) = + return (Right ((nm,e),us)) +flattenNode b@(CBranch (nm,(_,_,_,_,e)) us) = do + tcm <- Lens.view tcCache + norm <- splitNormalized tcm e + case norm of + Right (ids,[(_,bExpr)],_) -> do + let (fun,args) = collectArgs (unembed bExpr) + case stripArgs (map (nameOcc.varName) ids) (reverse ids) (reverse args) of + Just remainder -> return (Right ((nm,mkApps fun (reverse remainder)),us)) + Nothing -> return (Right ((nm,e),us)) + _ | isCheapFunction e -> return (Right ((nm,e),us)) + | otherwise -> return (Left b) + +flattenCallTree + :: CallTree + -> NormalizeSession CallTree +flattenCallTree c@(CLeaf _) = return c +flattenCallTree (CBranch (nm,(nm',ty,sp,inl,tm)) used) = do + flattenedUsed <- mapM flattenCallTree used + (newUsed,il_ct) <- partitionEithers <$> mapM flattenNode flattenedUsed + let (toInline,il_used) = unzip il_ct + newExpr <- case toInline of + [] -> return tm + _ -> rewriteExpr ("flattenExpr",flatten) (showDoc nm, substTms toInline tm) + let allUsed = newUsed ++ concat il_used + -- inline all components when the resulting expression after flattening + -- is still considered "cheap". This happens often at the topEntity which + -- wraps another functions and has some selectors and data-constructors. + if isCheapFunction newExpr + then do + let (toInline',allUsed') = unzip (map goCheap allUsed) + newExpr' <- rewriteExpr ("flattenCheap",flatten) (showDoc nm, substTms toInline' newExpr) + return (CBranch (nm,(nm',ty,sp,inl,newExpr')) (concat allUsed')) + else return (CBranch (nm,(nm',ty,sp,inl,newExpr)) allUsed) + where + flatten = + innerMost (appProp >-> bindConstantVar >-> caseCon >-> reduceConst >-> flattenLet) !-> + topdownSucR topLet + + goCheap (CLeaf (nm2,(_,_,_,_,e))) = ((nm2,e),[]) + goCheap (CBranch (nm2,(_,_,_,_,e)) us) = ((nm2,e),us) + +callTreeToList + :: [TmOccName] + -> CallTree + -> ([TmOccName],[(TmOccName,(TmName,Type,SrcSpan,InlineSpec,Term))]) +callTreeToList visited (CLeaf (nm,bndr)) + | nm `elem` visited = (visited,[]) + | otherwise = (nm:visited,[(nm,bndr)]) +callTreeToList visited (CBranch (nm,bndr) used) + | nm `elem` visited = (visited,[]) + | otherwise = (visited',(nm,bndr):(concat others)) + where + (visited',others) = mapAccumL callTreeToList (nm:visited) used + +-- | Clash's clock and reset domain annotations prevent most accidental +-- meta-stability situations. That is, unless the developer uses the +-- functions marked "unsafe", the type system will prevent things like +-- illegal clock domain crossing, or improper use of asynchronous resets. +-- +-- However, this all depends on clock and resets being unique. With explicit +-- clocks and resets, it is possible to have multiple clock and reset arguments +-- that are annotated with the same domain. If these arguments aren't connected +-- to the same source, we can still get metastability due to either illegal +-- clock domain crossing, or improper use of asynchronous resets. +-- +-- The following situations are reported: +-- * There are 2 or more clock arguments in scope that have the same clock +-- domain annotation. +-- * There are 2 or more reset arguments in scope that have the same reset +-- domain annotation, and at least one of them is an asynchronous reset. +clockResetErrors + :: SrcSpan + -> (HashMap TyConOccName TyCon -> Bool -> Type -> Maybe (Either String HWType)) + -> HashMap TyConOccName TyCon + -> Type + -> [String] +clockResetErrors sp tyTran tcm ty = + (Maybe.mapMaybe reportClock clks ++ Maybe.mapMaybe reportResets rsts) + where + (args,_) = splitCoreFunForallTy tcm ty + (_,args') = partitionEithers args + hwArgs = zip (map (unsafeCoreTypeToHWType sp $(curLoc) tyTran tcm False) args') args' + clks = groupBy ((==) `on` fst) . sortBy (compare `on` fst) + $ [ ((nm,i),ty') | (Clock nm i _,ty') <- hwArgs] + rsts = groupBy ((==) `on` (fst.fst)) . sortBy (compare `on` (fst.fst)) + $ [ (((nm,i),s),ty') | (Reset nm i s,ty') <- hwArgs] + + reportClock clks' + | length clks' >= 2 + = Just + $ concat ["The following clocks:\n" + ,concatMap (\c -> "* " ++ showDoc (snd c) ++ "\n") clks' + ,"belong to the same clock domain and should be connected to " + ,"the same clock source in order to prevent meta-stability " + ,"issues." + ] + | otherwise + = Nothing + + reportResets rsts' + | length rsts' >= 2 + , any (\((_,sync),_) -> sync == Asynchronous) rsts' + = Just + $ concat ["The following resets:\n" + ,concatMap (\c -> "* " ++ showDoc (snd c) ++ "\n") rsts' + ,"belong to the same reset domain, and one or more of these " + ,"resets is Asynchronous. Ensure that these resets are " + ,"synchronized in order to prevent meta-stability issues." + ] + reportResets _ = Nothing diff --git a/src/Clash/Normalize/DEC.hs b/src/Clash/Normalize/DEC.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Normalize/DEC.hs @@ -0,0 +1,486 @@ +{-| + Copyright : (C) 2015-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Helper functions for the 'disjointExpressionConsolidation' transformation + + The 'disjointExpressionConsolidation' transformation lifts applications of + global binders out of alternatives of case-statements. + + e.g. It converts: + + > case x of + > A -> f 3 y + > B -> f x x + > C -> h x + + into: + + > let f_arg0 = case x of {A -> 3; B -> x} + > f_arg1 = case x of {A -> y; B -> x} + > f_out = f f_arg0 f_arg1 + > in case x of + > A -> f_out + > B -> f_out + > C -> h x +-} + +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +module Clash.Normalize.DEC + (collectGlobals + ,isDisjoint + ,mkDisjointGroup + ) +where + +-- external +import Control.Concurrent.Supply (splitSupply) +import qualified Control.Lens as Lens +import Data.Bits ((.&.),complement) +import qualified Data.Either as Either +import qualified Data.Foldable as Foldable +import qualified Data.HashMap.Strict as HashMap +import qualified Data.IntMap.Strict as IM +import qualified Data.List as List +import qualified Data.Map.Strict as Map +import qualified Data.Maybe as Maybe +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Set.Lens as Lens + +import Unbound.Generics.LocallyNameless + (Bind, bind, embed, fv, unbind, unembed, unrec) +import qualified Unbound.Generics.LocallyNameless as Unbound + +-- internal +import Clash.Core.DataCon (DataCon, dcTag) +import Clash.Core.Evaluator (whnf') +import Clash.Core.FreeVars (termFreeIds, typeFreeVars) +import Clash.Core.Name (Name (..), string2InternalName) +import Clash.Core.Literal (Literal (..)) +import Clash.Core.Term (LetBinding, Pat (..), Term (..), TmOccName) +import Clash.Core.TyCon (tyConDataCons) +import Clash.Core.Type (Type, isPolyFunTy, mkTyConApp, splitFunForallTy) +import Clash.Core.Util (collectArgs, mkApps, termType) +import Clash.Normalize.Types (NormalizeState) +import Clash.Normalize.Util (isConstant) +import Clash.Rewrite.Types + (RewriteMonad, bindings, evaluator, tcCache, tupleTcCache, uniqSupply) +import Clash.Rewrite.Util (mkInternalVar, mkSelectorCase, + isUntranslatableType) +import Clash.Util + +data CaseTree a + = Leaf a + | LB [LetBinding] (CaseTree a) + | Branch Term [(Pat,CaseTree a)] + deriving (Eq,Show,Functor,Foldable) + +-- | Test if a 'CaseTree' collected from an expression indicates that +-- application of a global binder is disjoint: occur in separate branches of a +-- case-expression. +isDisjoint :: CaseTree ([Either Term Type]) + -> Bool +isDisjoint (Branch _ [_]) = False +isDisjoint ct = go ct + where + go (Leaf _) = False + go (LB _ ct') = go ct' + go (Branch _ []) = False + go (Branch _ [(_,x)]) = go x + go b@(Branch _ (_:_:_)) = allEqual (map Either.rights (Foldable.toList b)) + +-- Remove empty branches from a 'CaseTree' +removeEmpty :: Eq a => CaseTree [a] -> CaseTree [a] +removeEmpty l@(Leaf _) = l +removeEmpty (LB lb ct) = + case removeEmpty ct of + Leaf [] -> Leaf [] + ct' -> LB lb ct' +removeEmpty (Branch s bs) = + case filter ((/= (Leaf [])) . snd) (map (second removeEmpty) bs) of + [] -> Leaf [] + bs' -> Branch s bs' + +-- | Test if all elements in a list are equal to each other. +allEqual :: Eq a => [a] -> Bool +allEqual [] = True +allEqual (x:xs) = all (== x) xs + +-- | Collect 'CaseTree's for (potentially) disjoint applications of globals out +-- of an expression. Also substitute truly disjoint applications of globals by a +-- reference to a lifted out application. +collectGlobals :: + Set TmOccName + -> [(Term,Term)] -- ^ Substitution of (applications of) a global + -- binder by a reference to a lifted term. + -> [Term] -- ^ List of already seen global binders + -> Term -- ^ The expression + -> RewriteMonad NormalizeState + (Term,[(Term,([Term],CaseTree [(Either Term Type)]))]) +collectGlobals inScope substitution seen (Case scrut ty alts) = do + rec (alts' ,collected) <- collectGlobalsAlts inScope substitution seen scrut' + alts + (scrut',collected') <- collectGlobals inScope substitution + (map fst collected ++ seen) scrut + return (Case scrut' ty alts',collected ++ collected') + +collectGlobals inScope substitution seen e@(collectArgs -> (fun, args@(_:_))) + | not (isConstant e) = do + tcm <- Lens.view tcCache + bndrs <- Lens.use bindings + primEval <- Lens.view evaluator + ids <- Lens.use uniqSupply + let (ids1,ids2) = splitSupply ids + uniqSupply Lens..= ids2 + let eval = whnf' primEval bndrs tcm ids1 False + eTy <- termType tcm e + untran <- isUntranslatableType False eTy + case untran of + -- Don't lift out non-representable values, because they cannot be let-bound + -- in our desired normal form. + False -> case interestingToLift inScope eval fun args of + Just fun' | fun' `notElem` seen -> do + (args',collected) <- collectGlobalsArgs inScope substitution + (fun':seen) args + let e' = Maybe.fromMaybe (mkApps fun' args') (List.lookup fun' substitution) + -- This function is lifted out an environment with the currently 'seen' + -- binders. When we later apply substitution, we need to start with this + -- environment, otherwise we perform incorrect substitutions in the + -- arguments. + return (e',(fun',(seen,Leaf args')):collected) + _ -> do (args',collected) <- collectGlobalsArgs inScope substitution + seen args + return (mkApps fun args',collected) + _ -> return (e,[]) + +-- FIXME: This duplicates A LOT of let-bindings, where I just pray that after +-- the ANF, CSE, and DeadCodeRemoval pass all duplicates are removed. +-- +-- I think we should be able to do better, but perhaps we cannot fix it here. +collectGlobals inScope substitution seen (Letrec b) = do + (unrec -> lbs,body) <- unbind b + (body',collected) <- collectGlobals inScope substitution seen body + (lbs',collected') <- collectGlobalsLbs inScope substitution + (map fst collected ++ seen) + lbs + return (Letrec (bind (Unbound.rec lbs') body') + ,map (second (second (LB lbs'))) (collected ++ collected') + ) + +collectGlobals _ _ _ e = return (e,[]) + +-- | Collect 'CaseTree's for (potentially) disjoint applications of globals out +-- of a list of application arguments. Also substitute truly disjoint +-- applications of globals by a reference to a lifted out application. +collectGlobalsArgs :: + Set TmOccName + -> [(Term,Term)] -- ^ Substitution of (applications of) a global + -- binder by a reference to a lifted term. + -> [Term] -- ^ List of already seen global binders + -> [Either Term Type] -- ^ The list of arguments + -> RewriteMonad NormalizeState + ([Either Term Type] + ,[(Term,([Term],CaseTree [(Either Term Type)]))] + ) +collectGlobalsArgs inScope substitution seen args = do + (_,(args',collected)) <- second unzip <$> mapAccumLM go seen args + return (args',concat collected) + where + go s (Left tm) = do + (tm',collected) <- collectGlobals inScope substitution s tm + return (map fst collected ++ s,(Left tm',collected)) + go s (Right ty) = return (s,(Right ty,[])) + +-- | Collect 'CaseTree's for (potentially) disjoint applications of globals out +-- of a list of alternatives. Also substitute truly disjoint applications of +-- globals by a reference to a lifted out application. +collectGlobalsAlts :: + Set TmOccName + -> [(Term,Term)] -- ^ Substitution of (applications of) a global + -- binder by a reference to a lifted term. + -> [Term] -- ^ List of already seen global binders + -> Term -- ^ The subject term + -> [Bind Pat Term] -- ^ The list of alternatives + -> RewriteMonad NormalizeState + ([Bind Pat Term] + ,[(Term,([Term],CaseTree [(Either Term Type)]))] + ) +collectGlobalsAlts inScope substitution seen scrut alts = do + (alts',collected) <- unzip <$> mapM go alts + let collectedM = map (Map.fromList . map (second (second (:[])))) collected + collectedUN = Map.unionsWith (\(l1,r1) (l2,r2) -> (List.nub (l1 ++ l2),r1 ++ r2)) collectedM + collected' = map (second (second (Branch scrut))) (Map.toList collectedUN) + return (alts',collected') + where + go pe = do (p,e) <- unbind pe + (e',collected) <- collectGlobals inScope substitution seen e + return (bind p e',map (second (second (p,))) collected) + +-- | Collect 'CaseTree's for (potentially) disjoint applications of globals out +-- of a list of let-bindings. Also substitute truly disjoint applications of +-- globals by a reference to a lifted out application. +collectGlobalsLbs :: + Set TmOccName + -> [(Term,Term)] -- ^ Substitution of (applications of) a global + -- binder by a reference to a lifted term. + -> [Term] -- ^ List of already seen global binders + -> [LetBinding] -- ^ The list let-bindings + -> RewriteMonad NormalizeState + ([LetBinding] + ,[(Term,([Term],CaseTree [(Either Term Type)]))] + ) +collectGlobalsLbs inScope substitution seen lbs = do + (_,(lbs',collected)) <- second unzip <$> mapAccumLM go seen lbs + return (lbs',concat collected) + where + go :: [Term] -> LetBinding + -> RewriteMonad NormalizeState + ([Term] + ,(LetBinding + ,[(Term,([Term],CaseTree [(Either Term Type)]))] + ) + ) + go s (id_,unembed -> e) = do + (e',collected) <- collectGlobals inScope substitution s e + return (map fst collected ++ s,((id_,embed e'),collected)) + +-- | Given a case-tree corresponding to a disjoint interesting \"term-in-a- +-- function-position\", return a let-expression: where the let-binding holds +-- a case-expression selecting between the uncommon arguments of the case-tree, +-- and the body is an application of the term applied to the common arguments of +-- the case tree, and projections of let-binding corresponding to the uncommon +-- argument positions. +mkDisjointGroup :: Set TmOccName -- ^ Current free variables. + -> (Term,([Term],CaseTree [(Either Term Type)])) + -- ^ Case-tree of arguments belonging to the applied term. + -> RewriteMonad NormalizeState (Term,[Term]) +mkDisjointGroup fvs (fun,(seen,cs)) = do + let argss = Foldable.toList cs + argssT = zip [0..] (List.transpose argss) + (commonT,uncommonT) = List.partition (isCommon fvs . snd) argssT + common = map (second head) commonT + uncommon = map (Either.lefts) (List.transpose (map snd uncommonT)) + cs' = fmap (zip [0..]) cs + cs'' = removeEmpty + $ fmap (Either.lefts . map snd) + (if null common + then cs' + else fmap (filter (`notElem` common)) cs') + tcm <- Lens.view tcCache + (uncommonCaseM,uncommonProjections) <- case uncommon of + -- only common arguments: do nothing. + [] -> return (Nothing,[]) + -- Create selectors and projections + (uc:_) -> do + argTys <- mapM (termType tcm) uc + disJointSelProj argTys cs'' + let newArgs = mkDJArgs 0 common uncommonProjections + case uncommonCaseM of + Just lb -> return (Letrec (bind (Unbound.rec [lb]) (mkApps fun newArgs)), seen) + Nothing -> return (mkApps fun newArgs, seen) + +-- | Create a single selector for all the representable uncommon arguments by +-- selecting between tuples. This selector is only ('Just') created when the +-- number of representable uncommmon arguments is larger than one, otherwise it +-- is not ('Nothing'). +-- +-- It also returns: +-- +-- * For all the non-representable uncommon arguments: a selector +-- * For all the representable uncommon arguments: a projection out of the tuple +-- created by the larger selector. If this larger selector does not exist, a +-- single selector is created for the single representable uncommon argument. +disJointSelProj :: [Type] -- ^ Types of the arguments + -> CaseTree [Term] -- The case-tree of arguments + -> RewriteMonad NormalizeState (Maybe LetBinding,[Term]) +disJointSelProj _ (Leaf []) = return (Nothing,[]) +disJointSelProj argTys cs = do + let maxIndex = length argTys - 1 + css = map (\i -> fmap ((:[]) . (!!i)) cs) [0..maxIndex] + (untran,tran) <- partitionM (isUntranslatableType False . snd) (zip [0..] argTys) + let untranCs = map (css!!) (map fst untran) + untranSels = zipWith (\(_,ty) cs' -> genCase ty Nothing [] cs') + untran untranCs + (lbM,projs) <- case tran of + [] -> return (Nothing,[]) + [(i,ty)] -> return (Nothing,[genCase ty Nothing [] (css!!i)]) + tys -> do + tcm <- Lens.view tcCache + tupTcm <- Lens.view tupleTcCache + let m = length tys + Just tupTcNm = IM.lookup m tupTcm + Just tupTc = HashMap.lookup (nameOcc tupTcNm) tcm + [tupDc] = tyConDataCons tupTc + (tyIxs,tys') = unzip tys + tupTy = mkTyConApp tupTcNm tys' + cs' = fmap (\es -> map (es !!) tyIxs) cs + djCase = genCase tupTy (Just tupDc) tys' cs' + (scrutId,scrutVar) <- mkInternalVar (string2InternalName "tupIn") tupTy + projections <- mapM (mkSelectorCase ($(curLoc) ++ "disJointSelProj") + tcm scrutVar (dcTag tupDc)) [0..m-1] + return (Just (scrutId,embed djCase),projections) + let selProjs = tranOrUnTran 0 (zip (map fst untran) untranSels) projs + + return (lbM,selProjs) + where + tranOrUnTran _ [] projs = projs + tranOrUnTran _ sels [] = map snd sels + tranOrUnTran n ((ut,s):uts) (p:projs) + | n == ut = s : tranOrUnTran (n+1) uts (p:projs) + | otherwise = p : tranOrUnTran (n+1) ((ut,s):uts) projs + + +isCommon :: Set TmOccName -> [Either Term Type] -> Bool +isCommon _ [] = True +isCommon _ (Right ty:tys) = Set.null (Lens.setOf typeFreeVars ty) && + allEqual (Right ty:tys) +isCommon fvs (Left tm:tms) = Set.null (Lens.setOf termFreeIds tm Set.\\ fvs) && + allEqual (Left tm:tms) + +-- | Create a list of arguments given a map of positions to common arguments, +-- and a list of arguments +mkDJArgs :: Int -- ^ Current position + -> [(Int,Either Term Type)] -- ^ map from position to common argument + -> [Term] -- ^ (projections for) uncommon arguments + -> [Either Term Type] +mkDJArgs _ cms [] = map snd cms +mkDJArgs _ [] uncms = map Left uncms +mkDJArgs n ((m,x):cms) (y:uncms) + | n == m = x : mkDJArgs (n+1) cms (y:uncms) + | otherwise = Left y : mkDJArgs (n+1) ((m,x):cms) uncms + +-- | Create a case-expression that selects between the uncommon arguments given +-- a case-tree +genCase :: Type -- ^ Type of the alternatives + -> Maybe DataCon -- ^ DataCon to pack multiple arguments + -> [Type] -- ^ Types of the arguments + -> CaseTree [Term] -- ^ CaseTree of arguments + -> Term +genCase ty dcM argTys = go + where + go (Leaf tms) = + case dcM of + Just dc -> mkApps (Data dc) (map Right argTys ++ map Left tms) + _ -> head tms + + go (LB lb ct) = + Letrec (bind (Unbound.rec lb) (go ct)) + + go (Branch scrut [(p,ct)]) = + let ct' = go ct + alt = bind p ct' + in case Lens.setOf termFreeIds ct' == Lens.setOf fv alt of + True -> ct' + _ -> Case scrut ty [alt] + + go (Branch scrut pats) = + Case scrut ty (map (\(p,ct) -> bind p (go ct)) pats) + +-- | Determine if a term in a function position is interesting to lift out of +-- of a case-expression. +-- +-- This holds for all global functions, and certain primitives. Currently those +-- primitives are: +-- +-- * All non-power-of-two multiplications +-- * All division-like operations with a non-power-of-two divisor +interestingToLift + :: Set TmOccName + -- ^ in scope + -> (Term -> Term) + -- ^ Evaluator + -> Term + -- ^ Term in function position + -> [Either Term Type] + -- ^ Arguments + -> Maybe Term +interestingToLift inScope _ e@(Var _ nm) _ = + if nameOcc nm `Set.member` inScope + then Just e + else Nothing +interestingToLift inScope eval e@(Prim nm pty) args = + case List.lookup nm interestingPrims of + Just t | t || not (all isConstant lArgs) -> Just e + _ -> if isHOTy pty + then if not . null . Maybe.catMaybes $ + map (uncurry (interestingToLift inScope eval) . + collectArgs + ) lArgs + then Just e + else Nothing + else Nothing + + where + interestingPrims = + [("Clash.Sized.Internal.BitVector.*#",tailNonPow2) + ,("Clash.Sized.Internal.BitVector.times#",tailNonPow2) + ,("Clash.Sized.Internal.BitVector.quot#",lastNotPow2) + ,("Clash.Sized.Internal.BitVector.rem#",lastNotPow2) + ,("Clash.Sized.Internal.Index.*#",tailNonPow2) + ,("Clash.Sized.Internal.Index.quot#",lastNotPow2) + ,("Clash.Sized.Internal.Index.rem#",lastNotPow2) + ,("Clash.Sized.Internal.Signed.*#",tailNonPow2) + ,("Clash.Sized.Internal.Signed.times#",tailNonPow2) + ,("Clash.Sized.Internal.Signed.rem#",lastNotPow2) + ,("Clash.Sized.Internal.Signed.quot#",lastNotPow2) + ,("Clash.Sized.Internal.Signed.div#",lastNotPow2) + ,("Clash.Sized.Internal.Signed.mod#",lastNotPow2) + ,("Clash.Sized.Internal.Unsigned.*#",tailNonPow2) + ,("Clash.Sized.Internal.Unsigned.times#",tailNonPow2) + ,("Clash.Sized.Internal.Unsigned.quot#",lastNotPow2) + ,("Clash.Sized.Internal.Unsigned.rem#",lastNotPow2) + ,("GHC.Base.quotInt",lastNotPow2) + ,("GHC.Base.remInt",lastNotPow2) + ,("GHC.Base.divInt",lastNotPow2) + ,("GHC.Base.modInt",lastNotPow2) + ,("GHC.Classes.divInt#",lastNotPow2) + ,("GHC.Classes.modInt#",lastNotPow2) + ,("GHC.Integer.Type.timesInteger",allNonPow2) + ,("GHC.Integer.Type.divInteger",lastNotPow2) + ,("GHC.Integer.Type.modInteger",lastNotPow2) + ,("GHC.Integer.Type.quotInteger",lastNotPow2) + ,("GHC.Integer.Type.remInteger",lastNotPow2) + ,("GHC.Prim.*#",allNonPow2) + ,("GHC.Prim.quotInt#",lastNotPow2) + ,("GHC.Prim.remInt#",lastNotPow2) + ] + + lArgs = Either.lefts args + + allNonPow2 = all (not . termIsPow2) lArgs + tailNonPow2 = case lArgs of + [] -> True + _ -> all (not . termIsPow2) (tail lArgs) + lastNotPow2 = case lArgs of + [] -> True + _ -> not (termIsPow2 (last lArgs)) + + termIsPow2 e' = case eval e' of + Literal (IntegerLiteral n) -> isPow2 n + a -> case collectArgs a of + (Prim nm' _,[Right _,Left _,Left (Literal (IntegerLiteral n))]) + | isFromInteger nm' -> isPow2 n + _ -> False + + isPow2 x = x /= 0 && (x .&. (complement x + 1)) == x + + isFromInteger x = x `elem` ["Clash.Sized.Internal.BitVector.fromInteger##" + ,"Clash.Sized.Internal.BitVector.fromInteger#" + ,"Clash.Sized.Integer.Index.fromInteger" + ,"Clash.Sized.Internal.Signed.fromInteger#" + ,"Clash.Sized.Internal.Unsigned.fromInteger#" + ] + + isHOTy t = case splitFunForallTy t of + (args',_) -> any isPolyFunTy (Either.rights args') + +interestingToLift _ _ _ _ = Nothing diff --git a/src/Clash/Normalize/PrimitiveReductions.hs b/src/Clash/Normalize/PrimitiveReductions.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Normalize/PrimitiveReductions.hs @@ -0,0 +1,680 @@ +{-| + Copyright : (C) 2015-2016, University of Twente, + 2016 , Myrtle Software Ltd + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Reductions of primitives + + Currently, it contains reductions for: + + * Clash.Sized.Vector.map + * Clash.Sized.Vector.zipWith + * Clash.Sized.Vector.traverse# + * Clash.Sized.Vector.foldr + * Clash.Sized.Vector.fold + * Clash.Sized.Vector.dfold + * Clash.Sized.Vector.(++) + * Clash.Sized.Vector.head + * Clash.Sized.Vector.tail + * Clash.Sized.Vector.unconcatBitVector# + * Clash.Sized.Vector.replicate + * Clash.Sized.Vector.imap + * Clash.Sized.Vector.dtfold + * Clash.Sized.RTree.tfold + + Partially handles: + + * Clash.Sized.Vector.unconcat + * Clash.Sized.Vector.transpose +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +module Clash.Normalize.PrimitiveReductions where + +import qualified Control.Lens as Lens +import qualified Data.HashMap.Lazy as HashMap +import qualified Data.Maybe as Maybe +import Unbound.Generics.LocallyNameless (bind, embed, rec, rebind) + +import Clash.Core.DataCon (DataCon, dataConInstArgTys) +import Clash.Core.Literal (Literal (..)) +import Clash.Core.Name +import Clash.Core.Pretty (showDoc) +import Clash.Core.Term (Term (..), Pat (..)) +import Clash.Core.Type (LitTy (..), Type (..), + TypeView (..), coreView, + mkFunTy, mkTyConApp, + splitFunForallTy, tyView, + undefinedTy) +import Clash.Core.TyCon (TyConName, tyConDataCons) +import Clash.Core.TysPrim (integerPrimTy, typeNatKind) +import Clash.Core.Util (appendToVec, extractElems, + extractTElems, idToVar, + mkApps, mkRTree, mkVec, + termType) +import Clash.Core.Var (Var (..)) + +import Clash.Normalize.Types +import Clash.Rewrite.Types +import Clash.Rewrite.Util +import Clash.Util + +-- | Replace an application of the @Clash.Sized.Vector.zipWith@ primitive on +-- vectors of a known length @n@, by the fully unrolled recursive "definition" +-- of @Clash.Sized.Vector.zipWith@ +reduceZipWith :: Integer -- ^ Length of the vector(s) + -> Type -- ^ Type of the lhs of the function + -> Type -- ^ Type of the rhs of the function + -> Type -- ^ Type of the result of the function + -> Term -- ^ The zipWith'd functions + -> Term -- ^ The 1st vector argument + -> Term -- ^ The 2nd vector argument + -> NormalizeSession Term +reduceZipWith n lhsElTy rhsElTy resElTy fun lhsArg rhsArg = do + tcm <- Lens.view tcCache + ty <- termType tcm lhsArg + go tcm ty + where + go tcm (coreView tcm -> Just ty') = go tcm ty' + go tcm (tyView -> TyConApp vecTcNm _) + | (Just vecTc) <- HashMap.lookup (nameOcc vecTcNm) tcm + , [nilCon,consCon] <- tyConDataCons vecTc + = let (varsL,elemsL) = second concat . unzip + $ extractElems consCon lhsElTy 'L' n lhsArg + (varsR,elemsR) = second concat . unzip + $ extractElems consCon rhsElTy 'R' n rhsArg + funApps = zipWith (\l r -> mkApps fun [Left l,Left r]) varsL varsR + lbody = mkVec nilCon consCon resElTy n funApps + lb = Letrec (bind (rec (init elemsL ++ init elemsR)) lbody) + in changed lb + go _ ty = error $ $(curLoc) ++ "reduceZipWith: argument does not have a vector type: " ++ showDoc ty + +-- | Replace an application of the @Clash.Sized.Vector.map@ primitive on vectors +-- of a known length @n@, by the fully unrolled recursive "definition" of +-- @Clash.Sized.Vector.map@ +reduceMap :: Integer -- ^ Length of the vector + -> Type -- ^ Argument type of the function + -> Type -- ^ Result type of the function + -> Term -- ^ The map'd function + -> Term -- ^ The map'd over vector + -> NormalizeSession Term +reduceMap n argElTy resElTy fun arg = do + tcm <- Lens.view tcCache + ty <- termType tcm arg + go tcm ty + where + go tcm (coreView tcm -> Just ty') = go tcm ty' + go tcm (tyView -> TyConApp vecTcNm _) + | (Just vecTc) <- HashMap.lookup (nameOcc vecTcNm) tcm + , [nilCon,consCon] <- tyConDataCons vecTc + = let (vars,elems) = second concat . unzip + $ extractElems consCon argElTy 'A' n arg + funApps = map (fun `App`) vars + lbody = mkVec nilCon consCon resElTy n funApps + lb = Letrec (bind (rec (init elems)) lbody) + in changed lb + go _ ty = error $ $(curLoc) ++ "reduceMap: argument does not have a vector type: " ++ showDoc ty + +-- | Replace an application of the @Clash.Sized.Vector.imap@ primitive on vectors +-- of a known length @n@, by the fully unrolled recursive "definition" of +-- @Clash.Sized.Vector.imap@ +reduceImap :: Integer -- ^ Length of the vector + -> Type -- ^ Argument type of the function + -> Type -- ^ Result type of the function + -> Term -- ^ The imap'd function + -> Term -- ^ The imap'd over vector + -> NormalizeSession Term +reduceImap n argElTy resElTy fun arg = do + tcm <- Lens.view tcCache + ty <- termType tcm arg + go tcm ty + where + go tcm (coreView tcm -> Just ty') = go tcm ty' + go tcm (tyView -> TyConApp vecTcNm _) + | (Just vecTc) <- HashMap.lookup (nameOcc vecTcNm) tcm + , [nilCon,consCon] <- tyConDataCons vecTc + = do + let (vars,elems) = second concat . unzip + $ extractElems consCon argElTy 'I' n arg + (Right idxTy:_,_) <- splitFunForallTy <$> termType tcm fun + let (TyConApp idxTcNm _) = tyView idxTy + nTv = string2InternalName "n" + -- fromInteger# :: KnownNat n => Integer -> Index n + idxFromIntegerTy = ForAllTy (bind (TyVar nTv (embed typeNatKind)) + (foldr mkFunTy + (mkTyConApp idxTcNm + [VarTy typeNatKind nTv]) + [integerPrimTy,integerPrimTy])) + idxFromInteger = Prim "Clash.Sized.Internal.Index.fromInteger#" + idxFromIntegerTy + idxs = map (App (App (TyApp idxFromInteger (LitTy (NumTy n))) + (Literal (IntegerLiteral (toInteger n)))) + . Literal . IntegerLiteral . toInteger) [0..(n-1)] + + funApps = zipWith (\i v -> App (App fun i) v) idxs vars + lbody = mkVec nilCon consCon resElTy n funApps + lb = Letrec (bind (rec (init elems)) lbody) + changed lb + go _ ty = error $ $(curLoc) ++ "reduceImap: argument does not have a vector type: " ++ showDoc ty + +-- | Replace an application of the @Clash.Sized.Vector.traverse#@ primitive on +-- vectors of a known length @n@, by the fully unrolled recursive "definition" +-- of @Clash.Sized.Vector.traverse#@ +reduceTraverse :: Integer -- ^ Length of the vector + -> Type -- ^ Element type of the argument vector + -> Type -- ^ The type of the applicative + -> Type -- ^ Element type of the result vector + -> Term -- ^ The @Applicative@ dictionary + -> Term -- ^ The function to traverse with + -> Term -- ^ The argument vector + -> NormalizeSession Term +reduceTraverse n aTy fTy bTy dict fun arg = do + tcm <- Lens.view tcCache + (TyConApp apDictTcNm _) <- tyView <$> termType tcm dict + ty <- termType tcm arg + go tcm apDictTcNm ty + where + go tcm apDictTcNm (coreView tcm -> Just ty') = go tcm apDictTcNm ty' + go tcm apDictTcNm (tyView -> TyConApp vecTcNm _) + | (Just vecTc) <- HashMap.lookup (nameOcc vecTcNm) tcm + , [nilCon,consCon] <- tyConDataCons vecTc + = let (Just apDictTc) = HashMap.lookup (nameOcc apDictTcNm) tcm + [apDictCon] = tyConDataCons apDictTc + (Just apDictIdTys) = dataConInstArgTys apDictCon [fTy] + apDictIds = zipWith Id (map string2InternalName + ["functorDict" + ,"pure" + ,"ap" + ,"apConstL" + ,"apConstR"]) + (map embed apDictIdTys) + + (TyConApp funcDictTcNm _) = tyView (head apDictIdTys) + (Just funcDictTc) = HashMap.lookup (nameOcc funcDictTcNm) tcm + [funcDictCon] = tyConDataCons funcDictTc + (Just funcDictIdTys) = dataConInstArgTys funcDictCon [fTy] + funcDicIds = zipWith Id (map string2InternalName ["fmap","fmapConst"]) + (map embed funcDictIdTys) + + apPat = DataPat (embed apDictCon) (rebind [] apDictIds) + fnPat = DataPat (embed funcDictCon) (rebind [] funcDicIds) + + -- Extract the 'pure' function from the Applicative dictionary + pureTy = apDictIdTys!!1 + pureTm = Case dict pureTy [bind apPat (Var pureTy (string2InternalName "pure"))] + + -- Extract the '<*>' function from the Applicative dictionary + apTy = apDictIdTys!!2 + apTm = Case dict apTy [bind apPat (Var apTy (string2InternalName "ap"))] + + -- Extract the Functor dictionary from the Applicative dictionary + funcTy = (head apDictIdTys) + funcTm = Case dict funcTy + [bind apPat (Var funcTy (string2InternalName "functorDict"))] + + -- Extract the 'fmap' function from the Functor dictionary + fmapTy = (head funcDictIdTys) + fmapTm = Case (Var funcTy (string2InternalName "functorDict")) fmapTy + [bind fnPat (Var fmapTy (string2InternalName "fmap"))] + + (vars,elems) = second concat . unzip + $ extractElems consCon aTy 'T' n arg + + funApps = map (fun `App`) vars + + lbody = mkTravVec vecTcNm nilCon consCon (idToVar (apDictIds!!1)) + (idToVar (apDictIds!!2)) + (idToVar (funcDicIds!!0)) + bTy n funApps + + lb = Letrec (bind (rec ([((apDictIds!!0),embed funcTm) + ,((apDictIds!!1),embed pureTm) + ,((apDictIds!!2),embed apTm) + ,((funcDicIds!!0),embed fmapTm) + ] ++ init elems)) lbody) + in changed lb + go _ _ ty = error $ $(curLoc) ++ "reduceTraverse: argument does not have a vector type: " ++ showDoc ty + +-- | Create the traversable vector +-- +-- e.g. for a length '2' input vector, we get +-- +-- > (:>) <$> x0 <*> ((:>) <$> x1 <*> pure Nil) +mkTravVec :: TyConName -- ^ Vec tcon + -> DataCon -- ^ Nil con + -> DataCon -- ^ Cons con + -> Term -- ^ 'pure' term + -> Term -- ^ '<*>' term + -> Term -- ^ 'fmap' term + -> Type -- ^ 'b' ty + -> Integer -- ^ Length of the vector + -> [Term] -- ^ Elements of the vector + -> Term +mkTravVec vecTc nilCon consCon pureTm apTm fmapTm bTy = go + where + go :: Integer -> [Term] -> Term + go _ [] = mkApps pureTm [Right (mkTyConApp vecTc [LitTy (NumTy 0),bTy]) + ,Left (mkApps (Data nilCon) + [Right (LitTy (NumTy 0)) + ,Right bTy + ,Left (Prim "_CO_" nilCoTy)])] + + go n (x:xs) = mkApps apTm + [Right (mkTyConApp vecTc [LitTy (NumTy (n-1)),bTy]) + ,Right (mkTyConApp vecTc [LitTy (NumTy n),bTy]) + ,Left (mkApps fmapTm [Right bTy + ,Right (mkFunTy (mkTyConApp vecTc [LitTy (NumTy (n-1)),bTy]) + (mkTyConApp vecTc [LitTy (NumTy n),bTy])) + ,Left (mkApps (Data consCon) + [Right (LitTy (NumTy n)) + ,Right bTy + ,Right (LitTy (NumTy (n-1))) + ,Left (Prim "_CO_" (consCoTy n)) + ]) + ,Left x]) + ,Left (go (n-1) xs)] + + nilCoTy = head (Maybe.fromJust (dataConInstArgTys nilCon [(LitTy (NumTy 0)) + ,bTy])) + + consCoTy n = head (Maybe.fromJust (dataConInstArgTys consCon + [(LitTy (NumTy n)) + ,bTy + ,(LitTy (NumTy (n-1)))])) + +-- | Replace an application of the @Clash.Sized.Vector.foldr@ primitive on +-- vectors of a known length @n@, by the fully unrolled recursive "definition" +-- of @Clash.Sized.Vector.foldr@ +reduceFoldr :: Integer -- ^ Length of the vector + -> Type -- ^ Element type of the argument vector + -> Term -- ^ The function to fold with + -> Term -- ^ The starting value + -> Term -- ^ The argument vector + -> NormalizeSession Term +reduceFoldr n aTy fun start arg = do + tcm <- Lens.view tcCache + ty <- termType tcm arg + go tcm ty + where + go tcm (coreView tcm -> Just ty') = go tcm ty' + go tcm (tyView -> TyConApp vecTcNm _) + | (Just vecTc) <- HashMap.lookup (nameOcc vecTcNm) tcm + , [_,consCon] <- tyConDataCons vecTc + = let (vars,elems) = second concat . unzip + $ extractElems consCon aTy 'G' n arg + lbody = foldr (\l r -> mkApps fun [Left l,Left r]) start vars + lb = Letrec (bind (rec (init elems)) lbody) + in changed lb + go _ ty = error $ $(curLoc) ++ "reduceFoldr: argument does not have a vector type: " ++ showDoc ty + +-- | Replace an application of the @Clash.Sized.Vector.fold@ primitive on +-- vectors of a known length @n@, by the fully unrolled recursive "definition" +-- of @Clash.Sized.Vector.fold@ +reduceFold :: Integer -- ^ Length of the vector + -> Type -- ^ Element type of the argument vector + -> Term -- ^ The function to fold with + -> Term -- ^ The argument vector + -> NormalizeSession Term +reduceFold n aTy fun arg = do + tcm <- Lens.view tcCache + ty <- termType tcm arg + go tcm ty + where + go tcm (coreView tcm -> Just ty') = go tcm ty' + go tcm (tyView -> TyConApp vecTcNm _) + | (Just vecTc) <- HashMap.lookup (nameOcc vecTcNm) tcm + , [_,consCon] <- tyConDataCons vecTc + = let (vars,elems) = second concat . unzip + $ extractElems consCon aTy 'F' n arg + lbody = foldV vars + lb = Letrec (bind (rec (init elems)) lbody) + in changed lb + go _ ty = error $ $(curLoc) ++ "reduceFold: argument does not have a vector type: " ++ showDoc ty + + foldV [a] = a + foldV as = let (l,r) = splitAt (length as `div` 2) as + lF = foldV l + rF = foldV r + in mkApps fun [Left lF, Left rF] + +-- | Replace an application of the @Clash.Sized.Vector.dfold@ primitive on +-- vectors of a known length @n@, by the fully unrolled recursive "definition" +-- of @Clash.Sized.Vector.dfold@ +reduceDFold :: Integer -- ^ Length of the vector + -> Type -- ^ Element type of the argument vector + -> Term -- ^ Function to fold with + -> Term -- ^ Starting value + -> Term -- ^ The vector to fold + -> NormalizeSession Term +reduceDFold n aTy fun start arg = do + tcm <- Lens.view tcCache + ty <- termType tcm arg + go tcm ty + where + go tcm (coreView tcm -> Just ty') = go tcm ty' + go tcm (tyView -> TyConApp vecTcNm _) + | (Just vecTc) <- HashMap.lookup (nameOcc vecTcNm) tcm + , [_,consCon] <- tyConDataCons vecTc + = do + let (vars,elems) = second concat . unzip + $ extractElems consCon aTy 'D' n arg + (_ltv:Right snTy:_,_) <- splitFunForallTy <$> termType tcm fun + let (TyConApp snatTcNm _) = tyView snTy + (Just snatTc) = HashMap.lookup (nameOcc snatTcNm) tcm + [snatDc] = tyConDataCons snatTc + lbody = doFold (buildSNat snatDc) (n-1) vars + lb = Letrec (bind (rec (init elems)) lbody) + changed lb + go _ ty = error $ $(curLoc) ++ "reduceDFold: argument does not have a vector type: " ++ showDoc ty + + doFold _ _ [] = start + doFold snDc k (x:xs) = mkApps fun + [Right (LitTy (NumTy k)) + ,Left (snDc k) + ,Left x + ,Left (doFold snDc (k-1) xs) + ] + +-- | Replace an application of the @Clash.Sized.Vector.head@ primitive on +-- vectors of a known length @n@, by a projection of the first element of a +-- vector. +reduceHead :: Integer -- ^ Length of the vector + -> Type -- ^ Element type of the vector + -> Term -- ^ The argument vector + -> NormalizeSession Term +reduceHead n aTy vArg = do + tcm <- Lens.view tcCache + ty <- termType tcm vArg + go tcm ty + where + go tcm (coreView tcm -> Just ty') = go tcm ty' + go tcm (tyView -> TyConApp vecTcNm _) + | (Just vecTc) <- HashMap.lookup (nameOcc vecTcNm) tcm + , [_,consCon] <- tyConDataCons vecTc + = let (vars,elems) = second concat . unzip + $ extractElems consCon aTy 'H' n vArg + lb = Letrec (bind (rec [head elems]) (head vars)) + in changed lb + go _ ty = error $ $(curLoc) ++ "reduceHead: argument does not have a vector type: " ++ showDoc ty + +-- | Replace an application of the @Clash.Sized.Vector.tail@ primitive on +-- vectors of a known length @n@, by a projection of the tail of a +-- vector. +reduceTail :: Integer -- ^ Length of the vector + -> Type -- ^ Element type of the vector + -> Term -- ^ The argument vector + -> NormalizeSession Term +reduceTail n aTy vArg = do + tcm <- Lens.view tcCache + ty <- termType tcm vArg + go tcm ty + where + go tcm (coreView tcm -> Just ty') = go tcm ty' + go tcm (tyView -> TyConApp vecTcNm _) + | (Just vecTc) <- HashMap.lookup (nameOcc vecTcNm) tcm + , [_,consCon] <- tyConDataCons vecTc + = let (_,elems) = second concat . unzip + $ extractElems consCon aTy 'L' n vArg + b@(tB,_) = elems !! 1 + lb = Letrec (bind (rec [b]) (idToVar tB)) + in changed lb + go _ ty = error $ $(curLoc) ++ "reduceTail: argument does not have a vector type: " ++ showDoc ty + +-- | Replace an application of the @Clash.Sized.Vector.last@ primitive on +-- vectors of a known length @n@, by a projection of the last element of a +-- vector. +reduceLast :: Integer -- ^ Length of the vector + -> Type -- ^ Element type of the vector + -> Term -- ^ The argument vector + -> NormalizeSession Term +reduceLast n aTy vArg = do + tcm <- Lens.view tcCache + ty <- termType tcm vArg + go tcm ty + where + go tcm (coreView tcm -> Just ty') = go tcm ty' + go tcm (tyView -> TyConApp vecTcNm _) + | (Just vecTc) <- HashMap.lookup (nameOcc vecTcNm) tcm + , [_,consCon] <- tyConDataCons vecTc + = let (_,elems) = unzip + $ extractElems consCon aTy 'L' n vArg + (tB,_) = head (last elems) + in case n of + 0 -> changed (mkApps (Prim "Clash.Transformations.undefined" undefinedTy) [Right aTy]) + _ -> changed (Letrec (bind (rec (init (concat elems))) (idToVar tB))) + go _ ty = error $ $(curLoc) ++ "reduceLast: argument does not have a vector type: " ++ showDoc ty + +-- | Replace an application of the @Clash.Sized.Vector.init@ primitive on +-- vectors of a known length @n@, by a projection of the init of a +-- vector. +reduceInit :: Integer -- ^ Length of the vector + -> Type -- ^ Element type of the vector + -> Term -- ^ The argument vector + -> NormalizeSession Term +reduceInit n aTy vArg = do + tcm <- Lens.view tcCache + ty <- termType tcm vArg + go tcm ty + where + go tcm (coreView tcm -> Just ty') = go tcm ty' + go tcm (tyView -> TyConApp vecTcNm _) + | (Just vecTc) <- HashMap.lookup (nameOcc vecTcNm) tcm + , [nilCon,consCon] <- tyConDataCons vecTc + = let (_,elems) = unzip + $ extractElems consCon aTy 'L' n vArg + in case n of + 0 -> changed (mkApps (Prim "Clash.Transformations.undefined" undefinedTy) [Right aTy]) + 1 -> changed (mkVec nilCon consCon aTy 0 []) + _ -> let el = init elems + iv = mkVec nilCon consCon aTy (n-1) (map (idToVar . fst . head) el) + lb = rec (init (concat el)) + in changed (Letrec (bind lb iv)) + + go _ ty = error $ $(curLoc) ++ "reduceInit: argument does not have a vector type: " ++ showDoc ty + +-- | Replace an application of the @Clash.Sized.Vector.(++)@ primitive on +-- vectors of a known length @n@, by the fully unrolled recursive "definition" +-- of @Clash.Sized.Vector.(++)@ +reduceAppend :: Integer -- ^ Length of the LHS arg + -> Integer -- ^ Lenght of the RHS arg + -> Type -- ^ Element type of the vectors + -> Term -- ^ The LHS argument + -> Term -- ^ The RHS argument + -> NormalizeSession Term +reduceAppend n m aTy lArg rArg = do + tcm <- Lens.view tcCache + ty <- termType tcm lArg + go tcm ty + where + go tcm (coreView tcm -> Just ty') = go tcm ty' + go tcm (tyView -> TyConApp vecTcNm _) + | (Just vecTc) <- HashMap.lookup (nameOcc vecTcNm) tcm + , [_,consCon] <- tyConDataCons vecTc + = let (vars,elems) = second concat . unzip + $ extractElems consCon aTy 'C' n lArg + lbody = appendToVec consCon aTy rArg (n+m) vars + lb = Letrec (bind (rec (init elems)) lbody) + in changed lb + go _ ty = error $ $(curLoc) ++ "reduceAppend: argument does not have a vector type: " ++ showDoc ty + +-- | Replace an application of the @Clash.Sized.Vector.unconcat@ primitive on +-- vectors of a known length @n@, by the fully unrolled recursive "definition" +-- of @Clash.Sized.Vector.unconcat@ +reduceUnconcat :: Integer -- ^ Length of the result vector + -> Integer -- ^ Length of the elements of the result vector + -> Type -- ^ Element type + -> Term -- ^ Argument vector + -> NormalizeSession Term +reduceUnconcat n 0 aTy arg = do + tcm <- Lens.view tcCache + ty <- termType tcm arg + go tcm ty + where + go tcm (coreView tcm -> Just ty') = go tcm ty' + go tcm (tyView -> TyConApp vecTcNm _) + | (Just vecTc) <- HashMap.lookup (nameOcc vecTcNm) tcm + , [nilCon,consCon] <- tyConDataCons vecTc + = let nilVec = mkVec nilCon consCon aTy 0 [] + innerVecTy = mkTyConApp vecTcNm [LitTy (NumTy 0), aTy] + retVec = mkVec nilCon consCon innerVecTy n (replicate (fromInteger n) nilVec) + in changed retVec + go _ ty = error $ $(curLoc) ++ "reduceUnconcat: argument does not have a vector type: " ++ showDoc ty + +reduceUnconcat _ _ _ _ = error $ $(curLoc) ++ "reduceUnconcat: unimplemented" + +-- | Replace an application of the @Clash.Sized.Vector.transpose@ primitive on +-- vectors of a known length @n@, by the fully unrolled recursive "definition" +-- of @Clash.Sized.Vector.transpose@ +reduceTranspose :: Integer -- ^ Length of the result vector + -> Integer -- ^ Length of the elements of the result vector + -> Type -- ^ Element type + -> Term -- ^ Argument vector + -> NormalizeSession Term +reduceTranspose n 0 aTy arg = do + tcm <- Lens.view tcCache + ty <- termType tcm arg + go tcm ty + where + go tcm (coreView tcm -> Just ty') = go tcm ty' + go tcm (tyView -> TyConApp vecTcNm _) + | (Just vecTc) <- HashMap.lookup (nameOcc vecTcNm) tcm + , [nilCon,consCon] <- tyConDataCons vecTc + = let nilVec = mkVec nilCon consCon aTy 0 [] + innerVecTy = mkTyConApp vecTcNm [LitTy (NumTy 0), aTy] + retVec = mkVec nilCon consCon innerVecTy n (replicate (fromInteger n) nilVec) + in changed retVec + go _ ty = error $ $(curLoc) ++ "reduceTranspose: argument does not have a vector type: " ++ showDoc ty + +reduceTranspose _ _ _ _ = error $ $(curLoc) ++ "reduceTranspose: unimplemented" + +reduceReplicate :: Integer + -> Type + -> Type + -> Term + -> NormalizeSession Term +reduceReplicate n aTy eTy arg = do + tcm <- Lens.view tcCache + go tcm eTy + where + go tcm (coreView tcm -> Just ty') = go tcm ty' + go tcm (tyView -> TyConApp vecTcNm _) + | (Just vecTc) <- HashMap.lookup (nameOcc vecTcNm) tcm + , [nilCon,consCon] <- tyConDataCons vecTc + = let retVec = mkVec nilCon consCon aTy n (replicate (fromInteger n) arg) + in changed retVec + go _ ty = error $ $(curLoc) ++ "reduceReplicate: argument does not have a vector type: " ++ showDoc ty + +-- | Replace an application of the @Clash.Sized.Vector.dtfold@ primitive on +-- vectors of a known length @n@, by the fully unrolled recursive "definition" +-- of @Clash.Sized.Vector.dtfold@ +reduceDTFold :: Integer -- ^ Length of the vector + -> Type -- ^ Element type of the argument vector + -> Term -- ^ Function to convert elements with + -> Term -- ^ Function to combine branches with + -> Term -- ^ The vector to fold + -> NormalizeSession Term +reduceDTFold n aTy lrFun brFun arg = do + tcm <- Lens.view tcCache + ty <- termType tcm arg + go tcm ty + where + go tcm (coreView tcm -> Just ty') = go tcm ty' + go tcm (tyView -> TyConApp vecTcNm _) + | (Just vecTc) <- HashMap.lookup (nameOcc vecTcNm) tcm + , [_,consCon] <- tyConDataCons vecTc + = do let (vars,elems) = second concat . unzip + $ extractElems consCon aTy 'T' (2^n) arg + (_ltv:Right snTy:_,_) <- splitFunForallTy <$> termType tcm brFun + let (TyConApp snatTcNm _) = tyView snTy + (Just snatTc) = HashMap.lookup (nameOcc snatTcNm) tcm + [snatDc] = tyConDataCons snatTc + lbody = doFold (buildSNat snatDc) (n-1) vars + lb = Letrec (bind (rec (init elems)) lbody) + changed lb + go _ ty = error $ $(curLoc) ++ "reduceDTFold: argument does not have a vector type: " ++ showDoc ty + + doFold :: (Integer -> Term) -> Integer -> [Term] -> Term + doFold _ _ [x] = mkApps lrFun [Left x] + doFold snDc k xs = + let (xsL,xsR) = splitAt (2^k) xs + k' = k-1 + eL = doFold snDc k' xsL + eR = doFold snDc k' xsR + in mkApps brFun [Right (LitTy (NumTy k)) + ,Left (snDc k) + ,Left eL + ,Left eR + ] + +-- | Replace an application of the @Clash.Sized.RTree.tdfold@ primitive on +-- trees of a known depth @n@, by the fully unrolled recursive "definition" +-- of @Clash.Sized.RTree.tdfold@ +reduceTFold :: Integer -- ^ Depth of the tree + -> Type -- ^ Element type of the argument tree + -> Term -- ^ Function to convert elements with + -> Term -- ^ Function to combine branches with + -> Term -- ^ The tree to fold + -> NormalizeSession Term +reduceTFold n aTy lrFun brFun arg = do + tcm <- Lens.view tcCache + ty <- termType tcm arg + go tcm ty + where + go tcm (coreView tcm -> Just ty') = go tcm ty' + go tcm (tyView -> TyConApp treeTcNm _) + | (Just treeTc) <- HashMap.lookup (nameOcc treeTcNm) tcm + , [lrCon,brCon] <- tyConDataCons treeTc + = do let (vars,elems) = extractTElems lrCon brCon aTy 'T' n arg + (_ltv:Right snTy:_,_) <- splitFunForallTy <$> termType tcm brFun + let (TyConApp snatTcNm _) = tyView snTy + (Just snatTc) = HashMap.lookup (nameOcc snatTcNm) tcm + [snatDc] = tyConDataCons snatTc + lbody = doFold (buildSNat snatDc) (n-1) vars + lb = Letrec (bind (rec elems) lbody) + changed lb + go _ ty = error $ $(curLoc) ++ "reduceTFold: argument does not have a tree type: " ++ showDoc ty + + doFold _ _ [x] = mkApps lrFun [Left x] + doFold snDc k xs = + let (xsL,xsR) = splitAt (length xs `div` 2) xs + k' = k-1 + eL = doFold snDc k' xsL + eR = doFold snDc k' xsR + in mkApps brFun [Right (LitTy (NumTy k)) + ,Left (snDc k) + ,Left eL + ,Left eR + ] + +reduceTReplicate :: Integer -- ^ Depth of the tree + -> Type -- ^ Element type + -> Type -- ^ Result type + -> Term -- ^ Element + -> NormalizeSession Term +reduceTReplicate n aTy eTy arg = do + tcm <- Lens.view tcCache + go tcm eTy + where + go tcm (coreView tcm -> Just ty') = go tcm ty' + go tcm (tyView -> TyConApp treeTcNm _) + | (Just treeTc) <- HashMap.lookup (nameOcc treeTcNm) tcm + , [lrCon,brCon] <- tyConDataCons treeTc + = let retVec = mkRTree lrCon brCon aTy n (replicate (2^n) arg) + in changed retVec + go _ ty = error $ $(curLoc) ++ "reduceTReplicate: argument does not have a vector type: " ++ showDoc ty + +buildSNat :: DataCon -> Integer -> Term +buildSNat snatDc i = + mkApps (Data snatDc) + [Right (LitTy (NumTy i)) +#if MIN_VERSION_ghc(8,2,0) + ,Left (Literal (NaturalLiteral (toInteger i))) +#else + ,Left (Literal (IntegerLiteral (toInteger i))) +#endif + ] diff --git a/src/Clash/Normalize/Strategy.hs b/src/Clash/Normalize/Strategy.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Normalize/Strategy.hs @@ -0,0 +1,231 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Transformation process for normalization +-} + +module Clash.Normalize.Strategy where + +import Clash.Normalize.Transformations +import Clash.Normalize.Types +import Clash.Rewrite.Combinators +import Clash.Rewrite.Types +import Clash.Rewrite.Util + +-- | Normalisation transformation +normalization :: NormRewrite +normalization = rmDeadcode >-> constantPropgation >-> etaTL >-> rmUnusedExpr >-!-> anf >-!-> rmDeadcode >-> + bindConst >-> letTL >-> evalConst >-!-> cse >-!-> cleanup >-> recLetRec + where + etaTL = apply "etaTL" etaExpansionTL !-> innerMost (apply "applicationPropagation" appProp) + anf = topdownR (apply "nonRepANF" nonRepANF) >-> apply "ANF" makeANF + letTL = topdownSucR (apply "topLet" topLet) + recLetRec = apply "recToLetRec" recToLetRec + rmUnusedExpr = bottomupR (apply "removeUnusedExpr" removeUnusedExpr) + rmDeadcode = bottomupR (apply "deadcode" deadCode) + bindConst = topdownR (apply "bindConstantVar" bindConstantVar) + evalConst = topdownR (apply "evalConst" reduceConst) + cse = topdownR (apply "CSE" simpleCSE) + cleanup = topdownSucR (apply "inlineCleanup" inlineCleanup) !-> + innerMost (applyMany [("caseCon" , caseCon) + ,("bindConstantVar", bindConstantVar) + ,("letFlat" , flattenLet)]) + >-> rmDeadcode >-> letTL + + +constantPropgation :: NormRewrite +constantPropgation = propagate >-> repeatR inlineAndPropagate >-> + caseFlattening >-> dec >-> spec >-> dec >-> + conSpec + where + propagate = innerMost (applyMany transPropagate) + inlineAndPropagate = (topdownR (applyMany transInlineSafe) >-> inlineNR) + !-> propagate + spec = bottomupR (applyMany specTransformations) + caseFlattening = repeatR (topdownR (apply "caseFlat" caseFlat)) + dec = repeatR (topdownR (apply "DEC" disjointExpressionConsolidation)) + conSpec = bottomupR (apply "constantSpec" constantSpec) + + transPropagate :: [(String,NormRewrite)] + transPropagate = + [ ("applicationPropagation", appProp ) + , ("bindConstantVar" , bindConstantVar) + , ("caseLet" , caseLet ) + , ("caseCase" , caseCase ) + , ("caseCon" , caseCon ) + ] + + -- These transformations can safely be applied in a top-down traversal as + -- they themselves check whether the to-be-inlined binder is recursive or not. + transInlineSafe :: [(String,NormRewrite)] + transInlineSafe = + [ ("inlineWorkFree" , inlineWorkFree) + , ("inlineSmall" , inlineSmall) + , ("bindOrLiftNonRep", inlineOrLiftNonRep) -- See: [Note] bindNonRep before liftNonRep + -- See: [Note] bottom-up traversal for liftNonRep + , ("reduceNonRepPrim", reduceNonRepPrim) + + + , ("caseCast" , caseCast) + , ("letCast" , letCast) + , ("splitCastWork" , splitCastWork) + , ("argCastSpec" , argCastSpec) + , ("inlineCast" , inlineCast) + , ("eliminateCastCast",eliminateCastCast) + ] + + -- InlineNonRep cannot be applied in a top-down traversal, as the non-representable + -- binder might be recursive. The idea is, is that if the recursive + -- non-representable binder is inlined once, we can get rid of the recursive + -- aspect using the case-of-known-constructor + inlineNR :: NormRewrite + inlineNR = bottomupR (apply "inlineNonRep" inlineNonRep) + + specTransformations :: [(String,NormRewrite)] + specTransformations = + [ ("typeSpec" , typeSpec) + , ("nonRepSpec" , nonRepSpec) + ] + +{- [Note] bottom-up traversal for liftNonRep +We used to say: + +"The liftNonRep transformation must be applied in a topDown traversal because +of what Clash considers tail calls in its join-point analysis." + +Consider: + +> let fail = \x -> ... +> in case ... of +> A -> let fail1 = \y -> case ... of +> X -> fail ... +> Y -> ... +> in case ... of +> P -> fail1 ... +> Q -> ... +> B -> fail ... + +under "normal" tail call rules, the local 'fail' functions is not a join-point +because it is used in a let-binding. However, we apply "special" tail call rules +in Clash. Because 'fail' is used in a TC position within 'fail1', and 'fail1' is +only used in a TC position, in Clash, we consider 'tail' also only to be used +in a TC position. + +Now image we apply 'liftNonRep' in a bottom up traversal, we will end up with: + +> fail1 = \fail y -> case ... of +> X -> fail ... +> Y -> ... + +> let fail = \x -> ... +> in case ... of +> A -> case ... of +> P -> fail1 fail ... +> Q -> ... +> B -> fail ... + +Suddenly, 'fail' ends up in an argument position, because it occurred as a +_locally_ bound variable within 'fail1'. And because of that 'fail' stops being +a join-point. + +However, when we apply 'liftNonRep' in a top down traversal we end up with: + +> fail = \x -> ... +> +> fail1 = \y -> case ... of +> X -> fail ... +> Y -> ... +> +> let ... +> in case ... of +> A -> let +> in case ... of +> P -> fail1 ... +> Q -> ... +> B -> fail ... + +and all is well with the world. + +UPDATE: +We can now just perform liftNonRep in a bottom-up traversal again, because +liftNonRep no longer checks that if the binding that is lifted is a join-point. +However, for this to work, bindNonRep must always have been exhaustively applied +before liftNonRep. See also: [Note] bindNonRep before liftNonRep. +-} + +{- [Note] bindNonRep before liftNonRep +The combination of liftNonRep and nonRepSpec can lead to non-termination in an +unchecked rewrite system (without termination measures in place) on the +following: + +> main = f not +> f = \a x -> (a x) && (f a x) + +nonRepSpec will lead to: + +> main = f' +> f = \a x -> (a x) && (f a x) +> f' = (\a x -> (a x) && (f a x)) not + +then lamApp leads to: + +> main = f' +> f = \a x -> (a x) && (f a x) +> f' = let a = not in (\x -> (a x) && (f a x)) + +then liftNonRep leads to: + +> main = f' +> f = \a x -> (a x) && (f a x) +> f' = \x -> (g x) && (f g x) +> g = not + +and nonRepSepc leads to: + +> main = f' +> f = \a x -> (a x) && (f a x) +> f' = \x -> (g x) && (f'' g x) +> g = not +> f'' = (\a x -> (a x) && (f a x)) g + +This cycle continues indefinitely, as liftNonRep creates a new global variable, +which is never alpha-equivalent to the previous global variable introduced by +liftNonRep. + +That is why bindNonRep must always be applied before liftNonRep. When we end up +in the situation after lamApp: + +> main = f' +> f = \a x -> (a x) && (f a x) +> f' = let a = not in (\x -> (a x) && (f a x)) + +bindNonRep will now lead to: + +> main = f' +> f = \a x -> (a x) && (f a x) +> f' = \x -> (not x) && (f not x) + +Because `f` has already been specialised on the alpha-equivalent-to-itself `not` +function, liftNonRep leads to: + +> main = f' +> f = \a x -> (a x) && (f a x) +> f' = \x -> (not x) && (f' x) + +And there is no non-terminating rewriting cycle. + +That is why bindNonRep must always be exhaustively applied before we apply +liftNonRep. +-} + +-- | Topdown traversal, stops upon first success +topdownSucR :: Rewrite extra -> Rewrite extra +topdownSucR r = r >-! (allR True (topdownSucR r)) + +innerMost :: Rewrite extra -> Rewrite extra +innerMost r = bottomupR (r !-> innerMost r) + +applyMany :: [(String,Rewrite extra)] -> Rewrite extra +applyMany = foldr1 (>->) . map (uncurry apply) diff --git a/src/Clash/Normalize/Transformations.hs b/src/Clash/Normalize/Transformations.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Normalize/Transformations.hs @@ -0,0 +1,1703 @@ +{-| + Copyright : (C) 2012-2016, University of Twente, + 2016-2017, Myrtle Software Ltd, + 2017 , Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Transformations of the Normalization process +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +module Clash.Normalize.Transformations + ( appProp + , caseLet + , caseCon + , caseCase + , inlineNonRep + , inlineOrLiftNonRep + , typeSpec + , nonRepSpec + , etaExpansionTL + , nonRepANF + , bindConstantVar + , constantSpec + , makeANF + , deadCode + , topLet + , recToLetRec + , inlineWorkFree + , inlineHO + , inlineSmall + , simpleCSE + , reduceConst + , reduceNonRepPrim + , caseFlat + , disjointExpressionConsolidation + , removeUnusedExpr + , inlineCleanup + , flattenLet + , splitCastWork + , inlineCast + , caseCast + , letCast + , eliminateCastCast + , argCastSpec + ) +where + +import Control.Concurrent.Supply (splitSupply) +import Control.Exception (throw) +import qualified Control.Lens as Lens +import qualified Control.Monad as Monad +import Control.Monad.Writer + (WriterT (..), censor, lift, listen, tell) +import Control.Monad.Trans.Except (runExcept) +import Data.Bits ((.&.), complement) +import qualified Data.Either as Either +import qualified Data.HashMap.Lazy as HashMap +import qualified Data.HashSet as HashSet +import qualified Data.List as List +import qualified Data.Maybe as Maybe +import qualified Data.Monoid as Monoid +import qualified Data.Set as Set +import qualified Data.Set.Lens as Lens +import Data.Text (Text, unpack) +import Debug.Trace (trace) +import Unbound.Generics.LocallyNameless + (Bind, Embed (..), bind, embed, rec, runFreshM, unbind, unembed, unrebind, unrec) +import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) + +import BasicTypes (InlineSpec (..)) + +import Clash.Core.DataCon (DataCon (..)) +import Clash.Core.Evaluator (whnf') +import Clash.Core.Name + (Name (..), NameSort (..), name2String, string2InternalName, string2SystemName) +import Clash.Core.FreeVars (termFreeIds, termFreeTyVars, + typeFreeVars) +import Clash.Core.Literal (Literal (..)) +import Clash.Core.Pretty (showDoc) +import Clash.Core.Subst + (substBndr, substTm, substTms, substTyInTm, substTysinTm) +import Clash.Core.Term (LetBinding, Pat (..), Term (..), TmOccName) +import Clash.Core.Type (TypeView (..), applyFunTy, + applyTy, isPolyFunCoreTy, + normalizeType, + splitFunTy, typeKind, + tyView, undefinedTy) +import Clash.Core.TyCon (tyConDataCons) +import Clash.Core.Util + (collectArgs, idToVar, isClockOrReset, isCon, isFun, isLet, isPolyFun, isPrim, + isSignalType, isVar, mkApps, mkLams, mkVec, termSize, termType, + tyNatSize) +import Clash.Core.Var (Id, Var (..)) +import Clash.Driver.Types (DebugLevel (..), ClashException (..)) +import Clash.Netlist.BlackBox.Util (usedArguments) +import Clash.Netlist.Types (HWType (..)) +import Clash.Netlist.Util + (coreTypeToHWType, representableType, splitNormalized) +import Clash.Normalize.DEC +import Clash.Normalize.PrimitiveReductions +import Clash.Normalize.Types +import Clash.Normalize.Util +import Clash.Primitives.Types (Primitive (..), PrimMap) +import Clash.Rewrite.Combinators +import Clash.Rewrite.Types +import Clash.Rewrite.Util +import Clash.Util + +inlineOrLiftNonRep :: NormRewrite +inlineOrLiftNonRep = inlineOrLiftBinders nonRepTest inlineTest + where + nonRepTest :: (Var Term, Embed Term) -> RewriteMonad extra Bool + nonRepTest ((Id _ tyE), _) + = not <$> (representableType <$> Lens.view typeTranslator + <*> Lens.view allowZero + <*> pure False + <*> Lens.view tcCache + <*> pure (unembed tyE)) + nonRepTest _ = return False + + inlineTest :: Term -> (Var Term, Embed Term) -> RewriteMonad extra Bool + inlineTest e (id_@(Id (nameOcc -> idName) _), exprE) + = let e' = unembed exprE + in not . or <$> sequence -- We do __NOT__ inline: + [ -- 1. recursive let-binders + elem idName <$> (Lens.toListOf <$> localFreeIds <*> pure e') + -- 2. join points (which are not void-wrappers) + , pure (isJoinPointIn id_ e && not (isVoidWrapper e')) + -- 3. binders that are used more than once in the body, because + -- it makes CSE a whole lot more difficult. + , (>1) <$> freeOccurances + ] + where + -- The number of free occurrences of the binder in the entire + -- let-expression + freeOccurances :: RewriteMonad extra Int + freeOccurances = case e of + Letrec b -> do + -- It is safe to use unsafeUnbind because the expression @e@ is + -- the original let-expression, unbound and bound again, so no + -- bound variables have changed. + let (_,res) = unsafeUnbind b + fvOcc <-Lens.toListOf <$> localFreeIds <*> pure res + return (length $ filter (== idName) fvOcc) + _ -> return 0 + + inlineTest _ _ = return True + +{- [Note] join points and void wrappers +Join points are functions that only occur in tail-call positions within an +expression, and only when they occur in a tail-call position more than once. + +Normally bindNonRep binds/inlines all non-recursive local functions. However, +doing so for join points would significantly increase compilation time, so we +avoid it. The only exception to this rule are so-called void wrappers. Void +wrappers are functions of the form: + +> \(w :: Void) -> f a b c + +i.e. a wrapper around the function 'f' where the argument 'w' is not used. We +do bind/line these join-points because these void-wrappers interfere with the +'disjoint expression consolidation' (DEC) and 'common sub-expression elimination' +(CSE) transformation, sometimes resulting in circuits that are twice as big +as they'd need to be. +-} + +-- | Specialize functions on their type +typeSpec :: NormRewrite +typeSpec ctx e@(TyApp e1 ty) + | (Var _ _, args) <- collectArgs e1 + , null $ Lens.toListOf typeFreeVars ty + , (_, []) <- Either.partitionEithers args + = specializeNorm ctx e + +typeSpec _ e = return e + +-- | Specialize functions on their non-representable argument +nonRepSpec :: NormRewrite +nonRepSpec ctx e@(App e1 e2) + | (Var _ _, args) <- collectArgs e1 + , (_, []) <- Either.partitionEithers args + , null $ Lens.toListOf termFreeTyVars e2 + = do tcm <- Lens.view tcCache + e2Ty <- termType tcm e2 + localVar <- isLocalVar e2 + nonRepE2 <- not <$> (representableType <$> Lens.view typeTranslator + <*> Lens.view allowZero + <*> pure False + <*> Lens.view tcCache + <*> pure e2Ty) + if nonRepE2 && not localVar + then do + e2' <- inlineInternalSpecialisationArgument e2 + specializeNorm ctx (App e1 e2') + else return e + where + -- | If the argument on which we're specialising ia an internal function, + -- one created by the compiler, then inline that function before we + -- specialise. + -- + -- We need to do this because otherwise the specialisation history won't + -- recognize the new specialisation argument as something the function has + -- already been specialised on + inlineInternalSpecialisationArgument + :: Term + -> NormalizeSession Term + inlineInternalSpecialisationArgument app + | (Var _ f,fArgs) <- collectArgs app + = do + fTmM <- fmap (HashMap.lookup (nameOcc f)) $ Lens.use bindings + case fTmM of + Just (fNm,_,_,_,tm) + | nameSort fNm == Internal + -> do + tm' <- censor (const mempty) (bottomupR appProp ctx (mkApps tm fArgs)) + return tm' + _ -> return app + | otherwise = return app + +nonRepSpec _ e = return e + +-- | Lift the let-bindings out of the subject of a Case-decomposition +caseLet :: NormRewrite +caseLet _ (Case (Letrec b) ty alts) = do + (xes,e) <- unbind b + changed (Letrec (bind xes (Case e ty alts))) + +caseLet _ e = return e + +-- | Move a Case-decomposition from the subject of a Case-decomposition to the alternatives +caseCase :: NormRewrite +caseCase _ e@(Case (Case scrut alts1Ty alts1) alts2Ty alts2) + = do + ty1Rep <- representableType <$> Lens.view typeTranslator + <*> Lens.view allowZero + <*> pure False + <*> Lens.view tcCache + <*> pure alts1Ty + if not ty1Rep + then do newAlts <- mapM ( return + . uncurry bind + . second (\altE -> Case altE alts2Ty alts2) + <=< unbind + ) alts1 + changed $ Case scrut alts2Ty newAlts + else return e + +caseCase _ e = return e + +-- | Inline function with a non-representable result if it's the subject +-- of a Case-decomposition +inlineNonRep :: NormRewrite +inlineNonRep _ e@(Case scrut altsTy alts) + | (Var _ (nameOcc -> f), args) <- collectArgs scrut + = do + (nameOcc -> cf,_) <- Lens.use curFun + isInlined <- zoomExtra (alreadyInlined f cf) + limit <- Lens.use (extra.inlineLimit) + tcm <- Lens.view tcCache + scrutTy <- termType tcm scrut + let noException = not (exception tcm scrutTy) + if noException && (Maybe.fromMaybe 0 isInlined) > limit + then do + ty <- termType tcm scrut + traceIf True (concat [$(curLoc) ++ "InlineNonRep: " ++ show f + ," already inlined " ++ show limit ++ " times in:" + , show cf + , "\nType of the subject is: " ++ showDoc ty + , "\nFunction " ++ show cf + , " will not reach a normal form, and compilation" + , " might fail." + , "\nRun with '-fclash-inline-limit=N' to increase" + , " the inlining limit to N." + ]) + (return e) + else do + bodyMaybe <- fmap (HashMap.lookup f) $ Lens.use bindings + nonRepScrut <- not <$> (representableType <$> Lens.view typeTranslator + <*> Lens.view allowZero + <*> pure False + <*> Lens.view tcCache + <*> pure scrutTy) + case (nonRepScrut, bodyMaybe) of + (True,Just (_,_,_,_,scrutBody)) -> do + Monad.when noException (zoomExtra (addNewInline f cf)) + changed $ Case (mkApps scrutBody args) altsTy alts + _ -> return e + where + exception tcm ((tyView . typeKind tcm) -> TyConApp (name2String -> "GHC.Types.Constraint") _) = True + exception _ _ = False + +inlineNonRep _ e = return e + +-- | Specialize a Case-decomposition (replace by the RHS of an alternative) if +-- the subject is (an application of) a DataCon; or if there is only a single +-- alternative that doesn't reference variables bound by the pattern. +caseCon :: NormRewrite +caseCon _ (Case scrut ty alts) + | (Data dc, args) <- collectArgs scrut + = do + alts' <- mapM unbind alts + let dcAltM = List.find (equalCon dc . fst) alts' + case dcAltM of + Just (DataPat _ pxs, e) -> + let (tvs,xs) = unrebind pxs + fvs = Lens.toListOf termFreeIds e + (binds,_) = List.partition ((`elem` fvs) . nameOcc . varName . fst) + $ zip xs (Either.lefts args) + e' = case binds of + [] -> e + _ -> Letrec $ bind (rec $ map (second embed) binds) e + substTyMap = zip (map (nameOcc.varName) tvs) (drop (length $ dcUnivTyVars dc) (Either.rights args)) + in changed (substTysinTm substTyMap e') + _ -> case alts' of + ((DefaultPat,e):_) -> changed e + _ -> changed (mkApps (Prim "Clash.Transformations.undefined" undefinedTy) [Right ty]) + where + equalCon dc (DataPat dc' _) = dcTag dc == dcTag (unembed dc') + equalCon _ _ = False + +caseCon _ c@(Case (Literal l) _ alts) = do + alts' <- mapM unbind alts + let ltAltsM = List.find (equalLit . fst) alts' + case ltAltsM of + Just (LitPat _,e) -> changed e + _ -> matchLiteralContructor c l alts' + where + equalLit (LitPat l') = l == (unembed l') + equalLit _ = False + +caseCon ctx e@(Case subj ty alts) + | (Prim _ _,_) <- collectArgs subj = do + tcm <- Lens.view tcCache + bndrs <- Lens.use bindings + primEval <- Lens.view evaluator + ids <- Lens.use uniqSupply + let (ids1,ids2) = splitSupply ids + uniqSupply Lens..= ids2 + lvl <- Lens.view dbgLevel + case whnf' primEval bndrs tcm ids1 True subj of + Literal l -> caseCon ctx (Case (Literal l) ty alts) + subj' -> case collectArgs subj' of + (Data _,_) -> caseCon ctx (Case subj' ty alts) +#if MIN_VERSION_ghc(8,2,2) + (Prim nm ty',_:msgOrCallStack:_) + | nm == "Control.Exception.Base.absentError" -> + let e' = mkApps (Prim nm ty') [Right ty,msgOrCallStack] + in changed e' +#endif + + (Prim nm ty',repTy:_:msgOrCallStack:_) + | nm `elem` ["Control.Exception.Base.patError" +#if !MIN_VERSION_ghc(8,2,2) + ,"Control.Exception.Base.absentError" +#endif + ,"GHC.Err.undefined"] -> + let e' = mkApps (Prim nm ty') [repTy,Right ty,msgOrCallStack] + in changed e' + (Prim nm ty',[_]) + | nm `elem` ["Clash.Transformations.undefined"] -> + let e' = mkApps (Prim nm ty') [Right ty] + in changed e' + (Prim nm _,[]) + | nm `elem` ["EmptyCase"] -> + changed (Prim nm ty) + _ -> do + subjTy <- termType tcm subj + tran <- Lens.view typeTranslator + case coreTypeToHWType tran tcm False subjTy of + Right (Void (Just hty)) + | hty `elem` [BitVector 0, Unsigned 0, Signed 0, Index 1] + -> caseCon ctx (Case (Literal (IntegerLiteral 0)) ty alts) + _ -> traceIf (lvl > DebugNone && isConstant e) + ("Irreducible constant as case subject: " ++ showDoc subj ++ "\nCan be reduced to: " ++ showDoc subj') + (caseOneAlt e) + +caseCon ctx e@(Case subj ty alts) = do + tcm <- Lens.view tcCache + subjTy <- termType tcm subj + tran <- Lens.view typeTranslator + case coreTypeToHWType tran tcm False subjTy of + Right (Void (Just hty)) + | hty `elem` [BitVector 0, Unsigned 0, Signed 0, Index 1] + -> caseCon ctx (Case (Literal (IntegerLiteral 0)) ty alts) + _ -> caseOneAlt e + +caseCon _ e = return e + +matchLiteralContructor + :: Term + -> Literal + -> [(Pat,Term)] + -> NormalizeSession Term +matchLiteralContructor c (IntegerLiteral l) alts = do + let dcAltM = List.find (smallInt . fst) alts + case dcAltM of + Just (DataPat _ pxs, e) -> + let ([],xs) = unrebind pxs + fvs = Lens.toListOf termFreeIds e + (binds,_) = List.partition ((`elem` fvs) . nameOcc . varName . fst) + $ zip xs [Literal (IntLiteral l)] + e' = case binds of + [] -> e + _ -> Letrec $ bind (rec $ map (second embed) binds) e + in changed e' + _ -> matchLiteralDefault c alts + where + smallInt (DataPat dc _) + | dcTag (unembed dc) == 1 + , l < 2^(63 :: Int) + = True + smallInt _ = False +matchLiteralContructor c (NaturalLiteral l) alts = do + let dcAltM = List.find (smallNat . fst) alts + case dcAltM of + Just (DataPat _ pxs, e) -> + let ([],xs) = unrebind pxs + fvs = Lens.toListOf termFreeIds e + (binds,_) = List.partition ((`elem` fvs) . nameOcc . varName . fst) + $ zip xs [Literal (WordLiteral (toInteger l))] + e' = case binds of + [] -> e + _ -> Letrec $ bind (rec $ map (second embed) binds) e + in changed e' + _ -> matchLiteralDefault c alts + where + smallNat (DataPat dc _) + | dcTag (unembed dc) == 1 + , l < 2^(63 :: Int) + = True + smallNat _ = False +matchLiteralContructor c _ alts = matchLiteralDefault c alts + +matchLiteralDefault :: Term -> [(Pat,Term)] -> NormalizeSession Term +matchLiteralDefault _ ((DefaultPat,e):_) = changed e +matchLiteralDefault c _ = + error $ $(curLoc) ++ "Report as bug: caseCon error: " ++ showDoc c + +caseOneAlt :: Term -> RewriteMonad extra Term +caseOneAlt e@(Case _ _ [alt]) = do + (pat,altE) <- unbind alt + case pat of + DefaultPat -> changed altE + LitPat _ -> changed altE + DataPat _ pxs -> let (tvs,xs) = unrebind pxs + ftvs = Lens.toListOf termFreeTyVars altE + fvs = Lens.toListOf termFreeIds altE + usedTvs = filter ((`elem` ftvs) . nameOcc . varName) tvs + usedXs = filter ((`elem` fvs) . nameOcc . varName) xs + in case (usedTvs,usedXs) of + ([],[]) -> changed altE + _ -> return e + +caseOneAlt e = return e + +-- | Bring an application of a DataCon or Primitive in ANF, when the argument is +-- is considered non-representable +nonRepANF :: NormRewrite +nonRepANF ctx e@(App appConPrim arg) + | (conPrim, _) <- collectArgs e + , isCon conPrim || isPrim conPrim + = do + untranslatable <- isUntranslatable False arg + case (untranslatable,arg) of + (True,Letrec b) -> do (binds,body) <- unbind b + changed (Letrec (bind binds (App appConPrim body))) + (True,Case {}) -> specializeNorm ctx e + (True,Lam _) -> specializeNorm ctx e + (True,TyLam _) -> specializeNorm ctx e + _ -> return e + +nonRepANF _ e = return e + +-- | Ensure that top-level lambda's eventually bind a let-expression of which +-- the body is a variable-reference. +topLet :: NormRewrite +topLet ctx e + | all isLambdaBodyCtx ctx && not (isLet e) + = do + untranslatable <- isUntranslatable False e + if untranslatable + then return e + else do tcm <- Lens.view tcCache + (argId,argVar) <- mkTmBinderFor tcm (string2SystemName "result") e + changed . Letrec $ bind (rec [(argId,embed e)]) argVar + +topLet ctx e@(Letrec b) + | all isLambdaBodyCtx ctx + = do + (binds,body) <- unbind b + localVar <- isLocalVar body + untranslatable <- isUntranslatable False body + if localVar || untranslatable + then return e + else do tcm <- Lens.view tcCache + (argId,argVar) <- mkTmBinderFor tcm (string2SystemName "result") body + changed . Letrec $ bind (rec $ unrec binds ++ [(argId,embed body)]) argVar + +topLet _ e = return e + +-- Misc rewrites + +-- | Remove unused let-bindings +deadCode :: NormRewrite +deadCode _ e@(Letrec binds) = do + (xes, body) <- fmap (first unrec) $ unbind binds + let bodyFVs = Lens.toListOf termFreeIds body + (xesUsed,xesOther) = List.partition + ( (`elem` bodyFVs ) + . nameOcc + . varName + . fst + ) xes + xesUsed' = findUsedBndrs [] xesUsed xesOther + if length xesUsed' /= length xes + then case xesUsed' of + [] -> changed body + _ -> changed . Letrec $ bind (rec xesUsed') body + else return e + where + findUsedBndrs :: [(Var Term, Embed Term)] -> [(Var Term, Embed Term)] + -> [(Var Term, Embed Term)] -> [(Var Term, Embed Term)] + findUsedBndrs used [] _ = used + findUsedBndrs used explore other = + let fvsUsed = concatMap (Lens.toListOf termFreeIds . unembed . snd) explore + (explore',other') = List.partition + ( (`elem` fvsUsed) + . nameOcc + . varName + . fst + ) other + in findUsedBndrs (used ++ explore) explore' other' + +deadCode _ e = return e + +removeUnusedExpr :: NormRewrite +removeUnusedExpr _ e@(collectArgs -> (p@(Prim nm _),args)) = do + bbM <- HashMap.lookup nm <$> Lens.use (extra.primitives) + case bbM of + Just (BlackBox pNm _ _ _ inc templ) -> do + let usedArgs = if isFromInt pNm + then [0,1] + else either usedArguments usedArguments templ ++ + maybe [] (usedArguments . snd) inc + tcm <- Lens.view tcCache + args' <- go tcm 0 usedArgs args + if args == args' + then return e + else changed (mkApps p args') + _ -> return e + where + go _ _ _ [] = return [] + go tcm n used (Right ty:args') = do + args'' <- go tcm n used args' + return (Right ty : args'') + go tcm n used (Left tm : args') = do + args'' <- go tcm (n+1) used args' + ty <- termType tcm tm + let p' = mkApps (Prim "Clash.Transformations.removedArg" undefinedTy) [Right ty] + if n `elem` used + then return (Left tm : args'') + else return (Left p' : args'') + +removeUnusedExpr _ e@(Case _ _ [alt]) = do + (pat,altExpr) <- unbind alt + case pat of + DataPat _ (unrebind -> ([],xs)) -> do + let altFreeIds = Lens.setOf termFreeIds altExpr + if Set.null (Set.intersection (Set.fromList (map (nameOcc.varName) xs)) altFreeIds) + then changed altExpr + else return e + _ -> return e + +-- Replace any expression that creates a Vector of size 0 within the application +-- of the Cons constructor, by the Nil constructor. +removeUnusedExpr _ e@(collectArgs -> (Data dc, [_,Right aTy,Right nTy,_,Left a,Left nil])) + | name2String (dcName dc) == "Clash.Sized.Vector.Cons" + = do + tcm <- Lens.view tcCache + case runExcept (tyNatSize tcm nTy) of + Right 0 + | (con, _) <- collectArgs nil + , not (isCon con) + -> do eTy <- termType tcm e + let (TyConApp vecTcNm _) = tyView eTy + (Just vecTc) = HashMap.lookup (nameOcc vecTcNm) tcm + [nilCon,consCon] = tyConDataCons vecTc + v = mkVec nilCon consCon aTy 1 [a] + changed v + _ -> return e + +removeUnusedExpr _ e = return e + +-- | Inline let-bindings when the RHS is either a local variable reference or +-- is constant (except clock or reset generators) +bindConstantVar :: NormRewrite +bindConstantVar = inlineBinders test + where + test _ (_,Embed e) = isLocalVar e >>= \case + True -> return True + _ -> isConstantNotClockReset e >>= \case + True -> Lens.use (extra.inlineConstantLimit) >>= \case + 0 -> return True + n -> return (termSize e <= n) + _ -> return False + -- test _ _ = return False + +-- | Push a cast over a case into it's alternatives. +caseCast :: NormRewrite +caseCast _ (Cast (Case subj ty alts) ty1 ty2) = do + alts' <- mapM castAlt alts + changed $ Case subj ty alts' + where + castAlt alt = do + (pat,altExpr) <- unbind alt + return $ bind pat (Cast altExpr ty1 ty2) +caseCast _ e = return e + +-- | Push a cast over a Letrec into it's body +letCast :: NormRewrite +letCast _ (Cast (Letrec b) ty1 ty2) = do + let (binds,body) = unsafeUnbind b + changed $ Letrec $ bind binds (Cast body ty1 ty2) +letCast _ e = return e + + +-- | Push cast over an argument to a funtion into that function +-- +-- This is done by specializing on the casted argument. +-- Example: +-- @ +-- y = f (cast a) +-- where f x = g x +-- @ +-- transforms to: +-- @ +-- y = f' a +-- where f' x' = (\x -> g x) (cast x') +-- @ +argCastSpec :: NormRewrite +argCastSpec ctx e@(App _ (Cast e' _ _)) = case e' of + Var _ _ -> go + Cast (Var _ _) _ _ -> go + _ -> warn go + where + go = specializeNorm ctx e + warn = trace (unlines ["WARNING: " ++ $(curLoc) ++ "specializing a function on a possibly non work-free cast." + ,"Generated HDL implementation might contain duplicate work." + ,"Please report this as a bug." + ,"" + ,"Expression where this occurs:" + ,showDoc e + ]) +argCastSpec _ e = return e + +-- | Only inline casts that just contain a 'Var', because these are guaranteed work-free. +-- These are the result of the 'splitCastWork' transformation. +inlineCast :: NormRewrite +inlineCast = inlineBinders test + where + test _ (_, Embed (Cast (Var _ _) _ _)) = return True + test _ _ = return False + +-- | Eliminate two back to back casts where the type going in and coming out are the same +-- +-- @ +-- (cast :: b -> a) $ (cast :: a -> b) x ==> x +-- @ +eliminateCastCast :: NormRewrite +eliminateCastCast _ c@(Cast (Cast e tyA tyB) tyB' tyC) = do + tcm <- Lens.view tcCache + let ntyA = normalizeType tcm tyA + ntyB = normalizeType tcm tyB + ntyB' = normalizeType tcm tyB' + ntyC = normalizeType tcm tyC + if ntyB == ntyB' && ntyA == ntyC then changed e + else throwError + where throwError = do + (nm,sp) <- Lens.use curFun + throw (ClashException sp ($(curLoc) ++ showDoc nm + ++ ": Found 2 nested casts whose types don't line up:\n" + ++ showDoc c) + Nothing) + +eliminateCastCast _ e = return e + +-- | Make a cast work-free by splitting the work of to a separate binding +-- +-- @ +-- let x = cast (f a b) +-- ==> +-- let x = cast x' +-- x' = f a b +-- @ +splitCastWork :: NormRewrite +splitCastWork ctx unchanged@(Letrec b) = do + (v,e') <- unbind b + let vs = unrec v + (vss', Monoid.getAny -> hasChanged) <- listen (mapM splitCastLetBinding vs) + let vs' = concat vss' + if hasChanged then changed . Letrec $ bind (rec vs') (e') + else return unchanged + where + splitCastLetBinding :: LetBinding -> RewriteMonad extra [LetBinding] + splitCastLetBinding x@(nm, Embed e) = case e of + Cast (Var _ _) _ _ -> return [x] -- already work-free + Cast (Cast _ _ _) _ _ -> return [x] -- casts will be eliminated + Cast e' ty1 ty2 -> do + tcm <- Lens.view tcCache + (nm',var) <- mkTmBinderFor tcm (mkDerivedName ctx (name2String $ varName nm)) e' + changed [(nm',Embed e') + ,(nm, Embed $ Cast var ty1 ty2) + ] + _ -> return [x] + +splitCastWork _ e = return e + + +-- | Inline work-free functions, i.e. fully applied functions that evaluate to +-- a constant +inlineWorkFree :: NormRewrite +inlineWorkFree _ e@(collectArgs -> (Var _ (nameOcc -> f),args)) + = do + tcm <- Lens.view tcCache + eTy <- termType tcm e + argsHaveWork <- or <$> mapM (either expressionHasWork + (const (pure False))) + args + untranslatable <- isUntranslatableType True eTy + let isSignal = isSignalType tcm eTy + if untranslatable || isSignal || argsHaveWork + then return e + else do + bndrs <- Lens.use bindings + case HashMap.lookup f bndrs of + -- Don't inline recursive expressions + Just (_,_,_,_,body) -> do + isRecBndr <- isRecursiveBndr f + if isRecBndr + then return e + else changed (mkApps body args) + _ -> return e + where + -- an expression is has work when it contains free local variables, + -- or has a Signal type, i.e. it does not evaluate to a work-free + -- constant. + expressionHasWork e' = do + fvIds <- Lens.toListOf <$> localFreeIds <*> pure e' + tcm <- Lens.view tcCache + e'Ty <- termType tcm e' + let isSignal = isSignalType tcm e'Ty + return (not (null fvIds) || isSignal) + +inlineWorkFree _ e@(Var fTy (nameOcc -> f)) = do + tcm <- Lens.view tcCache + let closed = not (isPolyFunCoreTy tcm fTy) + isSignal = isSignalType tcm fTy + untranslatable <- isUntranslatableType True fTy + if closed && not untranslatable && not isSignal + then do + bndrs <- Lens.use bindings + case HashMap.lookup f bndrs of + -- Don't inline recursive expressions + Just (_,_,_,_,body) -> do + isRecBndr <- isRecursiveBndr f + if isRecBndr + then return e + else changed body + _ -> return e + else return e + +inlineWorkFree _ e = return e + +-- | Inline small functions +inlineSmall :: NormRewrite +inlineSmall _ e@(collectArgs -> (Var _ (nameOcc -> f),args)) = do + untranslatable <- isUntranslatable True e + topEnts <- Lens.view topEntities + if untranslatable || f `HashSet.member` topEnts + then return e + else do + bndrs <- Lens.use bindings + sizeLimit <- Lens.use (extra.inlineFunctionLimit) + case HashMap.lookup f bndrs of + -- Don't inline recursive expressions + Just (_,_,_,inl,body) -> do + isRecBndr <- isRecursiveBndr f + if not isRecBndr && inl /= NoInline && termSize body < sizeLimit + then changed (mkApps body args) + else return e + _ -> return e + +inlineSmall _ e = return e + +-- | Specialise functions on arguments which are constant, except when they +-- are clock or reset generators +constantSpec :: NormRewrite +constantSpec ctx e@(App e1 e2) + | (Var _ _, args) <- collectArgs e1 + , (_, []) <- Either.partitionEithers args + , null $ Lens.toListOf termFreeTyVars e2 + , isConstant e2 + = do tcm <- Lens.view tcCache + e2Ty <- termType tcm e2 + -- Don't specialise on clock or reset generators + case isClockOrReset tcm e2Ty of + False -> specializeNorm ctx e + _ -> return e + +constantSpec _ e = return e + + +-- Experimental + +-- | Propagate arguments of application inwards; except for 'Lam' where the +-- argument becomes let-bound. +appProp :: NormRewrite +appProp _ (App (Lam b) arg) = do + (v,e) <- unbind b + if isConstant arg || isVar arg + then changed $ substTm (nameOcc (varName v)) arg e + else changed . Letrec $ bind (rec [(v,embed arg)]) e + +appProp _ (App (Letrec b) arg) = do + (v,e) <- unbind b + changed . Letrec $ bind v (App e arg) + +appProp ctx (App (Case scrut ty alts) arg) = do + tcm <- Lens.view tcCache + argTy <- termType tcm arg + let ty' = applyFunTy tcm ty argTy + if isConstant arg || isVar arg + then do + alts' <- mapM ( return + . uncurry bind + . second (`App` arg) + <=< unbind + ) alts + changed $ Case scrut ty' alts' + else do + (boundArg,argVar) <- mkTmBinderFor tcm (mkDerivedName ctx "app_arg") arg + alts' <- mapM ( return + . uncurry bind + . second (`App` argVar) + <=< unbind + ) alts + changed . Letrec $ bind (rec [(boundArg,embed arg)]) (Case scrut ty' alts') + +appProp _ (TyApp (TyLam b) t) = do + (tv,e) <- unbind b + changed $ substTyInTm (nameOcc (varName tv)) t e + +appProp _ (TyApp (Letrec b) t) = do + (v,e) <- unbind b + changed . Letrec $ bind v (TyApp e t) + +appProp _ (TyApp (Case scrut altsTy alts) ty) = do + alts' <- mapM ( return + . uncurry bind + . second (`TyApp` ty) + <=< unbind + ) alts + tcm <- Lens.view tcCache + ty' <- applyTy tcm altsTy ty + changed $ Case scrut ty' alts' + +appProp _ e = return e + +-- | Flatten ridiculous case-statements generated by GHC +-- +-- For case-statements in haskell of the form: +-- +-- @ +-- f :: Unsigned 4 -> Unsigned 4 +-- f x = case x of +-- 0 -> 3 +-- 1 -> 2 +-- 2 -> 1 +-- 3 -> 0 +-- @ +-- +-- GHC generates Core that looks like: +-- +-- @ +-- f = \(x :: Unsigned 4) -> case x == fromInteger 3 of +-- False -> case x == fromInteger 2 of +-- False -> case x == fromInteger 1 of +-- False -> case x == fromInteger 0 of +-- False -> error "incomplete case" +-- True -> fromInteger 3 +-- True -> fromInteger 2 +-- True -> fromInteger 1 +-- True -> fromInteger 0 +-- @ +-- +-- Which would result in a priority decoder circuit where a normal decoder +-- circuit was desired. +-- +-- This transformation transforms the above Core to the saner: +-- +-- @ +-- f = \(x :: Unsigned 4) -> case x of +-- _ -> error "incomplete case" +-- 0 -> fromInteger 3 +-- 1 -> fromInteger 2 +-- 2 -> fromInteger 1 +-- 3 -> fromInteger 0 +-- @ +caseFlat :: NormRewrite +caseFlat _ e@(Case (collectArgs -> (Prim nm _,args)) ty _) + | isEq nm + = do let (Left scrut') = args !! 1 + case collectFlat scrut' e of + Just alts' -> changed (Case scrut' ty (last alts' : init alts')) + Nothing -> return e + +caseFlat _ e = return e + +collectFlat :: Term -> Term -> Maybe [Bind Pat Term] +collectFlat scrut (Case (collectArgs -> (Prim nm _,args)) _ty [lAlt,rAlt]) + | isEq nm + , scrut' == scrut + = case collectArgs val of + (Prim nm' _,args') | isFromInt nm' + -> case last args' of + Left (Literal i) -> case (unsafeUnbind lAlt,unsafeUnbind rAlt) of + ((pl,el),(pr,er)) + | isFalseDcPat pl || isTrueDcPat pr -> + case collectFlat scrut el of + Just alts' -> Just (bind (LitPat (embed i)) er : alts') + Nothing -> Just [bind (LitPat (embed i)) er + ,bind DefaultPat el + ] + | otherwise -> + case collectFlat scrut er of + Just alts' -> Just (bind (LitPat (embed i)) el : alts') + Nothing -> Just [bind (LitPat (embed i)) el + ,bind DefaultPat er + ] + _ -> Nothing + _ -> Nothing + where + (Left scrut') = args !! 1 + (Left val) = args !! 2 + + isFalseDcPat (DataPat p _) + = ((== "GHC.Types.False") . name2String . dcName . unembed) p + isFalseDcPat _ = False + + isTrueDcPat (DataPat p _) + = ((== "GHC.Types.True") . name2String . dcName . unembed) p + isTrueDcPat _ = False + +collectFlat _ _ = Nothing + +isEq :: Text -> Bool +isEq nm = nm == "Clash.Sized.Internal.BitVector.eq#" || + nm == "Clash.Sized.Internal.Index.eq#" || + nm == "Clash.Sized.Internal.Signed.eq#" || + nm == "Clash.Sized.Internal.Unsigned.eq#" + +isFromInt :: Text -> Bool +isFromInt nm = nm == "Clash.Sized.Internal.BitVector.fromInteger##" || + nm == "Clash.Sized.Internal.BitVector.fromInteger#" || + nm == "Clash.Sized.Internal.Index.fromInteger#" || + nm == "Clash.Sized.Internal.Signed.fromInteger#" || + nm == "Clash.Sized.Internal.Unsigned.fromInteger#" + +type NormRewriteW = Transform (WriterT [LetBinding] (RewriteMonad NormalizeState)) + +-- NOTE [unsafeUnbind]: Use unsafeUnbind (which doesn't freshen pattern +-- variables). Reason: previously collected expression still reference +-- the 'old' variable names created by the traversal! + +-- | Turn an expression into a modified ANF-form. As opposed to standard ANF, +-- constants do not become let-bound. +makeANF :: NormRewrite +makeANF ctx (Lam b) = do + -- See NOTE [unsafeUnbind] + let (bndr,e) = unsafeUnbind b + e' <- makeANF (LamBody bndr:ctx) e + return $ Lam (bind bndr e') + +makeANF _ (TyLam b) = return (TyLam b) + +makeANF ctx e + = do + (e',bndrs) <- runWriterT $ bottomupR collectANF ctx e + case bndrs of + [] -> return e + _ -> changed . Letrec $ bind (rec bndrs) e' + +collectANF :: NormRewriteW +collectANF ctx e@(App appf arg) + | (conVarPrim, _) <- collectArgs e + , isCon conVarPrim || isPrim conVarPrim || isVar conVarPrim + = do + untranslatable <- lift (isUntranslatable False arg) + localVar <- lift (isLocalVar arg) + constantNoCR <- lift (isConstantNotClockReset arg) + case (untranslatable,localVar || constantNoCR,arg) of + (False,False,_) -> do tcm <- Lens.view tcCache + (argId,argVar) <- lift (mkTmBinderFor tcm (mkDerivedName ctx "app_arg") arg) + tell [(argId,embed arg)] + return (App appf argVar) + (True,False,Letrec b) -> do (binds,body) <- unbind b + tell (unrec binds) + return (App appf body) + _ -> return e + +collectANF _ (Letrec b) = do + -- See NOTE [unsafeUnbind] + let (binds,body) = unsafeUnbind b + tell (unrec binds) + untranslatable <- lift (isUntranslatable False body) + localVar <- lift (isLocalVar body) + if localVar || untranslatable + then return body + else do + tcm <- Lens.view tcCache + (argId,argVar) <- lift (mkTmBinderFor tcm (string2SystemName "result") body) + tell [(argId,embed body)] + return argVar + +-- TODO: The code below special-cases ANF for the ':-' constructor for the +-- 'Signal' type. The 'Signal' type is essentially treated as a "transparent" +-- type by the Clash compiler, so observing its constructor leads to all kinds +-- of problems. In this case that "Clash.Rewrite.Util.mkSelectorCase" will +-- try to project the LHS and RHS of the ':-' constructor, however, +-- 'mkSelectorCase' uses 'coreView' to find the "real" data-constructor. +-- 'coreView' however looks through the 'Signal' type, and hence 'mkSelector' +-- finds the data constructors for the element type of Signal. This resulted in +-- error #24 (https://github.com/christiaanb/clash2/issues/24), where we +-- try to get the first field out of the 'Vec's 'Nil' constructor. +-- +-- Ultimately we should stop treating Signal as a "transparent" type and deal +-- handling of the Signal type, and the involved co-recursive functions, +-- properly. At the moment, Clash cannot deal with this recursive type and the +-- recursive functions involved, hence the need for special-casing code. After +-- everything is done properly, we should remove the two lines below. +collectANF _ e@(Case _ _ [unsafeUnbind -> (DataPat dc _,_)]) + | name2String (dcName $ unembed dc) == "Clash.Signal.Internal.:-" = return e + +collectANF ctx (Case subj ty alts) = do + localVar <- lift (isLocalVar subj) + (bndr,subj') <- if localVar || isConstant subj + then return ([],subj) + else do tcm <- Lens.view tcCache + (argId,argVar) <- lift (mkTmBinderFor tcm (mkDerivedName ctx "case_scrut") subj) + return ([(argId,embed subj)],argVar) + + (binds,alts') <- fmap (first concat . unzip) $ mapM (lift . doAlt subj') alts + + tell (bndr ++ binds) + case alts' of + [unsafeUnbind -> (DataPat _ (unrebind -> ([],xs)),altExpr)] + | let altFreeIds = Lens.setOf termFreeIds altExpr + , Set.null (Set.intersection (Set.fromList (map (nameOcc.varName) xs)) altFreeIds) + -> return altExpr + _ -> return (Case subj' ty alts') + where + doAlt :: Term -> Bind Pat Term -> RewriteMonad NormalizeState ([LetBinding],Bind Pat Term) + -- See NOTE [unsafeUnbind] + doAlt subj' = fmap (second (uncurry bind)) . doAlt' subj' . unsafeUnbind + + doAlt' :: Term -> (Pat,Term) -> RewriteMonad NormalizeState ([LetBinding],(Pat,Term)) + doAlt' subj' alt@(DataPat dc pxs@(unrebind -> ([],xs)),altExpr) = do + lv <- isLocalVar altExpr + patSels <- Monad.zipWithM (doPatBndr subj' (unembed dc)) xs [0..] + let usesXs (Var _ n) = any ((== n) . varName) xs + usesXs _ = False + if (lv && not (usesXs altExpr)) || isConstant altExpr + then return (patSels,alt) + else do tcm <- Lens.view tcCache + (altId,altVar) <- mkTmBinderFor tcm (mkDerivedName ctx "case_alt") altExpr + return ((altId,embed altExpr):patSels,(DataPat dc pxs,altVar)) + doAlt' _ alt@(DataPat _ _, _) = return ([],alt) + doAlt' _ alt@(pat,altExpr) = do + lv <- isLocalVar altExpr + if lv || isConstant altExpr + then return ([],alt) + else do tcm <- Lens.view tcCache + (altId,altVar) <- mkTmBinderFor tcm (mkDerivedName ctx "case_alt") altExpr + return ([(altId,embed altExpr)],(pat,altVar)) + + doPatBndr :: Term -> DataCon -> Id -> Int -> RewriteMonad NormalizeState LetBinding + doPatBndr subj' dc pId i + = do tcm <- Lens.view tcCache + patExpr <- mkSelectorCase ($(curLoc) ++ "doPatBndr") tcm subj' (dcTag dc) i + return (pId,embed patExpr) + +collectANF _ e = return e + +-- | Eta-expand top-level lambda's (DON'T use in a traversal!) +etaExpansionTL :: NormRewrite +etaExpansionTL ctx (Lam b) = do + (bndr,e) <- unbind b + e' <- etaExpansionTL (LamBody bndr:ctx) e + return $ Lam (bind bndr e') + +etaExpansionTL ctx (Letrec b) = do + (xesR,e) <- unbind b + let xes = unrec xesR + bndrs = map fst xes + e' <- etaExpansionTL (LetBody bndrs:ctx) e + e'' <- stripLambda e' + case e'' of + (bs@(_:_),e2) -> do + let e3 = Letrec (bind xesR e2) + changed (mkLams e3 bs) + _ -> return (Letrec (bind xesR e')) + where + stripLambda :: Term -> RewriteMonad NormalizeState ([Id],Term) + stripLambda (Lam b') = do + (bndr,e) <- unbind b' + (bndrs,e') <- stripLambda e + return (bndr:bndrs,e') + stripLambda e = return ([],e) + +etaExpansionTL ctx e + = do + tcm <- Lens.view tcCache + isF <- isFun tcm e + if isF + then do + argTy <- ( return + . fst + . Maybe.fromMaybe (error $ $(curLoc) ++ "etaExpansion splitFunTy") + . splitFunTy tcm + <=< termType tcm + ) e + (newIdB,newIdV) <- mkInternalVar (string2InternalName "arg") argTy + e' <- etaExpansionTL (LamBody newIdB:ctx) (App e newIdV) + changed . Lam $ bind newIdB e' + else return e + +-- | Turn a normalized recursive function, where the recursive calls only pass +-- along the unchanged original arguments, into let-recursive function. This +-- means that all recursive calls are replaced by the same variable reference as +-- found in the body of the top-level let-expression. +recToLetRec :: NormRewrite +recToLetRec [] e = do + (fn,_) <- Lens.use curFun + bodyM <- fmap (HashMap.lookup (nameOcc fn)) $ Lens.use bindings + tcm <- Lens.view tcCache + normalizedE <- splitNormalized tcm e + case (normalizedE,bodyM) of + (Right (args,bndrs,res), Just (_,bodyTy,_,_,_)) -> do + let v = Var bodyTy fn + args' = map idToVar args + (toInline,others) = List.partition (eqApp tcm v args' . unembed . snd) bndrs + resV = idToVar res + case (toInline,others) of + (_:_,_:_) -> do + let substsInline = map (\(id_,_) -> (nameOcc (varName id_),resV)) toInline + others' = map (second (embed . substTms substsInline . unembed)) others + changed $ mkLams (Letrec $ bind (rec others') resV) args + _ -> return e + _ -> return e + where + -- This checks whether things are semantically equal + -- + -- i.e. that + -- + -- xs == (fst xs, snd xs) + -- + -- TODO: this is far from complete + eqApp tcm v args (collectArgs -> (v',args')) + | v == v' + , let args2 = Either.lefts args' + , length args == length args2 + = and (zipWith (eqArg tcm) args args2) + | otherwise + = False + + eqArg _ v1 v2@(Var _ _) + = v1 == v2 + eqArg tcm v1 v2@(collectArgs -> (Data _,args')) + | runFreshM (termType tcm v1) == runFreshM (termType tcm v2) + = and (zipWith (isNthProjection v1) [0..] (Either.lefts args')) + eqArg _ _ _ + = False + + -- `isNthProjection s n c` checks that `c` is the `n`th projection + -- of `s`. + isNthProjection :: Term -> Int -> Term -> Bool + isNthProjection v n (Case v' altTy [alt]) + | v == v' + , (DataPat _ pxs,Var _ s) <- unsafeUnbind alt + , let (_,xs) = unrebind pxs + , Just n' <- List.elemIndex (Id s (embed altTy)) xs + = n == n' + isNthProjection _ _ _ = False + +recToLetRec _ e = return e + +-- | Inline a function with functional arguments +inlineHO :: NormRewrite +inlineHO _ e@(App _ _) + | (Var _ (nameOcc -> f), args) <- collectArgs e + = do + tcm <- Lens.view tcCache + hasPolyFunArgs <- or <$> mapM (either (isPolyFun tcm) (const (return False))) args + if hasPolyFunArgs + then do (nameOcc -> cf,_) <- Lens.use curFun + isInlined <- zoomExtra (alreadyInlined f cf) + limit <- Lens.use (extra.inlineLimit) + if (Maybe.fromMaybe 0 isInlined) > limit + then do + lvl <- Lens.view dbgLevel + traceIf (lvl > DebugNone) ($(curLoc) ++ "InlineHO: " ++ show f ++ " already inlined " ++ show limit ++ " times in:" ++ show cf) (return e) + else do + bodyMaybe <- fmap (HashMap.lookup f) $ Lens.use bindings + case bodyMaybe of + Just (_,_,_,_,body) -> do + zoomExtra (addNewInline f cf) + changed (mkApps body args) + _ -> return e + else return e + +inlineHO _ e = return e + +-- | Simplified CSE, only works on let-bindings, works from top to bottom +simpleCSE :: NormRewrite +simpleCSE _ e@(Letrec b) = do + (binders,body) <- first unrec <$> unbind b + let (reducedBindings,body') = reduceBindersFix binders body + if length binders /= length reducedBindings + then changed (Letrec (bind (rec reducedBindings) body')) + else return e + +simpleCSE _ e = return e + +reduceBindersFix :: [LetBinding] + -> Term + -> ([LetBinding],Term) +reduceBindersFix binders body = if length binders /= length reduced + then reduceBindersFix reduced body' + else (binders,body) + where + (reduced,body') = reduceBinders [] body binders + +reduceBinders :: [LetBinding] + -> Term + -> [LetBinding] + -> ([LetBinding],Term) +reduceBinders processed body [] = (processed,body) +reduceBinders processed body ((id_,expr):binders) = case List.find ((== expr) . snd) processed of + Just (id2,_) -> + let var = Var (unembed (varType id2)) (varName id2) + idName = nameOcc (varName id_) + processed' = map (second (Embed . (substTm idName var) . unembed)) processed + binders' = map (second (Embed . (substTm idName var) . unembed)) binders + body' = substTm idName var body + in reduceBinders processed' body' binders' + Nothing -> reduceBinders ((id_,expr):processed) body binders + +reduceConst :: NormRewrite +reduceConst _ e@(App _ _) + | isConstant e + , (conPrim, _) <- collectArgs e + , isPrim conPrim + = do + tcm <- Lens.view tcCache + bndrs <- Lens.use bindings + primEval <- Lens.view evaluator + ids <- Lens.use uniqSupply + let (ids1,ids2) = splitSupply ids + uniqSupply Lens..= ids2 + case whnf' primEval bndrs tcm ids1 False e of + e'@(Literal _) -> changed e' + e'@(collectArgs -> (Prim nm _, _)) + | isFromInt nm + , e /= e' + -> changed e' + e'@(collectArgs -> (Data _,_)) -> changed e' + _ -> return e + +reduceConst _ e = return e + +-- | Replace primitives by their "definition" if they would lead to let-bindings +-- with a non-representable type when a function is in ANF. This happens for +-- example when Clash.Size.Vector.map consumes or produces a vector of +-- non-representable elements. +-- +-- Basically what this transformation does is replace a primitive the completely +-- unrolled recursive definition that it represents. e.g. +-- +-- > zipWith ($) (xs :: Vec 2 (Int -> Int)) (ys :: Vec 2 Int) +-- +-- is replaced by: +-- +-- > let (x0 :: (Int -> Int)) = case xs of (:>) _ x xr -> x +-- > (xr0 :: Vec 1 (Int -> Int)) = case xs of (:>) _ x xr -> xr +-- > (x1 :: (Int -> Int)( = case xr0 of (:>) _ x xr -> x +-- > (y0 :: Int) = case ys of (:>) _ y yr -> y +-- > (yr0 :: Vec 1 Int) = case ys of (:>) _ y yr -> xr +-- > (y1 :: Int = case yr0 of (:>) _ y yr -> y +-- > in (($) x0 y0 :> ($) x1 y1 :> Nil) +-- +-- Currently, it only handles the following functions: +-- +-- * Clash.Sized.Vector.map +-- * Clash.Sized.Vector.zipWith +-- * Clash.Sized.Vector.traverse# +-- * Clash.Sized.Vector.foldr +-- * Clash.Sized.Vector.fold +-- * Clash.Sized.Vector.dfold +-- * Clash.Sized.Vector.(++) +-- * Clash.Sized.Vector.head +-- * Clash.Sized.Vector.tail +-- * Clash.Sized.Vector.unconcat +-- * Clash.Sized.Vector.transpose +-- * Clash.Sized.Vector.replicate +-- * Clash.Sized.Vector.dtfold +reduceNonRepPrim :: NormRewrite +reduceNonRepPrim _ e@(App _ _) | (Prim f _, args) <- collectArgs e = do + tcm <- Lens.view tcCache + eTy <- termType tcm e + case tyView eTy of + (TyConApp vecTcNm@(name2String -> "Clash.Sized.Vector.Vec") + [runExcept . tyNatSize tcm -> Right 0, aTy]) -> do + let (Just vecTc) = HashMap.lookup (nameOcc vecTcNm) tcm + [nilCon,consCon] = tyConDataCons vecTc + nilE = mkVec nilCon consCon aTy 0 [] + changed nilE + tv -> case f of + "Clash.Sized.Vector.zipWith" | length args == 7 -> do + let [lhsElTy,rhsElty,resElTy,nTy] = Either.rights args + case runExcept (tyNatSize tcm nTy) of + Right n -> do + untranslatableTys <- mapM isUntranslatableType_not_poly [lhsElTy,rhsElty,resElTy] + if or untranslatableTys + then let [fun,lhsArg,rhsArg] = Either.lefts args + in reduceZipWith n lhsElTy rhsElty resElTy fun lhsArg rhsArg + else return e + _ -> return e + "Clash.Sized.Vector.map" | length args == 5 -> do + let [argElTy,resElTy,nTy] = Either.rights args + case runExcept (tyNatSize tcm nTy) of + Right n -> do + untranslatableTys <- mapM isUntranslatableType_not_poly [argElTy,resElTy] + if or untranslatableTys + then let [fun,arg] = Either.lefts args + in reduceMap n argElTy resElTy fun arg + else return e + _ -> return e + "Clash.Sized.Vector.traverse#" | length args == 7 -> + let [aTy,fTy,bTy,nTy] = Either.rights args + in case runExcept (tyNatSize tcm nTy) of + Right n -> + let [dict,fun,arg] = Either.lefts args + in reduceTraverse n aTy fTy bTy dict fun arg + _ -> return e + "Clash.Sized.Vector.fold" | length args == 4 -> do + let [aTy,nTy] = Either.rights args + isPow2 x = x /= 0 && (x .&. (complement x + 1)) == x + untranslatableTy <- isUntranslatableType_not_poly aTy + case runExcept (tyNatSize tcm nTy) of + Right n | not (isPow2 (n + 1)) || untranslatableTy -> + let [fun,arg] = Either.lefts args + in reduceFold (n + 1) aTy fun arg + _ -> return e + "Clash.Sized.Vector.foldr" | length args == 6 -> + let [aTy,bTy,nTy] = Either.rights args + in case runExcept (tyNatSize tcm nTy) of + Right n -> do + untranslatableTys <- mapM isUntranslatableType_not_poly [aTy,bTy] + if or untranslatableTys + then let [fun,start,arg] = Either.lefts args + in reduceFoldr n aTy fun start arg + else return e + _ -> return e + "Clash.Sized.Vector.dfold" | length args == 8 -> + let ([_kn,_motive,fun,start,arg],[_mTy,nTy,aTy]) = Either.partitionEithers args + in case runExcept (tyNatSize tcm nTy) of + Right n -> reduceDFold n aTy fun start arg + _ -> return e + "Clash.Sized.Vector.++" | length args == 5 -> + let [nTy,aTy,mTy] = Either.rights args + [lArg,rArg] = Either.lefts args + in case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of + (Right n, Right m) + | n == 0 -> changed rArg + | m == 0 -> changed lArg + | otherwise -> do + untranslatableTy <- isUntranslatableType_not_poly aTy + if untranslatableTy + then reduceAppend n m aTy lArg rArg + else return e + _ -> return e + "Clash.Sized.Vector.head" | length args == 3 -> do + let [nTy,aTy] = Either.rights args + [vArg] = Either.lefts args + case runExcept (tyNatSize tcm nTy) of + Right n -> do + untranslatableTy <- isUntranslatableType_not_poly aTy + if untranslatableTy + then reduceHead n aTy vArg + else return e + _ -> return e + "Clash.Sized.Vector.tail" | length args == 3 -> do + let [nTy,aTy] = Either.rights args + [vArg] = Either.lefts args + case runExcept (tyNatSize tcm nTy) of + Right n -> do + untranslatableTy <- isUntranslatableType_not_poly aTy + if untranslatableTy + then reduceTail n aTy vArg + else return e + _ -> return e + "Clash.Sized.Vector.last" | length args == 3 -> do + let [nTy,aTy] = Either.rights args + [vArg] = Either.lefts args + case runExcept (tyNatSize tcm nTy) of + Right n -> do + untranslatableTy <- isUntranslatableType_not_poly aTy + if untranslatableTy + then reduceLast n aTy vArg + else return e + _ -> return e + "Clash.Sized.Vector.init" | length args == 3 -> do + let [nTy,aTy] = Either.rights args + [vArg] = Either.lefts args + case runExcept (tyNatSize tcm nTy) of + Right n -> do + untranslatableTy <- isUntranslatableType_not_poly aTy + if untranslatableTy + then reduceInit n aTy vArg + else return e + _ -> return e + "Clash.Sized.Vector.unconcat" | length args == 6 -> do + let ([_knN,_sm,arg],[mTy,nTy,aTy]) = Either.partitionEithers args + case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of + (Right n, Right 0) -> reduceUnconcat n 0 aTy arg + _ -> return e + "Clash.Sized.Vector.transpose" | length args == 5 -> do + let ([_knN,arg],[mTy,nTy,aTy]) = Either.partitionEithers args + case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of + (Right n, Right 0) -> reduceTranspose n 0 aTy arg + _ -> return e + "Clash.Sized.Vector.replicate" | length args == 4 -> do + let ([_sArg,vArg],[nTy,aTy]) = Either.partitionEithers args + case runExcept (tyNatSize tcm nTy) of + Right n -> do + untranslatableTy <- isUntranslatableType_not_poly aTy + if untranslatableTy + then reduceReplicate n aTy eTy vArg + else return e + _ -> return e + "Clash.Sized.Vector.imap" | length args == 6 -> do + let [nTy,argElTy,resElTy] = Either.rights args + case runExcept (tyNatSize tcm nTy) of + Right n -> do + untranslatableTys <- mapM isUntranslatableType_not_poly [argElTy,resElTy] + if or untranslatableTys + then let [_,fun,arg] = Either.lefts args + in reduceImap n argElTy resElTy fun arg + else return e + _ -> return e + "Clash.Sized.Vector.dtfold" | length args == 8 -> + let ([_kn,_motive,lrFun,brFun,arg],[_mTy,nTy,aTy]) = Either.partitionEithers args + in case runExcept (tyNatSize tcm nTy) of + Right n -> reduceDTFold n aTy lrFun brFun arg + _ -> return e + "Clash.Sized.RTree.tdfold" | length args == 8 -> + let ([_kn,_motive,lrFun,brFun,arg],[_mTy,nTy,aTy]) = Either.partitionEithers args + in case runExcept (tyNatSize tcm nTy) of + Right n -> reduceTFold n aTy lrFun brFun arg + _ -> return e + "Clash.Sized.RTree.treplicate" | length args == 4 -> do + let ([_sArg,vArg],[nTy,aTy]) = Either.partitionEithers args + case runExcept (tyNatSize tcm nTy) of + Right n -> do + untranslatableTy <- isUntranslatableType False aTy + if untranslatableTy + then reduceReplicate n aTy eTy vArg + else return e + _ -> return e + "Clash.Sized.Internal.BitVector.split#" | length args == 4 -> do + let ([_knArg,bvArg],[nTy,mTy]) = Either.partitionEithers args + case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy), tv) of + (Right n, Right m, TyConApp tupTcNm [lTy,rTy]) + | n == 0 -> do + let (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm + [tupDc] = tyConDataCons tupTc + tup = mkApps (Data tupDc) + [Right lTy + ,Right rTy + ,Left bvArg + ,Left (mkApps (Prim "Clash.Transformations.removedArg" undefinedTy) + [Right rTy]) + ] + + changed tup + | m == 0 -> do + let (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm + [tupDc] = tyConDataCons tupTc + tup = mkApps (Data tupDc) + [Right lTy + ,Right rTy + ,Left (mkApps (Prim "Clash.Transformations.removedArg" undefinedTy) + [Right lTy]) + ,Left bvArg + ] + + changed tup + _ -> return e + "Clash.Sized.Internal.BitVector.eq#" + | ([_,_],[nTy]) <- Either.partitionEithers args + , Right 0 <- runExcept (tyNatSize tcm nTy) + , TyConApp boolTcNm [] <- tv + -> let (Just boolTc) = HashMap.lookup (nameOcc boolTcNm) tcm + [_falseDc,trueDc] = tyConDataCons boolTc + in changed (Data trueDc) + _ -> return e + where + isUntranslatableType_not_poly t = do + u <- isUntranslatableType False t + if u + then return (null $ Lens.toListOf typeFreeVars t) + else return False + +reduceNonRepPrim _ e = return e + +-- | This transformation lifts applications of global binders out of +-- alternatives of case-statements. +-- +-- e.g. It converts: +-- +-- @ +-- case x of +-- A -> f 3 y +-- B -> f x x +-- C -> h x +-- @ +-- +-- into: +-- +-- @ +-- let f_arg0 = case x of {A -> 3; B -> x} +-- f_arg1 = case x of {A -> y; B -> x} +-- f_out = f f_arg0 f_arg1 +-- in case x of +-- A -> f_out +-- B -> f_out +-- C -> h x +-- @ +disjointExpressionConsolidation :: NormRewrite +disjointExpressionConsolidation ctx e@(Case _scrut _ty _alts@(_:_:_)) = do + let eFreeIds = Lens.setOf termFreeIds e + (_,collected) <- collectGlobals eFreeIds [] [] e + let disJoint = filter (isDisjoint . snd. snd) collected + if null disJoint + then return e + else do + exprs <- mapM (mkDisjointGroup eFreeIds) disJoint + tcm <- Lens.view tcCache + (lids,lvs) <- unzip <$> Monad.zipWithM (mkFunOut tcm) disJoint exprs + let substitution = zip (map fst disJoint) lvs + subsMatrix = l2m substitution + (exprs',_) <- unzip <$> Monad.zipWithM (\s (e',seen) -> collectGlobals eFreeIds s seen e') + subsMatrix + exprs + (e',_) <- collectGlobals eFreeIds substitution [] e + let lb = Letrec (bind (rec (zip lids (map embed exprs'))) e') + lb' <- bottomupR deadCode ctx lb + changed lb' + where + mkFunOut tcm (fun,_) (e',_) = do + ty <- termType tcm e' + let nm = case collectArgs fun of + (Var _ nm',_) -> name2String nm' + (Prim nm' _,_) -> unpack nm' + _ -> "complex_expression_" + nm'' = (reverse . List.takeWhile (/='.') . reverse) nm ++ "Out" + mkInternalVar (string2InternalName nm'') ty + + l2m = go [] + where + go _ [] = [] + go xs (y:ys) = (xs ++ ys) : go (xs ++ [y]) ys + +disjointExpressionConsolidation _ e = return e + +-- | Given a function in the desired normal form, inline all the following +-- let-bindings: +-- +-- Let-bindings with an internal name that is only used once, where it binds: +-- * a primitive that will be translated to an HDL expression (as opposed to +-- a HDL declaration) +-- * a projection case-expression (1 alternative) +-- * a data constructor +inlineCleanup :: NormRewrite +inlineCleanup _ (Letrec b) = do + prims <- Lens.use (extra.primitives) + let (bindsR,body) = unsafeUnbind b + binds = unrec bindsR + -- For all let-bindings, count the number of times they are referenced. + -- We only inline let-bindings which are referenced only once, otherwise + -- we would lose sharing. + allOccs = List.foldl' (HashMap.unionWith (+)) HashMap.empty + $ map ( List.foldl' countOcc HashMap.empty + . Lens.toListOf termFreeIds . unembed . snd) binds + bodyFVs = Lens.toListOf termFreeIds body + (il,keep) = List.partition (isInteresting allOccs prims bodyFVs) binds + keep' = inlineBndrs keep il + if null il then return (Letrec b) + else changed (Letrec (bind (rec keep') body)) + where + -- Count the number of occurrences of a variable + countOcc + :: HashMap.HashMap TmOccName Int + -> TmOccName + -> HashMap.HashMap TmOccName Int + countOcc m nm = HashMap.insertWith (+) nm (1::Int) m + + -- Determine whether a let-binding is interesting to inline + isInteresting + :: HashMap.HashMap TmOccName Int + -> PrimMap a + -> [TmOccName] + -> (Id,Embed Term) + -> Bool + isInteresting allOccs prims bodyFVs (id_,(fst.collectArgs.unembed) -> tm) + | nameSort (varName id_) /= User + , nameOcc (varName id_) `notElem` bodyFVs + = case tm of + Prim nm _ + | Just p@(BlackBox {}) <- HashMap.lookup nm prims + , Right _ <- template p + , Just occ <- HashMap.lookup (nameOcc (varName id_)) allOccs + , occ < 2 + -> True + Case _ _ [_] -> True + Data _ -> True + _ -> False + + isInteresting _ _ _ _ = False + + -- Inline let-bindings we want to inline into let-bindings we want to keep. + inlineBndrs + :: [(Id, Embed Term)] + -- let-bindings we keep + -> [(Id, Embed Term)] + -- let-bindings we want to inline + -> [(Id, Embed Term)] + inlineBndrs keep [] = keep + inlineBndrs keep (((nameOcc . varName) -> nm,unembed -> tm):il) = + inlineBndrs (map (substBndr nm tm) keep) + (map (substBndr nm tm) il) + -- We must not forget to inline the /current/ @to-inline@ let-binding into + -- the list of /remaining/ @to-inline@ let-bindings, because it might + -- only occur in /remaining/ @to-inline@ bindings. If we don't, we would + -- introduce free variables, because the @to-inline@ bindings are removed. + +inlineCleanup _ e = return e + +-- | Flatten's letrecs after `inlineCleanup` +-- +-- `inlineCleanup` sometimes exposes additional possibilities for `caseCon`, +-- which then introduces let-bindings in what should be ANF. This transformation +-- flattens those nested let-bindings again. +-- +-- NB: must only be called in the cleaning up phase. +flattenLet :: NormRewrite +flattenLet _ (Letrec b) = do + let (binds,body) = unsafeUnbind b + binds' <- concat <$> mapM go (unrec binds) + case binds' of + -- inline binders into the body when there's only a single binder + [(id',e')] -> do + let fvs = Lens.toListOf termFreeIds (unembed e') + nm = nameOcc (varName id') + if nm `elem` fvs + -- Except when the binder is recursive! + then return (Letrec (bind (rec binds') body)) + else changed (substTm nm (unembed e') body) + _ -> return (Letrec (bind (rec binds') body)) + where + go :: LetBinding -> NormalizeSession [LetBinding] + go (id_,e) = case unembed e of + Letrec b' -> do + let (binds,body) = unsafeUnbind b' + case unrec binds of + -- inline binders into the body when there's only a single binder + [(id',e')] -> do + let fvs = Lens.toListOf termFreeIds (unembed e') + nm = nameOcc (varName id') + if nm `elem` fvs + -- Except when the binder is recursive! + then changed [(id',e'),(id_,embed body)] + else changed [(id_,embed (substTm nm (unembed e') body))] + bs -> changed (bs ++ [(id_,embed body)]) + _ -> return [(id_,e)] + +flattenLet _ e = return e diff --git a/src/Clash/Normalize/Types.hs b/src/Clash/Normalize/Types.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Normalize/Types.hs @@ -0,0 +1,84 @@ +{-| + Copyright : (C) 2012-2016, University of Twente, + 2017, Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Types used in Normalize modules +-} + +{-# LANGUAGE TemplateHaskell #-} + +module Clash.Normalize.Types where + +import Control.Monad.State.Strict (State) +import Data.HashMap.Strict (HashMap) +import Data.Map (Map) + +import Clash.Core.Term (Term, TmName, TmOccName) +import Clash.Core.Type (Type) +import Clash.Driver.Types (BindingMap) +import Clash.Netlist.BlackBox.Types (BlackBoxTemplate) +import Clash.Primitives.Types (PrimMap) +import Clash.Rewrite.Types (Rewrite, RewriteMonad) +import Clash.Util + +-- | State of the 'NormalizeMonad' +data NormalizeState + = NormalizeState + { _normalized :: BindingMap + -- ^ Global binders + , _specialisationCache :: Map (TmOccName,Int,Either Term Type) (TmName,Type) + -- ^ Cache of previously specialised functions: + -- + -- * Key: (name of the original function, argument position, specialised term/type) + -- + -- * Elem: (name of specialised function,type of specialised function) + , _specialisationHistory :: HashMap TmOccName Int + -- ^ Cache of how many times a function was specialized + , _specialisationLimit :: !Int + -- ^ Number of time a function 'f' can be specialized + , _inlineHistory :: HashMap TmOccName (HashMap TmOccName Int) + -- ^ Cache of function where inlining took place: + -- + -- * Key: function where inlining took place + -- + -- * Elem: (functions which were inlined, number of times inlined) + , _inlineLimit :: !Int + -- ^ Number of times a function 'f' can be inlined in a function 'g' + , _inlineFunctionLimit :: !Word + -- ^ Size of a function below which it is always inlined if it is not + -- recursive + , _inlineConstantLimit :: !Word + -- ^ Size of a constant below which it is always inlined; 0 = no limit + , _primitives :: PrimMap BlackBoxTemplate -- ^ Primitive Definitions + , _recursiveComponents :: HashMap TmOccName Bool + -- ^ Map telling whether a components is recursively defined. + -- + -- NB: there are only no mutually-recursive component, only self-recursive + -- ones. + } + +makeLenses ''NormalizeState + +-- | State monad that stores specialisation and inlining information +type NormalizeMonad = State NormalizeState + +-- | RewriteSession with extra Normalisation information +type NormalizeSession = RewriteMonad NormalizeState + +-- | A 'Transform' action in the context of the 'RewriteMonad' and 'NormalizeMonad' +type NormRewrite = Rewrite NormalizeState + +-- | Description of a @Term@ in terms of the type "components" the @Term@ has. +-- +-- Is used as a performance/size metric. +data TermClassification + = TermClassification + { _function :: !Int -- ^ Number of functions + , _primitive :: !Int -- ^ Number of primitives + , _selection :: !Int -- ^ Number of selections/multiplexers + } + deriving Show + +makeLenses ''TermClassification diff --git a/src/Clash/Normalize/Util.hs b/src/Clash/Normalize/Util.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Normalize/Util.hs @@ -0,0 +1,165 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Utility functions used by the normalisation transformations +-} + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +module Clash.Normalize.Util where + +import Control.Lens ((&),(+~),(%=),(^.),_5) +import qualified Control.Lens as Lens +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Lazy as HashMap +import qualified Data.List as List +import Unbound.Generics.LocallyNameless (Fresh, unembed ,unrec) +import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) + +import Clash.Core.FreeVars (termFreeIds) +import Clash.Core.Term (Term (..), TmOccName) +import Clash.Core.TyCon (TyCon, TyConOccName) +import Clash.Core.Util + (collectArgs, isClockOrReset, isPolyFun, termType) +import Clash.Driver.Types (BindingMap) +import Clash.Normalize.Types +import Clash.Rewrite.Types (bindings,extra,tcCache) +import Clash.Rewrite.Util (specialise) + +-- | Determine if a function is already inlined in the context of the 'NetlistMonad' +alreadyInlined + :: TmOccName + -- ^ Function we want to inline + -> TmOccName + -- ^ Function in which we want to perform the inlining + -> NormalizeMonad (Maybe Int) +alreadyInlined f cf = do + inlinedHM <- Lens.use inlineHistory + case HashMap.lookup cf inlinedHM of + Nothing -> return Nothing + Just inlined' -> return (HashMap.lookup f inlined') + +addNewInline + :: TmOccName + -- ^ Function we want to inline + -> TmOccName + -- ^ Function in which we want to perform the inlining + -> NormalizeMonad () +addNewInline f cf = + inlineHistory %= HashMap.insertWith + (\_ hm -> HashMap.insertWith (+) f 1 hm) + cf + (HashMap.singleton f 1) + +-- | Specialize under the Normalization Monad +specializeNorm :: NormRewrite +specializeNorm = specialise specialisationCache specialisationHistory specialisationLimit + +-- | Determine if a term is closed +isClosed :: Fresh m + => HashMap TyConOccName TyCon + -> Term + -> m Bool +isClosed tcm = fmap not . isPolyFun tcm + +-- | Determine if a term represents a constant +isConstant :: Term -> Bool +isConstant e = case collectArgs e of + (Data _, args) -> all (either isConstant (const True)) args + (Prim _ _, args) -> all (either isConstant (const True)) args + (Literal _,_) -> True + _ -> False + +isConstantNotClockReset :: Term -> NormalizeSession Bool +isConstantNotClockReset e = do + tcm <- Lens.view tcCache + eTy <- termType tcm e + if isClockOrReset tcm eTy + then return False + else return (isConstant e) + +-- | Assert whether a name is a reference to a recursive binder. +isRecursiveBndr + :: TmOccName + -> NormalizeSession Bool +isRecursiveBndr f = do + cg <- Lens.use (extra.recursiveComponents) + case HashMap.lookup f cg of + Just isR -> return isR + Nothing -> do + fBodyM <- HashMap.lookup f <$> Lens.use bindings + case fBodyM of + Nothing -> return False + Just (_,_,_,_,fBody) -> do + -- There are no global mutually-recursive functions, only self-recursive + -- ones, so checking whether 'f' is part of the free variables of the + -- body of 'f' is sufficient. + let used = Lens.toListOf termFreeIds fBody + isR = f `elem` used + (extra.recursiveComponents) %= HashMap.insert f isR + return isR + +-- | A call graph counts the number of occurrences that a functions 'g' is used +-- in 'f'. +type CallGraph = HashMap TmOccName (HashMap TmOccName Word) + +-- | Create a call graph for a set of global binders, given a root +callGraph + :: BindingMap + -> TmOccName + -> CallGraph +callGraph bndrs = go HashMap.empty + where + go cg root + | Nothing <- HashMap.lookup root cg + , Just rootTm <- HashMap.lookup root bndrs = + let used = List.foldl' + (\m k -> HashMap.insertWith (+) k 1 m) + HashMap.empty + (Lens.toListOf termFreeIds (rootTm ^. _5)) + cg' = HashMap.insert root used cg + in List.foldl' go cg' (HashMap.keys used) + go cg _ = cg + +-- | Give a "performance/size" classification of a function in normal form. +classifyFunction + :: Term + -> TermClassification +classifyFunction = go (TermClassification 0 0 0) + where + go !c (Lam b) = let (_,e) = unsafeUnbind b in go c e + go !c (TyLam b) = let (_,e) = unsafeUnbind b in go c e + go !c (Letrec b) = + let (bndsR,_) = unsafeUnbind b + es = map (unembed . snd) (unrec bndsR) + in List.foldl' go c es + go !c e@(App _ _) = case fst (collectArgs e) of + Prim _ _ -> c & primitive +~ 1 + Var _ _ -> c & function +~ 1 + _ -> c + go !c (Case _ _ alts) = case alts of + (_:_:_) -> c & selection +~ 1 + _ -> c + go c _ = c + +-- | Determine whether a function adds a lot of hardware or not. +-- +-- It is considered expensive when it has 2 or more of the following components: +-- +-- * functions +-- * primitives +-- * selections (multiplexers) +isCheapFunction + :: Term + -> Bool +isCheapFunction tm = case classifyFunction tm of + TermClassification {..} + | _function <= 1 -> _primitive <= 0 && _selection <= 0 + | _primitive <= 1 -> _function <= 0 && _selection <= 0 + | _selection <= 1 -> _function <= 0 && _primitive <= 0 + | otherwise -> False diff --git a/src/Clash/Primitives/Types.hs b/src/Clash/Primitives/Types.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Primitives/Types.hs @@ -0,0 +1,68 @@ +{-| + Copyright : (C) 2012-2016, University of Twente, + 2016-2017, Myrtle Software Ltd + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Type and instance definitions for Primitive +-} + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Clash.Primitives.Types where + +import Control.Applicative ((<|>)) +import Data.Aeson (FromJSON (..), Value (..), (.:), (.:?), (.!=)) +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Strict as H +import qualified Data.Text as S +import Data.Text.Lazy (Text) + +-- | Primitive Definitions +type PrimMap a = HashMap S.Text (Primitive a) + +-- | Externally defined primitive +data Primitive a + -- | A primitive that has a template that can be filled out by the backend render + = BlackBox + { name :: !S.Text + -- ^ Name of the primitive + , outputReg :: Bool + -- ^ Verilog only: whether the result should be a /reg/(@True@) or /wire/ + -- (@False@); when not specified in the /.json/ file, the value will default + -- to @False@ (i.e. /wire/). + , library :: [a] + -- ^ VHDL only: add /library/ declarations for the given names + , imports :: [a] + -- ^ VHDL only: add /use/ declarations for the given names + , include :: Maybe ((S.Text,S.Text),a) + -- ^ Intel/Quartus only: create a /.qsys/ file from the given template. + -- Defaults to @Nothing@ when not specified in the /.json/ file + , template :: !(Either a a) -- ^ Either a /declaration/ or an /expression/ template. + } + -- | A primitive that carries additional information + | Primitive + { name :: !S.Text -- ^ Name of the primitive + , primType :: !Text -- ^ Additional information + } + deriving Show + +instance FromJSON (Primitive Text) where + parseJSON (Object v) = case H.toList v of + [(conKey,Object conVal)] -> case conKey of + "BlackBox" -> BlackBox <$> conVal .: "name" + <*> conVal .:? "outputReg" .!= False + <*> conVal .:? "libraries" .!= [] + <*> conVal .:? "imports" .!= [] + <*> (conVal .:? "include" >>= parseInclude) + <*> ((Left <$> conVal .: "templateD") <|> (Right <$> conVal .: "templateE")) + "Primitive" -> Primitive <$> conVal .: "name" <*> conVal .: "primType" + _ -> error "Expected: BlackBox or Primitive object" + _ -> error "Expected: BlackBox or Primitive object" + where + parseInclude Nothing = pure Nothing + parseInclude (Just c) = + Just <$> ((,) <$> ((,) <$> c .: "name" <*> c .: "extension") <*> c .: "content") + parseJSON _ = error "Expected: BlackBox or Primitive object" diff --git a/src/Clash/Primitives/Util.hs b/src/Clash/Primitives/Util.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Primitives/Util.hs @@ -0,0 +1,55 @@ +{-| + Copyright : (C) 2012-2016, University of Twente, + 2017 , Myrtle Software Ltd + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Utility functions to generate Primitives +-} + +module Clash.Primitives.Util where + +import Data.Aeson (FromJSON) +import Data.Aeson.Extra (decodeOrErr) +import qualified Data.ByteString.Lazy as LZ +import qualified Data.HashMap.Lazy as HashMap +import Data.List (isSuffixOf) +import Data.Maybe (fromMaybe) +import Data.Text.Lazy (Text) +import qualified System.Directory as Directory +import qualified System.FilePath as FilePath + +import Clash.Primitives.Types +import Clash.Util + +parsePrimitive :: (FromJSON a) + => FilePath + -> IO [a] +parsePrimitive filename = ( return + . fromMaybe [] + . decodeOrErr filename + <=< LZ.readFile + ) filename + +-- | Generate a set of primitives that are found in the primitive definition +-- files in the given directories. +generatePrimMap :: [FilePath] -- ^ Directories to search for primitive definitions + -> IO (PrimMap Text) +generatePrimMap filePaths = do + primitiveFiles <- fmap concat $ mapM + (\filePath -> do + fpExists <- Directory.doesDirectoryExist filePath + if fpExists + then + fmap ( map (FilePath.combine filePath) + . filter (isSuffixOf ".json") + ) (Directory.getDirectoryContents filePath) + else + return [] + ) filePaths + + primitives <- fmap concat $ mapM parsePrimitive primitiveFiles + + let primMap = HashMap.fromList $ zip (map name primitives) primitives + + return primMap diff --git a/src/Clash/Rewrite/Combinators.hs b/src/Clash/Rewrite/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Rewrite/Combinators.hs @@ -0,0 +1,179 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Rewriting combinators and traversals +-} + +{-# LANGUAGE ScopedTypeVariables #-} + +module Clash.Rewrite.Combinators where + +import Control.DeepSeq (deepseq) +import Control.Monad ((<=<), (>=>)) +import qualified Control.Monad.Writer as Writer +import qualified Data.Monoid as Monoid +import Unbound.Generics.LocallyNameless (Embed, Fresh, bind, embed, + rec, unbind, unembed, unrec) +import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) + +import Clash.Core.Term (Pat, Term (..)) +import Clash.Core.Util (patIds) +import Clash.Core.Var (Id) +import Clash.Rewrite.Types + +-- | Apply a transformation on the subtrees of an term +allR :: forall m . (Monad m, Fresh m) + => Bool -- ^ Freshen variable references in abstracted terms + -> Transform m -- ^ The transformation to apply to the subtrees + -> Transform m +allR _ _ _ (Var t x) = return (Var t x) +allR _ _ _ (Data dc) = return (Data dc) +allR _ _ _ (Literal l) = return (Literal l) +allR _ _ _ (Prim nm t) = return (Prim nm t) + +allR rf trans c (Lam b) = do + (v,e) <- if rf then unbind b else return (unsafeUnbind b) + e' <- trans (LamBody v:c) e + return . Lam $ bind v e' + +allR rf trans c (TyLam b) = do + (tv, e) <- if rf then unbind b else return (unsafeUnbind b) + e' <- trans (TyLamBody tv:c) e + return . TyLam $ bind tv e' + +allR _ trans c (App e1 e2) = do + e1' <- trans (AppFun:c) e1 + e2' <- trans (AppArg:c) e2 + return $ App e1' e2' + +allR _ trans c (TyApp e ty) = do + e' <- trans (TyAppC:c) e + return $ TyApp e' ty + +allR _ trans c (Cast e ty1 ty2) = do + e' <- trans (CastBody:c) e + return $ Cast e' ty1 ty2 + +allR rf trans c (Letrec b) = do + (xesR,e) <- if rf then unbind b else return (unsafeUnbind b) + let xes = unrec xesR + let bndrs = map fst xes + e' <- trans (LetBody bndrs:c) e + xes' <- mapM (rewriteBind bndrs) xes + return . Letrec $ bind (rec xes') e' + where + rewriteBind :: [Id] -> (Id,Embed Term) -> m (Id,Embed Term) + rewriteBind bndrs (b', e) = do + e' <- trans (LetBinding b' bndrs:c) (unembed e) + return (b',embed e') + +allR rf trans c (Case scrut ty alts) = do + scrut' <- trans (CaseScrut:c) scrut + alts' <- if rf then mapM (fmap (uncurry bind) . rewriteAlt <=< unbind) alts + else mapM (fmap (uncurry bind) . rewriteAlt . unsafeUnbind) alts + return $ Case scrut' ty alts' + where + rewriteAlt :: (Pat, Term) -> m (Pat, Term) + rewriteAlt (p,e) = do + e' <- trans (CaseAlt (patIds p):c) e + return (p,e') + +infixr 6 >-> +-- | Apply two transformations in succession +(>->) :: Monad m => Transform m -> Transform m -> Transform m +(>->) r1 r2 c = r1 c >=> r2 c + +infixr 6 >-!-> +-- | Apply two transformations in succession, and perform a deepseq in between. +(>-!->) :: Monad m => Transform m -> Transform m -> Transform m +(>-!->) r1 r2 c e = do + e' <- r1 c e + deepseq e' (r2 c e') + +{- +Note [topdown repeatR] +~~~~~~~~~~~~~~~~~~~~~~ +In a topdown traversal we need to repeat the transformation r because +if r replaces a parent node with one of its children +we should still apply r to that child, before continuing with its children. + +Example: topdownR (inlineBinders (\_ _ -> return True)) +on: +> letrec +> x = 1 +> in letrec +> y = 2 +> in f x y + +inlineBinders would inline x and return: +> letrec +> y = 2 +> in f 1 y + +Then we must repeat the transformation to let it also inline y. +-} + +-- | Apply a transformation in a topdown traversal +topdownR :: Rewrite m -> Rewrite m +-- See Note [topdown repeatR] +topdownR r = repeatR r >-> allR True (topdownR r) + +-- | Apply a transformation in a topdown traversal. Doesn't freshen bound +-- variables +unsafeTopdownR :: Rewrite m -> Rewrite m +-- See NOTE [topdown repeatR] +unsafeTopdownR r = repeatR r >-> allR False (unsafeTopdownR r) + +-- | Apply a transformation in a bottomup traversal +bottomupR :: Fresh m => Transform m -> Transform m +bottomupR r = allR True (bottomupR r) >-> r + +-- | Apply a transformation in a bottomup traversal. Doesn't freshen bound +-- variables +unsafeBottomupR :: Fresh m => Transform m -> Transform m +unsafeBottomupR r = allR False (unsafeBottomupR r) >-> r + +infixr 5 !-> +-- | Only apply the second transformation if the first one succeeds. +(!->) :: Rewrite m -> Rewrite m -> Rewrite m +(!->) r1 r2 c expr = do + (expr',changed) <- Writer.listen $ r1 c expr + if Monoid.getAny changed + then r2 c expr' + else return expr' + +infixr 5 >-! +-- | Only apply the second transformation if the first one fails. +(>-!) :: Rewrite m -> Rewrite m -> Rewrite m +(>-!) r1 r2 c expr = do + (expr',changed) <- Writer.listen $ r1 c expr + if Monoid.getAny changed + then return expr' + else r2 c expr' + +-- | Keep applying a transformation until it fails. +repeatR :: Rewrite m -> Rewrite m +repeatR r = r !-> repeatR r + +whenR :: Monad m + => ([CoreContext] -> Term -> m Bool) + -> Transform m + -> Transform m +whenR f r1 ctx expr = do + b <- f ctx expr + if b + then r1 ctx expr + else return expr + +-- | Only traverse downwards when the assertion evaluates to true +bottomupWhenR :: Fresh m + => ([CoreContext] -> Term -> m Bool) + -> Transform m + -> Transform m +bottomupWhenR f r ctx expr = do + b <- f ctx expr + if b + then (allR True (bottomupWhenR f r) >-> r) ctx expr + else r ctx expr diff --git a/src/Clash/Rewrite/Types.hs b/src/Clash/Rewrite/Types.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Rewrite/Types.hs @@ -0,0 +1,159 @@ +{-| + Copyright : (C) 2012-2016, University of Twente, + 2016 , Myrtle Software Ltd, + 2017 , Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Type and instance definitions for Rewrite modules +-} + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +module Clash.Rewrite.Types where + +import Control.Concurrent.Supply (Supply, freshId) +import Control.Lens (use, (.=), (<<%=)) +import Control.Monad +import Control.Monad.Fix (MonadFix (..), fix) +import Control.Monad.Reader (MonadReader (..)) +import Control.Monad.State (MonadState (..)) +import Control.Monad.Writer (MonadWriter (..)) +import Data.HashMap.Strict (HashMap) +import Data.HashSet (HashSet) +import Data.IntMap.Strict (IntMap) +import Data.Monoid (Any) +import Unbound.Generics.LocallyNameless (Fresh (..)) +import Unbound.Generics.LocallyNameless.Name (Name (..)) + +import SrcLoc (SrcSpan) + +import Clash.Core.Evaluator (PrimEvaluator) +import Clash.Core.Term (Term, TmName, TmOccName) +import Clash.Core.Type (Type) +import Clash.Core.TyCon (TyCon, TyConName, TyConOccName) +import Clash.Core.Var (Id, TyVar) +import Clash.Driver.Types (BindingMap, DebugLevel) +import Clash.Netlist.Types (HWType) +import Clash.Util + +-- | Context in which a term appears +data CoreContext + = AppFun -- ^ Function position of an application + | AppArg -- ^ Argument position of an application + | TyAppC -- ^ Function position of a type application + | LetBinding Id [Id] -- ^ RHS of a Let-binder with the sibling LHS' + | LetBody [Id] -- ^ Body of a Let-binding with the bound LHS' + | LamBody Id -- ^ Body of a lambda-term with the abstracted variable + | TyLamBody TyVar -- ^ Body of a TyLambda-term with the abstracted + -- type-variable + | CaseAlt [Id] -- ^ RHS of a case-alternative with the variables bound by + -- the pattern on the LHS + | CaseScrut -- ^ Subject of a case-decomposition + | CastBody -- ^ Body of a Cast + deriving (Eq,Show) + +-- | State of a rewriting session +data RewriteState extra + = RewriteState + { _transformCounter :: {-# UNPACK #-} !Int + -- ^ Number of applied transformations + , _bindings :: !BindingMap + -- ^ Global binders + , _uniqSupply :: !Supply + -- ^ Supply of unique numbers + , _curFun :: (TmName,SrcSpan) -- Initially set to undefined: no strictness annotation + -- ^ Function which is currently normalized + , _nameCounter :: {-# UNPACK #-} !Int + -- ^ Used for 'Fresh' + , _extra :: !extra + -- ^ Additional state + } + +makeLenses ''RewriteState + + + +-- | Read-only environment of a rewriting session +data RewriteEnv + = RewriteEnv + { _dbgLevel :: DebugLevel + -- ^ Lvl at which we print debugging messages + , _typeTranslator :: HashMap TyConOccName TyCon -> Bool -> Type + -> Maybe (Either String HWType) + -- ^ Hardcode Type -> HWType translator + , _tcCache :: HashMap TyConOccName TyCon + -- ^ TyCon cache + , _tupleTcCache :: IntMap TyConName + -- ^ Tuple TyCon cache + , _evaluator :: PrimEvaluator + -- ^ Hardcoded evaluator (delta-reduction)} + , _allowZero :: Bool + -- ^ Zero bit wide things are representable + , _topEntities :: HashSet TmOccName + -- ^ Functions that are considered TopEntities + } + +makeLenses ''RewriteEnv + +-- | Monad that keeps track how many transformations have been applied and can +-- generate fresh variables and unique identifiers. In addition, it keeps track +-- if a transformation/rewrite has been successfully applied. +newtype RewriteMonad extra a = R + { runR :: RewriteEnv -> RewriteState extra -> (a,RewriteState extra,Any) } + +instance Functor (RewriteMonad extra) where + fmap f m = R (\r s -> case runR m r s of (a,s',w) -> (f a,s',w)) + +instance Applicative (RewriteMonad extra) where + pure = return + (<*>) = ap + +instance Monad (RewriteMonad extra) where + return a = R (\_ s -> (a, s, mempty)) + m >>= k = R (\r s -> case runR m r s of + (a,s',w) -> case runR (k a) r s' of + (b,s'',w') -> let w'' = mappend w w' + in seq w'' (b,s'',w'')) + +instance MonadState (RewriteState extra) (RewriteMonad extra) where + get = R (\_ s -> (s,s,mempty)) + put s = R (\_ _ -> ((),s,mempty)) + state f = R (\_ s -> case f s of (a,s') -> (a,s',mempty)) + +instance Fresh (RewriteMonad extra) where + fresh (Fn s _) = do + n <- nameCounter <<%= (+1) + let n' = toInteger n + n' `seq` return (Fn s n') + fresh nm@(Bn {}) = return nm + +instance MonadUnique (RewriteMonad extra) where + getUniqueM = do + sup <- use uniqSupply + let (a,sup') = freshId sup + uniqSupply .= sup' + a `seq` return a + +instance MonadWriter Any (RewriteMonad extra) where + writer (a,w) = R (\_ s -> (a,s,w)) + tell w = R (\_ s -> ((),s,w)) + listen m = R (\r s -> case runR m r s of (a,s',w) -> ((a,w),s',w)) + pass m = R (\r s -> case runR m r s of ((a,f),s',w) -> (a, s', f w)) + +instance MonadReader RewriteEnv (RewriteMonad extra) where + ask = R (\r s -> (r,s,mempty)) + local f m = R (\r s -> runR m (f r) s) + reader f = R (\r s -> (f r,s,mempty)) + +instance MonadFix (RewriteMonad extra) where + mfix f = R (\r s -> fix $ \ ~(a,_,_) -> runR (f a) r s) + +-- | Monadic action that transforms a term given a certain context +type Transform m = [CoreContext] -> Term -> m Term + +-- | A 'Transform' action in the context of the 'RewriteMonad' +type Rewrite extra = Transform (RewriteMonad extra) diff --git a/src/Clash/Rewrite/Util.hs b/src/Clash/Rewrite/Util.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Rewrite/Util.hs @@ -0,0 +1,759 @@ +{-| + Copyright : (C) 2012-2016, University of Twente, + 2016 , Myrtle Software Ltd, + 2017 , Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Utilities for rewriting: e.g. inlining, specialisation, etc. +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +module Clash.Rewrite.Util where + +import Control.DeepSeq +import Control.Exception (throw) +import Control.Lens + (Lens', (%=), (+=), (^.), _2, _4, _5, _Left) +import qualified Control.Lens as Lens +import qualified Control.Monad as Monad +import qualified Control.Monad.State.Strict as State +import qualified Control.Monad.Writer as Writer +import Data.Bifunctor (bimap) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Lazy as HML +import qualified Data.HashMap.Strict as HMS +import qualified Data.HashSet as HashSet +import qualified Data.List as List +import qualified Data.Map as Map +import Data.Maybe (catMaybes,isJust,mapMaybe) +import qualified Data.Monoid as Monoid +import qualified Data.Set as Set +import qualified Data.Set.Lens as Lens +import Unbound.Generics.LocallyNameless + (Fresh, bind, embed, rebind, rec, unbind, unembed, unrec) +import qualified Unbound.Generics.LocallyNameless as Unbound +import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) + +import BasicTypes (InlineSpec (..)) +import SrcLoc (SrcSpan) + +import Clash.Core.DataCon (dataConInstArgTys) +import Clash.Core.FreeVars (termFreeIds, termFreeTyVars, + typeFreeVars) +import Clash.Core.Name +import Clash.Core.Pretty (showDoc) +import Clash.Core.Subst (substTm) +import Clash.Core.Term + (LetBinding, Pat (..), Term (..), TmName, TmOccName) +import Clash.Core.TyCon + (TyCon, TyConOccName, tyConDataCons) +import Clash.Core.Type (KindOrType, Type (..), + TypeView (..), coreView, + normalizeType, + typeKind, tyView) +import Clash.Core.Util + (Delta, Gamma, collectArgs, isPolyFun, mkAbstraction, mkApps, mkId, mkLams, + mkTmApps, mkTyApps, mkTyLams, mkTyVar, termType) +import Clash.Core.Var (Id, TyVar, Var (..)) +import Clash.Driver.Types + (ClashException (..), DebugLevel (..)) +import Clash.Netlist.Util (representableType) +import Clash.Rewrite.Types +import Clash.Util + +-- | Lift an action working in the '_extra' state to the 'RewriteMonad' +zoomExtra :: State.State extra a + -> RewriteMonad extra a +zoomExtra m = R (\_ s -> case State.runState m (s ^. extra) of + (a,s') -> (a,s {_extra = s'},mempty)) + +-- | Record if a transformation is succesfully applied +apply :: String -- ^ Name of the transformation + -> Rewrite extra -- ^ Transformation to be applied + -> Rewrite extra +apply name rewrite ctx expr = do + lvl <- Lens.view dbgLevel + let before = showDoc expr + (expr', anyChanged) <- traceIf (lvl >= DebugAll) ("Trying: " ++ name ++ " on:\n" ++ before) $ Writer.listen $ rewrite ctx expr + let hasChanged = Monoid.getAny anyChanged + Monad.when hasChanged $ transformCounter += 1 + let after = showDoc expr' + let expr'' = if hasChanged then expr' else expr + + Monad.when (lvl > DebugNone && hasChanged) $ do + tcm <- Lens.view tcCache + beforeTy <- termType tcm expr + let beforeFTV = Lens.setOf termFreeTyVars expr + beforeFV <- Lens.setOf <$> localFreeIds <*> pure expr + afterTy <- termType tcm expr' + let afterFTV = Lens.setOf termFreeTyVars expr + afterFV <- Lens.setOf <$> localFreeIds <*> pure expr' + let newFV = Set.size afterFTV > Set.size beforeFTV || + Set.size afterFV > Set.size beforeFV + Monad.when newFV $ + error ( concat [ $(curLoc) + , "Error when applying rewrite ", name + , " to:\n" , before + , "\nResult:\n" ++ after ++ "\n" + , "Changes free variables from: ", show (beforeFTV,beforeFV) + , "\nto: ", show (afterFTV,afterFV) + ] + ) + traceIf (lvl >= DebugAll && beforeTy /= afterTy) + ( concat [ $(curLoc) + , "Error when applying rewrite ", name + , " to:\n" , before + , "\nResult:\n" ++ after ++ "\n" + , "Changes type from:\n", showDoc beforeTy + , "\nto:\n", showDoc afterTy + ] + ) (return ()) + + Monad.when (lvl >= DebugApplied && not hasChanged && expr /= expr') $ + error $ $(curLoc) ++ "Expression changed without notice(" ++ name ++ "): before" ++ before ++ "\nafter:\n" ++ after + + traceIf (lvl >= DebugName && hasChanged) name $ + traceIf (lvl >= DebugApplied && hasChanged) ("Changes when applying rewrite to:\n" ++ before ++ "\nResult:\n" ++ after ++ "\n") $ + traceIf (lvl >= DebugAll && not hasChanged) ("No changes when applying rewrite " ++ name ++ " to:\n" ++ after ++ "\n") $ + return expr'' + +-- | Perform a transformation on a Term +runRewrite :: String -- ^ Name of the transformation + -> Rewrite extra -- ^ Transformation to perform + -> Term -- ^ Term to transform + -> RewriteMonad extra Term +runRewrite name rewrite expr = apply name rewrite [] expr + +-- | Evaluate a RewriteSession to its inner monad +runRewriteSession :: RewriteEnv + -> RewriteState extra + -> RewriteMonad extra a + -> a +runRewriteSession r s m = traceIf True ("Applied " ++ + show (s' ^. transformCounter) ++ + " transformations") + a + where + (a,s',_) = runR m r s + +-- | Notify that a transformation has changed the expression +setChanged :: RewriteMonad extra () +setChanged = Writer.tell (Monoid.Any True) + +-- | Identity function that additionally notifies that a transformation has +-- changed the expression +changed :: a -> RewriteMonad extra a +changed val = do + Writer.tell (Monoid.Any True) + return val + +-- | Create a type and kind context out of a transformation context +contextEnv :: [CoreContext] + -> (Gamma, Delta) +contextEnv = go HML.empty HML.empty + where + go gamma delta [] = (gamma,delta) + go gamma delta (LetBinding _ ids:ctx) = go gamma' delta ctx + where + gamma' = foldl addToGamma gamma ids + + go gamma delta (LetBody ids:ctx) = go gamma' delta ctx + where + gamma' = foldl addToGamma gamma ids + + go gamma delta (LamBody lId:ctx) = go gamma' delta ctx + where + gamma' = addToGamma gamma lId + + go gamma delta (TyLamBody tv:ctx) = go gamma delta' ctx + where + delta' = addToDelta delta tv + + go gamma delta (CaseAlt ids:ctx) = go gamma' delta ctx + where + gamma' = foldl addToGamma gamma ids + + go gamma delta (_:ctx) = go gamma delta ctx + + addToGamma gamma (Id idName ty) = HML.insert (nameOcc idName) (unembed ty) gamma + addToGamma _ _ = error $ $(curLoc) ++ "Adding TyVar to Gamma" + + addToDelta delta (TyVar tvName ki) = HML.insert (nameOcc tvName) (unembed ki) delta + addToDelta _ _ = error $ $(curLoc) ++ "Adding Id to Delta" + +closestLetBinder :: [CoreContext] -> Maybe Id +closestLetBinder [] = Nothing +closestLetBinder (LetBinding id_ _:_) = Just id_ +closestLetBinder (_:ctx) = closestLetBinder ctx + +mkDerivedName :: [CoreContext] -> String -> TmName +mkDerivedName ctx sf = case closestLetBinder ctx of + Just id_ -> appendToName (varName id_) ('_':sf) + _ -> string2InternalName sf + +-- | Create a complete type and kind context out of the global binders and the +-- transformation context +mkEnv :: [CoreContext] + -> RewriteMonad extra (Gamma, Delta) +mkEnv ctx = do + let (gamma,delta) = contextEnv ctx + tsMap <- fmap (HML.map (^. _2)) $ Lens.use bindings + let gamma' = tsMap `HML.union` gamma + return (gamma',delta) + +-- | Make a new binder and variable reference for a term +mkTmBinderFor :: (Fresh m, MonadUnique m) + => HashMap TyConOccName TyCon -- ^ TyCon cache + -> Name a -- ^ Name of the new binder + -> Term -- ^ Term to bind + -> m (Id, Term) +mkTmBinderFor tcm name e = do + (Left r) <- mkBinderFor tcm name (Left e) + return r + +-- | Make a new binder and variable reference for either a term or a type +mkBinderFor :: (Monad m, MonadUnique m, Fresh m) + => HashMap TyConOccName TyCon -- ^ TyCon cache + -> Name a -- ^ Name of the new binder + -> Either Term Type -- ^ Type or Term to bind + -> m (Either (Id,Term) (TyVar,Type)) +mkBinderFor tcm name (Left term) = + Left <$> (mkInternalVar (coerceName name) =<< termType tcm term) + +mkBinderFor tcm name (Right ty) = do + name' <- cloneVar (coerceName name) + let kind = typeKind tcm ty + return $ Right (TyVar name' (embed kind), VarTy kind name') + +-- | Make a new, unique, identifier and corresponding variable reference +mkInternalVar :: (Monad m, MonadUnique m) + => TmName -- ^ Name of the identifier + -> KindOrType + -> m (Id,Term) +mkInternalVar name ty = do + name' <- cloneVar name + return (Id name' (embed ty),Var ty name') + +-- | Inline the binders in a let-binding that have a certain property +inlineBinders :: (Term -> LetBinding -> RewriteMonad extra Bool) -- ^ Property test + -> Rewrite extra +inlineBinders condition _ expr@(Letrec b) = do + (xes,res) <- unbind b + let expr' = Letrec (bind xes res) + (replace,others) <- partitionM (condition expr') (unrec xes) + case replace of + [] -> return expr + _ -> do + let (others',res') = substituteBinders replace others res + newExpr = case others' of + [] -> res' + _ -> Letrec (bind (rec others') res') + + changed newExpr + +inlineBinders _ _ e = return e + +-- | Determine whether a binder is a join-point created for a complex case +-- expression. +-- +-- A join-point is when a local function only occurs in tail-call positions, +-- and when it does, more than once. +isJoinPointIn :: Id -- ^ 'Id' of the local binder + -> Term -- ^ Expression in which the binder is bound + -> Bool +isJoinPointIn id_ e = case tailCalls id_ e of + Just n | n > 1 -> True + _ -> False + +-- | Count the number of (only) tail calls of a function in an expression. +-- 'Nothing' indicates that the function was used in a non-tail call position. +tailCalls :: Id -- ^ Function to check + -> Term -- ^ Expression to check it in + -> Maybe Int +tailCalls id_ expr = case expr of + Var _ nm | varName id_ == nm -> Just 1 + | otherwise -> Just 0 + Lam b -> let (_,expr') = unsafeUnbind b + in tailCalls id_ expr' + TyLam b -> let (_,expr') = unsafeUnbind b + in tailCalls id_ expr' + App l r -> case tailCalls id_ r of + Just 0 -> tailCalls id_ l + _ -> Nothing + TyApp l _ -> tailCalls id_ l + Letrec b -> + let (bsR,expr') = unsafeUnbind b + (bsIds,bsExprs) = unzip (unrec bsR) + bsTls = map (tailCalls id_ . unembed) bsExprs + bsIdsUsed = mapMaybe (\(l,r) -> pure l <* r) (zip bsIds bsTls) + bsIdsTls = map (`tailCalls` expr') bsIdsUsed + bsCount = pure . sum $ catMaybes bsTls + in case (all isJust bsTls) of + False -> Nothing + True -> case (all (==0) $ catMaybes bsTls) of + False -> case all isJust bsIdsTls of + False -> Nothing + True -> (+) <$> bsCount <*> tailCalls id_ expr' + True -> tailCalls id_ expr' + Case scrut _ alts -> + let scrutTl = tailCalls id_ scrut + altsTl = map (tailCalls id_ . snd . unsafeUnbind) alts + in case scrutTl of + Just 0 | all (/= Nothing) altsTl -> Just (sum (catMaybes altsTl)) + _ -> Nothing + _ -> Just 0 + +-- | Determines whether a function has the following shape: +-- +-- > \(w :: Void) -> f a b c +-- +-- i.e. is a wrapper around a (partially) applied function 'f', where the +-- introduced argument 'w' is not used by 'f' +isVoidWrapper :: Term -> Bool +isVoidWrapper (Lam b) = case unsafeUnbind b of + (bndr,e@(collectArgs -> (Var _ _,_))) + -> nameOcc (varName bndr) `notElem` Lens.toListOf termFreeIds e + _ -> False +isVoidWrapper _ = False + +-- | Substitute the RHS of the first set of Let-binders for references to the +-- first set of Let-binders in: the second set of Let-binders and the additional +-- term +substituteBinders :: [LetBinding] -- ^ Let-binders to substitute + -> [LetBinding] -- ^ Let-binders where substitution takes place + -> Term -- ^ Expression where substitution takes place + -> ([LetBinding],Term) +substituteBinders [] others res = (others,res) +substituteBinders ((bndr,valE):rest) others res = substituteBinders rest' others' res' + where + val = unembed valE + bndrName = nameOcc (varName bndr) + selfRef = bndrName `elem` Lens.toListOf termFreeIds val + (res',rest',others') = if selfRef + then (res,rest,(bndr,valE):others) + else ( substTm bndrName val res + , map (second ( embed + . substTm bndrName val + . unembed) + ) rest + , map (second ( embed + . substTm bndrName val + . unembed) + ) others + ) + +-- | Calculate the /local/ free variable of an expression: the free variables +-- that are not bound in the global environment. +localFreeIds :: (Applicative f, Lens.Contravariant f) + => RewriteMonad extra ((TmOccName -> f TmOccName) -> Term -> f Term) +localFreeIds = do + globalBndrs <- Lens.use bindings + return ((termFreeIds . Lens.filtered (not . (`HML.member` globalBndrs)))) + +inlineOrLiftBinders :: (LetBinding -> RewriteMonad extra Bool) -- ^ Property test + -> (Term -> LetBinding -> RewriteMonad extra Bool) + -- ^ Test whether to lift or inline + -- + -- * True: inline + -- * False: lift + -> Rewrite extra +inlineOrLiftBinders condition inlineOrLift ctx expr@(Letrec b) = do + (xesR,res) <- unbind b + let xes = unrec xesR + (replace,others) <- partitionM condition xes + case replace of + [] -> return expr + _ -> do + -- Because 'unbind b' refreshes binders in xes, we must recreate + -- the let expression, and _not_ reuse 'expr' + let expr' = Letrec (bind xesR res) + (doInline,doLift) <- partitionM (inlineOrLift expr') replace + -- We first substitute the binders that we can inline both the binders + -- that we intend to lift, the other binders, and the body + let (others',res') = substituteBinders doInline (doLift ++ others) res + (doLift',others'') = splitAt (length doLift) others' + (gamma,delta) <- mkEnv (LetBinding undefined (map fst xes) : ctx) + doLift'' <- mapM (liftBinding gamma delta) doLift' + -- We then substitute the lifted binders in the other binders and the body + let (others3,res'') = substituteBinders doLift'' others'' res' + newExpr = case others3 of + [] -> res'' + _ -> Letrec (bind (rec others3) res'') + changed newExpr + +inlineOrLiftBinders _ _ _ e = return e + +-- | Create a global function for a Let-binding and return a Let-binding where +-- the RHS is a reference to the new global function applied to the free +-- variables of the original RHS +liftBinding :: Gamma + -> Delta + -> LetBinding + -> RewriteMonad extra LetBinding +liftBinding gamma delta (Id idName tyE,eE) = do + let e = unembed eE + -- Get all local FVs, excluding the 'idName' from the let-binding + let localFTVs = map (\nm -> Name Internal nm noSrcSpan) + . List.nub $ Lens.toListOf termFreeTyVars e + localFVs <- map (\nm -> Name Internal nm noSrcSpan) . List.nub <$> + (Lens.toListOf <$> localFreeIds <*> pure e) + let localFTVkinds = map (\k -> HML.lookupDefault (error $ $(curLoc) ++ show k ++ " not found") (nameOcc k) delta) localFTVs + localFVs' = filter ((/= (nameOcc idName)) . nameOcc) localFVs + localFVtys' = map (\k -> HML.lookupDefault (error $ $(curLoc) ++ show k ++ " not found") (nameOcc k) gamma) localFVs' + -- Abstract expression over its local FVs + boundFTVs = zipWith mkTyVar localFTVkinds localFTVs + boundFVs = zipWith mkId localFVtys' localFVs' + -- Make a new global ID + tcm <- Lens.view tcCache + newBodyTy <- termType tcm $ mkTyLams (mkLams e boundFVs) boundFTVs + (cf,sp) <- Lens.use curFun + -- newBodyId <- fmap (makeName (name2String cf ++ "_" ++ name2String idName) . toInteger) getUniqueM + newBodyId <- cloneVar (appendToName cf ("_" ++ name2String idName)) + + -- Make a new expression, consisting of the the lifted function applied to + -- its free variables + let newExpr = mkTmApps + (mkTyApps (Var newBodyTy newBodyId) + (zipWith VarTy localFTVkinds localFTVs)) + (zipWith Var localFVtys' localFVs') + -- Substitute the recursive calls by the new expression + e' = substTm (nameOcc idName) newExpr e + -- Create a new body that abstracts over the free variables + newBody = mkTyLams (mkLams e' boundFVs) boundFTVs + + -- Check if an alpha-equivalent global binder already exists + aeqExisting <- (HMS.toList . HMS.filter ((== newBody) . (^. _5))) <$> Lens.use bindings + case aeqExisting of + -- If it doesn't, create a new binder + [] -> do -- Add the created function to the list of global bindings + bindings %= HMS.insert (nameOcc newBodyId) + -- We mark this function as internal so that + -- it can be inlined at the very end of + -- the normalisation pipeline as part of the + -- flattening pass. We don't inline + -- right away because we are lifting this + -- function at this moment for a reason! + -- (termination, CSE and DEC oppertunities, + -- ,etc.) + (newBodyId {nameSort = Internal} + ,newBodyTy,sp +#if MIN_VERSION_ghc(8,4,1) + ,NoUserInline +#else + ,EmptyInlineSpec +#endif + ,newBody) + -- Return the new binder + return (Id idName tyE, embed newExpr) + -- If it does, use the existing binder + ((_,(k,aeqTy,_,_,_)):_) -> + let newExpr' = mkTmApps + (mkTyApps (Var aeqTy k) + (zipWith VarTy localFTVkinds localFTVs)) + (zipWith Var localFVtys' localFVs') + in return (Id idName tyE, embed newExpr') + +liftBinding _ _ _ = error $ $(curLoc) ++ "liftBinding: invalid core, expr bound to tyvar" + +-- | Make a global function for a name-term tuple +mkFunction + :: TmName + -- ^ Name of the function + -> SrcSpan + -> InlineSpec + -> Term + -- ^ Term bound to the function + -> RewriteMonad extra (TmName,Type) + -- ^ Name with a proper unique and the type of the function +mkFunction bndr sp inl body = do + tcm <- Lens.view tcCache + bodyTy <- termType tcm body + bodyId <- cloneVar bndr + addGlobalBind bodyId bodyTy sp inl body + return (bodyId,bodyTy) + +-- | Add a function to the set of global binders +addGlobalBind + :: TmName + -> Type + -> SrcSpan + -> InlineSpec + -> Term + -> RewriteMonad extra () +addGlobalBind vId ty sp inl body = + (ty,body) `deepseq` bindings %= HMS.insert (nameOcc vId) (vId,ty,sp,inl,body) + +-- | Create a new name out of the given name, but with another unique +cloneVar + :: (Monad m, MonadUnique m) + => Name a + -> m (Name a) +cloneVar (Name sort nm loc) = do + i <- toInteger <$> getUniqueM + return (Name sort (Unbound.makeName (Unbound.name2String nm) i) loc) + +-- | Test whether a term is a variable reference to a local binder +isLocalVar :: Term + -> RewriteMonad extra Bool +isLocalVar (Var _ name) + = fmap (not . HML.member (nameOcc name)) + $ Lens.use bindings +isLocalVar _ = return False + +{-# INLINE isUntranslatable #-} +-- | Determine if a term cannot be represented in hardware +isUntranslatable + :: Bool + -- ^ String representable + -> Term + -> RewriteMonad extra Bool +isUntranslatable stringRepresentable tm = do + tcm <- Lens.view tcCache + not <$> (representableType <$> Lens.view typeTranslator + <*> Lens.view allowZero + <*> pure stringRepresentable + <*> pure tcm + <*> termType tcm tm) + +{-# INLINE isUntranslatableType #-} +-- | Determine if a type cannot be represented in hardware +isUntranslatableType + :: Bool + -- ^ String representable + -> Type + -> RewriteMonad extra Bool +isUntranslatableType stringRepresentable ty = + not <$> (representableType <$> Lens.view typeTranslator + <*> Lens.view allowZero + <*> pure stringRepresentable + <*> Lens.view tcCache + <*> pure ty) + +-- | Is the Context a Lambda/Term-abstraction context? +isLambdaBodyCtx :: CoreContext + -> Bool +isLambdaBodyCtx (LamBody _) = True +isLambdaBodyCtx _ = False + +-- | Make a binder that should not be referenced +mkWildValBinder :: (Monad m, MonadUnique m) + => Type + -> m Id +mkWildValBinder = fmap fst . mkInternalVar (string2InternalName "wild") + +-- | Make a case-decomposition that extracts a field out of a (Sum-of-)Product type +mkSelectorCase :: (Functor m, Monad m, MonadUnique m, Fresh m) + => String -- ^ Name of the caller of this function + -> HashMap TyConOccName TyCon -- ^ TyCon cache + -> Term -- ^ Subject of the case-composition + -> Int -- n'th DataCon + -> Int -- n'th field + -> m Term +mkSelectorCase caller tcm scrut dcI fieldI = do + scrutTy <- termType tcm scrut + go scrutTy + where + go (coreView tcm -> Just ty') = go ty' + go scrutTy@(tyView -> TyConApp tc args) = + case tyConDataCons (tcm HMS.! nameOcc tc) of + [] -> cantCreate $(curLoc) ("TyCon has no DataCons: " ++ show tc ++ " " ++ showDoc tc) scrutTy + dcs | dcI > length dcs -> cantCreate $(curLoc) "DC index exceeds max" scrutTy + | otherwise -> do + let dc = indexNote ($(curLoc) ++ "No DC with tag: " ++ show (dcI-1)) dcs (dcI-1) + let (Just fieldTys) = dataConInstArgTys dc args + if fieldI >= length fieldTys + then cantCreate $(curLoc) "Field index exceed max" scrutTy + else do + wildBndrs <- mapM mkWildValBinder fieldTys + let ty = indexNote ($(curLoc) ++ "No DC field#: " ++ show fieldI) fieldTys fieldI + selBndr <- mkInternalVar (string2InternalName "sel") ty + let bndrs = take fieldI wildBndrs ++ [fst selBndr] ++ drop (fieldI+1) wildBndrs + pat = DataPat (embed dc) (rebind [] bndrs) + retVal = Case scrut ty [ bind pat (snd selBndr) ] + return retVal + go scrutTy = cantCreate $(curLoc) ("Type of subject is not a datatype: " ++ showDoc scrutTy) scrutTy + + cantCreate loc info scrutTy = error $ loc ++ "Can't create selector " ++ show (caller,dcI,fieldI) ++ " for: (" ++ showDoc scrut ++ " :: " ++ showDoc scrutTy ++ ")\nAdditional info: " ++ info + +-- | Specialise an application on its argument +specialise :: Lens' extra (Map.Map (TmOccName, Int, Either Term Type) (TmName,Type)) -- ^ Lens into previous specialisations + -> Lens' extra (HashMap TmOccName Int) -- ^ Lens into the specialisation history + -> Lens' extra Int -- ^ Lens into the specialisation limit + -> Rewrite extra +specialise specMapLbl specHistLbl specLimitLbl ctx e = case e of + (TyApp e1 ty) -> specialise' specMapLbl specHistLbl specLimitLbl ctx e (collectArgs e1) (Right ty) + (App e1 e2) -> specialise' specMapLbl specHistLbl specLimitLbl ctx e (collectArgs e1) (Left e2) + _ -> return e + +-- | Specialise an application on its argument +specialise' :: Lens' extra (Map.Map (TmOccName, Int, Either Term Type) (TmName,Type)) -- ^ Lens into previous specialisations + -> Lens' extra (HashMap TmOccName Int) -- ^ Lens into specialisation history + -> Lens' extra Int -- ^ Lens into the specialisation limit + -> [CoreContext] -- Transformation context + -> Term -- ^ Original term + -> (Term, [Either Term Type]) -- ^ Function part of the term, split into root and applied arguments + -> Either Term Type -- ^ Argument to specialize on + -> RewriteMonad extra Term +specialise' specMapLbl specHistLbl specLimitLbl ctx e (Var _ f, args) specArgIn = do + lvl <- Lens.view dbgLevel + + -- Don't specialise TopEntities + topEnts <- Lens.view topEntities + if nameOcc f `HashSet.member` topEnts + then traceIf (lvl >= DebugNone) ("Not specialising TopEntity: " ++ showDoc f) (return e) + else do -- NondecreasingIndentation + + tcm <- Lens.view tcCache + + let specArg = bimap (normalizeTermTypes tcm) (normalizeType tcm) specArgIn + -- Create binders and variable references for free variables in 'specArg' + -- (specBndrsIn,specVars) :: ([Either Id TyVar], [Either Term Type]) + (specBndrsIn,specVars) <- specArgBndrsAndVars ctx specArg + let argLen = length args + specBndrs :: [Either Id TyVar] + specBndrs = map (Lens.over _Left (normalizeId tcm)) specBndrsIn + specAbs :: Either Term Type + specAbs = either (Left . (`mkAbstraction` specBndrs)) (Right . id) specArg + -- Determine if 'f' has already been specialized on (a type-normalized) 'specArg' + specM <- Map.lookup (nameOcc f,argLen,specAbs) <$> Lens.use (extra.specMapLbl) + case specM of + -- Use previously specialized function + Just (fname,fty) -> + traceIf (lvl >= DebugApplied) ("Using previous specialization of " ++ showDoc (nameOcc f) ++ " on " ++ (either showDoc showDoc) specAbs ++ ": " ++ showDoc fname) $ + changed $ mkApps (Var fty fname) (args ++ specVars) + -- Create new specialized function + Nothing -> do + -- Determine if we can specialize f + bodyMaybe <- fmap (HML.lookup (nameOcc f)) $ Lens.use bindings + case bodyMaybe of + Just (_,_,sp,inl,bodyTm) -> do + -- Determine if we see a sequence of specialisations on a growing argument + specHistM <- HML.lookup (nameOcc f) <$> Lens.use (extra.specHistLbl) + specLim <- Lens.use (extra . specLimitLbl) + if maybe False (> specLim) specHistM + then throw (ClashException + sp + (unlines [ "Hit specialisation limit " ++ show specLim ++ " on function `" ++ showDoc (nameOcc f) ++ "'.\n" + , "The function `" ++ showDoc f ++ "' is most likely recursive, and looks like it is being indefinitely specialized on a growing argument.\n" + , "Body of `" ++ showDoc f ++ "':\n" ++ showDoc bodyTm ++ "\n" + , "Argument (in position: " ++ show argLen ++ ") that triggered termination:\n" ++ (either showDoc showDoc) specArg + , "Run with '-fclash-spec-limit=N' to increase the specialisation limit to N." + ]) + Nothing) + else do + -- Make new binders for existing arguments + (boundArgs,argVars) <- fmap (unzip . map (either (Left *** Left) (Right *** Right))) $ + Monad.zipWithM + (mkBinderFor tcm) + (unsafeCollectBndrs bodyTm ++ repeat (string2InternalName "pTS")) + args + -- Determine name the resulting specialised function, and the + -- form of the specialised-on argument + (fName,inl',specArg') <- case specArg of + Left a@(collectArgs -> (Var _ g,gArgs)) -> do + polyFun <- isPolyFun tcm a + if polyFun + then do + -- In case we are specialising on an argument that is a + -- global function then we use that function's name as the + -- name of the specialised higher-order function. + -- Additionally, we will return the body of the global + -- function, instead of a variable reference to the + -- global function. + -- + -- This will turn things like @mealy g k@ into a new + -- binding @g'@ where both the body of @mealy@ and @g@ + -- are inlined, meaning the state-transition-function + -- and the memory element will be in a single function. + gTmM <- fmap (HML.lookup (nameOcc g)) $ Lens.use bindings + return (g,maybe inl (^. _4) gTmM, maybe specArg (Left . (`mkApps` gArgs) . (^. _5)) gTmM) + else return (f,inl,specArg) + _ -> return (f,inl,specArg) + -- Create specialized functions + let newBody = mkAbstraction (mkApps bodyTm (argVars ++ [specArg'])) (boundArgs ++ specBndrs) + newf <- mkFunction fName sp inl' newBody + -- Remember specialization + (extra.specHistLbl) %= HML.insertWith (+) (nameOcc f) 1 + (extra.specMapLbl) %= Map.insert (nameOcc f,argLen,specAbs) newf + -- use specialized function + let newExpr = mkApps ((uncurry . flip) Var newf) (args ++ specVars) + newf `deepseq` changed newExpr + Nothing -> return e + where + unsafeCollectBndrs :: Term -> [Name a] + unsafeCollectBndrs = + map (either (coerceName . varName) (coerceName . varName)) . reverse . go [] + where + go bs (Lam b) = let (v,e') = unsafeUnbind b in go (Left v:bs) e' + go bs (TyLam b) = let (tv,e') = unsafeUnbind b in go (Right tv:bs) e' + go bs (App e' _) = case go [] e' of + [] -> bs + bs' -> init bs' ++ bs + go bs (TyApp e' _) = case go [] e' of + [] -> bs + bs' -> init bs' ++ bs + go bs _ = bs + +specialise' _ _ _ ctx _ (appE,args) (Left specArg) = do + -- Create binders and variable references for free variables in 'specArg' + (specBndrs,specVars) <- specArgBndrsAndVars ctx (Left specArg) + -- Create specialized function + let newBody = mkAbstraction specArg specBndrs + -- See if there's an existing binder that's alpha-equivalent to the + -- specialised function + existing <- HML.filter ((== newBody) . (^. _5)) <$> Lens.use bindings + -- Create a new function if an alpha-equivalent binder doesn't exist + newf <- case HML.toList existing of + [] -> do (cf,sp) <- Lens.use curFun + mkFunction (appendToName cf "_specF") + sp +#if MIN_VERSION_ghc(8,4,1) + NoUserInline +#else + EmptyInlineSpec +#endif + newBody + ((_,(k,kTy,_,_,_)):_) -> return (k,kTy) + -- Create specialized argument + let newArg = Left $ mkApps ((uncurry . flip) Var newf) specVars + -- Use specialized argument + let newExpr = mkApps appE (args ++ [newArg]) + changed newExpr + +specialise' _ _ _ _ e _ _ = return e + +normalizeTermTypes :: HashMap TyConOccName TyCon -> Term -> Term +normalizeTermTypes tcm e = case e of + Cast e' ty1 ty2 -> Cast (normalizeTermTypes tcm e') (normalizeType tcm ty1) (normalizeType tcm ty2) + Var ty nm -> Var (normalizeType tcm ty) nm + -- TODO other terms? + _ -> e + +normalizeId :: HashMap TyConOccName TyCon -> Id -> Id +normalizeId tcm (Id nm (Unbound.Embed ty)) = Id nm (Unbound.Embed $ normalizeType tcm ty) +normalizeId _ tyvar = tyvar + + +-- | Create binders and variable references for free variables in 'specArg' +specArgBndrsAndVars :: [CoreContext] + -> Either Term Type + -> RewriteMonad extra ([Either Id TyVar],[Either Term Type]) +specArgBndrsAndVars ctx specArg = do + let specFTVs = List.nub $ either (Lens.toListOf termFreeTyVars) (Lens.toListOf typeFreeVars) specArg + specFVs <- List.nub <$> either ((Lens.toListOf <$> localFreeIds <*>) . pure) (const (pure [])) specArg + (gamma,delta) <- mkEnv ctx + let (specTyBndrs,specTyVars) = unzip + $ map (\tv -> let ki = HML.lookupDefault (error $ $(curLoc) ++ show tv ++ " not found") tv delta + tv' = Name Internal tv noSrcSpan + in (Right $ TyVar tv' (embed ki), Right $ VarTy ki tv')) specFTVs + (specTmBndrs,specTmVars) = unzip + $ map (\tm -> let ty = HML.lookupDefault (error $ $(curLoc) ++ show tm ++ " not found") tm gamma + tm' = Name Internal tm noSrcSpan + in (Left $ Id tm' (embed ty), Left $ Var ty tm')) specFVs + return (specTyBndrs ++ specTmBndrs,specTyVars ++ specTmVars) diff --git a/src/Clash/Util.hs b/src/Clash/Util.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Util.hs @@ -0,0 +1,243 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Assortment of utility function used in the Clash library +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TupleSections #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Clash.Util + ( module Clash.Util + , module X + , makeLenses + ) +where + +import Control.Applicative as X (Applicative,(<$>),(<*>),pure) +import Control.Arrow as X ((***),first,second) +import Control.DeepSeq +import Control.Monad as X ((<=<),(>=>)) +import Control.Monad.State (MonadState,State,StateT,runState) +import qualified Control.Monad.State as State +import Control.Monad.Trans.Class (MonadTrans,lift) +import Data.Function as X (on) +import Data.Hashable (Hashable) +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Lazy as HashMapL +import qualified Data.HashMap.Strict as HashMapS +import Data.Maybe (fromMaybe) +import Data.Version (Version) +import Control.Lens +import Debug.Trace (trace) +import GHC.Base (Int(..),isTrue#,(==#),(+#)) +import GHC.Integer.Logarithms (integerLogBase#) +import qualified Language.Haskell.TH as TH + +#ifdef CABAL +import qualified Paths_clash_lib (version) +#endif + +-- | A class that can generate unique numbers +class MonadUnique m where + -- | Get a new unique + getUniqueM :: m Int + +instance Monad m => MonadUnique (StateT Int m) where + getUniqueM = do + supply <- State.get + State.modify (+1) + return supply + +-- | Create a TH expression that returns the a formatted string containing the +-- name of the module 'curLoc' is spliced into, and the line where it was spliced. +curLoc :: TH.Q TH.Exp +curLoc = do + (TH.Loc _ _ modName (startPosL,_) _) <- TH.location + TH.litE (TH.StringL $ modName ++ "(" ++ show startPosL ++ "): ") + +-- | Cache the result of a monadic action +makeCached :: (MonadState s m, Hashable k, Eq k) + => k -- ^ The key the action is associated with + -> Lens' s (HashMap k v) -- ^ The Lens to the HashMap that is the cache + -> m v -- ^ The action to cache + -> m v +makeCached key l create = do + cache <- use l + case HashMapL.lookup key cache of + Just value -> return value + Nothing -> do + value <- create + l %= HashMapL.insert key value + return value + +-- | Cache the result of a monadic action in a State 3 transformer layers down +makeCachedT3 :: ( MonadTrans t2, MonadTrans t1, MonadTrans t + , Eq k, Hashable k + , MonadState s m + , Monad (t2 m), Monad (t1 (t2 m)), Monad (t (t1 (t2 m)))) + => k -- ^ The key the action is associated with + -> Lens' s (HashMap k v) -- ^ The Lens to the HashMap that is the cache + -> (t (t1 (t2 m))) v -- ^ The action to cache + -> (t (t1 (t2 m))) v +makeCachedT3 key l create = do + cache <- (lift . lift . lift) $ use l + case HashMapL.lookup key cache of + Just value -> return value + Nothing -> do + value <- create + (lift . lift . lift) $ l %= HashMapL.insert key value + return value + +-- | Spine-strict cache variant of 'mkCachedT3' +makeCachedT3S :: ( MonadTrans t2, MonadTrans t1, MonadTrans t + , Eq k, Hashable k + , MonadState s m + , Monad (t2 m), Monad (t1 (t2 m)), Monad (t (t1 (t2 m))) + , NFData v) + => k + -> Lens' s (HashMap k v) + -> (t (t1 (t2 m))) v + -> (t (t1 (t2 m))) v +makeCachedT3S key l create = do + cache <- (lift . lift . lift) $ use l + case HashMapS.lookup key cache of + Just value -> return value + Nothing -> do + value <- create + value `deepseq` ((lift . lift . lift) $ l %= HashMapS.insert key value) + return value + +-- | Run a State-action using the State that is stored in a higher-layer Monad +liftState :: (MonadState s m) + => Lens' s s' -- ^ Lens to the State in the higher-layer monad + -> State s' a -- ^ The State-action to perform + -> m a +liftState l m = do + s <- use l + let (a,s') = runState m s + l .= s' + return a + +-- | Functorial version of 'Control.Arrow.first' +firstM :: Functor f + => (a -> f c) + -> (a, b) + -> f (c, b) +firstM f (x,y) = (,y) <$> f x + +-- | Functorial version of 'Control.Arrow.second' +secondM :: Functor f + => (b -> f c) + -> (a, b) + -> f (a, c) +secondM f (x,y) = (x,) <$> f y + +combineM :: (Applicative f) + => (a -> f b) + -> (c -> f d) + -> (a,c) + -> f (b,d) +combineM f g (x,y) = (,) <$> f x <*> g y + +-- | Performs trace when first argument evaluates to 'True' +traceIf :: Bool -> String -> a -> a +traceIf True msg = trace msg +traceIf False _ = id + +-- | Monadic version of 'Data.List.partition' +partitionM :: Monad m + => (a -> m Bool) + -> [a] + -> m ([a], [a]) +partitionM _ [] = return ([], []) +partitionM p (x:xs) = do + test <- p x + (ys, ys') <- partitionM p xs + return $ if test then (x:ys, ys') else (ys, x:ys') + +-- | Monadic version of 'Data.List.mapAccumL' +mapAccumLM :: (Monad m) + => (acc -> x -> m (acc,y)) + -> acc + -> [x] + -> m (acc,[y]) +mapAccumLM _ acc [] = return (acc,[]) +mapAccumLM f acc (x:xs) = do + (acc',y) <- f acc x + (acc'',ys) <- mapAccumLM f acc' xs + return (acc'',y:ys) + +-- | Composition of a unary function with a binary function +dot :: (c -> d) -> (a -> b -> c) -> a -> b -> d +dot = (.) . (.) + +-- | if-then-else as a function on an argument +ifThenElse :: (a -> Bool) + -> (a -> b) + -> (a -> b) + -> a + -> b +ifThenElse t f g a = if t a then f a else g a + +infixr 5 <:> +-- | Applicative version of 'GHC.Types.(:)' +(<:>) :: Applicative f + => f a + -> f [a] + -> f [a] +x <:> xs = (:) <$> x <*> xs + +-- | Safe indexing, returns a 'Nothing' if the index does not exist +indexMaybe :: [a] + -> Int + -> Maybe a +indexMaybe [] _ = Nothing +indexMaybe (x:_) 0 = Just x +indexMaybe (_:xs) n = indexMaybe xs (n-1) + +-- | Unsafe indexing, return a custom error message when indexing fails +indexNote :: String + -> [a] + -> Int + -> a +indexNote note = fromMaybe (error note) `dot` indexMaybe + +-- | Split the second list at the length of the first list +splitAtList :: [b] -> [a] -> ([a], [a]) +splitAtList [] xs = ([], xs) +splitAtList _ xs@[] = (xs, xs) +splitAtList (_:xs) (y:ys) = (y:ys', ys'') + where + (ys', ys'') = splitAtList xs ys + +clashLibVersion :: Version +#ifdef CABAL +clashLibVersion = Paths_clash_lib.version +#else +clashLibVersion = error "development version" +#endif + +-- | \x y -> floor (logBase x y), x > 1 && y > 0 +flogBase :: Integer -> Integer -> Maybe Int +flogBase x y | x > 1 && y > 0 = Just (I# (integerLogBase# x y)) +flogBase _ _ = Nothing + +-- | \x y -> ceiling (logBase x y), x > 1 && y > 0 +clogBase :: Integer -> Integer -> Maybe Int +clogBase x y | x > 1 && y > 0 = + case y of + 1 -> Just 0 + _ -> let z1 = integerLogBase# x y + z2 = integerLogBase# x (y-1) + in if isTrue# (z1 ==# z2) + then Just (I# (z1 +# 1#)) + else Just (I# z1) +clogBase _ _ = Nothing diff --git a/src/Data/Aeson/Extra.hs b/src/Data/Aeson/Extra.hs --- a/src/Data/Aeson/Extra.hs +++ b/src/Data/Aeson/Extra.hs @@ -6,19 +6,56 @@ module Data.Aeson.Extra where -import Data.Aeson (FromJSON, Result (..), fromJSON, json) -import Data.Attoparsec.Lazy (Result (..), parse) -import Data.ByteString.Lazy (ByteString) -import CLaSH.Util (traceIf) +import qualified Data.Ix as Ix +import qualified Data.Text as T +import Data.Text (Text,pack,unpack) +import Data.List (intercalate) +import Data.Aeson (FromJSON, Result (..), fromJSON, json) +import Data.Attoparsec.Lazy (Result (..), parse) +import Data.ByteString.Lazy (ByteString) +import System.FilePath () +-- Quick and dirty way of replacing fake escapes in naively converted bytestring +replaceCommonEscapes :: Text -> Text +replaceCommonEscapes = ( T.replace (pack "\\n") (pack "\n") ) . + ( T.replace (pack "\\\\") (pack "\\") ) . + ( T.replace (pack "\\\"") (pack "\"") ) + +genLineErr' :: [Text] -> (Int, Int) -> Int -> Text +genLineErr' allLines range errorLineN = T.unlines [ T.concat [ if i == errorLineN then pack ">> " else pack " " + , pack $ show i + , pack ". " + , allLines !! i + ] | i <- Ix.range range] + +-- | Pretty print part of json file related to error +genLineErr :: ByteString -> ByteString -> Text +genLineErr full part = genLineErr' allLines interval errorLineN + where + -- Determine interval, and pass to helper function + nLastLines = 1 + (length $ T.lines $ replaceCommonEscapes $ pack $ show part) + errorLineN = length allLines - nLastLines + 1 + allLines = T.lines $ replaceCommonEscapes $ pack $ show full + interval = (max 0 (errorLineN - 5), min (max 0 $ length allLines - 1) (errorLineN + 5)) + -- | Parse a ByteString according to the given JSON template. Prints failures -- on @stdout@, and returns 'Nothing' if parsing fails. -decodeAndReport :: (FromJSON a) - => ByteString -- ^ Bytestring to parse +decodeOrErr :: (FromJSON a) + => FilePath + -> ByteString -- ^ Bytestring to parse -> Maybe a -decodeAndReport s = - case parse json s of +decodeOrErr path contents = + case parse json contents of Done _ v -> case fromJSON v of Success a -> Just a - Error msg -> traceIf True msg Nothing - Fail _ _ msg -> traceIf True msg Nothing + Error msg -> error ("Could not deduce valid scheme for '" ++ show path ++ "'. Error was: \n\n" ++ msg) + + -- JSON parse error: + Fail bytes cntxs msg -> error ( "Could not read or parse " ++ show path ++ ". " + ++ (if null cntxs then "" else "Context was:\n " ++ intercalate "\n " cntxs) + ++ "\n\nError reported by Attoparsec was:\n " + ++ msg + ++ "\n\nApproximate location of error:\n\n" + -- HACK: Replace with proper parser/fail logic in future. Or don't. It's not important. + ++ (unpack $ genLineErr contents bytes) + ) diff --git a/src/Data/Semigroup/Monad/Extra.hs b/src/Data/Semigroup/Monad/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semigroup/Monad/Extra.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Data.Semigroup.Monad.Extra + (module Data.Semigroup.Monad + ) +where + +import Control.Monad.Fix +import Data.Semigroup.Monad + +instance MonadFix f => MonadFix (Mon f) where + mfix f = Mon (mfix (getMon . f)) + diff --git a/src/Data/Text/Prettyprint/Doc/Extra.hs b/src/Data/Text/Prettyprint/Doc/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Prettyprint/Doc/Extra.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Data.Text.Prettyprint.Doc.Extra + ( module Data.Text.Prettyprint.Doc.Extra + , LayoutOptions (..) + , PageWidth (..) + , layoutCompact + , layoutPretty + , renderLazy + ) +where + +import Control.Applicative +import Data.String (IsString (..)) +import Data.Text.Lazy as T +import qualified Data.Text.Prettyprint.Doc as PP +import Data.Text.Prettyprint.Doc.Internal hiding (Doc) +import Data.Text.Prettyprint.Doc.Render.Text + +type Doc = PP.Doc () + +layoutOneLine + :: PP.Doc ann + -> SimpleDocStream ann +layoutOneLine doc = scan 0 [doc] + where + scan _ [] = SEmpty + scan !col (d:ds) = case d of + Fail -> SFail + Empty -> scan col ds + Char c -> SChar c (scan (col+1) ds) + Text l t -> let !col' = col+l in SText l t (scan col' ds) + FlatAlt x _ -> scan col (x:ds) + Line -> scan col ds + Cat x y -> scan col (x:y:ds) + Nest _ x -> scan col (x:ds) + Union _ y -> scan col (y:ds) + Column f -> scan col (f col:ds) + WithPageWidth f -> scan col (f Unbounded : ds) + Nesting f -> scan col (f 0 : ds) + Annotated _ x -> scan col (x:ds) + +renderOneLine + :: PP.Doc ann + -> Text +renderOneLine = renderLazy . layoutOneLine + +int :: Applicative f => Int -> f Doc +int = pure . PP.pretty + +integer :: Applicative f => Integer -> f Doc +integer = pure . PP.pretty + +char :: Applicative f => Char -> f Doc +char = pure . PP.pretty + +lbrace :: Applicative f => f Doc +lbrace = pure PP.lbrace + +rbrace :: Applicative f => f Doc +rbrace = pure PP.rbrace + +colon :: Applicative f => f Doc +colon = pure PP.colon + +semi :: Applicative f => f Doc +semi = pure PP.semi + +equals :: Applicative f => f Doc +equals = pure PP.equals + +comma :: Applicative f => f Doc +comma = pure PP.comma + +dot :: Applicative f => f Doc +dot = pure PP.dot + +lparen :: Applicative f => f Doc +lparen = pure PP.lparen + +rparen :: Applicative f => f Doc +rparen = pure PP.rparen + +space :: Applicative f => f Doc +space = pure PP.space + +brackets :: Functor f => f Doc -> f Doc +brackets = fmap PP.brackets + +braces :: Functor f => f Doc -> f Doc +braces = fmap PP.braces + +tupled :: Functor f => f [Doc] -> f Doc +tupled = fmap PP.tupled + +(<+>) :: Applicative f => f Doc -> f Doc -> f Doc +(<+>) = liftA2 (PP.<+>) +infixr 6 <+> + +vcat :: Functor f => f [Doc] -> f Doc +vcat = fmap PP.vcat + +hcat :: Functor f => f [Doc] -> f Doc +hcat = fmap PP.hcat + +nest :: Functor f => Int -> f Doc -> f Doc +nest i = fmap (PP.nest i) + +indent :: Functor f => Int -> f Doc -> f Doc +indent i = fmap (PP.indent i) + +parens :: Functor f => f Doc -> f Doc +parens = fmap PP.parens + +emptyDoc :: Applicative f => f Doc +emptyDoc = pure PP.emptyDoc + +punctuate :: Applicative f => f Doc -> f [Doc] -> f [Doc] +punctuate = liftA2 PP.punctuate + +encloseSep :: Applicative f => f Doc -> f Doc -> f Doc -> f [Doc] -> f Doc +encloseSep l r s is = PP.encloseSep <$> l <*> r <*> s <*> is + +line :: Applicative f => f Doc +line = pure PP.line + +line' :: Applicative f => f Doc +line' = pure PP.line' + +softline :: Applicative f => f Doc +softline = pure PP.softline + +softline' :: Applicative f => f Doc +softline' = pure PP.softline' + +pretty :: (Applicative f, Pretty a) => a -> f Doc +pretty = pure . PP.pretty + +string :: Applicative f => Text -> f Doc +string = pure . PP.pretty + +squotes :: Applicative f => f Doc -> f Doc +squotes = fmap PP.squotes + +dquotes :: Functor f => f Doc -> f Doc +dquotes = fmap PP.dquotes + +align :: Functor f => f Doc -> f Doc +align = fmap PP.align + +vsep :: Functor f => f [Doc] -> f Doc +vsep = fmap PP.vsep + +isEmpty :: Doc -> Bool +isEmpty Empty = True +isEmpty _ = False + +fill :: Applicative f => Int -> f Doc -> f Doc +fill = fmap . PP.fill + +column :: Functor f => f (Int -> Doc) -> f Doc +column = fmap PP.column + +nesting :: Functor f => f (Int -> Doc) -> f Doc +nesting = fmap PP.nesting + +instance Applicative f => IsString (f Doc) where + fromString = string . fromString diff --git a/src/GHC/BasicTypes/Extra.hs b/src/GHC/BasicTypes/Extra.hs new file mode 100644 --- /dev/null +++ b/src/GHC/BasicTypes/Extra.hs @@ -0,0 +1,19 @@ +{-| + Copyright : (C) 2017, Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij +-} + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module GHC.BasicTypes.Extra where + +import BasicTypes +import Control.DeepSeq +import GHC.Generics + +deriving instance Generic InlineSpec +instance NFData InlineSpec diff --git a/src/GHC/Extra.hs b/src/GHC/Extra.hs deleted file mode 100644 --- a/src/GHC/Extra.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-| - Copyright : (C) 2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij --} - -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module GHC.Extra where - -#if !(MIN_VERSION_GLASGOW_HASKELL(8,0,1,20161117)) -import Control.DeepSeq -import SrcLoc (SrcSpan) - -instance NFData SrcSpan where - rnf x = x `seq` () -#endif diff --git a/src/GHC/SrcLoc/Extra.hs b/src/GHC/SrcLoc/Extra.hs new file mode 100644 --- /dev/null +++ b/src/GHC/SrcLoc/Extra.hs @@ -0,0 +1,37 @@ +{-| + Copyright : (C) 2017, Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij +-} + +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module GHC.SrcLoc.Extra where + +import Data.Hashable (Hashable (..)) +import GHC.Generics +import SrcLoc + (SrcSpan (..), RealSrcSpan, srcSpanFile, srcSpanStartLine, srcSpanEndLine, + srcSpanStartCol, srcSpanEndCol) +import FastString (FastString (..)) +import Unbound.Generics.LocallyNameless (Alpha (..)) +import Unbound.Generics.LocallyNameless.TH + +deriving instance Generic SrcSpan +instance Hashable SrcSpan + +makeClosedAlpha ''SrcSpan + +instance Hashable RealSrcSpan where + hashWithSalt salt rss = + hashWithSalt salt (srcSpanFile rss,srcSpanStartLine rss, srcSpanEndLine rss + ,srcSpanStartCol rss, srcSpanEndCol rss) + +instance Hashable FastString where + hashWithSalt salt fs = hashWithSalt salt (uniq fs) + diff --git a/src/Unbound/Generics/LocallyNameless/Extra.hs b/src/Unbound/Generics/LocallyNameless/Extra.hs --- a/src/Unbound/Generics/LocallyNameless/Extra.hs +++ b/src/Unbound/Generics/LocallyNameless/Extra.hs @@ -1,5 +1,6 @@ {-| - Copyright : (C) 2015-2016, University of Twente + Copyright : (C) 2015-2016, University of Twente, + 2017, Google Inc. License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij -} @@ -31,15 +32,14 @@ #else import Unbound.Generics.LocallyNameless.Alpha (Alpha (..)) #endif -#if !MIN_VERSION_unbound_generics(0,2,0) import Unbound.Generics.LocallyNameless.Bind (Bind (..)) import Unbound.Generics.LocallyNameless.Embed (Embed (..)) -#endif import Unbound.Generics.LocallyNameless.Name (Name (..)) #if !MIN_VERSION_unbound_generics(0,2,0) -import Unbound.Generics.LocallyNameless.Rebind (Rebind (..)) -import Unbound.Generics.LocallyNameless.Rec (Rec,unrec) +import Unbound.Generics.LocallyNameless.Rec (unrec) #endif +import Unbound.Generics.LocallyNameless.Rebind (Rebind (..)) +import Unbound.Generics.LocallyNameless.Rec (Rec) import Unbound.Generics.LocallyNameless.Subst (Subst (..)) #if !MIN_VERSION_unbound_generics(0,2,0) @@ -58,6 +58,11 @@ instance Hashable (Name a) where hashWithSalt salt (Fn str int) = hashWithSalt salt (hashWithSalt (hash int) str) hashWithSalt salt (Bn i0 i1) = hashWithSalt salt (hash i0 `hashWithSalt` i1) + +instance (Hashable a, Hashable b) => Hashable (Bind a b) +instance Hashable a => Hashable (Embed a) +instance (Hashable a, Hashable b) => Hashable (Rebind a b) +instance Hashable a => Hashable (Rec a) #if !MIN_VERSION_unbound_generics(0,2,0) instance (Ord a) => Ord (Embed a) where