clash-lib 0.4.1 → 0.5

raw patch · 41 files changed

+1001/−1517 lines, 41 filesdep +unbound-genericsdep −ListLikedep −contravariantdep −unboundPVP ok

version bump matches the API change (PVP)

Dependencies added: unbound-generics

Dependencies removed: ListLike, contravariant, unbound

API changes (from Hackage documentation)

Files

• CHANGELOG.md +27/−13
• LICENSE +1/−1
• README.md +0/−8
• clash-lib.cabal +11/−14
• src/CLaSH/Backend.hs +42/−0
• src/CLaSH/Core/DataCon.hs +31/−27
• src/CLaSH/Core/DataCon.hs-boot +16/−12
• src/CLaSH/Core/FreeVars.hs +7/−18
• src/CLaSH/Core/Literal.hs +14/−20
• src/CLaSH/Core/Pretty.hs +20/−20
• src/CLaSH/Core/Subst.hs +3/−3
• src/CLaSH/Core/Term.hs +50/−35
• src/CLaSH/Core/Term.hs-boot +9/−5
• src/CLaSH/Core/TyCon.hs +43/−39
• src/CLaSH/Core/TyCon.hs-boot +1/−1
• src/CLaSH/Core/Type.hs +35/−33
• src/CLaSH/Core/Type.hs-boot +16/−11
• src/CLaSH/Core/TysPrim.hs +4/−4
• src/CLaSH/Core/Util.hs +14/−16
• src/CLaSH/Core/Var.hs +13/−16
• src/CLaSH/Driver.hs +63/−62
• src/CLaSH/Driver/TestbenchGen.hs +83/−83
• src/CLaSH/Netlist.hs +59/−57
• src/CLaSH/Netlist.hs-boot +9/−10
• src/CLaSH/Netlist/BlackBox.hs +122/−161
• src/CLaSH/Netlist/BlackBox/Parser.hs +18/−16
• src/CLaSH/Netlist/BlackBox/Types.hs +2/−29
• src/CLaSH/Netlist/BlackBox/Util.hs +141/−98
• src/CLaSH/Netlist/Id.hs +2/−2
• src/CLaSH/Netlist/Types.hs +37/−21
• src/CLaSH/Netlist/Util.hs +16/−10
• src/CLaSH/Netlist/VHDL.hs +0/−569
• src/CLaSH/Normalize.hs +36/−34
• src/CLaSH/Normalize/Strategy.hs +2/−1
• src/CLaSH/Normalize/Transformations.hs +17/−19
• src/CLaSH/Normalize/Util.hs +7/−7
• src/CLaSH/Primitives/Types.hs +2/−0
• src/CLaSH/Rewrite/Combinators.hs +3/−2
• src/CLaSH/Rewrite/Types.hs +1/−2
• src/CLaSH/Rewrite/Util.hs +20/−32
• src/CLaSH/Util.hs +4/−6

@@ -1,33 +1,47 @@-# Changelog for the [`clash-ghc`](http://hackage.haskell.org/package/clash-ghc) package+# Changelog for the [`clash-lib`](http://hackage.haskell.org/package/clash-lib) package -## 0.4 *November 17th 2014*+## 0.5 *March 11th 2015* * New features:-  * Support for clash-prelude 0.6+  * Simplify BlackBox handling, and improve VHDL generation. [#47](https://github.com/clash-lang/clash-compiler/issues/47)+  * Use unbound-generics. [#48](https://github.com/clash-lang/clash-compiler/issues/48)  * Fixes bugs:-  * clash-ghc ignores "-package-db" flag [#35](https://github.com/christiaanb/clash2/issues/35)+  * VHDL generation error: wrapper for sum-of-products type. [#44](https://github.com/clash-lang/clash-compiler/issues/44) -## 0.3.3 *August 12th 2014*+## 0.4.1 *February 4th 2015* * Fixes bugs:-  * Compile with GHC 7.8.3 [#31](https://github.com/christiaanb/clash2/issues/31)+  * Treat BlackBox expressions as declarations when DC args. [#37](https://github.com/christiaanb/clash2/issues/33)+  * Don't inline recursive closed bindings +## 0.4 *November 17th 2014*+* New features:+  * Support for clash-prelude 0.6++* Fixes bugs:+  * Ambiguous type: 'std_logic_vector' or 'std_ulogic_vector' [#33](https://github.com/christiaanb/clash2/issues/33)+ ## 0.3.2 *June 5th 2014*  * Fixes bugs:-  * Type synonym improperly expanded [#17](https://github.com/christiaanb/clash2/issues/17)-  * BlackBox for `Signed` `maxBound` and `minBound` generate incorrect VHDL. [#19](https://github.com/christiaanb/clash2/issues/19)-  * Generate failure code in the VHDL for recSelError [#23](https://github.com/christiaanb/clash2/issues/23)+  * VHDL array constant ambiguous [#18](https://github.com/christiaanb/clash2/issues/18)+  * Exception: can't create selector [#24](https://github.com/christiaanb/clash2/issues/24)+  * Calls to `vhdlTypeMark` don't result to inclusion of VHDL type in types.vhdl [#28](https://github.com/christiaanb/clash2/issues/28)  ## 0.3.1 *May 15th 2014*  * New features:+  * Make ANF lift non-representable values [#7](https://github.com/christiaanb/clash2/issues/7)   * Hardcode `fromInteger` for `Signed` and `Unsigned` [#9](https://github.com/christiaanb/clash2/issues/9)-  * Better blackbox operation for vindex [#12](https://github.com/christiaanb/clash2/issues/12)   * Replace VHDL default hole by error hole [#13](https://github.com/christiaanb/clash2/issues/13)  * Fixes bugs:-  * Update GHC2Core.hs [#1](https://github.com/christiaanb/clash2/issues/1)-  * primitives (clash.sized.vector) [#2](https://github.com/christiaanb/clash2/issues/2)   * Type families are not expanded [#3](https://github.com/christiaanb/clash2/issues/3)+  * Exception: CLaSH.Netlist.VHDL(512): fromSLV: Vector 13 Bool [#5](https://github.com/christiaanb/clash2/issues/5)   * Incorrect vhdl generation for default value in blackbox [#6](https://github.com/christiaanb/clash2/issues/6)-  * Missing begin keyword in Signed/Unsigned JSON files [#16](https://github.com/christiaanb/clash2/issues/16)+  * Duplicate type names when multiple ADTs need the same amount of bits [#8](https://github.com/christiaanb/clash2/issues/8)+  * Circuit testbench generation with MAC example fails[#15](https://github.com/christiaanb/clash2/issues/15)++* Code improvements:+  * Refactor Netlist/BlackBox [#10](https://github.com/christiaanb/clash2/issues/10)+  * CPP special-case conversion of `Control.Exception.Base.irrefutPatError` [#11](https://github.com/christiaanb/clash2/issues/11)+

@@ -1,4 +1,4 @@-Copyright (c) 2012-2014, University of Twente+Copyright (c) 2012-2015, University of Twente All rights reserved.  Redistribution and use in source and binary forms, with or without

@@ -1,10 +1,2 @@-# Support-For updates and questions join the mailing list clash-language+subscribe@googlegroups.com or read the [forum](https://groups.google.com/d/forum/clash-language)- # `clash-lib`   * See the LICENSE file for license and copyright details--# `clash-ghc`-  * See the LICENSE file for license and copyright details-  * Contains code from the [GHC compiler](http://haskell.org/ghc), see the-    LICENSE_GHC file for license and copyright details pertaining to that code.

@@ -1,5 +1,5 @@ Name:                 clash-lib-Version:              0.4.1+Version:              0.5 Synopsis:             CAES Language for Synchronous Hardware - As a Library Description:   CλaSH (pronounced ‘clash’) is a functional hardware description language that@@ -16,8 +16,6 @@   * The normalisation process that brings CoreHW in a normal form that can be   converted to a netlist   .-  * VHDL Backend-  .   * Blackbox/Primitive Handling   .   .@@ -29,13 +27,13 @@   .   .   Prelude library: <http://hackage.haskell.org/package/clash-prelude>-Homepage:             http://christiaanb.github.io/clash2-bug-reports:          http://github.com/christiaanb/clash2/issues-License:              OtherLicense+Homepage:             http://www.clash-lang.org/+bug-reports:          http://github.com/clash-lang/clash-compiler/issues+License:              BSD2 License-file:         LICENSE Author:               Christiaan Baaij Maintainer:           Christiaan Baaij <christiaan.baaij@gmail.com>-Copyright:            Copyright © 2012-2014 University of Twente+Copyright:            Copyright © 2012-2015 University of Twente Category:             Hardware Build-type:           Simple @@ -46,13 +44,13 @@  source-repository head   type: git-  location: https://github.com/christiaanb/clash2.git+  location: https://github.com/clash-lang/clash-compiler.git  Library   HS-Source-Dirs:     src    default-language:   Haskell2010-  ghc-options:        -O2 -Wall -fwarn-tabs+  ghc-options:        -Wall -fwarn-tabs   CPP-Options:        -DCABAL    Build-depends:      aeson                   >= 0.6.2.0,@@ -61,7 +59,6 @@                       bytestring              >= 0.10.0.2,                       concurrent-supply       >= 0.1.7,                       containers              >= 0.5.0.0,-                      contravariant           >= 0.4.4,                       deepseq                 >= 1.3.0.2,                       directory               >= 1.2.0.1,                       errors                  >= 1.4.2,@@ -69,7 +66,6 @@                       filepath                >= 1.3.0.1,                       hashable                >= 1.2.1.0,                       lens                    >= 3.9.2,-                      ListLike                >= 4.0.0,                       mtl                     >= 2.1.2,                       pretty                  >= 1.1.1.0,                       process                 >= 1.1.0.2,@@ -77,12 +73,14 @@                       text                    >= 0.11.3.1,                       time                    >= 1.4.0.1,                       transformers            >= 0.3.0.0,-                      unbound                 >= 0.4.2,+                      unbound-generics        >= 0.1,                       unordered-containers    >= 0.2.3.3,                       uu-parsinglib           >= 2.8.1,                       wl-pprint-text          >= 1.1.0.0 -  Exposed-modules:    CLaSH.Core.DataCon+  Exposed-modules:    CLaSH.Backend++                      CLaSH.Core.DataCon                       CLaSH.Core.FreeVars                       CLaSH.Core.Literal                       CLaSH.Core.Pretty@@ -106,7 +104,6 @@                       CLaSH.Netlist.Id                       CLaSH.Netlist.Types                       CLaSH.Netlist.Util-                      CLaSH.Netlist.VHDL                        CLaSH.Normalize                       CLaSH.Normalize.Strategy

@@ -0,0 +1,42 @@+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 CLaSH.Netlist.Types++class Backend state where+  -- | Initial state for state monad+  initBackend :: state++  -- | 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           :: Component    -> State state (String, Doc)+  -- | Generate a HDL package containing type definitions for the given HWTypes+  mkTyPackage      :: [HWType]     -> State state 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+  -- | 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

