diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +http://christiaanb.github.io/clash2/ diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/clash-lib.cabal b/clash-lib.cabal new file mode 100644 --- /dev/null +++ b/clash-lib.cabal @@ -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: + . + * + . + * +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 +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 diff --git a/src/CLaSH/Core/DataCon.hs b/src/CLaSH/Core/DataCon.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Core/DataCon.hs @@ -0,0 +1,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 diff --git a/src/CLaSH/Core/DataCon.hs-boot b/src/CLaSH/Core/DataCon.hs-boot new file mode 100644 --- /dev/null +++ b/src/CLaSH/Core/DataCon.hs-boot @@ -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 diff --git a/src/CLaSH/Core/FreeVars.hs b/src/CLaSH/Core/FreeVars.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Core/FreeVars.hs @@ -0,0 +1,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 diff --git a/src/CLaSH/Core/Literal.hs b/src/CLaSH/Core/Literal.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Core/Literal.hs @@ -0,0 +1,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 diff --git a/src/CLaSH/Core/Pretty.hs b/src/CLaSH/Core/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Core/Pretty.hs @@ -0,0 +1,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` "!#$%&*+./<=>?@\\^|~-" diff --git a/src/CLaSH/Core/Subst.hs b/src/CLaSH/Core/Subst.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Core/Subst.hs @@ -0,0 +1,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 diff --git a/src/CLaSH/Core/Term.hs b/src/CLaSH/Core/Term.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Core/Term.hs @@ -0,0 +1,98 @@ +{-# 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 diff --git a/src/CLaSH/Core/Term.hs-boot b/src/CLaSH/Core/Term.hs-boot new file mode 100644 --- /dev/null +++ b/src/CLaSH/Core/Term.hs-boot @@ -0,0 +1,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 diff --git a/src/CLaSH/Core/TyCon.hs b/src/CLaSH/Core/TyCon.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Core/TyCon.hs @@ -0,0 +1,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 _ = [] diff --git a/src/CLaSH/Core/TyCon.hs-boot b/src/CLaSH/Core/TyCon.hs-boot new file mode 100644 --- /dev/null +++ b/src/CLaSH/Core/TyCon.hs-boot @@ -0,0 +1,3 @@ +module CLaSH.Core.TyCon where + +data TyCon diff --git a/src/CLaSH/Core/Type.hs b/src/CLaSH/Core/Type.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Core/Type.hs @@ -0,0 +1,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 diff --git a/src/CLaSH/Core/Type.hs-boot b/src/CLaSH/Core/Type.hs-boot new file mode 100644 --- /dev/null +++ b/src/CLaSH/Core/Type.hs-boot @@ -0,0 +1,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 diff --git a/src/CLaSH/Core/TysPrim.hs b/src/CLaSH/Core/TysPrim.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Core/TysPrim.hs @@ -0,0 +1,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) diff --git a/src/CLaSH/Core/Util.hs b/src/CLaSH/Core/Util.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Core/Util.hs @@ -0,0 +1,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 diff --git a/src/CLaSH/Core/Var.hs b/src/CLaSH/Core/Var.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Core/Var.hs @@ -0,0 +1,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 diff --git a/src/CLaSH/Driver.hs b/src/CLaSH/Driver.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Driver.hs @@ -0,0 +1,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 diff --git a/src/CLaSH/Driver/TestbenchGen.hs b/src/CLaSH/Driver/TestbenchGen.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Driver/TestbenchGen.hs @@ -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') diff --git a/src/CLaSH/Driver/Types.hs b/src/CLaSH/Driver/Types.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Driver/Types.hs @@ -0,0 +1,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) diff --git a/src/CLaSH/Netlist.hs b/src/CLaSH/Netlist.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Netlist.hs @@ -0,0 +1,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 diff --git a/src/CLaSH/Netlist.hs-boot b/src/CLaSH/Netlist.hs-boot new file mode 100644 --- /dev/null +++ b/src/CLaSH/Netlist.hs-boot @@ -0,0 +1,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]) diff --git a/src/CLaSH/Netlist/BlackBox.hs b/src/CLaSH/Netlist/BlackBox.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Netlist/BlackBox.hs @@ -0,0 +1,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' diff --git a/src/CLaSH/Netlist/BlackBox/Parser.hs b/src/CLaSH/Netlist/BlackBox/Parser.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Netlist/BlackBox/Parser.hs @@ -0,0 +1,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 diff --git a/src/CLaSH/Netlist/BlackBox/Types.hs b/src/CLaSH/Netlist/BlackBox/Types.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Netlist/BlackBox/Types.hs @@ -0,0 +1,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) diff --git a/src/CLaSH/Netlist/BlackBox/Util.hs b/src/CLaSH/Netlist/BlackBox/Util.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Netlist/BlackBox/Util.hs @@ -0,0 +1,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" diff --git a/src/CLaSH/Netlist/Id.hs b/src/CLaSH/Netlist/Id.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Netlist/Id.hs @@ -0,0 +1,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 == '_'] diff --git a/src/CLaSH/Netlist/Types.hs b/src/CLaSH/Netlist/Types.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Netlist/Types.hs @@ -0,0 +1,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 diff --git a/src/CLaSH/Netlist/Util.hs b/src/CLaSH/Netlist/Util.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Netlist/Util.hs @@ -0,0 +1,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 diff --git a/src/CLaSH/Netlist/VHDL.hs b/src/CLaSH/Netlist/VHDL.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Netlist/VHDL.hs @@ -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 diff --git a/src/CLaSH/Normalize.hs b/src/CLaSH/Normalize.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Normalize.hs @@ -0,0 +1,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 diff --git a/src/CLaSH/Normalize/Strategy.hs b/src/CLaSH/Normalize/Strategy.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Normalize/Strategy.hs @@ -0,0 +1,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) diff --git a/src/CLaSH/Normalize/Transformations.hs b/src/CLaSH/Normalize/Transformations.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Normalize/Transformations.hs @@ -0,0 +1,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 diff --git a/src/CLaSH/Normalize/Types.hs b/src/CLaSH/Normalize/Types.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Normalize/Types.hs @@ -0,0 +1,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 diff --git a/src/CLaSH/Normalize/Util.hs b/src/CLaSH/Normalize/Util.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Normalize/Util.hs @@ -0,0 +1,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)) diff --git a/src/CLaSH/Primitives/Types.hs b/src/CLaSH/Primitives/Types.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Primitives/Types.hs @@ -0,0 +1,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" diff --git a/src/CLaSH/Primitives/Util.hs b/src/CLaSH/Primitives/Util.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Primitives/Util.hs @@ -0,0 +1,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 diff --git a/src/CLaSH/Rewrite/Combinators.hs b/src/CLaSH/Rewrite/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Rewrite/Combinators.hs @@ -0,0 +1,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 diff --git a/src/CLaSH/Rewrite/Types.hs b/src/CLaSH/Rewrite/Types.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Rewrite/Types.hs @@ -0,0 +1,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) diff --git a/src/CLaSH/Rewrite/Util.hs b/src/CLaSH/Rewrite/Util.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Rewrite/Util.hs @@ -0,0 +1,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) diff --git a/src/CLaSH/Util.hs b/src/CLaSH/Util.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Util.hs @@ -0,0 +1,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