packages feed

clash-lib (empty) → 0.2

raw patch · 43 files changed

+5535/−0 lines, 43 filesdep +aesondep +attoparsecdep +basesetup-changed

Dependencies added: aeson, attoparsec, base, bytestring, concurrent-supply, containers, directory, errors, fgl, filepath, hashable, lens, listlike-instances, mtl, pretty, process, template-haskell, text, time, transformers, unbound, unordered-containers, uu-parsinglib, wl-pprint-text

Files

+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2012-2013, University of Twente+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the documentation+   and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+http://christiaanb.github.io/clash2/
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ clash-lib.cabal view
@@ -0,0 +1,117 @@+Name:                 clash-lib+Version:              0.2+Synopsis:             CAES Language for Synchronous Hardware - As a Library+Description:+  CλaSH (pronounced ‘clash’) is a functional hardware description language that+  borrows both its syntax and semantics from the functional programming language+  Haskell. The merits of using a functional language to describe hardware comes+  from the fact that combinational circuits can be directly modeled as+  mathematical functions and that functional languages lend themselves very well+  at describing and (de-)composing mathematical functions.+  .+  This package provides:+  .+  * The CoreHW internal language: SystemF + Letrec + Case-decomposition+  .+  * The normalisation process that brings CoreHW in a normal form that can be+  converted to a netlist+  .+  * VHDL Backend+  .+  * Blackbox/Primitive Handling+  .+  .+  Front-ends (for: parsing, typecheck, etc.) are provided by seperate packages:+  .+  * <https://github.com/christiaanb/Idris-dev Idris Frontend>+  .+  * <https://github.com/christiaanb/clash2 GHC/Haskell Frontend>+Homepage:             http://christiaanb.github.io/clash2+bug-reports:          http://github.com/christiaanb/clash2/issues+License:              OtherLicense+License-file:         LICENSE+Author:               Christiaan Baaij+Maintainer:           Christiaan Baaij <christiaan.baaij@gmail.com>+Copyright:            Copyright (c) 2012-2013 University of Twente+Category:             Hardware+Build-type:           Simple++Extra-source-files:   README.md++Cabal-version:        >=1.10++source-repository head+  type: git+  location: git@github.com:christiaanb/clash2.git++Library+  HS-Source-Dirs:     src++  default-language:   Haskell2010+  ghc-options:        -Wall -fwarn-tabs++  Build-depends:      aeson                >= 0.6.0.2,+                      attoparsec           >= 0.10.2.0,+                      base                 >= 4.3.1.0 && < 5,+                      bytestring           >= 0.9.2.1,+                      concurrent-supply    >= 0.1.3,+                      containers           >= 0.4.2.1,+                      directory            >= 1.1.0.2,+                      errors               >= 1.4.1,+                      fgl                  >= 5.4.2.4,+                      filepath             >= 1.3.0.0,+                      hashable             >= 1.1.2.3,+                      lens                 >= 3.7.1,+                      listlike-instances   >= 0.2.3.1,+                      mtl                  >= 2.0.1.0,+                      pretty               >= 1.1.1.0,+                      process              >= 1.1.0.2,+                      template-haskell     >= 2.7.0.0,+                      text                 >= 0.11.1.13,+                      time                 >= 1.4.0.1,+                      transformers         >= 0.2.2.0,+                      unbound              >= 0.4.0.2,+                      unordered-containers >= 0.2.1.0,+                      uu-parsinglib        >= 2.7.4,+                      wl-pprint-text       >= 1.0.0.0++  Exposed-modules:    CLaSH.Core.DataCon+                      CLaSH.Core.FreeVars+                      CLaSH.Core.Literal+                      CLaSH.Core.Pretty+                      CLaSH.Core.Subst+                      CLaSH.Core.Term+                      CLaSH.Core.TyCon+                      CLaSH.Core.Type+                      CLaSH.Core.TysPrim+                      CLaSH.Core.Util+                      CLaSH.Core.Var++                      CLaSH.Driver+                      CLaSH.Driver.TestbenchGen+                      CLaSH.Driver.Types++                      CLaSH.Netlist+                      CLaSH.Netlist.BlackBox+                      CLaSH.Netlist.BlackBox.Parser+                      CLaSH.Netlist.BlackBox.Types+                      CLaSH.Netlist.BlackBox.Util+                      CLaSH.Netlist.Id+                      CLaSH.Netlist.Types+                      CLaSH.Netlist.Util+                      CLaSH.Netlist.VHDL++                      CLaSH.Normalize+                      CLaSH.Normalize.Strategy+                      CLaSH.Normalize.Transformations+                      CLaSH.Normalize.Types+                      CLaSH.Normalize.Util++                      CLaSH.Primitives.Types+                      CLaSH.Primitives.Util++                      CLaSH.Rewrite.Combinators+                      CLaSH.Rewrite.Types+                      CLaSH.Rewrite.Util++                      CLaSH.Util
+ src/CLaSH/Core/DataCon.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE UndecidableInstances  #-}++{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++-- | Data Constructors in CoreHW+module CLaSH.Core.DataCon+  ( DataCon (..)+  , DcName+  , ConTag+  , dataConInstArgTys+  )+where++import                Unbound.LocallyNameless as Unbound++import {-# SOURCE #-} CLaSH.Core.Term         (Term)+import {-# SOURCE #-} CLaSH.Core.Type         (TyName, Type)+import                CLaSH.Util++-- | Data Constructor+data DataCon+  = MkData+  { dcName       :: DcName   -- ^ Name of the DataCon+  , dcTag        :: ConTag   -- ^ Syntactical position in the type definition+  , dcType       :: Type     -- ^ Type of the 'DataCon+  , dcUnivTyVars :: [TyName] -- ^ Universally quantified type-variables,+                             -- these type variables are also part of the+                             -- result type of the DataCon+  , dcExtTyVars  :: [TyName] -- ^ Existentially quantified type-variables,+                             -- these type variables are not part of the result+                             -- of the DataCon, but only of the arguments.+  , dcArgTys     :: [Type]   -- ^ Argument types+  }++instance Show DataCon where+  show = show . dcName++instance Eq DataCon where+  (==) = (==) `on` dcName++instance Ord DataCon where+  compare = compare `on` dcName++-- | Syntactical position of the DataCon in the type definition+type ConTag = Int+-- | DataCon reference+type DcName = Name DataCon++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)+  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++-- | Given a DataCon and a list of types, the type variables of the DataCon+-- type are substituted for the list of types. The argument types are returned.+--+-- The list of types should be equal to the number of type variables, otherwise+-- an error is reported.+dataConInstArgTys :: DataCon -> [Type] -> [Type]+dataConInstArgTys (MkData { dcArgTys     = arg_tys+                          , dcUnivTyVars = univ_tvs+                          , dcExtTyVars  = ex_tvs+                          })+                  inst_tys+  | length tyvars == length inst_tys+  = map (substs (zip tyvars inst_tys)) arg_tys++  | otherwise+  = error $ $(curLoc) ++ "dataConInstArgTys: number of tyVars and Types differ"++  where+    tyvars = univ_tvs ++ ex_tvs
+ src/CLaSH/Core/DataCon.hs-boot view
@@ -0,0 +1,17 @@+{-# LANGUAGE MultiParamTypeClasses #-}+module CLaSH.Core.DataCon where++import                Unbound.LocallyNameless++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
+ src/CLaSH/Core/FreeVars.hs view
@@ -0,0 +1,31 @@+-- | Free variable calculations+module CLaSH.Core.FreeVars where++import Unbound.LocallyNameless (Collection, fv)++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 = 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 = fv++-- | Gives the free type-variables of a Term+termFreeTyVars :: Collection c+               => Term+               -> c TyName+termFreeTyVars = fv
+ src/CLaSH/Core/Literal.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE UndecidableInstances  #-}++{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++-- | Term Literal+module CLaSH.Core.Literal+  ( Literal (..)+  , literalType+  )+where++import                Unbound.LocallyNameless       as Unbound+import                Unbound.LocallyNameless.Alpha++import {-# SOURCE #-} CLaSH.Core.Term               (Term)+import {-# SOURCE #-} CLaSH.Core.Type               (Type)+import                CLaSH.Core.TysPrim            (intPrimTy, voidPrimTy)++-- | Term Literal+data Literal+  = IntegerLiteral Integer+  | StringLiteral  String+  deriving (Eq,Ord,Show)++Unbound.derive [''Literal]++instance Alpha Literal where+  fv' _ _ = emptyC++  acompare' _ (IntegerLiteral i) (IntegerLiteral j) = compare i j+  acompare' c l1                 l2                 = acompareR1 rep1 c l1 l2++instance Subst Type Literal+instance Subst Term Literal++-- | Determines the Type of a Literal+literalType :: Literal+            -> Type+literalType (IntegerLiteral _) = intPrimTy+literalType (StringLiteral  _) = voidPrimTy
+ src/CLaSH/Core/Pretty.hs view
@@ -0,0 +1,339 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternGuards     #-}+{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE ViewPatterns      #-}+-- | Pretty printing class and instances for CoreHW+module CLaSH.Core.Pretty+  ( Pretty (..)+  , showDoc+  )+where++import           Data.Char               (isSymbol, isUpper, ord)+import           Data.Traversable        (sequenceA)+import           GHC.Show                (showMultiLineString)+import           Text.PrettyPrint        (Doc, char, comma, empty, equals, hang,+                                          hsep, int, integer, parens, punctuate,+                                          render, sep, text, vcat, ($$), ($+$),+                                          (<+>), (<>))+import           Unbound.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 (..), isTupleTyConLike)+import           CLaSH.Core.Type         (ConstTy (..), Kind, LitTy (..),+                                          Type (..), TypeView (..), tyView)+import           CLaSH.Core.Var          (Id, TyVar, Var, varKind, varName,+                                          varType)+import           CLaSH.Util++-- | Pretty printing Show-like typeclass+class Pretty p where+  ppr :: (Applicative m, LFresh m) => p -> m Doc+  ppr = pprPrec 0++  pprPrec :: (Applicative m, LFresh m) => Rational -> p -> m Doc++noPrec, opPrec, appPrec :: Num a => a+noPrec = 0+opPrec = 1+appPrec = 2++-- | Print a Pretty thing to a String+showDoc :: Pretty p => p -> String+showDoc = render . runLFreshM . ppr++prettyParen :: Bool -> Doc -> Doc+prettyParen False = id+prettyParen True  = parens++instance Pretty (Name a) where+  pprPrec _ = return . text . show++instance Pretty a => Pretty [a] where+  pprPrec prec xs = do+    xs' <- mapM (pprPrec prec) xs+    return $ vcat xs'++instance Pretty (Id, Term) where+  pprPrec _ = pprTopLevelBndr++pprTopLevelBndr :: (Applicative m, LFresh m) => (Id,Term) -> m Doc+pprTopLevelBndr (bndr,expr) = do+  bndr' <- ppr bndr+  bndrName <- ppr (varName bndr)+  expr' <- ppr expr+  return $ bndr' $$ hang (bndrName <+> equals) 2 expr' <> text "\n"++dcolon :: Doc+dcolon = text "::"++period :: Doc+period = char '.'++rarrow :: Doc+rarrow = text "->"++instance Pretty Type where+  pprPrec _ = pprType++instance Pretty (Var Type) where+  pprPrec _ v = ppr $ varName v++instance Pretty TyCon where+  pprPrec _ tc = return . text . name2String $ tyConName tc++instance Pretty LitTy where+  pprPrec _ (NumTy i) = return $ int i+  pprPrec _ (SymTy s) = return $ text s++instance Pretty Term where+  pprPrec prec e = case e of+    Var _ x        -> pprPrec prec x+    Data dc        -> pprPrec prec dc+    Literal l      -> pprPrec prec l+    Prim nm _      -> return . text $ name2String nm+    Lam b          -> lunbind b $ \(v,e')  -> pprPrecLam prec [v] e'+    TyLam b        -> lunbind b $ \(tv,e') -> pprPrecTyLam prec [tv] e'+    App fun arg    -> pprPrecApp prec fun arg+    TyApp e' ty    -> pprPrecTyApp prec e' ty+    Letrec b       -> lunbind b $ \(xes,e') -> pprPrecLetrec prec (unrec xes) e'+    Case e' _ alts -> pprPrecCase prec e' =<< mapM (`lunbind` return) alts++data BindingSite+  = LambdaBind+  | CaseBind+  | LetBind++instance Pretty (Var Term) where+  pprPrec _ v = do+    v'  <- ppr (varName v)+    ty' <- ppr (unembed $ varType v)+    return $ v' <+> dcolon <+> ty'++instance Pretty DataCon where+  pprPrec _ dc = return . text . name2String $ dcName dc++instance Pretty Literal where+  pprPrec _ l = case l of+    IntegerLiteral i+      | i < 0       -> return $ parens (integer i)+      | otherwise   -> return $ integer i+    StringLiteral s -> return $ vcat $ map text $ showMultiLineString s++instance Pretty Pat where+  pprPrec prec pat = case pat of+    DataPat dc pxs -> do+      let (txs,xs) = unrebind pxs+      dc'  <- ppr (unembed dc)+      txs' <- mapM (pprBndr LetBind) txs+      xs'  <- mapM (pprBndr CaseBind) xs+      return $ prettyParen (prec >= appPrec) $ dc' <+> hsep txs' <+> hsep xs'+    LitPat l   -> ppr (unembed l)+    DefaultPat -> return $ char '_'++pprPrecLam :: (Applicative m, LFresh m) => Rational -> [Id] -> Term -> m Doc+pprPrecLam prec xs e = do+  xs' <- mapM (pprBndr LambdaBind) xs+  e'  <- pprPrec noPrec e+  return $ prettyParen (prec > noPrec) $+    char 'λ' <> hsep xs' <+> rarrow $+$ e'++pprPrecTyLam :: (Applicative m, LFresh m) => Rational -> [TyVar] -> Term -> m Doc+pprPrecTyLam prec tvs e = do+  tvs' <- mapM ppr tvs+  e'   <- pprPrec noPrec e+  return $ prettyParen (prec > noPrec) $+    char 'Λ' <> hsep tvs' <+> rarrow $+$ e'++pprPrecApp :: (Applicative m, LFresh m) => Rational -> Term -> Term -> m Doc+pprPrecApp prec e1 e2 = do+  e1' <- pprPrec opPrec e1+  e2' <- pprPrec appPrec e2+  return $ prettyParen (prec >= appPrec) $ e1' <+> e2'++pprPrecTyApp :: (Applicative m, LFresh m) => Rational -> Term -> Type -> m Doc+pprPrecTyApp prec e ty = do+  e' <- pprPrec opPrec e+  ty' <- pprParendType ty+  return $ prettyParen (prec >= appPrec) $ e' <+> char '@' <> ty'++pprPrecLetrec :: (Applicative m, LFresh m) => Rational -> [(Id, Embed Term)] -> Term+  -> m Doc+pprPrecLetrec prec xes body+  | [] <- xes = pprPrec prec body+  | otherwise = do+    body' <- pprPrec noPrec body+    xes'  <- mapM (\(x,e) -> do+                    x' <- pprBndr LetBind x+                    e' <- pprPrec noPrec (unembed e)+                    return $ x' <+> equals <+> e'+                  ) xes+    return $ prettyParen (prec > noPrec) $+      hang (text "letrec") 2 (vcat xes') $$ text "in" <+> body'++pprPrecCase :: (Applicative m, LFresh m) => Rational -> Term -> [(Pat,Term)] -> m Doc+pprPrecCase prec e alts = do+  e' <- pprPrec prec e+  alts' <- mapM (pprPrecAlt noPrec) alts+  return $ prettyParen (prec > noPrec) $+    hang (text "case" <+> e' <+> text "of") 2 $ vcat alts'++pprPrecAlt :: (Applicative m, LFresh m) => Rational -> (Pat,Term) -> m Doc+pprPrecAlt _ (altPat, altE) = do+  altPat' <- pprPrec noPrec altPat+  altE'   <- pprPrec noPrec altE+  return $ hang (altPat' <+> rarrow) 2 altE'++pprBndr :: (Applicative m, LFresh m, Pretty a) => BindingSite -> a -> m Doc+pprBndr bs x = prettyParen needsParen <$> ppr x+  where+    needsParen = case bs of+      LambdaBind -> True+      CaseBind   -> True+      LetBind    -> False++data TypePrec+  = TopPrec+  | FunPrec+  | TyConPrec+  deriving (Eq,Ord)++maybeParen :: TypePrec -> TypePrec -> Doc -> Doc+maybeParen ctxt_prec inner_prec = prettyParen (ctxt_prec >= inner_prec)++pprType :: (Applicative m, LFresh m) => Type -> m Doc+pprType = ppr_type TopPrec++pprParendType :: (Applicative m, LFresh m) => Type -> m Doc+pprParendType = ppr_type TyConPrec++ppr_type :: (Applicative m, LFresh m) => TypePrec -> Type -> m Doc+ppr_type _ (VarTy _ tv)                 = ppr tv+ppr_type _ (LitTy tyLit)                = ppr tyLit+ppr_type p ty@(ForAllTy _)              = pprForAllType p ty+ppr_type p (ConstTy (TyCon tc))         = pprTcApp p ppr_type tc []+ppr_type p (tyView -> TyConApp tc args) = pprTcApp p ppr_type tc args+ppr_type p (tyView -> FunTy ty1 ty2)    = pprArrowChain p <$> ppr_type FunPrec ty1 <:> pprFunTail ty2+  where+    pprFunTail (tyView -> FunTy ty1' ty2') = ppr_type FunPrec ty1' <:> pprFunTail ty2'+    pprFunTail otherTy                     = ppr_type TopPrec otherTy <:> pure []++ppr_type p (AppTy ty1 ty2) = maybeParen p TyConPrec <$> ((<+>) <$> pprType ty1 <*> ppr_type TyConPrec ty2)+ppr_type p ty = error $ $(curLoc) ++ "Can't pretty print type: " ++ show ty++pprForAllType :: (Applicative m, LFresh m) => TypePrec -> Type -> m Doc+pprForAllType p ty = maybeParen p FunPrec <$> pprSigmaType True ty++pprSigmaType :: (Applicative m, LFresh m) => Bool -> Type -> m Doc+pprSigmaType showForalls ty = do+    (tvs, rho)     <- split1 [] ty+    sep <$> sequenceA [ if showForalls then pprForAll tvs else pure empty+                      , pprType rho+                      ]+  where+    split1 tvs (ForAllTy b) =+      lunbind b $ \(tv,resTy) -> split1 (tv:tvs) resTy+    split1 tvs resTy = return (reverse tvs,resTy)++pprForAll :: (Applicative m, LFresh m) => [TyVar] -> m Doc+pprForAll [] = return empty+pprForAll tvs = do+  tvs' <- mapM pprTvBndr tvs+  return $ char '∀' <+> sep tvs' <> period++pprTvBndr :: (Applicative m, LFresh m) => TyVar -> m Doc+pprTvBndr tv+  = do+      tv'   <- ppr tv+      kind' <- pprKind kind+      return $ parens (tv' <+> dcolon <+> kind')+  where+    kind = unembed $ varKind tv++pprKind :: (Applicative m, LFresh m) => Kind -> m Doc+pprKind = pprType++pprTcApp :: (Applicative m, LFresh m) => TypePrec -> (TypePrec -> Type -> m Doc)+  -> TyCon -> [Type] -> m Doc+pprTcApp _ _  tc []+  = ppr tc++pprTcApp p pp tc tys+  | isTupleTyConLike tc && tyConArity tc == length tys+  = do+    tys' <- mapM (pp TopPrec) tys+    return $ parens $ sep $ punctuate comma tys'++  | otherwise+  = pprTypeNameApp p pp (tyConName tc) tys++pprTypeNameApp :: LFresh m => TypePrec -> (TypePrec -> Type -> m Doc)+  -> Name a -> [Type] -> m Doc+pprTypeNameApp p pp name tys+  | isSym+  , [ty1,ty2] <- tys+  = pprInfixApp p pp name ty1 ty2+  | otherwise+  = do+    tys' <- mapM (pp TyConPrec) tys+    let name' = text $ name2String name+    return $ pprPrefixApp p (pprPrefixVar isSym name') tys'+  where+    isSym = isSymName name++pprInfixApp :: LFresh m => TypePrec -> (TypePrec -> Type -> m Doc)+  -> Name a -> Type -> Type -> m Doc+pprInfixApp p pp name ty1 ty2 = do+  ty1'  <- pp FunPrec ty1+  ty2'  <- pp FunPrec ty2+  let name' = text $ name2String name+  return $ maybeParen p FunPrec $ sep [ty1', pprInfixVar True name' <+> ty2']++pprPrefixApp :: TypePrec -> Doc -> [Doc] -> Doc+pprPrefixApp p pp_fun pp_tys = maybeParen p TyConPrec $+                                 hang pp_fun 2 (sep pp_tys)++pprPrefixVar :: Bool -> Doc -> Doc+pprPrefixVar is_operator pp_v+  | is_operator = parens pp_v+  | otherwise   = pp_v++pprInfixVar :: Bool -> Doc -> Doc+pprInfixVar is_operator pp_v+  | is_operator = pp_v+  | otherwise   = char '`' <> pp_v <> char '`'++pprArrowChain :: TypePrec -> [Doc] -> Doc+pprArrowChain _ []         = empty+pprArrowChain p (arg:args) = maybeParen p FunPrec $+                               sep [arg, sep (map (rarrow <+>) args)]++isSymName :: Name a -> Bool+isSymName n = go (name2String n)+  where+    go s | null s           = False+         | isUpper $ head s = isLexConSym s+         | otherwise        = isLexSym s++isLexSym :: String -> Bool+isLexSym cs = isLexConSym cs || isLexVarSym cs++isLexConSym :: String -> Bool+isLexConSym "->" = True+isLexConSym cs   = startsConSym (head cs)++isLexVarSym :: String -> Bool+isLexVarSym cs = startsVarSym (head cs)++startsConSym :: Char -> Bool+startsConSym c = c == ':'++startsVarSym :: Char -> Bool+startsVarSym c = isSymbolASCII c || (ord c > 0x7f && isSymbol c)++isSymbolASCII :: Char -> Bool+isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
+ src/CLaSH/Core/Subst.hs view
@@ -0,0 +1,52 @@+-- | Capture-free substitution function for CoreHW+module CLaSH.Core.Subst where++import                Unbound.LocallyNameless (subst, substs)++import                CLaSH.Core.Term         (Term, TmName)+import {-# SOURCE #-} CLaSH.Core.Type         (KiName, Kind, TyName, Type)++-- | Substitutes types in a type+substTys :: [(TyName,Type)]+         -> Type+         -> Type+substTys = substs++-- | Substitutes a type in a type+substTy :: TyName+        -> Type+        -> Type+        -> Type+substTy = subst++-- | Substitutes kinds in a kind+substKindWith :: [(KiName,Kind)]+              -> Kind+              -> Kind+substKindWith = substs++-- | Substitutes a type in a term+substTyInTm :: TyName+            -> Type+            -> Term+            -> Term+substTyInTm = subst++-- | Substitutes types in a term+substTysinTm :: [(TyName,Type)]+             -> Term+             -> Term+substTysinTm = substs++-- | Substitutes a term in a term+substTm :: TmName+        -> Term+        -> Term+        -> Term+substTm = subst++-- | Substitutes terms in a term+substTms :: [(TmName,Term)]+         -> Term+         -> Term+substTms = substs
+ src/CLaSH/Core/Term.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE UndecidableInstances  #-}++{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++-- | Term representation in the CoreHW language: System F + LetRec + Case+module CLaSH.Core.Term+  ( Term (..)+  , TmName+  , LetBinding+  , Pat (..)+  )+where++-- External Modules+import                Unbound.LocallyNameless       as Unbound hiding (Data)+import                Unbound.LocallyNameless.Alpha (aeqR1, fvR1)+import                Unbound.LocallyNameless.Name  (isFree)++-- 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++-- | Term representation in the CoreHW language: System F + LetRec + Case+data Term+  = Var     Type TmName -- ^ Variable reference+  | Data    DataCon -- ^ Datatype constructor+  | Literal Literal -- ^ Literal+  | Prim    TmName Type -- ^ Primitive+  | Lam     (Bind Id Term) -- ^ Term-abstraction+  | TyLam   (Bind TyVar Term) -- ^ Type-abstraction+  | App     Term Term -- ^ Application+  | TyApp   Term Type -- ^ Type-application+  | Letrec  (Bind (Rec [LetBinding]) Term) -- ^ Recursive let-binding+  | Case    Term Type [Bind Pat Term] -- ^ Case-expression: subject, type of+                                      -- alternatives, list of alternatives+  deriving Show++-- | Term reference+type TmName     = Name Term+-- | Binding in a LetRec construct+type LetBinding = (Id, Embed Term)++-- | Patterns in the LHS of a case-decomposition+data Pat+  = DataPat (Embed DataCon) (Rebind [TyVar] [Id])+  -- ^ Datatype pattern, '[TyVar]' bind existentially-quantified+  -- type-variables of a DataCon+  | LitPat  (Embed Literal)+  -- ^ Literal pattern+  | DefaultPat+  -- ^ Default pattern+  deriving (Show)++Unbound.derive [''Term,''Pat]++instance Eq Term where+  (==) = aeq++instance Ord Term where+  compare = acompare++instance Alpha Term where+  fv' c (Var _ n)  = fv' c n+  fv' c (Prim _ t) = fv' c t+  fv' c t          = fvR1 rep1 c t++  aeq' c (Var _ n) (Var _ m) = aeq' c n m+  aeq' c t1        t2        = aeqR1 rep1 c t1 t2++instance Alpha Pat++instance Subst Term Pat+instance Subst Term Term where+  isvar (Var _ x) = Just (SubstName x)+  isvar _         = Nothing++instance Subst Type Pat+instance Subst Type Term where+  subst tvN u x | isFree 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)+    TyApp  e   ty  -> TyApp  (subst tvN u e  ) (subst tvN u ty )+    Letrec b       -> Letrec (subst tvN u b  )+    Case   e ty  a -> Case   (subst tvN u e  )+                             (subst tvN u ty )+                             (subst tvN u a  )+    Var ty nm      -> Var    (subst tvN u ty ) nm+    Prim nm ty     -> Prim   nm (subst tvN u ty)+    e              -> e+  subst m _ _ = error $ $(curLoc) ++ "Cannot substitute for bound variable: " ++ show m
+ src/CLaSH/Core/Term.hs-boot view
@@ -0,0 +1,13 @@+{-# LANGUAGE MultiParamTypeClasses #-}+module CLaSH.Core.Term where++import Unbound.LocallyNameless++data Term++type TmName = Name Term++instance Rep   Term+instance Show  Term+instance Alpha Term+instance Subst Term Term
+ src/CLaSH/Core/TyCon.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# 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 (..)+  , TyConName+  , AlgTyConRhs (..)+  , PrimRep (..)+  , mkKindTyCon+  , isTupleTyConLike+  , tyConDataCons+  )+where++-- External Import+import                Unbound.LocallyNameless as Unbound++-- 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++-- | Type Constructor+data TyCon+  -- | Algorithmic DataCons+  = AlgTyCon+  { tyConName   :: TyConName   -- ^ Name of the TyCon+  , tyConKind   :: Kind        -- ^ Kind of the TyCon+  , tyConArity  :: Int         -- ^ Number of type arguments+  , algTcRhs    :: AlgTyConRhs -- ^ DataCon definitions+  }+  -- | Primitive TyCons+  | PrimTyCon+  { tyConName    :: TyConName  -- ^ Name of the TyCon+  , tyConKind    :: Kind       -- ^ Kind of the TyCon+  , tyConArity   :: Int        -- ^ Number of type arguments+  , primTyConRep :: PrimRep    -- ^ Representation+  }+  -- | To close the loop on the type hierarchy+  | SuperKindTyCon+  { tyConName :: TyConName     -- ^ Name of the TyCon+  }++instance Show TyCon where+  show (AlgTyCon       {tyConName = n}) = "AlgTyCon: " ++ show n+  show (PrimTyCon      {tyConName = n}) = "PrimTyCon: " ++ show n+  show (SuperKindTyCon {tyConName = n}) = "SuperKindTyCon: " ++ show n++instance Eq TyCon where+  (==) = (==) `on` tyConName++instance Ord TyCon where+  compare = compare `on` tyConName++-- | TyCon reference+type TyConName = Name TyCon++-- | The RHS of an Algebraic Datatype+data AlgTyConRhs+  = DataTyCon+  { dataCons :: [DataCon]        -- ^ The DataCons of a TyCon+  }+  | NewTyCon+  { dataCon   :: DataCon         -- ^ The newtype DataCon+  , ntEtadRhs :: ([TyName],Type) -- ^ The argument type of the newtype+                                 -- DataCon in eta-reduced form, which is+                                 -- just the representation of the TyCon.+                                 -- The TyName's are the type-variables from+                                 -- the corresponding TyCon.+  }+  deriving Show++-- | Representations for primitive types+data PrimRep+  = IntRep+  | VoidRep+  deriving Show++Unbound.derive [''TyCon,''AlgTyConRhs,''PrimRep]++instance Alpha PrimRep+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"++instance Alpha AlgTyConRhs++instance Subst Type TyCon+instance Subst Type AlgTyConRhs+instance Subst Type PrimRep++instance Subst Term TyCon+instance Subst Term AlgTyConRhs+instance Subst Term PrimRep++-- | Create a Kind out of a TyConName+mkKindTyCon :: TyConName+            -> Kind+            -> TyCon+mkKindTyCon name kind+  = PrimTyCon name kind 0 VoidRep++-- | Does the TyCon look like a tuple TyCon+isTupleTyConLike :: TyCon -> Bool+isTupleTyConLike (AlgTyCon {tyConName = nm}) = tupleName (name2String nm)+  where+    tupleName nm+      | '(' <- head nm+      , ')' <- last nm+      = all (== ',') (init $ tail nm)+    tupleName _ = False++isTupleTyConLike _ = False++-- | Get the DataCons belonging to a TyCon+tyConDataCons :: TyCon -> [DataCon]+tyConDataCons (AlgTyCon {algTcRhs = DataTyCon { dataCons = cons}}) = cons+tyConDataCons (AlgTyCon {algTcRhs = NewTyCon  { dataCon  = con }}) = [con]+tyConDataCons _                                                    = []
+ src/CLaSH/Core/TyCon.hs-boot view
@@ -0,0 +1,3 @@+module CLaSH.Core.TyCon where++data TyCon
+ src/CLaSH/Core/Type.hs view
@@ -0,0 +1,265 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# 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 (..)+  , TypeView (..)+  , ConstTy (..)+  , LitTy (..)+  , Kind+  , KindOrType+  , KiName+  , TyName+  , TyVar+  , tyView+  , coreView+  , transparentTy+  , typeKind+  , mkTyConTy+  , mkFunTy+  , mkTyConApp+  , splitFunTy+  , splitFunForallTy+  , splitTyConAppM+  , isPolyTy+  , isFunTy+  , applyFunTy+  , applyTy+  )+where++-- External import+import                Data.Maybe                    (isJust)+import                Unbound.LocallyNameless       as Unbound hiding (Arrow)+import                Unbound.LocallyNameless.Alpha (aeqR1,fvR1)+import                Unbound.LocallyNameless.Ops   (unsafeUnbind)++-- Local imports+import                CLaSH.Core.Subst+import {-# SOURCE #-} CLaSH.Core.Term+import                CLaSH.Core.TyCon+import                CLaSH.Core.TysPrim+import                CLaSH.Core.Var+import                CLaSH.Util++-- | Types in CoreHW: function and polymorphic types+data Type+  = VarTy    Kind TyName       -- ^ Type variable+  | ConstTy  ConstTy           -- ^ Type constant+  | ForAllTy (Bind TyVar Type) -- ^ Polymorphic Type+  | AppTy    Type Type         -- ^ Type Application+  | LitTy    LitTy             -- ^ Type literal+  deriving Show++-- | An easier view on types+data TypeView+  = FunTy    Type  Type   -- ^ Function type+  | TyConApp TyCon [Type] -- ^ Applied TyCon+  | OtherType Type        -- ^ Neither of the above+  deriving Show++-- | Type Constants+data ConstTy+  = TyCon TyCon -- ^ TyCon type+  | Arrow       -- ^ Function type+  deriving Show++-- | Literal Types+data LitTy+  = NumTy Int+  | SymTy String+  deriving Show++-- | The level above types+type Kind       = Type+-- | Either a Kind or a Type+type KindOrType = Type++-- | Reference to a Type+type TyName     = Name Type+-- | Reference to a Kind+type KiName     = Name Kind++Unbound.derive [''Type,''LitTy,''ConstTy]++instance Alpha Type where+  fv' c (VarTy _ n) = fv' c n+  fv' c t           = fvR1 rep1 c t++  aeq' c (VarTy _ n) (VarTy _ m) = aeq' c n m+  aeq' c t1          t2          = aeqR1 rep1 c t1 t2++instance Alpha ConstTy+instance Alpha LitTy++instance Subst Type LitTy+instance Subst Term LitTy+instance Subst Type ConstTy+instance Subst Term ConstTy+instance Subst Term Type+instance Subst Type Type where+  isvar (VarTy _ v) = Just (SubstName v)+  isvar _           = Nothing++instance Eq Type where+  (==) = aeq++instance Ord Type where+  compare = acompare++-- | An easier view on types+tyView :: Type -> TypeView+tyView ty@(AppTy _ _) = case splitTyAppM ty of+  Just (ConstTy Arrow, [ty1,ty2]) -> FunTy ty1 ty2+  Just (ConstTy (TyCon tc), args) -> TyConApp tc args+  _ -> OtherType ty+tyView (ConstTy (TyCon tc)) = TyConApp tc []+tyView t = OtherType t++-- | A transformation that renders 'Signal' types transparent+transparentTy :: Type -> Type+transparentTy (AppTy (ConstTy (TyCon tc)) ty)+  = case name2String (tyConName tc) of+      "CLaSH.Signal.Signal"  -> transparentTy ty+      "CLaSH.Signal.SignalP" -> transparentTy ty+      _ -> AppTy (ConstTy (TyCon tc)) (transparentTy ty)+transparentTy (AppTy ty1 ty2) = AppTy (transparentTy ty1) (transparentTy ty2)+transparentTy (ForAllTy b)    = ForAllTy (uncurry bind $ second transparentTy $ unsafeUnbind b)+transparentTy ty              = ty++-- | A view on types in which 'Signal' types and newtypes are transparent+coreView :: Type -> TypeView+coreView ty =+  let tView = tyView ty+  in case tView of+       TyConApp (AlgTyCon {algTcRhs = (NewTyCon _ nt)}) args+         | length (fst nt) == length args -> coreView (newTyConInstRhs nt args)+         | otherwise  -> tView+       TyConApp tc args -> case name2String (tyConName tc) of+         "CLaSH.Signal.Signal"  -> coreView (head args)+         "CLaSH.Signal.SignalP" -> coreView (head args)+         _ -> tView+       _ -> tView++-- | Instantiate and Apply the RHS/Original of a NewType with the given+-- list of argument types+newTyConInstRhs :: ([TyName],Type) -> [Type] -> Type+newTyConInstRhs (tvs,ty) tys = foldl AppTy (substTys (zip tvs tys1) ty) tys2+  where+    (tys1, tys2) = splitAtList tvs tys++-- | Make a function type of an argument and result type+mkFunTy :: Type -> Type -> Type+mkFunTy t1 = AppTy (AppTy (ConstTy Arrow) t1)++-- | Make a TyCon Application out of a TyCon and a list of argument types+mkTyConApp :: TyCon -> [Type] -> Type+mkTyConApp tc = foldl AppTy (ConstTy $ TyCon tc)++-- | Make a Type out of a TyCon+mkTyConTy :: TyCon -> Type+mkTyConTy ty = ConstTy $ TyCon ty++-- | Split a TyCon Application in a TyCon and its arguments+splitTyConAppM :: Type+               -> Maybe (TyCon,[Type])+splitTyConAppM (tyView -> TyConApp tc args) = Just (tc,args)+splitTyConAppM _                            = Nothing++-- | Is a type a Superkind?+isSuperKind :: Type -> Bool+isSuperKind (ConstTy (TyCon (SuperKindTyCon {}))) = True+isSuperKind _                                     = False++-- | Determine the kind of a type+typeKind :: Type -> Kind+typeKind (VarTy k _)          = k+typeKind (ForAllTy b)         = let (_,ty) = runFreshM $ unbind b+                                in typeKind ty+typeKind (LitTy (NumTy _))    = typeNatKind+typeKind (LitTy (SymTy _))    = typeSymbolKind+typeKind (tyView -> FunTy _arg res)+  | isSuperKind k = k+  | otherwise     = liftedTypeKind+  where k = typeKind res++typeKind (tyView -> TyConApp tc args) = foldl kindFunResult (tyConKind tc) args++typeKind (AppTy fun arg)      = kindFunResult (typeKind fun) arg+typeKind (ConstTy ct)         = error $ $(curLoc) ++ "typeKind: naked ConstTy: " ++ show ct++kindFunResult :: Kind -> KindOrType -> Kind+kindFunResult (tyView -> FunTy _ res) _ = res++kindFunResult (ForAllTy b) arg =+  let (kv,ki) = runFreshM . unbind $ b+  in  substKindWith (zip [varName kv] [arg]) ki++kindFunResult k tys =+  error $ $(curLoc) ++ "kindFunResult: " ++ show (k,tys)++-- | Is a type polymorphic?+isPolyTy :: Type -> Bool+isPolyTy (ForAllTy _)            = True+isPolyTy (tyView -> FunTy _ res) = isPolyTy res+isPolyTy _                       = False++-- | Split a function type in an argument and result type+splitFunTy :: Type+           -> Maybe (Type, Type)+splitFunTy (coreView -> FunTy arg res) = Just (arg,res)+splitFunTy _                           = Nothing++-- | Split a poly-function type in a: list of type-binders and argument types,+-- and the result type+splitFunForallTy :: Type+                 -> ([Either TyVar Type],Type)+splitFunForallTy = go []+  where+    go args (ForAllTy b) = let (tv,ty) = runFreshM $ unbind b+                           in  go (Left tv:args) ty+    go args (tyView -> FunTy arg res) = go (Right arg:args) res+    go args ty                        = (reverse args,ty)++-- | Is a type a function type?+isFunTy :: Type+        -> Bool+isFunTy = isJust . splitFunTy++-- | Apply a function type to an argument type and get the result type+applyFunTy :: Type+           -> Type+           -> Type+applyFunTy (coreView -> FunTy _ resTy) _ = resTy+applyFunTy _ _ = error $ $(curLoc) ++ "Report as bug: not a FunTy"++-- | Substitute the type variable of a type ('ForAllTy') with another type+applyTy :: Fresh m+        => Type+        -> KindOrType+        -> m Type+applyTy (ForAllTy b) arg = do+  (tv,ty) <- unbind b+  return $ substTy (varName tv) arg ty+applyTy _ _ = error $ $(curLoc) ++ "applyTy: not a forall type"++-- | Split a type application in the applied type and the argument types+splitTyAppM :: Type+            -> Maybe (Type, [Type])+splitTyAppM = fmap (second reverse) . go []+  where+    go args (AppTy ty1 ty2) =+      case go args ty1 of+        Nothing             -> Just (ty1,ty2:args)+        Just (ty1',ty1args) -> Just (ty1',ty2:ty1args )+    go _ _ = Nothing
+ src/CLaSH/Core/Type.hs-boot view
@@ -0,0 +1,23 @@+{-# LANGUAGE MultiParamTypeClasses #-}+module CLaSH.Core.Type where++import                Unbound.LocallyNameless++import {-# SOURCE #-} CLaSH.Core.Term+import {-# SOURCE #-} CLaSH.Core.TyCon++data Type++type Kind   = Type+type TyName = Name Type+type KiName = Name Kind++instance Eq    Type+instance Ord   Type+instance Rep   Type+instance Show  Type+instance Alpha Type+instance Subst Type Type+instance Subst Term Type++mkTyConTy :: TyCon -> Type
+ src/CLaSH/Core/TysPrim.hs view
@@ -0,0 +1,43 @@+-- | Builtin Type and Kind definitions+module CLaSH.Core.TysPrim+  ( liftedTypeKind+  , typeNatKind+  , typeSymbolKind+  , intPrimTy+  , voidPrimTy+  )+where++import                Unbound.LocallyNameless (string2Name)++import                CLaSH.Core.TyCon+import {-# SOURCE #-} CLaSH.Core.Type++-- | Builtin Name+tySuperKindTyConName, liftedTypeKindTyConName, typeNatKindTyConName, typeSymbolKindTyConName :: TyConName+tySuperKindTyConName      = string2Name "__BOX__"+liftedTypeKindTyConName   = string2Name "__*__"+typeNatKindTyConName      = string2Name "__Nat__"+typeSymbolKindTyConName   = string2Name "__Symbol__"++-- | Builtin Kind+liftedTypeKind, tySuperKind, typeNatKind, typeSymbolKind :: Kind+tySuperKind    = mkTyConTy (SuperKindTyCon tySuperKindTyConName)+liftedTypeKind = mkTyConTy (mkKindTyCon liftedTypeKindTyConName tySuperKind)+typeNatKind    = mkTyConTy (mkKindTyCon typeNatKindTyConName tySuperKind)+typeSymbolKind = mkTyConTy (mkKindTyCon typeSymbolKindTyConName tySuperKind)++intPrimTyConName, voidPrimTyConName :: TyConName+intPrimTyConName  = string2Name "__INT__"+voidPrimTyConName = string2Name "__VOID__"++liftedPrimTC ::+  TyConName+  -> PrimRep+  -> TyCon+liftedPrimTC name = PrimTyCon name liftedTypeKind 0++-- | Builtin Type+intPrimTy, voidPrimTy :: Type+intPrimTy  = mkTyConTy (liftedPrimTC intPrimTyConName  IntRep )+voidPrimTy = mkTyConTy (liftedPrimTC voidPrimTyConName VoidRep)
+ src/CLaSH/Core/Util.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE TemplateHaskell #-}+-- | 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)++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, mkFunTy, splitFunTy)+import           CLaSH.Core.Var          (Id, TyVar, Var (..), varType)+import           CLaSH.Util++-- | Type environment/context+type Gamma = HashMap TmName Type+-- | Kind environment/context+type Delta = HashMap TyName Kind++-- | Determine the type of a term+termType :: (Functor m, Fresh m)+         => Term+         -> m Type+termType e = case e of+  Var t _     -> return t+  Data dc     -> return $ dcType dc+  Literal l   -> return $ literalType l+  Prim _ t    -> return t+  Lam b       -> do (v,e') <- unbind b+                    mkFunTy (unembed $ varType v) <$> termType e'+  TyLam b     -> do (tv,e') <- unbind b+                    ForAllTy <$> bind tv <$> termType e'+  App _ _     -> case collectArgs e of+                   (fun, args) -> termType fun >>=+                                  (`applyTypeToArgs` args)+  TyApp e' ty -> termType e' >>= (`applyTy` ty)+  Letrec b    -> do (_,e') <- unbind b+                    termType e'+  Case _ ty _ -> return ty++-- | Split a (Type)Application in the applied term and it arguments+collectArgs :: Term+            -> (Term, [Either Term Type])+collectArgs = go []+  where+    go args (App e1 e2) = go (Left e2:args) e1+    go args (TyApp e t) = go (Right t:args) e+    go args e           = (e, args)++-- | Split a (Type)Abstraction in the bound variables and the abstracted term+collectBndrs :: Fresh m+             => Term+             -> m ([Either Id TyVar], Term)+collectBndrs = go []+  where+    go bs (Lam b) = do+      (v,e') <- unbind b+      go (Left v:bs) e'+    go bs (TyLam b) = do+      (tv,e') <- unbind b+      go (Right tv:bs) e'+    go bs e' = return (reverse bs,e')++-- | Get the result type of a polymorphic function given a list of arguments+applyTypeToArgs :: Fresh m => Type -> [Either Term Type] -> m Type+applyTypeToArgs opTy []              = return opTy+applyTypeToArgs opTy (Right ty:args) = applyTy opTy ty >>=+                                       (`applyTypeToArgs` args)+applyTypeToArgs opTy (Left e:args)   = case splitFunTy opTy of+  Just (_,resTy) -> applyTypeToArgs resTy args+  Nothing        -> error $+                    concat [ $(curLoc)+                           , "applyTypeToArgs splitFunTy: not a funTy:\n"+                           , "opTy: "+                           , showDoc opTy+                           , "\nTerm: "+                           , showDoc e+                           , "\nOtherArgs: "+                           , unlines (map (either showDoc showDoc) args)+                           ]++-- | Get the list of term-binders out of a DataType pattern+patIds :: Pat -> [Id]+patIds (DataPat _ ids) = snd $ unrebind ids+patIds _               = []++-- | Make a type variable+mkTyVar :: Kind+        -> TyName+        -> TyVar+mkTyVar tyKind tyName = TyVar tyName (embed tyKind)++-- | Make a term variable+mkId :: Type+     -> TmName+     -> Id+mkId tmType tmName = Id tmName (embed tmType)++-- | Abstract a term over a list of term and type variables+mkAbstraction :: Term+              -> [Either Id TyVar]+              -> Term+mkAbstraction = foldr (either (Lam `dot` bind) (TyLam `dot` bind))++-- | Abstract a term over a list of term variables+mkTyLams :: Term+         -> [TyVar]+         -> Term+mkTyLams tm = mkAbstraction tm . map Right++-- | Abstract a term over a list of type variables+mkLams :: Term+       -> [Id]+       -> Term+mkLams tm = mkAbstraction tm . map Left++-- | Apply a list of types and terms to a term+mkApps :: Term+       -> [Either Term Type]+       -> Term+mkApps = foldl (\e a -> either (App e) (TyApp e) a)++-- | Apply a list of terms to a term+mkTmApps :: Term+         -> [Term]+         -> Term+mkTmApps = foldl App++-- | Apply a list of types to a term+mkTyApps :: Term+         -> [Type]+         -> Term+mkTyApps = foldl TyApp++-- | Does a term have a function type?+isFun :: (Functor m, Fresh m)+      => Term+      -> m Bool+isFun t = fmap isFunTy $ termType t++-- | Is a term a term-abstraction?+isLam :: Term+      -> Bool+isLam (Lam _) = True+isLam _       = False++-- | Is a term a recursive let-binding?+isLet :: Term+      -> Bool+isLet (Letrec _) = True+isLet _          = False++-- | Is a term a variable reference?+isVar :: Term+      -> Bool+isVar (Var _ _) = True+isVar _         = False++-- | Is a term a datatype constructor?+isCon :: Term+      -> Bool+isCon (Data _) = True+isCon _        = False++-- | Is a term a primitive?+isPrim :: Term+       -> Bool+isPrim (Prim _ _) = True+isPrim _          = False++-- | Make variable reference out of term variable+idToVar :: Id+        -> Term+idToVar (Id nm tyE) = Var (unembed tyE) nm+idToVar tv          = error $ $(curLoc) ++ "idToVar: tyVar: " ++ showDoc tv++-- | Make a term variable out of a variable reference+varToId :: Term+        -> Id+varToId (Var ty nm) = Id nm (embed ty)+varToId e           = error $ $(curLoc) ++ "varToId: not a var: " ++ showDoc e
+ src/CLaSH/Core/Var.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# 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 (..)+  , Id+  , TyVar+  , modifyVarName+  )+where++import                Unbound.LocallyNameless      as Unbound+import                Unbound.LocallyNameless.Name (isFree)++import {-# SOURCE #-} CLaSH.Core.Term              (Term)+import {-# SOURCE #-} CLaSH.Core.Type              (Kind, Type)+import                CLaSH.Util++-- | Variables in CoreHW+data Var a+  -- | Constructor for type variables+  = TyVar+  { varName :: Name a+  , varKind :: Embed Kind+  }+  -- | Constructor for term variables+  | Id+  { varName :: Name a+  , varType :: Embed Type+  }+  deriving (Eq,Ord,Show)++-- | Term variable+type Id    = Var Term+-- | Type variable+type TyVar = Var Type++Unbound.derive [''Var]++instance 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 m _ _ = error $ $(curLoc) ++ "Cannot substitute for bound variable: " ++ show m++-- | Change the name of a variable+modifyVarName ::+  (Name a -> Name a)+  -> Var a+  -> Var a+modifyVarName f (TyVar n k) = TyVar (f n) k+modifyVarName f (Id n t)    = Id (f n) t
+ src/CLaSH/Driver.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# 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           Control.Monad.State          (evalState)+import           Control.Lens                 (_1, use)+import qualified Data.HashMap.Lazy            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           CLaSH.Core.Type              (Type)+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.Primitives.Types+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+             -> (Type -> Maybe (Either String HWType)) -- ^ Hardcoded 'Type' -> 'HWType' translator+             -> DebugLevel -- ^ Debug information level for the normalization process+             -> IO ()+generateVHDL bindingsMap primMap typeTrans dbgLevel = do+  start <- Clock.getCurrentTime++  let topEntities = HashMap.toList+                  $ HashMap.filterWithKey+                      (\var _ -> isSuffixOf "topEntity" $ name2String var)+                      bindingsMap++      testInputs  = HashMap.toList+                  $ HashMap.filterWithKey+                      (\var _ -> isSuffixOf "testInput" $ name2String var)+                      bindingsMap++      expectedOutputs = HashMap.toList+                      $ HashMap.filterWithKey+                          (\var _ -> isSuffixOf "expectedOutput" $ name2String var)+                          bindingsMap++  case topEntities of+    [topEntity] -> do+      -- Create unique supplies for normalisation and TB generation+      (supplyN,supplyTB) <- Supply.splitSupply+                          . snd+                          . Supply.freshId+                         <$> Supply.newSupply++      prepTime <- bindingsMap `seq` Clock.getCurrentTime+      let prepStartDiff = Clock.diffUTCTime prepTime start+      putStrLn $ "Loading dependencies took " ++ show prepStartDiff++      let doNorm = do norm <- normalize [fst topEntity]+                      let normChecked = checkNonRecursive (fst topEntity) norm+                      cleanupGraph [fst topEntity] normChecked++          transformedBindings =+            runNormalization dbgLevel supplyN bindingsMap typeTrans doNorm++      normTime <- transformedBindings `seq` Clock.getCurrentTime+      let prepNormDiff = Clock.diffUTCTime normTime prepTime+      putStrLn $ "Normalisation took " ++ show prepNormDiff++      (netlist,vhdlState) <- genNetlist Nothing+                               (HashMap.fromList transformedBindings)+                               primMap typeTrans Nothing (fst topEntity)++      netlistTime <- netlist `seq` Clock.getCurrentTime+      let normNetDiff = Clock.diffUTCTime netlistTime normTime+      putStrLn $ "Netlist generation took " ++ show normNetDiff++      let topComponent = head+                       $ filter (\(Component cName _ _ _ _) ->+                                    Text.isSuffixOf (Text.pack "topEntity_0")+                                      cName)+                                netlist++      (testBench,vhdlState') <- genTestBench dbgLevel supplyTB primMap+                                  typeTrans vhdlState bindingsMap+                                  (listToMaybe $ map fst testInputs)+                                  (listToMaybe $ map fst 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/"+                       , takeWhile (/= '.') (name2String $ fst topEntity)+                       , "/"+                       ]+      prepareDir dir+      mapM_ (writeVHDL dir) vhdlDocs++      end <- vhdlDocs `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+           -> [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+  typesPkgM <- case hwtys of+                 [] -> return Nothing+                 _  -> Just <$> mkTyPackage hwtys++  return $ maybe vhdlNmDocs (\t -> ("types",t):vhdlNmDocs) typesPkgM++-- | 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.+prepareDir :: String -> IO ()+prepareDir dir = do+  -- Create the dir if needed+  Directory.createDirectoryIfMissing True dir+  -- Find all .vhdl files in the directory+  files <- Directory.getDirectoryContents dir+  let to_remove = filter ((==".vhdl") . 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+  IO.hPutStr handle "\n"+  IO.hClose handle
+ src/CLaSH/Driver/TestbenchGen.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++-- | Generate a VHDL 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.Error                    (EitherT, eitherT,+                                                   hoistEither, left, note,+                                                   right)+import           Control.Monad.Trans.Class        (lift)+import           Data.Either                      (lefts)+import           Data.HashMap.Lazy                (HashMap)+import qualified Data.HashMap.Lazy                as HashMap+import           Data.List                        (intersperse)+import           Data.Maybe                       (mapMaybe)+import           Data.Text.Lazy                   (Text)+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          (bind, makeName, name2Integer,+                                                   name2String, rec, unrec)+import           Unbound.LocallyNameless.Ops      (unsafeUnbind)++import           CLaSH.Core.DataCon+import           CLaSH.Core.Pretty+import           CLaSH.Core.Term+import           CLaSH.Core.TyCon+import           CLaSH.Core.Type+import           CLaSH.Core.Util++import           CLaSH.Netlist+import           CLaSH.Netlist.Types              as N+import           CLaSH.Normalize                  (cleanupGraph, normalize,+                                                   runNormalization)+import           CLaSH.Primitives.Types+import           CLaSH.Rewrite.Types++import           CLaSH.Util+++-- | Generate a VHDL testbench for a component given a set of stimuli and a+-- set of matching expected outputs+genTestBench :: DebugLevel+             -> Supply+             -> PrimMap                      -- ^ Primitives+             -> (Type -> Maybe (Either String HWType))+             -> VHDLState+             -> 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 vhdlState globals stimuliNmM expectedNmM+  (Component cName [(clkName,Clock rate),(rstName,Reset reset)] [inp] outp _)+  = eitherT error return $ do+  let rateF  = fromIntegral rate :: Float+      resetF = fromIntegral reset :: Float+      emptyStimuli = right ([],[],vhdlState,0)+  (inpDecls,inpComps,vhdlState',inpCnt) <- flip (maybe emptyStimuli) stimuliNmM $ \stimuliNm -> do+    (decls,sigVs,comps,vhdlState') <- prepareSignals vhdlState primMap globals+                                        typeTrans normalizeSignal Nothing+                                        stimuliNm++    let sigAs     = zipWith delayedSignal sigVs+                      (0.0:iterate (+rateF) (0.6 * rateF))+        sigAs'    = BlackBoxE ( PP.displayT . PP.renderPretty 0.4 80 . PP.vsep+                              $ PP.punctuate PP.comma sigAs ) Nothing+        inpAssign = Assignment (fst inp) sigAs'++    return (inpAssign:decls,comps,vhdlState',length sigVs)++  let emptyExpected = right ([],[],vhdlState',0)+  (expDecls,expComps,vhdlState'',expCnt) <- flip (maybe emptyExpected) expectedNmM $ \expectedNm -> do+    (decls,sigVs,comps,vhdlState'') <- prepareSignals vhdlState' primMap globals typeTrans normalizeSignal (Just inpCnt) expectedNm+    let asserts  = map (genAssert (fst outp)) sigVs+        procDecl = PP.vsep+                   [ "process is"+                   , "begin"+                   , PP.indent 2 ( PP.vsep $+                                   map (<> PP.semi) $+                                   concat [ ["wait for" <+> renderFloat2Dec (rateF * 0.4) <+> "ns" ]+                                            , intersperse ("wait for" <+> renderFloat2Dec rateF <+> "ns") asserts+                                            , ["wait"]+                                            ]+                                 )+                   , "end process" <> PP.semi+                   ]+        procDecl' = BlackBoxD (PP.displayT $ PP.renderPretty 0.4 80 procDecl)+    return (procDecl':decls,comps,vhdlState'',length sigVs)++  let finExpr = "'1' after" <+> renderFloat2Dec (rateF * (fromIntegral (max inpCnt expCnt) - 0.5)) <+> "ns"+      finDecl = [ NetDecl "finished" Bit (Just (N.Literal Nothing (BitLit L)))+                , Assignment "finished" (BlackBoxE (PP.displayT $ PP.renderCompact finExpr) Nothing)+                , Assignment "done" (Identifier "finished" Nothing)+                ]++      clkExpr = "not" <+> PP.text clkName <+> "after" <+> renderFloat2Dec (rateF * 0.5) <+> "ns when finished = '0'"+      clkDecl = [ NetDecl clkName (Clock rate) (Just (N.Literal Nothing (BitLit L)))+                , Assignment clkName (BlackBoxE (PP.displayT $ PP.renderCompact clkExpr) Nothing)+                ]++      retExpr = PP.vcat $ PP.punctuate PP.comma+                  [ "'0' after 0 ns"+                  , "'1' after" <+> renderFloat2Dec (0.24 * resetF) <+> "ns"+                  ]+      retDecl = [ NetDecl rstName Bit Nothing+                , Assignment rstName (BlackBoxE (PP.displayT $ PP.renderCompact retExpr) Nothing)+                ]+      ioDecl  = [ uncurry NetDecl inp  Nothing+                , uncurry NetDecl outp Nothing+                ]++      instDecl = InstDecl cName "totest"+                  (map (\i -> (i,Identifier i Nothing))+                       [ clkName, rstName, fst inp, fst outp ]+                  )++      tbComp = Component "testbench" [] [] ("done",Bit)+                  (concat [ finDecl+                          , clkDecl+                          , retDecl+                          , ioDecl+                          , [instDecl]+                          , inpDecls+                          , expDecls+                          ])++  return (tbComp:inpComps ++ expComps,vhdlState'')++  where+    normalizeSignal :: (HashMap TmName (Type,Term)+                    -> TmName+                    -> [(TmName,(Type,Term))])+    normalizeSignal glbls bndr =+      runNormalization dbgLvl supply glbls typeTrans (normalize [bndr] >>= cleanupGraph [bndr])++genTestBench _ _ _ _ v _ _ _ c = traceIf True ("Can't make testbench for: " ++ show c) $ return ([],v)++delayedSignal :: Text+              -> Float+              -> PP.Doc+delayedSignal s t =+  PP.hsep+    [ PP.text s+    , "after"+    , renderFloat2Dec t+    , "ns"+    ]++renderFloat2Dec :: Float -> PP.Doc+renderFloat2Dec = PP.text . Builder.toLazyText . Builder.formatRealFloat Builder.Fixed (Just 2)++genAssert :: Identifier -> Identifier -> PP.Doc+genAssert compO expV = PP.hsep+  [ PP.text "assert"+  , PP.parens $ PP.hsep [ PP.text compO+                        , PP.equals+                        , PP.text expV+                        ]+  , PP.text "report"+  , PP.parens (PP.hsep [ "\"expected: \" &"+                       , "to_string" <+> PP.parens (PP.text expV)+                       , "& \", actual: \" &"+                       , "to_string" <+> PP.parens (PP.text compO)+                       ])+  , PP.text "severity error"+  ]++prepareSignals :: VHDLState+               -> PrimMap+               -> HashMap TmName (Type,Term)+               -> (Type -> Maybe (Either String HWType))+               -> ( HashMap TmName (Type,Term)+                    -> TmName+                    -> [(TmName,(Type,Term))])+               -> Maybe Int+               -> TmName+               -> EitherT String IO+                    ([Declaration],[Identifier],[Component],VHDLState)+prepareSignals vhdlState primMap globals typeTrans normalizeSignal mStart signalNm = do+  let signalS = name2String signalNm+  (signalTy,signalTm) <- hoistEither $ note ($(curLoc) ++ "Unable to find: " ++ signalS)+                                            (HashMap.lookup signalNm globals)+  signalList          <- termToList signalTm+  elemTy              <- stimuliElemTy signalTy++  let signalK  = name2Integer signalNm+      elemNms  = map (\i -> makeName (signalS ++ show i) signalK) [(0::Int)..]+      elemBnds = zipWith (\nm e -> (nm,(elemTy,e))) elemNms signalList+      signalList_normalized = map (normalizeSignal (HashMap.fromList elemBnds `HashMap.union` globals)+                                  . fst+                                  ) elemBnds++  lift $ createSignal vhdlState primMap typeTrans mStart signalList_normalized++termToList :: Monad m => Term -> EitherT String m [Term]+termToList e = case second lefts $ collectArgs e of+  (Data dc,[])+    | name2String (dcName dc) == "[]" -> pure []+    | name2String (dcName dc) == "Prelude.List.Nil" -> pure []+    | otherwise                                 -> errNoConstruct $(curLoc)+  (Data dc,[hdArg,tlArg])+    | name2String (dcName dc) == ":"  -> (hdArg:) <$> termToList tlArg+    | name2String (dcName dc) == "Prelude.List.::"  -> (hdArg:) <$> termToList tlArg+    | otherwise                                 -> errNoConstruct $(curLoc)+  _ -> errNoConstruct $(curLoc)+  where+    errNoConstruct l = left $ l ++ "Can't deconstruct list literal: " ++ show (second lefts $ collectArgs e)++stimuliElemTy :: Monad m => Type -> EitherT String m Type+stimuliElemTy ty = case splitTyConAppM ty of+  (Just (tc,[arg]))+    | name2String (tyConName tc) == "GHC.Types.[]" -> return arg+    | name2String (tyConName tc) == "Prelude.List.List" -> return arg+    | otherwise -> left $ $(curLoc) ++ "Not a List TyCon: " ++ showDoc ty+  _ -> left $ $(curLoc) ++ "Not a List TyCon: " ++ showDoc ty++createSignal :: VHDLState+             -> PrimMap+             -> (Type -> Maybe (Either String HWType))+             -> Maybe Int+             -> [[(TmName,(Type,Term))]]+             -> IO ([Declaration],[Identifier],[Component],VHDLState)+createSignal vhdlState primMap typeTrans mStart normalizedSignals = do+  let (signalHds,signalTls) = unzip $ map (\(l:ls) -> (l,ls)) normalizedSignals+      sigEs                 = map (\(_,(_,Letrec b)) -> unrec . fst $ unsafeUnbind b+                                  ) signalHds+      newExpr               = Letrec $ bind (rec $ concat sigEs)+                                            (Var (fst . snd $ head signalHds)+                                                 (fst $ head signalHds))+      newBndr               = (fst $ head signalHds, (fst . snd $ head signalHds, newExpr))++  (Component _ _ _ _ decls:comps,vhdlState') <- genNetlist (Just vhdlState)+                                                             (HashMap.fromList $ newBndr : concat signalTls)+                                                             primMap+                                                             typeTrans+                                                             mStart+                                                             (fst $ head signalHds)++  let sigVs = mapMaybe (\d -> case d of+                                NetDecl i _ _ -> Just i+                                _             -> Nothing+                       )+                       decls++  return (decls,sigVs,comps,vhdlState')
+ src/CLaSH/Driver/Types.hs view
@@ -0,0 +1,10 @@+-- | Type definitions used by the Driver module+module CLaSH.Driver.Types where++import Data.HashMap.Lazy (HashMap)++import CLaSH.Core.Term   (Term,TmName)+import CLaSH.Core.Type   (Type)++-- | Global function binders+type BindingMap = HashMap TmName (Type,Term)
+ src/CLaSH/Netlist.hs view
@@ -0,0 +1,327 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections   #-}++-- | Create Netlists out of normalized CoreHW Terms+module CLaSH.Netlist where++import           Control.Applicative        (liftA2)+import           Control.Lens               ((.=), (<<%=))+import qualified Control.Lens               as Lens+import qualified Control.Monad              as Monad+import           Control.Monad.State        (runStateT)+import           Control.Monad.Writer       (listen, runWriterT)+import qualified Data.ByteString.Lazy.Char8 as LZ+import           Data.Either                (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, string2Name, 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.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.Util+import           CLaSH.Normalize.Util+import           CLaSH.Primitives.Types     as P+import           CLaSH.Util++-- | Generate a hierarchical netlist out of a set of global binders with+-- @topEntity@ at the top.+genNetlist :: Maybe VHDLState+           -- ^ State for the 'CLaSH.Netlist.VHDL.VHDLM' Monad+           -> HashMap TmName (Type,Term)+           -- ^ Global binders+           -> PrimMap+           -- ^ Primitive definitions+           -> (Type -> Maybe (Either String HWType))+           -- ^ Hardcoded Type -> HWType translator+           -> Maybe Int+           -- ^ Symbol count+           -> TmName+           -- ^ Name of the @topEntity@+           -> IO ([Component],VHDLState)+genNetlist vhdlStateM globals primMap typeTrans mStart topEntity = do+  (_,s) <- runNetlistMonad vhdlStateM globals primMap typeTrans $ genComponent topEntity mStart+  return (HashMap.elems $ _components s, _vhdlMState s)++-- | Run a NetlistMonad action in a given environment+runNetlistMonad :: Maybe VHDLState+                -- ^ State for the 'CLaSH.Netlist.VHDL.VHDLM' Monad+                -> HashMap TmName (Type,Term)+                -- ^ Global binders+                -> PrimMap+                -- ^ Primitive Definitions+                -> (Type -> Maybe (Either String HWType))+                -- ^ Hardcode Type -> HWType translator+                -> NetlistMonad a+                -- ^ Action to run+                -> IO (a,NetlistState)+runNetlistMonad vhdlStateM s p typeTrans+  = runFreshMT+  . flip runStateT s'+  . (fmap fst . runWriterT)+  . runNetlist+  where+    s' = NetlistState s HashMap.empty 0 0 HashMap.empty p (fromMaybe (HashSet.empty,0,HashMap.empty) vhdlStateM) typeTrans++-- | Generate a component for a given function (caching)+genComponent :: TmName -- ^ Name of the function+             -> Maybe Int -- ^ Starting value of the unique counter+             -> NetlistMonad Component+genComponent compName mStart = do+  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++-- | Generate a component for a given function+genComponentT :: TmName -- ^ Name of the function+              -> Term -- ^ Corresponding term+              -> Maybe Int -- ^ Starting value of the unique counter+              -> NetlistMonad Component+genComponentT compName componentExpr mStart = do+  varCount .= fromMaybe 0 mStart+  componentNumber <- cmpCount <<%= (+1)++  let componentName' = (`Text.append` (Text.pack $ show componentNumber))+                     . ifThenElse Text.null+                          (`Text.append` Text.pack "Component_")+                          (`Text.append` Text.pack "_")+                     . mkBasicId+                     . last+                     . Text.splitOn (Text.pack ".")+                     . Text.pack+                     $ name2String compName++  (arguments,binders,result) <- do { normalizedM <- splitNormalized componentExpr+                                   ; case normalizedM of+                                       Right normalized -> mkUniqueNormalized normalized+                                       Left err         -> error err+                                   }++  let ids = HashMap.fromList+          $ map (\(Id v (Embed t)) -> (v,t))+          $ arguments ++ map fst binders++  gamma <- (ids `HashMap.union`) . HashMap.map fst+           <$> Lens.use bindings++  varEnv .= gamma++  typeTrans    <- Lens.use typeTranslator+  let resType  = unsafeCoreTypeToHWType typeTrans $ ids HashMap.! result+      argTypes = map (\(Id _ (Embed t)) -> unsafeCoreTypeToHWType typeTrans t) arguments++  let netDecls = map (\(id_,_) ->+                        NetDecl (mkBasicId . Text.pack . name2String $ varName id_)+                                (unsafeCoreTypeToHWType typeTrans . unembed $ varType id_)+                                Nothing+                     ) $ filter ((/= result) . varName . fst) binders+  (decls,clks) <- listen $ concat <$> mapM (uncurry mkDeclarations . second unembed) binders++  let compInps       = zip (map (mkBasicId . Text.pack . name2String . varName) arguments) argTypes+      compOutp       = (mkBasicId . Text.pack $ name2String result, resType)+      component      = Component componentName' (nub clks) compInps compOutp (netDecls ++ decls)+  return component++-- | Generate a list of Declarations for a let-binder+mkDeclarations :: Id -- ^ LHS of the let-binder+               -> Term -- ^ RHS of the let-binder+               -> NetlistMonad [Declaration]+mkDeclarations bndr (Var _ v) = mkFunApp bndr v []++mkDeclarations bndr e@(Case _ _ []) =+  error $ $(curLoc) ++ "Case-decompositions with an empty list of alternatives not supported"++mkDeclarations bndr e@(Case (Var scrutTy scrutNm) _ [alt]) = do+  (pat,Var varTy varTm)  <- unbind alt+  typeTrans    <- Lens.use typeTranslator+  let dstId    = mkBasicId . Text.pack . name2String $ varName bndr+      altVarId = mkBasicId . Text.pack $ name2String varTm+      selId    = mkBasicId . Text.pack $ name2String scrutNm+      modifier = case pat of+        DataPat (Embed dc) ids -> let (_,tms) = unrebind ids+                                  in case elemIndex (Id varTm (Embed varTy)) tms of+                                       Nothing -> Nothing+                                       Just fI -> Just (Indexed (unsafeCoreTypeToHWType typeTrans scrutTy,dcTag dc - 1,fI))+        _                      -> error $ $(curLoc) ++ "unexpected pattern in extractor: " ++ showDoc e+      extractExpr = Identifier (maybe altVarId (const selId) modifier) modifier+  return [Assignment dstId extractExpr]++mkDeclarations bndr (Case scrut ty alts) = do+  alts'                  <- mapM unbind alts+  scrutTy                <- termType scrut+  scrutHTy               <- unsafeCoreTypeToHWTypeM scrutTy+  (scrutExpr,scrutDecls) <- first (mkScrutExpr scrutHTy (fst (last alts'))) <$> mkExpr scrutTy scrut+  (exprs,altsDecls)      <- (second concat . unzip) <$> mapM (mkCondExpr scrutHTy) alts'++  let dstId = mkBasicId . Text.pack . name2String $ varName bndr+  return $! scrutDecls ++ altsDecls ++ [CondAssignment dstId scrutExpr (reverse exprs)]+  where+    mkCondExpr :: HWType -> (Pat,Term) -> NetlistMonad ((Maybe Expr,Expr),[Declaration])+    mkCondExpr scrutHTy (pat,alt) = do+      (altExpr,altDecls) <- mkExpr ty alt+      (,altDecls) <$> case pat of+        DefaultPat           -> return (Nothing,altExpr)+        DataPat (Embed dc) _ -> return (Just (dcToLiteral scrutHTy (dcTag dc)),altExpr)+        LitPat  (Embed (IntegerLiteral i)) -> return (Just (HW.Literal Nothing (NumLit $ fromInteger i)),altExpr)+        _                    -> error $ $(curLoc) ++ "Not an integer literal in LitPat"++    mkScrutExpr :: HWType -> Pat -> Expr -> Expr+    mkScrutExpr scrutHTy pat scrutE = case pat of+      DataPat (Embed dc) _ -> let modifier = Just (DC (scrutHTy,dcTag dc - 1))+                              in case scrutE of+                                  Identifier scrutId _ -> Identifier scrutId modifier+                                  BlackBoxE bbE _      -> BlackBoxE bbE modifier+                                  _ -> error $ $(curLoc) ++ "Not in normal form: Not a variable reference or primitive as subject of a case-statement"+      _ -> scrutE++    dcToLiteral :: HWType -> Int -> Expr+    dcToLiteral Bool 1 = HW.Literal Nothing (BoolLit False)+    dcToLiteral Bool 2 = HW.Literal Nothing (BoolLit True)+    dcToLiteral Bit 1  = HW.Literal Nothing (BitLit H)+    dcToLiteral Bit 2  = HW.Literal Nothing (BitLit L)+    dcToLiteral t i    = HW.Literal (Just $ conSize t) (NumLit (i-1))++mkDeclarations bndr app = do+  let (appF,(args,tyArgs)) = second partitionEithers $ collectArgs app+  args' <- Monad.filterM (liftA2 representableType (Lens.use typeTranslator) . termType) args+  case appF of+    Var _ f+      | all isVar args' && null tyArgs -> mkFunApp bndr f args'+      | otherwise                      -> error $ $(curLoc) ++ "Not in normal form: Var-application with non-Var arguments"+    _ -> do+      (exprApp,declsApp) <- mkExpr (unembed $ varType bndr) app+      let dstId = mkBasicId . Text.pack . name2String $ varName bndr+      return (declsApp ++ [Assignment dstId exprApp])++-- | Generate a list of Declarations for a let-binder where the RHS is a function application+mkFunApp :: Id -- ^ LHS of the let-binder+         -> TmName -- ^ Name of the applied function+         -> [Term] -- ^ Function arguments+         -> NetlistMonad [Declaration]+mkFunApp dst fun args = do+  normalized <- Lens.use bindings+  case HashMap.lookup fun normalized of+    Just _ -> do+      (Component compName hidden compInps compOutp _) <- preserveVarEnv $ genComponent fun Nothing+      if length args == length compInps+        then let dstId         = mkBasicId . Text.pack . name2String $ varName dst+                 args'         = map varToExpr args+                 hiddenAssigns = map (\(i,_) -> (i,Identifier i Nothing)) hidden+                 inpAssigns    = zip (map fst compInps) args'+                 outpAssign    = (fst compOutp,Identifier dstId Nothing)+                 instDecl      = InstDecl compName dstId (outpAssign:hiddenAssigns ++ inpAssigns)+             in return [instDecl]+        else error $ $(curLoc) ++ "under-applied normalized function"+    Nothing -> case args of+      [] -> do+        let dstId = mkBasicId . Text.pack . name2String $ varName dst+        return [Assignment dstId (Identifier (mkBasicId . Text.pack $ name2String fun) Nothing)]+      _ -> error $ $(curLoc) ++ "Unknown function: " ++ showDoc fun++-- | Generate an expression for a term occurring on the RHS of a let-binder+mkExpr :: Type -- ^ Type of the LHS of the let-binder+       -> Term -- ^ Term to convert to an expression+       -> NetlistMonad (Expr,[Declaration]) -- ^ Returned expression and a list of generate BlackBox declarations+mkExpr _ (Core.Literal lit) = return (HW.Literal Nothing . NumLit $ fromInteger  $! i,[])+  where+    i = case lit of+          (IntegerLiteral i') -> i'+          _ -> error $ $(curLoc) ++ "not an integer literal"++mkExpr ty app = do+  let (appF,(args,tyArgs)) = second partitionEithers $ collectArgs app+  hwTy <- unsafeCoreTypeToHWTypeM ty+  args' <- Monad.filterM (liftA2 representableType (Lens.use typeTranslator) . termType) args+  case appF of+    Data dc+      | all (\e -> isConstant e || isVar e) args' -> mkDcApplication hwTy dc args'+      | otherwise                                 -> error $ $(curLoc) ++ "Not in normal form: DataCon-application with non-Simple arguments"+    Prim nm _ -> do+      bbM <- fmap (HashMap.lookup . LZ.pack $ name2String nm) $ Lens.use primitives+      case bbM of+        Just p@(P.BlackBox {}) ->+          case template p of+            Left templD -> do+              i <- varCount <<%= (+1)+              let tmpNm   = "tmp_" ++ show i+                  tmpId   = Id (string2Name tmpNm) (Embed ty)+                  tmpS    = Text.pack tmpNm+                  netDecl = NetDecl tmpS hwTy Nothing+              (bbCtx,ctxDcls) <- mkBlackBoxContext tmpId args+              bb <- fmap BlackBoxD $! mkBlackBox templD bbCtx+              return (Identifier tmpS Nothing, ctxDcls ++ [netDecl,bb])+            Right templE -> do+              (bbCtx,ctxDcls) <- mkBlackBoxContext (Id (string2Name "_ERROR_") (Embed ty)) args+              bb <- fmap (`BlackBoxE` Nothing) $! mkBlackBox templE bbCtx+              return (bb,ctxDcls)+        _ -> error $ $(curLoc) ++ "No blackbox found: " ++ name2String nm+    Var _ f+      | null args -> return (Identifier (mkBasicId . Text.pack $ name2String f) Nothing,[])+      | otherwise -> error $ $(curLoc) ++ "Not in normal form: top-level binder in argument position: " ++ showDoc app+    _ -> error $ $(curLoc) ++ "Not in normal form: application of a Let/Lam/Case: " ++ showDoc app++-- | Generate an expression for a DataCon application occurring on the RHS of a let-binder+mkDcApplication :: HWType -- ^ HWType of the LHS of the let-binder+                -> DataCon -- ^ Applied DataCon+                -> [Term] -- ^ DataCon Arguments+                -> NetlistMonad (Expr,[Declaration]) -- ^ Returned expression and a list of generate BlackBox declarations+mkDcApplication dstHType dc args = do+  argTys              <- mapM termType args+  (argExprs,argDecls) <- fmap (second concat . unzip) $! mapM (\(e,t) -> mkExpr t e) (zip args argTys)++  fmap (,argDecls) $! case dstHType of+    SP _ dcArgPairs -> do+      let dcNameBS = Text.pack . name2String $ dcName dc+          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)+        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)+        LT -> error $ $(curLoc) ++ "Over-applied constructor"+        GT -> error $ $(curLoc) ++ "Under-applied constructor"+    Sum _ dcs ->+      let dcNameBS = Text.pack . name2String $ dcName dc+          dcI = fromMaybe (error "Sum: dc not found") $ elemIndex dcNameBS dcs+      in  return (HW.DataCon dstHType (Just $ DC (dstHType,dcI)) [])+    Bool ->+      let dc' = case name2String $ dcName dc of+                 "True"  -> HW.Literal Nothing (BoolLit True)+                 "False" -> HW.Literal Nothing (BoolLit False)+                 _ -> error $ $(curLoc) ++ "unknown bool literal: " ++ show dc+      in  return dc'+    Bit ->+      let dc' = case name2String $ dcName dc of+                 "H" -> HW.Literal Nothing (BitLit H)+                 "L" -> HW.Literal Nothing (BitLit L)+                 _ -> error $ $(curLoc) ++ "unknown bit literal: " ++ show dc+      in return dc'+    Integer ->+      let dc' = case name2String $ dcName dc of+                  "S#" -> Nothing+                  _    -> error $ $(curLoc) ++ "not a simple integer: " ++ show dc+      in return (HW.DataCon dstHType dc' argExprs)+    Vector 0 _ -> return (HW.DataCon dstHType Nothing          [])+    Vector 1 _ -> return (HW.DataCon dstHType (Just VecAppend) [head argExprs])+    Vector _ _ -> return (HW.DataCon dstHType (Just VecAppend) argExprs)++    _ -> error $ $(curLoc) ++ "mkDcApplication undefined for: " ++ show dstHType
+ src/CLaSH/Netlist.hs-boot view
@@ -0,0 +1,16 @@+module CLaSH.Netlist (genComponent,mkDcApplication) where++import CLaSH.Core.DataCon   (DataCon)+import CLaSH.Core.Term      (Term,TmName)+import CLaSH.Netlist.Types  (Expr,HWType,NetlistMonad,Component,Declaration)++genComponent ::+  TmName+  -> Maybe Int+  -> NetlistMonad Component++mkDcApplication ::+  HWType+  -> DataCon+  -> [Term]+  -> NetlistMonad (Expr,[Declaration])
+ src/CLaSH/Netlist/BlackBox.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards     #-}+{-# LANGUAGE TemplateHaskell   #-}+{-# 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 qualified Data.ByteString.Lazy.Char8    as BSL+import           Data.Either                   (lefts, partitionEithers)+import qualified Data.HashMap.Lazy             as HashMap+import           Data.List                     (partition)+import           Data.Maybe                    (catMaybes, fromJust)+import           Data.Monoid                   (mconcat)+import           Data.Text.Lazy                (Text, pack)+import           Unbound.LocallyNameless       (embed, name2String, string2Name,+                                                unembed)++import           CLaSH.Core.Literal            as L (Literal (..))+import           CLaSH.Core.Pretty             (showDoc)+import           CLaSH.Core.Term               as C (Term (..), TmName)+import           CLaSH.Core.Util               (collectArgs, isFun, termType)+import           CLaSH.Core.Var                as V (Id, Var (..))+import {-# SOURCE #-} CLaSH.Netlist            (genComponent, mkDcApplication)+import           CLaSH.Netlist.BlackBox.Parser as B+import           CLaSH.Netlist.BlackBox.Types  as B+import           CLaSH.Netlist.BlackBox.Util   as B+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++-- | Generate the context for a BlackBox instantiation.+mkBlackBoxContext :: Id -- ^ Identifier binding the primitive/blackbox application+                  -> [Term] -- ^ Arguments of the primitive/blackbox application+                  -> NetlistMonad (BlackBoxContext,[Declaration])+mkBlackBoxContext resId args = do+    -- Make context inputs+    args'                 <- fmap (zip args) $ mapM isFun 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++    -- Make context result+    let res   = Left . mkBasicId . pack $ name2String (V.varName resId)+    resTy <- N.unsafeCoreTypeToHWTypeM (unembed $ V.varType resId)++    return ( Context (res,resTy) varInps (map fst litInps) funInps+           , concat declssV ++ concat declssL ++ concat declssF+           )+  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 context:\n" ++ show bbCtx ++ "\nwith template:\n" ++ show templ ++ "\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),[])++mkInput (Var ty v, False) = do+  let vT = mkBasicId . pack $ name2String v+  hwTy <- lift $ N.unsafeCoreTypeToHWTypeM ty+  case synchronizedClk ty of+    Just clk -> return ((Right (vT,clk), hwTy),[])+    Nothing  -> return ((Left vT, hwTy),[])++mkInput (e, False) = case collectArgs e of+  (Prim f _, args) -> mkInput' f args+  _                -> fmap (first (first Left)) $ mkLitInput e+  where+    mkInput' nm args = do+      bbM <- fmap (HashMap.lookup . BSL.pack $ name2String nm) $ Lens.use primitives+      case bbM of+        Just p@(P.BlackBox {}) -> do+          i           <- lift $ varCount <<%= (+1)+          ty          <- termType e+          let dstNm   = "bb_sig_" ++ show i+              dstId   = pack dstNm+              resId   = Id (string2Name dstNm) (embed ty)+          (bbCtx,ctxDecls) <- lift $ mkBlackBoxContext resId (lefts args)+          let hwTy = snd $ result bbCtx+          case template p of+            (Left tempD)  -> do+              let netDecl = N.NetDecl dstId hwTy Nothing+                  bbCtx'  = bbCtx { result = first (either (Left . const dstId)+                                                           (Right . first (const dstId)))+                                                           (result bbCtx) }+              bbDecl      <- fmap N.BlackBoxD $ lift $ mkBlackBox tempD bbCtx'+              return ((Left dstId, hwTy),ctxDecls ++ [netDecl,bbDecl])+            (Right tempE) -> do+              bb   <- lift $ mkBlackBox tempE bbCtx+              let bb' = mconcat [pack "(",bb,pack ")"]+              return ((Left bb', hwTy),ctxDecls)+        _ -> error $ $(curLoc) ++ "No blackbox found: " ++ name2String 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+  args' <- filterM (fmap (representableType typeTrans) . termType) (lefts args)+  hwTy  <- N.termHWType 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+           -> Term -- ^ The function argument term+           -> MaybeT NetlistMonad ((BlackBoxTemplate,BlackBoxContext),[Declaration])+mkFunInput resId e = case collectArgs e of+  (Prim nm _, args) -> do+    bbM <- fmap (HashMap.lookup . BSL.pack $ name2String nm) $ Lens.use primitives+    case bbM of+      Just p@(P.BlackBox {}) -> do+        (bbCtx,dcls) <- lift $ mkBlackBoxContext resId (lefts args)+        let (l,err) = either runParse (first (([O,C " <= "] ++) . (++ [C ";"])) . runParse) (template p)+        if null err+          then do+            l' <- lift $ instantiateSym l+            return ((l',bbCtx),dcls)+          else error $ $(curLoc) ++ "\nTemplate:\n" ++ show (template p) ++ "\nHas errors:\n" ++ show err+      _ -> error $ "No blackbox found: " ++ name2String nm+  (Var ty fun, args) -> do+    normalized <- Lens.use bindings+    case HashMap.lookup fun normalized of+      Just _ -> do+        (bbCtx,dcls) <- lift $ mkBlackBoxContext resId (lefts args)+        (Component compName hidden compInps compOutp _) <- lift $ 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 instDecl      = InstDecl compName (pack ("comp_inst_" ++ show i)) (outpAssign:hiddenAssigns ++ inpAssigns)+        templ <- fmap (pack . show . fromJust) $ liftState vhdlMState $ inst instDecl+        let (line,err)    = runParse templ+        if null err+          then return ((line,bbCtx),dcls)+          else error $ $(curLoc) ++ "\nTemplate:\n" ++ show templ ++ "\nHas errors:\n" ++ show err+      Nothing -> return $ error $ $(curLoc) ++ "Cannot make function input for: " ++ showDoc e+  _ -> return $ error $ $(curLoc) ++ "Cannot make function input for: " ++ showDoc e++-- | Instantiate symbols references with a new symbol and increment symbol counter+instantiateSym :: BlackBoxTemplate+               -> NetlistMonad BlackBoxTemplate+instantiateSym l = do+  i <- Lens.use varCount+  let (l',i') = setSym i l+  varCount .= i'+  return l'
+ src/CLaSH/Netlist/BlackBox/Parser.hs view
@@ -0,0 +1,87 @@+-- | Parser definitions for BlackBox templates+module CLaSH.Netlist.BlackBox.Parser+  (runParse)+where++import           Data.ListLike.Text.TextLazy              ()+import           Data.Text.Lazy                           (Text, pack)+import           Text.ParserCombinators.UU+import           Text.ParserCombinators.UU.BasicInstances hiding (Parser)+import qualified Text.ParserCombinators.UU.Core           as PCC (parse)+import           Text.ParserCombinators.UU.Utils          hiding (pBrackets)++import           CLaSH.Netlist.BlackBox.Types++type Parser a = P (Str Char Text LineColPos) a+++-- | Parse a text as a BlackBoxTemplate, returns a list of errors in case+-- parsing fails+runParse :: Text -> (BlackBoxTemplate, [Error LineColPos])+runParse = PCC.parse ((,) <$> pBlackBoxD <*> pEnd)+         . createStr (LineColPos 0 0 0)++-- | Parse a BlackBoxTemplate (Declarations and Expressions)+pBlackBoxD :: Parser BlackBoxTemplate+pBlackBoxD = pSome pElement++-- | Parse a single Template Element+pElement :: Parser Element+pElement  =  pTagD+         <|> C <$> pText++-- | Parse the Text part of a Template+pText :: Parser Text+pText = pack <$> pList1 (pRange ('\000','\125'))++-- | Parse a Declaration or Expression element+pTagD :: Parser Element+pTagD =  D <$> pDecl+     <|> pTagE++-- | Parse a Declaration+pDecl :: Parser Decl+pDecl = Decl <$> (pTokenWS "~INST" *> pNatural) <*>+        ((:) <$> pOutput <*> pList pInput) <* pToken "~INST"++-- | Parse the output tag of Declaration+pOutput :: Parser BlackBoxTemplate+pOutput = pTokenWS "~OUTPUT" *> pTokenWS "<=" *> pBlackBoxE <* pTokenWS "~"++-- | Parse the input tag of Declaration+pInput :: Parser BlackBoxTemplate+pInput = pTokenWS "~INPUT" *> pTokenWS "<=" *> pBlackBoxE <* pTokenWS "~"++-- | 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)+     <|> Def Nothing   <$  pToken "~DEFAULTO"+     <|> (Def . Just)  <$> (pToken "~DEFAULT" *> pBrackets pNatural)++-- | Parse a bracketed text+pBrackets :: Parser a -> Parser a+pBrackets p = pSym '[' *> p <* pSym ']'++-- | Parse a token and eat trailing whitespace+pTokenWS :: String -> Parser String+pTokenWS keyw = pToken keyw <* pSpaces++-- | Parse the expression part of Blackbox Templates+pBlackBoxE :: Parser BlackBoxTemplate+pBlackBoxE = pSome pElemE++-- | Parse an Expression or Text+pElemE :: Parser Element+pElemE = pTagE+      <|> C <$> pText
+ src/CLaSH/Netlist/BlackBox/Types.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | Types used in BlackBox modules+module CLaSH.Netlist.BlackBox.Types where++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)++-- | A BlackBox Template is a List of Elements+type BlackBoxTemplate = [Element]++-- | Elements of a blackbox context+data Element = C   Text          -- ^ Constant+             | D   Decl          -- ^ Component instantiation hole+             | O                 -- ^ Output hole+             | I   Int           -- ^ Input hole+             | L   Int           -- ^ Literal hole+             | Sym Int           -- ^ Symbol hole+             | Clk (Maybe Int)   -- ^ Clock hole (Maybe clk corresponding to+                                 -- input, clk corresponding to output if Nothing)+             | Rst (Maybe Int)   -- ^ Reset hole+             | Typ (Maybe Int)   -- ^ Type declaration hole+             | TypM (Maybe Int)  -- ^ Type root hole+             | Def (Maybe Int)   -- ^ Default value hole+  deriving Show++-- | Component instantiation hole. First argument indicates which function argument+-- to instantiate. Second argument corresponds to output and input assignments,+-- where the first element is the output assignment, and the subsequent elements+-- are the consecutive input assignments.+data Decl = Decl Int [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, Monad, MonadWriter [(Identifier,HWType)], MonadState VHDLState)
+ src/CLaSH/Netlist/BlackBox/Util.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Utilties to verify blackbox contexts against templates and rendering+-- filled in templates+module CLaSH.Netlist.BlackBox.Util where++import           Control.Lens                         (at, use, (%=), (+=), _1,+                                                       _2)+import           Control.Monad.State                  (State, lift, runState)+import           Control.Monad.Writer                 (runWriterT, 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           CLaSH.Netlist.BlackBox.Types+import           CLaSH.Netlist.Types                  (HWType (..), Identifier,+                                                       VHDLState)+import           CLaSH.Netlist.VHDL                   (vhdlType,+                                                       vhdlTypeDefault,+                                                       vhdlTypeMark)+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+                      -> 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 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 l'+                            _ -> -1+                   ) l++-- | 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++-- | Update all the symbol references in a template, and increment the symbol+-- counter for every newly encountered symbol.+setSym :: Int -> BlackBoxTemplate -> (BlackBoxTemplate,Int)+setSym i l+  = second fst+  $ runState (setSym' l) (i,IntMap.empty)+  where+    setSym' :: BlackBoxTemplate -> State (Int,IntMap.IntMap Int) BlackBoxTemplate+    setSym' = mapM (\e -> case e of+                      Sym i'        -> do symM <- use (_2 . at i')+                                          case symM of+                                            Nothing -> do k <- use _1+                                                          _1 += 1+                                                          _2 %= IntMap.insert i' k+                                                          return (Sym k)+                                            Just k  -> return (Sym k)+                      D (Decl n l') -> D <$> (Decl n <$> mapM setSym' l')+                      _             -> pure e+              )++-- | Get the name of the clock of an identifier+clkSyncId :: SyncIdentifier -> Identifier+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+               -> 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+  $ mapM (renderElem bbCtx) l++-- | Render a single template element+renderElem :: BlackBoxContext+           -> Element+           -> BlackBoxMonad Text+renderElem b (D (Decl n (l:ls))) = do+  o  <- lineToIdentifier b l+  is <- mapM (lineToIdentifier 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++renderElem b e = either id fst <$> mkSyncIdentifier b e++-- | 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+                 -> BlackBoxTemplate+                 -> BlackBoxMonad (SyncIdentifier,HWType)+lineToIdentifier b = foldrM (\e (a,_) -> do+                              e' <- mkSyncIdentifier  b e+                              case (e', a) of+                                (Left t, Left t')             -> return (Left  (t `Text.append` t'), ty)+                                (Left t, Right (t',clk))      -> return (Right (t `Text.append` t',clk), ty)+                                (Right (t,clk), Left t')      -> return (Right (t `Text.append` t',clk), ty)+                                (Right (t,clk), Right (t',_)) -> return (Right (t `Text.append` t',clk), ty)+                   ) (Left Text.empty,ty)+  where+    ty = Void++-- | 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 t = clkSyncId $ fst $ result b+                                     in tell [(t,Clock 10)] >> return (Left t)+mkSyncIdentifier b (Clk (Just n))  = let t = clkSyncId $ fst $ inputs b !! n+                                     in tell [(t,Clock 10)] >> return (Left t)+mkSyncIdentifier b (Rst Nothing)   = let t = (`Text.append` Text.pack "_rst") . clkSyncId $ fst $ result b+                                     in tell [(t,Reset 10)] >> return (Left t)+mkSyncIdentifier b (Rst (Just n))  = let t = (`Text.append` Text.pack "_rst") . clkSyncId $ fst $ inputs b !! n+                                     in tell [(t,Reset 10)] >> return (Left t)+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 (Def Nothing)   = fmap (Left . displayT . renderOneLine) . B . lift . vhdlTypeDefault . snd $ result b+mkSyncIdentifier b (Def (Just n))  = fmap (Left . displayT . renderOneLine) . B . lift . vhdlTypeDefault . snd $ inputs b !! n+mkSyncIdentifier b (D _)           = error $ $(curLoc) ++ "Unexpected component declaration"
+ src/CLaSH/Netlist/Id.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Transform/format a Netlist Identifier so that it is acceptable as a VHDL identifier+module CLaSH.Netlist.Id+  (mkBasicId)+where++import Data.Char      (isAsciiLower,isAsciiUpper,isDigit,ord)+import Data.Text.Lazy as Text+import Numeric        (showHex)++-- | Transform/format a text so that it is acceptable as a VHDL identifier+mkBasicId :: Text+          -> Text+mkBasicId = stripMultiscore . stripLeading . zEncode+  where+    stripLeading    = Text.dropWhile (`elem` ['0'..'9'])+    stripMultiscore = Text.concat+                    . Prelude.map (\cs -> case Text.head cs of+                                            '_' -> "_"+                                            _   -> cs+                                  )+                    . Text.group++type UserString    = Text -- As the user typed it+type EncodedString = Text -- Encoded form++zEncode :: UserString -> EncodedString+zEncode cs = go (uncons cs)+  where+    go Nothing         = empty+    go (Just (c,cs'))  = append (encodeDigitCh c) (go' $ uncons cs')+    go' Nothing        = empty+    go' (Just (c,cs')) = append (encodeCh c) (go' $ uncons cs')++encodeDigitCh :: Char -> EncodedString+encodeDigitCh c | isDigit c = encodeAsUnicodeChar c+encodeDigitCh c             = encodeCh c++encodeCh :: Char -> EncodedString+encodeCh c | unencodedChar c = singleton c     -- Common case first++-- Constructors+encodeCh '['  = "ZM"+encodeCh ']'  = "ZN"+encodeCh ':'  = "ZC"++-- Variables+encodeCh '&'  = "za"+encodeCh '|'  = "zb"+encodeCh '^'  = "zc"+encodeCh '$'  = "zd"+encodeCh '='  = "ze"+encodeCh '>'  = "zf"+encodeCh '#'  = "zg"+encodeCh '.'  = "zh"+encodeCh '<'  = "zu"+encodeCh '-'  = "zj"+encodeCh '!'  = "zk"+encodeCh '+'  = "zl"+encodeCh '\'' = "zm"+encodeCh '\\' = "zn"+encodeCh '/'  = "zo"+encodeCh '*'  = "zp"+encodeCh '%'  = "zq"+encodeCh c    = encodeAsUnicodeChar c++encodeAsUnicodeChar :: Char -> EncodedString+encodeAsUnicodeChar c = cons 'z' (if isDigit (Text.head hex_str)+                                    then hex_str+                                    else cons '0' hex_str)+  where hex_str = pack $ showHex (ord c) "U"++unencodedChar :: Char -> Bool   -- True for chars that don't need encoding+unencodedChar c  = or [ isAsciiLower c+                      , isAsciiUpper c+                      , isDigit c+                      , c == '_']
+ src/CLaSH/Netlist/Types.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell            #-}++-- | Type and instance definitions for Netlist modules+module CLaSH.Netlist.Types where++import Control.Monad.State                  (MonadIO, MonadState, StateT)+import Control.Monad.Writer                 (MonadWriter, WriterT)+import Data.ByteString.Lazy                 (ByteString)+import Data.Hashable+import Data.HashMap.Lazy                    (HashMap)+import Data.HashSet                         (HashSet)+import Data.Text.Lazy                       (Text)+import GHC.Generics                         (Generic)+import Text.PrettyPrint.Leijen.Text.Monadic (Doc)+import Unbound.LocallyNameless              (Fresh, FreshMT)++import CLaSH.Core.Term                      (Term, TmName)+import CLaSH.Core.Type                      (Type)+import CLaSH.Core.Util                      (Gamma)+import CLaSH.Primitives.Types               (Primitive)+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)++-- | State of the NetlistMonad+data NetlistState+  = NetlistState+  { _bindings       :: HashMap TmName (Type,Term) -- ^ Global binders+  , _varEnv         :: Gamma -- ^ Type environment/context+  , _varCount       :: Int -- ^ Number of signal declarations+  , _cmpCount       :: Int -- ^ Number of create components+  , _components     :: HashMap TmName Component -- ^ Cached components+  , _primitives     :: HashMap ByteString Primitive -- ^ Primitive Definitions+  , _vhdlMState     :: VHDLState -- ^ State for the 'CLaSH.Netlist.VHDL.VHDLM' Monad+  , _typeTranslator :: Type -> Maybe (Either String HWType) -- ^ Hardcoded Type -> HWType translator+  }++-- | Signal reference+type Identifier = Text++-- | Component: base unit of a Netlist+data Component+  = Component+  { componentName :: Identifier -- ^ Name of the component+  , hiddenPorts   :: [(Identifier,HWType)] -- ^ Ports that have no correspondence the original function definition+  , inputs        :: [(Identifier,HWType)] -- ^ Input ports+  , output        :: (Identifier,HWType) -- ^ Output port+  , declarations  :: [Declaration] -- ^ Internal declarations+  }+  deriving Show++-- | Size indication of a type (e.g. bit-size or number of elements)+type Size = Int++-- | Representable hardware types+data HWType+  = Void -- ^ Empty type+  | Bit -- ^ Bit type+  | Bool -- ^ Boolean type+  | Integer -- ^ Integer type+  | Signed   Size -- ^ Signed integer of a specified size+  | Unsigned Size -- ^ Unsigned integer of a specified size+  | Vector   Size       HWType -- ^ Vector type+  | Sum      Identifier [Identifier] -- ^ Sum type: Name and Constructor names+  | Product  Identifier [HWType] -- ^ Product type: Name and field types+  | SP       Identifier [(Identifier,[HWType])] -- ^ Sum-of-Product type: Name and Constructor names + field types+  | Clock    Int -- ^ Clock type with specified period+  | Reset    Int -- ^ Reset type corresponding to clock with a specified period+  deriving (Eq,Show,Generic)++instance Hashable HWType++-- | Internals of a Component+data Declaration+  = Assignment Identifier Expr+  -- ^ Signal assignment:+  --+  -- * Signal to assign+  --+  -- * Assigned expression+  | CondAssignment Identifier Expr [(Maybe Expr,Expr)]+  -- ^ Conditional signal assignment:+  --+  -- * Signal to assign+  --+  -- * Scrutinized expression+  --+  -- * 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+  deriving Show++-- | Expression Modifier+data Modifier+  = Indexed (HWType,Int,Int) -- ^ Index the expression: (Type of expression,DataCon tag,Field Tag)+  | DC (HWType,Int) -- ^ See expression in a DataCon context: (Type of the expression, DataCon tag)+  | VecAppend -- ^ See the expression in the context of a Vector append operation+  deriving Show++-- | Expression used in RHS of a declaration+data Expr+  = Literal    (Maybe Size) Literal -- ^ Literal expression+  | DataCon    HWType       (Maybe Modifier)  [Expr] -- ^ DataCon application+  | Identifier Identifier   (Maybe Modifier) -- ^ Signal reference+  | BlackBoxE Text (Maybe Modifier) -- ^ Instantiation of a BlackBox expression+  deriving Show++-- | Literals used in an expression+data Literal+  = NumLit  Int -- ^ Number literal+  | BitLit  Bit -- ^ Bit literal+  | BoolLit Bool -- ^ Boolean literal+  | VecLit  [Literal] -- ^ Vector literal+  deriving Show++-- | Bit literal+data Bit+  = H -- ^ High+  | L -- ^ Low+  | U -- ^ Undefined+  | Z -- ^ High-impedance+  deriving Show++makeLenses ''NetlistState
+ src/CLaSH/Netlist/Util.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE PatternGuards   #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns    #-}++-- | Utilities for converting Core Type/Term to Netlist datatypes+module CLaSH.Netlist.Util where++import           Control.Lens            ((.=),(<<%=))+import qualified Control.Lens            as Lens+import qualified Control.Monad           as Monad+import           Data.Either             (partitionEithers)+import           Data.Maybe              (catMaybes,fromMaybe)+import           Data.Text.Lazy          (pack)+import           Unbound.LocallyNameless (Embed, Fresh, bind, embed, makeName,+                                          name2Integer, name2String, unbind,+                                          unembed, unrec)++import           CLaSH.Core.DataCon      (DataCon (..))+import           CLaSH.Core.FreeVars     (termFreeIds, typeFreeVars)+import           CLaSH.Core.Pretty       (showDoc)+import           CLaSH.Core.Subst        (substTys)+import           CLaSH.Core.Term         (LetBinding, Term (..), TmName)+import           CLaSH.Core.TyCon        (TyCon (..), tyConDataCons)+import           CLaSH.Core.Type         (Type (..), TypeView (..),+                                          splitTyConAppM, tyView)+import           CLaSH.Core.Util         (collectBndrs, termType)+import           CLaSH.Core.Var          (Id, Var (..), modifyVarName)+import           CLaSH.Netlist.Types+import           CLaSH.Util++-- | 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)+                => Term+                -> m (Either String ([Id],[LetBinding],Id))+splitNormalized expr = do+  (args,letExpr) <- fmap (first partitionEithers) $ collectBndrs expr+  case letExpr of+    Letrec b+      | (tmArgs,[]) <- args -> do+          (xes,e) <- unbind b+          case e of+            Var t v -> return $! Right (tmArgs,unrec xes,Id v (embed t))+            _ -> return $! Left ($(curLoc) ++ "Not in normal form: res not simple var")+      | otherwise -> return $! Left ($(curLoc) ++ "Not in normal form: tyArgs")+    _ -> return $! Left ($(curLoc) ++ "Not in normal from: no Letrec: " ++ showDoc expr)++-- | Converts a Core type to a HWType given a function that translates certain+-- builtin types. Errors if the Core type is not translatable.+unsafeCoreTypeToHWType :: (Type -> Maybe (Either String HWType))+                       -> Type+                       -> HWType+unsafeCoreTypeToHWType builtInTranslation = either error id . coreTypeToHWType builtInTranslation++-- | Converts a Core type to a HWType within the NetlistMonad+unsafeCoreTypeToHWTypeM :: Type+                        -> NetlistMonad HWType+unsafeCoreTypeToHWTypeM ty = unsafeCoreTypeToHWType <$> Lens.use typeTranslator <*> pure ty++-- | Returns the name of the clock corresponding to a type+synchronizedClk :: Type+                -> Maybe Identifier+synchronizedClk ty+  | not . null . typeFreeVars $ ty = Nothing+  | Just (tyCon,args) <- splitTyConAppM ty+  = case name2String (tyConName tyCon) of+      "CLaSH.Signal.Signal"    -> Just (pack "clk")+      "CLaSH.Sized.Vector.Vec" -> synchronizedClk (args!!1)+      "CLaSH.Signal.SignalP"   -> Just (pack "clk")+      _                        -> Nothing+  | otherwise+  = Nothing++-- | Converts a Core type to a HWType given a function that translates certain+-- builtin types. Returns a string containing the error message when the Core+-- type is not translatable.+coreTypeToHWType :: (Type -> Maybe (Either String HWType))+                 -> Type+                 -> Either String HWType+coreTypeToHWType builtInTranslation ty =+  fromMaybe+    (case tyView ty of+       TyConApp tc args -> mkADT builtInTranslation (showDoc ty) tc args+       _                -> Left $ "Can't translate non tycon-type: " ++ showDoc ty)+    (builtInTranslation ty)++-- | Converts an algebraic Core type (split into a TyCon and its argument) to a HWType.+mkADT :: (Type -> Maybe (Either String HWType)) -- ^ Hardcoded Type -> HWType translator+      -> String -- ^ String representation of the Core type for error messages+      -> TyCon -- ^ The TyCon+      -> [Type] -- ^ Its applied arguments+      -> Either String HWType+mkADT _ tyString tc args+  | isRecursiveTy tc+  = Left $ $(curLoc) ++ "Can't translate recursive type: " ++ tyString++mkADT builtInTranslation _ tc args = case tyConDataCons tc of+  []  -> return Void+  dcs -> do+    let tcName       = pack . name2String $ tyConName tc+        argTyss      = map dcArgTys dcs+        argTVss      = map dcUnivTyVars dcs+        argSubts     = map (`zip` args) argTVss+        substArgTyss = zipWith (\s tys -> map (substTys s) tys) argSubts argTyss+    argHTyss         <- mapM (mapM (coreTypeToHWType builtInTranslation)) substArgTyss+    case (dcs,argHTyss) of+      (_:[],[elemTys@(_:_)]) -> return $ Product tcName elemTys+      (_   ,concat -> [])    -> return $ Sum tcName $ map (pack . name2String . dcName) dcs+      (_   ,elemHTys)        -> return $ SP tcName+                                      $ zipWith (\dc tys ->+                                                  ( pack . name2String $ dcName dc+                                                  , tys+                                                  )+                                                ) dcs elemHTys++-- | Simple check if a TyCon is recursively defined.+isRecursiveTy :: TyCon -> Bool+isRecursiveTy tc = case tyConDataCons tc of+    []  -> False+    dcs -> let argTyss      = map dcArgTys dcs+               argTycons    = (map fst . catMaybes) $ (concatMap . map) splitTyConAppM argTyss+           in tc `elem` argTycons++-- | Determines if a Core type is translatable to a HWType given a function that+-- translates certain builtin types.+representableType :: (Type -> Maybe (Either String HWType))+                  -> Type+                  -> Bool+representableType builtInTranslation = either (const False) (const True) . coreTypeToHWType builtInTranslation++-- | Determines the bitsize of a type+typeSize :: HWType+         -> Int+typeSize Void = 0+typeSize Bool = 1+typeSize (Clock _) = 1+typeSize (Reset _) = 1+typeSize Integer = 32+typeSize (Signed i) = i+typeSize (Unsigned i) = i+typeSize (Vector n el) = n * typeSize el+typeSize t@(SP _ cons) = conSize t ++  maximum (map (sum . map typeSize . snd) cons)+typeSize (Sum _ dcs) = ceiling . logBase (2 :: Float) . fromIntegral $ length dcs+typeSize (Product _ tys) = sum $ map typeSize tys+typeSize _ = 0++-- | Determines the bitsize of the constructor of a type+conSize :: HWType+        -> Int+conSize (SP _ cons) = ceiling . logBase (2 :: Float) . fromIntegral $ length cons+conSize t           = typeSize t++-- | Gives the length of length-indexed types+typeLength :: HWType+           -> Int+typeLength (Vector n _) = n+typeLength _            = 0++-- | Gives the HWType corresponding to a term. Returns an error if the term has+-- a Core type that is not translatable to a HWType.+termHWType :: Term+           -> NetlistMonad HWType+termHWType e = unsafeCoreTypeToHWTypeM =<< termType e++-- | Turns a Core variable reference to a Netlist expression. Errors if the term+-- is not a variable.+varToExpr :: Term+          -> Expr+varToExpr (Var _ var) = Identifier (pack $ name2String var) Nothing+varToExpr _           = error "not a var"++-- | Uniquely rename all the variables and their references in a normalized+-- term+mkUniqueNormalized :: ([Id],[LetBinding],Id)+                   -> NetlistMonad ([Id],[LetBinding],TmName)+mkUniqueNormalized (args,binds,res) = do+  let args' = zipWith (\n s -> modifyVarName (`appendToName` s) n)+                args ["_i" ++ show i | i <- [(1::Integer)..]]+  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 (res2,extraBndr) = case usesOutput of+                            [] -> (res1,[] :: [(Id, Embed Term)])+                            _  -> let res3 = appendToName (varName res) "_o_sig"+                                  in (res3,[(Id res1 (varType res),embed $ Var (unembed $ varType res) res3)])+  bndrs' <- mapM (mkUnique (varName res,res2)) bndrs+  let repl = zip args args' ++ zip bndrs bndrs'+  exprs' <- fmap (map embed) $ Monad.foldM subsBndrs exprs repl+  return (args',zip bndrs' exprs' ++ extraBndr,res1)++  where+    mkUnique :: (TmName,TmName) -> Id -> NetlistMonad Id+    mkUnique (find,repl) v = if find == varName v+      then return $ modifyVarName (const repl) v+      else do+        varCnt <- varCount <<%= (+1)+        let v' = modifyVarName (`appendToName` ('_' : show varCnt)) v+        return v'++    subsBndrs :: [Term] -> (Id,Id) -> NetlistMonad [Term]+    subsBndrs es (f,r) = mapM (subsBndr f r) es++    subsBndr :: Id -> Id -> Term -> NetlistMonad Term+    subsBndr f r e = case e of+      Var t v | v == varName f -> return . Var t $ varName r+      App e1 e2                -> App <$> subsBndr f r e1+                                      <*> subsBndr f r e2+      Case scrut ty alts       -> Case <$> subsBndr f r scrut+                                       <*> pure ty+                                       <*> mapM ( return+                                                . uncurry bind+                                                <=< secondM (subsBndr f r)+                                                <=< unbind+                                                ) alts+      _ -> return e++-- | Append a string to a name+appendToName :: TmName+             -> String+             -> TmName+appendToName n s = makeName (name2String n ++ s) (name2Integer n)++-- | Preserve the Netlist '_varEnv' and '_varCount' when executing a monadic action+preserveVarEnv :: NetlistMonad a+                  -> NetlistMonad a+preserveVarEnv action = do+  vCnt <- Lens.use varCount+  vEnv <- Lens.use varEnv+  val  <- action+  varCount .= vCnt+  varEnv   .= vEnv+  return val
+ src/CLaSH/Netlist/VHDL.hs view
@@ -0,0 +1,408 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecursiveDo       #-}+{-# LANGUAGE TupleSections     #-}+{-# LANGUAGE ViewPatterns      #-}++-- | Generate VHDL for assorted Netlist datatypes+module CLaSH.Netlist.VHDL+  ( genVHDL+  , mkTyPackage+  , vhdlType+  , vhdlTypeDefault+  , vhdlTypeMark+  , inst+  , expr+  )+where++import qualified Control.Applicative                  as A+import           Control.Lens                         hiding (Indexed)+import           Control.Monad                        (liftM,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                            (nub)+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                           (makeCached, (<:>))++type VHDLM a = State VHDLState a++-- | Generate VHDL for a Netlist component+genVHDL :: Component -> VHDLM (String,Doc)+genVHDL c = do+    _1 %= (\s -> foldr HashSet.insert s needsDec)+    (unpack cName,) A.<$> vhdl+  where+    cName   = componentName c+    vhdl    = tyImports (not $ null needsDec) <$$> linebreak <>+              entity c <$$> linebreak <>+              architecture c++    tys     =  snd (output c)+            :  map snd (inputs c)+            ++ concatMap (\d -> case d of {(NetDecl _ ty _) -> [ty]; _ -> []}) (declarations c)+    needsDec = nub $ concatMap needsTyDec tys++-- | 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" <$>+      packageDec <$>+   "end" <> semi <> packageBodyDec+  where+    hwTysSorted = topSortHWTys hwtys+    packageDec  = indent 2 (vcat $ mapM tyDec hwTysSorted)++    packageBodyDec = do+      funDecs <- catMaybes A.<$> mapM funDec hwTysSorted+      case funDecs of+        [] -> empty+        _  -> linebreak <$>+              "package" <+> "body" <+> "types" <+> "is" <$>+                indent 2 (vcat $ return funDecs) <$>+              "end" <> semi++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 [] ((:[]) . (nodesI HashMap.! t,,())) (HashMap.lookup elTy nodesI)+    edge t@(Product _ tys) = let ti = nodesI HashMap.! t+                             in mapMaybe (\ty -> liftM (ti,,()) (HashMap.lookup ty nodesI)) tys+    edge t@(SP _ ctys)     = let ti = nodesI HashMap.! t+                             in concatMap (\(_,tys) -> mapMaybe (\ty -> liftM (ti,,()) (HashMap.lookup ty nodesI)) tys) ctys+    edge _                 = []++needsTyDec :: HWType -> [HWType]+needsTyDec (Vector _ Bit)     = []+needsTyDec (Vector _ elTy)    = needsTyDec elTy ++ [Vector 0 elTy]+needsTyDec ty@(Product _ tys) = concatMap needsTyDec tys ++ [ty]+needsTyDec (SP _ tys)         = concatMap (concatMap needsTyDec . snd) tys+needsTyDec Bool               = [Bool]+needsTyDec Integer            = [Integer]+needsTyDec _                  = []++tyDec :: HWType -> VHDLM Doc+tyDec Bool = "function" <+> "toSLV" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "std_logic_vector" <> semi+tyDec Integer = "function" <+> "to_integer" <+> parens ("i" <+> colon <+> "in" <+> "integer") <+> "return" <+> "integer" <> semi++tyDec (Vector _ elTy) = "type" <+> "array_of_" <> tyName elTy <+> "is array (natural 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 -> VHDLM (Maybe Doc)+funDec Bool = fmap Just $+  "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++funDec Integer = fmap Just $+  "function" <+> "to_integer" <+> parens ("i" <+> colon <+> "in" <+> "integer") <+> "return" <+> "integer" <+> "is" <$>+  "begin" <$>+    indent 2 ("return" <+> "i" <> semi) <$>+  "end" <> semi++funDec _ = return Nothing++tyName :: HWType -> VHDLM Doc+tyName Integer           = "integer"+tyName Bit               = "std_logic"+tyName (Vector n Bit)    = "std_logic_vector_" <> int n+tyName (Vector n elTy)   = "array_of_" <> int n <> "_" <> tyName elTy+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 _ = empty++tyImports :: Bool -> VHDLM Doc+tyImports needsDec =+  punctuate' semi $ sequence $ concat+    [ [ "library IEEE"+      , "use IEEE.STD_LOGIC_1164.ALL"+      , "use IEEE.NUMERIC_STD.ALL"+      , "use work.all" ]+    , if needsDec then ["use work.types.all"] else []+    ]+++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 <+> ":=" <+> vhdlTypeDefault ty)+              | (i,ty) <- inputs c ] +++              [ (,fromIntegral $ T.length i) A.<$> (fill l (text i) <+> colon <+> "in" <+> vhdlType ty <+> ":=" <+> vhdlTypeDefault ty)+              | (i,ty) <- hiddenPorts c ] +++              [ (,fromIntegral $ T.length (fst $ output c)) A.<$> (fill l (text (fst $ output c)) <+> colon <+> "out" <+> vhdlType (snd $ output c) <+> ":=" <+> vhdlTypeDefault (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 Bit        = "std_logic"+vhdlType Bool       = "boolean"+vhdlType (Clock _)  = "std_logic"+vhdlType (Reset _)  = "std_logic"+vhdlType Integer    = "integer"+vhdlType (Signed n) = "signed" <>+                      parens ( int (n-1) <+> "downto 0")+vhdlType (Unsigned n) = "unsigned" <>+                        parens ( int (n-1) <+> "downto 0")+vhdlType (Vector n Bit) = "std_logic_vector" <> parens ( int (n-1) <+> "downto 0")+vhdlType (Vector n elTy) = "array_of_" <> tyName elTy <> parens ( int (n-1) <+> "downto 0")+vhdlType t@(SP _ _) = "std_logic_vector" <>+                      parens ( int (typeSize t - 1) <+>+                               "downto 0" )+vhdlType t@(Sum _ _) = "unsigned" <>+                        parens ( int (typeSize t -1) <+>+                                 "downto 0")+vhdlType t@(Product _ _) = tyName t+vhdlType t          = error $ "vhdlType: " ++ show t++-- | Convert a Netlist HWType to the root of a VHDL type+vhdlTypeMark :: HWType -> VHDLM Doc+vhdlTypeMark Bit             = "std_logic"+vhdlTypeMark Bool            = "boolean"+vhdlTypeMark (Clock _)       = "std_logic"+vhdlTypeMark (Reset _)       = "std_logic"+vhdlTypeMark Integer         = "integer"+vhdlTypeMark (Signed _)      = "signed"+vhdlTypeMark (Unsigned _)    = "unsigned"+vhdlTypeMark (Vector _ Bit)  = "std_logic_vector"+vhdlTypeMark (Vector _ elTy) = "array_of_" <> tyName elTy+vhdlTypeMark (SP _ _)        = "std_logic_vector"+vhdlTypeMark (Sum _ _)       = "unsigned"+vhdlTypeMark t@(Product _ _) = tyName t+vhdlTypeMark t               = error $ "vhdlTypeMark: " ++ show t++-- | Convert a Netlist HWType to a default VHDL value for that type+vhdlTypeDefault :: HWType -> VHDLM Doc+vhdlTypeDefault Bit                 = "'0'"+vhdlTypeDefault Bool                = "false"+vhdlTypeDefault Integer             = "0"+vhdlTypeDefault (Signed _)          = "(others => '0')"+vhdlTypeDefault (Unsigned _)        = "(others => '0')"+vhdlTypeDefault (Vector _ elTy)     = parens ("others" <+> rarrow <+> vhdlTypeDefault elTy)+vhdlTypeDefault (SP _ _)            = "(others => '0')"+vhdlTypeDefault (Sum _ _)           = "(others => '0')"+vhdlTypeDefault (Product _ elTys)   = tupled $ mapM vhdlTypeDefault elTys+vhdlTypeDefault (Reset _)           = "'0'"+vhdlTypeDefault (Clock _)           = "'0'"+vhdlTypeDefault t                   = error $ "vhdlTypeDefault: " ++ show t++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 (vhdlTypeDefault ty) (expr False) 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 (mapM cond es)) <> semi+    where+      cond :: (Maybe Expr,Expr) -> VHDLM Doc+      cond (Nothing,e) = expr False e+      cond (Just c ,e) = expr False e <+> "when" <+> parens (expr True scrut <+> "=" <+> expr True c) <+> "else"++inst (InstDecl nm lbl pms) = fmap Just $+    nest 2 $ text lbl <> "_comp_inst" <+> 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 selected+  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+    selected = text id_ <> parens (int start <+> "downto" <+> int end)++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 _ (vectorChain -> Just es)                  = tupled (mapM (expr False) es)+expr _ (DataCon (Vector 1 _) _ [e])              = parens ("others" <+> rarrow <+> expr False e)+expr _ (DataCon (Vector _ _) _ [e1,e2])          = 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 $ map (expr False) es+    extraArg   = case typeSize ty - dcSize of+                   0 -> []+                   n -> [exprLit (Just n) (NumLit 0)]+    assignExpr = 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 _ _ = 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 Size -> Literal -> VHDLM Doc+exprLit Nothing   (NumLit i) = int i+exprLit (Just sz) (NumLit i) = bits (toBits sz i)+exprLit _         (BoolLit t) = if t then "true" else "false"+exprLit _         (BitLit b) = squotes $ bit_char b+exprLit _         _          = error "exprLit"++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 -> VHDLM Doc -> VHDLM Doc+toSLV Bit        d   = parens (int 0 <+> rarrow <+> d)+toSLV Bool       d   = "toSLV" <> parens d+toSLV Integer    d   = toSLV (Signed 32) ("to_signed" <> tupled (sequence [d,int 32]))+toSLV (Signed _) d   = "std_logic_vector" <> parens d+toSLV (Unsigned _) d = "std_logic_vector" <> parens d+toSLV (Sum _ _) d    = "std_logic_vector" <> parens d+toSLV hty          _ = error $ "toSLV: " ++ show hty++fromSLV :: HWType -> VHDLM Doc -> VHDLM Doc+fromSLV Bit d          = d <> parens (int 0)+fromSLV Bool d         = "fromSLV" <> parens d+fromSLV Integer d      = "to_integer" <> parens (fromSLV (Signed 32) d)+fromSLV (Signed _) d   = "signed" <> parens d+fromSLV (Unsigned _) d = "unsigned" <> parens d+fromSLV (SP _ _) d     = d+fromSLV (Sum _ _) d    = "unsigned" <> parens d+fromSLV hty _          = error $ "fromSLV: " ++ show hty++dcToExpr :: HWType -> Int -> Expr+dcToExpr ty i = Literal (Just $ conSize ty) (NumLit 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
+ src/CLaSH/Normalize.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE TemplateHaskell #-}++-- | 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.HashMap.Lazy         (HashMap)+import qualified Data.HashMap.Lazy         as HashMap+import qualified Data.Map                  as Map+import qualified Data.Set                  as Set++import           CLaSH.Core.FreeVars       (termFreeIds)+import           CLaSH.Core.Pretty         (showDoc)+import           CLaSH.Core.Term           (Term, TmName)+import           CLaSH.Core.Type           (Type)+import           CLaSH.Netlist.Types       (HWType)+import           CLaSH.Normalize.Strategy+import           CLaSH.Normalize.Types+import           CLaSH.Normalize.Util+import           CLaSH.Rewrite.Types       (DebugLevel (..), RewriteState (..),+                                            bindings, dbgLevel)+import           CLaSH.Rewrite.Util        (liftRS, runRewrite,+                                            runRewriteSession)+import           CLaSH.Util++-- | Run a NormalizeSession in a given environment+runNormalization :: DebugLevel+                 -- ^ Level of debug messages to print+                 -> Supply+                 -- ^ UniqueSupply+                 -> HashMap TmName (Type,Term)+                 -- ^ Global Binders+                 -> (Type -> Maybe (Either String HWType))+                 -- ^ Hardcoded Type -> HWType translator+                 -> NormalizeSession a+                 -- ^ NormalizeSession to run+                 -> a+runNormalization lvl supply globals typeTrans+  = flip State.evalState normState+  . runRewriteSession lvl rwState+  where+    rwState   = RewriteState 0 globals supply typeTrans+    normState = NormalizeState+                  HashMap.empty+                  Map.empty+                  HashMap.empty+                  []+                  (error "Report as bug: no curFun")++-- | Normalize a list of global binders+normalize :: [TmName]+          -> NormalizeSession [(TmName,(Type,Term))]+normalize (bndr:bndrs) = do+  let bndrS = showDoc bndr+  exprM <- fmap (HashMap.lookup bndr) $ Lens.use bindings+  case exprM of+    Just (ty,expr) -> do+      liftRS $ curFun .= bndr+      normalizedExpr <- makeCachedT3' bndr normalized $+                         rewriteExpr ("normalization",normalization) (bndrS,expr)+      let usedBndrs = Set.toList $ termFreeIds normalizedExpr+      if bndr `elem` usedBndrs+        then error $ $(curLoc) ++ "Expr belonging to bndr: " ++ bndrS ++ " remains recursive after normalization."+        else do+          prevNorm <- fmap HashMap.keys $ liftRS $ Lens.use normalized+          let toNormalize = filter (`notElem` prevNorm) usedBndrs+          normalizedOthers <- normalize (toNormalize ++ bndrs)+          return ((bndr,(ty,normalizedExpr)):normalizedOthers)+    Nothing -> error $ $(curLoc) ++ "Expr belonging to bndr: " ++ bndrS ++ " not found"++normalize [] = return []++-- | Rewrite a term according to the provided transformation+rewriteExpr :: (String,NormRewrite) -- ^ Transformation to apply+            -> (String,Term) -- ^ Term to transform+            -> NormalizeSession Term+rewriteExpr (nrwS,nrw) (bndrS,expr) = do+  lvl <- Lens.view dbgLevel+  let before = showDoc expr+  let expr' = traceIf (lvl >= DebugFinal)+                (bndrS ++ " before " ++ nrwS ++ ":\n\n" ++ before ++ "\n")+                expr+  rewritten <- runRewrite nrwS nrw expr'+  let after = showDoc rewritten+  traceIf (lvl >= DebugFinal)+    (bndrS ++ " after " ++ nrwS ++ ":\n\n" ++ after ++ "\n") $+    return rewritten++-- | Perform general \"clean up\" of the normalized (non-recursive) function+-- hierarchy. This includes:+--+--   * Inlining functions that simply \"wrap\" another function+cleanupGraph :: [TmName]+             -- ^ Names of the functions to clean up+             -> [(TmName,(Type,Term))]+             -- ^ Global binders+             -> NormalizeSession [(TmName,(Type,Term))]+cleanupGraph bndrs norm = do+    bindings .= HashMap.fromList norm+    cleanupGraph' ("cleanup",cleanup) bndrs+  where+    cleanupGraph' :: (String,NormRewrite) -> [TmName] -> NormalizeSession [(TmName,(Type,Term))]+    cleanupGraph' rw (bndr:bndrs') = do+      let bndrS = showDoc bndr+      exprM <- fmap (HashMap.lookup bndr) $ Lens.use bindings+      case exprM of+        Just (ty,expr) -> do+          liftRS $ curFun .= bndr+          cleaned <- rewriteExpr rw (bndrS,expr)+          let usedBndrs = Set.toList $ termFreeIds cleaned+          cleanedOthers <- cleanupGraph' rw (usedBndrs ++ bndrs')+          return $! (bndr,(ty,cleaned)):cleanedOthers+        Nothing -> error $ $(curLoc) ++ "Expr belonging to bndr: " ++ bndrS ++ " not found"+    cleanupGraph' _ [] = return []++-- | Check if the call graph (second argument), starting at the @topEnity@+-- (first argument) is non-recursive. Returns the list of normalized terms if+-- call graph is indeed non-recursive, errors otherwise.+checkNonRecursive :: TmName -- ^ @topEntity@+                  -> [(TmName,(Type,Term))] -- ^ List of normalized binders+                  -> [(TmName,(Type,Term))]+checkNonRecursive topEntity norm =+  let cg = callGraph [] (HashMap.fromList $ map (second snd) norm) topEntity+  in  case recursiveComponents cg of+       []  -> norm+       rcs -> error $ "Callgraph after normalisation contains following recursive cycles: " ++ show rcs
+ src/CLaSH/Normalize/Strategy.hs view
@@ -0,0 +1,80 @@+-- | Transformation process for normalization+module CLaSH.Normalize.Strategy where++import CLaSH.Normalize.Transformations+import CLaSH.Normalize.Types+import CLaSH.Normalize.Util+import CLaSH.Rewrite.Combinators+import CLaSH.Rewrite.Util++-- | Normalisation transformation+normalization :: NormRewrite+normalization = representable >-> simplification >-> apply "recToLetrec" recToLetRec++-- | Simple cleanup transformation, currently only inlines \"Wrappers\"+cleanup :: NormRewrite+cleanup = repeatR $ topdownR (apply "inlineWrapper" inlineWrapper)++-- | Unsure that functions have representable arguments, results, and let-bindings+representable :: NormRewrite+representable = propagagition >-> specialisation+  where+    propagagition = repeatR ( upDownR  (apply "propagation" appProp) >->+                              repeatBottomup [ ("bindNonRep"   , bindNonRep )+                                             , ("liftNonRep"   , liftNonRep )+                                             , ("caseLet"      , caseLet    )+                                             , ("caseCase"     , caseCase   )+                                             , ("caseCon"      , caseCon    )+                                             ]+                              >->+                              doInline "inlineNonRep" inlineNonRep+                            )+    specialisation = repeatR (bottomupR (apply "typeSpec" typeSpec)) >->+                     repeatR (bottomupR (apply "nonRepSpec" nonRepSpec))++-- | Brings representable function in the desired normal form:+--+-- * Only top-level lambda's+--+-- * Single Lambda-bound top-level Let-binding, where the body is a variable reference+--+-- * Modified ANF (constants are not let-bound, non-representable arguments to primitives are not let-bound)+--+-- * All let-bindings are representable+simplification :: NormRewrite+simplification = etaTL >-> constSimpl >-> anf >-> deadCodeRemoval >-> letTL++  where+    etaTL           = apply "etaTL" etaExpansionTL++    constSimpl      = repeatR ( upDownR (apply "propagation" appProp) >->+                                bottomupR inlineClosed >->+                                repeatBottomup  [ ("nonRepANF"       , nonRepANF       )+                                                , ("bindConstantVar" , bindConstantVar )+                                                , ("constantSpec"    , constantSpec    )+                                                , ("caseCon"         , caseCon         )+                                                ]+                              )++    anf             = apply "ANF" makeANF++    deadCodeRemoval = bottomupR (apply "deadcode" deadCode)++    letTL           = bottomupR (apply "topLet" topLet)++    inlineClosed    = apply "inlineClosedTerm" (inlineClosedTerm+                                                  "normalization"+                                                  normalization+                                               )++-- | Perform an inlining transformation using a bottomup traversal, and commit+-- inlined function names to the inlining log/cachce+doInline :: String -> NormRewrite -> NormRewrite+doInline n t = bottomupR (apply n t) >-> commitNewInlined++-- | Repeatedly apply a set of transformation in a bottom-up traversal+repeatBottomup :: [(String,NormRewrite)] -> NormRewrite+repeatBottomup+  = repeatR+  . foldl1 (>->)+  . map (bottomupR . uncurry apply)
+ src/CLaSH/Normalize/Transformations.hs view
@@ -0,0 +1,543 @@+{-# LANGUAGE PatternGuards   #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns    #-}++-- | Transformations of the Normalization process+module CLaSH.Normalize.Transformations+  ( appProp+  , bindNonRep+  , liftNonRep+  , caseLet+  , caseCon+  , caseCase+  , inlineNonRep+  , typeSpec+  , nonRepSpec+  , etaExpansionTL+  , inlineClosedTerm+  , nonRepANF+  , bindConstantVar+  , constantSpec+  , makeANF+  , deadCode+  , topLet+  , inlineWrapper+  , recToLetRec+  )+where++import           Control.Lens                ((.=),(%=))+import qualified Control.Lens                as Lens+import qualified Control.Monad               as Monad+import           Control.Monad.Writer        (WriterT (..), lift, tell)+import qualified Data.Either                 as Either+import qualified Data.HashMap.Lazy           as HashMap+import qualified Data.List                   as List+import qualified Data.Maybe                  as Maybe+import           Unbound.LocallyNameless     (Bind, Embed (..), bind, embed,+                                              rec, unbind, unembed, unrebind,+                                              unrec)+import           Unbound.LocallyNameless.Ops (unsafeUnbind)++import           CLaSH.Core.DataCon          (DataCon, dcTag, dcUnivTyVars)+import           CLaSH.Core.FreeVars         (termFreeIds, termFreeTyVars,+                                              termFreeVars, typeFreeVars)+import           CLaSH.Core.Subst            (substTm, substTms, substTyInTm,+                                              substTysinTm)+import           CLaSH.Core.Term             (LetBinding, Pat (..), Term (..))+import           CLaSH.Core.Type             (applyFunTy, applyTy, splitFunTy)+import           CLaSH.Core.Util             (collectArgs, idToVar, isCon,+                                              isFun, isLet, isPrim, isVar,+                                              mkApps, mkLams, mkTmApps,+                                              termType)+import           CLaSH.Core.Var              (Id, Var (..))+import           CLaSH.Netlist.Util          (representableType,+                                              splitNormalized)+import           CLaSH.Normalize.Types+import           CLaSH.Normalize.Util+import           CLaSH.Rewrite.Combinators+import           CLaSH.Rewrite.Types+import           CLaSH.Rewrite.Util+import           CLaSH.Util++-- | Inline non-recursive, non-representable let-bindings+bindNonRep :: NormRewrite+bindNonRep = inlineBinders nonRepTest+  where+    nonRepTest (Id idName tyE, exprE)+      = (&&) <$> (not <$> (representableType <$> Lens.use typeTranslator <*> pure (unembed tyE)))+             <*> ((notElem idName . snd) <$> localFreeVars (unembed exprE))++    nonRepTest _ = return False++-- | Lift recursive, non-representable let-bindings+liftNonRep :: NormRewrite+liftNonRep = liftBinders nonRepTest+  where+    nonRepTest (Id idName tyE, exprE)+      = (&&) <$> (not <$> (representableType <$> Lens.use typeTranslator <*> pure (unembed tyE)))+             <*> ((elem idName . snd) <$> localFreeVars (unembed exprE))++    nonRepTest _ = return False++-- | Specialize functions on their type+typeSpec :: NormRewrite+typeSpec ctx e@(TyApp e1 ty)+  | (Var _ _,  args) <- collectArgs e1+  , null $ typeFreeVars ty+  , (_, []) <- Either.partitionEithers args+  = specialise specialisations ctx e++typeSpec _ e = return e++-- | Specialize functions on their non-representable argument+nonRepSpec :: NormRewrite+nonRepSpec ctx e@(App e1 e2)+  | (Var _ _, args) <- collectArgs e1+  , (_, [])     <- Either.partitionEithers args+  , null $ termFreeTyVars e2+  = R $ do e2Ty <- termType e2+           localVar <- isLocalVar e2+           nonRepE2 <- not <$> (representableType <$> Lens.use typeTranslator <*> pure e2Ty)+           if nonRepE2 && not localVar+             then runR $ specialise specialisations ctx e+             else return e++nonRepSpec _ e = return e++-- | Lift the let-bindings out of the subject of a Case-decomposition+caseLet :: NormRewrite+caseLet _ (Case (Letrec b) ty alts) = R $ do+  (xes,e) <- unbind b+  changed . Letrec $ bind xes (Case e ty alts)++caseLet _ e = return e++-- | Move a Case-decomposition from the subject of a Case-decomposition to the alternatives+caseCase :: NormRewrite+caseCase _ e@(Case (Case scrut ty1 alts1) ty2 alts2)+  = R $ do+    ty1Rep <- representableType <$> Lens.use typeTranslator <*> pure ty1+    if ty1Rep+      then do newAlts <- mapM ( return+                                  . uncurry bind+                                  . second (\altE -> Case altE ty2 alts2)+                                  <=< unbind+                                  ) alts1+              changed $ Case scrut ty2 newAlts+      else return e++caseCase _ e = return e++-- | Inline function with a non-representable result if it's the subject+-- of a Case-decomposition+inlineNonRep :: NormRewrite+inlineNonRep ctx e@(Case scrut ty alts)+  | (Var _ f, args) <- collectArgs scrut+  = R $ do+    isInlined <- liftR $ alreadyInlined f+    if isInlined+      then do+        cf <- liftR $ Lens.use curFun+        traceIf True ($(curLoc) ++ "InlineNonRep: " ++ show f ++ " already inlined in: " ++ show cf) $ return e+      else do+        scrutTy     <- termType scrut+        bodyMaybe   <- fmap (HashMap.lookup f) $ Lens.use bindings+        nonRepScrut <- not <$> (representableType <$> Lens.use typeTranslator <*> pure scrutTy)+        case (nonRepScrut, bodyMaybe) of+          (True,Just (_, scrutBody)) -> do+            liftR $ newInlined %= (f:)+            changed $ Case (mkApps scrutBody args) ty alts+          _ -> return e++inlineNonRep _ e = return e++-- | Specialize a Case-decomposition (replace by the RHS of an alternative) if+-- the subject is (an application of) a DataCon; or if there is only a single+-- alternative that doesn't reference variables bound by the pattern.+caseCon :: NormRewrite+caseCon _ (Case scrut ty alts)+  | (Data dc, args) <- collectArgs scrut+  = R $ do+    alts' <- mapM unbind alts+    let dcAltM = List.find (equalCon dc . fst) alts'+    case dcAltM of+      Just (DataPat _ pxs, e) ->+        let (tvs,xs) = unrebind pxs+            fvs = termFreeIds e+            (binds,_) = List.partition ((`elem` fvs) . varName . fst)+                      $ zip xs (Either.lefts args)+            e' = case binds of+                  [] -> e+                  _  -> Letrec $ bind (rec $ map (second embed) binds) e+            substTyMap = zip (map varName tvs) (drop (length $ dcUnivTyVars dc) (Either.rights args))+        in  changed (substTysinTm substTyMap e')+      Nothing -> do+        let defAltM = List.find (isDefPat . fst) alts'+        case defAltM of+          Just (DefaultPat, e) -> changed e+          Nothing -> error $ $(curLoc) ++ "Non-exhaustive case-statement"+          Just _ -> error $ $(curLoc) ++ "Report as bug: caseCon error"+      Just _ -> error $ $(curLoc) ++ "Report as bug: caseCon error"+  where+    equalCon dc (DataPat dc' _) = dcTag dc == dcTag (unembed dc')+    equalCon _  _               = False++    isDefPat DefaultPat = True+    isDefPat _          = False++caseCon _ e@(Case _ _ [alt]) = R $ do+  (pat,altE) <- unbind alt+  case pat of+    DefaultPat    -> changed altE+    LitPat _      -> changed altE+    DataPat _ pxs -> let (tvs,xs)   = unrebind pxs+                         (ftvs,fvs) = termFreeVars altE+                         usedTvs    = filter ((`elem` ftvs) . varName) tvs+                         usedXs     = filter ((`elem` fvs) . varName) xs+                     in  case (usedTvs,usedXs) of+                           ([],[]) -> changed altE+                           _       -> return e++caseCon _ e = return e++-- | Bring an application of a DataCon or Primitive in ANF, when the argument is+-- is considered non-representable+nonRepANF :: NormRewrite+nonRepANF ctx e@(App appConPrim arg)+  | (conPrim, _) <- collectArgs e+  , isCon conPrim || isPrim conPrim+  = R $ do+    untranslatable <- isUntranslatable arg+    case (untranslatable,arg) of+      (True,Letrec b) -> do (binds,body) <- unbind b+                            changed . Letrec $ bind binds (App appConPrim body)+      (True,Case {})  -> runR $ specialise specialisations ctx e+      (True,Lam _)    -> runR $ specialise specialisations ctx e+      _               -> return e++nonRepANF _ e = return e++-- | Ensure that top-level lambda's eventually bind a let-expression of which+-- the body is a variable-reference.+topLet :: NormRewrite+topLet ctx e+  | all isLambdaBodyCtx ctx && not (isLet e)+  = R $ do+  untranslatable <- isUntranslatable e+  if untranslatable+    then return e+    else do (argId,argVar) <- mkTmBinderFor "topLet" e+            changed . Letrec $ bind (rec [(argId,embed e)]) argVar++topLet ctx e@(Letrec b)+  | all isLambdaBodyCtx ctx+  = R $ do+    (binds,body)   <- unbind b+    localVar       <- isLocalVar body+    untranslatable <- isUntranslatable body+    if localVar || untranslatable+      then return e+      else do (argId,argVar) <- mkTmBinderFor "topLet" body+              changed . Letrec $ bind (rec $ unrec binds ++ [(argId,embed body)]) argVar++topLet _ e = return e++-- Misc rewrites++-- | Remove unused let-bindings+deadCode :: NormRewrite+deadCode _ e@(Letrec binds) = R $ do+    (xes, body) <- fmap (first unrec) $ unbind binds+    let bodyFVs = termFreeIds body+        (xesUsed,xesOther) = List.partition+                               ( (`elem` bodyFVs )+                               . varName+                               . fst+                               ) xes+        xesUsed' = findUsedBndrs [] xesUsed xesOther+    if length xesUsed' /= length xes+      then changed . Letrec $ bind (rec xesUsed') body+      else return e+  where+    findUsedBndrs used []      _     = used+    findUsedBndrs used explore other =+      let fvsUsed = concatMap (termFreeIds . unembed . snd) explore+          (explore',other') = List.partition+                                ( (`elem` fvsUsed)+                                . varName+                                . fst+                                ) other+      in findUsedBndrs (used ++ explore) explore' other'++deadCode _ e = return e++-- | Inline let-bindings when the RHS is either a local variable reference or+-- is constant+bindConstantVar :: NormRewrite+bindConstantVar = inlineBinders test+  where+    test (_,Embed e) = (||) <$> isLocalVar e <*> pure (isConstant e)++-- | Inline nullary/closed functions+inlineClosedTerm :: String -> NormRewrite -> NormRewrite+inlineClosedTerm rwS rw _ e@(Var _ f) = R $ do+  bodyMaybe <- fmap (HashMap.lookup f) $ Lens.use bindings+  normMaybe <- fmap (HashMap.lookup f) $ liftR $ Lens.use normalized+  case bodyMaybe of+    Just (_,body) -> do+      closed <- isClosed body+      untranslatable <- isUntranslatable body+      if closed && not untranslatable+        then case normMaybe of+               Just norm -> changed norm+               Nothing   -> do cf <- liftR $ Lens.use curFun+                               liftR $ curFun .= f+                               newNorm <- lift $ runRewrite rwS rw body+                               liftR $ curFun .= cf+                               liftR $ normalized %= HashMap.insert f newNorm+                               changed newNorm+        else return e+    _ -> return e++inlineClosedTerm _ _ _ e = return e++-- | Specialise functions on arguments which are constant+constantSpec :: NormRewrite+constantSpec ctx e@(App e1 e2)+  | (Var _ _, args) <- collectArgs e1+  , (_, [])     <- Either.partitionEithers args+  , null $ termFreeTyVars e2+  , isConstant e2+  = specialise specialisations ctx e++constantSpec _ e = return e++-- | Inline functions which simply \"wrap\" another function+inlineWrapper :: NormRewrite+inlineWrapper [] e = R $ do+  normalizedM <- splitNormalized e+  case normalizedM of+    Right (_,[(_,bExpr)],_) -> case collectArgs (unembed bExpr) of+      (Var _ fn,args) -> do allLocal <- fmap and $ mapM (either isLocalVar (\_ -> return True)) args+                            bodyMaybe <- fmap (HashMap.lookup fn) $ Lens.use bindings+                            case (bodyMaybe,allLocal) of+                              (Just (bodyTy,body),True) -> do+                                eTy <- termType e+                                if eTy == bodyTy+                                  then changed body+                                  else return e+                              _ -> return e+      _ -> return e+    _ -> return e++inlineWrapper _ e@(Var _ f) = R $ do+  bodyMaybe <- fmap (HashMap.lookup f) $ Lens.use bindings+  case bodyMaybe of+    Just (_,body) -> do+      wrappedF_maybe <- getWrappedF body+      case wrappedF_maybe of+        Just wrappedF -> changed wrappedF+        Nothing       -> return e+    _ -> return e++inlineWrapper _ e = return e++-- Experimental++-- | Propagate arguments of application inwards; except for 'Lam' where the+-- argument becomes let-bound.+appProp :: NormRewrite+appProp _ (App (Lam b) arg) = R $ do+  (v,e) <- unbind b+  if isConstant arg || isVar arg+    then changed $ substTm (varName v) arg e+    else changed . Letrec $ bind (rec [(v,embed arg)]) e++appProp _ (App (Letrec b) arg) = R $ do+  (v,e) <- unbind b+  changed . Letrec $ bind v (App e arg)++appProp _ (App (Case scrut ty alts) arg) = R $ do+  argTy <- termType arg+  let ty' = applyFunTy ty argTy+  if isConstant arg || isVar arg+    then do+      alts' <- mapM ( return+                    . uncurry bind+                    . second (`App` arg)+                    <=< unbind+                    ) alts+      changed $ Case scrut ty' alts'+    else do+      (boundArg,argVar) <- mkTmBinderFor "caseApp" arg+      alts' <- mapM ( return+                    . uncurry bind+                    . second (`App` argVar)+                    <=< unbind+                    ) alts+      changed . Letrec $ bind (rec [(boundArg,embed arg)]) (Case scrut ty' alts')++appProp _ (TyApp (TyLam b) t) = R $ do+  (tv,e) <- unbind b+  changed $ substTyInTm (varName tv) t e++appProp _ (TyApp (Letrec b) t) = R $ do+  (v,e) <- unbind b+  changed . Letrec $ bind v (TyApp e t)++appProp _ (TyApp (Case scrut ty' alts) ty) = R $ do+  alts' <- mapM ( return+                . uncurry bind+                . second (`TyApp` ty)+                <=< unbind+                ) alts+  ty'' <- applyTy ty' ty+  changed $ Case scrut ty'' alts'++appProp _ e = return e++type NormRewriteW = Transform (WriterT [LetBinding] (R NormalizeMonad))++liftNormR :: RewriteMonad NormalizeMonad a+          -> WriterT [LetBinding] (R NormalizeMonad) a+liftNormR = lift . R++-- NOTE [unsafeUnbind]: Use unsafeUnbind (which doesn't freshen pattern+-- variables). Reason: previously collected expression still reference+-- the 'old' variable names created by the traversal!++-- | Turn an expression into a modified ANF-form. As opposed to standard ANF,+-- constants do not become let-bound.+makeANF :: NormRewrite+makeANF ctx (Lam b) = do+  -- See NOTE [unsafeUnbind]+  let (bndr,e) = unsafeUnbind b+  e' <- makeANF (LamBody bndr:ctx) e+  return $ Lam (bind bndr e')++makeANF ctx e+  = R $ do+    (e',bndrs) <- runR $ runWriterT $ bottomupR collectANF ctx e+    case bndrs of+      [] -> return e+      _  -> changed . Letrec $ bind (rec bndrs) e'++collectANF :: NormRewriteW+collectANF _ e@(App appf arg)+  | (conVarPrim, _) <- collectArgs e+  , isCon conVarPrim || isPrim conVarPrim || isVar conVarPrim+  = do+    untranslatable <- liftNormR $ isUntranslatable arg+    localVar       <- liftNormR $ isLocalVar arg+    case (untranslatable,localVar || isConstant arg,arg) of+      (False,False,_) -> do (argId,argVar) <- liftNormR $ mkTmBinderFor "repANF" arg+                            tell [(argId,embed arg)]+                            return (App appf argVar)+      (True,False,Letrec b) -> do (binds,body) <- unbind b+                                  tell (unrec binds)+                                  return (App appf body)+      _ -> return e++collectANF _ (Letrec b) = do+  -- See NOTE [unsafeUnbind]+  let (binds,body) = unsafeUnbind b+  tell (unrec binds)+  untranslatable <- liftNormR $ isUntranslatable body+  localVar       <- liftNormR $ isLocalVar body+  if localVar || untranslatable+    then return body+    else do+      (argId,argVar) <- liftNormR $ mkTmBinderFor "bodyVar" body+      tell [(argId,embed body)]+      return argVar++collectANF ctx e@(Case subj ty alts) = do+    untranslatableSubj <- liftNormR $ isUntranslatable subj+    localVar           <- liftNormR $ isLocalVar subj+    (bndr,subj') <- if localVar || untranslatableSubj || isConstant subj+      then return ([],subj)+      else do (argId,argVar) <- liftNormR $ mkTmBinderFor "subjLet" subj+              return ([(argId,embed subj)],argVar)++    untranslatableE <- liftNormR $ isUntranslatable e+    (binds,alts') <- if untranslatableE+      then return ([],alts)+      else fmap (first concat . unzip) $ liftNormR $ mapM doAlt alts++    tell (bndr ++ binds)+    return (Case subj' ty alts')+  where+    doAlt :: Bind Pat Term -> RewriteMonad NormalizeMonad ([LetBinding],Bind Pat Term)+    -- See NOTE [unsafeUnbind]+    doAlt = fmap (second (uncurry bind)) . doAlt' . unsafeUnbind++    doAlt' :: (Pat,Term) -> RewriteMonad NormalizeMonad ([LetBinding],(Pat,Term))+    doAlt' alt@(DataPat dc pxs@(unrebind -> ([],xs)),altExpr) = do+      lv      <- isLocalVar altExpr+      patSels <- Monad.zipWithM (doPatBndr (unembed dc)) xs [0..]+      if lv || isConstant altExpr+        then return (patSels,alt)+        else do (altId,altVar) <- mkTmBinderFor "altLet" altExpr+                return ((altId,embed altExpr):patSels,(DataPat dc pxs,altVar))+    doAlt' alt@(DataPat _ _, _) = return ([],alt)+    doAlt' alt@(pat,altExpr) = do+      lv <- isLocalVar altExpr+      if lv || isConstant altExpr+        then return ([],alt)+        else do (altId,altVar) <- mkTmBinderFor "altLet" altExpr+                return ([(altId,embed altExpr)],(pat,altVar))++    doPatBndr :: DataCon -> Id -> Int -> RewriteMonad NormalizeMonad LetBinding+    doPatBndr dc pId i+      = do patExpr <- mkSelectorCase "doPatBndr" ctx subj (dcTag dc) i+           return (pId,embed patExpr)++collectANF _ e = return e++-- | Eta-expand top-level lambda's (DON'T use in a traversal!)+etaExpansionTL :: NormRewrite+etaExpansionTL ctx (Lam b) = do+  (bndr,e) <- unbind b+  e' <- etaExpansionTL (LamBody bndr:ctx) e+  return $ Lam (bind bndr e')++etaExpansionTL ctx e+  = R $ do+    isF <- isFun e+    if isF+      then do+        argTy <- ( return+                 . fst+                 . Maybe.fromMaybe (error "etaExpansion splitFunTy")+                 . splitFunTy+                 <=< termType+                 ) e+        (newIdB,newIdV) <- mkInternalVar "eta" argTy+        e' <- runR $ etaExpansionTL (LamBody newIdB:ctx) (App e newIdV)+        changed . Lam $ bind newIdB e'+      else return e++-- | Turn a  normalized recursive function, where the recursive calls only pass+-- along the unchanged original arguments, into let-recursive function. This+-- means that all recursive calls are replaced by the same variable reference as+-- found in the body of the top-level let-expression.+recToLetRec :: NormRewrite+recToLetRec [] e = R $ do+  fn          <- liftR $ Lens.use curFun+  bodyM       <- fmap (HashMap.lookup fn) $ Lens.use bindings+  normalizedE <- splitNormalized e+  case (normalizedE,bodyM) of+    (Right (args,bndrs,res), Just (bodyTy,_)) -> do+      let appF              = mkTmApps (Var bodyTy fn) (map idToVar args)+          (toInline,others) = List.partition ((==) appF . unembed . snd) bndrs+          resV              = idToVar res+      case (toInline,others) of+        (_:_,_:_) -> do+          let substsInline = map (\(id_,_) -> (varName id_,resV)) toInline+              others'      = map (second (embed . substTms substsInline . unembed)) others+          changed $ mkLams (Letrec $ bind (rec others') resV) args+        _ -> return e+    _ -> return e++recToLetRec _ e = return e
+ src/CLaSH/Normalize/Types.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE TemplateHaskell #-}+-- | Types used in Normalize modules+module CLaSH.Normalize.Types where++import Control.Monad.State (State)+import Data.HashMap.Strict (HashMap)+import Data.Map            (Map)++import CLaSH.Core.Term     (Term, TmName)+import CLaSH.Core.Type     (Type)+import CLaSH.Rewrite.Types (Rewrite, RewriteSession)+import CLaSH.Util++-- | State of the 'NormalizeMonad'+data NormalizeState+  = NormalizeState+  { _normalized      :: HashMap TmName Term -- ^ Global binders+  , _specialisations :: Map (TmName,Int,Either Term Type) (TmName,Type)+  -- ^ Cache of previously specialised functions:+  --+  -- * Key: (name of the original function, argument position, specialised term/type)+  --+  -- * Elem: (name of specialised function,type of specialised function)+  , _inlined         :: HashMap TmName [TmName]+  -- ^ Cache of function where inlining took place:+  --+  -- * Key: function where inlining took place+  --+  -- * Elem: functions which were inlined+  , _newInlined      :: [TmName]+  -- ^ Inlined functions in the current traversal+  , _curFun          :: TmName+  -- ^ Function which is currently normalized+  }++makeLenses ''NormalizeState++-- | State monad that stores specialisation and inlining information+type NormalizeMonad = State NormalizeState++-- | RewriteSession with extra Normalisation information+type NormalizeSession = RewriteSession NormalizeMonad++-- | A 'Transform' action in the context of the 'RewriteMonad' and 'NormalizeMonad'+type NormRewrite = Rewrite NormalizeMonad
+ src/CLaSH/Normalize/Util.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE LambdaCase    #-}+{-# LANGUAGE ViewPatterns  #-}++-- | Utility functions used by the normalisation transformations+module CLaSH.Normalize.Util where++import           Control.Lens            ((%=), (.=))+import qualified Control.Lens            as Lens+import qualified Data.Either             as Either+import qualified Data.Graph              as Graph+import           Data.HashMap.Lazy       (HashMap)+import qualified Data.HashMap.Lazy       as HashMap+import qualified Data.List               as List+import qualified Data.Maybe              as Maybe+import qualified Data.Set                as Set+import           Unbound.LocallyNameless (Fresh, unembed)++import           CLaSH.Core.FreeVars     (termFreeIds)+import           CLaSH.Core.Term         (Term (..), TmName)+import           CLaSH.Core.Type         (Type (..), splitFunForallTy)+import           CLaSH.Core.Util         (collectArgs, termType)+import           CLaSH.Core.Var          (Id, Var (..))+import           CLaSH.Netlist.Util      (splitNormalized)+import           CLaSH.Normalize.Types+import           CLaSH.Rewrite.Types+import           CLaSH.Rewrite.Util++-- | Determine if a function is already inlined in the context of the 'NetlistMonad'+alreadyInlined :: TmName+               -> NormalizeMonad Bool+alreadyInlined f = do+  cf <- Lens.use curFun+  inlinedHM <- Lens.use inlined+  case HashMap.lookup cf inlinedHM of+    Nothing       -> return False+    Just inlined' -> return (f `elem` inlined')++-- | Move the names of inlined functions collected during a traversal into the+-- permanent inlined function cache+commitNewInlined :: NormRewrite+commitNewInlined _ e = R $ liftR $ do+  cf <- Lens.use curFun+  nI <- Lens.use newInlined+  inlinedHM <- Lens.use inlined+  case HashMap.lookup cf inlinedHM of+    Nothing -> inlined %= HashMap.insert cf nI+    Just _  -> inlined %= HashMap.adjust (`List.union` nI) cf+  newInlined .= []+  return e++-- | Determine if a term is closed+isClosed :: (Functor m, Fresh m)+         => Term+         -> m Bool+isClosed = fmap (not . isPolyFunTy) . termType+  where+    -- Is a type a (polymorphic) function type?+    isPolyFunTy = not . null . Either.lefts . fst . splitFunForallTy++-- | Determine if a term represents a constant+isConstant :: Term -> Bool+isConstant e = case collectArgs e of+  (Data _, args)   -> all (either isConstant (const True)) args+  (Prim _ _, args) -> all (either isConstant (const True)) args+  (Literal _,_)    -> True+  _                -> False++-- | Get the \"Wrapped\" function out of a normalized Term. Returns 'Nothing' if+-- the normalized term is not actually a wrapper.+getWrappedF :: (Fresh m,Functor m) => Term -> m (Maybe Term)+getWrappedF body = do+    normalizedM <- splitNormalized body+    case normalizedM of+      Right (funArgs,[(_,bExpr)],_) -> return $! uncurry (reduceArgs True funArgs) (collectArgs $ unembed bExpr)+      _                             -> return Nothing+  where+    reduceArgs :: Bool -> [Id] -> Term -> [Either Term Type] -> Maybe Term+    reduceArgs _    []    appE []                         = Just appE+    reduceArgs _    (_:_) _ []                            = Nothing+    reduceArgs b    ids       appE (Right ty:args)        = reduceArgs b ids (TyApp appE ty) args+    reduceArgs _    (id1:ids) appE (Left (Var _ nm):args) | varName id1 == nm = reduceArgs False ids appE args+    reduceArgs True ids@(_:_) appE (Left arg:args)        = reduceArgs True ids (App appE arg) args+    reduceArgs _ _ _ _                                    = Nothing++-- | Create a call graph for a set of global binders, given a root+callGraph :: [TmName] -- ^ List of functions that should not be inspected+          -> HashMap TmName Term -- ^ Global binders+          -> TmName -- ^ Root of the call graph+          -> [(TmName,[TmName])]+callGraph visited bindingMap root = node:other+  where+    rootTm = Maybe.fromMaybe (error $ show root ++ " is not a global binder") $ HashMap.lookup root bindingMap+    used   = Set.toList $ termFreeIds rootTm+    node   = (root,used)+    other  = concatMap (callGraph (root:visited) bindingMap) (filter (`notElem` visited) used)++-- | Determine the sets of recursive components given the edges of a callgraph+recursiveComponents :: [(TmName,[TmName])] -- ^ [(calling function,[called function])]+                    -> [[TmName]]+recursiveComponents = Maybe.catMaybes+                    . map (\case {Graph.CyclicSCC vs -> Just vs; _ -> Nothing})+                    . Graph.stronglyConnComp+                    . map (\(n,es) -> (n,n,es))
+ src/CLaSH/Primitives/Types.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Type and instance definitions for Primitive+module CLaSH.Primitives.Types where++import           Control.Applicative  ((<$>), (<*>), (<|>))+import           Data.Aeson           (FromJSON (..), Value (..), (.:))+import           Data.ByteString.Lazy (ByteString)+import           Data.HashMap.Lazy    (HashMap)+import qualified Data.HashMap.Strict  as H+import           Data.Text.Lazy       (Text)++-- | Primitive Definitions+type PrimMap = HashMap ByteString Primitive++-- | Externally defined primitive+data Primitive+  -- | A primitive that has a template that can be filled out by the backend render+  = BlackBox+  { name     :: ByteString -- ^ Name of the primitive+  , template :: Either Text Text -- ^ Either a /declaration/ or an /expression/ template.+  }+  -- | A primitive that carries additional information+  | Primitive+  { name     :: ByteString -- ^ Name of the primitive+  , primType :: Text -- ^ Additional information+  }++instance FromJSON Primitive where+  parseJSON (Object v) = case H.toList v of+    [(conKey,Object conVal)] -> case conKey of+      "BlackBox"  -> BlackBox <$> conVal .: "name" <*> ((Left <$> conVal .: "templateD") <|> (Right <$> conVal .: "templateE"))+      "Primitive" -> Primitive <$> conVal .: "name" <*> conVal .: "primType"+      _ -> error "Expected: BlackBox or Primitive object"+    _ -> error "Expected: BlackBox or Primitive object"+  parseJSON _ = error "Expected: BlackBox or Primitive object"
+ src/CLaSH/Primitives/Util.hs view
@@ -0,0 +1,50 @@+-- | Utility functions to generate Primitives+module CLaSH.Primitives.Util where++import           Data.Aeson             (FromJSON, Result (..), fromJSON, json)+import qualified Data.Attoparsec.Lazy   as L+import           Data.ByteString.Lazy   (ByteString)+import qualified Data.ByteString.Lazy   as LZ+import qualified Data.HashMap.Lazy      as HashMap+import           Data.List              (isSuffixOf)+import           Data.Maybe             (fromMaybe)+import qualified System.Directory       as Directory+import qualified System.FilePath        as FilePath++import           CLaSH.Primitives.Types+import           CLaSH.Util++-- | Generate a set of primitives that are found in the primitive definition+-- files in the given directories.+generatePrimMap :: [FilePath] -- ^ Directories to search for primitive definitions+                -> IO PrimMap+generatePrimMap filePaths = do+  primitiveFiles <- fmap concat $ mapM+                      (\filePath ->+                          fmap ( map (FilePath.combine filePath)+                               . filter (isSuffixOf ".json")+                               ) (Directory.getDirectoryContents filePath)+                      ) filePaths++  primitives <- fmap concat $ mapM+                  ( return+                  . fromMaybe []+                  . decodeAndReport+                  <=< LZ.readFile+                  ) primitiveFiles++  let primMap = HashMap.fromList $ zip (map name primitives) primitives++  return primMap++-- | Parse a ByteString according to the given JSON template. Prints failures+-- on @stdout@, and returns 'Nothing' if parsing fails.+decodeAndReport :: (FromJSON a)+                => ByteString -- ^ Bytestring to parse+                -> Maybe a+decodeAndReport s =+  case L.parse json s of+    L.Done _ v -> case fromJSON v of+                    Success a -> Just a+                    Error msg -> traceIf True msg Nothing+    L.Fail _ _ msg -> traceIf True msg Nothing
+ src/CLaSH/Rewrite/Combinators.hs view
@@ -0,0 +1,116 @@+{-# 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,+                                              unbind, unembed, unrec)+import           Unbound.LocallyNameless.Ops (unsafeUnbind)++import           CLaSH.Core.Term             (Pat, Term (..))+import           CLaSH.Core.Util             (patIds)+import           CLaSH.Core.Var              (Id)+import           CLaSH.Rewrite.Types++-- | Apply a transformation on the subtrees of an term+allR :: forall m . (Functor m, Monad m, Fresh m)+     => Bool -- ^ Freshen variable references in abstracted terms+     -> Transform m -- ^ The transformation to apply to the subtrees+     -> Transform m+allR _ _ _ (Var t x)   = return (Var t x)+allR _ _ _ (Data dc)   = return (Data dc)+allR _ _ _ (Literal l) = return (Literal l)+allR _ _ _ (Prim nm t) = return (Prim nm t)++allR rf trans c (Lam b) = do+  (v,e) <- if rf then unbind b else return (unsafeUnbind b)+  e'    <- trans (LamBody v:c) e+  return . Lam $ bind v e'++allR rf trans c (TyLam b) = do+  (tv, e) <- if rf then unbind b else return (unsafeUnbind b)+  e' <- trans (TyLamBody tv:c) e+  return . TyLam $ bind tv e'++allR _ trans c (App e1 e2) = do+  e1' <- trans (AppFun:c) e1+  e2' <- trans (AppArg:c) e2+  return $ App e1' e2'++allR _ trans c (TyApp e ty) = do+  e' <- trans (TyAppC:c) e+  return $ TyApp e' ty++allR rf trans c (Letrec b) = do+  (xesR,e) <- if rf then unbind b else return (unsafeUnbind b)+  let xes   = unrec xesR+  let bndrs = map fst xes+  e' <- trans (LetBody bndrs:c) e+  xes' <- mapM (rewriteBind bndrs) xes+  return . Letrec $ bind (rec xes') e'+  where+    rewriteBind :: [Id] -> (Id,Embed Term) -> m (Id,Embed Term)+    rewriteBind bndrs (b', e) = do+      e' <- trans (LetBinding bndrs:c) (unembed e)+      return (b',embed e')++allR rf trans c (Case scrut ty alts) = do+  scrut' <- trans (CaseScrut:c) scrut+  alts'  <- if rf then mapM (fmap (uncurry bind) . rewriteAlt <=< unbind) alts+                  else mapM (fmap (uncurry bind) . rewriteAlt . unsafeUnbind) alts+  return $ Case scrut' ty alts'+  where+    rewriteAlt :: (Pat, Term) -> m (Pat, Term)+    rewriteAlt (p,e) = do+      e' <- trans (CaseAlt (patIds p):c) e+      return (p,e')++infixr 6 >->+-- | Apply two transformations in succession+(>->) :: (Monad m) => Transform m -> Transform m -> Transform m+(>->) r1 r2 c = r1 c >=> r2 c++-- | Apply a transformation in a topdown traversal+topdownR :: (Fresh m, Functor m, Monad m) => Transform m -> Transform m+topdownR r = r >-> allR True (topdownR r)++-- | Apply a transformation in a topdown traversal. Doesn't freshen bound+-- variables+unsafeTopdownR :: (Fresh m, Functor m, Monad m) => Transform m -> Transform m+unsafeTopdownR r = r >-> allR False (unsafeTopdownR r)++-- | Apply a transformation in a bottomup traversal+bottomupR :: (Fresh m, Functor m, Monad m) => Transform m -> Transform m+bottomupR r = allR True (bottomupR r) >-> r++-- | Apply a transformation in a bottomup traversal. Doesn't freshen bound+-- variables+unsafeBottomupR :: (Fresh m, Functor m, Monad m) => Transform m -> Transform m+unsafeBottomupR r = allR False (unsafeBottomupR r) >-> r++-- | Apply a transformation in a bottomup traversal, when a transformation+-- succeeds in a certain node, apply the transformation further in a topdown+-- traversal starting at that node.+upDownR :: (Functor m,Monad m) => Rewrite m -> Rewrite m+upDownR r = bottomupR (r !-> topdownR r)++-- | Apply a transformation in a bottomup traversal, when a transformation+-- succeeds in a certain node, apply the transformation further in a topdown+-- traversal starting at that node. Doesn't freshen bound variables+unsafeUpDownR :: (Functor m,Monad m) => Rewrite m -> Rewrite m+unsafeUpDownR r = unsafeBottomupR (r !-> unsafeTopdownR r)++infixr 5 !->+-- | Only apply the second transformation if the first one succeeds.+(!->) :: Monad m => Rewrite m -> Rewrite m -> Rewrite m+(!->) r1 r2 c expr = R $ do+  (expr',changed) <- runR $ Writer.listen $ r1 c expr+  if Monoid.getAny changed+    then runR $ r2 c expr'+    else return expr++-- | Keep applying a transformation until it fails.+repeatR :: Monad m => Rewrite m -> Rewrite m+repeatR r = r !-> repeatR r
+ src/CLaSH/Rewrite/Types.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TypeSynonymInstances       #-}++-- | Type and instance definitions for Rewrite modules+module CLaSH.Rewrite.Types where++import Control.Concurrent.Supply (Supply, freshId)+import Control.Lens              (use, (.=))+import Control.Monad.Reader      (MonadReader, ReaderT, lift)+import Control.Monad.State       (MonadState, StateT)+import Control.Monad.Writer      (MonadWriter, WriterT)+import Data.HashMap.Lazy         (HashMap)+import Data.Monoid               (Any)+import Unbound.LocallyNameless   (Fresh, FreshMT)++import CLaSH.Core.Term           (Term, TmName)+import CLaSH.Core.Type           (Type)+import CLaSH.Core.Var            (Id, TyVar)+import CLaSH.Netlist.Types       (HWType)+import CLaSH.Util++-- | Context in which a term appears+data CoreContext = AppFun -- ^ Function position of an application+                 | AppArg -- ^ Argument position of an application+                 | TyAppC -- ^ Function position of a type application+                 | LetBinding [Id] -- ^ RHS of a Let-binder with the sibling LHS'+                 | LetBody    [Id] -- ^ Body of a Let-binding with the bound LHS'+                 | LamBody    Id   -- ^ Body of a lambda-term with the abstracted variable+                 | TyLamBody  TyVar -- ^ Body of a TyLambda-term with the abstracted type-variable+                 | CaseAlt    [Id] -- ^ RHS of a case-alternative with the variables bound by the pattern on the LHS+                 | CaseScrut -- ^ Subject of a case-decomposition+                 deriving Show++-- | State of a rewriting session+data RewriteState+  = RewriteState+  { _transformCounter :: Int -- ^ Number of applied transformations+  , _bindings         :: HashMap TmName (Type,Term) -- ^ Global binders+  , _uniqSupply       :: Supply -- ^ Supply of unique numbers+  , _typeTranslator   :: Type -> Maybe (Either String HWType) -- ^ Hardcode Type -> HWType translator+  }++makeLenses ''RewriteState++-- | Debug Message Verbosity+data DebugLevel+  = DebugNone -- ^ Don't show debug messages+  | DebugFinal -- ^ Show completely normalized expressions+  | DebugApplied -- ^ Show sub-expressions after a successful rewrite+  | DebugAll -- ^ Show all sub-expressions on which a rewrite is attempted+  deriving (Eq,Ord)++-- | Read-only environment of a rewriting session+newtype RewriteEnv = RE { _dbgLevel :: DebugLevel }++makeLenses ''RewriteEnv++-- | Monad that keeps track how many transformations have been applied and can+-- generate fresh variables and unique identifiers+type RewriteSession m = ReaderT RewriteEnv (StateT RewriteState (FreshMT m))++-- | Monad that can do the same as 'RewriteSession' and in addition keeps track+-- if a transformation/rewrite has been successfully applied.+type RewriteMonad m = WriterT Any (RewriteSession m)++instance Monad m => MonadUnique (RewriteMonad m) where+  getUniqueM = do+    sup <- lift . lift $ use uniqSupply+    let (a,sup') = freshId sup+    lift . lift $ uniqSupply .= sup'+    return a++-- | MTL convenience wrapper around 'RewriteMonad'+newtype R m a = R { runR :: RewriteMonad m a }+  deriving ( Monad+           , Functor+           , MonadReader RewriteEnv+           , MonadState  RewriteState+           , MonadWriter Any+           , MonadUnique+           , Fresh+           )++-- | Monadic action that transforms a term given a certain context+type Transform m = [CoreContext] -> Term -> m Term++-- | A 'Transform' action in the context of the 'RewriteMonad'+type Rewrite m   = Transform (R m)
+ src/CLaSH/Rewrite/Util.hs view
@@ -0,0 +1,483 @@+{-# LANGUAGE Rank2Types      #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections   #-}+{-# LANGUAGE TypeOperators   #-}+{-# LANGUAGE ViewPatterns    #-}++-- | Utilities for rewriting: e.g. inlining, specialisation, etc.+module CLaSH.Rewrite.Util where++import           Control.Lens              (Lens', (%=), (+=))+import qualified Control.Lens              as Lens+import qualified Control.Monad             as Monad+import qualified Control.Monad.Reader      as Reader+import qualified Control.Monad.State       as State+import           Control.Monad.Trans.Class (lift)+import qualified Control.Monad.Writer      as Writer+import qualified Data.HashMap.Lazy         as HashMap+import qualified Data.Map                  as Map+import qualified Data.Monoid               as Monoid+import qualified Data.Set                  as Set+import           Unbound.LocallyNameless   (Collection (..), Fresh, bind, embed,+                                            makeName, name2String, rebind, rec,+                                            string2Name, unbind, unembed, unrec)+import qualified Unbound.LocallyNameless   as Unbound+import           Unbound.Util              (filterC)++import           CLaSH.Core.DataCon        (dataConInstArgTys)+import           CLaSH.Core.FreeVars       (termFreeVars, typeFreeVars)+import           CLaSH.Core.Pretty         (showDoc)+import           CLaSH.Core.Subst          (substTm)+import           CLaSH.Core.Term           (LetBinding, Pat (..), Term (..),+                                            TmName)+import           CLaSH.Core.TyCon          (tyConDataCons)+import           CLaSH.Core.Type           (KindOrType, TyName, Type (..),+                                            TypeView (..), transparentTy,+                                            typeKind, tyView)+import           CLaSH.Core.Util           (Delta, Gamma, collectArgs,+                                            mkAbstraction, mkApps, mkId, mkLams,+                                            mkTmApps, mkTyApps, mkTyLams,+                                            mkTyVar, termType)+import           CLaSH.Core.Var            (Id, TyVar, Var (..))+import           CLaSH.Netlist.Util        (representableType)+import           CLaSH.Rewrite.Types+import           CLaSH.Util++-- | Lift an action working in the inner monad to the 'RewriteMonad'+liftR :: Monad m => m a -> RewriteMonad m a+liftR m = lift . lift . lift . lift $ m++-- | Lift an action working in the inner monad to the 'RewriteSession'+liftRS :: Monad m => m a -> RewriteSession m a+liftRS m = lift . lift . lift $ m++-- | Record if a transformation is succesfully applied+apply :: (Monad m, Functor m)+      => String -- ^ Name of the transformation+      -> Rewrite m -- ^ Transformation to be applied+      -> Rewrite m+apply name rewrite ctx expr = R $ do+  lvl <- Lens.view dbgLevel+  let before = showDoc expr+  (expr', anyChanged) <- traceIf (lvl >= DebugAll) ("Trying: " ++ name ++ " on:\n" ++ before) $ Writer.listen $ runR $ rewrite ctx expr+  let hasChanged = Monoid.getAny anyChanged+  Monad.when hasChanged $ transformCounter += 1+  let after  = showDoc expr'+  let expr'' = if hasChanged then expr' else expr++  Monad.when (lvl > DebugNone && hasChanged) $ do+    beforeTy             <- fmap transparentTy $ termType expr+    (beforeFTV,beforeFV) <- localFreeVars expr+    afterTy              <- fmap transparentTy $ termType expr'+    (afterFTV,afterFV)   <- localFreeVars expr'+    let newFV = Set.size afterFTV > Set.size beforeFTV ||+                Set.size afterFV > Set.size beforeFV+    Monad.when newFV $+            error ( concat [ $(curLoc)+                           , "Error when applying rewrite ", name+                           , " to:\n" , before+                           , "\nResult:\n" ++ after ++ "\n"+                           , "Changes free variables from: ", show (beforeFTV,beforeFV)+                           , "\nto: ", show (afterFTV,afterFV)+                           ]+                  )+    traceIf ( beforeTy /= afterTy)+            ( concat [ $(curLoc)+                     , "Error when applying rewrite ", name+                     , " to:\n" , before+                     , "\nResult:\n" ++ after ++ "\n"+                     , "Changes type from:\n", showDoc beforeTy+                     , "\nto:\n", showDoc afterTy+                     ]+            ) (return ())++  Monad.when (lvl >= DebugApplied && not hasChanged && expr /= expr') $+    error $ "Expression changed without notice(" ++ name ++  "): before" ++ before ++ "\nafter:\n" ++ after++  traceIf (lvl >= DebugApplied && hasChanged) ("Changes when applying rewrite " ++ name ++ " to:\n" ++ before ++ "\nResult:\n" ++ after ++ "\n") $+    traceIf (lvl >= DebugAll && not hasChanged) ("No changes when applying rewrite " ++ name ++ " to:\n" ++ after ++ "\n") $+      return expr''++-- | Perform a transformation on a Term+runRewrite :: (Monad m, Functor m)+           => String -- ^ Name of the transformation+           -> Rewrite m -- ^ Transformation to perform+           -> Term  -- ^ Term to transform+           -> RewriteSession m Term+runRewrite name rewrite expr = do+  (expr',_) <- Writer.runWriterT . runR $ apply name rewrite [] expr+  return expr'++-- | Evaluate a RewriteSession to its inner monad+runRewriteSession :: Monad m+                  => DebugLevel+                  -> RewriteState+                  -> RewriteSession m a+                  -> m a+runRewriteSession lvl st+  = Unbound.runFreshMT+  . (`State.evalStateT` st)+  . (`Reader.runReaderT` RE lvl)++-- | Notify that a transformation has changed the expression+setChanged :: Monad m => RewriteMonad m ()+setChanged = Writer.tell (Monoid.Any True)++-- | Identity function that additionally notifies that a transformation has+-- changed the expression+changed :: Monad m => a -> RewriteMonad m a+changed val = do+  Writer.tell (Monoid.Any True)+  return val++-- | Create a type and kind context out of a transformation context+contextEnv :: [CoreContext]+           -> (Gamma, Delta)+contextEnv = go HashMap.empty HashMap.empty+  where+    go gamma delta []                   = (gamma,delta)+    go gamma delta (LetBinding ids:ctx) = go gamma' delta ctx+      where+        gamma' = foldl addToGamma gamma ids++    go gamma delta (LetBody ids:ctx)    = go gamma' delta ctx+      where+        gamma' = foldl addToGamma gamma ids++    go gamma delta (LamBody lId:ctx)    = go gamma' delta ctx+      where+        gamma' = addToGamma gamma lId++    go gamma delta (TyLamBody tv:ctx)   = go gamma delta' ctx+      where+        delta' = addToDelta delta tv++    go gamma delta (CaseAlt ids:ctx)    = go gamma' delta ctx+      where+        gamma' = foldl addToGamma gamma ids++    go gamma delta (_:ctx) = go gamma delta ctx++    addToGamma gamma (Id idName ty) = HashMap.insert idName (unembed ty) gamma+    addToGamma gamma _              = error $ $(curLoc) ++ "Adding TyVar to Gamma"++    addToDelta delta (TyVar tvName ki) = HashMap.insert tvName (unembed ki) delta+    addToDelta delta _                 = error $ $(curLoc) ++ "Adding Id to Delta"++-- | Create a complete type and kind context out of the global binders and the+-- transformation context+mkEnv :: (Functor m, Monad m)+      => [CoreContext]+      -> RewriteMonad m (Gamma, Delta)+mkEnv ctx = do+  let (gamma,delta) = contextEnv ctx+  tsMap             <- fmap (HashMap.map fst) $ Lens.use bindings+  let gamma'        = tsMap `HashMap.union` gamma+  return (gamma',delta)++-- | Make a new binder and variable reference for a term+mkTmBinderFor :: (Functor m, Fresh m, MonadUnique m)+              => String -- ^ Name of the new binder+              -> Term -- ^ Term to bind+              -> m (Id, Term)+mkTmBinderFor name e = do+  (Left r) <- mkBinderFor name (Left e)+  return r++-- | Make a new binder and variable reference for either a term or a type+mkBinderFor :: (Functor m, Monad m, MonadUnique m, Fresh m)+            => String -- ^ Name of the new binder+            -> Either Term Type -- ^ Type or Term to bind+            -> m (Either (Id,Term) (TyVar,Type))+mkBinderFor name (Left term) =+  Left <$> (mkInternalVar name =<< termType term)++mkBinderFor name (Right ty) = do+  name'     <- fmap (makeName name . toInteger) getUniqueM+  let kind  = typeKind ty+  return $ Right (TyVar name' (embed kind), VarTy kind name')++-- | Make a new, unique, identifier and corresponding variable reference+mkInternalVar :: (Functor m, Monad m, MonadUnique m)+              => String -- ^ Name of the identifier+              -> KindOrType+              -> m (Id,Term)+mkInternalVar name ty = do+  name' <- fmap (makeName name . toInteger) getUniqueM+  return (Id name' (embed ty),Var ty name')++-- | Inline the binders in a let-binding that have a certain property+inlineBinders :: Monad m+              => (LetBinding -> RewriteMonad m Bool) -- ^ Property test+              -> Rewrite m+inlineBinders condition _ expr@(Letrec b) = R $ do+  (xes,res)        <- unbind b+  (replace,others) <- partitionM condition (unrec xes)+  case replace of+    [] -> return expr+    _  -> do+      let (others',res') = substituteBinders replace others res+          newExpr = case others of+                          [] -> res'+                          _  -> Letrec (bind (rec others') res')+      changed newExpr++inlineBinders _ _ e = return e++-- | Substitute the RHS of the first set of Let-binders for references to the+-- first set of Let-binders in: the second set of Let-binders and the additional+-- term+substituteBinders :: [LetBinding] -- ^ Let-binders to substitute+                  -> [LetBinding] -- ^ Let-binders where substitution takes place+                  -> Term -- ^ Expression where substitution takes place+                  -> ([LetBinding],Term)+substituteBinders [] others res = (others,res)+substituteBinders ((bndr,valE):rest) others res+  = let val   = unembed valE+        res'  = substTm (varName bndr) val res+        rest' = map (second ( embed+                            . substTm (varName bndr) val+                            . unembed)+                    ) rest+        others' = map (second ( embed+                            . substTm (varName bndr) val+                            . unembed)+                    ) others+    in substituteBinders rest' others' res'++-- | 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+  globalBndrs <- Lens.use bindings+  let (tyFVs,tmFVs) = termFreeVars term+  return ( tyFVs+         , filterC+         $ cmap (\v -> if v `HashMap.member` globalBndrs+                       then Nothing+                       else Just v+                ) tmFVs+         )++-- | Lift the binders in a let-binding to a global function that have a certain+-- property+liftBinders :: (Functor m, Monad m)+            => (LetBinding -> RewriteMonad m Bool) -- ^ Property test+            -> Rewrite m+liftBinders condition ctx expr@(Letrec b) = R $ do+  (xes,res)        <- unbind b+  (replace,others) <- partitionM condition (unrec xes)+  case replace of+    [] -> return expr+    _  -> do+      (gamma,delta) <- mkEnv ctx+      replace' <- mapM (liftBinding gamma delta) replace+      let (others',res') = substituteBinders replace' others res+          newExpr = case others of+                          [] -> res'+                          _  -> Letrec (bind (rec others') res')+      changed newExpr++liftBinders _ _ e = return e++-- | Create a global function for a Let-binding and return a Let-binding where+-- the RHS is a reference to the new global function applied to the free+-- variables of the original RHS+liftBinding :: (Functor m, Monad m)+            => Gamma+            -> Delta+            -> LetBinding+            -> RewriteMonad m LetBinding+liftBinding gamma delta (Id idName tyE,eE) = do+  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 localFTVkinds = map (delta HashMap.!) localFTVs+      localFVs'     = filter (/= idName) localFVs+      localFVtys'   = map (gamma HashMap.!) localFVs'+  -- Abstract expression over its local FVs+      boundFTVs = zipWith mkTyVar localFTVkinds localFTVs+      boundFVs  = zipWith mkId localFVtys' localFVs'+  -- Make a new global ID+  newBodyTy <- termType $ mkTyLams (mkLams e boundFVs) boundFTVs+  newBodyId <- fmap (makeName (name2String idName) . toInteger) getUniqueM+  -- Make a new expression, consisting of the te lifted function applied to+  -- its free variables+  let newExpr = mkTmApps+                  (mkTyApps (Var newBodyTy newBodyId)+                            (zipWith VarTy localFTVkinds localFTVs))+                  (zipWith Var localFVtys' localFVs')+  -- Substitute the recursive calls by the new expression+      e' = substTm idName newExpr e+  -- Create a new body that abstracts over the free variables+      newBody = mkTyLams (mkLams e' boundFVs) boundFTVs+  -- Add the created function to the list of global bindings+  bindings %= HashMap.insert newBodyId (newBodyTy,newBody)+  -- Return the new binder+  return (Id idName (embed ty), embed newExpr)++liftBinding _ _ _ = error $ $(curLoc) ++ "liftBinding: invalid core, expr bound to tyvar"++-- | Make a global function for a name-term tuple+mkFunction :: (Functor m, Monad m)+           => TmName -- ^ Name of the function+           -> Term -- ^ Term bound to the function+           -> RewriteMonad m (TmName,Type) -- ^ Name with a proper unique and the type of the function+mkFunction bndr body = do+  bodyTy <- termType body+  bodyId <- cloneVar bndr+  addGlobalBind bodyId bodyTy body+  return (bodyId,bodyTy)++-- | Add a function to the set of global binders+addGlobalBind :: (Functor m, Monad m)+              => TmName+              -> Type+              -> Term+              -> RewriteMonad m ()+addGlobalBind vId ty body = bindings %= HashMap.insert vId (ty,body)++-- | Create a new name out of the given name, but with another unique+cloneVar :: (Functor m, Monad m)+         => TmName+         -> RewriteMonad m TmName+cloneVar name = fmap (makeName (name2String name) . toInteger) getUniqueM+++-- | Test whether a term is a variable reference to a local binder+isLocalVar :: (Functor m, Monad m)+           => Term+           -> RewriteMonad m Bool+isLocalVar (Var _ name)+  = fmap (not . HashMap.member name)+  $ Lens.use bindings+isLocalVar _ = return False++-- | Determine if a term cannot be represented in hardware+isUntranslatable :: (Functor m, Monad m)+                 => Term+                 -> RewriteMonad m Bool+isUntranslatable tm = not <$> (representableType <$> Lens.use typeTranslator <*> termType tm)++-- | Is the Context a Lambda/Term-abstraction context?+isLambdaBodyCtx :: CoreContext+                -> Bool+isLambdaBodyCtx (LamBody _) = True+isLambdaBodyCtx _           = False++-- | Make a binder that should not be referenced+mkWildValBinder :: (Functor m, Monad m, MonadUnique m)+                => Type+                -> m Id+mkWildValBinder = fmap fst . mkInternalVar "wild"++-- | Make a case-decomposition that extracts a field out of a (Sum-of-)Product type+mkSelectorCase :: (Functor m, Monad m, MonadUnique m, Fresh m)+               => String -- ^ Name of the caller of this function+               -> [CoreContext] -- ^ Transformation Context in which this function is called+               -> Term -- ^ Subject of the case-composition+               -> Int -- n'th DataCon+               -> Int -- n'th field+               -> m Term+mkSelectorCase caller ctx scrut dcI fieldI = do+  scrutTy <- termType scrut+  let cantCreate loc info = error $ loc ++ "Can't create selector " ++ show (caller,dcI,fieldI) ++ " for: (" ++ showDoc scrut ++ " :: " ++ showDoc scrutTy ++ ")\nAdditional info: " ++ info+  case transparentTy scrutTy of+    (tyView -> TyConApp tc args) ->+      case tyConDataCons tc of+        [] -> cantCreate $(curLoc) ("TyCon has no DataCons: " ++ show tc ++ " " ++ showDoc tc)+        dcs | dcI > length dcs -> cantCreate $(curLoc) "DC index exceeds max"+            | otherwise -> do+          let dc = indexNote ($(curLoc) ++ "No DC with tag: " ++ show (dcI-1)) dcs (dcI-1)+          let fieldTys = dataConInstArgTys dc args+          if fieldI >= length fieldTys+            then cantCreate $(curLoc) "Field index exceed max"+            else do+              wildBndrs <- mapM mkWildValBinder fieldTys+              selBndr <- mkInternalVar "sel" (indexNote ($(curLoc) ++ "No DC field#: " ++ show fieldI) fieldTys fieldI)+              let bndrs  = take fieldI wildBndrs ++ [fst selBndr] ++ drop (fieldI+1) wildBndrs+              let pat    = DataPat (embed dc) (rebind [] bndrs)+              let retVal = Case scrut (indexNote ($(curLoc) ++ "No DC field#: " ++ show fieldI) fieldTys fieldI) [ bind pat (snd selBndr) ]+              return retVal+    _ -> cantCreate $(curLoc) "Type of subject is not a datatype"++-- | Specialise an application on its argument+specialise :: (Functor m, State.MonadState s m)+           => Lens' s (Map.Map (TmName, Int, Either Term Type) (TmName,Type))+           -> Rewrite m+specialise specMapLbl ctx e@(TyApp e1 ty) = specialise' specMapLbl ctx e (collectArgs e1) (Right ty)+specialise specMapLbl ctx e@(App   e1 e2) = specialise' specMapLbl ctx e (collectArgs e1) (Left  e2)+specialise _          _   e               = return e++-- | Specialise an application on its argument+specialise' :: (Functor m, State.MonadState s m)+            => Lens' s (Map.Map (TmName, Int, Either Term Type) (TmName,Type)) -- ^ Lens into previous specialisations+            -> [CoreContext] -- Transformation context+            -> Term -- ^ Original term+            -> (Term, [Either Term Type]) -- ^ Function part of the term, split into root and applied arguments+            -> Either Term Type -- ^ Argument to specialize on+            -> R m Term+specialise' specMapLbl ctx e (Var _ f, args) specArg = R $ do+  lvl <- Lens.view dbgLevel+  -- Create binders and variable references for free variables in 'specArg'+  (specBndrs,specVars) <- specArgBndrsAndVars ctx specArg+  let argLen = length args+  -- Determine if 'f' has already been specialized on 'specArg'+  specM <- liftR $ fmap (Map.lookup (f,argLen,specArg))+                 $ Lens.use specMapLbl+  case specM of+    -- Use previously specialized function+    Just (fname,fty) ->+      traceIf (lvl >= DebugApplied) ("Using previous specialization: " ++ showDoc fname) $+        changed $ mkApps (Var fty fname) (args ++ specVars)+    -- Create new specialized function+    Nothing -> do+      bodyMaybe <- fmap (HashMap.lookup f) $ Lens.use bindings+      case bodyMaybe of+        Just (_,bodyTm) -> do+          -- Make new binders for existing arguments+          (boundArgs,argVars) <- fmap (unzip . map (either (Left *** Left) (Right *** Right))) $+                                 mapM (mkBinderFor "pTS") args+          -- Create specialized functions+          let newBody = mkAbstraction (mkApps bodyTm (argVars ++ [specArg])) (boundArgs ++ specBndrs)+          newf <- mkFunction f newBody+          -- Remember specialization+          liftR $ specMapLbl %= Map.insert (f,argLen,specArg) newf+          -- use specialized function+          let newExpr = mkApps ((uncurry . flip) Var newf) (args ++ specVars)+          changed newExpr+        Nothing -> return e++specialise' _ ctx _ (appE,args) (Left specArg) = R $ do+  -- Create binders and variable references for free variables in 'specArg'+  (specBndrs,specVars) <- specArgBndrsAndVars ctx (Left specArg)+  -- Create specialized function+  let newBody = mkAbstraction specArg specBndrs+  newf <- mkFunction (string2Name "specF") newBody+  -- Create specialized argument+  let newArg  = Left $ mkApps ((uncurry . flip) Var newf) specVars+  -- Use specialized argument+  let newExpr = mkApps appE (args ++ [newArg])+  changed newExpr++specialise' _ _ e _ _ = return e++-- | Create binders and variable references for free variables in 'specArg'+specArgBndrsAndVars :: (Functor m, Monad m)+                    => [CoreContext]+                    -> 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+  (gamma,delta) <- mkEnv ctx+  let (specTyBndrs,specTyVars) = unzip+                 $ map (\tv -> let ki = delta HashMap.! tv+                               in  (Right $ TyVar tv (embed ki), Right $ VarTy ki tv)) specFTVs+      (specTmBndrs,specTmVars) = unzip+                 $ map (\tm -> let ty = gamma HashMap.! tm+                               in  (Left $ Id tm (embed ty), Left $ Var ty tm)) specFVs+  return (specTyBndrs ++ specTmBndrs,specTyVars ++ specTmVars)
+ src/CLaSH/Util.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE Rank2Types           #-}+{-# LANGUAGE TupleSections        #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Assortment of utility function used in the CLaSH library+module CLaSH.Util+  ( module CLaSH.Util+  , module X+  , makeLenses+  )+where++import Control.Applicative            as X (Applicative,(<$>),(<*>),pure)+import Control.Arrow                  as X ((***),first,second)+import Control.Monad                  as X ((<=<),(>=>))+import Control.Monad.State            (MonadState,State,StateT,runState)+import qualified Control.Monad.State  as State+import Control.Monad.Trans.Class      (MonadTrans,lift)+import Data.Function                  as X (on)+import Data.Hashable                  (Hashable(..),hash)+import Data.HashMap.Lazy              (HashMap)+import qualified Data.HashMap.Lazy    as HashMapL+import qualified Data.HashMap.Strict  as HashMapS+import Data.Maybe                     (fromMaybe)+import Control.Lens+import Debug.Trace                    (trace)+import qualified Language.Haskell.TH  as TH+import Unbound.LocallyNameless        (Embed(..))+import Unbound.LocallyNameless.Name   (Name(..))++-- | A class that can generate unique numbers+class MonadUnique m where+  -- | Get a new unique+  getUniqueM :: m Int++instance Monad m => MonadUnique (StateT Int m) where+  getUniqueM = do+    supply <- State.get+    State.modify (+1)+    return supply++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)++instance (Ord a) => Ord (Embed a) where+  compare (Embed a) (Embed b) = compare a b++-- | Create a TH expression that returns the a formatted string containing the+-- name of the module 'curLoc' is spliced into, and the line where it was spliced.+curLoc :: TH.Q TH.Exp+curLoc = do+  (TH.Loc _ _ modName (startPosL,_) _) <- TH.location+  TH.litE (TH.StringL $ modName ++ "(" ++ show startPosL ++ "): ")++-- | Cache the result of a monadic action+makeCached :: (MonadState s m, Hashable k, Eq k)+           => k -- ^ The key the action is associated with+           -> Lens' s (HashMap k v) -- ^ The Lens to the HashMap that is the cache+           -> m v -- ^ The action to cache+           -> m v+makeCached key l create = do+  cache <- use l+  case HashMapL.lookup key cache of+    Just value -> return value+    Nothing -> do+      value <- create+      l %= HashMapL.insert key value+      return value++-- | Cache the result of a monadic action in a State 3 transformer layers down+makeCachedT3 :: ( MonadTrans t2, MonadTrans t1, MonadTrans t+                , Eq k, Hashable k+                , MonadState s m+                , Monad (t2 m), Monad (t1 (t2 m)), Monad (t (t1 (t2 m))))+             => k -- ^ The key the action is associated with+             -> Lens' s (HashMap k v) -- ^ The Lens to the HashMap that is the cache+             -> (t (t1 (t2 m))) v -- ^ The action to cache+             -> (t (t1 (t2 m))) v+makeCachedT3 key l create = do+  cache <- (lift . lift . lift) $ use l+  case HashMapL.lookup key cache of+    Just value -> return value+    Nothing -> do+      value <- create+      (lift . lift . lift) $ l %= HashMapL.insert key value+      return value++-- | Spine-strict cache variant of 'mkCachedT3'+makeCachedT3' :: ( MonadTrans t2, MonadTrans t1, MonadTrans t+                 , Eq k, Hashable k+                 , MonadState s m+                 , Monad (t2 m), Monad (t1 (t2 m)), Monad (t (t1 (t2 m))))+              => k+              -> Lens' s (HashMap k v)+              -> (t (t1 (t2 m))) v+              -> (t (t1 (t2 m))) v+makeCachedT3' key l create = do+  cache <- (lift . lift . lift) $ use l+  case HashMapS.lookup key cache of+    Just value -> return value+    Nothing -> do+      value <- create+      (lift . lift . lift) $ l %= HashMapS.insert key value+      return value++-- | Run a State-action using the State that is stored in a higher-layer Monad+liftState :: (MonadState s m)+          => Lens' s s' -- ^ Lens to the State in the higher-layer monad+          -> State s' a -- ^ The State-action to perform+          -> m a+liftState l m = do+  s <- use l+  let (a,s') = runState m s+  l .= s'+  return a++-- | Functorial version of 'Control.Arrow.first'+firstM :: Functor f+       => (a -> f c)+       -> (a, b)+       -> f (c, b)+firstM f (x,y) = (,y) <$> f x++-- | Functorial version of 'Control.Arrow.second'+secondM :: Functor f+        => (b -> f c)+        -> (a, b)+        -> f (a, c)+secondM f (x,y) = (x,) <$> f y++-- | Performs trace when first argument evaluates to 'True'+traceIf :: Bool -> String -> a -> a+traceIf True  msg = trace msg+traceIf False _   = id++-- | Monadic version of 'Data.List.partition'+partitionM :: Monad m+           => (a -> m Bool)+           -> [a]+           -> m ([a], [a])+partitionM _ []     = return ([], [])+partitionM p (x:xs) = do+  test      <- p x+  (ys, ys') <- partitionM p xs+  return $ if test then (x:ys, ys') else (ys, x:ys')++-- | Monadic version of 'Data.List.mapAccumL'+mapAccumLM :: (Monad m)+           => (acc -> x -> m (acc,y))+           -> acc+           -> [x]+           -> m (acc,[y])+mapAccumLM _ acc [] = return (acc,[])+mapAccumLM f acc (x:xs) = do+  (acc',y) <- f acc x+  (acc'',ys) <- mapAccumLM f acc' xs+  return (acc'',y:ys)++-- | Composition of a unary function with a binary function+dot :: (c -> d) -> (a -> b -> c) -> a -> b -> d+dot = (.) . (.)++-- | if-then-else as a function on an argument+ifThenElse :: (a -> Bool)+           -> (a -> b)+           -> (a -> b)+           -> a+           -> b+ifThenElse t f g a = if t a then f a else g a++infixr 5 <:>+-- | Applicative version of 'GHC.Types.(:)'+(<:>) :: Applicative f+      => f a+      -> f [a]+      -> f [a]+x <:> xs = (:) <$> x <*> xs++-- | Safe indexing, returns a 'Nothing' if the index does not exist+indexMaybe :: [a]+           -> Int+           -> Maybe a+indexMaybe [] _     = Nothing+indexMaybe (x:_)  0 = Just x+indexMaybe (_:xs) n = indexMaybe xs (n-1)++-- | Unsafe indexing, return a custom error message when indexing fails+indexNote :: String+          -> [a]+          -> Int+          -> a+indexNote note = fromMaybe (error note) `dot` indexMaybe++-- | Split the second list at the length of the first list+splitAtList :: [b] -> [a] -> ([a], [a])+splitAtList [] xs         = ([], xs)+splitAtList _ xs@[]       = (xs, xs)+splitAtList (_:xs) (y:ys) = (y:ys', ys'')+    where+      (ys', ys'') = splitAtList xs ys