packages feed

clash-lib 0.7.1 → 0.99

raw patch · 202 files changed

+28633/−9680 lines, 202 filesdep +ansi-wl-pprintdep +parsersdep +prettyprinterdep −prettydep −uu-parsinglibdep −wl-pprint-textdep ~clash-preludedep ~fgldep ~ghc

Dependencies added: ansi-wl-pprint, parsers, prettyprinter, reducers, trifecta

Dependencies removed: pretty, uu-parsinglib, wl-pprint-text

Dependency ranges changed: clash-prelude, fgl, ghc, lens, process, template-haskell, time

Files

CHANGELOG.md view
@@ -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)
LICENSE view
@@ -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
clash-lib.cabal view
@@ -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 <christiaan.baaij@gmail.com>-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
+ prims/common/Clash_Class_BitPack.json view
@@ -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]"+    }+  }+]
+ prims/common/Clash_Explicit_Signal.json view
@@ -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]"+    }+  }+]
+ prims/common/Clash_GHC_GHC2Core.json view
@@ -0,0 +1,16 @@+[ { "BlackBox" :+    { "name"      : "EmptyCase"+    , "templateE" : "~ERRORO"+    }+  }+, { "Primitive" :+    { "name"     : "_CO_"+    , "primType" : "Constructor"+    }+  }+, { "Primitive" :+    { "name"     : "_TY_"+    , "primType" : "Constructor"+    }+  }+]
+ prims/common/Clash_Promoted_Nat_Unsafe.json view
@@ -0,0 +1,7 @@+[ { "BlackBox" :+    { "name"      : "Clash.Promoted.Nat.Unsafe.unsafeSNat"+    , "type"      : "Clash.Promoted.Nat.Unsafe.unsafeSNat :: Integer -> SNat k"+    , "templateE" : "~LIT[0]"+    }+  }+]
+ prims/common/Clash_Promoted_Symbol.json view
@@ -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]"+    }+  }+]
+ prims/common/Clash_Signal_Bundle.json view
@@ -0,0 +1,6 @@+[ { "Primitive" :+    { "name"      : "Clash.Signal.Bundle.vecBundle#"+    , "primType"  : "Function"+    }+  }+]
+ prims/common/Clash_Transformations.json view
@@ -0,0 +1,7 @@+[ { "BlackBox" :+    { "name"      : "Clash.Transformations.removedArg"+    , "type"      : "removedArg :: a"+    , "templateE" : "~ERRORO"+    }+  }+]
+ prims/common/Clash_XException.json view
@@ -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"+    }+  }+]
+ prims/common/Control_Exception_Base.json view
@@ -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"+    }+  }+]
+ prims/common/Debug_Trace.json view
@@ -0,0 +1,7 @@+[ { "BlackBox" :+    { "name"      : "Debug.Trace.trace"+    , "type"      : "trace :: String -> a -> a"+    , "templateE" : "~ARG[1]"+    }+  }+]
+ prims/common/GHC_CString.json view
@@ -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"+    }+  }+]
+ prims/common/GHC_Err.json view
@@ -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"+    }+  }+]
+ prims/common/GHC_IO_Exception.json view
@@ -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]"+    }+  }+]
+ prims/common/GHC_Magic.json view
@@ -0,0 +1,11 @@+[ { "Primitive" :+    { "name"      : "GHC.Magic.lazy"+    , "primType"  : "Function"+    }+  }+, { "Primitive" :+    { "name"      : "GHC.Magic.runRW#"+    , "primType"  : "Function"+    }+  }+]
+ prims/common/GHC_Natural.json view
@@ -0,0 +1,12 @@+[ { "Primitive" :+    { "name"      : "GHC.Natural.NatS#"+    , "primType"  : "Constructor"+    }+  }+, { "BlackBox" :+    { "name"      : "GHC.Natural.underflowError"+    , "type"      : "underflowError :: a"+    , "templateE" : "~ERRORO"+    }+  }+]
+ prims/common/GHC_Real.json view
@@ -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"+    }+  }+]
+ prims/common/GHC_TypeNats.json view
@@ -0,0 +1,7 @@+[ { "BlackBox" :+    { "name"      : "GHC.TypeNats.natVal"+    , "type"      : "natVal :: forall n proxy. KnownNat n => proxy n -> Natural"+    , "templateE" : "~ARG[0]"+    }+  }+]
+ prims/common/GHC_Typelits.json view
@@ -0,0 +1,7 @@+[ { "BlackBox" :+    { "name"      : "GHC.TypeLits.natVal"+    , "type"      : "natVal :: forall n proxy. KnownNat n => proxy n -> Integer"+    , "templateE" : "~ARG[0]"+    }+  }+]
+ prims/common/Unsafe_Coerce.json view
@@ -0,0 +1,7 @@+[ { "BlackBox" :+    { "name"      : "Unsafe.Coerce.unsafeCoerce"+    , "type"      : "unsafeCoerce :: a -> b"+    , "templateE" : "~ARG[0]"+    }+  }+]
+ prims/commonverilog/Clash_Promoted_Nat.json view
@@ -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])"+    }+  }+]
+ prims/commonverilog/Clash_Sized_Internal_BitVector.json view
@@ -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;"+    }+  }+]
+ prims/commonverilog/Clash_Sized_Internal_Index.json view
@@ -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]);"+    }+  }+]
+ prims/commonverilog/Clash_Sized_Internal_Signed.json view
@@ -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;"+    }+  }+]
+ prims/commonverilog/Clash_Sized_Internal_Unsigned.json view
@@ -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;"+    }+  }+]
+ prims/commonverilog/GHC_Integer_Logarithms.json view
@@ -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])"+    }+  }+]
+ prims/systemverilog/Clash_Explicit_BlockRam.json view
@@ -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"+    }+  }+]
+ prims/systemverilog/Clash_Explicit_BlockRam_File.json view
@@ -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"+    }+  }+]
+ prims/systemverilog/Clash_Explicit_DDR.json view
@@ -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"+    }+  }+]
+ prims/systemverilog/Clash_Explicit_RAM.json view
@@ -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"+    }+  }+]
+ prims/systemverilog/Clash_Explicit_ROM.json view
@@ -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"+    }+  }+]
+ prims/systemverilog/Clash_Explicit_ROM_File.json view
@@ -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"+    }+  }+]
+ prims/systemverilog/Clash_Explicit_Testbench.json view
@@ -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"+    }+  }+]
+ prims/systemverilog/Clash_Intel_ClockGen.json view
@@ -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"+    }+  }+]
+ prims/systemverilog/Clash_Intel_DDR.json view
@@ -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"+    }+  }+]
+ prims/systemverilog/Clash_Prelude_ROM.json view
@@ -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"+    }+  }+]
+ prims/systemverilog/Clash_Prelude_ROM_File.json view
@@ -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"+    }+  }+]
+ prims/systemverilog/Clash_Signal_Internal.json view
@@ -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"+    }+  }+]
+ prims/systemverilog/Clash_Sized_Internal_BitVector.json view
@@ -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]);"+    }+  }+]
+ prims/systemverilog/Clash_Sized_Internal_Signed.json view
@@ -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]);"+    }+  }+]
+ prims/systemverilog/Clash_Sized_Internal_Unsigned.json view
@@ -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]);"+    }+  }+]
+ prims/systemverilog/Clash_Sized_RTree.json view
@@ -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]]"+    }+  }+]
+ prims/systemverilog/Clash_Sized_Vector.json view
@@ -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"+    }+  }+]
+ prims/systemverilog/Clash_Xilinx_ClockGen.json view
@@ -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"+    }+  }+]
+ prims/systemverilog/Clash_Xilinx_DDR.json view
@@ -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"+    }+  }+]
+ prims/systemverilog/GHC_Base.json view
@@ -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"+    }+  }+]
+ prims/systemverilog/GHC_Classes.json view
@@ -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"+    }+  }+]
+ prims/systemverilog/GHC_Int.json view
@@ -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]);"+    }+  }+]
+ prims/systemverilog/GHC_Integer_Type.json view
@@ -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]);"+    }+  }+]
+ prims/systemverilog/GHC_Prim.json view
@@ -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]"+    }+  }+]
+ prims/systemverilog/GHC_Types.json view
@@ -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]"+    }+  }+]
+ prims/systemverilog/GHC_Word.json view
@@ -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]);"+    }+  }+]
+ prims/verilog/Clash_Explicit_BlockRam.json view
@@ -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"+    }+  }+]
+ prims/verilog/Clash_Explicit_BlockRam_File.json view
@@ -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"+    }+  }+]
+ prims/verilog/Clash_Explicit_DDR.json view
@@ -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"+    }+  }+]
+ prims/verilog/Clash_Explicit_RAM.json view
@@ -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"+    }+  }+]
+ prims/verilog/Clash_Explicit_ROM.json view
@@ -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"+    }+  }+]
+ prims/verilog/Clash_Explicit_ROM_File.json view
@@ -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"+    }+  }+]
+ prims/verilog/Clash_Explicit_Testbench.json view
@@ -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"+    }+  }+]
+ prims/verilog/Clash_Intel_ClockGen.json view
@@ -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"+    }+  }+]
+ prims/verilog/Clash_Intel_DDR.json view
@@ -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"+    }+  }+]
+ prims/verilog/Clash_Prelude_ROM.json view
@@ -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"+    }+  }+]
+ prims/verilog/Clash_Prelude_ROM_File.json view
@@ -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"+    }+  }+]
+ prims/verilog/Clash_Signal_Internal.json view
@@ -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"+    }+  }+]
+ prims/verilog/Clash_Sized_Internal_BitVector.json view
@@ -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]);"+    }+  }+]
+ prims/verilog/Clash_Sized_Internal_Signed.json view
@@ -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]);"+    }+  }+]
+ prims/verilog/Clash_Sized_Internal_Unsigned.json view
@@ -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]);"+    }+  }+]
+ prims/verilog/Clash_Sized_RTree.json view
@@ -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]"+    }+  }+]
+ prims/verilog/Clash_Sized_Vector.json view
@@ -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"+    }+  }+]
+ prims/verilog/Clash_Xilinx_ClockGen.json view
@@ -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"+    }+  }+]
+ prims/verilog/Clash_Xilinx_DDR.json view
@@ -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"+    }+  }+]
+ prims/verilog/GHC_Base.json view
@@ -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"+    }+  }+]
+ prims/verilog/GHC_Classes.json view
@@ -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"+    }+  }+]
+ prims/verilog/GHC_Int.json view
@@ -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]);"+    }+  }+]
+ prims/verilog/GHC_Integer_Type.json view
@@ -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]);"+    }+  }+]
+ prims/verilog/GHC_Prim.json view
@@ -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]"+    }+  }+]
+ prims/verilog/GHC_Types.json view
@@ -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]"+    }+  }+]
+ prims/verilog/GHC_Word.json view
@@ -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]);"+    }+  }+]
+ prims/vhdl/Clash_Explicit_BlockRam.json view
@@ -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"+    }+  }+]
+ prims/vhdl/Clash_Explicit_BlockRam_File.json view
@@ -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"+    }+  }+]
+ prims/vhdl/Clash_Explicit_DDR.json view
@@ -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"+    }+  }+]
+ prims/vhdl/Clash_Explicit_RAM.json view
@@ -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"+    }+  }+]
+ prims/vhdl/Clash_Explicit_ROM.json view
@@ -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"+    }+  }+]
+ prims/vhdl/Clash_Explicit_ROM_File.json view
@@ -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"+    }+  }+]
+ prims/vhdl/Clash_Explicit_Testbench.json view
@@ -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"+    }+  }+]
+ prims/vhdl/Clash_Intel_ClockGen.json view
@@ -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"+    }+  }+]
+ prims/vhdl/Clash_Intel_DDR.json view
@@ -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"+    }+  }+]
+ prims/vhdl/Clash_Prelude_ROM.json view
@@ -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"+    }+  }+]
+ prims/vhdl/Clash_Prelude_ROM_File.json view
@@ -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"+    }+  }+]
+ prims/vhdl/Clash_Promoted_Nat.json view
@@ -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]))))"+    }+  }+]
+ prims/vhdl/Clash_Signal_Internal.json view
@@ -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"+    }+  }+]
+ prims/vhdl/Clash_Sized_Internal_BitVector.json view
@@ -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]))"+    }+  }+]
+ prims/vhdl/Clash_Sized_Internal_Index.json view
@@ -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])"+    }+  }+]
+ prims/vhdl/Clash_Sized_Internal_Signed.json view
@@ -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"+    }+  }+]
+ prims/vhdl/Clash_Sized_Internal_Unsigned.json view
@@ -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])"+    }+  }+]
+ prims/vhdl/Clash_Sized_RTree.json view
@@ -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))"+    }+  }+]
+ prims/vhdl/Clash_Sized_Vector.json view
@@ -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"+    }+  }+]
+ prims/vhdl/Clash_Xilinx_ClockGen.json view
@@ -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"+    }+  }+]
+ prims/vhdl/Clash_Xilinx_DDR.json view
@@ -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"+    }+  }+]
+ prims/vhdl/GHC_Base.json view
@@ -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]"+    }+  }+]
+ prims/vhdl/GHC_Classes.json view
@@ -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]"+    }+  }+]
+ prims/vhdl/GHC_Int.json view
@@ -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)"+    }+  }+]
+ prims/vhdl/GHC_Integer_Logarithms.json view
@@ -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]))))"+    }+  }+]
+ prims/vhdl/GHC_Integer_Type.json view
@@ -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]))"+    }+  }+]
+ prims/vhdl/GHC_Prim.json view
@@ -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]"+    }+  }+]
+ prims/vhdl/GHC_Types.json view
@@ -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]"+    }+  }+]
+ prims/vhdl/GHC_Word.json view
@@ -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)"+    }+  }+]
− src/CLaSH/Backend.hs 
@@ -1,76 +0,0 @@-{-|-  Copyright  :  (C) 2015-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--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
− src/CLaSH/Core/DataCon.hs 
@@ -1,118 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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
− src/CLaSH/Core/FreeVars.hs 
@@ -1,27 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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
− src/CLaSH/Core/Literal.hs 
@@ -1,63 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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
− src/CLaSH/Core/Pretty.hs 
@@ -1,358 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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` "!#$%&*+./<=>?@\\^|~-"
− src/CLaSH/Core/Subst.hs 
@@ -1,59 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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
− src/CLaSH/Core/Term.hs 
@@ -1,92 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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
− src/CLaSH/Core/Term.hs-boot 
@@ -1,17 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# 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
− src/CLaSH/Core/TyCon.hs 
@@ -1,151 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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 _                                                    = []
− src/CLaSH/Core/TyCon.hs-boot 
@@ -1,12 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--module CLaSH.Core.TyCon where--import Unbound.Generics.LocallyNameless (Name)--data TyCon-type TyConName = Name TyCon
− src/CLaSH/Core/Type.hs 
@@ -1,469 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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))
− src/CLaSH/Core/Type.hs-boot 
@@ -1,34 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# 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
− src/CLaSH/Core/TysPrim.hs 
@@ -1,116 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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)-  ]
− src/CLaSH/Core/Util.hs 
@@ -1,447 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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
− src/CLaSH/Core/Var.hs 
@@ -1,59 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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
− src/CLaSH/Driver.hs 
@@ -1,214 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente, 2017, QBayLogic-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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
− src/CLaSH/Driver/TestbenchGen.hs 
@@ -1,272 +0,0 @@-{-|-  Copyright   :  (C) 2013-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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')
− src/CLaSH/Driver/TopWrapper.hs 
@@ -1,346 +0,0 @@-{-|-  Copyright  :  (C) 2015-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# 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 []
− src/CLaSH/Driver/Types.hs 
@@ -1,49 +0,0 @@-{-|-  Copyright  :  (C) 2013-2016, University of Twente, 2017, QBayLogic-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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
− src/CLaSH/Netlist.hs 
@@ -1,468 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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)
− src/CLaSH/Netlist.hs-boot 
@@ -1,31 +0,0 @@-{-|-  Copyright   :  (C) 2015-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--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])
− src/CLaSH/Netlist/BlackBox.hs 
@@ -1,319 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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'
− src/CLaSH/Netlist/BlackBox/Parser.hs 
@@ -1,128 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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')))))
− src/CLaSH/Netlist/BlackBox/Types.hs 
@@ -1,66 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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)
− src/CLaSH/Netlist/BlackBox/Util.hs 
@@ -1,507 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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-      _ -> []
− src/CLaSH/Netlist/Id.hs 
@@ -1,115 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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)
− src/CLaSH/Netlist/Types.hs 
@@ -1,196 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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
− src/CLaSH/Netlist/Util.hs 
@@ -1,366 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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 "<X>_rec", and assign the "<X>_rec" to-  -- "<X>". 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 "<X>" by "<X>_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)
− src/CLaSH/Normalize.hs 
@@ -1,276 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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
− src/CLaSH/Normalize/DEC.hs 
@@ -1,471 +0,0 @@-{-|-  Copyright  :  (C) 2015-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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
− src/CLaSH/Normalize/PrimitiveReductions.hs 
@@ -1,678 +0,0 @@-{-|-  Copyright  :  (C) 2015-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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
− src/CLaSH/Normalize/Strategy.hs 
@@ -1,218 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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)
− src/CLaSH/Normalize/Transformations.hs 
@@ -1,1244 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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
− src/CLaSH/Normalize/Types.hs 
@@ -1,66 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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
− src/CLaSH/Normalize/Util.hs 
@@ -1,167 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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)
− src/CLaSH/Primitives/Types.hs 
@@ -1,57 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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"
− src/CLaSH/Primitives/Util.hs 
@@ -1,49 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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
− src/CLaSH/Rewrite/Combinators.hs 
@@ -1,150 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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
− src/CLaSH/Rewrite/Types.hs 
@@ -1,158 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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)
− src/CLaSH/Rewrite/Util.hs 
@@ -1,638 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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)
− src/CLaSH/Util.hs 
@@ -1,243 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  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
+ src/Clash/Annotations/TopEntity/Extra.hs view
@@ -0,0 +1,24 @@+{-|+  Copyright   :  (C) 2017, Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# 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
+ src/Clash/Backend.hs view
@@ -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 <christiaan.baaij@gmail.com>+-}++{-# 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,"]"])
+ src/Clash/Backend/SystemVerilog.hs view
@@ -0,0 +1,1008 @@+{-|+  Copyright   :  (C) 2015-2016, University of Twente,+                          2017, Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>++  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
+ src/Clash/Backend/VHDL.hs view
@@ -0,0 +1,1201 @@+{-|+  Copyright   :  (C) 2015-2016, University of Twente,+                          2017, Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>++  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
+ src/Clash/Backend/Verilog.hs view
@@ -0,0 +1,627 @@+{-|+  Copyright   :  (C) 2015-2016, University of Twente,+                          2017, Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>++  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
+ src/Clash/Core/DataCon.hs view
@@ -0,0 +1,121 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente,+                          2017, Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>++  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)
+ src/Clash/Core/Evaluator.hs view
@@ -0,0 +1,500 @@+{-|+  Copyright   :  (C) 2017, Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>++  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')
+ src/Clash/Core/FreeVars.hs view
@@ -0,0 +1,27 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>++  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
+ src/Clash/Core/Literal.hs view
@@ -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 <christiaan.baaij@gmail.com>++  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
+ src/Clash/Core/Name.hs view
@@ -0,0 +1,99 @@+{-|+  Copyright   :  (C) 2017, Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>++  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)
+ src/Clash/Core/Pretty.hs view
@@ -0,0 +1,377 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente,+                     2016     , Myrtle Software Ltd+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>++  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` "!#$%&*+./<=>?@\\^|~-"
+ src/Clash/Core/Subst.hs view
@@ -0,0 +1,66 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente,+                          2017, Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>++  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'))
+ src/Clash/Core/Term.hs view
@@ -0,0 +1,98 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente,+                          2017, Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>++  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
+ src/Clash/Core/Term.hs-boot view
@@ -0,0 +1,17 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# 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
+ src/Clash/Core/TyCon.hs view
@@ -0,0 +1,156 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>++  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 _                                                    = []
+ src/Clash/Core/TyCon.hs-boot view
@@ -0,0 +1,13 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++module Clash.Core.TyCon where++import Clash.Core.Name (Name, OccName)++data TyCon+type TyConName = Name TyCon+type TyConOccName = OccName TyCon
+ src/Clash/Core/Type.hs view
@@ -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 <christiaan.baaij@gmail.com>++  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
+ src/Clash/Core/Type.hs-boot view
@@ -0,0 +1,40 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente,+                          2017, Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# 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
+ src/Clash/Core/TysPrim.hs view
@@ -0,0 +1,144 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente,+                     2016     , Myrtle Software Ltd+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>++  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)+  ]
+ src/Clash/Core/Util.hs view
@@ -0,0 +1,459 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>++  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
+ src/Clash/Core/Var.hs view
@@ -0,0 +1,61 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente,+                          2017, Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>++  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
+ src/Clash/Driver.hs view
@@ -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 <christiaan.baaij@gmail.com>++  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
+ src/Clash/Driver/Types.hs view
@@ -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 <christiaan.baaij@gmail.com>++  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)
+ src/Clash/Netlist.hs view
@@ -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 <christiaan.baaij@gmail.com>++  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)
+ src/Clash/Netlist.hs-boot view
@@ -0,0 +1,57 @@+{-|+  Copyright   :  (C) 2015-2016, University of Twente+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++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]
+ src/Clash/Netlist/BlackBox.hs view
@@ -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 <christiaan.baaij@gmail.com>++  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'
+ src/Clash/Netlist/BlackBox/Parser.hs view
@@ -0,0 +1,132 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                    2017     , Myrtle Software Ltd+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>++  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'))))
+ src/Clash/Netlist/BlackBox/Types.hs view
@@ -0,0 +1,72 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                    2017     , Myrtle Software Ltd+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>++  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)
+ src/Clash/Netlist/BlackBox/Util.hs view
@@ -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 <christiaan.baaij@gmail.com>++  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]+      _ -> []
+ src/Clash/Netlist/Id.hs view
@@ -0,0 +1,118 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>++  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)
+ src/Clash/Netlist/Types.hs view
@@ -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 <christiaan.baaij@gmail.com>++  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
+ src/Clash/Netlist/Util.hs view
@@ -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 <christiaan.baaij@gmail.com>++  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 "<X>_rec", and assign the "<X>_rec" to+  -- "<X>". 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 "<X>" by "<X>_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)
+ src/Clash/Normalize.hs view
@@ -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 <christiaan.baaij@gmail.com>++  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
+ src/Clash/Normalize/DEC.hs view
@@ -0,0 +1,486 @@+{-|+  Copyright  :  (C) 2015-2016, University of Twente+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>++  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
+ src/Clash/Normalize/PrimitiveReductions.hs view
@@ -0,0 +1,680 @@+{-|+  Copyright  :  (C) 2015-2016, University of Twente,+                    2016     , Myrtle Software Ltd+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>++  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+         ]
+ src/Clash/Normalize/Strategy.hs view
@@ -0,0 +1,231 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>++  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)
+ src/Clash/Normalize/Transformations.hs view
@@ -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 <christiaan.baaij@gmail.com>++  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
+ src/Clash/Normalize/Types.hs view
@@ -0,0 +1,84 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                         2017, Google Inc.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>++  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
+ src/Clash/Normalize/Util.hs view
@@ -0,0 +1,165 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>++  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
+ src/Clash/Primitives/Types.hs view
@@ -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 <christiaan.baaij@gmail.com>++  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"
+ src/Clash/Primitives/Util.hs view
@@ -0,0 +1,55 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                    2017     , Myrtle Software Ltd+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>++  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
+ src/Clash/Rewrite/Combinators.hs view
@@ -0,0 +1,179 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>++  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
+ src/Clash/Rewrite/Types.hs view
@@ -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 <christiaan.baaij@gmail.com>++  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)
+ src/Clash/Rewrite/Util.hs view
@@ -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 <christiaan.baaij@gmail.com>++  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)
+ src/Clash/Util.hs view
@@ -0,0 +1,243 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>++  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
src/Data/Aeson/Extra.hs view
@@ -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)+                                 )
+ src/Data/Semigroup/Monad/Extra.hs view
@@ -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))+
+ src/Data/Text/Prettyprint/Doc/Extra.hs view
@@ -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
+ src/GHC/BasicTypes/Extra.hs view
@@ -0,0 +1,19 @@+{-|+  Copyright   :  (C) 2017, Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# 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
− src/GHC/Extra.hs 
@@ -1,18 +0,0 @@-{-|-  Copyright   :  (C) 2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# 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
+ src/GHC/SrcLoc/Extra.hs view
@@ -0,0 +1,37 @@+{-|+  Copyright   :  (C) 2017, Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# 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)+
src/Unbound/Generics/LocallyNameless/Extra.hs view
@@ -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 <christiaan.baaij@gmail.com> -}@@ -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