@@ -1,11 +1,9 @@-{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE DeriveGeneric         #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell       #-}-{-# LANGUAGE UndecidableInstances  #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-}- -- | Data Constructors in CoreHW module CLaSH.Core.DataCon   ( DataCon (..)@@ -15,13 +13,16 @@   ) where -import                Control.DeepSeq-import                Unbound.LocallyNameless as Unbound hiding (rnf)-import                Unbound.LocallyNameless.Name (Name(Nm,Bn))+import Data.Monoid                           (mempty)+import Data.Typeable                         (Typeable)+import Control.DeepSeq                       (NFData(..))+import GHC.Generics                          (Generic)+import Unbound.Generics.LocallyNameless      (Alpha(..),Subst,substs)+import Unbound.Generics.LocallyNameless.Name (Name(..)) -import {-# SOURCE #-} CLaSH.Core.Term         (Term)-import {-# SOURCE #-} CLaSH.Core.Type         (TyName, Type)-import                CLaSH.Util+import {-# SOURCE #-} CLaSH.Core.Term        (Term)+import {-# SOURCE #-} CLaSH.Core.Type        (TyName, Type)+import CLaSH.Util  -- | Data Constructor data DataCon@@ -36,7 +37,7 @@                              -- these type variables are not part of the result                              -- of the DataCon, but only of the arguments.   , dcArgTys     :: [Type]   -- ^ Argument types-  }+  } deriving (Generic,Typeable)  instance Show DataCon where   show = show . dcName@@ -52,22 +53,25 @@ -- | DataCon reference type DcName = Name DataCon -Unbound.derive [''DataCon]- instance Alpha DataCon where-  swaps' _ _ d    = d-  fv' _ _         = emptyC-  lfreshen' _ a f = f a empty-  freshen' _ a    = return (a,empty)-  aeq' c dc1 dc2  = aeq' c (dcName dc1) (dcName dc2)+  aeq' c dc1 dc2      = aeq' c (dcName dc1) (dcName dc2)++  fvAny' _ _ dc       = pure dc++  close _ _ dc        = dc+  open _ _ dc         = dc++  isPat _             = mempty+  isTerm _            = True++  nthPatFind _        = Left+  namePatFind _ _     = Left 0++  swaps' _ _ dc       = dc+  lfreshen' _ dc cont = cont dc mempty+  freshen' _ dc       = return (dc,mempty)+   acompare' c dc1 dc2 = acompare' c (dcName dc1) (dcName dc2)-  open _ _ d      = d-  close _ _ d     = d-  isPat _         = error "isPat DataCon"-  isTerm _        = error "isTerm DataCon"-  isEmbed _       = error "isEmbed DataCon"-  nthpatrec _     = error "nthpatrec DataCon"-  findpatrec _ _  = error "findpatrec DataCon"  instance Subst Type DataCon instance Subst Term DataCon@@ -79,8 +83,8 @@  instance NFData (Name DataCon) where   rnf nm = case nm of-    (Nm _ s)   -> rnf s-    (Bn _ l r) -> rnf l `seq` rnf r+    (Fn s i) -> rnf s `seq` rnf i+    (Bn l r) -> rnf l `seq` rnf r  -- | 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.

@@ -1,19 +1,23 @@ {-# LANGUAGE MultiParamTypeClasses #-}++{-# OPTIONS_GHC -fno-warn-missing-methods #-}+ module CLaSH.Core.DataCon where -import                Control.DeepSeq-import                Unbound.LocallyNameless+import Control.DeepSeq                  (NFData)+import GHC.Generics                     (Generic)+import Unbound.Generics.LocallyNameless (Alpha,Subst) -import {-# SOURCE #-} CLaSH.Core.Term         (Term)-import {-# SOURCE #-} CLaSH.Core.Type         (Type)+import {-# SOURCE #-} CLaSH.Core.Term   (Term)+import {-# SOURCE #-} CLaSH.Core.Type   (Type)  data DataCon -instance Eq    DataCon-instance Ord   DataCon-instance Rep   DataCon-instance Show  DataCon-instance Alpha DataCon-instance Subst Type DataCon-instance Subst Term DataCon-instance NFData DataCon+instance Eq      DataCon+instance Ord     DataCon+instance Generic DataCon+instance Show    DataCon+instance Alpha   DataCon+instance Subst   Type DataCon+instance Subst   Term DataCon+instance NFData  DataCon

@@ -1,31 +1,20 @@ -- | Free variable calculations module CLaSH.Core.FreeVars where -import Unbound.LocallyNameless (Collection, fv)+import Control.Lens.Fold                (Fold)+import Unbound.Generics.LocallyNameless (fv) -import CLaSH.Core.Term         (Term, TmName)-import CLaSH.Core.Type         (TyName, Type)+import CLaSH.Core.Term                  (Term, TmName)+import CLaSH.Core.Type                  (TyName, Type)  -- | Gives the free type-variables in a Type-typeFreeVars :: Collection c-             => Type-             -> c TyName+typeFreeVars :: Fold Type TyName typeFreeVars = fv --- | Gives the free type-variables and free term-variables of a Term-termFreeVars :: Collection c-             => Term-             -> (c TyName, c TmName)-termFreeVars tm = (termFreeTyVars tm, termFreeIds tm)- -- | Gives the free term-variables of a Term-termFreeIds :: Collection c-            => Term-            -> c TmName+termFreeIds :: Fold Term TmName termFreeIds = fv  -- | Gives the free type-variables of a Term-termFreeTyVars :: Collection c-               => Term-               -> c TyName+termFreeTyVars :: Fold Term TyName termFreeTyVars = fv

@@ -1,10 +1,8 @@-{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE DeriveGeneric         #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TemplateHaskell       #-}-{-# LANGUAGE UndecidableInstances  #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  -- | Term Literal module CLaSH.Core.Literal@@ -13,32 +11,28 @@   ) where -import                Control.DeepSeq-import                Unbound.LocallyNameless       as Unbound hiding (rnf)-import                Unbound.LocallyNameless.Alpha+import Control.DeepSeq                  (NFData (..))+import GHC.Generics                     (Generic)+import Unbound.Generics.LocallyNameless (Alpha (..), Subst (..)) -import {-# SOURCE #-} CLaSH.Core.Term               (Term)-import {-# SOURCE #-} CLaSH.Core.Type               (Type)-import                CLaSH.Core.TysPrim            (intPrimTy, voidPrimTy)+import {-# SOURCE #-} CLaSH.Core.Term   (Term)+import {-# SOURCE #-} CLaSH.Core.Type   (Type)+import CLaSH.Core.TysPrim               (intPrimTy, voidPrimTy)+import CLaSH.Util  -- | Term Literal data Literal   = IntegerLiteral  Integer   | StringLiteral   String   | RationalLiteral Rational-  deriving (Eq,Ord,Show)--Unbound.derive [''Literal]+  deriving (Eq,Ord,Show,Generic) -instance Alpha Rational-instance Subst b Rational+instance Subst b Rational where+  subst  _ _ = id+  substs _   = id  instance Alpha Literal where-  fv' _ _ = emptyC--  acompare' _ (IntegerLiteral i) (IntegerLiteral j)   = compare i j-  acompare' _ (RationalLiteral i) (RationalLiteral j) = compare i j-  acompare' c l1                 l2                   = acompareR1 rep1 c l1 l2+  fvAny' _ _ l = pure l  instance Subst Type Literal instance Subst Term Literal

@@ -9,27 +9,27 @@   ) where -import           Data.Char               (isSymbol, isUpper, ord)-import           Data.Traversable        (sequenceA)-import           Data.Text               (unpack)-import           GHC.Show                (showMultiLineString)-import           Text.PrettyPrint        (Doc, char, comma, empty, equals, hang,-                                          hsep, int, integer, parens, punctuate,-                                          render, sep, text, vcat, ($$), ($+$),-                                          (<+>), (<>), rational, nest)-import           Unbound.LocallyNameless (Embed (..), LFresh, Name, lunbind,-                                          name2String, runLFreshM, unembed,-                                          unrebind, unrec)+import Data.Char                        (isSymbol, isUpper, ord)+import Data.Traversable                 (sequenceA)+import Data.Text                        (unpack)+import GHC.Show                         (showMultiLineString)+import Text.PrettyPrint                 (Doc, char, comma, empty, equals, hang,+                                         hsep, int, integer, parens, punctuate,+                                         render, sep, text, vcat, ($$), ($+$),+                                         (<+>), (<>), rational, nest)+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+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

@@ -1,10 +1,10 @@ -- | Capture-free substitution function for CoreHW module CLaSH.Core.Subst where -import                Unbound.LocallyNameless (subst, substs)+import Unbound.Generics.LocallyNameless (subst, substs) -import                CLaSH.Core.Term         (Term, TmName)-import {-# SOURCE #-} CLaSH.Core.Type         (KiName, Kind, TyName, Type)+import CLaSH.Core.Term                  (Term, TmName)+import {-# SOURCE #-} CLaSH.Core.Type   (KiName, Kind, TyName, Type)  -- | Substitutes types in a type substTys :: [(TyName,Type)]

@@ -1,10 +1,10 @@-{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE DeriveGeneric         #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell       #-}-{-# LANGUAGE UndecidableInstances  #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  -- | Term representation in the CoreHW language: System F + LetRec + Case module CLaSH.Core.Term@@ -16,19 +16,21 @@ where  -- External Modules-import                Control.DeepSeq-import                Unbound.LocallyNameless       as Unbound hiding (Data,rnf)-import                Unbound.LocallyNameless.Alpha (acompareR1, aeqR1, fvR1)-import                Unbound.LocallyNameless.Name  (Name(Nm,Bn),isFree)-import                Unbound.LocallyNameless.Ops   (unsafeUnbind)-import                Data.Text                     (Text)+import Control.DeepSeq+import Data.Monoid                             (mempty)+import Data.Text                               (Text)+import Data.Typeable+import GHC.Generics+import Unbound.Generics.LocallyNameless+import Unbound.Generics.LocallyNameless.Name   (Name(..))+import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind)  -- Internal Modules-import                CLaSH.Core.DataCon            (DataCon)-import                CLaSH.Core.Literal            (Literal)-import {-# SOURCE #-} CLaSH.Core.Type               (Type)-import                CLaSH.Core.Var                (Id, TyVar)-import                CLaSH.Util+import CLaSH.Core.DataCon                      (DataCon)+import CLaSH.Core.Literal                      (Literal)+import {-# SOURCE #-} CLaSH.Core.Type          (Type)+import CLaSH.Core.Var                          (Id, TyVar)+import CLaSH.Util  -- | Term representation in the CoreHW language: System F + LetRec + Case data Term@@ -43,7 +45,7 @@   | 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+  deriving (Show,Typeable,Generic)  -- | Term reference type TmName     = Name Term@@ -59,12 +61,21 @@   -- ^ Literal pattern   | DefaultPat   -- ^ Default pattern-  deriving (Show)--Unbound.derive_abstract [''Text]-instance Alpha Text+  deriving (Show,Typeable,Generic) -Unbound.derive [''Term,''Pat]+instance Alpha Text where+  aeq' _ctx             = (==)+  fvAny' _ctx _nfn i    = pure i+  close _ctx _b         = id+  open _ctx _b          = id+  isPat _               = mempty+  isTerm _              = True+  nthPatFind _          = Left+  namePatFind _ _       = Left 0+  swaps' _ctx _p        = id+  freshen' _ctx i       = return (i, mempty)+  lfreshen' _ctx i cont = cont i mempty+  acompare' _ctx        = compare  instance Eq Term where   (==) = aeq@@ -73,17 +84,17 @@   compare = acompare  instance Alpha Term where-  fv' c (Var _ n)  = fv' c n-  fv' c t          = fvR1 rep1 c t--  acompare' c (Var _ n)   (Var _ m)   = acompare' c n m-  acompare' _ (Prim t1 _) (Prim t2 _) = compare t1 t2-  acompare' c t1          t2          = acompareR1 rep1 c t1 t2+  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          = aeqR1 rep1 c 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 Alpha Pat  instance Subst Term Pat@@ -93,7 +104,7 @@  instance Subst Type Pat instance Subst Type Term where-  subst tvN u x | isFree tvN = case x of+  subst tvN u x | isFreeName tvN = case x of     Lam    b         -> Lam    (subst tvN u b  )     TyLam  b         -> TyLam  (subst tvN u b  )     App    fun arg   -> App    (subst tvN u fun) (subst tvN u arg)@@ -107,8 +118,12 @@     e                -> e   subst m _ _ = error $ $(curLoc) ++ "Cannot substitute for bound variable: " ++ show m -instance Subst Term Text-instance Subst Type Text+instance Subst Term Text where+  subst  _ _ = id+  substs _   = id+instance Subst Type Text where+  subst  _ _ = id+  substs _   = id  instance NFData Term where   rnf tm = case tm of@@ -117,11 +132,11 @@     Literal l     -> rnf l     Prim    nm ty -> rnf nm `seq` rnf ty     Lam     b     -> case unsafeUnbind b of-                       (id_,tm) -> rnf id_ `seq` rnf tm+                       (id_,tm') -> rnf id_ `seq` rnf tm'     TyLam   b       -> case unsafeUnbind b of-                         (tv,tm) -> rnf tv `seq` rnf tm+                         (tv,tm') -> rnf tv `seq` rnf tm'     App     tmL tmR -> rnf tmL `seq` rnf tmR-    TyApp   tm ty   -> rnf tm `seq` rnf ty+    TyApp   tm' ty  -> rnf tm' `seq` rnf ty     Letrec  b       -> case unsafeUnbind b of                         (bs,e) -> rnf (map (second unembed) (unrec bs)) `seq` rnf e     Case    sc ty alts -> rnf sc `seq` rnf ty `seq` rnf (map unsafeUnbind alts)@@ -134,5 +149,5 @@  instance NFData (Name Term) where   rnf nm = case nm of-    (Nm _ s)   -> rnf s-    (Bn _ l r) -> rnf l `seq` rnf r+    (Fn s i) -> rnf s `seq` rnf i+    (Bn l r) -> rnf l `seq` rnf r

@@ -1,13 +1,17 @@ {-# LANGUAGE MultiParamTypeClasses #-}++{-# OPTIONS_GHC -fno-warn-missing-methods #-}+ module CLaSH.Core.Term where -import Unbound.LocallyNameless+import GHC.Generics                     (Generic)+import Unbound.Generics.LocallyNameless (Alpha,Name,Subst)  data Term  type TmName = Name Term -instance Rep   Term-instance Show  Term-instance Alpha Term-instance Subst Term Term+instance Generic Term+instance Show    Term+instance Alpha   Term+instance Subst   Term Term

@@ -1,12 +1,8 @@-{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE DeriveGeneric         #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternGuards         #-}-{-# LANGUAGE TemplateHaskell       #-}-{-# LANGUAGE UndecidableInstances  #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-}- -- | Type Constructors in CoreHW module CLaSH.Core.TyCon   ( TyCon (..)@@ -19,15 +15,18 @@ where  -- External Import-import                Control.DeepSeq-import                Unbound.LocallyNameless as Unbound hiding (rnf)-import                Unbound.LocallyNameless.Name (Name(Nm,Bn))+import Control.DeepSeq+import Data.Monoid                           (mempty)+import Data.Typeable                         hiding (TyCon,tyConName)+import GHC.Generics+import Unbound.Generics.LocallyNameless      (Alpha(..),Subst(..))+import Unbound.Generics.LocallyNameless.Name (Name(..),name2String)  -- Internal Imports-import {-# SOURCE #-} CLaSH.Core.DataCon      (DataCon)-import {-# SOURCE #-} CLaSH.Core.Term         (Term)-import {-# SOURCE #-} CLaSH.Core.Type         (Kind, TyName, Type)-import                CLaSH.Util+import {-# SOURCE #-} CLaSH.Core.DataCon     (DataCon)+import {-# SOURCE #-} CLaSH.Core.Term        (Term)+import {-# SOURCE #-} CLaSH.Core.Type        (Kind, TyName, Type)+import CLaSH.Util  -- | Type Constructor data TyCon@@ -55,6 +54,7 @@   | SuperKindTyCon   { tyConName :: TyConName     -- ^ Name of the TyCon   }+  deriving (Generic,Typeable)  instance Show TyCon where   show (AlgTyCon       {tyConName = n}) = "AlgTyCon: " ++ show n@@ -84,25 +84,29 @@                                  -- The TyName's are the type-variables from                                  -- the corresponding TyCon.   }-  deriving Show--Unbound.derive [''TyCon,''AlgTyConRhs]+  deriving (Show,Generic)  instance Alpha TyCon where-  swaps' _ _ d    = d-  fv' _ _         = emptyC-  lfreshen' _ a f = f a empty-  freshen' _ a    = return (a,empty)-  aeq' _ tc1 tc2  = aeq (tyConName tc1) (tyConName tc2)-  acompare' _ tc1 tc2 = acompare (tyConName tc1) (tyConName tc2)-  open _ _ d      = d-  close _ _ d     = d-  isPat _         = error "isPat TyCon"-  isTerm _        = error "isTerm TyCon"-  isEmbed _       = error "isEmbed TyCon"-  nthpatrec _     = error "nthpatrec TyCon"-  findpatrec _ _  = error "findpatrec TyCon"+  aeq' c tc1 tc2      = aeq' c (tyConName tc1) (tyConName tc2) +  fvAny' _ _ tc       = pure tc++  close _ _ tc        = tc+  open _ _ tc         = tc++  isPat _             = mempty+  isTerm _            = True++  nthPatFind _        = Left+  namePatFind _ _     = Left 0++  swaps' _ _ tc       = tc+  lfreshen' _ tc cont = cont tc mempty+  freshen' _ tc       = return (tc,mempty)++  acompare' c tc1 tc2 = acompare' c (tyConName tc1) (tyConName tc2)++ instance Alpha AlgTyConRhs  instance Subst Type TyCon@@ -113,15 +117,15 @@  instance NFData TyCon where   rnf tc = case tc of-    AlgTyCon nm ki ar rhs   -> rnf nm `seq` rnf ki `seq` rnf ar `seq` rnf rhs-    FunTyCon nm ki ar subst -> rnf nm `seq` rnf ki `seq` rnf ar `seq` rnf subst-    PrimTyCon nm ki ar      -> rnf nm `seq` rnf ki `seq` rnf ar-    SuperKindTyCon nm       -> rnf nm+    AlgTyCon nm ki ar rhs     -> rnf nm `seq` rnf ki `seq` rnf ar `seq` rnf rhs+    FunTyCon nm ki ar tcSubst -> rnf nm `seq` rnf ki `seq` rnf ar `seq` rnf tcSubst+    PrimTyCon nm ki ar        -> rnf nm `seq` rnf ki `seq` rnf ar+    SuperKindTyCon nm         -> rnf nm  instance NFData (Name TyCon) where   rnf nm = case nm of-    (Nm _ s)   -> rnf s-    (Bn _ l r) -> rnf l `seq` rnf r+    (Fn s i) -> rnf s `seq` rnf i+    (Bn l r) -> rnf l `seq` rnf r  instance NFData AlgTyConRhs where   rnf rhs = case rhs of@@ -139,10 +143,10 @@ isTupleTyConLike :: TyConName -> Bool isTupleTyConLike nm = tupleName (name2String nm)   where-    tupleName nm-      | '(' <- head nm-      , ')' <- last nm-      = all (== ',') (init $ tail nm)+    tupleName nm'+      | '(' <- head nm'+      , ')' <- last nm'+      = all (== ',') (init $ tail nm')     tupleName _ = False  -- | Get the DataCons belonging to a TyCon

@@ -1,6 +1,6 @@ module CLaSH.Core.TyCon where -import Unbound.LocallyNameless (Name)+import Unbound.Generics.LocallyNameless (Name)  data TyCon type TyConName = Name TyCon

@@ -1,15 +1,10 @@-{-# LANGUAGE CPP                   #-}-{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE DeriveGeneric         #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell       #-}-{-# LANGUAGE UndecidableInstances  #-} {-# LANGUAGE ViewPatterns          #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707-{-# OPTIONS_GHC -fno-warn-duplicate-constraints #-}-#endif- -- | Types in CoreHW module CLaSH.Core.Type   ( Type (..)@@ -43,23 +38,29 @@ where  -- External import-import                Control.DeepSeq               as DS-import                Control.Monad                 (zipWithM)-import                Data.HashMap.Strict           (HashMap)-import qualified      Data.HashMap.Strict           as HashMap-import                Data.Maybe                    (isJust)-import                Unbound.LocallyNameless       as Unbound hiding (Arrow,rnf)-import                Unbound.LocallyNameless.Alpha (aeqR1,fvR1)-import                Unbound.LocallyNameless.Name  (Name(Nm,Bn))-import                Unbound.LocallyNameless.Ops   (unsafeUnbind)+import           Control.DeepSeq                         as DS+import           Control.Monad                           (zipWithM)+import           Data.HashMap.Strict                     (HashMap)+import qualified Data.HashMap.Strict                     as HashMap+import           Data.Maybe                              (isJust)+import           Data.Typeable                           hiding (TyCon,mkFunTy,+                                                          mkTyConApp)+import           GHC.Generics                            (Generic(..))+import           Unbound.Generics.LocallyNameless        (Alpha(..),Bind,Fresh,+                                                          Subst(..),SubstName(..),+                                                          acompare,aeq,bind,+                                                          gacompare,gaeq,gfvAny,+                                                          runFreshM,unbind)+import           Unbound.Generics.LocallyNameless.Name   (Name(..), name2String)+import           Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind)  -- Local imports-import                CLaSH.Core.Subst+import           CLaSH.Core.Subst import {-# SOURCE #-} CLaSH.Core.Term-import                CLaSH.Core.TyCon-import                CLaSH.Core.TysPrim-import                CLaSH.Core.Var-import                CLaSH.Util+import           CLaSH.Core.TyCon+import           CLaSH.Core.TysPrim+import           CLaSH.Core.Var+import           CLaSH.Util  -- | Types in CoreHW: function and polymorphic types data Type@@ -68,7 +69,7 @@   | ForAllTy (Bind TyVar Type) -- ^ Polymorphic Type   | AppTy    Type Type         -- ^ Type Application   | LitTy    LitTy             -- ^ Type literal-  deriving Show+  deriving (Show,Generic,Typeable)  -- | An easier view on types data TypeView@@ -81,13 +82,13 @@ data ConstTy   = TyCon TyConName -- ^ TyCon type   | Arrow           -- ^ Function type-  deriving Show+  deriving (Show,Generic,Typeable)  -- | Literal Types data LitTy   = NumTy Int   | SymTy String-  deriving Show+  deriving (Show,Generic,Typeable)  -- | The level above types type Kind       = Type@@ -99,15 +100,16 @@ -- | Reference to a Kind type KiName     = Name Kind -Unbound.derive [''Type,''LitTy,''ConstTy]- instance Alpha Type where-  fv' c (VarTy _ n) = fv' c n-  fv' c t           = fvR1 rep1 c t+  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          = aeqR1 rep1 c t1 t2+  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 Alpha ConstTy instance Alpha LitTy @@ -137,8 +139,8 @@  instance NFData (Name Type) where   rnf nm = case nm of-    (Nm _ s)   -> rnf s-    (Bn _ l r) -> rnf l `seq` rnf r+    (Fn s i) -> rnf s `seq` rnf i+    (Bn l r) -> rnf l `seq` rnf r  instance NFData ConstTy where   rnf cty = case cty of@@ -163,7 +165,7 @@ transparentTy :: Type -> Type transparentTy ty@(AppTy (AppTy (ConstTy (TyCon tc)) _) elTy)   = case name2String tc of-      "CLaSH.Signal.Internal.CSignal" -> transparentTy elTy+      "CLaSH.Signal.Internal.Signal'" -> transparentTy elTy       _ -> ty transparentTy (AppTy ty1 ty2) = AppTy (transparentTy ty1) (transparentTy ty2) transparentTy (ForAllTy b)    = ForAllTy (uncurry bind $ second transparentTy $ unsafeUnbind b)@@ -176,7 +178,7 @@   let tView = tyView ty   in case tView of        TyConApp tc args -> case name2String tc of-         "CLaSH.Signal.Internal.CSignal" -> coreView tcMap (args !! 1)+         "CLaSH.Signal.Internal.Signal'" -> coreView tcMap (args !! 1)          _ -> case (tcMap HashMap.! tc) of                 (AlgTyCon {algTcRhs = (NewTyCon _ nt)})                   | length (fst nt) == length args -> coreView tcMap (newTyConInstRhs nt args)

@@ -1,9 +1,14 @@ {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}++{-# OPTIONS_GHC -fno-warn-missing-methods #-}+ module CLaSH.Core.Type where -import                Control.DeepSeq-import                Unbound.LocallyNameless+import Control.DeepSeq+import Data.Typeable+import GHC.Generics+import Unbound.Generics.LocallyNameless  import {-# SOURCE #-} CLaSH.Core.Term import {-# SOURCE #-} CLaSH.Core.TyCon@@ -14,14 +19,14 @@ type TyName = Name Type type KiName = Name Kind -instance Eq    Type-instance Ord   Type-instance Rep   Type-instance Show  Type-instance Alpha Type-instance Subst Type Type-instance Subst Term Type-instance NFData Type-instance NFData (Name Type)+instance Eq       Type+instance Generic  Type+instance Show     Type+instance Alpha    Type+instance Subst    Type Type+instance Subst    Term Type+instance NFData   Type+instance NFData   (Name Type)+instance Typeable Type  mkTyConTy :: TyConName -> Type

@@ -9,11 +9,11 @@   ) where -import                Data.HashMap.Strict     (HashMap)-import qualified      Data.HashMap.Strict     as HashMap-import                Unbound.LocallyNameless (string2Name)+import           Data.HashMap.Strict              (HashMap)+import qualified Data.HashMap.Strict              as HashMap+import           Unbound.Generics.LocallyNameless (string2Name) -import                CLaSH.Core.TyCon+import           CLaSH.Core.TyCon import {-# SOURCE #-} CLaSH.Core.Type  -- | Builtin Name

@@ -1,25 +1,23 @@ {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fcontext-stack=21 #-}- -- | Smart constructor and destructor functions for CoreHW module CLaSH.Core.Util where -import           Data.HashMap.Lazy       (HashMap)-import           Unbound.LocallyNameless (Fresh, bind, embed, unbind, unembed,-                                          unrebind, unrec)-import           Unbound.LocallyNameless.Ops (unsafeUnbind)+import Data.HashMap.Lazy                       (HashMap)+import Unbound.Generics.LocallyNameless        (Fresh, bind, embed, unbind, unembed,+                                                unrebind, unrec)+import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) -import           CLaSH.Core.DataCon      (dcType)-import           CLaSH.Core.Literal      (literalType)-import           CLaSH.Core.Pretty       (showDoc)-import           CLaSH.Core.Term         (Pat (..), Term (..), TmName)-import           CLaSH.Core.Type         (Kind, TyName, Type (..), applyTy,-                                          isFunTy, isPolyFunCoreTy, mkFunTy,-                                          splitFunTy)-import           CLaSH.Core.TyCon        (TyCon, TyConName)-import           CLaSH.Core.Var          (Id, TyVar, Var (..), varType)-import           CLaSH.Util+import CLaSH.Core.DataCon                      (dcType)+import CLaSH.Core.Literal                      (literalType)+import CLaSH.Core.Pretty                       (showDoc)+import CLaSH.Core.Term                         (Pat (..), Term (..), TmName)+import CLaSH.Core.Type                         (Kind, TyName, Type (..), applyTy,+                                                isFunTy, isPolyFunCoreTy, mkFunTy,+                                                splitFunTy)+import CLaSH.Core.TyCon                        (TyCon, TyConName)+import CLaSH.Core.Var                          (Id, TyVar, Var (..), varType)+import CLaSH.Util  -- | Type environment/context type Gamma = HashMap TmName Type

@@ -1,4 +1,6 @@ {-# LANGUAGE CPP                   #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE DeriveGeneric         #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -6,11 +8,6 @@ {-# LANGUAGE TemplateHaskell       #-} {-# LANGUAGE UndecidableInstances  #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707-{-# OPTIONS_GHC -fno-warn-duplicate-constraints #-}-#endif- -- | Variables in CoreHW module CLaSH.Core.Var   ( Var (..)@@ -20,13 +17,15 @@   ) where -import                Control.DeepSeq              as DS-import                Unbound.LocallyNameless      as Unbound hiding (rnf)-import                Unbound.LocallyNameless.Name (isFree)+import Control.DeepSeq                  (NFData (..))+import Data.Typeable                    (Typeable)+import GHC.Generics                     (Generic)+import Unbound.Generics.LocallyNameless (Alpha,Embed,Name,Subst(..),isFreeName,+                                         unembed) -import {-# SOURCE #-} CLaSH.Core.Term              (Term)-import {-# SOURCE #-} CLaSH.Core.Type              (Kind, Type)-import                CLaSH.Util+import {-# SOURCE #-} CLaSH.Core.Term   (Term)+import {-# SOURCE #-} CLaSH.Core.Type   (Kind, Type)+import CLaSH.Util  -- | Variables in CoreHW data Var a@@ -40,23 +39,21 @@   { varName :: Name a   , varType :: Embed Type   }-  deriving (Eq,Ord,Show)+  deriving (Eq,Show,Generic,Typeable)  -- | Term variable type Id    = Var Term -- | Type variable type TyVar = Var Type -Unbound.derive [''Var]--instance Alpha a => Alpha (Var a)+instance (Typeable a, Alpha a) => Alpha (Var a)  instance Subst Term Id instance Subst Term TyVar  instance Subst Type TyVar instance Subst Type Id where-  subst tvN u (Id idN ty) | isFree tvN = Id idN (subst tvN u ty)+  subst tvN u (Id idN ty) | isFreeName tvN = Id idN (subst tvN u ty)   subst m _ _ = error $ $(curLoc) ++ "Cannot substitute for bound variable: " ++ show m  instance NFData (Name a) => NFData (Var a) where

@@ -1,50 +1,50 @@+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell     #-}  -- | Module that connects all the parts of the CLaSH compiler library module CLaSH.Driver where -import qualified Control.Concurrent.Supply    as Supply+import qualified Control.Concurrent.Supply        as Supply import           Control.DeepSeq-import           Control.Monad.State          (evalState)-import           Control.Lens                 (_1, use)-import           Data.HashMap.Strict          (HashMap)-import qualified Data.HashMap.Strict          as HashMap-import qualified Data.HashSet                 as HashSet-import           Data.List                    (isSuffixOf)-import           Data.Maybe                   (listToMaybe)-import qualified Data.Text.Lazy               as Text-import qualified System.Directory             as Directory-import qualified System.FilePath              as FilePath-import qualified System.IO                    as IO-import           Text.PrettyPrint.Leijen.Text (Doc, hPutDoc)-import           Unbound.LocallyNameless      (name2String)+import           Control.Monad.State              (evalState, get)+import           Data.HashMap.Strict              (HashMap)+import qualified Data.HashMap.Strict              as HashMap+import qualified Data.HashSet                     as HashSet+import           Data.List                        (isSuffixOf)+import           Data.Maybe                       (fromMaybe, listToMaybe)+import qualified Data.Text.Lazy                   as Text+import qualified Data.Time.Clock                  as Clock+import qualified System.Directory                 as Directory+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           CLaSH.Core.Term              (Term)-import           CLaSH.Core.Type              (Type)-import           CLaSH.Core.TyCon             (TyCon, TyConName)+import           CLaSH.Backend+import           CLaSH.Core.Term                  (Term)+import           CLaSH.Core.Type                  (Type)+import           CLaSH.Core.TyCon                 (TyCon, TyConName) import           CLaSH.Driver.TestbenchGen import           CLaSH.Driver.Types-import           CLaSH.Netlist                (genNetlist)-import           CLaSH.Netlist.Types          (Component (..), HWType,-                                               VHDLState)-import           CLaSH.Netlist.VHDL           (genVHDL, mkTyPackage)-import           CLaSH.Normalize              (checkNonRecursive, cleanupGraph,-                                               normalize, runNormalization)+import           CLaSH.Netlist                    (genNetlist)+import           CLaSH.Netlist.Types              (Component (..), HWType)+import           CLaSH.Normalize                  (checkNonRecursive, cleanupGraph,+                                                   normalize, runNormalization) import           CLaSH.Primitives.Types-import           CLaSH.Rewrite.Types          (DebugLevel (..))+import           CLaSH.Rewrite.Types              (DebugLevel (..)) import           CLaSH.Util -import qualified Data.Time.Clock              as Clock---- | Create a set of .VHDL files for a set of functions-generateVHDL :: BindingMap -- ^ Set of functions-             -> PrimMap -- ^ Primitive / BlackBox Definitions-             -> HashMap TyConName TyCon -- ^ TyCon cache-             -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -- ^ Hardcoded 'Type' -> 'HWType' translator-             -> (HashMap TyConName TyCon -> Term -> Term) -- ^ Hardcoded evaluator (delta-reduction)-             -> DebugLevel -- ^ Debug information level for the normalization process-             -> IO ()-generateVHDL bindingsMap primMap tcm typeTrans eval dbgLevel = do+-- | Create a set of target HDL files for a set of functions+generateHDL :: forall backend . Backend backend+            => BindingMap -- ^ Set of functions+            -> Maybe backend+            -> PrimMap -- ^ Primitive / BlackBox Definitions+            -> HashMap TyConName TyCon -- ^ TyCon cache+            -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -- ^ Hardcoded 'Type' -> 'HWType' translator+            -> (HashMap TyConName TyCon -> Term -> Term) -- ^ Hardcoded evaluator (delta-reduction)+            -> DebugLevel -- ^ Debug information level for the normalization process+            -> IO ()+generateHDL bindingsMap hdlState primMap tcm typeTrans eval dbgLevel = do   start <- Clock.getCurrentTime   prepTime <- start `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime   let prepStartDiff = Clock.diffUTCTime prepTime start@@ -79,7 +79,7 @@       let prepNormDiff = Clock.diffUTCTime normTime prepTime       putStrLn $ "Normalisation took " ++ show prepNormDiff -      (netlist,vhdlState,cmpCnt) <- genNetlist Nothing Nothing+      (netlist,cmpCnt) <- genNetlist Nothing                                transformedBindings                                primMap tcm typeTrans Nothing (fst topEntity) @@ -93,62 +93,63 @@                                       cName)                                 netlist -      (testBench,vhdlState') <- genTestBench dbgLevel supplyTB primMap-                                  typeTrans tcm eval vhdlState cmpCnt bindingsMap-                                  (listToMaybe $ map fst $ HashMap.toList testInputs)-                                  (listToMaybe $ map fst $ HashMap.toList expectedOutputs)-                                  topComponent+      testBench <- genTestBench dbgLevel supplyTB primMap+                                 typeTrans tcm eval cmpCnt bindingsMap+                                 (listToMaybe $ map fst $ HashMap.toList testInputs)+                                 (listToMaybe $ map fst $ HashMap.toList expectedOutputs)+                                 topComponent         testBenchTime <- testBench `seq` Clock.getCurrentTime       let netTBDiff = Clock.diffUTCTime testBenchTime netlistTime       putStrLn $ "Testbench generation took " ++ show netTBDiff -      let vhdlDocs = createVHDL vhdlState' (netlist ++ testBench)-          dir = concat [ "./vhdl/"+      let hdlState' = fromMaybe (initBackend :: backend) hdlState+          hdlDocs = createHDL hdlState' (netlist ++ testBench)+          dir = concat [ "./" ++ CLaSH.Backend.name hdlState' ++ "/"                        , takeWhile (/= '.') (name2String $ fst topEntity)                        , "/"                        ]       prepareDir dir-      mapM_ (writeVHDL dir) vhdlDocs+      mapM_ (writeHDL hdlState' dir) hdlDocs -      end <- vhdlDocs `seq` Clock.getCurrentTime+      end <- hdlDocs `seq` Clock.getCurrentTime       let startEndDiff = Clock.diffUTCTime end start       putStrLn $ "Total compilation took " ++ show startEndDiff      [] -> error $ $(curLoc) ++ "No 'topEntity' found"     _  -> error $ $(curLoc) ++ "Multiple 'topEntity's found" --- | Pretty print Components to VHDL Documents-createVHDL :: VHDLState+-- | Pretty print Components to HDL Documents+createHDL :: Backend backend+           => backend            -> [Component]            -> [(String,Doc)]-createVHDL vhdlState components = flip evalState vhdlState $ do-  (vhdlNms,vhdlDocs) <- unzip <$> mapM genVHDL components-  let vhdlNmDocs = zip vhdlNms vhdlDocs-  hwtys <- HashSet.toList <$> use _1+createHDL backend components = flip evalState backend $ do+  (hdlNms,hdlDocs) <- unzip <$> mapM genHDL components+  let hdlNmDocs = zip hdlNms hdlDocs+  hwtys <- HashSet.toList <$> extractTypes <$> get   typesPkg <- mkTyPackage hwtys-  return (("types",typesPkg):vhdlNmDocs)+  return (("types",typesPkg):hdlNmDocs) --- | Prepares the directory for writing VHDL files. This means creating the---   dir if it does not exist and removing all existing .vhdl files from it.+-- | 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 :: String -> IO () prepareDir dir = do   -- Create the dir if needed   Directory.createDirectoryIfMissing True dir-  -- Find all .vhdl files in the directory+  -- Find all .hdl files in the directory   files <- Directory.getDirectoryContents dir-  let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files+  let to_remove = filter ((==".hdl") . 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 VHDL file to the given directory-writeVHDL :: FilePath -> (String, Doc) -> IO ()-writeVHDL dir (cname, vhdl) = do-  handle <- IO.openFile (dir ++ cname ++ ".vhdl") IO.WriteMode-  IO.hPutStrLn handle "-- Automatically generated VHDL"-  hPutDoc handle vhdl+-- | Writes a HDL file to the given directory+writeHDL :: Backend backend => backend -> FilePath -> (String, Doc) -> IO ()+writeHDL backend dir (cname, hdl) = do+  handle <- IO.openFile (dir ++ cname ++ CLaSH.Backend.extension backend) IO.WriteMode+  hPutDoc handle hdl   IO.hPutStr handle "\n"   IO.hClose handle

@@ -1,33 +1,28 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell   #-} -{-# OPTIONS_GHC -fcontext-stack=21 #-}---- | Generate a VHDL testbench for a component given a set of stimuli and a+-- | Generate a HDL testbench for a component given a set of stimuli and a -- set of matching expected outputs module CLaSH.Driver.TestbenchGen   ( genTestBench ) where  import           Control.Concurrent.Supply        (Supply)-import           Control.Monad.State              (evalState) import           Data.HashMap.Lazy                (HashMap)+import qualified Data.HashMap.Lazy                as HashMap import           Data.List                        (find,nub) import           Data.Maybe                       (mapMaybe) import           Data.Text.Lazy                   (isPrefixOf,pack,splitOn)-import qualified Data.Text.Lazy.Builder           as Builder-import qualified Data.Text.Lazy.Builder.RealFloat as Builder-import           Text.PrettyPrint.Leijen.Text     ((<+>), (<>))-import qualified Text.PrettyPrint.Leijen.Text     as PP-import           Unbound.LocallyNameless          (name2String)+import           Unbound.Generics.LocallyNameless          (name2String)  import           CLaSH.Core.Term import           CLaSH.Core.TyCon import           CLaSH.Core.Type  import           CLaSH.Netlist+import           CLaSH.Netlist.BlackBox.Types     (Element (Err))+import           CLaSH.Netlist.BlackBox.Util      (parseFail) import           CLaSH.Netlist.Types              as N-import           CLaSH.Netlist.VHDL               (vhdlTypeErrValue) import           CLaSH.Normalize                  (cleanupGraph, normalize,                                                    runNormalization) import           CLaSH.Primitives.Types@@ -35,8 +30,7 @@  import           CLaSH.Util ---- | Generate a VHDL testbench for a component given a set of stimuli and a+-- | Generate a HDL testbench for a component given a set of stimuli and a -- set of matching expected outputs genTestBench :: DebugLevel              -> Supply@@ -44,36 +38,33 @@              -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))              -> HashMap TyConName TyCon              -> (HashMap TyConName TyCon -> Term -> Term)-             -> VHDLState              -> Int              -> HashMap TmName (Type,Term)   -- ^ Global binders              -> Maybe TmName                 -- ^ Stimuli              -> Maybe TmName                 -- ^ Expected output              -> Component                    -- ^ Component to generate TB for-             -> IO ([Component],VHDLState)-genTestBench dbgLvl supply primMap typeTrans tcm eval vhdlState cmpCnt globals stimuliNmM expectedNmM+             -> IO ([Component])+genTestBench dbgLvl supply primMap typeTrans tcm eval cmpCnt globals stimuliNmM expectedNmM   (Component cName hidden [inp] outp _) = do-  let ioDecl  = [ uncurry NetDecl inp  Nothing-                , uncurry NetDecl outp Nothing+  let ioDecl  = [ uncurry NetDecl inp+                , uncurry NetDecl outp                 ]-      inpAssg = evalState (vhdlTypeErrValue (snd inp)) vhdlState-      inpExpr = Assignment (fst inp) (BlackBoxE (PP.displayT $ PP.renderCompact inpAssg) Nothing)-  (inpInst,inpComps,vhdlState',cmpCnt',hidden') <- maybe (return (inpExpr,[],vhdlState,cmpCnt,hidden))-                                                 (genStimuli vhdlState cmpCnt primMap globals typeTrans tcm normalizeSignal hidden inp)+      inpExpr = Assignment (fst inp) (BlackBoxE "" [Err Nothing] (emptyBBContext {bbResult = (undefined,snd inp)}) False)+  (inpInst,inpComps,cmpCnt',hidden') <- maybe (return (inpExpr,[],cmpCnt,hidden))+                                                 (genStimuli cmpCnt primMap globals typeTrans tcm normalizeSignal hidden inp)                                                  stimuliNmM -  let finDecl = [ NetDecl "finished" Bool (Just (N.Literal Nothing (BoolLit False)))-                , Assignment "done" (Identifier "finished" Nothing)+  let finDecl = [ NetDecl "finished" Bool+                , genDone primMap                 ]-      finAssg = "true after 100 ns"-      finExpr = Assignment "finished" (BlackBoxE (PP.displayT $ PP.renderCompact finAssg) Nothing)-  (expInst,expComps,vhdlState'',hidden'') <- maybe (return (finExpr,[],vhdlState',hidden'))-                                                 (genVerifier vhdlState' cmpCnt' primMap globals typeTrans tcm normalizeSignal hidden' outp)+      finExpr = genFinish primMap+  (expInst,expComps,hidden'') <- maybe (return (finExpr,[],hidden'))+                                                 (genVerifier cmpCnt' primMap globals typeTrans tcm normalizeSignal hidden' outp)                                                  expectedNmM   let clkNms = mapMaybe (\hd -> case hd of (clkNm,Clock _) -> Just clkNm ; _ -> Nothing) hidden       rstNms = mapMaybe (\hd -> case hd of (clkNm,Reset _) -> Just clkNm ; _ -> Nothing) hidden-      clks   = mapMaybe genClock hidden''-      rsts   = mapMaybe genReset hidden''+      clks   = mapMaybe (genClock primMap) hidden''+      rsts   = mapMaybe (genReset primMap) hidden''    let instDecl = InstDecl cName "totest"                    (map (\i -> (i,Identifier i Nothing))@@ -88,7 +79,7 @@                           , [instDecl,inpInst,expInst]                           ]) -  return (tbComp:(inpComps++expComps),vhdlState'')+  return (tbComp:(inpComps++expComps))   where     normalizeSignal :: HashMap TmName (Type,Term)                     -> TmName@@ -96,62 +87,72 @@     normalizeSignal glbls bndr =       runNormalization dbgLvl supply glbls typeTrans tcm eval (normalize [bndr] >>= cleanupGraph bndr) -genTestBench dbgLvl _ _ _ _ _ v _ _ _ _ c = traceIf (dbgLvl > DebugNone) ("Can't make testbench for: " ++ show c) $ return ([],v)+genTestBench dbgLvl _ _ _ _ _ _ _ _ _ c = traceIf (dbgLvl > DebugNone) ("Can't make testbench for: " ++ show c) $ return [] -genClock :: (Identifier,HWType)+genClock :: PrimMap+         -> (Identifier,HWType)          -> Maybe [Declaration]-genClock (clkName,Clock rate) = Just clkDecls+genClock primMap (clkName,Clock rate) = Just clkDecls   where-    clkGenDecl = PP.vsep-                  [ "-- pragma translate_off"-                  , "process is"-                  , "begin"-                  , PP.indent 2-                      (PP.vsep [ "wait for 2 ns;"-                               , "while (not finished) loop"-                               , PP.indent 2-                                  (PP.vsep [PP.text clkName <+> "<= not" <+> PP.text clkName <> PP.semi-                                           ,"wait for" <+> renderFloat2Dec (fromIntegral rate * 0.5) <+> "ns;"-                                           ,PP.text clkName <+> "<= not" <+> PP.text clkName <> PP.semi-                                           ,"wait for" <+> renderFloat2Dec (fromIntegral rate * 0.5) <+> "ns;"-                                           ])-                               , "end loop;"-                               , "wait;"-                               ])-                  , "end process;"-                  , "-- pragma translate_on"-                  ]+    clkGenDecl = case HashMap.lookup "CLaSH.Driver.TestbenchGen.clockGen" primMap of+      Just (BlackBox _ (Left templ)) -> let (rising,rest) = divMod (toInteger rate) 2+                                            falling       = rising + rest+                                            ctx = emptyBBContext+                                                    { bbResult = (Left (Identifier clkName Nothing), Clock rate)+                                                    , bbInputs = [ (Left (N.Literal Nothing (NumLit 2)),Integer,True)+                                                                 , (Left (N.Literal Nothing (NumLit rising)),Integer,True)+                                                                 , (Left (N.Literal Nothing (NumLit falling)),Integer,True)+                                                                 ]+                                                    }+                                        in  BlackBoxD "CLaSH.Driver.TestbenchGen.clockGen" (parseFail templ) ctx+      pM -> error $ $(curLoc) ++ ("Can't make clock declaration for: " ++ show pM) -    clkDecls = [ NetDecl clkName (Clock rate) (Just (N.Literal Nothing (BitLit L)))-               , BlackBoxD (PP.displayT $ PP.renderPretty 0.4 80 clkGenDecl)-               ]+    clkDecls   = [ NetDecl clkName (Clock rate)+                 , clkGenDecl+                 ] -genClock _ = Nothing+genClock _ _ = Nothing -genReset :: (Identifier,HWType)+genReset :: PrimMap+         -> (Identifier,HWType)          -> Maybe [Declaration]-genReset (rstName,Reset clk) = Just rstDecls+genReset primMap (rstName,Reset clk) = Just rstDecls   where-    rstExpr = PP.vsep-                [ "-- pragma translate_off"-                , PP.text rstName <+> "<=" <+> PP.align (PP.vsep (PP.punctuate PP.comma-                                                  [ "'0' after 0 ns"-                                                  , "'1' after 1 ns;"-                                                  ]))-                , "-- pragma translate_on"-                ]+    resetGenDecl = case HashMap.lookup "CLaSH.Driver.TestbenchGen.resetGen" primMap of+      Just (BlackBox _ (Left templ)) -> let ctx = emptyBBContext+                                                    { bbResult = (Left (Identifier rstName Nothing), Reset clk)+                                                    , bbInputs = [(Left (N.Literal Nothing (NumLit 1)),Integer,True)]+                                                    }+                                        in  BlackBoxD "CLaSH.Driver.TestbenchGen.resetGen" (parseFail templ) ctx+      pM -> error $ $(curLoc) ++ ("Can't make reset declaration for: " ++ show pM) -    rstDecls = [ NetDecl rstName (Reset clk) Nothing-               , BlackBoxD (PP.displayT $ PP.renderCompact rstExpr)+    rstDecls = [ NetDecl rstName (Reset clk)+               , resetGenDecl                ] -genReset _ = Nothing+genReset _ _ = Nothing -renderFloat2Dec :: Float -> PP.Doc-renderFloat2Dec = PP.text . Builder.toLazyText . Builder.formatRealFloat Builder.Fixed (Just 2)+genFinish :: PrimMap+          -> Declaration+genFinish primMap = case HashMap.lookup "CLaSH.Driver.TestbenchGen.finishedGen" primMap of+  Just (BlackBox _ (Left templ)) -> let ctx = emptyBBContext+                                                { bbResult = (Left (Identifier "finished" Nothing), Bool)+                                                , bbInputs = [ (Left (N.Literal Nothing (NumLit 100)),Integer,True) ]+                                                }+                                    in  BlackBoxD "CLaSH.Driver.TestbenchGen.finishGen" (parseFail templ) ctx+  pM -> error $ $(curLoc) ++ ("Can't make finish declaration for: " ++ show pM) -genStimuli :: VHDLState-           -> Int+genDone :: PrimMap+        -> Declaration+genDone primMap = case HashMap.lookup "CLaSH.Driver.TestbenchGen.doneGen" primMap of+  Just (BlackBox _ (Left templ)) -> let ctx = emptyBBContext+                                                { bbResult    = (Left (Identifier "done" Nothing), Bool)+                                                , bbInputs    = [(Left (Identifier "finished" Nothing),Bool,False)]+                                                }+                                    in  BlackBoxD "CLaSH.Driver.TestbenchGen.doneGen" (parseFail templ) ctx+  pM -> error $ $(curLoc) ++ ("Can't make done declaration for: " ++ show pM)++genStimuli :: Int            -> PrimMap            -> HashMap TmName (Type,Term)            -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))@@ -162,10 +163,10 @@            -> [(Identifier,HWType)]            -> (Identifier,HWType)            -> TmName-           -> IO (Declaration,[Component],VHDLState,Int,[(Identifier,HWType)])-genStimuli vhdlState cmpCnt primMap globals typeTrans tcm normalizeSignal hidden inp signalNm = do+           -> IO (Declaration,[Component],Int,[(Identifier,HWType)])+genStimuli cmpCnt primMap globals typeTrans tcm normalizeSignal hidden inp signalNm = do   let stimNormal = normalizeSignal globals signalNm-  (comps,vhdlState',cmpCnt') <- genNetlist (Just vhdlState) (Just cmpCnt) stimNormal primMap tcm typeTrans Nothing signalNm+  (comps,cmpCnt') <- genNetlist (Just cmpCnt) stimNormal primMap tcm typeTrans Nothing signalNm   let sigNm   = last (splitOn (pack ".") (pack (name2String signalNm)))       sigComp = case find ((isPrefixOf sigNm) . componentName) comps of                   Just c -> c@@ -182,10 +183,9 @@                         (concat [ clkNms, rstNms ]) ++                         [(outp,Identifier (fst inp) Nothing)]                    )-  return (decl,comps,vhdlState',cmpCnt',hidden'')+  return (decl,comps,cmpCnt',hidden'') -genVerifier :: VHDLState-            -> Int+genVerifier :: Int             -> PrimMap             -> HashMap TmName (Type,Term)             -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))@@ -196,10 +196,10 @@             -> [(Identifier,HWType)]             -> (Identifier,HWType)             -> TmName-            -> IO (Declaration,[Component],VHDLState,[(Identifier,HWType)])-genVerifier vhdlState cmpCnt primMap globals typeTrans tcm normalizeSignal hidden outp signalNm = do+            -> IO (Declaration,[Component],[(Identifier,HWType)])+genVerifier cmpCnt primMap globals typeTrans tcm normalizeSignal hidden outp signalNm = do   let stimNormal = normalizeSignal globals signalNm-  (comps,vhdlState',_) <- genNetlist (Just vhdlState) (Just cmpCnt) stimNormal primMap tcm typeTrans Nothing signalNm+  (comps,_) <- genNetlist (Just cmpCnt) stimNormal primMap tcm typeTrans Nothing signalNm   let sigNm   = last (splitOn (pack ".") (pack (name2String signalNm)))       sigComp = case find ((isPrefixOf sigNm) . componentName) comps of                   Just c -> c@@ -215,4 +215,4 @@                         (concat [ clkNms, rstNms ]) ++                         [(inp,Identifier (fst outp) Nothing),(fin,Identifier "finished" Nothing)]                    )-  return (decl,comps,vhdlState',hidden'')+  return (decl,comps,hidden'')

@@ -4,43 +4,40 @@ -- | Create Netlists out of normalized CoreHW Terms module CLaSH.Netlist where -import           Control.Lens               ((.=), (<<%=))-import qualified Control.Lens               as Lens-import           Control.Monad.State        (runStateT)-import           Control.Monad.Writer       (listen, runWriterT)-import           Data.Either                (lefts,partitionEithers)-import           Data.HashMap.Lazy          (HashMap)-import qualified Data.HashMap.Lazy          as HashMap-import qualified Data.HashSet               as HashSet-import           Data.List                  (elemIndex, nub)-import           Data.Maybe                 (fromMaybe)-import qualified Data.Text.Lazy             as Text-import           Unbound.LocallyNameless    (Embed (..), name2String,-                                             runFreshMT, unbind, unembed,-                                             unrebind)+import           Control.Lens                     ((.=), (<<%=))+import qualified Control.Lens                     as Lens+import           Control.Monad.State              (runStateT)+import           Control.Monad.Writer             (listen, runWriterT)+import           Data.Either                      (lefts,partitionEithers)+import           Data.HashMap.Lazy                (HashMap)+import qualified Data.HashMap.Lazy                as HashMap+import           Data.List                        (elemIndex, nub)+import           Data.Maybe                       (fromMaybe)+import qualified Data.Text.Lazy                   as Text+import           Unbound.Generics.LocallyNameless (Embed (..), name2String,+                                                  runFreshMT, unbind, unembed,+                                                  unrebind) -import           CLaSH.Core.DataCon         (DataCon (..))-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.Core.DataCon               (DataCon (..))+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.Netlist.BlackBox import           CLaSH.Netlist.Id-import           CLaSH.Netlist.Types        as HW+import           CLaSH.Netlist.Types              as HW import           CLaSH.Netlist.Util import           CLaSH.Normalize.Util-import           CLaSH.Primitives.Types     as P+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 :: Maybe VHDLState-           -- ^ State for the 'CLaSH.Netlist.VHDL.VHDLM' Monad-           -> Maybe Int+genNetlist :: Maybe Int            -- ^ Starting number of the component counter            -> HashMap TmName (Type,Term)            -- ^ Global binders@@ -54,15 +51,13 @@            -- ^ Symbol count            -> TmName            -- ^ Name of the @topEntity@-           -> IO ([Component],VHDLState,Int)-genNetlist vhdlStateM compCntM globals primMap tcm typeTrans mStart topEntity = do-  (_,s) <- runNetlistMonad vhdlStateM compCntM globals primMap tcm typeTrans $ genComponent topEntity mStart-  return (HashMap.elems $ _components s, _vhdlMState s, _cmpCount s)+           -> IO ([Component],Int)+genNetlist compCntM globals primMap tcm typeTrans mStart topEntity = do+  (_,s) <- runNetlistMonad compCntM globals primMap tcm typeTrans $ genComponent topEntity mStart+  return (HashMap.elems $ _components s, _cmpCount s)  -- | Run a NetlistMonad action in a given environment-runNetlistMonad :: Maybe VHDLState-                -- ^ State for the 'CLaSH.Netlist.VHDL.VHDLM' Monad-                -> Maybe Int+runNetlistMonad :: Maybe Int                 -- ^ Starting number of the component counter                 -> HashMap TmName (Type,Term)                 -- ^ Global binders@@ -74,14 +69,14 @@                 -- ^ Hardcode Type -> HWType translator                 -> NetlistMonad a                 -- ^ Action to run-                -> IO (a,NetlistState)-runNetlistMonad vhdlStateM compCntM s p tcm typeTrans+                -> IO (a, NetlistState)+runNetlistMonad compCntM s p tcm typeTrans   = runFreshMT   . flip runStateT s'   . (fmap fst . runWriterT)   . runNetlist   where-    s' = NetlistState s HashMap.empty 0 (fromMaybe 0 compCntM) HashMap.empty p (fromMaybe (HashSet.empty,0,HashMap.empty) vhdlStateM) typeTrans tcm+    s' = NetlistState s HashMap.empty 0 (fromMaybe 0 compCntM) HashMap.empty p typeTrans tcm  -- | Generate a component for a given function (caching) genComponent :: TmName -- ^ Name of the function@@ -91,8 +86,8 @@   compExprM <- fmap (HashMap.lookup compName) $ Lens.use bindings   case compExprM of     Nothing -> error $ $(curLoc) ++ "No normalized expression found for: " ++ show compName-    Just (_,expr) -> makeCached compName components $-                      genComponentT compName expr mStart+    Just (_,expr_) -> makeCached compName components $+                      genComponentT compName expr_ mStart  -- | Generate a component for a given function genComponentT :: TmName -- ^ Name of the function@@ -118,7 +113,7 @@   (arguments,binders,result) <- do { normalizedM <- splitNormalized tcm componentExpr                                    ; case normalizedM of                                        Right normalized -> mkUniqueNormalized normalized-                                       Left err         -> error err+                                       Left err         -> error $ $(curLoc) ++ err                                    }    let ids = HashMap.fromList@@ -137,7 +132,6 @@   let netDecls = map (\(id_,_) ->                         NetDecl (mkBasicId . Text.pack . name2String $ varName id_)                                 (unsafeCoreTypeToHWType $(curLoc) typeTrans tcm . unembed $ varType id_)-                                Nothing                      ) $ filter ((/= result) . varName . fst) binders   (decls,clks) <- listen $ concat <$> mapM (uncurry mkDeclarations . second unembed) binders @@ -164,6 +158,7 @@   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 (mkBasicId . Text.pack $ name2String scrutNm,[])                      _ -> do@@ -171,16 +166,22 @@                         i   <- varCount <<%= (+1)                         let tmpNm   = "tmp_" ++ show i                             tmpNmT  = Text.pack tmpNm-                            tmpDecl = NetDecl tmpNmT sHwTy Nothing+                            tmpDecl = NetDecl tmpNmT sHwTy                             tmpAssn = Assignment tmpNmT newExpr                         return (tmpNmT,newDecls ++ [tmpDecl,tmpAssn])   let dstId    = mkBasicId . Text.pack . name2String $ varName bndr       altVarId = mkBasicId . Text.pack $ name2String varTm       modifier = case pat of-        DataPat (Embed dc) ids -> let (_,tms) = unrebind ids+        DataPat (Embed dc) ids -> let tms = case unrebind ids of+                                              ([],tms') -> tms'+                                              _         -> error $ $(curLoc) ++ "Not in normal form: Pattern binds existential variables: " ++ showDoc e                                   in case elemIndex (Id varTm (Embed varTy)) tms of                                        Nothing -> Nothing-                                       Just fI -> Just (Indexed (unsafeCoreTypeToHWType $(curLoc) typeTrans tcm scrutTy,dcTag dc - 1,fI))+                                       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))         _                      -> error $ $(curLoc) ++ "Not in normal form: Unexpected pattern in case-projection: " ++ showDoc e       extractExpr = Identifier (maybe altVarId (const selId) modifier) modifier   return (decls ++ [Assignment dstId extractExpr])@@ -190,7 +191,7 @@   tcm                    <- Lens.use tcCache   scrutTy                <- termType tcm scrut   scrutHTy               <- unsafeCoreTypeToHWTypeM $(curLoc) scrutTy-  (scrutExpr,scrutDecls) <- first (mkScrutExpr scrutHTy (fst (last alts'))) <$> mkExpr False scrutTy scrut+  (scrutExpr,scrutDecls) <- first (mkScrutExpr scrutHTy (fst (last alts'))) <$> mkExpr True scrutTy scrut   (exprs,altsDecls)      <- (second concat . unzip) <$> mapM (mkCondExpr scrutHTy) alts'    let dstId = mkBasicId . Text.pack . name2String $ varName bndr@@ -210,7 +211,6 @@       DataPat (Embed dc) _ -> let modifier = Just (DC (scrutHTy,dcTag dc - 1))                               in case scrutE of                                   Identifier scrutId _ -> Identifier scrutId modifier-                                  BlackBoxE bbE _      -> BlackBoxE bbE modifier                                   _ -> error $ $(curLoc) ++ "Not in normal form: Not a variable reference or primitive as subject of a case-statement"       _ -> scrutE @@ -272,7 +272,7 @@     Data dc       | all (\e -> isConstant e || isVar e) tmArgs -> mkDcApplication hwTy dc tmArgs       | otherwise                                  -> error $ $(curLoc) ++ "Not in normal form: DataCon-application with non-Simple arguments"-    Prim nm _ -> first fst <$> mkPrimitive False bbEasD nm args ty+    Prim nm _ -> mkPrimitive False bbEasD nm args ty     Var _ f       | null tmArgs -> return (Identifier (mkBasicId . Text.pack $ name2String f) Nothing,[])       | otherwise -> error $ $(curLoc) ++ "Not in normal form: top-level binder in argument position: " ++ showDoc app@@ -286,7 +286,9 @@ mkDcApplication dstHType dc args = do   tcm                 <- Lens.use tcCache   argTys              <- mapM (termType tcm) args-  (argExprs,argDecls) <- fmap (second concat . unzip) $! mapM (\(e,t) -> mkExpr True t e) (zip args argTys)+  let isSP (SP _ _) = True+      isSP _        = False+  (argExprs,argDecls) <- fmap (second concat . unzip) $! mapM (\(e,t) -> mkExpr (isSP dstHType) t e) (zip args argTys)   argHWTys            <- mapM coreTypeToHWTypeM argTys   fmap (,argDecls) $! case (argHWTys,argExprs) of     -- Is the DC just a newtype wrapper?@@ -296,23 +298,23 @@         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 (Just $ DC (dstHType,dcI)) argExprs)+          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 (Just $ DC (dstHType,0)) argExprs)+          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 (Just $ DC (dstHType,dcTag dc - 1)) [])+        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 Nothing [])+      Vector 0 _ -> return (HW.DataCon dstHType VecAppend [])       -- Note [Vector Wrapper]       -- The Vector type has two versions of the cons constructor:       --   * The 'normal' one, which takes a coercion as its first argument,@@ -322,10 +324,10 @@       -- We need to account for both occurrences, that's why we have the two       -- case statements below:       Vector 1 _ -> case argExprs of-                      [_,e,_] -> return (HW.DataCon dstHType (Just VecAppend) [e])-                      _       -> return (HW.DataCon dstHType (Just VecAppend) [head argExprs])+                      [_,e,_] -> return (HW.DataCon dstHType VecAppend [e])+                      _       -> return (HW.DataCon dstHType VecAppend [head argExprs])       Vector _ _ -> case argExprs of-                      [_,e1,e2] -> return (HW.DataCon dstHType (Just VecAppend) [e1,e2])-                      _         -> return (HW.DataCon dstHType (Just VecAppend) argExprs)+                      [_,e1,e2] -> return (HW.DataCon dstHType VecAppend [e1,e2])+                      _         -> return (HW.DataCon dstHType VecAppend argExprs)        _ -> error $ $(curLoc) ++ "mkDcApplication undefined for: " ++ show (dstHType,dc,args,argHWTys)

@@ -3,20 +3,19 @@ import CLaSH.Core.DataCon   (DataCon) import CLaSH.Core.Term      (Term,TmName) import CLaSH.Core.Type      (Type)-import CLaSH.Netlist.Types  (Expr,HWType,NetlistMonad,Component,Declaration)+import CLaSH.Netlist.Types  (Expr, HWType, NetlistMonad, Component,+                             Declaration) -genComponent ::-  TmName-  -> Maybe Int-  -> NetlistMonad Component+genComponent :: TmName+             -> Maybe Int+             -> NetlistMonad Component  mkExpr :: Bool        -> Type        -> Term        -> NetlistMonad (Expr,[Declaration]) -mkDcApplication ::-  HWType-  -> DataCon-  -> [Term]-  -> NetlistMonad (Expr,[Declaration])+mkDcApplication :: HWType+                -> DataCon+                -> [Term]+                -> NetlistMonad (Expr,[Declaration])

@@ -1,35 +1,29 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternGuards     #-} {-# LANGUAGE TemplateHaskell   #-} {-# LANGUAGE TupleSections     #-}-{-# LANGUAGE ViewPatterns      #-}  -- | Functions to create BlackBox Contexts and fill in BlackBox templates module CLaSH.Netlist.BlackBox where  import           Control.Lens                  ((.=),(<<%=)) import qualified Control.Lens                  as Lens-import           Control.Monad                 (filterM, mzero)-import           Control.Monad.State           (state)-import           Control.Monad.Trans.Class     (lift)-import           Control.Monad.Trans.Maybe     (MaybeT (..))-import           Control.Monad.Writer          (tell)-import           Data.Either                   (lefts, partitionEithers)+import           Control.Monad                 (filterM)+import           Data.Either                   (lefts) import qualified Data.HashMap.Lazy             as HashMap-import           Data.List                     (partition)-import           Data.Maybe                    (catMaybes, fromJust)+import qualified Data.IntMap                   as IntMap import           Data.Monoid                   (mconcat) import           Data.Text.Lazy                (Text, fromStrict, pack) import qualified Data.Text.Lazy                as Text import           Data.Text                     (unpack) import qualified Data.Text                     as TextS-import           Unbound.LocallyNameless       (embed, name2String, string2Name,+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 (..), TmName)+import           CLaSH.Core.Term               as C (Term (..)) import           CLaSH.Core.Type               as C (Type (..), ConstTy (..),                                                 splitFunTys) import           CLaSH.Core.TyCon              as C (tyConDataCons)@@ -43,7 +37,6 @@ import           CLaSH.Netlist.Id              as N import           CLaSH.Netlist.Types           as N import           CLaSH.Netlist.Util            as N-import           CLaSH.Netlist.VHDL            as N import           CLaSH.Normalize.Util          (isConstant) import           CLaSH.Primitives.Types        as P import           CLaSH.Util@@ -54,70 +47,81 @@                   -> NetlistMonad (BlackBoxContext,[Declaration]) mkBlackBoxContext resId args = do     -- Make context inputs-    tcm                   <- Lens.use tcCache-    args'                 <- fmap (zip args) $ mapM (isFun tcm) args-    (varInps,declssV)     <- fmap (unzip . catMaybes)  $ mapM (runMaybeT . mkInput) args'-    let (_,otherArgs)     = partitionEithers $ map unVar args'-        (litArgs,funArgs) = partition (\(t,b) -> not b && isConstant t) otherArgs-    (litInps,declssL)     <- fmap (unzip . catMaybes) $ mapM (runMaybeT . mkLitInput . fst) litArgs-    (funInps,declssF)     <- fmap (unzip . catMaybes) $ mapM (runMaybeT . mkFunInput resId . fst) funArgs+    tcm             <- Lens.use tcCache+    (imps,impDecls) <- unzip <$> mapM mkArgument args+    (funs,funDecls) <- mapAccumLM (addFunction tcm) IntMap.empty (zip args [0..])      -- Make context result     let res = case synchronizedClk tcm (unembed $ V.varType resId) of-                Just clk -> Right . (,clk) . mkBasicId . pack $ name2String (V.varName resId)-                Nothing  -> Left . mkBasicId . pack $ name2String (V.varName resId)-    resTy <- N.unsafeCoreTypeToHWTypeM $(curLoc) (unembed $ V.varType resId)+                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) varInps (map fst litInps) funInps-           , concat declssV ++ concat declssL ++ concat declssF+    return ( Context (res,resTy) imps funs+           , concat impDecls ++ concat funDecls            )   where-    unVar :: (Term, Bool) -> Either TmName (Term, Bool)-    unVar (Var _ v, False) = Left v-    unVar t                = Right t---- | Instantiate a BlackBox template according to the given context-mkBlackBox :: Text -- ^ Template to instantiate-           -> BlackBoxContext -- ^ Context to instantiate template with-           -> NetlistMonad Text-mkBlackBox templ bbCtx =-  let (l,err) = runParse templ-  in if null err && verifyBlackBoxContext l bbCtx-    then do-      l'        <- instantiateSym l-      (bb,clks) <- liftState vhdlMState $ state $ renderBlackBox l' bbCtx-      tell clks-      return $! bb-    else error $ $(curLoc) ++ "\nCan't match template:\n" ++ show templ ++ "\nwith context:\n" ++ show bbCtx ++ "\ngiven errors:\n" ++ show err---- | Create an template instantiation text for an argument term-mkInput :: (Term, Bool)-        -> MaybeT NetlistMonad ((SyncIdentifier,HWType),[Declaration])-mkInput (_, True) = return ((Left $ pack "__FUN__", Void),[])+    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,[]) -mkInput (Var ty v, False) = do-  let vT = mkBasicId . pack $ name2String v-  tcm  <- Lens.use tcCache-  hwTy <- lift $ N.unsafeCoreTypeToHWTypeM $(curLoc) ty-  case synchronizedClk tcm ty of-    Just clk -> return ((Right (vT,clk), hwTy),[])-    Nothing  -> return ((Left vT, hwTy),[])+prepareBlackBox :: TextS.Text+                -> Text+                -> BlackBoxContext+                -> NetlistMonad BlackBoxTemplate+prepareBlackBox pNm t bbCtx =+  let (templ,err) = runParse t+  in  if null err && verifyBlackBoxContext bbCtx templ+         then do+           templ'  <- instantiateSym templ+           templ'' <- setClocks bbCtx templ'+           return $! templ''+         else+           error $ $(curLoc) ++ "\nCan't match template for " ++ show pNm ++ " :\n" ++ show t +++                   "\nwith context:\n" ++ show bbCtx ++ "\ngiven errors:\n" +++                   show err -mkInput (e, False) = case collectArgs e of-  (Prim f _, args) -> do-    tcm <- Lens.use tcCache-    ty  <- termType tcm e-    ((exprN,hwTy),decls) <- lift $ mkPrimitive True False f args ty-    exprV <- fmap (pack . show) $ liftState vhdlMState $ N.expr False exprN-    return ((Left exprV,hwTy),decls)-  _ -> fmap (first (first Left)) $ mkLitInput e+mkArgument :: Term+           -> NetlistMonad ( (SyncExpr,HWType,Bool)+                           , [Declaration]+                           )+mkArgument e = do+    tcm   <- Lens.use tcCache+    ty    <- termType tcm e+    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,[]) -> let vT = Identifier (mkBasicId . pack $ name2String v) Nothing+                        in  return ((vT,hwTy,False),[])+        (C.Literal (IntegerLiteral i),[]) -> return ((N.Literal Nothing (N.NumLit i),hwTy,True),[])+        (Prim f _,args) -> do+          (e',d) <- mkPrimitive True False f args ty+          case e' of+            (Identifier _ _) -> return ((e',hwTy,False), d)+            _                -> return ((e',hwTy,isConstant e), d)+        (Data dc, args) -> do+            typeTrans <- Lens.use typeTranslator+            args' <- filterM (fmap (representableType typeTrans tcm) . termType tcm) (lefts args)+            (exprN,dcDecls) <- mkDcApplication hwTy dc 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             -> TextS.Text             -> [Either Term Type]             -> Type-            -> NetlistMonad ((Expr,HWType),[Declaration])+            -> NetlistMonad (Expr,[Declaration]) mkPrimitive bbEParen bbEasD nm args ty = do   bbM <- HashMap.lookup nm <$> Lens.use primitives   case bbM of@@ -127,20 +131,21 @@           tmpNmT  = pack tmpNm           tmpId   = Id (string2Name tmpNm) (embed ty)       (bbCtx,ctxDcls) <- mkBlackBoxContext tmpId (lefts args)-      let hwTy    = snd $ result bbCtx+      let hwTy    = snd $ bbResult bbCtx       case template p of         (Left tempD) -> do-          let tmpDecl = NetDecl tmpNmT hwTy Nothing-          bbDecl <- N.BlackBoxD <$> mkBlackBox tempD bbCtx-          return ((Identifier tmpNmT Nothing,hwTy),ctxDcls ++ [tmpDecl,bbDecl])+          let tmpDecl = NetDecl tmpNmT hwTy+              pNm     = name p+          bbDecl <- N.BlackBoxD pNm <$> prepareBlackBox pNm tempD bbCtx <*> pure bbCtx+          return (Identifier tmpNmT Nothing,ctxDcls ++ [tmpDecl,bbDecl])         (Right tempE) -> do-          bbExpr <- mkBlackBox tempE bbCtx-          let bbExpr' = if bbEParen then mconcat ["(",bbExpr,")"] else bbExpr+          let pNm = name p+          bbTempl <- prepareBlackBox pNm tempE bbCtx           if bbEasD-            then let tmpDecl  = NetDecl tmpNmT hwTy Nothing-                     tmpAssgn = Assignment tmpNmT (BlackBoxE bbExpr' Nothing)-                 in  return ((Identifier tmpNmT Nothing, hwTy), ctxDcls ++ [tmpDecl,tmpAssgn])-            else return ((BlackBoxE bbExpr' Nothing,hwTy),ctxDcls)+            then let tmpDecl  = NetDecl tmpNmT hwTy+                     tmpAssgn = Assignment tmpNmT (BlackBoxE pNm bbTempl bbCtx bbEParen)+                 in  return (Identifier tmpNmT Nothing, ctxDcls ++ [tmpDecl,tmpAssgn])+            else return (BlackBoxE pNm bbTempl bbCtx bbEParen,ctxDcls)     Just (P.Primitive pNm _)       | pNm == "GHC.Prim.tagToEnum#" -> do           hwTy <- N.unsafeCoreTypeToHWTypeM $(curLoc) ty@@ -150,145 +155,101 @@               let dcs = tyConDataCons (tcm HashMap.! tcN)                   dc  = dcs !! fromInteger i               (exprN,dcDecls) <- mkDcApplication hwTy dc []-              return ((exprN,hwTy),dcDecls)+              return (exprN,dcDecls)             [Right _, Left scrut] -> do               i <- varCount <<%= (+1)               tcm     <- Lens.use tcCache               scrutTy <- termType tcm scrut+              scrutHTy <- unsafeCoreTypeToHWTypeM $(curLoc) scrutTy               (scrutExpr,scrutDecls) <- mkExpr False scrutTy scrut-              let tmpNm     = "tmp_tte_" ++ show i-                  tmpS      = pack tmpNm-                  netDecl   = NetDecl tmpS hwTy Nothing-                  netAssign = Assignment tmpS (DataTag hwTy (Left scrutExpr))-              return ((Identifier tmpS Nothing,hwTy),netDecl:netAssign:scrutDecls)+              let tmpRhs       = pack ("tmp_tte_rhs_" ++ show i)+                  tmpS         = pack ("tmp_tte_" ++ show i)+                  netDeclRhs   = NetDecl tmpRhs scrutHTy+                  netDeclS     = NetDecl tmpS hwTy+                  netAssignRhs = Assignment tmpRhs scrutExpr+                  netAssignS   = Assignment tmpS (DataTag hwTy (Left tmpRhs))+              return (Identifier tmpS Nothing,[netDeclRhs,netDeclS,netAssignRhs,netAssignS] ++ scrutDecls)             _ -> error $ $(curLoc) ++ "tagToEnum: " ++ show (map (either showDoc showDoc) args)       | pNm == "GHC.Prim.dataToTag#" -> case args of-          [Right _,Left (Data dc)] -> return ((N.Literal Nothing (NumLit $ toInteger $ dcTag dc - 1),Integer),[])+          [Right _,Left (Data dc)] -> return (N.Literal Nothing (NumLit $ toInteger $ dcTag dc - 1),[])           [Right _,Left scrut] -> do             i <- varCount <<%= (+1)+            j <- varCount <<%= (+1)             tcm      <- Lens.use tcCache             scrutTy  <- termType tcm scrut             scrutHTy <- unsafeCoreTypeToHWTypeM $(curLoc) scrutTy             (scrutExpr,scrutDecls) <- mkExpr False scrutTy scrut-            let tmpNm     = "tmp_dtt_" ++ show i-                tmpS      = pack tmpNm-                netDecl   = NetDecl tmpS Integer Nothing-                netAssign = Assignment tmpS (DataTag scrutHTy (Right scrutExpr))-            return ((Identifier tmpS Nothing,Integer),netDecl:netAssign:scrutDecls)-          _ -> error $ $(curLoc) ++ "tagToEnum: " ++ show (map (either showDoc showDoc) args)-      | pNm == "CLaSH.Sized.Internal.BitVector.fromInteger#" -> case lefts args of-          largs@[C.Literal (IntegerLiteral i),arg] ->-            let sz = fromInteger i-            in case arg of-              C.Literal (IntegerLiteral j) ->-                return ((N.Literal (Just (BitVector sz,sz)) (NumLit $ fromInteger j), BitVector sz),[])-              _ -> do-                (bbCtx,ctxDcls) <- mkBlackBoxContext (Id (string2Name "_ERROR_") (embed ty)) largs-                bb <- mkBlackBox (pack "std_logic_vector(to_unsigned(~ARG[1],~LIT[0]))") bbCtx-                return ((BlackBoxE bb Nothing,BitVector sz),ctxDcls)-          _ -> error $ $(curLoc) ++ "CLaSH.Sized.Internal.Signed.fromInteger#: " ++ show (map (either showDoc showDoc) args)-      | pNm == "CLaSH.Sized.Internal.Signed.fromInteger#" -> case lefts args of-          largs@[C.Literal (IntegerLiteral i),arg] ->-            let sz = fromInteger i-            in case arg of-              C.Literal (IntegerLiteral j)-                | i > 32 -> return ((N.Literal (Just (Signed sz,sz)) (NumLit $ fromInteger j), Signed sz),[])-              _ -> do-                (bbCtx,ctxDcls) <- mkBlackBoxContext (Id (string2Name "_ERROR_") (embed ty)) largs-                bb <- mkBlackBox (pack "to_signed(~ARG[1],~LIT[0])") bbCtx-                return ((BlackBoxE bb Nothing,Signed sz),ctxDcls)-          _ -> error $ $(curLoc) ++ "CLaSH.Sized.Internal.Signed.fromInteger#: " ++ show (map (either showDoc showDoc) args)-      | pNm == "CLaSH.Sized.Internal.Unsigned.fromInteger#" -> case lefts args of-          largs@[C.Literal (IntegerLiteral i),arg] ->-            let sz = fromInteger i-            in case arg of-              C.Literal (IntegerLiteral j)-                | i > 31 -> return ((N.Literal (Just (Unsigned sz,sz)) (NumLit $ fromInteger j), Unsigned sz),[])-              _ -> do-                (bbCtx,ctxDcls) <- mkBlackBoxContext (Id (string2Name "_ERROR_") (embed ty)) largs-                bb <- mkBlackBox (pack "to_unsigned(~ARG[1],~LIT[0])") bbCtx-                return ((BlackBoxE bb Nothing,Unsigned sz),ctxDcls)-          _ -> error $ $(curLoc) ++ "CLaSH.Sized.Internal.Unsigned.fromInteger#: " ++ show (map (either showDoc showDoc) args)-      | otherwise -> return ((BlackBoxE (mconcat ["NO_TRANSLATION_FOR:",fromStrict pNm]) Nothing,Void),[])+            let tmpRhs       = pack ("tmp_dtt_rhs_" ++ show i)+                tmpS         = pack ("tmp_dtt_" ++ show j)+                netDeclRhs   = NetDecl tmpRhs scrutHTy+                netDeclS     = NetDecl tmpS Integer+                netAssignRhs = Assignment tmpRhs scrutExpr+                netAssignS   = Assignment tmpS   (DataTag scrutHTy (Right tmpRhs))+            return (Identifier tmpS Nothing,[netDeclRhs,netDeclS,netAssignRhs,netAssignS] ++ scrutDecls)+          _ -> error $ $(curLoc) ++ "dataToTag: " ++ show (map (either showDoc showDoc) args)+      | otherwise -> return (BlackBoxE "" [C $ mconcat ["NO_TRANSLATION_FOR:",fromStrict pNm]] emptyBBContext False,[])     _ -> error $ $(curLoc) ++ "No blackbox found for: " ++ unpack nm --- | Create an template instantiation text for an argument term, given that--- the term is a literal. Returns 'Nothing' if the term is not a literal.-mkLitInput :: Term -- ^ The literal argument term-           -> MaybeT NetlistMonad ((Identifier,HWType),[Declaration])-mkLitInput (C.Literal (IntegerLiteral i))     = return ((pack $ show i,Integer),[])-mkLitInput e@(collectArgs -> (Data dc, args)) = lift $ do-  typeTrans <- Lens.use typeTranslator-  tcm   <- Lens.use tcCache-  args' <- filterM (fmap (representableType typeTrans tcm) . termType tcm) (lefts args)-  hwTy  <- N.termHWType $(curLoc) e-  (exprN,dcDecls) <- mkDcApplication hwTy dc args'-  exprV <- fmap (pack . show) $ liftState vhdlMState $ N.expr False exprN-  return ((exprV,hwTy),dcDecls)-mkLitInput _ = mzero- -- | 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+mkFunInput :: Id   -- ^ Identifier binding the encompassing primitive/blackbox application            -> Term -- ^ The function argument term-           -> MaybeT NetlistMonad ((BlackBoxTemplate,BlackBoxContext),[Declaration])+           -> NetlistMonad ((Either BlackBoxTemplate Declaration,BlackBoxContext),[Declaration]) mkFunInput resId e = do   let (appE,args) = collectArgs e-  (bbCtx,dcls) <- lift $ mkBlackBoxContext resId (lefts args)+  (bbCtx,dcls) <- mkBlackBoxContext resId (lefts args)   templ <- case appE of             Prim nm _ -> do               bbM <- fmap (HashMap.lookup nm) $ Lens.use primitives               let templ = case bbM of-                            Just p@(P.BlackBox {}) -> template p-                            Just (P.Primitive pNm _)-                              | pNm == "CLaSH.Sized.Internal.BitVector.fromInteger#" -> Right "std_logic_vector(to_unsigned(~ARG[1],~LIT[0]))"-                              | pNm == "CLaSH.Sized.Internal.Signed.fromInteger#"    -> Right "to_signed(~ARG[1],~LIT[0])"-                              | pNm == "CLaSH.Sized.Internal.Unsigned.fromInteger#"  -> Right "to_unsigned(~ARG[1],~LIT[0])"+                            Just p@(P.BlackBox {}) -> Left (name p, template p)                             _ -> error $ $(curLoc) ++ "No blackbox found for: " ++ unpack nm               return templ             Data dc -> do               tcm <- Lens.use tcCache               eTy <- termType tcm e               let (_,resTy) = splitFunTys tcm eTy-              resHTyM <- lift $ coreTypeToHWTypeM resTy+              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 (Just $ DC (resHTy,dcI)) dcInps+                      dcApp    = DataCon resHTy (DC (resHTy,dcI)) dcInps                       dcAss    = Assignment (pack "~RESULT") dcApp-                  templ <- fmap (pack . show . fromJust) $ liftState vhdlMState $ inst dcAss-                  return (Left templ)+                  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 (Just $ DC (resHTy,0)) dcInps+                      dcApp  = DataCon resHTy (DC (resHTy,0)) dcInps                       dcAss  = Assignment (pack "~RESULT") dcApp-                  templ <- fmap (pack . show . fromJust) $ liftState vhdlMState $ inst dcAss-                  return (Left templ)+                  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 _) <- lift $ preserveVarEnv $ genComponent fun Nothing+                  (Component compName hidden compInps compOutp _) <- preserveVarEnv $ genComponent fun Nothing                   let hiddenAssigns = map (\(i,_) -> (i,Identifier i Nothing)) hidden                       inpAssigns    = zip (map fst compInps) [ Identifier (pack ("~ARG[" ++ show x ++ "]")) Nothing | x <- [(0::Int)..] ]                       outpAssign    = (fst compOutp,Identifier (pack "~RESULT") Nothing)                   i <- varCount <<%= (+1)                   let instLabel     = Text.concat [compName,pack ("_" ++ show i)]                       instDecl      = InstDecl compName instLabel (outpAssign:hiddenAssigns ++ inpAssigns)-                  templ <- fmap (pack . show . fromJust) $ liftState vhdlMState $ inst instDecl-                  return (Left templ)-                Nothing -> return $ error $ $(curLoc) ++ "Cannot make function input for: " ++ showDoc e-            _ -> return $ error $ $(curLoc) ++ "Cannot make function input for: " ++ showDoc e-  let (l,err) = either runParse (first (([O,C " <= "] ++) . (++ [C ";"])) . runParse) templ-  if null err-    then do-      l' <- lift $ instantiateSym l-      return ((l',bbCtx),dcls)-    else error $ $(curLoc) ++ "\nTemplate:\n" ++ show templ ++ "\nHas errors:\n" ++ show err+                  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') -> let (l,err) = runParse templ'+                             in  if null err+                                    then do+                                      l'  <- instantiateSym l+                                      l'' <- setClocks bbCtx l'+                                      return ((Left l'',bbCtx),dcls)+                                    else error $ $(curLoc) ++ "\nTemplate:\n" ++ show templ ++ "\nHas errors:\n" ++ show err+    Left (_, Right templ') -> let ass = Assignment (pack "~RESULT") (Identifier templ' Nothing)+                              in  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

@@ -3,7 +3,6 @@   (runParse) where -import           Data.ListLike.Text.TextLazy              () import           Data.Text.Lazy                           (Text, pack) import           Text.ParserCombinators.UU import           Text.ParserCombinators.UU.BasicInstances hiding (Parser)@@ -29,6 +28,7 @@ pElement :: Parser Element pElement  =  pTagD          <|> C <$> pText+         <|> C <$> (pack <$> pToken "~ ")  -- | Parse the Text part of a Template pText :: Parser Text@@ -54,21 +54,23 @@  -- | Parse an Expression element pTagE :: Parser Element-pTagE =  O             <$  pToken "~RESULT"-     <|> I             <$> (pToken "~ARG" *> pBrackets pNatural)-     <|> I             <$> (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           <$> (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)+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               <$> (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)+     <|> SigD              <$> (pToken "~SIGD" *> pBrackets pTagE) <*> (Just <$> (pBrackets pNatural))+     <|> (`SigD` Nothing)  <$> (pToken "~SIGDO" *> pBrackets pTagE)  -- | Parse a bracketed text pBrackets :: Parser a -> Parser a

@@ -1,30 +1,7 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Types used in BlackBox modules module CLaSH.Netlist.BlackBox.Types where -import Control.Applicative  (Applicative)-import Control.Monad.State  (MonadState, State)-import Control.Monad.Writer (MonadWriter,WriterT)-import Data.Text.Lazy       (Text)--import CLaSH.Netlist.Types---- | Context used to fill in the holes of a BlackBox template-data BlackBoxContext-  = Context-  { result    :: (SyncIdentifier,HWType) -- ^ Result name and type-  , inputs    :: [(SyncIdentifier,HWType)] -- ^ Argument names and types-  , litInputs :: [Identifier] -- ^ Literal arguments (subset of inputs)-  , funInputs :: [(BlackBoxTemplate,BlackBoxContext)]-  -- ^ Function arguments (subset of inputs):-  ---  -- * (Blackbox Template,Partial Blackbox Concext)-  }-  deriving Show---- | Either the name of the identifier, or a tuple of the identifier and the--- corresponding clock-type SyncIdentifier = Either Identifier (Identifier,(Identifier,Int))+import Data.Text.Lazy (Text)  -- | A BlackBox Template is a List of Elements type BlackBoxTemplate = [Element]@@ -43,6 +20,7 @@              | TypM (Maybe Int)  -- ^ Type root hole              | Err (Maybe Int)   -- ^ Error value hole              | TypElem Element   -- ^ Select element type from a vector type+             | SigD Element (Maybe Int)   deriving Show  -- | Component instantiation hole. First argument indicates which function argument@@ -54,8 +32,3 @@ -- is the type of the signal data Decl = Decl Int [(BlackBoxTemplate,BlackBoxTemplate)]   deriving Show---- | Monad that caches VHDL information and remembers hidden inputs of--- black boxes that are being generated (WriterT)-newtype BlackBoxMonad a = B { runBlackBoxM :: WriterT [(Identifier,HWType)] (State VHDLState) a }-  deriving (Functor, Applicative, Monad, MonadWriter [(Identifier,HWType)], MonadState VHDLState)

@@ -1,4 +1,7 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE FlexibleContexts  #-}  -- | Utilties to verify blackbox contexts against templates and rendering -- filled in templates@@ -6,58 +9,51 @@  import           Control.Lens                         (at, use, (%=), (+=), _1,                                                        _2)-import           Control.Monad.State                  (State, lift, runState)-import           Control.Monad.Writer                 (runWriterT, tell)+import           Control.Monad.State                  (State, runState)+import           Control.Monad.Writer                 (MonadWriter, tell) import           Data.Foldable                        (foldrM) import qualified Data.IntMap                          as IntMap-import qualified Data.List                            as List import           Data.Text.Lazy                       (Text) import qualified Data.Text.Lazy                       as Text-import           Text.PrettyPrint.Leijen.Text.Monadic (displayT, renderOneLine)+import           Text.PrettyPrint.Leijen.Text.Monadic (displayT, renderCompact,+                                                       renderOneLine) +import           CLaSH.Backend                        (Backend (..))+import           CLaSH.Netlist.BlackBox.Parser import           CLaSH.Netlist.BlackBox.Types import           CLaSH.Netlist.Types                  (HWType (..), Identifier,-                                                       VHDLState)-import           CLaSH.Netlist.VHDL                   (vhdlType,-                                                       vhdlTypeErrValue,-                                                       vhdlTypeMark)+                                                       BlackBoxContext (..),+                                                       SyncExpr, Expr(Identifier)) 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 :: BlackBoxTemplate -- ^ Template to check against-                      -> BlackBoxContext -- ^ Blackbox to verify+verifyBlackBoxContext :: BlackBoxContext -- ^ Blackbox to verify+                      -> BlackBoxTemplate -- ^ Template to check against                       -> Bool-verifyBlackBoxContext tmpl bbCtx =-  ((length (inputs bbCtx) - 1)    >= countArgs tmpl) &&-  ((length (litInputs bbCtx) - 1) >= countLits tmpl) &&-  ((length (funInputs bbCtx) - 1) >= countFuns tmpl)---- | Count the number of argument tags/holes in a blackbox template-countArgs :: BlackBoxTemplate -> Int-countArgs [] = -1-countArgs l  = maximum-             $ map (\e -> case e of-                            I n -> n-                            D (Decl _ l') -> maximum $ map (countArgs . fst) l'-                            _ -> -1-                   ) l---- | Counter the number of literal tags/holes in a blackbox template-countLits :: BlackBoxTemplate -> Int-countLits [] = -1-countLits l  = maximum-             $ map (\e -> case e of-                            L n -> n-                            D (Decl _ l') -> maximum $ map (countLits . fst) l'-                            _ -> -1-                   ) l+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 --- | Count the number of function instantiations in a blackbox template-countFuns :: BlackBoxTemplate -> Int-countFuns [] = -1-countFuns l  = maximum $ map (\e -> case e of { D (Decl n _) -> n; _ -> -1 }) l+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.@@ -76,91 +72,138 @@                                                           return (Sym k)                                             Just k  -> return (Sym k)                       D (Decl n l') -> D <$> (Decl n <$> mapM (combineM setSym' setSym') l')+                      SigD e' m     -> SigD <$> (head <$> setSym' [e']) <*> pure m                       _             -> pure e               ) +setClocks :: ( MonadWriter [(Identifier,HWType)] m+             , Applicative 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' (SigD e m)     = SigD <$> (head <$> setClocks bc [e]) <*> pure m++    setClocks' (Clk Nothing)  = let (clk,rate) = clkSyncId $ fst $ bbResult bc+                                in  tell [(clk,Clock rate)] >> return (C clk)+    setClocks' (Clk (Just n)) = let (e,_,_)    = bbInputs bc !! n+                                    (clk,rate) = clkSyncId e+                                in  tell [(clk,Clock rate)] >> return (C clk)++    setClocks' (Rst Nothing)  = let (rst,rate) = (first (`Text.append` "_rst")) . clkSyncId $ fst $ bbResult bc+                                in  tell [(rst,Reset rate)] >> return (C rst)+    setClocks' (Rst (Just n)) = let (e,_,_)    = bbInputs bc !! n+                                    (rst,rate) = clkSyncId e+                                    rst'       = Text.append rst "_rst"+                                in  tell [(rst',Reset rate)] >> return (C rst')++    setClocks' e = return e+ -- | Get the name of the clock of an identifier-clkSyncId :: SyncIdentifier -> (Identifier,Int)+clkSyncId :: SyncExpr -> (Identifier,Int) 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 :: BlackBoxTemplate -- ^ Blackbox template+renderBlackBox :: Backend backend+               => BlackBoxTemplate -- ^ Blackbox template                -> BlackBoxContext -- ^ Context used to fill in the hole-               -> VHDLState-               -> ((Text, [(Identifier,HWType)]),VHDLState)-renderBlackBox l bbCtx s-  = first (Text.concat *** List.nub)-  $ flip runState s-  $ runWriterT-  $ runBlackBoxM+               -> State backend Text+renderBlackBox l bbCtx+  = fmap Text.concat   $ mapM (renderElem bbCtx) l  -- | Render a single template element-renderElem :: BlackBoxContext+renderElem :: Backend backend+           => BlackBoxContext            -> Element-           -> BlackBoxMonad Text+           -> State backend Text renderElem b (D (Decl n (l:ls))) = do-  o  <- combineM (lineToIdentifier b) (lineToType b) l-  is <- mapM (combineM (lineToIdentifier b) (lineToType b)) ls-  let (templ,pCtx) = indexNote ($(curLoc) ++ "No function argument " ++ show n) (funInputs b) n-  let b' = pCtx { result = o, inputs = inputs pCtx ++ is }-  if verifyBlackBoxContext templ b'-    then Text.concat <$> mapM (renderElem b') templ-    else error $ $(curLoc) ++ "\nCan't match context:\n" ++ show b' ++ "\nwith template:\n" ++ show templ+    (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 error $ $(curLoc) ++ "\nCan't match context:\n" ++ show b' ++ "\nwith template:\n" ++ show templ -renderElem b e = either id fst <$> mkSyncIdentifier b e+renderElem b (SigD e m) = do+  e' <- 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 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 :: BlackBoxContext+lineToIdentifier :: Backend backend+                 => BlackBoxContext                  -> BlackBoxTemplate-                 -> BlackBoxMonad SyncIdentifier+                 -> State backend Text lineToIdentifier b = foldrM (\e a -> do-                              e' <- mkSyncIdentifier  b e-                              case (e', a) of-                                (Left t, Left t')             -> return (Left  (t `Text.append` t'))-                                (Left t, Right (t',clk))      -> return (Right (t `Text.append` t',clk))-                                (Right (t,clk), Left t')      -> return (Right (t `Text.append` t',clk))-                                (Right (t,clk), Right (t',_)) -> return (Right (t `Text.append` t',clk))-                   ) (Left Text.empty)+                              e' <- renderTag b e+                              return (e' `Text.append` a)+                   ) Text.empty  lineToType :: BlackBoxContext            -> BlackBoxTemplate-           -> BlackBoxMonad HWType-lineToType b [(Typ Nothing)]  = return (snd $ result b)-lineToType b [(Typ (Just n))] = return (snd $ inputs b !! n)-lineToType b [(TypElem t)]    = do hwty' <- lineToType b [t]-                                   case hwty' of-                                     Vector _ elTy -> return elTy-                                     _ -> error $ $(curLoc) ++ "Element type selection of a non-vector type"+           -> 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 _ _ = 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.-mkSyncIdentifier :: BlackBoxContext-                 -> Element-                 -> BlackBoxMonad SyncIdentifier-mkSyncIdentifier _ (C t)           = return $ Left t-mkSyncIdentifier b O               = return $ fst $ result b-mkSyncIdentifier b (I n)           = return $ fst $ inputs b !! n-mkSyncIdentifier b (L n)           = return $ Left $ litInputs b !! n-mkSyncIdentifier _ (Sym n)         = return $ Left $ Text.pack ("n_" ++ show n)-mkSyncIdentifier b (Clk Nothing)   = let (clk,rate) = clkSyncId $ fst $ result b-                                     in tell [(clk,Clock rate)] >> return (Left clk)-mkSyncIdentifier b (Clk (Just n))  = let (clk,rate) = clkSyncId $ fst $ inputs b !! n-                                     in tell [(clk,Clock rate)] >> return (Left clk)-mkSyncIdentifier b (Rst Nothing)   = let (rst,rate) = (first (`Text.append` Text.pack "_rst")) . clkSyncId $ fst $ result b-                                     in tell [(rst,Reset rate)] >> return (Left rst)-mkSyncIdentifier b (Rst (Just n))  = let (rst,rate) = (first (`Text.append` Text.pack "_rst")) . clkSyncId $ fst $ inputs b !! n-                                     in tell [(rst,Reset rate)] >> return (Left rst)-mkSyncIdentifier b (Typ Nothing)   = fmap (Left . displayT . renderOneLine) . B . lift . vhdlType . snd $ result b-mkSyncIdentifier b (Typ (Just n))  = fmap (Left . displayT . renderOneLine) . B . lift . vhdlType . snd $ inputs b !! n-mkSyncIdentifier b (TypM Nothing)  = fmap (Left . displayT . renderOneLine) . B . lift . vhdlTypeMark . snd $ result b-mkSyncIdentifier b (TypM (Just n)) = fmap (Left . displayT . renderOneLine) . B . lift . vhdlTypeMark . snd $ inputs b !! n-mkSyncIdentifier b (Err Nothing)   = fmap (Left . displayT . renderOneLine) . B . lift . vhdlTypeErrValue . snd $ result b-mkSyncIdentifier b (Err (Just n))  = fmap (Left . displayT . renderOneLine) . B . lift . vhdlTypeErrValue . snd $ inputs b !! n-mkSyncIdentifier _ (D _)           = error $ $(curLoc) ++ "Unexpected component declaration"-mkSyncIdentifier _ (TypElem _)     = error $ $(curLoc) ++ "Unexpected type element selector"+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 e+renderTag _ (Sym n)         = return $ Text.pack ("n_" ++ show n)+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 _ (D _)           = error $ $(curLoc) ++ "Unexpected component declaration"+renderTag _ (TypElem _)     = error $ $(curLoc) ++ "Unexpected type element selector"+renderTag _ (SigD _ _)      = error $ $(curLoc) ++ "Unexpected signal declaration"+renderTag _ (Clk _)         = error $ $(curLoc) ++ "Unexpected clock"+renderTag _ (Rst _)         = error $ $(curLoc) ++ "Unexpected reset"

@@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns      #-}--- | Transform/format a Netlist Identifier so that it is acceptable as a VHDL identifier+-- | Transform/format a Netlist Identifier so that it is acceptable as a HDL identifier module CLaSH.Netlist.Id   ( mkBasicId   , mkBasicId'@@ -12,7 +12,7 @@ import Data.Text.Lazy as Text import Numeric        (showHex) --- | Transform/format a text so that it is acceptable as a VHDL identifier+-- | Transform/format a text so that it is acceptable as a HDL identifier mkBasicId :: Text           -> Text mkBasicId = mkBasicId' False

@@ -10,33 +10,30 @@ import Control.Monad.Writer                 (MonadWriter, WriterT) import Data.Hashable import Data.HashMap.Lazy                    (HashMap)-import Data.HashSet                         (HashSet)-import Data.Text.Lazy                       (Text)+import Data.IntMap.Lazy                     (IntMap, empty)+import qualified Data.Text                  as S+import Data.Text.Lazy                       (Text, pack) import GHC.Generics                         (Generic)-import Text.PrettyPrint.Leijen.Text.Monadic (Doc)-import Unbound.LocallyNameless              (Fresh, FreshMT)+import Unbound.Generics.LocallyNameless              (Fresh, FreshMT)  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 [(Identifier,HWType)] (StateT NetlistState (FreshMT IO)) a }-  deriving (Functor, Monad, Applicative, MonadState NetlistState, MonadWriter [(Identifier,HWType)], Fresh, MonadIO)---- | State for the 'CLaSH.Netlist.VHDL.VHDLM' monad:------ * Previously encountered HWTypes------ * Product type counter------ * Cache for previously generated product type names-type VHDLState = (HashSet HWType,Int,HashMap HWType Doc)+  NetlistMonad { runNetlist :: WriterT+                               [(Identifier,HWType)]+                               (StateT NetlistState (FreshMT IO))+                               a+               }+  deriving (Functor, Monad, Applicative, MonadWriter [(Identifier,HWType)],+            MonadState NetlistState, Fresh, MonadIO)  -- | State of the NetlistMonad data NetlistState@@ -47,7 +44,6 @@   , _cmpCount       :: Int -- ^ Number of create components   , _components     :: HashMap TmName Component -- ^ Cached components   , _primitives     :: PrimMap -- ^ Primitive Definitions-  , _vhdlMState     :: VHDLState -- ^ State for the 'CLaSH.Netlist.VHDL.VHDLM' Monad   , _typeTranslator :: HashMap TyConName TyCon -> Type -> Maybe (Either String HWType) -- ^ Hardcoded Type -> HWType translator   , _tcCache        :: HashMap TyConName TyCon -- ^ TyCon cache   }@@ -125,8 +121,8 @@   --   -- * List of: (Maybe expression scrutinized expression is compared with,RHS of alternative)   | InstDecl Identifier Identifier [(Identifier,Expr)] -- ^ Instantiation of another component-  | BlackBoxD Text -- ^ Instantiation of blackbox declaration-  | NetDecl Identifier HWType (Maybe Expr) -- ^ Signal declaration+  | BlackBoxD S.Text BlackBoxTemplate BlackBoxContext -- ^ Instantiation of blackbox declaration+  | NetDecl Identifier HWType -- ^ Signal declaration   deriving Show  instance NFData Declaration where@@ -142,10 +138,10 @@ -- | Expression used in RHS of a declaration data Expr   = Literal    (Maybe (HWType,Size)) Literal -- ^ Literal expression-  | DataCon    HWType       (Maybe Modifier)  [Expr] -- ^ DataCon application+  | DataCon    HWType       Modifier  [Expr] -- ^ DataCon application   | Identifier Identifier   (Maybe Modifier) -- ^ Signal reference-  | DataTag    HWType       (Either Expr Expr) -- ^ @Left e@: tagToEnum#, @Right e@: dataToTag#-  | BlackBoxE Text (Maybe Modifier) -- ^ Instantiation of a BlackBox expression+  | DataTag    HWType       (Either Identifier Identifier) -- ^ @Left e@: tagToEnum#, @Right e@: dataToTag#+  | BlackBoxE S.Text BlackBoxTemplate BlackBoxContext Bool -- ^ Instantiation of a BlackBox expression   deriving Show  -- | Literals used in an expression@@ -163,5 +159,25 @@   | U -- ^ Undefined   | Z -- ^ High-impedance   deriving 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)+  }+  deriving Show++emptyBBContext :: BlackBoxContext+emptyBBContext = Context (Left $ Identifier (pack "__EMPTY__") Nothing, Void) [] empty++-- | 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,Int))  makeLenses ''NetlistState

@@ -1,9 +1,6 @@-{-# LANGUAGE PatternGuards   #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns    #-} -{-# OPTIONS_GHC -fcontext-stack=21 #-}- -- | Utilities for converting Core Type/Term to Netlist datatypes module CLaSH.Netlist.Util where @@ -16,7 +13,7 @@ import qualified Data.HashMap.Strict     as HashMap import           Data.Maybe              (catMaybes,fromMaybe) import           Data.Text.Lazy          (pack)-import           Unbound.LocallyNameless (Embed, Fresh, bind, embed, makeName,+import           Unbound.Generics.LocallyNameless (Embed, Fresh, bind, embed, makeName,                                           name2Integer, name2String, unbind,                                           unembed, unrec) @@ -37,7 +34,7 @@ -- | 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,Functor m)+splitNormalized :: (Fresh m, Functor m)                 => HashMap TyConName TyCon                 -> Term                 -> m (Either String ([Id],[LetBinding],Id))@@ -80,14 +77,14 @@                 -> Type                 -> Maybe (Identifier,Int) synchronizedClk tcm ty-  | not . null . typeFreeVars $ ty = Nothing+  | 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 (NumTy i)]) -> Just (pack (s ++ show i),i)                                           _ -> error $ $(curLoc) ++ "Clock period not a simple literal: " ++ showDoc ty-      "CLaSH.Signal.Internal.CSignal" -> case splitTyConAppM (head args) of+      "CLaSH.Signal.Internal.Signal'" -> case splitTyConAppM (head args) of                                            Just (_,[LitTy (SymTy s),LitTy (NumTy i)]) -> Just (pack (s ++ show i),i)                                            _ -> error $ $(curLoc) ++ "Clock period not a simple literal: " ++ showDoc ty       _                               -> case tyConDataCons (tcm HashMap.! tyCon) of@@ -203,12 +200,21 @@   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+ -- | Turns a Core variable reference to a Netlist expression. Errors if the term -- is not a variable. varToExpr :: Term           -> Expr varToExpr (Var _ var) = Identifier (mkBasicId . pack $ name2String var) Nothing-varToExpr _           = error "not a var"+varToExpr _           = error $ $(curLoc) ++ "not a var"  -- | Uniquely rename all the variables and their references in a normalized -- term@@ -220,7 +226,7 @@   let res1  = appendToName (varName res) "_o"   let bndrs = map fst binds   let exprs = map (unembed . snd) binds-  let usesOutput = concatMap (filter (== varName res) . termFreeIds) exprs+  let usesOutput = concatMap (filter (== varName res) . Lens.toListOf termFreeIds) exprs   let (res2,extraBndr) = case usesOutput of                             [] -> (res1,[] :: [(Id, Embed Term)])                             _  -> let res3 = appendToName (varName res) "_o_sig"@@ -264,7 +270,7 @@  -- | Preserve the Netlist '_varEnv' and '_varCount' when executing a monadic action preserveVarEnv :: NetlistMonad a-                  -> NetlistMonad a+               -> NetlistMonad a preserveVarEnv action = do   vCnt <- Lens.use varCount   vEnv <- Lens.use varEnv

@@ -1,569 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecursiveDo       #-}-{-# LANGUAGE TemplateHaskell   #-}-{-# LANGUAGE TupleSections     #-}-{-# LANGUAGE ViewPatterns      #-}---- | Generate VHDL for assorted Netlist datatypes-module CLaSH.Netlist.VHDL-  ( genVHDL-  , mkTyPackage-  , vhdlType-  , vhdlTypeErrValue-  , vhdlTypeMark-  , inst-  , expr-  )-where--import qualified Control.Applicative                  as A-import           Control.Lens                         hiding (Indexed)-import           Control.Monad                        (forM,join,liftM,when,zipWithM)-import           Control.Monad.State                  (State)-import           Data.Graph.Inductive                 (Gr, mkGraph, topsort')-import qualified Data.HashMap.Lazy                    as HashMap-import qualified Data.HashSet                         as HashSet-import           Data.List                            (mapAccumL,nubBy)-import           Data.Maybe                           (catMaybes,mapMaybe)-import           Data.Text.Lazy                       (unpack)-import qualified Data.Text.Lazy                       as T-import           Text.PrettyPrint.Leijen.Text.Monadic--import           CLaSH.Netlist.Types-import           CLaSH.Netlist.Util-import           CLaSH.Util                           (clog2, curLoc, makeCached, (<:>))--type VHDLM a = State VHDLState a---- | Generate VHDL for a Netlist component-genVHDL :: Component -> VHDLM (String,Doc)-genVHDL c = (unpack cName,) A.<$> vhdl-  where-    cName   = componentName c-    vhdl    = tyImports <$$> linebreak <>-              entity c <$$> linebreak <>-              architecture c---- | Generate a VHDL package containing type definitions for the given HWTypes-mkTyPackage :: [HWType]-            -> VHDLM Doc-mkTyPackage hwtys =-   "library IEEE;" <$>-   "use IEEE.STD_LOGIC_1164.ALL;" <$>-   "use IEEE.NUMERIC_STD.ALL;" <$$> linebreak <>-   "package" <+> "types" <+> "is" <$>-      indent 2 ( packageDec <$>-                 vcat (sequence funDecs)-               ) <>-      (case showDecs of-         [] -> empty-         _  -> linebreak <$>-               "-- pragma translate_off" <$>-               indent 2 (vcat (sequence showDecs)) <$>-               "-- pragma translate_on"-      ) <$>-   "end" <> semi <> packageBodyDec-  where-    usedTys     = nubBy eqHWTy $ concatMap mkUsedTys hwtys-    needsDec    = nubBy eqHWTy (hwtys ++ filter needsTyDec usedTys)-    hwTysSorted = topSortHWTys needsDec-    packageDec  = vcat $ mapM tyDec hwTysSorted-    (funDecs,funBodies) = unzip . catMaybes $ map funDec (nubBy eqIndexTy usedTys)-    (showDecs,showBodies) = unzip $ map mkToStringDecls hwTysSorted--    packageBodyDec :: VHDLM Doc-    packageBodyDec = case (funBodies,showBodies) of-        ([],[]) -> empty-        _  -> linebreak <$>-              "package" <+> "body" <+> "types" <+> "is" <$>-                indent 2 (vcat (sequence funBodies)) <$>-                linebreak <>-                "-- pragma translate_off" <$>-                indent 2 (vcat (sequence showBodies)) <$>-                "-- pragma translate_on" <$>-              "end" <> semi--    eqIndexTy :: HWType -> HWType -> Bool-    eqIndexTy (Index _) (Index _) = True-    eqIndexTy _ _ = False--    eqHWTy :: HWType -> HWType -> Bool-    eqHWTy (Vector _ elTy1) (Vector _ elTy2) = case (elTy1,elTy2) of-      (Sum _ _,Sum _ _)    -> typeSize elTy1 == typeSize elTy2-      (Unsigned n,Sum _ _) -> n == typeSize elTy2-      (Sum _ _,Unsigned n) -> typeSize elTy1 == n-      (Index u,Unsigned n) -> clog2 (max 2 u) == n-      (Unsigned n,Index u) -> clog2 (max 2 u) == n-      _ -> elTy1 == elTy2-    eqHWTy ty1 ty2 = ty1 == ty2--mkUsedTys :: HWType-        -> [HWType]-mkUsedTys v@(Vector _ 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@(Product _ tys) = let ti = HashMap.lookupDefault (error $ $(curLoc) ++ "Product") t nodesI-                             in mapMaybe (\ty -> liftM (ti,,()) (HashMap.lookup (mkVecZ 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 (mkVecZ ty) nodesI)) tys) ctys-    edge _                 = []--mkVecZ :: HWType -> HWType-mkVecZ (Vector _ elTy) = Vector 0 elTy-mkVecZ t               = t--needsTyDec :: HWType -> Bool-needsTyDec (Vector _ _)   = True-needsTyDec (Product _ _)  = True-needsTyDec (SP _ _)       = True-needsTyDec Bool           = True-needsTyDec Integer        = True-needsTyDec _              = False--tyDec :: HWType -> VHDLM Doc-tyDec (Vector _ elTy) = "type" <+> "array_of_" <> tyName elTy <+> "is array (integer range <>) of" <+> vhdlType elTy <> semi--tyDec ty@(Product _ tys) = prodDec-  where-    prodDec = "type" <+> tName <+> "is record" <$>-                indent 2 (vcat $ zipWithM (\x y -> x <+> colon <+> y <> semi) selNames selTys) <$>-              "end record" <> semi--    tName    = tyName ty-    selNames = map (\i -> tName <> "_sel" <> int i) [0..]-    selTys   = map vhdlType tys--tyDec _ = empty--funDec :: HWType -> Maybe (VHDLM Doc,VHDLM Doc)-funDec Bool = Just-  ( "function" <+> "toSLV" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "std_logic_vector" <> semi <$>-    "function" <+> "fromSL" <+> parens ("sl" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "boolean" <> semi-  , "function" <+> "toSLV" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "std_logic_vector" <+> "is" <$>-    "begin" <$>-      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-                                ]) <$>-    "end" <> semi <$>-    "function" <+> "fromSL" <+> parens ("sl" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "boolean" <+> "is" <$>-    "begin" <$>-      indent 2 (vcat $ sequence ["if" <+> "sl" <+> "=" <+> dquotes (int 1) <+> "then"-                                ,   indent 2 ("return" <+> "true" <> semi)-                                ,"else"-                                ,   indent 2 ("return" <+> "false" <> semi)-                                ,"end" <+> "if" <> semi-                                ]) <$>-    "end" <> semi-  )--funDec Integer = Just-  ( "function" <+> "to_integer" <+> parens ("i" <+> colon <+> "in" <+> "integer") <+> "return" <+> "integer" <> semi-  , "function" <+> "to_integer" <+> parens ("i" <+> colon <+> "in" <+> "integer") <+> "return" <+> "integer" <+> "is" <$>-    "begin" <$>-      indent 2 ("return" <+> "i" <> semi) <$>-    "end" <> semi-  )--funDec (Index _) =  Just-  ( "function" <+> "max" <+> parens ("left, right: in integer") <+> "return integer" <> semi-  , "function" <+> "max" <+> parens ("left, right: in integer") <+> "return integer" <+> "is" <$>-    "begin" <$>-      indent 2 (vcat $ sequence [ "if" <+> "left > right" <+> "then return left" <> semi-                                , "else return right" <> semi-                                , "end if" <> semi-                                ]) <$>-    "end" <> semi-  )--funDec _ = Nothing--mkToStringDecls :: HWType -> (VHDLM Doc, VHDLM Doc)-mkToStringDecls t@(Product _ elTys) =-  ( "function to_string" <+> parens ("value :" <+> vhdlType t) <+> "return STRING" <> semi-  , "function to_string" <+> parens ("value :" <+> vhdlType t) <+> "return STRING is" <$>-    "begin" <$>-    indent 2 ("return" <+> parens (hcat (punctuate " & " elTyPrint)) <> semi) <$>-    "end function to_string;"-  )-  where-    elTyPrint = forM [0..(length elTys - 1)]-                     (\i -> "to_string" <>-                            parens ("value." <> vhdlType t <> "_sel" <> int i))-mkToStringDecls t@(Vector _ elTy) =-  ( "function to_string" <+> parens ("value : " <+> vhdlTypeMark t) <+> "return STRING" <> semi-  , "function to_string" <+> parens ("value : " <+> vhdlTypeMark t) <+> "return STRING is" <$>-      indent 2-        ( "alias ivalue    : " <+> vhdlTypeMark t <> "(1 to value'length) is value;" <$>-          "variable result : STRING" <> parens ("1 to value'length * " <> int (typeSize elTy)) <> semi-        ) <$>-    "begin" <$>-      indent 2-        ("for i in ivalue'range loop" <$>-            indent 2-              (  "result" <> parens (parens ("(i - 1) * " <> int (typeSize elTy)) <+> "+ 1" <+>-                                             "to i*" <> int (typeSize elTy)) <+>-                          ":= to_string" <> parens (if elTy == Bool then "toSLV(ivalue(i))" else "ivalue(i)") <> semi-              ) <$>-         "end loop;" <$>-         "return result;"-        ) <$>-    "end function to_string;"-  )-mkToStringDecls _ = (empty,empty)--tyImports :: VHDLM Doc-tyImports =-  punctuate' semi $ sequence-    [ "library IEEE"-    , "use IEEE.STD_LOGIC_1164.ALL"-    , "use IEEE.NUMERIC_STD.ALL"-    , "use IEEE.MATH_REAL.ALL"-    , "use work.all"-    , "use work.types.all"-    ]---entity :: Component -> VHDLM Doc-entity c = do-    rec (p,ls) <- fmap unzip (ports (maximum ls))-    "entity" <+> text (componentName c) <+> "is" <$>-      (case p of-         [] -> empty-         _  -> indent 2 ("port" <>-                         parens (align $ vcat $ punctuate semi (A.pure p)) <>-                         semi)-      ) <$>-      "end" <> semi-  where-    ports l = sequence-            $ [ (,fromIntegral $ T.length i) A.<$> (fill l (text i) <+> colon <+> "in" <+> vhdlType ty)-              | (i,ty) <- inputs c ] ++-              [ (,fromIntegral $ T.length i) A.<$> (fill l (text i) <+> colon <+> "in" <+> vhdlType ty)-              | (i,ty) <- hiddenPorts c ] ++-              [ (,fromIntegral $ T.length (fst $ output c)) A.<$> (fill l (text (fst $ output c)) <+> colon <+> "out" <+> vhdlType (snd $ output c))-              ]--architecture :: Component -> VHDLM Doc-architecture c =-  nest 2-    ("architecture structural of" <+> text (componentName c) <+> "is" <$$>-     decls (declarations c)) <$$>-  nest 2-    ("begin" <$$>-     insts (declarations c)) <$$>-    "end" <> semi---- | Convert a Netlist HWType to a VHDL type-vhdlType :: HWType -> VHDLM Doc-vhdlType hwty = do-  when (needsTyDec hwty) (_1 %= HashSet.insert (mkVecZ hwty))-  vhdlType' hwty--vhdlType' :: HWType -> VHDLM Doc-vhdlType' Bool            = "boolean"-vhdlType' (Clock _)       = "std_logic"-vhdlType' (Reset _)       = "std_logic"-vhdlType' Integer         = "integer"-vhdlType' (BitVector n)   = case n of-                              0 -> "std_logic_vector (0 downto 1)"-                              _ -> "std_logic_vector" <> parens (int (n-1) <+> "downto 0")-vhdlType' (Index u)       = "unsigned" <> parens (int (clog2 (max 2 u) - 1) <+> "downto 0")-vhdlType' (Signed n)      = if n == 0 then "signed (0 downto 1)"-                                      else "signed" <> parens (int (n-1) <+> "downto 0")-vhdlType' (Unsigned n)    = if n == 0 then "unsigned (0 downto 1)"-                                      else "unsigned" <> parens ( int (n-1) <+> "downto 0")-vhdlType' (Vector n elTy) = "array_of_" <> tyName elTy <> parens ("0 to " <> int (n-1))-vhdlType' t@(SP _ _)      = "std_logic_vector" <> parens (int (typeSize t - 1) <+> "downto 0")-vhdlType' t@(Sum _ _)     = case typeSize t of-                              0 -> "unsigned (0 downto 1)"-                              n -> "unsigned" <> parens (int (n -1) <+> "downto 0")-vhdlType' t@(Product _ _) = tyName t-vhdlType' Void            = "std_logic_vector" <> parens (int (-1) <+> "downto 0")---- | Convert a Netlist HWType to the root of a VHDL type-vhdlTypeMark :: HWType -> VHDLM Doc-vhdlTypeMark hwty = do-  when (needsTyDec hwty) (_1 %= HashSet.insert (mkVecZ hwty))-  vhdlTypeMark' hwty-  where-    vhdlTypeMark' Bool            = "boolean"-    vhdlTypeMark' (Clock _)       = "std_logic"-    vhdlTypeMark' (Reset _)       = "std_logic"-    vhdlTypeMark' Integer         = "integer"-    vhdlTypeMark' (BitVector _)   = "std_logic_vector"-    vhdlTypeMark' (Index _)       = "unsigned"-    vhdlTypeMark' (Signed _)      = "signed"-    vhdlTypeMark' (Unsigned _)    = "unsigned"-    vhdlTypeMark' (Vector _ elTy) = "array_of_" <> tyName elTy-    vhdlTypeMark' (SP _ _)        = "std_logic_vector"-    vhdlTypeMark' (Sum _ _)       = "unsigned"-    vhdlTypeMark' t@(Product _ _) = tyName t-    vhdlTypeMark' t               = error $ $(curLoc) ++ "vhdlTypeMark: " ++ show t--tyName :: HWType -> VHDLM Doc-tyName Integer           = "integer"-tyName Bool              = "boolean"-tyName (Vector n elTy)   = "array_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 _ _)       = "unsigned_" <> int (typeSize t)-tyName t@(Product _ _)   = makeCached t _3 prodName-  where-    prodName = do i <- _2 <<%= (+1)-                  "product" <> int i-tyName t@(SP _ _)        = "std_logic_vector_" <> int (typeSize t)-tyName _ = empty---- | Convert a Netlist HWType to an error VHDL value for that type-vhdlTypeErrValue :: HWType -> VHDLM Doc-vhdlTypeErrValue Bool                = "true"-vhdlTypeErrValue Integer             = "integer'high"-vhdlTypeErrValue (BitVector _)       = "(others => 'X')"-vhdlTypeErrValue (Index _)           = "(others => 'X')"-vhdlTypeErrValue (Signed _)          = "(others => 'X')"-vhdlTypeErrValue (Unsigned _)        = "(others => 'X')"-vhdlTypeErrValue (Vector _ elTy)     = parens ("others" <+> rarrow <+> vhdlTypeErrValue elTy)-vhdlTypeErrValue (SP _ _)            = "(others => 'X')"-vhdlTypeErrValue (Sum _ _)           = "(others => 'X')"-vhdlTypeErrValue (Product _ elTys)   = tupled $ mapM vhdlTypeErrValue elTys-vhdlTypeErrValue (Reset _)           = "'X'"-vhdlTypeErrValue (Clock _)           = "'X'"-vhdlTypeErrValue Void                = "(0 downto 1 => 'X')"--decls :: [Declaration] -> VHDLM Doc-decls [] = empty-decls ds = do-    rec (dsDoc,ls) <- fmap (unzip . catMaybes) $ mapM (decl (maximum ls)) ds-    case dsDoc of-      [] -> empty-      _  -> vcat (punctuate semi (A.pure dsDoc)) <> semi--decl :: Int ->  Declaration -> VHDLM (Maybe (Doc,Int))-decl l (NetDecl id_ ty netInit) = Just A.<$> (,fromIntegral (T.length id_)) A.<$>-  "signal" <+> fill l (text id_) <+> colon <+> vhdlType ty <> (maybe empty (\e -> " :=" <+> expr False e) netInit)--decl _ _ = return Nothing--insts :: [Declaration] -> VHDLM Doc-insts [] = empty-insts is = vcat . punctuate linebreak . 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 $-  text id_ <+> larrow <+> expr False e <> semi--inst (CondAssignment id_ scrut es) = fmap Just $-  text id_ <+> larrow <+> align (vcat (conds es)) <> semi-    where-      conds :: [(Maybe Expr,Expr)] -> VHDLM [Doc]-      conds []                = return []-      conds [(_,e)]           = expr False e <:> return []-      conds ((Nothing,e):_)   = expr False e <:> return []-      conds ((Just c ,e):es') = (expr False e <+> "when" <+> parens (expr True scrut <+> "=" <+> expr True c) <+> "else") <:> conds es'--inst (InstDecl nm lbl pms) = fmap Just $-    nest 2 $ text lbl <+> colon <+> "entity"-              <+> text nm <$$> pms' <> semi-  where-    pms' = do-      rec (p,ls) <- fmap unzip $ sequence [ (,fromIntegral (T.length i)) A.<$> fill (maximum ls) (text i) <+> "=>" <+> expr False e | (i,e) <- pms]-      nest 2 $ "port map" <$$> tupled (A.pure p)--inst (BlackBoxD bs) = fmap Just $ string bs--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)                      = text 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)))) = text id_ <> dot <> tyName ty <> "_sel" <> int fI-expr _ (Identifier id_ (Just (DC (ty@(SP _ _),_)))) = text id_ <> parens (int start <+> "downto" <+> int end)-  where-    start = typeSize ty - 1-    end   = typeSize ty - conSize ty--expr _ (Identifier id_ (Just _)) = text id_-expr _ (DataCon ty@(Vector 1 _) _ [e])           = vhdlTypeMark ty <> "'" <> parens (int 0 <+> rarrow <+> expr False e)-expr _ e@(DataCon ty@(Vector _ elTy) _ [e1,e2])     = vhdlTypeMark ty <> "'" <> case vectorChain e of-                                                     Just es -> tupled (mapM (expr False) es)-                                                     Nothing -> parens (vhdlTypeMark elTy <> "'" <> parens (expr False e1) <+> "&" <+> expr False e2)-expr _ (DataCon ty@(SP _ args) (Just (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 -- (map (expr False) es)-    extraArg   = case typeSize ty - dcSize of-                   0 -> []-                   n -> [exprLit (Just (ty,n)) (NumLit 0)]-    assignExpr = "std_logic_vector'" <> parens (hcat $ punctuate " & " $ sequence (dcExpr:argExprs ++ extraArg))--expr _ (DataCon ty@(Sum _ _) (Just (DC (_,i))) []) = "to_unsigned" <> tupled (sequence [int i,int (typeSize ty)])-expr _ (DataCon ty@(Product _ _) _ es)             = tupled $ zipWithM (\i e -> tName <> "_sel" <> int i <+> rarrow <+> expr False e) [0..] es-  where-    tName = tyName ty--expr b (BlackBoxE bs (Just (DC (ty@(SP _ _),_)))) = parenIf b $ parens (string bs) <> parens (int start <+> "downto" <+> int end)-  where-    start = typeSize ty - 1-    end   = typeSize ty - conSize ty-expr b (BlackBoxE bs _) = parenIf b $ string bs--expr _ (DataTag Bool (Left e))           = "false when" <+> expr False e <+> "= 0 else true"-expr _ (DataTag Bool (Right e))          = "1 when" <+> expr False e <+> "else 0"-expr _ (DataTag hty@(Sum _ _) (Left e))  = "to_unsigned" <> tupled (sequence [expr False e,int (typeSize hty)])-expr _ (DataTag (Sum _ _) (Right e))     = "to_integer" <> parens (expr False e)--expr _ (DataTag (Product _ _) (Right _)) = int 0-expr _ (DataTag hty@(SP _ _) (Right e))  = "to_integer" <> parens-                                                ("unsigned" <> parens-                                                (expr False e <> parens-                                                (int start <+> "downto" <+> int end)))-  where-    start = typeSize hty - 1-    end   = typeSize hty - conSize hty--expr _ (DataTag (Vector 0 _) (Right _)) = int 0-expr _ (DataTag (Vector _ _) (Right _)) = int 1--expr _ _ = 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 _ _) Nothing _)        = Just []-vectorChain (DataCon (Vector 1 _) (Just _) [e])     = Just [e]-vectorChain (DataCon (Vector _ _) (Just _) [e1,e2]) = Just e1 <:> vectorChain e2-vectorChain _                                       = Nothing--exprLit :: Maybe (HWType,Size) -> Literal -> VHDLM Doc-exprLit Nothing       (NumLit i)   = integer i-exprLit (Just (hty,sz)) (NumLit i) = case hty of-                                       Unsigned _  -> "unsigned'" <> parens blit-                                       Signed   _  -> "signed'" <> parens blit-                                       BitVector _ -> "std_logic_vector'" <> parens blit-                                       _           -> blit--  where-    blit = bits (toBits sz i)-exprLit _             (BoolLit t)  = if t then "true" else "false"-exprLit _             (BitLit b)   = squotes $ bit_char b-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] -> VHDLM Doc-bits = dquotes . hcat . mapM bit_char--bit_char :: Bit -> VHDLM Doc-bit_char H = char '1'-bit_char L = char '0'-bit_char U = char 'U'-bit_char Z = char 'Z'--toSLV :: HWType -> Expr -> VHDLM Doc-toSLV Bool         e = "toSLV" <> parens (expr False e)-toSLV Integer      e = "std_logic_vector" <> parens ("to_signed" <> tupled (sequence [expr False e,int 32]))-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 (Sum _ _)    e = "std_logic_vector" <> parens (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 (displayT . renderOneLine) ) [text id_ <> dot <> tName <> "_sel" <> int i | i <- [0..(length tys)-1]]-    selIds   = map (fmap (\n -> Identifier n Nothing)) selNames-toSLV (Product _ tys) (DataCon _ _ es) = encloseSep lparen rparen " & " (zipWithM toSLV tys es)-toSLV (SP _ _) e = expr False e-toSLV (Vector n elTy) (Identifier id_ Nothing) = do-    selIds' <- sequence (reverse selIds)-    parens (encloseSep lparen rparen " & " (mapM (toSLV elTy) selIds'))-  where-    selNames = map (fmap (displayT . renderOneLine) ) $ reverse [text id_ <> parens (int i) | i <- [0 .. (n-1)]]-    selIds   = map (fmap (`Identifier` Nothing)) selNames-toSLV (Vector n elTy) (DataCon _ _ es) = encloseSep lparen rparen " & " (zipWithM toSLV [elTy,Vector (n-1) elTy] es)-toSLV hty      e = error $ $(curLoc) ++  "toSLV: ty:" ++ show hty ++ "\n expr: " ++ show e--fromSLV :: HWType -> Identifier -> Int -> Int -> VHDLM Doc-fromSLV Bool              id_ start _   = "fromSL" <> parens (text id_ <> parens (int start))-fromSLV Integer           id_ start end = "to_integer" <> parens (fromSLV (Signed 32) id_ start end)-fromSLV (BitVector _)     id_ start end = text id_ <> parens (int start <+> "downto" <+> int end)-fromSLV (Index _)         id_ start end = "unsigned" <> parens (text id_ <> parens (int start <+> "downto" <+> int end))-fromSLV (Signed _)        id_ start end = "signed" <> parens (text id_ <> parens (int start <+> "downto" <+> int end))-fromSLV (Unsigned _)      id_ start end = "unsigned" <> parens (text id_ <> parens (int start <+> "downto" <+> int end))-fromSLV (Sum _ _)         id_ start end = "unsigned" <> parens (text id_ <> parens (int start <+> "downto" <+> int end))-fromSLV t@(Product _ tys) id_ start _   = 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 = text id_ <> parens (int start <+> "downto" <+> int end)-fromSLV (Vector n elTy)   id_ start _   = tupled (fmap reverse args)-  where-    argLength = typeSize elTy-    starts    = take (n + 1) $ iterate (subtract argLength) start-    ends      = map (+1) (tail starts)-    args      = zipWithM (fromSLV elTy id_) starts ends-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 -> m Doc -> m Doc-parenIf True  = parens-parenIf False = id--punctuate' :: Monad m => m Doc -> m [Doc] -> m Doc-punctuate' s d = vcat (punctuate s d) <> s

@@ -3,38 +3,40 @@ -- | Turn CoreHW terms into normalized CoreHW Terms module CLaSH.Normalize where -import           Control.Concurrent.Supply (Supply)-import           Control.Lens              ((.=))-import qualified Control.Lens              as Lens-import qualified Control.Monad.State       as State-import           Data.Either               (partitionEithers)-import           Data.HashMap.Strict       (HashMap)-import qualified Data.HashMap.Strict       as HashMap-import           Data.List                 (mapAccumL)-import qualified Data.Map                  as Map-import qualified Data.Maybe                as Maybe-import qualified Data.Set                  as Set-import           Unbound.LocallyNameless   (unembed)+import           Control.Concurrent.Supply        (Supply)+import           Control.Lens                     ((.=))+import qualified Control.Lens                     as Lens+import qualified Control.Monad.State              as State+import           Data.Either                      (partitionEithers)+import           Data.HashMap.Strict              (HashMap)+import qualified Data.HashMap.Strict              as HashMap+import           Data.List                        (mapAccumL)+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           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)-import           CLaSH.Core.TyCon          (TyCon, TyConName)-import           CLaSH.Core.Util           (collectArgs, mkApps, termType)-import           CLaSH.Core.Var            (Id,varName)-import           CLaSH.Netlist.Types       (HWType)-import           CLaSH.Netlist.Util        (splitNormalized)+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)+import           CLaSH.Core.TyCon                 (TyCon, TyConName)+import           CLaSH.Core.Util                  (collectArgs, mkApps, termType)+import           CLaSH.Core.Var                   (Id,varName)+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.Transformations  (bindConstantVar, caseCon,+                                                   reduceConst, topLet ) import           CLaSH.Normalize.Types import           CLaSH.Normalize.Util-import           CLaSH.Rewrite.Combinators ((>->),(!->),repeatR,topdownR)-import           CLaSH.Rewrite.Types       (DebugLevel (..), RewriteState (..),-                                            bindings, dbgLevel, tcCache)-import           CLaSH.Rewrite.Util        (liftRS, runRewrite,-                                            runRewriteSession)+import           CLaSH.Rewrite.Combinators        ((>->),(!->),repeatR,topdownR)+import           CLaSH.Rewrite.Types              (DebugLevel (..), RewriteState (..),+                                                   bindings, dbgLevel, tcCache)+import           CLaSH.Rewrite.Util               (liftRS, runRewrite,+                                                   runRewriteSession) import           CLaSH.Util  -- | Run a NormalizeSession in a given environment@@ -65,7 +67,7 @@                   100                   HashMap.empty                   100-                  (error "Report as bug: no curFun")+                  (error $ $(curLoc) ++ "Report as bug: no curFun")   normalize :: [TmName]@@ -89,9 +91,9 @@                   tcm <- Lens.use tcCache                   ty' <- termType tcm tm'                   return (ty',tm')-      let usedBndrs = termFreeIds (snd tmNorm)+      let usedBndrs = Lens.toListOf termFreeIds (snd tmNorm)       if nm `elem` usedBndrs-        then error $ $(curLoc) ++ "Expr belonging to bndr: " ++ nmS ++ " remains recursive after normalization."+        then error $ $(curLoc) ++ "Expr belonging to bndr: " ++ nmS ++ " (:: " ++ showDoc (fst tmNorm) ++ ") remains recursive after normalization:\n" ++ showDoc (snd tmNorm)         else do           prevNorm <- fmap HashMap.keys $ liftRS $ Lens.use normalized           let toNormalize = filter (`notElem` prevNorm) usedBndrs@@ -124,7 +126,7 @@   let cg = callGraph [] norm topEntity   in  case recursiveComponents cg of        []  -> norm-       rcs -> error $ "Callgraph after normalisation contains following recursive cycles: " ++ show rcs+       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:@@ -150,8 +152,8 @@                             [] -> CLeaf   (root,rootTm)                             _  -> CBranch (root,rootTm) other   where-    rootTm = Maybe.fromMaybe (error $ show root ++ " is not a global binder") $ HashMap.lookup root bindingMap-    used   = Set.toList $ termFreeIds $ snd rootTm+    rootTm = Maybe.fromMaybe (error $ $(curLoc) ++ show root ++ " is not a global binder") $ HashMap.lookup root bindingMap+    used   = Set.toList $ Lens.setOf termFreeIds $ snd rootTm     other  = map (mkCallTree (root:visited) bindingMap) (filter (`notElem` visited) used)  stripArgs :: [TmName]

@@ -9,7 +9,7 @@  -- | Normalisation transformation normalization :: NormRewrite-normalization = etaTL >-> constantPropgation >-> anf >-> rmDeadcode >-> bindConst >-> letTL >-> cse >-> recLetRec+normalization = etaTL >-> constantPropgation >-> anf >-> rmDeadcode >-> bindConst >-> letTL >-> evalConst >-> cse >-> recLetRec   where     etaTL      = apply "etaTL" etaExpansionTL     anf        = topdownR (apply "nonRepANF" nonRepANF) >-> apply "ANF" makeANF@@ -17,6 +17,7 @@     recLetRec  = apply "recToLetRec" recToLetRec     rmDeadcode = topdownR (apply "deadcode" deadCode)     bindConst  = topdownR (apply "bindConstantVar" bindConstantVar)+    evalConst  = topdownR (apply "evalConst" reduceConst)     cse        = topdownR (apply "CSE" simpleCSE)  constantPropgation :: NormRewrite

@@ -1,9 +1,6 @@-{-# LANGUAGE PatternGuards   #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns    #-} -{-# OPTIONS_GHC -fcontext-stack=21 #-}- -- | Transformations of the Normalization process module CLaSH.Normalize.Transformations   ( appProp@@ -38,15 +35,15 @@ import qualified Data.HashMap.Lazy           as HashMap import qualified Data.List                   as List import qualified Data.Maybe                  as Maybe-import           Unbound.LocallyNameless     (Bind, Embed (..), bind, embed,+import           Unbound.Generics.LocallyNameless     (Bind, Embed (..), bind, embed,                                               rec, unbind, unembed, unrebind,                                               unrec, name2String)-import           Unbound.LocallyNameless.Ops (unsafeUnbind)+import           Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind)  import           CLaSH.Core.DataCon          (DataCon, dcName, dcTag,                                               dcUnivTyVars) import           CLaSH.Core.FreeVars         (termFreeIds, termFreeTyVars,-                                              termFreeVars, typeFreeVars)+                                              typeFreeVars) import           CLaSH.Core.Pretty           (showDoc) import           CLaSH.Core.Subst            (substTm, substTms, substTyInTm,                                               substTysinTm)@@ -73,7 +70,7 @@   where     nonRepTest (Id idName tyE, exprE)       = (&&) <$> (not <$> (representableType <$> Lens.use typeTranslator <*> Lens.use tcCache <*> pure (unembed tyE)))-             <*> ((notElem idName . snd) <$> localFreeVars (unembed exprE))+             <*> (notElem idName <$> (Lens.toListOf <$> localFreeIds <*> pure (unembed exprE)))      nonRepTest _ = return False @@ -83,7 +80,7 @@   where     nonRepTest (Id idName tyE, exprE)       = (&&) <$> (not <$> (representableType <$> Lens.use typeTranslator <*> Lens.use tcCache <*> pure (unembed tyE)))-             <*> ((elem idName . snd) <$> localFreeVars (unembed exprE))+             <*> (elem idName <$> (Lens.toListOf <$> localFreeIds <*> pure (unembed exprE)))      nonRepTest _ = return False @@ -91,7 +88,7 @@ typeSpec :: NormRewrite typeSpec ctx e@(TyApp e1 ty)   | (Var _ _,  args) <- collectArgs e1-  , null $ typeFreeVars ty+  , null $ Lens.toListOf typeFreeVars ty   , (_, []) <- Either.partitionEithers args   = specializeNorm False ctx e @@ -102,7 +99,7 @@ nonRepSpec ctx e@(App e1 e2)   | (Var _ _, args) <- collectArgs e1   , (_, [])     <- Either.partitionEithers args-  , null $ termFreeTyVars e2+  , null $ Lens.toListOf termFreeTyVars e2   = R $ do tcm <- Lens.use tcCache            e2Ty <- termType tcm e2            localVar <- isLocalVar e2@@ -179,7 +176,7 @@     case dcAltM of       Just (DataPat _ pxs, e) ->         let (tvs,xs) = unrebind pxs-            fvs = termFreeIds e+            fvs = Lens.toListOf termFreeIds e             (binds,_) = List.partition ((`elem` fvs) . varName . fst)                       $ zip xs (Either.lefts args)             e' = case binds of@@ -212,7 +209,8 @@     DefaultPat    -> changed altE     LitPat _      -> changed altE     DataPat _ pxs -> let (tvs,xs)   = unrebind pxs-                         (ftvs,fvs) = termFreeVars altE+                         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@@ -281,7 +279,7 @@ deadCode :: NormRewrite deadCode _ e@(Letrec binds) = R $ do     (xes, body) <- fmap (first unrec) $ unbind binds-    let bodyFVs = termFreeIds body+    let bodyFVs = Lens.toListOf termFreeIds body         (xesUsed,xesOther) = List.partition                                ( (`elem` bodyFVs )                                . varName@@ -294,7 +292,7 @@   where     findUsedBndrs used []      _     = used     findUsedBndrs used explore other =-      let fvsUsed = concatMap (termFreeIds . unembed . snd) explore+      let fvsUsed = concatMap (Lens.toListOf termFreeIds . unembed . snd) explore           (explore',other') = List.partition                                 ( (`elem` fvsUsed)                                 . varName@@ -323,7 +321,7 @@         bodyMaybe <- fmap (HashMap.lookup f) $ Lens.use bindings         case bodyMaybe of           -- Don't inline recursive expressions-          Just (_,body) -> if f `elem` (termFreeIds body)+          Just (_,body) -> if f `elem` (Lens.toListOf termFreeIds body)                               then return e                               else changed (mkApps body args)           _ -> return e@@ -337,7 +335,7 @@       bodyMaybe <- fmap (HashMap.lookup f) $ Lens.use bindings       case bodyMaybe of         -- Don't inline recursive expressions-        Just (_,body) -> if f `elem` (termFreeIds body)+        Just (_,body) -> if f `elem` (Lens.toListOf termFreeIds body)                             then return e                             else changed body         _ -> return e@@ -373,7 +371,7 @@ constantSpec ctx e@(App e1 e2)   | (Var _ _, args) <- collectArgs e1   , (_, [])     <- Either.partitionEithers args-  , null $ termFreeTyVars e2+  , null $ Lens.toListOf termFreeTyVars e2   , isConstant e2   = specializeNorm False ctx e @@ -512,7 +510,7 @@ -- 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.Types.:-" = return e+  | name2String (dcName $ unembed dc) == "CLaSH.Signal.Internal.:-" = return e  collectANF ctx (Case subj ty alts) = do     localVar     <- liftNormR $ isLocalVar subj@@ -574,7 +572,7 @@       then do         argTy <- ( return                  . fst-                 . Maybe.fromMaybe (error "etaExpansion splitFunTy")+                 . Maybe.fromMaybe (error $ $(curLoc) ++ "etaExpansion splitFunTy")                  . splitFunTy tcm                  <=< termType tcm                  ) e

@@ -1,7 +1,5 @@-{-# LANGUAGE LambdaCase   #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -fcontext-stack=21 #-}+{-# LANGUAGE LambdaCase      #-}+{-# LANGUAGE TemplateHaskell #-}  -- | Utility functions used by the normalisation transformations module CLaSH.Normalize.Util where@@ -14,7 +12,8 @@ import qualified Data.HashMap.Lazy       as HashMap import qualified Data.Maybe              as Maybe import qualified Data.Set                as Set-import           Unbound.LocallyNameless (Fresh, bind, embed, rec)+import qualified Data.Set.Lens           as Lens+import           Unbound.Generics.LocallyNameless (Fresh, bind, embed, rec)  import           CLaSH.Core.FreeVars     (termFreeIds) import           CLaSH.Core.Var          (Var (Id))@@ -24,6 +23,7 @@ import           CLaSH.Core.Util         (collectArgs, isPolyFun) import           CLaSH.Normalize.Types import           CLaSH.Rewrite.Util      (specialise)+import           CLaSH.Util              (curLoc)  -- | Determine if a function is already inlined in the context of the 'NetlistMonad' alreadyInlined :: TmName@@ -71,7 +71,7 @@ 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 $ termFreeIds (snd rootTm)+    used   = Set.toList $ Lens.setOf termFreeIds (snd rootTm)     node   = (root,used)     other  = concatMap (callGraph (root:visited) bindingMap) (filter (`notElem` visited) used) @@ -103,7 +103,7 @@     doms  = dominator depGraph cyc     block = blockSink bndrs doms (0,root) -lambdaDrop _ _ [] = error "Can't lambdadrop empty cycle"+lambdaDrop _ _ [] = error $ $(curLoc) ++ "Can't lambdadrop empty cycle"  dominator :: HashMap TmName [TmName] -- ^ Dependency Graph           -> [TmName]                -- ^ Recursive block

@@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase        #-} {-# LANGUAGE OverloadedStrings #-}+ -- | Type and instance definitions for Primitive module CLaSH.Primitives.Types where @@ -25,6 +26,7 @@   { name     :: S.Text -- ^ Name of the primitive   , primType :: Text -- ^ Additional information   }+  deriving Show  instance FromJSON Primitive where   parseJSON (Object v) = case H.toList v of

@@ -1,13 +1,14 @@ {-# LANGUAGE ScopedTypeVariables #-}+ -- | Rewriting combinators and traversals module CLaSH.Rewrite.Combinators where  import           Control.Monad               ((<=<), (>=>)) import qualified Control.Monad.Writer        as Writer import qualified Data.Monoid                 as Monoid-import           Unbound.LocallyNameless     (Embed, Fresh, bind, embed, rec,+import           Unbound.Generics.LocallyNameless     (Embed, Fresh, bind, embed, rec,                                               unbind, unembed, unrec)-import           Unbound.LocallyNameless.Ops (unsafeUnbind)+import           Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind)  import           CLaSH.Core.Term             (Pat, Term (..)) import           CLaSH.Core.Util             (patIds)

@@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell            #-}-{-# LANGUAGE TypeSynonymInstances       #-}  -- | Type and instance definitions for Rewrite modules module CLaSH.Rewrite.Types where@@ -13,7 +12,7 @@ import Control.Monad.Writer      (MonadWriter, WriterT) import Data.HashMap.Strict       (HashMap) import Data.Monoid               (Any)-import Unbound.LocallyNameless   (Fresh, FreshMT)+import Unbound.Generics.LocallyNameless   (Fresh, FreshMT)  import CLaSH.Core.Term           (Term, TmName) import CLaSH.Core.Type           (Type)

@@ -1,14 +1,6 @@-{-# LANGUAGE DeriveFoldable    #-}-{-# LANGUAGE DeriveFunctor     #-}-{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE Rank2Types        #-} {-# LANGUAGE TemplateHaskell   #-}-{-# LANGUAGE TupleSections     #-}-{-# LANGUAGE TypeOperators     #-}-{-# LANGUAGE ViewPatterns      #-} -{-# OPTIONS_GHC -fcontext-stack=21 #-}- -- | Utilities for rewriting: e.g. inlining, specialisation, etc. module CLaSH.Rewrite.Util where @@ -23,24 +15,25 @@ 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 qualified Data.Monoid                 as Monoid import qualified Data.Set                    as Set-import           Unbound.LocallyNameless     (Collection (..), Fresh, bind,+import qualified Data.Set.Lens               as Lens+import           Unbound.Generics.LocallyNameless     (Fresh, bind,                                               embed, makeName, name2String,                                               rebind, rec, string2Name, unbind,                                               unembed, unrec)-import qualified Unbound.LocallyNameless     as Unbound-import           Unbound.Util                (filterC)+import qualified Unbound.Generics.LocallyNameless     as Unbound  import           CLaSH.Core.DataCon          (dataConInstArgTys)-import           CLaSH.Core.FreeVars         (termFreeVars, typeFreeVars)+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, TyName, Type (..),+import           CLaSH.Core.Type             (KindOrType, Type (..),                                               TypeView (..), transparentTy,                                               typeKind, coreView) import           CLaSH.Core.Util             (Delta, Gamma, collectArgs,@@ -77,9 +70,11 @@   Monad.when (lvl > DebugNone && hasChanged) $ do     tcm                  <- Lens.use tcCache     beforeTy             <- fmap transparentTy $ termType tcm expr-    (beforeFTV,beforeFV) <- localFreeVars expr+    let beforeFTV        = Lens.setOf termFreeTyVars expr+    beforeFV             <- Lens.setOf <$> localFreeIds <*> pure expr     afterTy              <- fmap transparentTy $ termType tcm expr'-    (afterFTV,afterFV)   <- localFreeVars 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 $@@ -102,7 +97,7 @@             ) (return ())    Monad.when (lvl >= DebugApplied && not hasChanged && expr /= expr') $-    error $ "Expression changed without notice(" ++ name ++  "): before" ++ before ++ "\nafter:\n" ++ after+    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") $@@ -250,7 +245,7 @@   where     val      = unembed valE     bndrName = varName bndr-    selfRef  = (bndrName `elem`) . snd $ termFreeVars val+    selfRef  = bndrName `elem` Lens.toListOf termFreeIds val     (res',rest',others') = if selfRef       then (res,rest,(bndr,valE):others)       else ( substTm (varName bndr) val res@@ -266,19 +261,11 @@  -- | Calculate the /local/ free variable of an expression: the free variables -- that are not bound in the global environment.-localFreeVars :: (Functor m, Monad m, Collection c)-              => Term-              -> RewriteMonad m (c TyName,c TmName)-localFreeVars term = do+localFreeIds :: (Applicative f, Lens.Contravariant f, Monad m)+             => RewriteMonad m ((TmName -> f TmName) -> Term -> f Term)+localFreeIds = do   globalBndrs <- Lens.use bindings-  let (tyFVs,tmFVs) = termFreeVars term-  return ( tyFVs-         , filterC-         $ cmap (\v -> if v `HML.member` globalBndrs-                       then Nothing-                       else Just v-                ) tmFVs-         )+  return ((termFreeIds . Lens.filtered (not . (`HML.member` globalBndrs))))  -- | Lift the binders in a let-binding to a global function that have a certain -- property@@ -313,7 +300,8 @@   let ty = unembed tyE       e  = unembed eE   -- Get all local FVs, excluding the 'idName' from the let-binding-  (localFTVs,localFVs) <- fmap (Set.toList *** Set.toList) $ localFreeVars e+  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'@@ -517,8 +505,8 @@                     -> Either Term Type                     -> RewriteMonad m ([Either Id TyVar],[Either Term Type]) specArgBndrsAndVars ctx specArg = do-  (specFTVs,specFVs) <- fmap (Set.toList *** Set.toList) $-                        either localFreeVars (pure . (,emptyC) . typeFreeVars) specArg+  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

@@ -2,8 +2,6 @@ {-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE Rank2Types           #-} {-# LANGUAGE TupleSections        #-}-{-# LANGUAGE TypeOperators        #-}-{-# LANGUAGE TypeSynonymInstances #-}  {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -32,8 +30,8 @@ import Control.Lens import Debug.Trace                    (trace) import qualified Language.Haskell.TH  as TH-import Unbound.LocallyNameless        (Embed(..))-import Unbound.LocallyNameless.Name   (Name(..))+import Unbound.Generics.LocallyNameless        (Embed(..))+import Unbound.Generics.LocallyNameless.Name   (Name(..))  #ifdef CABAL import qualified Paths_clash_lib      (version)@@ -51,8 +49,8 @@     return supply  instance Hashable (Name a) where-  hashWithSalt salt (Nm _ (str,int)) = hashWithSalt salt (hashWithSalt (hash int) str)-  hashWithSalt salt (Bn _ i0 i1)     = hashWithSalt salt (hash i0 `hashWithSalt` i1)+  hashWithSalt salt (Fn str int) = hashWithSalt salt (hashWithSalt (hash int) str)+  hashWithSalt salt (Bn i0  i1)  = hashWithSalt salt (hash i0 `hashWithSalt` i1)  instance (Ord a) => Ord (Embed a) where   compare (Embed a) (Embed b) = compare a b